.rio-servant-nested.md

Using RIO with Servant in Haskell, with nested environments.

Port of servant-nested-apis Gist.

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)

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)

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

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

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)

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

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

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)

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

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

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: .

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
    }

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