diff --git a/spec/TestServices.hs b/spec/TestServices.hs index 19b203b..d87a62c 100644 --- a/spec/TestServices.hs +++ b/spec/TestServices.hs @@ -1,16 +1,21 @@ module TestServices where import App.Env -import App.Services (Services (..), connectedAuthenticateUser, connectedContentRepository, connectedUserRepository, encryptedPasswordManager) +import App.Services (Services (..)) +import AppM (runApp, runWithContext) 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.Authentication.PasswordManager qualified as PasswordManager import Infrastructure.Logger as Logger import Infrastructure.SystemTime as SystemTime -import Optics import Servant.Auth.Server (defaultJWTSettings, generateKey) +import Servant.Server (Handler) +import Tagger.Authentication.Authenticator qualified as Auth +import Tagger.Repository.Content qualified as Repo.Content +import Tagger.Repository.User qualified as Repo.User mkTestEnv :: IO Env mkTestEnv = do @@ -29,25 +34,25 @@ mkTestEnv = do } } -testServices :: Env -> IO Services +testServices :: Env -> IO (Services Handler) testServices env = do userMap <- newTVarIO mempty contentsMap <- newTVarIO mempty let userRepository = Repo.User.inMemory userMap contentsRepository = Repo.Content.inMemory contentsMap passwordManager = - encryptedPasswordManager - (env & #handles % #logger %~ withContext "PasswordManager") + PasswordManager.hoist + (runWithContext "PasswordManager" env) (bcryptPasswordManager (defaultJWTSettings env.jwkKey)) authenticator = Auth.authenticator userRepository passwordManager authenticateUser = - connectedAuthenticateUser - (env & #handles % #logger %~ withContext "Authenticator") + Auth.hoist + (runWithContext "Authenticator" env) authenticator pure $ Services { passwordManager = passwordManager, - contentRepository = connectedContentRepository env contentsRepository, - userRepository = connectedUserRepository env userRepository, + contentRepository = Repo.Content.hoist (runApp env) contentsRepository, + userRepository = Repo.User.hoist (runApp env) userRepository, authenticateUser } diff --git a/src/API.hs b/src/API.hs index 3b71bb5..adca7a4 100644 --- a/src/API.hs +++ b/src/API.hs @@ -1,10 +1,10 @@ module API (mkAPI, API, ApplicationAPI (..)) where -import App.Services (Services (..)) import API.Authentication qualified as Authentication import API.Docs qualified as Docs import API.Healthcheck qualified as Healthcheck import API.Tagger qualified as Tagger +import App.Services (Services (..)) import GHC.Generics (Generic) import Servant (Handler, err401) import Servant.API (NamedRoutes, type (:>)) @@ -30,7 +30,7 @@ data ApplicationAPI mode = ApplicationAPI -- | -- Setup all the application server, providing the services needed by the various endpoints -mkAPI :: Services -> ApplicationAPI AsServer +mkAPI :: Services Handler -> ApplicationAPI AsServer mkAPI services = ApplicationAPI { tagger = diff --git a/src/App/Services.hs b/src/App/Services.hs index 3dd5e5b..798b0d3 100644 --- a/src/App/Services.hs +++ b/src/App/Services.hs @@ -1,10 +1,6 @@ module App.Services ( Services (..), start, - connectedContentRepository, - connectedUserRepository, - connectedAuthenticateUser, - encryptedPasswordManager, ) where @@ -15,11 +11,8 @@ import DB.Repository.Content as Repo.Content import DB.Repository.User qualified as Repo.User import Infrastructure.Authentication.PasswordManager (PasswordManager, bcryptPasswordManager) import Infrastructure.Authentication.PasswordManager qualified as PasswordManager -import Infrastructure.Logger (withContext) -import Optics import Servant (Handler) import Servant.Auth.Server (defaultJWTSettings) -import Tagger.Authentication.Authenticator (Authenticator) import Tagger.Authentication.Authenticator qualified as Auth import Tagger.Repository.Content (ContentRepository) import Tagger.Repository.Content qualified as ContentRepository @@ -28,56 +21,34 @@ import Tagger.Repository.User qualified as UserRepository -- | -- Collection of services needed by the application to work -data Services = Services - { passwordManager :: PasswordManager Handler, - contentRepository :: ContentRepository Handler, - userRepository :: UserRepository Handler, - authenticateUser :: Auth.Authenticator Handler +data Services m = Services + { passwordManager :: PasswordManager m, + contentRepository :: ContentRepository m, + userRepository :: UserRepository m, + authenticateUser :: Auth.Authenticator m } -start :: Env -> Services +start :: Env -> Services Handler start env = let passwordManager = - encryptedPasswordManager - (env & #handles % #logger %~ withContext "PasswordManager") + PasswordManager.hoist + (runWithContext "PasswordManager" env) (bcryptPasswordManager (defaultJWTSettings env.jwkKey)) - dbUserRepository = Repo.User.postgres - authenticator = Auth.authenticator dbUserRepository passwordManager contentRepository = - connectedContentRepository - (env & #handles % #logger %~ withContext "ContentRepository") + ContentRepository.hoist + (runWithContext "ContentRepository" env) Repo.Content.postgres userRepository = - connectedUserRepository - (env & #handles % #logger %~ withContext "UserRepository") - dbUserRepository - authenticateUser = - connectedAuthenticateUser - (env & #handles % #logger %~ withContext "Authenticator") - authenticator + UserRepository.hoist + (runWithContext "UserRepository" env) + Repo.User.postgres + authenticateUser = do + Auth.hoist + (runWithContext "Authenticator" env) + (Auth.authenticator Repo.User.postgres passwordManager) in Services { passwordManager, contentRepository, userRepository, authenticateUser } - --- | --- Creates a 'PasswordManager' service injecting its dependencies and handling errors -encryptedPasswordManager :: Env -> PasswordManager AppM' -> PasswordManager Handler -encryptedPasswordManager = runComponent PasswordManager.hoist - --- | --- Lifts a 'ContentRepository' fo the 'Handler' monad, handling all errors by logging them and returning a 500 response -connectedContentRepository :: Env -> ContentRepository AppM' -> ContentRepository Handler -connectedContentRepository = runComponent ContentRepository.hoist - --- | --- Lifts a 'UserRepository' fo the 'Handler' monad, handling all errors by logging them and returning a 500 response -connectedUserRepository :: Env -> UserRepository AppM' -> UserRepository Handler -connectedUserRepository = runComponent UserRepository.hoist - --- | --- Creates an 'AuthenticateUser' service injecting its dependencies and handling errors -connectedAuthenticateUser :: Env -> Authenticator AppM' -> Auth.Authenticator Handler -connectedAuthenticateUser = runComponent Auth.hoist diff --git a/src/AppM.hs b/src/AppM.hs index c688701..1189503 100644 --- a/src/AppM.hs +++ b/src/AppM.hs @@ -1,4 +1,4 @@ -module AppM (AppM, AppM', runComponent) where +module AppM (AppM, AppM', runApp, runWithContext) where import App.Env (Env (..), Handles (..)) import App.Error @@ -6,6 +6,9 @@ import Control.Arrow ((>>>)) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import Data.Text (Text) +import Infrastructure.Logger (withContext) +import Optics import Servant (Handler) type AppM a = AppM' a @@ -20,17 +23,6 @@ runApp env computation = where runApp' = runExceptT >>> flip runReaderT env >>> liftIO -runComponent :: ((forall a. AppM a -> Handler a) -> b) -> Env -> b -runComponent hoister env = hoister (runApp env) - --- newtype NewAppM a = NewAppM {runNewAppM :: AppM' a} - --- -- | --- -- Lifts a computation from 'NewAppM' to 'Handler a' using the provided 'handleError' function --- runApp' :: Env -> NewAppM a -> Handler a --- runApp' env (NewAppM computation) = --- (liftIO . runExceptT $ computation) >>= \case --- Right a -> pure a --- Left e -> handleAppError env.handles.logger e --- g :: ((NewAppM a -> Handler a) -> b) -> Env -> b --- g hoister = hoister . runApp +runWithContext :: Text -> Env -> AppM a -> Handler a +runWithContext contextName env = + runApp $ env & #handles % #logger %~ withContext contextName diff --git a/src/Application.hs b/src/Application.hs index 8de266e..eeeac29 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,15 +1,15 @@ module Application (mkApp) where import API -import App.Services import App.Env qualified as App +import App.Services import Data.Proxy (Proxy (..)) import Middleware qualified import Network.Wai (Application) -import Servant (Context (EmptyContext, (:.)), serveWithContext) +import Servant (Context (EmptyContext, (:.)), Handler, serveWithContext) import Servant.Auth.Server (defaultCookieSettings, defaultJWTSettings) -mkApp :: App.Env -> Services -> Application +mkApp :: App.Env -> Services Handler -> Application mkApp env services = let jwtSettings = defaultJWTSettings env.jwkKey app = diff --git a/src/Authentication.hs b/src/Authentication.hs index f9d215c..070e0e2 100644 --- a/src/Authentication.hs +++ b/src/Authentication.hs @@ -12,10 +12,7 @@ import Tagger.Id (Id) import Tagger.Repository.User as UserRepo import Tagger.User (User) -authenticator :: - UserRepository AppM' -> - PasswordManager n -> - Authenticator AppM' +authenticator :: UserRepository AppM' -> PasswordManager n -> Authenticator AppM' authenticator repo pm = Authenticator { authUser = authenticateUser repo pm diff --git a/src/Infrastructure/Authentication/PasswordManager.hs b/src/Infrastructure/Authentication/PasswordManager.hs index 7448e32..28e103e 100644 --- a/src/Infrastructure/Authentication/PasswordManager.hs +++ b/src/Infrastructure/Authentication/PasswordManager.hs @@ -29,8 +29,12 @@ data PasswordManager m = PasswordManager -- | -- Given a natural transformation between a context 'm' and a context 'n', it allows to change the context where 'PasswordManager' is operating hoist :: (forall a. m a -> n a) -> PasswordManager m -> PasswordManager n -hoist f PasswordManager {generatePassword, generateToken, validatePassword} = - PasswordManager (f . generatePassword) (f . generateToken) validatePassword +hoist f pm = + PasswordManager + { generatePassword = f . pm.generatePassword, + generateToken = f . pm.generateToken, + validatePassword = pm.validatePassword + } -- | -- A 'PasswordManager' implementation based on the 'bcrypt' algorithm diff --git a/src/Tagger/Authentication/Authenticator.hs b/src/Tagger/Authentication/Authenticator.hs index 9c12894..5e50ed0 100644 --- a/src/Tagger/Authentication/Authenticator.hs +++ b/src/Tagger/Authentication/Authenticator.hs @@ -12,4 +12,7 @@ newtype Authenticator m = Authenticator {authUser :: Credentials -> m (Id User)} -- | -- Given a natural transformation between a context 'm' and a context 'n', it allows to change the context where 'AuthenticateUser' is operating hoist :: (forall a. m a -> n a) -> Authenticator m -> Authenticator n -hoist f (Authenticator auth) = Authenticator $ f . auth +hoist f auth = + Authenticator + { authUser = f . auth.authUser + } diff --git a/src/Tagger/Repository/Content.hs b/src/Tagger/Repository/Content.hs index 17479a9..8bdf619 100644 --- a/src/Tagger/Repository/Content.hs +++ b/src/Tagger/Repository/Content.hs @@ -19,5 +19,8 @@ data ContentRepository m = ContentRepository -- | -- Given a natural transformation between a context 'm' and a context 'n', it allows to change the context where 'ContentRepository' is operating hoist :: (forall a. m a -> n a) -> ContentRepository m -> ContentRepository n -hoist f ContentRepository {selectUserContentsByTags, addContentWithTags} = - ContentRepository ((f .) . selectUserContentsByTags) ((f .) . addContentWithTags) +hoist f repo = + ContentRepository + { selectUserContentsByTags = \uid tags -> f $ repo.selectUserContentsByTags uid tags, + addContentWithTags = \uid tagContent -> f $ repo.addContentWithTags uid tagContent + } diff --git a/src/Tagger/Repository/User.hs b/src/Tagger/Repository/User.hs index 0e77fec..06c3da5 100644 --- a/src/Tagger/Repository/User.hs +++ b/src/Tagger/Repository/User.hs @@ -6,7 +6,7 @@ import Tagger.Id (Id) import Tagger.User (User) -- | --- A 'UserRespository' represents a collection of 'User's. +-- A 'UserRepository' represents a collection of 'User's. -- It is indexed by a context 'm' which wraps the results. data UserRepository m = UserRepository { -- | Searches the repository for 'User's with the provided name @@ -18,4 +18,8 @@ data UserRepository m = UserRepository -- | -- Given a natural transformation between a context 'm' and a context 'n', it allows to change the context where 'UserRepository' is operating hoist :: (forall a. m a -> n a) -> UserRepository m -> UserRepository n -hoist f UserRepository {findByName, add} = UserRepository (f . findByName) ((f .) . add) +hoist f repo = + UserRepository + { findByName = f . repo.findByName, + add = \name pw -> f $ repo.add name pw + }