.servant-nested-apis.md

Nesting APIs and ReaderT environments in Haskell's Servant

Environments, from parent to child (or base to extended):

• App (ReaderT AppEnv IO):
  • HasLogFunc env
  • HasDatabase env
  • HasTracing env
• AppAuthenticated (ReaderT AppAuthenticatedEnv IO):
  • HasApp env (everything from App)
  • HasOrganizationService env
• AppProject (ReaderT AppProjectEnv IO):
  • HasAppAuthenticated env (everything from AppAuthenticated)
  • projectOrganization
• AppTicket (ReaderT AppTicketEnv IO):
  • HasAppProject env (everything from AppProject)
  • ticketProject

Files:

• Api.hs
• App.hs
• AppAuthenticated.hs
• AppProject.hs
• AppTicket.hs
• Authentication.hs
• Database.hs
• Logging.hs
• Main.hs
• Organization.hs
• Server.hs
• Tracing.hs

flowchart TB
  App["App"]
  AppAuthenticated["AppAuthenticated"]
  AppProject["AppProject"]
  AppTicket["AppTicket"]

  HasLogFunc["HasLogFunc env"]
  HasDatabase["HasDatabase env"]
  HasTracing["HasTracing env"]
  HasAuth["HasAuth env"]
  HasOrganizationService["HasOrganizationService env"]
  projectOrganization["ask projectOrganization"]
  ticketProject["ask ticketProject"]

  AppTicket-->AppProject
  AppTicket--->ticketProject
  AppProject-->AppAuthenticated
  AppProject--->projectOrganization
  AppAuthenticated-->App
  AppAuthenticated--->HasAuth
  AppAuthenticated--->HasOrganizationService
  App-->HasLogFunc
  App-->HasDatabase
  App-->HasTracing

Api.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}

module Api where

import Relude

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 (..),
  App (..),
  HasApp (..),
  runApp,
  healthHandler,
  layoutHandler,
) where

import Relude

import Api (Api, TraceParentHeader)
import Control.Exception (try)
import Control.Monad.Logger (MonadLogger (..))
import Database (Connection, DatabaseEnv (..), HasDatabase (..), Pool)
import Logging (HasLogFunc (..), LogFunc, monadLoggerLogImpl)
import Servant (Handler (..), NoContent (..), layout)
import Tracing (HasTracing (..), Tracer, TracingEnv (..), createNewSpan)

data AppDeps = AppDeps
  { dbPool :: Pool Connection
  , depsLogger :: LogFunc
  , tracer :: Tracer
  }

data AppEnv = AppEnv
  { appLogger :: LogFunc
  , databaseEnv :: DatabaseEnv
  , tracingEnv :: TracingEnv
  }

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

instance MonadLogger App where
  monadLoggerLog = monadLoggerLogImpl

class (HasLogFunc env, HasDatabase env, HasTracing env) => HasApp env where
  getApp :: env -> AppEnv

instance HasApp AppEnv where
  getApp = identity

instance HasLogFunc AppEnv where
  getLogFunc = appLogger

instance HasDatabase AppEnv where
  getDatabase = databaseEnv

instance HasTracing AppEnv where
  getTracing = tracingEnv

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

runApp :: AppDeps -> Maybe TraceParentHeader -> App a -> Handler a
runApp
  AppDeps {dbPool, depsLogger, tracer}
  maybeTraceParentHeader
  action = do
    activeSpan <- createNewSpan maybeTraceParentHeader >>= newIORef
    let tracingEnv =
          TracingEnv
            { tracer = tracer
            , activeSpan = activeSpan
            }
        databaseEnv =
          DatabaseEnv
            { dbLogger = depsLogger
            , connectionPool = dbPool
            }
        appEnv =
          AppEnv
            { appLogger = depsLogger
            , databaseEnv = databaseEnv
            , tracingEnv = tracingEnv
            }
    runAppServant appEnv action

healthHandler :: App NoContent
healthHandler = pure NoContent

layoutHandler :: App Text
layoutHandler = pure $ layout (Proxy @Api)

AppAuthenticated.hs

module AppAuthenticated (
  AppAuthenticatedDeps (..),
  AppAuthenticatedEnv (..),
  AppAuthenticated (..),
  HasAppAuthenticated (..),
  runAppAuthenticated,
  listOrganizationsHandler,
) where

import Relude

import Api (
  AuthorizationHeader,
  ListOrganizationsResponse,
 )
import App (App (..), AppEnv (..), HasApp (..))
import Authentication (
  AuthEnv (..),
  AuthKey,
  HasAuth (..),
  authenticateUser,
  getUserId,
 )
import Control.Exception (throwIO)
import Control.Monad.Logger (MonadLogger (..))
import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
import Database (HasDatabase (..))
import Logging (HasLogFunc (..), 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
  , authEnv :: AuthEnv
  , appOrganizationService :: OrganizationService
  }

newtype AppAuthenticated a = AppAuthenticated
  { unAppAuthenticated :: ReaderT AppAuthenticatedEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppAuthenticatedEnv
    )

instance MonadLogger AppAuthenticated where
  monadLoggerLog = monadLoggerLogImpl

class
  (HasApp env, HasAuth env, HasOrganizationService env) =>
  HasAppAuthenticated env
  where
  getAppAuthenticated :: env -> AppAuthenticatedEnv

instance HasAppAuthenticated AppAuthenticatedEnv where
  getAppAuthenticated = identity

instance HasAuth AppAuthenticatedEnv where
  getAuth = authEnv

instance HasOrganizationService AppAuthenticatedEnv where
  getOrganizationService = appOrganizationService

instance HasApp AppAuthenticatedEnv where
  getApp = appEnv

instance HasLogFunc AppAuthenticatedEnv where
  getLogFunc = getLogFunc . getApp

instance HasDatabase AppAuthenticatedEnv where
  getDatabase = getDatabase . getApp

instance HasTracing AppAuthenticatedEnv where
  getTracing = getTracing . getApp

runAppAuthenticated
  :: AppAuthenticatedDeps
  -> Maybe AuthorizationHeader
  -> AppAuthenticated a
  -> App a
runAppAuthenticated
  AppAuthenticatedDeps {authKey, organizationService}
  maybeAuthHeader
  action = do
    userId <- authenticateUser authKey maybeAuthHeader
    let authEnv =
          AuthEnv
            { userId = userId
            }
        mapEnv appEnv =
          AppAuthenticatedEnv
            { appEnv = appEnv
            , authEnv = authEnv
            , appOrganizationService = organizationService
            }
    App $ withReaderT mapEnv (unAppAuthenticated action)

listOrganizationsHandler :: AppAuthenticated ListOrganizationsResponse
listOrganizationsHandler = traced "list_organizations" $ do
  userId <- getUserId
  organizations <- fetchUserOrganizations userId
  logInfo
    $ "fetched organizations"
    :# [ "user_id" .= userId
       , "organizations" .= map organizationId organizations
       ]
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

AppProject.hs

module AppProject (
  Project (..),
  AppProjectEnv (..),
  AppProject (..),
  HasAppProject (..),
  runAppProject,
  createProjectHandler,
  getProjectHandler,
  getProjectOrganization,
  findProjectById,
) where

import Relude

import Api (
  CreateProjectRequest,
  CreateProjectResponse,
  GetProjectResponse,
  OrganizationId,
  ProjectId,
 )
import App (HasApp (..))
import AppAuthenticated (
  AppAuthenticated (..),
  AppAuthenticatedEnv (..),
  HasAppAuthenticated (..),
 )
import Authentication (HasAuth (..), getUserId)
import Control.Exception (throwIO)
import Control.Monad.Logger (MonadLogger (..))
import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
import Database (Database, HasDatabase (..), query, runDatabase)
import Logging (HasLogFunc (..), 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
  }

newtype AppProject a = AppProject
  { unAppProject :: ReaderT AppProjectEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppProjectEnv
    )

instance MonadLogger AppProject where
  monadLoggerLog = monadLoggerLogImpl

class (HasAppAuthenticated env) => HasAppProject env where
  getAppProject :: env -> AppProjectEnv

instance HasAppProject AppProjectEnv where
  getAppProject = identity

instance HasAppAuthenticated AppProjectEnv where
  getAppAuthenticated = appAuthenticatedEnv

instance HasAuth AppProjectEnv where
  getAuth = getAuth . getAppAuthenticated

instance HasOrganizationService AppProjectEnv where
  getOrganizationService = getOrganizationService . getAppAuthenticated

instance HasApp AppProjectEnv where
  getApp = getApp . getAppAuthenticated

instance HasLogFunc AppProjectEnv where
  getLogFunc = getLogFunc . getApp

instance HasDatabase AppProjectEnv where
  getDatabase = getDatabase . getApp

instance HasTracing AppProjectEnv where
  getTracing = getTracing . getApp

runAppProject
  :: OrganizationId
  -> AppProject a
  -> AppAuthenticated a
runAppProject organizationId action = do
  projectOrganization <- fetchOrganization organizationId
  let mapEnv appAuthenticatedEnv =
        AppProjectEnv
          { appAuthenticatedEnv = appAuthenticatedEnv
          , projectOrganization = projectOrganization
          }
  AppAuthenticated $ withReaderT mapEnv (unAppProject action)

createProjectHandler :: CreateProjectRequest -> AppProject CreateProjectResponse
createProjectHandler projectName = traced "create_project" $ do
  userId <- getUserId
  organizationId <- organizationId <$> getProjectOrganization
  _ <-
    runDatabase
      $ query
        "insert into projects (name, organization_id) values (?, ?) returning id"
        (projectName, organizationId)
  logInfo
    $ "created project"
    :# [ "user_id" .= userId
       , "organization_id" .= organizationId
       ]
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getProjectHandler :: ProjectId -> AppProject GetProjectResponse
getProjectHandler projectId = traced "get_project" $ do
  userId <- getUserId
  organizationId <- organizationId <$> getProjectOrganization
  _ <- runDatabase $ findProjectById projectId
  logInfo
    $ "fetched project"
    :# [ "user_id" .= userId
       , "organization_id" .= organizationId
       ]
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getProjectOrganization
  :: (MonadReader env m, HasAppProject env) => m Organization
getProjectOrganization =
  asks (projectOrganization . getAppProject)

findProjectById :: ProjectId -> Database (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 (..),
  AppTicket (..),
  HasAppTicket (..),
  runAppTicket,
  createTicketHandler,
  getTicketHandler,
  getTicketProject,
) where

import Relude

import Api (
  CreateTicketRequest,
  CreateTicketResponse,
  GetTicketResponse,
  ProjectId,
  TicketId,
 )
import App (HasApp (..))
import AppAuthenticated (HasAppAuthenticated (..))
import AppProject (
  AppProject (..),
  AppProjectEnv,
  HasAppProject (..),
  Project (..),
  findProjectById,
  getProjectOrganization,
 )
import Authentication (HasAuth (..), getUserId)
import Control.Exception (throwIO)
import Control.Monad.Logger (MonadLogger (..))
import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
import Database (HasDatabase (..), query, runDatabase)
import Logging (HasLogFunc (..), monadLoggerLogImpl)
import Organization (HasOrganizationService (..), Organization (organizationId))
import Servant (ServerError (..), err404, err500)
import Tracing (HasTracing (..), traced)

data AppTicketEnv = AppTicketEnv
  { appProjectEnv :: AppProjectEnv
  , ticketProject :: Project
  }

newtype AppTicket a = AppTicket
  { unAppTicket :: ReaderT AppTicketEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppTicketEnv
    )

instance MonadLogger AppTicket where
  monadLoggerLog = monadLoggerLogImpl

class (HasAppProject env) => HasAppTicket env where
  getAppTicket :: env -> AppTicketEnv

instance HasAppTicket AppTicketEnv where
  getAppTicket = identity

instance HasAppProject AppTicketEnv where
  getAppProject = appProjectEnv

instance HasAppAuthenticated AppTicketEnv where
  getAppAuthenticated = getAppAuthenticated . getAppProject

instance HasAuth AppTicketEnv where
  getAuth = getAuth . getAppAuthenticated

instance HasOrganizationService AppTicketEnv where
  getOrganizationService = getOrganizationService . getAppAuthenticated

instance HasApp AppTicketEnv where
  getApp = getApp . getAppAuthenticated . getAppProject

instance HasLogFunc AppTicketEnv where
  getLogFunc = getLogFunc . getApp

instance HasDatabase AppTicketEnv where
  getDatabase = getDatabase . getApp

instance HasTracing AppTicketEnv where
  getTracing = getTracing . getApp

runAppTicket
  :: ProjectId
  -> AppTicket a
  -> AppProject a
runAppTicket projectId action = do
  let projectNotFound :: AppProject Project
      projectNotFound =
        liftIO $ throwIO $ err404 {errBody = "Project not found"}
  maybeProject <- runDatabase (findProjectById projectId)
  project <- maybe projectNotFound pure maybeProject
  let mapEnv appProjectEnv =
        AppTicketEnv
          { appProjectEnv = appProjectEnv
          , ticketProject = project
          }
  AppProject $ withReaderT mapEnv (unAppTicket action)

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

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

getTicketProject
  :: (MonadReader env m, HasAppTicket env) => m Project
getTicketProject =
  asks (ticketProject . getAppTicket)

Authentication.hs

-- | Fake authentication
module Authentication (
  AuthKey,
  UserId,
  parseAuthHeader,
  authenticateUser,
  AuthEnv (..),
  HasAuth (..),
  MonadAuth,
  getUserId,
) where

import Relude

import Api (AuthorizationHeader)
import Control.Exception (throwIO)
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 _ ->
      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

Database.hs

-- | Fake database
module Database (
  Pool,
  Connection,
  createDbPool,
  DatabaseEnv (..),
  HasDatabase (..),
  Database (..),
  MonadDatabase,
  runDatabaseIO,
  runDatabase,
  query,
) where

import Relude

import Control.Monad.Logger.Aeson (Message ((:#)), logDebug, runLoggingT, (.=))
import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
import Logging (LogFunc)

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

Logging.hs

module Logging (
  LogFunc,
  HasLogFunc (..),
  MonadLogFunc,
  monadLoggerLogImpl,
) where

import Relude

import Control.Monad.Logger (
  Loc,
  LogLevel,
  LogSource,
  LogStr,
  ToLogStr (toLogStr),
 )

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

class HasLogFunc env where
  getLogFunc :: env -> LogFunc

type MonadLogFunc env m = (MonadReader env m, HasLogFunc env)

monadLoggerLogImpl
  :: (MonadLogFunc env m, ToLogStr msg, MonadIO m)
  => Loc
  -> LogSource
  -> LogLevel
  -> msg
  -> m ()
monadLoggerLogImpl loc logSource logLevel msg = do
  logger <- asks getLogFunc
  liftIO $ logger loc logSource logLevel (toLogStr msg)

Main.hs

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

module Main (main) where

import Relude

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 Servant (serve)
import Server (server)
import Tracing (createTracer)

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
      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 (..),
  MonadOrganizationService,
  fetchUserOrganizations,
  fetchOrganization,
) where

import Relude

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

type MonadOrganizationService env m =
  (MonadReader env m, HasOrganizationService env)

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
  :: (MonadOrganizationService env m, MonadIO m)
  => UserId
  -> m [Organization]
fetchUserOrganizations userId = do
  service <- asks getOrganizationService
  liftIO $ fetchUserOrganizationsImpl service userId

fetchOrganization
  :: (MonadOrganizationService env m, MonadIO m)
  => OrganizationId
  -> m Organization
fetchOrganization organizationId = do
  service <- asks getOrganizationService
  liftIO $ fetchOrganizationImpl service organizationId

servant-nested-apis.cabal

cabal-version: 3.0
name: servant-nested-apis
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 servant-nested-apis
    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 Relude

import Api (
  AuthenticatedApi (..),
  AuthorizationHeader,
  OrganizationId,
  ProjectApi (..),
  ProjectId,
  RootApi (..),
  TicketApi (..),
  TraceParentHeader,
 )
import App (App, AppDeps, healthHandler, layoutHandler, runApp)
import AppAuthenticated (
  AppAuthenticated,
  AppAuthenticatedDeps (..),
  listOrganizationsHandler,
  runAppAuthenticated,
 )
import AppProject (
  AppProject,
  createProjectHandler,
  getProjectHandler,
  runAppProject,
 )
import AppTicket (
  AppTicket,
  createTicketHandler,
  getTicketHandler,
  runAppTicket,
 )
import Servant (HasServer (ServerT), NamedRoutes, Server, hoistServer)

server
  :: AppDeps
  -> AppAuthenticatedDeps
  -> Maybe TraceParentHeader
  -> Server (NamedRoutes RootApi)
server appDeps appAuthenticatedDeps maybeTraceParentHeader =
  hoistServer
    (Proxy @(NamedRoutes RootApi))
    (runApp appDeps maybeTraceParentHeader)
    (rootServer appAuthenticatedDeps)

rootServer :: AppAuthenticatedDeps -> ServerT (NamedRoutes RootApi) App
rootServer appAuthenticatedDeps =
  RootApi
    { health = healthHandler
    , layout = layoutHandler
    , authenticatedApi = authenticatedServer'
    }
  where
    authenticatedServer' maybeAuthHeader =
      hoistServer
        (Proxy @(NamedRoutes AuthenticatedApi))
        (runAppAuthenticated appAuthenticatedDeps maybeAuthHeader)
        (authenticatedServer maybeAuthHeader)

authenticatedServer
  :: Maybe AuthorizationHeader
  -> ServerT (NamedRoutes AuthenticatedApi) AppAuthenticated
authenticatedServer _maybeAuthHeader =
  AuthenticatedApi
    { listOrganizations = listOrganizationsHandler
    , projectApi = projectServer'
    }
  where
    projectServer' organizationId =
      hoistServer
        (Proxy @(NamedRoutes ProjectApi))
        (runAppProject organizationId)
        (projectServer organizationId)

projectServer :: OrganizationId -> ServerT (NamedRoutes ProjectApi) AppProject
projectServer _organizationId =
  ProjectApi
    { createProject = createProjectHandler
    , getProject = getProjectHandler
    , ticketApi = ticketServer'
    }
  where
    ticketServer' projectId =
      hoistServer
        (Proxy @(NamedRoutes TicketApi))
        (runAppTicket projectId)
        (ticketServer projectId)

ticketServer :: ProjectId -> ServerT (NamedRoutes TicketApi) AppTicket
ticketServer _projectId =
  TicketApi
    { createTicket = createTicketHandler
    , getTicket = getTicketHandler
    }

Tracing.hs

-- | Fake tracing
module Tracing (
  Tracer,
  Span,
  TracingEnv (..),
  HasTracing (..),
  MonadTracing,
  createTracer,
  createNewSpan,
  traced,
) where

import Relude

import Api (TraceParentHeader)

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