Parameterize Services + refactor hoisting functions

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
       }

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 =

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

src/AppM.hs

@@ -1,11 +1,14 @@
-module AppM (AppM, AppM', runComponent) where
+module AppM (AppM, AppM', runApp, runWithContext) where
 
 import App.Env (Env (..), Handles (..))
 import App.Error
 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

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 =

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

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

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
+    }

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
+    }

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
+    }