Skip to content

Instantly share code, notes, and snippets.

@nicolashery

nicolashery/.rio-servant-nested.md

Last active June 12, 2023 20:33
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save nicolashery/cbce0a831dc8a9ac7161e03abfab2d79 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save nicolashery/cbce0a831dc8a9ac7161e03abfab2d79 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
.rio-servant-nested.md

Using RIO with Servant in Haskell, with nested environments.

Port of servant-nested-apis Gist.

Raw
Api.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Api where
import RIO
import Servant.API (
Capture,
GenericMode ((:-)),
Get,
GetNoContent,
Header,
NamedRoutes,
PlainText,
Post,
ReqBody,
(:>),
)
type AuthorizationHeader = Text
type TraceParentHeader = Text
type OrganizationId = Text
type ProjectId = Text
type TicketId = Text
type ListOrganizationsResponse = Text
type LayoutResponse = Text
type CreateProjectRequest = Text
type CreateProjectResponse = Text
type GetProjectResponse = Text
type CreateTicketRequest = Text
type CreateTicketResponse = Text
type GetTicketResponse = Text
type Api =
"v1"
:> Header "traceparent" TraceParentHeader
:> NamedRoutes RootApi
data RootApi mode = RootApi
{ health
:: mode
:- "health"
:> GetNoContent
, layout
:: mode
:- "layout"
:> Get '[PlainText] LayoutResponse
, authenticatedApi
:: mode
:- Header "Authorization" AuthorizationHeader
:> NamedRoutes AuthenticatedApi
}
deriving stock (Generic)
data AuthenticatedApi mode = AuthenticatedApi
{ listOrganizations
:: mode
:- "organizations"
:> Get '[PlainText] ListOrganizationsResponse
, projectApi
:: mode
:- "organizations"
:> Capture "organizationId" OrganizationId
:> "projects"
:> NamedRoutes ProjectApi
}
deriving stock (Generic)
data ProjectApi mode = ProjectApi
{ createProject
:: mode
:- ReqBody '[PlainText] CreateProjectRequest
:> Post '[PlainText] CreateProjectResponse
, getProject
:: mode
:- Capture "projectId" ProjectId
:> Get '[PlainText] GetProjectResponse
, ticketApi
:: mode
:- Capture "projectId" ProjectId
:> "tickets"
:> NamedRoutes TicketApi
}
deriving stock (Generic)
data TicketApi mode = TicketApi
{ createTicket
:: mode
:- ReqBody '[PlainText] CreateTicketRequest
:> Post '[PlainText] CreateTicketResponse
, getTicket
:: mode
:- Capture "ticketId" TicketId
:> Get '[PlainText] GetTicketResponse
}
deriving stock (Generic)
Raw
App.hs
module App (
AppDeps (..),
AppEnv (..),
HasAppEnv (..),
runApp,
healthHandler,
layoutHandler,
) where
import RIO
import Api (Api, TraceParentHeader)
import Control.Monad.Except (ExceptT (..))
import Control.Monad.Logger (MonadLogger (..))
import Database (Connection, Database (..), HasDatabase (..), Pool)
import Logging (HasLogging (..), Logging, monadLoggerLogImpl)
import Servant (Handler (..), NoContent (..), layout)
import Tracing (HasTracing (..), Tracer, Tracing (..), createNewSpan)
data AppDeps = AppDeps
{ dbPool :: Pool Connection
, depsLogger :: Logging
, tracer :: Tracer
}
data AppEnv = AppEnv
{ appLogger :: Logging
, databaseEnv :: Database
, appTracing :: Tracing
}
instance MonadLogger (RIO AppEnv) where
monadLoggerLog = monadLoggerLogImpl
class
(HasLogging env, HasDatabase env, HasTracing env) =>
HasAppEnv env
where
getAppEnv :: env -> AppEnv
instance HasAppEnv AppEnv where
getAppEnv = id
instance HasLogging AppEnv where
getLogging = appLogger
instance HasDatabase AppEnv where
getDatabase = databaseEnv
instance HasTracing AppEnv where
getTracing = appTracing
runAppServant :: AppEnv -> RIO AppEnv a -> Servant.Handler a
runAppServant appEnv action =
Servant.Handler . ExceptT . try $ runRIO appEnv action
runApp
:: AppDeps
-> Maybe TraceParentHeader
-> RIO AppEnv a
-> Servant.Handler a
runApp
AppDeps {dbPool, depsLogger, tracer}
maybeTraceParentHeader
action = do
activeSpan <- createNewSpan maybeTraceParentHeader >>= newIORef
let tracing =
Tracing
{ tracer = tracer
, activeSpan = activeSpan
}
databaseEnv =
Database
{ dbLogger = depsLogger
, connectionPool = dbPool
}
appEnv =
AppEnv
{ appLogger = depsLogger
, databaseEnv = databaseEnv
, appTracing = tracing
}
runAppServant appEnv action
healthHandler :: RIO AppEnv NoContent
healthHandler = pure NoContent
layoutHandler :: RIO AppEnv Text
layoutHandler = pure $ layout (Proxy @Api)
Raw
AppAuthenticated.hs
module AppAuthenticated (
AppAuthenticatedDeps (..),
AppAuthenticatedEnv (..),
HasAppAuthenticatedEnv (..),
runAppAuthenticated,
listOrganizationsHandler,
) where
import RIO hiding (logInfo)
import Api (
AuthorizationHeader,
ListOrganizationsResponse,
)
import App (AppEnv (..), HasAppEnv (..))
import Authentication (
Auth (..),
AuthKey,
HasAuth (..),
authenticateUser,
getUserId,
)
import Control.Monad.Logger (MonadLogger (..))
import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
import Database (HasDatabase (..))
import Logging (HasLogging (..), monadLoggerLogImpl)
import Organization (
HasOrganizationService (..),
Organization (organizationId),
OrganizationService,
fetchUserOrganizations,
)
import Servant (ServerError (..), err500)
import Tracing (HasTracing (..), traced)
data AppAuthenticatedDeps = AppAuthenticatedDeps
{ authKey :: AuthKey
, organizationService :: OrganizationService
}
data AppAuthenticatedEnv = AppAuthenticatedEnv
{ appEnv :: AppEnv
, appAuth :: Auth
, appOrganizationService :: OrganizationService
}
instance MonadLogger (RIO AppAuthenticatedEnv) where
monadLoggerLog = monadLoggerLogImpl
class
(HasAppEnv env, HasAuth env, HasOrganizationService env) =>
HasAppAuthenticatedEnv env
where
getAppAuthenticatedEnv :: env -> AppAuthenticatedEnv
instance HasAppAuthenticatedEnv AppAuthenticatedEnv where
getAppAuthenticatedEnv = id
instance HasAuth AppAuthenticatedEnv where
getAuth = appAuth
instance HasOrganizationService AppAuthenticatedEnv where
getOrganizationService = appOrganizationService
instance HasAppEnv AppAuthenticatedEnv where
getAppEnv = appEnv
instance HasLogging AppAuthenticatedEnv where
getLogging = getLogging . getAppEnv
instance HasDatabase AppAuthenticatedEnv where
getDatabase = getDatabase . getAppEnv
instance HasTracing AppAuthenticatedEnv where
getTracing = getTracing . getAppEnv
runAppAuthenticated
:: AppAuthenticatedDeps
-> Maybe AuthorizationHeader
-> RIO AppAuthenticatedEnv a
-> RIO AppEnv a
runAppAuthenticated
AppAuthenticatedDeps {authKey, organizationService}
maybeAuthHeader
action = do
userId <- authenticateUser authKey maybeAuthHeader
let auth =
Auth
{ userId = userId
}
mapEnv appEnv' =
AppAuthenticatedEnv
{ appEnv = appEnv'
, appAuth = auth
, appOrganizationService = organizationService
}
mapRIO mapEnv action
listOrganizationsHandler :: RIO AppAuthenticatedEnv ListOrganizationsResponse
listOrganizationsHandler = traced "list_organizations" $ do
userId <- getUserId
organizations <- fetchUserOrganizations userId
logInfo $
"fetched organizations"
:# [ "user_id" .= userId
, "organizations" .= map organizationId organizations
]
throwIO $ err500 {errBody = "Not implemented"}
Raw
AppProject.hs
module AppProject (
Project (..),
AppProjectEnv (..),
HasAppProjectEnv (..),
runAppProject,
createProjectHandler,
getProjectHandler,
getProjectOrganization,
findProjectById,
) where
import RIO hiding (logInfo)
import Api (
CreateProjectRequest,
CreateProjectResponse,
GetProjectResponse,
OrganizationId,
ProjectId,
)
import App (HasAppEnv (..))
import AppAuthenticated (
AppAuthenticatedEnv (..),
HasAppAuthenticatedEnv (..),
)
import Authentication (HasAuth (..), getUserId)
import Control.Monad.Logger (MonadLogger (..))
import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
import Database (HasDatabase (..), query)
import Logging (HasLogging (..), monadLoggerLogImpl)
import Organization (
HasOrganizationService (..),
Organization (organizationId),
fetchOrganization,
)
import Servant (ServerError (..), err500)
import Tracing (HasTracing (..), traced)
data Project = Project
{ projectId :: ProjectId
, name :: Text
}
data AppProjectEnv = AppProjectEnv
{ appAuthenticatedEnv :: AppAuthenticatedEnv
, projectOrganization :: Organization
}
instance MonadLogger (RIO AppProjectEnv) where
monadLoggerLog = monadLoggerLogImpl
class (HasAppAuthenticatedEnv env) => HasAppProjectEnv env where
getAppProjectEnv :: env -> AppProjectEnv
instance HasAppProjectEnv AppProjectEnv where
getAppProjectEnv = id
instance HasAppAuthenticatedEnv AppProjectEnv where
getAppAuthenticatedEnv = appAuthenticatedEnv
instance HasAuth AppProjectEnv where
getAuth = getAuth . getAppAuthenticatedEnv
instance HasOrganizationService AppProjectEnv where
getOrganizationService = getOrganizationService . getAppAuthenticatedEnv
instance HasAppEnv AppProjectEnv where
getAppEnv = getAppEnv . getAppAuthenticatedEnv
instance HasLogging AppProjectEnv where
getLogging = getLogging . getAppEnv
instance HasDatabase AppProjectEnv where
getDatabase = getDatabase . getAppEnv
instance HasTracing AppProjectEnv where
getTracing = getTracing . getAppEnv
runAppProject
:: OrganizationId
-> RIO AppProjectEnv a
-> RIO AppAuthenticatedEnv a
runAppProject organizationId action = do
projectOrganization <- fetchOrganization organizationId
let mapEnv appAuthenticatedEnv' =
AppProjectEnv
{ appAuthenticatedEnv = appAuthenticatedEnv'
, projectOrganization = projectOrganization
}
mapRIO mapEnv action
createProjectHandler
:: CreateProjectRequest -> RIO AppProjectEnv CreateProjectResponse
createProjectHandler projectName = traced "create_project" $ do
userId <- getUserId
organizationId <- organizationId <$> getProjectOrganization
_ <-
query
"insert into projects (name, organization_id) values (?, ?) returning id"
(projectName, organizationId)
logInfo $
"created project"
:# [ "user_id" .= userId
, "organization_id" .= organizationId
]
throwIO $ err500 {errBody = "Not implemented"}
getProjectHandler :: ProjectId -> RIO AppProjectEnv GetProjectResponse
getProjectHandler projectId = traced "get_project" $ do
userId <- getUserId
organizationId <- organizationId <$> getProjectOrganization
_ <- findProjectById projectId
logInfo $
"fetched project"
:# [ "user_id" .= userId
, "organization_id" .= organizationId
]
throwIO $ err500 {errBody = "Not implemented"}
getProjectOrganization
:: (MonadReader env m, HasAppProjectEnv env) => m Organization
getProjectOrganization =
asks (projectOrganization . getAppProjectEnv)
findProjectById :: (HasDatabase env) => ProjectId -> RIO env (Maybe Project)
findProjectById projectId = do
_ <-
query
"select id, name from projects where id = ?"
projectId
pure . Just $
Project
{ projectId = projectId
, name = "My project"
}
Raw
AppTicket.hs
module AppTicket (
AppTicketEnv (..),
HasAppTicketEnv (..),
runAppTicket,
createTicketHandler,
getTicketHandler,
getTicketProject,
) where
import RIO hiding (logInfo)
import Api (
CreateTicketRequest,
CreateTicketResponse,
GetTicketResponse,
ProjectId,
TicketId,
)
import App (HasAppEnv (..))
import AppAuthenticated (HasAppAuthenticatedEnv (..))
import AppProject (
AppProjectEnv,
HasAppProjectEnv (..),
Project (..),
findProjectById,
getProjectOrganization,
)
import Authentication (HasAuth (..), getUserId)
import Control.Monad.Logger (MonadLogger (..))
import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
import Database (HasDatabase (..), query)
import Logging (HasLogging (..), monadLoggerLogImpl)
import Organization (HasOrganizationService (..), Organization (organizationId))
import Servant (ServerError (..), err404, err500)
import Tracing (HasTracing (..), traced)
data AppTicketEnv = AppTicketEnv
{ appProjectEnv :: AppProjectEnv
, ticketProject :: Project
}
instance MonadLogger (RIO AppTicketEnv) where
monadLoggerLog = monadLoggerLogImpl
class (HasAppProjectEnv env) => HasAppTicketEnv env where
getAppTicketEnv :: env -> AppTicketEnv
instance HasAppTicketEnv AppTicketEnv where
getAppTicketEnv = id
instance HasAppProjectEnv AppTicketEnv where
getAppProjectEnv = appProjectEnv
instance HasAppAuthenticatedEnv AppTicketEnv where
getAppAuthenticatedEnv = getAppAuthenticatedEnv . getAppProjectEnv
instance HasAuth AppTicketEnv where
getAuth = getAuth . getAppAuthenticatedEnv
instance HasOrganizationService AppTicketEnv where
getOrganizationService = getOrganizationService . getAppAuthenticatedEnv
instance HasAppEnv AppTicketEnv where
getAppEnv = getAppEnv . getAppAuthenticatedEnv . getAppProjectEnv
instance HasLogging AppTicketEnv where
getLogging = getLogging . getAppEnv
instance HasDatabase AppTicketEnv where
getDatabase = getDatabase . getAppEnv
instance HasTracing AppTicketEnv where
getTracing = getTracing . getAppEnv
runAppTicket
:: ProjectId
-> RIO AppTicketEnv a
-> RIO AppProjectEnv a
runAppTicket projectId action = do
let projectNotFound :: RIO AppProjectEnv Project
projectNotFound =
throwIO $ err404 {errBody = "Project not found"}
maybeProject <- findProjectById projectId
project <- maybe projectNotFound pure maybeProject
let mapEnv appProjectEnv' =
AppTicketEnv
{ appProjectEnv = appProjectEnv'
, ticketProject = project
}
mapRIO mapEnv action
createTicketHandler
:: CreateTicketRequest -> RIO AppTicketEnv CreateTicketResponse
createTicketHandler ticketName = traced "create_ticket" $ do
userId <- getUserId
organizationId <- organizationId <$> getProjectOrganization
projectId <- projectId <$> getTicketProject
_ <-
query
"insert into tickets (name, project_id) values (?, ?) returning id"
(ticketName, projectId)
logInfo $
"created ticket"
:# [ "user_id" .= userId
, "organization_id" .= organizationId
, "project_id" .= projectId
]
throwIO $ err500 {errBody = "Not implemented"}
getTicketHandler :: TicketId -> RIO AppTicketEnv GetTicketResponse
getTicketHandler ticketId = traced "get_ticket" $ do
userId <- getUserId
organizationId <- organizationId <$> getProjectOrganization
projectId <- projectId <$> getTicketProject
_ <-
query
"select id, name from tickets where id = ?"
ticketId
logInfo $
"fetched ticket"
:# [ "user_id" .= userId
, "organization_id" .= organizationId
, "project_id" .= projectId
]
throwIO $ err500 {errBody = "Not implemented"}
getTicketProject
:: (MonadReader env m, HasAppTicketEnv env) => m Project
getTicketProject =
asks (ticketProject . getAppTicketEnv)
Raw
Authentication.hs
-- | Fake authentication
module Authentication (
AuthKey,
UserId,
parseAuthHeader,
authenticateUser,
Auth (..),
HasAuth (..),
getUserId,
) where
import RIO
import Api (AuthorizationHeader)
import Servant (err401, errBody)
type AuthKey = Text
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)
=> AuthKey
-> Maybe AuthorizationHeader
-> m UserId
authenticateUser _authKey maybeAuthHeader =
case parseAuthHeader maybeAuthHeader of
Left _ ->
throwIO $
err401
{ errBody = "Missing or invalid 'Authorization' header"
}
Right userId -> pure userId
data Auth = Auth
{ userId :: UserId
}
class HasAuth env where
getAuth :: env -> Auth
getUserId :: (HasAuth env) => RIO env Text
getUserId = userId <$> asks getAuth
Raw
Database.hs
-- | Fake database
module Database (
Pool,
Connection,
createDbPool,
Database (..),
HasDatabase (..),
query,
) where
import RIO hiding (logDebug)
import Control.Monad.Logger.Aeson (Message ((:#)), logDebug, runLoggingT, (.=))
import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
import Logging (Logging)
import RIO.Text qualified as T
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
data Database = Database
{ dbLogger :: Logging
, connectionPool :: Pool Connection
}
class HasDatabase env where
getDatabase :: env -> Database
query :: (HasDatabase env, Show p) => Text -> p -> RIO env [r]
query q parameters = do
logger <- asks (dbLogger . getDatabase)
void . flip runLoggingT logger . logDebug $
"Database.query"
:# [ "query" .= q
, "parameters" .= (T.pack . show $ parameters)
]
withConnection $ const (pure [])
withConnection :: (HasDatabase env) => (Connection -> IO a) -> RIO env a
withConnection action = do
pool <- asks (connectionPool . getDatabase)
liftIO $ withResource pool action
Raw
Logging.hs
module Logging (
Logging,
HasLogging (..),
monadLoggerLogImpl,
) where
import RIO hiding (LogLevel, LogSource)
import Control.Monad.Logger (
Loc,
LogLevel,
LogSource,
LogStr,
ToLogStr (toLogStr),
)
type Logging =
Loc -> LogSource -> LogLevel -> LogStr -> IO ()
class HasLogging env where
getLogging :: env -> Logging
monadLoggerLogImpl
:: (HasLogging env, ToLogStr msg)
=> Loc
-> LogSource
-> LogLevel
-> msg
-> RIO env ()
monadLoggerLogImpl loc logSource logLevel msg = do
logger <- asks getLogging
liftIO $ logger loc logSource logLevel (toLogStr msg)
Raw
Main.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Main (main) where
import RIO
import Api (Api)
import App (AppDeps (..))
import AppAuthenticated (AppAuthenticatedDeps (..))
import Control.Monad.Logger.Aeson qualified as Logger (defaultOutput)
import Database (createDbPool)
import Network.HTTP.Client (
defaultManagerSettings,
managerConnCount,
newManager,
)
import Network.Wai.Handler.Warp qualified as Warp
import Organization (createOrganizationServiceClient)
import RIO.Text qualified as T
import Servant (serve)
import Server (server)
import System.Environment (lookupEnv)
import Tracing (createTracer)
main :: IO ()
main = do
authKey <- T.pack . fromMaybe "abc123" <$> lookupEnv "AUTH_KEY"
projectServiceUrl <-
T.pack . 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
appDeps =
AppDeps
{ dbPool = dbPool
, depsLogger = Logger.defaultOutput stdout
, tracer = tracer
}
appAuthenticatedDeps =
AppAuthenticatedDeps
{ authKey = authKey
, organizationService =
createOrganizationServiceClient
httpManager
projectServiceUrl
}
waiApp = serve (Proxy @Api) (server appDeps appAuthenticatedDeps)
Warp.run port waiApp
Raw
Organization.hs
-- | Fake organization service client
module Organization (
Organization (..),
OrganizationService (..),
createOrganizationServiceClient,
HasOrganizationService (..),
fetchUserOrganizations,
fetchOrganization,
) where
import RIO
import Api (OrganizationId)
import Authentication (UserId)
import Network.HTTP.Client (Manager)
data Organization = Organization
{ organizationId :: OrganizationId
, name :: Text
}
data OrganizationService = OrganizationService
{ fetchUserOrganizationsImpl :: UserId -> IO [Organization]
, fetchOrganizationImpl :: OrganizationId -> IO Organization
}
class HasOrganizationService env where
getOrganizationService :: env -> OrganizationService
createOrganizationServiceClient :: Manager -> Text -> OrganizationService
createOrganizationServiceClient _httpManager _serviceBaseUrl =
OrganizationService
{ fetchUserOrganizationsImpl =
\_userId ->
pure
[ Organization
{ organizationId = "90ee1361-ee8b-4b22-be38-14bf46a28cfd"
, name = "Org 1"
}
, Organization
{ organizationId = "6e0549c0-15da-4262-9046-4357413c2791"
, name = "Org 2"
}
]
, fetchOrganizationImpl = \organizationId ->
pure
Organization
{ organizationId = organizationId
, name = "Org 1"
}
}
fetchUserOrganizations
:: (HasOrganizationService env)
=> UserId
-> RIO env [Organization]
fetchUserOrganizations userId = do
service <- asks getOrganizationService
liftIO $ fetchUserOrganizationsImpl service userId
fetchOrganization
:: (HasOrganizationService env)
=> OrganizationId
-> RIO env Organization
fetchOrganization organizationId = do
service <- asks getOrganizationService
liftIO $ fetchOrganizationImpl service organizationId
Raw
rio-servant-nested.cabal
cabal-version: 3.0
name: rio-servant-nested
version: 1.0.0
common options
build-depends:
, base
, http-client
, monad-logger
, monad-logger-aeson
, mtl
, resource-pool
, rio
, 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 rio-servant-nested
import: options
main-is: Main.hs
other-modules:
Api
App
AppAuthenticated
AppProject
AppTicket
Authentication
Database
Logging
Organization
Server
Tracing
hs-source-dirs: .
Raw
Server.hs
module Server (server) where
import RIO
import Api (
AuthenticatedApi (..),
AuthorizationHeader,
OrganizationId,
ProjectApi (..),
ProjectId,
RootApi (..),
TicketApi (..),
TraceParentHeader,
)
import App (AppDeps, AppEnv, healthHandler, layoutHandler, runApp)
import AppAuthenticated (
AppAuthenticatedDeps (..),
AppAuthenticatedEnv,
listOrganizationsHandler,
runAppAuthenticated,
)
import AppProject (
AppProjectEnv,
createProjectHandler,
getProjectHandler,
runAppProject,
)
import AppTicket (
AppTicketEnv,
createTicketHandler,
getTicketHandler,
runAppTicket,
)
import Servant (Handler, NamedRoutes, hoistServer)
import Servant.Server.Generic (AsServerT)
server
:: AppDeps
-> AppAuthenticatedDeps
-> Maybe TraceParentHeader
-> RootApi (AsServerT Servant.Handler)
server appDeps appAuthenticatedDeps maybeTraceParentHeader =
hoistServer
(Proxy @(NamedRoutes RootApi))
(runApp appDeps maybeTraceParentHeader)
(rootServer appAuthenticatedDeps)
rootServer :: AppAuthenticatedDeps -> RootApi (AsServerT (RIO AppEnv))
rootServer appAuthenticatedDeps =
RootApi
{ health = healthHandler
, layout = layoutHandler
, authenticatedApi = authenticatedServer'
}
where
authenticatedServer' maybeAuthHeader =
hoistServer
(Proxy @(NamedRoutes AuthenticatedApi))
(runAppAuthenticated appAuthenticatedDeps maybeAuthHeader)
(authenticatedServer maybeAuthHeader)
authenticatedServer
:: Maybe AuthorizationHeader
-> AuthenticatedApi (AsServerT (RIO AppAuthenticatedEnv))
authenticatedServer _maybeAuthHeader =
AuthenticatedApi
{ listOrganizations = listOrganizationsHandler
, projectApi = projectServer'
}
where
projectServer' organizationId =
hoistServer
(Proxy @(NamedRoutes ProjectApi))
(runAppProject organizationId)
(projectServer organizationId)
projectServer :: OrganizationId -> ProjectApi (AsServerT (RIO AppProjectEnv))
projectServer _organizationId =
ProjectApi
{ createProject = createProjectHandler
, getProject = getProjectHandler
, ticketApi = ticketServer'
}
where
ticketServer' projectId =
hoistServer
(Proxy @(NamedRoutes TicketApi))
(runAppTicket projectId)
(ticketServer projectId)
ticketServer :: ProjectId -> TicketApi (AsServerT (RIO AppTicketEnv))
ticketServer _projectId =
TicketApi
{ createTicket = createTicketHandler
, getTicket = getTicketHandler
}
Raw
Tracing.hs
-- | Fake tracing
module Tracing (
Tracer,
Span,
Tracing (..),
HasTracing (..),
createTracer,
createNewSpan,
traced,
) where
import RIO
import Api (TraceParentHeader)
data Tracer = Tracer
data Span = Span
data Tracing = Tracing
{ tracer :: Tracer
, activeSpan :: IORef Span
}
class HasTracing env where
getTracing :: env -> Tracing
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 ((,()))
traced :: (HasTracing env) => Text -> RIO env a -> RIO env a
traced spanName action = do
activeSpan <- activeSpan <$> asks getTracing
childSpan activeSpan spanName
action
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment