Reorganize database and authentication modules

servant-template.cabal

@@ -27,6 +27,8 @@ library
       App.Services
       Application
       AppM
+      Authentication
+      Authentication.Error
       Boot
       CLIOptions
       DB.Queries
@@ -38,10 +40,9 @@ library
       DB.Repository.User.InMemory
       DB.Repository.User.Postgres
       DB.Schema
+      DB.Schema.Content
       DB.Schema.Tag
-      DB.Serializer
-      Impl.Authentication.Authenticator
-      Impl.Authentication.Authenticator.Error
+      DB.Schema.User
       Infrastructure.Authentication.PasswordManager
       Infrastructure.Authentication.PasswordManager.Error
       Infrastructure.Authentication.Token

spec/TestServices.hs

@@ -1,11 +1,11 @@
 module TestServices where
 
-import App.Services (Services (..), connectedAuthenticateUser, connectedContentRepository, connectedUserRepository, encryptedPasswordManager)
 import App.Env
-import GHC.Conc (newTVarIO)
-import Impl.Authentication.Authenticator qualified as Auth
+import App.Services (Services (..), connectedAuthenticateUser, connectedContentRepository, connectedUserRepository, encryptedPasswordManager)
+import Authentication qualified as Auth
 import DB.Repository.Content qualified as Repo.Content
 import DB.Repository.User qualified as Repo.User
+import GHC.Conc (newTVarIO)
 import Infrastructure.Authentication.PasswordManager (bcryptPasswordManager)
 import Infrastructure.Logger as Logger
 import Infrastructure.SystemTime as SystemTime

src/App/Error.hs

@@ -1,15 +1,15 @@
 module App.Error where
 
+import Authentication.Error (Error (..))
+import Authentication.Error qualified as Auth
 import Control.Monad.Except (throwError)
 import Control.Monad.IO.Class
-import Hasql.Session (QueryError)
-import Impl.Authentication.Authenticator.Error (Error (..))
-import Impl.Authentication.Authenticator.Error qualified as Auth
+import DB.Queries (WrongNumberOfResults (..))
 import DB.Repository.User.Error (UserRepositoryError (..))
+import Hasql.Session (QueryError)
 import Infrastructure.Authentication.PasswordManager.Error (PasswordManagerError (..))
 import Infrastructure.Logger (logError, logWarning)
 import Infrastructure.Logger qualified as Logger
-import DB.Queries (WrongNumberOfResults (..))
 import Servant (Handler, err401, err403, err500)
 import Prelude hiding (log)
 

src/App/Services.hs

@@ -10,7 +10,7 @@ where
 
 import App.Env
 import AppM
-import Impl.Authentication.Authenticator qualified as Auth
+import Authentication qualified as Auth
 import DB.Repository.Content as Repo.Content
 import DB.Repository.User qualified as Repo.User
 import Infrastructure.Authentication.PasswordManager (PasswordManager, bcryptPasswordManager)

src/Impl/Authentication/Authenticator.hs → src/Authentication.hs

@@ -1,10 +1,10 @@
-module Impl.Authentication.Authenticator (authenticator) where
+module Authentication (authenticator) where
 
 import App.Error (AppError (..))
 import AppM
+import Authentication.Error (Error (..))
 import Control.Monad.Except (catchError)
 import Control.Monad.Trans.Except (throwE)
-import Impl.Authentication.Authenticator.Error (Error (..))
 import Infrastructure.Authentication.PasswordManager (PasswordManager (validatePassword))
 import Tagger.Authentication.Authenticator (Authenticator (..))
 import Tagger.Authentication.Credentials (Credentials (..))

src/Impl/Authentication/Authenticator/Error.hs → src/Authentication/Error.hs

@@ -1,7 +1,7 @@
-module Impl.Authentication.Authenticator.Error (Error (..)) where
+module Authentication.Error (Error (..)) where
 
-import DB.Repository.User.Error (UserRepositoryError)
 import DB.Queries (WrongNumberOfResults)
+import DB.Repository.User.Error (UserRepositoryError)
 
 -- |
 -- How 'authenticateUser' can actually fail

src/DB/Queries.hs

@@ -1,12 +1,17 @@
 module DB.Queries where
 
+import DB.Schema (ContentsTags (..), contentsTagsSchema)
+import DB.Schema.Content (litContent)
+import DB.Schema.Content qualified as Content
+import DB.Schema.Tag (litTag)
+import DB.Schema.Tag qualified as Tag
+import DB.Schema.User qualified as User
 import Data.List qualified as List (filter)
 import Data.Text (Text)
 import Hasql.Session (Session, statement)
 import Hasql.Statement (Statement)
 import Hasql.Transaction qualified as Transaction (statement)
 import Hasql.Transaction.Sessions (IsolationLevel (Serializable), Mode (Write), transaction)
-import DB.Schema (Content (..), ContentsTags (..), Tag (..), User (userName), contentSchema, contentsTagsSchema, litContent, litTag, tagSchema, userId, userSchema)
 import Rel8 (Expr, Insert (..), Name, OnConflict (..), Query, Rel8able, Result, TableSchema, each, filter, in_, insert, lit, many, select, values, where_, (==.))
 import Tagger.Id (Id)
 import Tagger.User qualified as Domain (User)
@@ -16,43 +21,43 @@ import Prelude hiding (filter)
 
 -- |
 -- Selects the 'ContentsTags' for a given 'Content'
-contentsTagsForContent :: Content Expr -> Query (ContentsTags Expr)
+contentsTagsForContent :: Content.Row Expr -> Query (ContentsTags Expr)
 contentsTagsForContent content =
   each contentsTagsSchema
     >>= filter
       ( \contentTag' ->
-          ctContentId contentTag' ==. contentId content
+          ctContentId contentTag' ==. content.contentId
       )
 
 -- |
 -- Selects the 'Tags' associated with a given 'Content'
-tagsForContent :: Content Expr -> Query (Tag Expr)
+tagsForContent :: Content.Row Expr -> Query (Tag.Row Expr)
 tagsForContent content = do
-  tag <- each tagSchema
+  tag <- each Tag.relation
   contentTag' <- contentsTagsForContent content
-  where_ $ tagId tag ==. ctTagId contentTag'
+  where_ $ tag.tagId ==. ctTagId contentTag'
   return tag
 
 -- |
 -- Selects the 'User' who ownes a 'Content'
-userForContent :: Content Expr -> Query (User Expr)
+userForContent :: Content.Row Expr -> Query (User.Row Expr)
 userForContent content =
-  each userSchema
+  each User.relation
     >>= filter
       ( \user ->
-          userId user ==. contentUserId content
+          user.userId ==. content.contentUserId
       )
 
 -- |
 -- Given a 'Domain.User' 'Id', retrieves all the contents for that specific user
-selectUserContents :: Id Domain.User -> Session [(Content Result, [Tag Result], User Result)]
+selectUserContents :: Id Domain.User -> Session [(Content.Row Result, [Tag.Row Result], User.Row Result)]
 selectUserContents userId' = statement () . select $ do
   -- Select all content for the given user
   content <-
-    each contentSchema
+    each Content.relation
       >>= filter
         ( \content ->
-            contentUserId content ==. lit userId'
+            content.contentUserId ==. lit userId'
         )
   -- Select tags for each content
   tags <- many $ tagsForContent content
@@ -64,8 +69,8 @@ selectUserContents userId' = statement () . select $ do
 
 -- |
 -- Selects all tags present in the database among the requested ones
-selectTags :: [Tag Result] -> Statement () [Tag Result]
-selectTags tagNames = select $ each tagSchema >>= filter ((`in_` (tagName . litTag <$> tagNames)) . tagName)
+selectTags :: [Tag.Row Result] -> Statement () [Tag.Row Result]
+selectTags tagNames = select $ each Tag.relation >>= filter ((`in_` ((.tagName) . litTag <$> tagNames)) . (.tagName))
 
 -- ADD CONTENT
 
@@ -83,17 +88,17 @@ add schema rows' =
 
 -- |
 -- Creates a 'ContentTag' given a 'Content' and a 'Tag'
-contentTag :: Content f -> Tag f -> ContentsTags f
+contentTag :: Content.Row f -> Tag.Row f -> ContentsTags f
 contentTag content tag =
   ContentsTags
-    { ctContentId = contentId content,
-      ctTagId = tagId tag
+    { ctContentId = content.contentId,
+      ctTagId = tag.tagId
     }
 
 -- |
 -- Removes the 'alreadyPresentTags' from 'allTags'
-removeAlreadyPresentTags :: [Tag Result] -> [Tag Result] -> [Tag Result]
-removeAlreadyPresentTags allTags alreadyPresentTags = List.filter (\tag -> tagName tag `notElem` (tagName <$> alreadyPresentTags)) allTags
+removeAlreadyPresentTags :: [Tag.Row Result] -> [Tag.Row Result] -> [Tag.Row Result]
+removeAlreadyPresentTags allTags alreadyPresentTags = List.filter (\tag -> tag.tagName `notElem` ((.tagName) <$> alreadyPresentTags)) allTags
 
 -- |
 -- Given a 'Content' and a list of 'Tag's, it inserts the new content into the database associating to it the provided tags.
@@ -104,12 +109,12 @@ removeAlreadyPresentTags allTags alreadyPresentTags = List.filter (\tag -> tagNa
 -- * inserts the new 'Tag's
 -- * inserts the 'Content'
 -- * inserts the 'ContentsTags' to link the 'Content' with its 'Tags'
-addContentWithTags :: Content Result -> [Tag Result] -> Session ()
+addContentWithTags :: Content.Row Result -> [Tag.Row Result] -> Session ()
 addContentWithTags content tags = transaction Serializable Write $ do
   alreadyPresentTags <- Transaction.statement () (selectTags tags)
   let newTags = litTag <$> removeAlreadyPresentTags tags alreadyPresentTags
-  Transaction.statement () $ add tagSchema newTags
-  Transaction.statement () $ add contentSchema [litContent content]
+  Transaction.statement () $ add Tag.relation newTags
+  Transaction.statement () $ add Content.relation [litContent content]
   Transaction.statement () $ add contentsTagsSchema (contentTag (litContent content) <$> (litTag <$> alreadyPresentTags) <> newTags)
 
 -- SELECT USER BY USERNAME
@@ -132,16 +137,16 @@ justOne = \case
 -- |
 -- Retrieve from the database a user with the provided name.
 -- If in the database we find none or more the one, it returns the appropriate error message
-selectUserByName :: Text -> Session (Either WrongNumberOfResults (User Result))
+selectUserByName :: Text -> Session (Either WrongNumberOfResults (User.Row Result))
 selectUserByName name = statement () query
   where
     query = fmap justOne . select $ do
-      users <- each userSchema
-      filter (\user -> userName user ==. lit name) users
+      users <- each User.relation
+      filter (\user -> user.userName ==. lit name) users
 
 -- ADD USER
 
 -- |
 -- Add a new 'User' in the database
-addUser :: User Expr -> Session ()
-addUser = statement () . add userSchema . pure
+addUser :: User.Row Expr -> Session ()
+addUser = statement () . add User.relation . pure

src/DB/Repository/Content/Postgres.hs

@@ -3,10 +3,10 @@ module DB.Repository.Content.Postgres (repository) where
 import AppM (AppM, AppM')
 import Control.Monad (forM)
 import Control.Monad.IO.Class (liftIO)
+import DB.Queries qualified as DB (addContentWithTags, selectUserContents)
+import DB.Schema.Content (serializeContent, unserializeContent)
 import Data.Tuple.Extra (uncurry3)
 import Data.UUID.V4 (nextRandom)
-import DB.Queries qualified as DB (addContentWithTags, selectUserContents)
-import DB.Serializer (serializeContent, unserializeContent)
 import Tagger.Content (Content, hasAllTags)
 import Tagger.Database (runQuery)
 import Tagger.Id (Id (Id))

src/DB/Repository/User/Postgres.hs

@@ -5,14 +5,13 @@ import AppM (AppM, AppM')
 import Control.Monad.Except (catchError)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Except (throwE)
+import DB.Queries qualified as Query
+import DB.Repository.User.Error (UserRepositoryError (..))
+import DB.Schema.User (litUser, serializeUser, unserializeUser, userId)
 import Data.ByteString (isInfixOf)
 import Data.Text (Text)
 import Data.UUID.V4 (nextRandom)
 import Hasql.Session (CommandError (ResultError), QueryError (QueryError), ResultError (ServerError), Session)
-import DB.Repository.User.Error (UserRepositoryError (..))
-import DB.Queries qualified as Query
-import DB.Schema (litUser, userId)
-import DB.Serializer (serializeUser, unserializeUser)
 import Tagger.Database (runQuery)
 import Tagger.EncryptedPassword (EncryptedPassword)
 import Tagger.Id (Id (Id))

src/DB/Schema.hs

@@ -1,46 +1,10 @@
 module DB.Schema where
 
-import Data.Text (Text)
 import GHC.Generics (Generic)
-import Rel8 (Column, Expr, Name, Rel8able, Result, TableSchema (..), lit)
+import Rel8 (Column, Name, Rel8able, TableSchema (..))
 import Tagger.Content qualified as Domain (Content)
-import Tagger.EncryptedPassword (EncryptedPassword)
 import Tagger.Id (Id)
 import Tagger.Tag qualified as Domain (Tag)
-import Tagger.User qualified as Domain (User)
-
-
--- CONTENT
-
--- |
--- The database representation of a 'Content'
-data Content f = Content
-  { contentId :: Column f (Id (Domain.Content Domain.Tag)),
-    contentContent :: Column f Text,
-    contentUserId :: Column f (Id Domain.User)
-  }
-  deriving stock (Generic)
-  deriving anyclass (Rel8able)
-
--- |
--- A description of the schema of the 'Content' table
-contentSchema :: TableSchema (Content Name)
-contentSchema =
-  TableSchema
-    { name = "contents",
-      schema = Nothing,
-      columns =
-        Content
-          { contentId = "id",
-            contentContent = "content",
-            contentUserId = "user_id"
-          }
-    }
-
--- |
--- Allows to lift a 'Content' with no context into the 'Expr' context
-litContent :: Content Result -> Content Expr
-litContent (Content id' content' userId') = Content (lit id') (lit content') (lit userId')
 
 -- CONTENTS_TAGS
 
@@ -66,35 +30,3 @@ contentsTagsSchema =
             ctTagId = "tag_id"
           }
     }
-
--- USERS
-
--- |
--- The database representation of a 'User'
-data User f = User
-  { userId :: Column f (Id Domain.User),
-    userName :: Column f Text,
-    userPassword :: Column f EncryptedPassword
-  }
-  deriving stock (Generic)
-  deriving anyclass (Rel8able)
-
--- |
--- A description of the schema of the 'User' table
-userSchema :: TableSchema (User Name)
-userSchema =
-  TableSchema
-    { name = "users",
-      schema = Nothing,
-      columns =
-        User
-          { userId = "id",
-            userName = "name",
-            userPassword = "password"
-          }
-    }
-
--- |
--- Allows to lift a 'User' with no context into the 'Expr' context
-litUser :: User Result -> User Expr
-litUser (User id' name' password) = User (lit id') (lit name') (lit password)