.transformers-vs-reader.md

Compare using a stack of transformers vs. the ReaderT pattern for a web service.

See files:

• Transformers.hs
• Reader.hs

Reader.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Main (main) where

import Relude hiding (traceId)

import Control.Exception (throwIO, try)
import Control.Monad.Logger (
  Loc,
  LogLevel,
  LogSource,
  LogStr,
  MonadLogger (..),
  ToLogStr (toLogStr),
 )
import Control.Monad.Logger.Aeson (
  Message ((:#)),
  logDebug,
  logInfo,
  runLoggingT,
  (.=),
 )
import Control.Monad.Logger.Aeson qualified as Logger (defaultOutput)
import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
import Network.HTTP.Client (
  Manager,
  defaultManagerSettings,
  managerConnCount,
  newManager,
 )
import Network.Wai.Handler.Warp qualified as Warp
import Servant (
  NamedRoutes,
  ServerError (..),
  err401,
  err500,
  hoistServer,
  serve,
 )
import Servant qualified (Handler (..))
import Servant.API (
  Capture,
  GenericMode ((:-)),
  Get,
  Header,
  PlainText,
  Post,
  ReqBody,
  (:>),
 )
import Servant.Server.Internal (AsServerT)

-- API
-- ----------------------------------------------------------------------------

type AuthorizationHeader = Text
type TraceParentHeader = Text
type ProjectId = Text
type TicketId = Text
type CreateTicketRequest = Text
type CreateTicketResponse = Text
type GetTicketResponse = Text

type Api =
  "v1"
    :> Header "Authorization" AuthorizationHeader
    :> Header "traceparent" TraceParentHeader
    :> "projects"
    :> Capture "projectId" ProjectId
    :> "tickets"
    :> NamedRoutes TicketApi

data TicketApi mode = TicketApi
  { createTicket
      :: mode
        :- ReqBody '[PlainText] CreateTicketRequest
        :> Post '[PlainText] CreateTicketResponse
  , getTicket
      :: mode
        :- Capture "ticketId" TicketId
        :> Get '[PlainText] GetTicketResponse
  }
  deriving stock (Generic)

-- Fake database
-- ----------------------------------------------------------------------------

data Connection = Connection

createDbPool :: Text -> Int -> IO (Pool Connection)
createDbPool _databaseUrl poolSize = do
  newPool $
    defaultPoolConfig
      create
      destroy
      poolTtl
      poolSize
  where
    create = pure Connection
    destroy = const $ pure ()
    poolTtl = 10

type LogFunc =
  Loc -> LogSource -> LogLevel -> LogStr -> IO ()

data DatabaseEnv = DatabaseEnv
  { dbLogger :: LogFunc
  , connectionPool :: Pool Connection
  }

class HasDatabase env where
  getDatabase :: env -> DatabaseEnv

newtype Database a = Database
  { unDatabase :: ReaderT DatabaseEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader DatabaseEnv
    )

runDatabaseIO :: DatabaseEnv -> Database a -> IO a
runDatabaseIO env action =
  runReaderT (unDatabase action) env

type MonadDatabase env m = (MonadReader env m, HasDatabase env)

runDatabase
  :: (MonadDatabase env m, MonadIO m)
  => Database a
  -> m a
runDatabase action = do
  env <- asks getDatabase
  liftIO $ runDatabaseIO env action

query :: (Show p) => Text -> p -> Database [r]
query q parameters = do
  logger <- asks dbLogger
  void . flip runLoggingT logger . logDebug $
    "Database.query"
      :# [ "query" .= q
         , "parameters" .= (show parameters :: Text)
         ]
  withConnection $ const (pure [])

withConnection :: (Connection -> IO a) -> Database a
withConnection action = do
  pool <- asks connectionPool
  liftIO $ withResource pool action

-- Fake authentication
-- ----------------------------------------------------------------------------

type UserId = Text

parseAuthHeader :: Maybe AuthorizationHeader -> Either Text UserId
parseAuthHeader Nothing = Left "Missing 'Authorization' header"
parseAuthHeader _ = Right "d42ed530-adba-41f0-99af-60bd6c476617"

authenticateUser
  :: (MonadIO m)
  => Text
  -> Maybe AuthorizationHeader
  -> m UserId
authenticateUser _authKey maybeAuthHeader =
  case parseAuthHeader maybeAuthHeader of
    Left _ ->
      liftIO . throwIO $
        err401
          { errBody = "Missing or invalid 'Authorization' header"
          }
    Right userId -> pure userId

data AuthEnv = AuthEnv
  { userId :: UserId
  }

class HasAuth env where
  getAuth :: env -> AuthEnv

type MonadAuth env m = (MonadReader env m, HasAuth env)

getUserId :: (MonadAuth env m) => m Text
getUserId = userId <$> asks getAuth

-- Fake tracing
-- ----------------------------------------------------------------------------

data Tracer = Tracer
data Span = Span

data TracingEnv = TracingEnv
  { tracer :: Tracer
  , activeSpan :: IORef Span
  }

class HasTracing env where
  getTracing :: env -> TracingEnv

type MonadTracing env m = (MonadReader env m, HasTracing env)

createTracer :: (MonadIO m) => Text -> m Tracer
createTracer _ = pure Tracer

createNewSpan :: (MonadIO m) => Maybe TraceParentHeader -> m Span
createNewSpan _ = pure Span

childSpan :: (MonadIO m) => IORef Span -> Text -> m ()
childSpan activeSpan _childSpanName =
  atomicModifyIORef activeSpan ((,()) . identity)

traced :: (MonadTracing env m, MonadIO m) => Text -> m a -> m a
traced spanName action = do
  activeSpan <- activeSpan <$> asks getTracing
  childSpan activeSpan spanName
  action

-- Fake project service client
-- ----------------------------------------------------------------------------

data Project = Project
  { projectId :: ProjectId
  , name :: Text
  }

data ProjectService = ProjectService
  { fetchProject :: ProjectId -> IO Project
  }

createProjectServiceClient :: Manager -> Text -> ProjectService
createProjectServiceClient _httpManager _serviceBaseUrl =
  ProjectService
    { fetchProject =
        \projectId -> pure Project {projectId = projectId, name = "My project"}
    }

-- Custom monad
-- ----------------------------------------------------------------------------

data Dependencies = Dependencies
  { dbPool :: Pool Connection
  , depsLogger :: LogFunc
  , tracer :: Tracer
  , authKey :: Text
  , projectService :: ProjectService
  }

data AppEnv = AppEnv
  { appLogger :: LogFunc
  , databaseEnv :: DatabaseEnv
  , tracingEnv :: TracingEnv
  , authEnv :: AuthEnv
  , appProject :: Project
  }

newtype App a = App
  { unApp :: ReaderT AppEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppEnv
    )

instance MonadLogger App where
  monadLoggerLog loc logSource logLevel msg = do
    logger <- asks appLogger
    liftIO $ logger loc logSource logLevel (toLogStr msg)

instance HasDatabase AppEnv where
  getDatabase = databaseEnv

instance HasTracing AppEnv where
  getTracing = tracingEnv

instance HasAuth AppEnv where
  getAuth = authEnv

runAppIO :: AppEnv -> App a -> IO a
runAppIO appEnv action = runReaderT (unApp action) appEnv

runAppServant
  :: AppEnv
  -> App a
  -> Servant.Handler a
runAppServant appEnv action =
  Servant.Handler . ExceptT . try $ runAppIO appEnv action

-- Handlers
-- ----------------------------------------------------------------------------

createTicketHandler :: CreateTicketRequest -> App CreateTicketResponse
createTicketHandler ticketName = do
  traced "create_ticket" $ do
    userId <- getUserId
    projectId <- asks (projectId . appProject)
    _ <-
      runDatabase $
        query
          "insert into tickets (name, project_id) values (?, ?) returning id"
          (ticketName, projectId)
    logInfo $
      "created ticket" :# ["user_id" .= userId, "project_id" .= projectId]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getTicketHandler :: TicketId -> App GetTicketResponse
getTicketHandler ticketId = do
  traced "get_ticket" $ do
    userId <- getUserId
    projectId <- asks (projectId . appProject)
    _ <-
      runDatabase $
        query
          "select id, name from tickets where id = ?"
          ticketId
    logInfo $
      "fetched ticket" :# ["user_id" .= userId, "project_id" .= projectId]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

-- Server
-- ----------------------------------------------------------------------------

server
  :: Dependencies
  -> Maybe AuthorizationHeader
  -> Maybe TraceParentHeader
  -> ProjectId
  -> TicketApi (AsServerT Servant.Handler)
server
  Dependencies {dbPool, depsLogger, tracer, authKey, projectService}
  maybeAuthHeader
  maybeTraceParentHeader
  projectId =
    hoistServer (Proxy @(NamedRoutes TicketApi)) run ticketServer
    where
      run :: App a -> Servant.Handler a
      run action = do
        userId <- authenticateUser authKey maybeAuthHeader
        activeSpan <- createNewSpan maybeTraceParentHeader >>= newIORef
        project <- liftIO $ fetchProject projectService projectId
        let authEnv =
              AuthEnv
                { userId = userId
                }
            tracingEnv =
              TracingEnv
                { tracer = tracer
                , activeSpan = activeSpan
                }
            databaseEnv =
              DatabaseEnv
                { dbLogger = depsLogger
                , connectionPool = dbPool
                }
            appEnv =
              AppEnv
                { appLogger = depsLogger
                , databaseEnv = databaseEnv
                , tracingEnv = tracingEnv
                , authEnv = authEnv
                , appProject = project
                }
        runAppServant appEnv action

ticketServer :: TicketApi (AsServerT App)
ticketServer =
  TicketApi
    { createTicket = createTicketHandler
    , getTicket = getTicketHandler
    }

-- Main
-- ----------------------------------------------------------------------------

main :: IO ()
main = do
  authKey <- toText . fromMaybe "abc123" <$> lookupEnv "AUTH_KEY"
  projectServiceUrl <-
    toText . fromMaybe "http://localhost:3001"
      <$> lookupEnv "PROJECT_SERVICE_URL"
  dbPool <- createDbPool "app:app@localhost:5432/app" 10
  tracer <- createTracer "app"
  httpManager <-
    newManager $
      defaultManagerSettings {managerConnCount = 20}
  let port = 3000
      dependencies =
        Dependencies
          { dbPool = dbPool
          , depsLogger = Logger.defaultOutput stdout
          , tracer = tracer
          , authKey = authKey
          , projectService =
              createProjectServiceClient
                httpManager
                projectServiceUrl
          }
      waiApp = serve (Proxy @Api) (server dependencies)
  Warp.run port waiApp

transformers-vs-reader.cabal

cabal-version: 3.0
name: transformers-vs-reader
version: 1.0.0

common options
    build-depends:
        , base
        , http-client
        , monad-logger
        , monad-logger-aeson
        , relude
        , relude
        , resource-pool
        , servant
        , servant-server
        , warp
    ghc-options:
        -Wall
        -Wcompat
        -Widentities
        -Wincomplete-uni-patterns
        -Wincomplete-record-updates
        -Wredundant-constraints
        -Wmissing-export-lists
        -Wpartial-fields
        -Wunused-packages
    default-language: GHC2021
    default-extensions:
        DeriveAnyClass
        DerivingStrategies
        DerivingVia
        DuplicateRecordFields
        NoImplicitPrelude
        OverloadedRecordDot
        OverloadedStrings
        StrictData

executable app-transformers
    import: options
    main-is: Transformers.hs
    hs-source-dirs: .

executable app-reader
    import: options
    main-is: Reader.hs
    hs-source-dirs: .

Transformers.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Main (main) where

import Relude hiding (traceId)

import Control.Exception (throwIO, try)
import Control.Monad.Logger (
  Loc,
  LogLevel,
  LogSource,
  LogStr,
  LoggingT,
  MonadLogger,
  askLoggerIO,
 )
import Control.Monad.Logger.Aeson (
  Message ((:#)),
  logDebug,
  logInfo,
  runLoggingT,
  runStdoutLoggingT,
  (.=),
 )
import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
import Network.HTTP.Client (
  Manager,
  defaultManagerSettings,
  managerConnCount,
  newManager,
 )
import Network.Wai.Handler.Warp qualified as Warp
import Servant (
  NamedRoutes,
  ServerError (..),
  err401,
  err500,
  hoistServer,
  serve,
 )
import Servant qualified (Handler (..))
import Servant.API (
  Capture,
  GenericMode ((:-)),
  Get,
  Header,
  PlainText,
  Post,
  ReqBody,
  (:>),
 )
import Servant.Server.Internal (AsServerT)

-- API
-- ----------------------------------------------------------------------------

type AuthorizationHeader = Text
type TraceParentHeader = Text
type ProjectId = Text
type TicketId = Text
type CreateTicketRequest = Text
type CreateTicketResponse = Text
type GetTicketResponse = Text

type Api =
  "v1"
    :> Header "Authorization" AuthorizationHeader
    :> Header "traceparent" TraceParentHeader
    :> "projects"
    :> Capture "projectId" ProjectId
    :> "tickets"
    :> NamedRoutes TicketApi

data TicketApi mode = TicketApi
  { createTicket
      :: mode
        :- ReqBody '[PlainText] CreateTicketRequest
        :> Post '[PlainText] CreateTicketResponse
  , getTicket
      :: mode
        :- Capture "ticketId" TicketId
        :> Get '[PlainText] GetTicketResponse
  }
  deriving stock (Generic)

-- Fake database
-- ----------------------------------------------------------------------------

data Connection = Connection

createDbPool :: Text -> Int -> IO (Pool Connection)
createDbPool _databaseUrl poolSize = do
  newPool $
    defaultPoolConfig
      create
      destroy
      poolTtl
      poolSize
  where
    create = pure Connection
    destroy = const $ pure ()
    poolTtl = 10

type LogFunc =
  Loc -> LogSource -> LogLevel -> LogStr -> IO ()

data DatabaseEnv = DatabaseEnv
  { dbLogger :: LogFunc
  , connectionPool :: Pool Connection
  }

newtype DatabaseT m a = DatabaseT
  { unDatabaseT :: ReaderT DatabaseEnv m a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader DatabaseEnv
    , MonadTrans
    , MonadLogger
    )

runDatabaseT :: DatabaseEnv -> DatabaseT m a -> m a
runDatabaseT env action = runReaderT (unDatabaseT action) env

type Database = DatabaseT IO

class (Monad m) => MonadDatabase m where
  runDatabase :: Database a -> m a

instance
  {-# OVERLAPPABLE #-}
  (Monad (t m), MonadDatabase m, MonadTrans t)
  => MonadDatabase (t m)
  where
  runDatabase :: Database a -> t m a
  runDatabase action = lift $ runDatabase action

instance (MonadIO m) => MonadDatabase (DatabaseT m) where
  runDatabase action =
    DatabaseT $ ReaderT $ \env -> liftIO $ runDatabaseT env action

query :: (Show p) => Text -> p -> Database [r]
query q parameters = do
  logger <- asks dbLogger
  void . flip runLoggingT logger . logDebug $
    "Database.query"
      :# [ "query" .= q
         , "parameters" .= (show parameters :: Text)
         ]
  withConnection $ const (pure [])

withConnection :: (Connection -> IO a) -> Database a
withConnection action = do
  pool <- asks connectionPool
  liftIO $ withResource pool action

-- Fake authentication
-- ----------------------------------------------------------------------------

type UserId = Text

parseAuthHeader :: Maybe AuthorizationHeader -> Either Text UserId
parseAuthHeader Nothing = Left "Missing 'Authorization' header"
parseAuthHeader _ = Right "d42ed530-adba-41f0-99af-60bd6c476617"

authenticateUser
  :: (MonadIO m)
  => Text
  -> Maybe AuthorizationHeader
  -> m UserId
authenticateUser _authKey maybeAuthHeader =
  case parseAuthHeader maybeAuthHeader of
    Left _ ->
      liftIO . throwIO $
        err401
          { errBody = "Missing or invalid 'Authorization' header"
          }
    Right userId -> pure userId

data AuthEnv = AuthEnv
  { userId :: UserId
  }

newtype AuthT m a = AuthT
  { unAuthT :: ReaderT AuthEnv m a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AuthEnv
    , MonadTrans
    , MonadLogger
    )

runAuthT :: AuthEnv -> AuthT m a -> m a
runAuthT env action = runReaderT (unAuthT action) env

class (Monad m) => MonadAuth m where
  getAuth :: m AuthEnv

instance
  {-# OVERLAPPABLE #-}
  (Monad (t m), MonadAuth m, MonadTrans t)
  => MonadAuth (t m)
  where
  getAuth :: t m AuthEnv
  getAuth = lift getAuth

instance (Monad m) => MonadAuth (AuthT m) where
  getAuth = AuthT ask

getUserId :: (MonadAuth m) => m Text
getUserId = userId <$> getAuth

-- Fake tracing
-- ----------------------------------------------------------------------------

data Tracer = Tracer
data Span = Span

data TracingEnv = TracingEnv
  { tracer :: Tracer
  , activeSpan :: IORef Span
  }

newtype TracingT m a = TracingT
  { unTracingT :: ReaderT TracingEnv m a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader TracingEnv
    , MonadTrans
    , MonadLogger
    )

runTracingT :: TracingEnv -> TracingT m a -> m a
runTracingT env action = runReaderT (unTracingT action) env

class (MonadIO m) => MonadTracing m where
  getTracing :: m TracingEnv

instance
  {-# OVERLAPPABLE #-}
  (MonadIO (t m), MonadTracing m, MonadTrans t)
  => MonadTracing (t m)
  where
  getTracing :: t m TracingEnv
  getTracing = lift getTracing

instance (MonadIO m) => MonadTracing (TracingT m) where
  getTracing = TracingT ask

createTracer :: (MonadIO m) => Text -> m Tracer
createTracer _ = pure Tracer

createNewSpan :: (MonadIO m) => Maybe TraceParentHeader -> m Span
createNewSpan _ = pure Span

childSpan :: (MonadIO m) => IORef Span -> Text -> m ()
childSpan activeSpan _childSpanName =
  atomicModifyIORef activeSpan ((,()) . identity)

traced :: (MonadTracing m) => Text -> m a -> m a
traced spanName action = do
  activeSpan <- activeSpan <$> getTracing
  childSpan activeSpan spanName
  action

-- Fake project service client
-- ----------------------------------------------------------------------------

data Project = Project
  { projectId :: ProjectId
  , name :: Text
  }

data ProjectService = ProjectService
  { fetchProject :: ProjectId -> IO Project
  }

createProjectServiceClient :: Manager -> Text -> ProjectService
createProjectServiceClient _httpManager _serviceBaseUrl =
  ProjectService
    { fetchProject =
        \projectId -> pure Project {projectId = projectId, name = "My project"}
    }

-- Custom monad
-- ----------------------------------------------------------------------------

type App = AppT (AuthT (TracingT (DatabaseT (LoggingT IO))))

data Dependencies = Dependencies
  { dbPool :: Pool Connection
  , runLogging :: forall a. LoggingT IO a -> IO a
  , tracer :: Tracer
  , authKey :: Text
  , projectService :: ProjectService
  }

data AppEnv = AppEnv
  { appProject :: Project
  }

newtype AppT m a = AppT
  { unAppT :: ReaderT AppEnv m a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppEnv
    , MonadTrans
    , MonadLogger
    )

runAppIO
  :: Dependencies
  -> DatabaseEnv
  -> TracingEnv
  -> AuthEnv
  -> AppEnv
  -> App a
  -> IO a
runAppIO
  Dependencies {runLogging}
  databaseEnv
  tracingEnv
  authEnv
  appEnv
  action =
    runLogging
      . runDatabaseT databaseEnv
      . runTracingT tracingEnv
      . runAuthT authEnv
      . flip runReaderT appEnv
      . unAppT
      $ action

runAppServant
  :: Dependencies
  -> DatabaseEnv
  -> TracingEnv
  -> AuthEnv
  -> AppEnv
  -> App a
  -> Servant.Handler a
runAppServant deps databaseEnv tracingEnv authEnv appEnv action =
  Servant.Handler . ExceptT . try $
    runAppIO deps databaseEnv tracingEnv authEnv appEnv action

-- Handlers
-- ----------------------------------------------------------------------------

createTicketHandler :: CreateTicketRequest -> App CreateTicketResponse
createTicketHandler ticketName = do
  traced "create_ticket" $ do
    userId <- getUserId
    projectId <- asks (projectId . appProject)
    _ <-
      runDatabase $
        query
          "insert into tickets (name, project_id) values (?, ?) returning id"
          (ticketName, projectId)
    logInfo $
      "created ticket" :# ["user_id" .= userId, "project_id" .= projectId]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getTicketHandler :: TicketId -> App GetTicketResponse
getTicketHandler ticketId = do
  traced "get_ticket" $ do
    userId <- getUserId
    projectId <- asks (projectId . appProject)
    _ <-
      runDatabase $
        query
          "select id, name from tickets where id = ?"
          ticketId
    logInfo $
      "fetched ticket" :# ["user_id" .= userId, "project_id" .= projectId]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

-- Server
-- ----------------------------------------------------------------------------

server
  :: Dependencies
  -> Maybe AuthorizationHeader
  -> Maybe TraceParentHeader
  -> ProjectId
  -> TicketApi (AsServerT Servant.Handler)
server
  deps@Dependencies {dbPool, runLogging, tracer, authKey, projectService}
  maybeAuthHeader
  maybeTraceParentHeader
  projectId =
    hoistServer (Proxy @(NamedRoutes TicketApi)) run ticketServer
    where
      run :: App a -> Servant.Handler a
      run action = do
        logger <- liftIO $ runLogging askLoggerIO
        userId <- authenticateUser authKey maybeAuthHeader
        activeSpan <- createNewSpan maybeTraceParentHeader >>= newIORef
        project <- liftIO $ fetchProject projectService projectId
        let authEnv =
              AuthEnv
                { userId = userId
                }
            tracingEnv =
              TracingEnv
                { tracer = tracer
                , activeSpan = activeSpan
                }
            databaseEnv =
              DatabaseEnv
                { dbLogger = logger
                , connectionPool = dbPool
                }
            appEnv =
              AppEnv
                { appProject = project
                }
        runAppServant deps databaseEnv tracingEnv authEnv appEnv action

ticketServer :: TicketApi (AsServerT App)
ticketServer =
  TicketApi
    { createTicket = createTicketHandler
    , getTicket = getTicketHandler
    }

-- Main
-- ----------------------------------------------------------------------------

main :: IO ()
main = do
  authKey <- toText . fromMaybe "abc123" <$> lookupEnv "AUTH_KEY"
  projectServiceUrl <-
    toText . fromMaybe "http://localhost:3001"
      <$> lookupEnv "PROJECT_SERVICE_URL"
  dbPool <- createDbPool "app:app@localhost:5432/app" 10
  tracer <- createTracer "app"
  httpManager <-
    newManager $
      defaultManagerSettings {managerConnCount = 20}
  let port = 3000
      dependencies =
        Dependencies
          { dbPool = dbPool
          , runLogging = runStdoutLoggingT
          , tracer = tracer
          , authKey = authKey
          , projectService =
              createProjectServiceClient
                httpManager
                projectServiceUrl
          }
      waiApp = serve (Proxy @Api) (server dependencies)
  Warp.run port waiApp