Compare using a stack of transformers vs. the ReaderT pattern for a web service.
See files:
Compare using a stack of transformers vs. the ReaderT pattern for a web service.
See files:
{-# 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 |
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: . |
{-# 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 |