Skip to content

Instantly share code, notes, and snippets.

@nicolashery

nicolashery/.servant-nested-apis.md

Last active December 13, 2023 21:43
Show Gist options

  • Select an option

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

Select an option

Learn more about clone URLs
Save nicolashery/4dcf7003564c576d0d2f4872447c7b02 to your computer and use it in GitHub Desktop.
Download ZIP

Revisions

  1. nicolashery revised this gist Nov 23, 2023. 4 changed files with 12 additions and 13 deletions.
    4 changes: 2 additions & 2 deletions AppAuthenticated.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -101,9 +101,9 @@ runAppAuthenticated
    AuthEnv
    { userId = userId
    }
    mapEnv appEnv' =
    mapEnv appEnv =
    AppAuthenticatedEnv
    { appEnv = appEnv'
    { appEnv = appEnv
    , authEnv = authEnv
    , appOrganizationService = organizationService
    }
    4 changes: 2 additions & 2 deletions AppProject.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -96,9 +96,9 @@ runAppProject
    -> AppAuthenticated a
    runAppProject organizationId action = do
    projectOrganization <- fetchOrganization organizationId
    let mapEnv appAuthenticatedEnv' =
    let mapEnv appAuthenticatedEnv =
    AppProjectEnv
    { appAuthenticatedEnv = appAuthenticatedEnv'
    { appAuthenticatedEnv = appAuthenticatedEnv
    , projectOrganization = projectOrganization
    }
    AppAuthenticated $ withReaderT mapEnv (unAppProject action)
    4 changes: 2 additions & 2 deletions AppTicket.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -96,9 +96,9 @@ runAppTicket projectId action = do
    liftIO $ throwIO $ err404 {errBody = "Project not found"}
    maybeProject <- runDatabase (findProjectById projectId)
    project <- maybe projectNotFound pure maybeProject
    let mapEnv appProjectEnv' =
    let mapEnv appProjectEnv =
    AppTicketEnv
    { appProjectEnv = appProjectEnv'
    { appProjectEnv = appProjectEnv
    , ticketProject = project
    }
    AppProject $ withReaderT mapEnv (unAppTicket action)
    13 changes: 6 additions & 7 deletions Server.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -31,21 +31,20 @@ import AppTicket (
    getTicketHandler,
    runAppTicket,
    )
    import Servant (Handler, NamedRoutes, hoistServer)
    import Servant.Server.Generic (AsServerT)
    import Servant (HasServer (ServerT), NamedRoutes, Server, hoistServer)

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

    rootServer :: AppAuthenticatedDeps -> RootApi (AsServerT App)
    rootServer :: AppAuthenticatedDeps -> ServerT (NamedRoutes RootApi) App
    rootServer appAuthenticatedDeps =
    RootApi
    { health = healthHandler
    @@ -61,7 +60,7 @@ rootServer appAuthenticatedDeps =

    authenticatedServer
    :: Maybe AuthorizationHeader
    -> AuthenticatedApi (AsServerT AppAuthenticated)
    -> ServerT (NamedRoutes AuthenticatedApi) AppAuthenticated
    authenticatedServer _maybeAuthHeader =
    AuthenticatedApi
    { listOrganizations = listOrganizationsHandler
    @@ -74,7 +73,7 @@ authenticatedServer _maybeAuthHeader =
    (runAppProject organizationId)
    (projectServer organizationId)

    projectServer :: OrganizationId -> ProjectApi (AsServerT AppProject)
    projectServer :: OrganizationId -> ServerT (NamedRoutes ProjectApi) AppProject
    projectServer _organizationId =
    ProjectApi
    { createProject = createProjectHandler
    @@ -88,7 +87,7 @@ projectServer _organizationId =
    (runAppTicket projectId)
    (ticketServer projectId)

    ticketServer :: ProjectId -> TicketApi (AsServerT AppTicket)
    ticketServer :: ProjectId -> ServerT (NamedRoutes TicketApi) AppTicket
    ticketServer _projectId =
    TicketApi
    { createTicket = createTicketHandler
  2. nicolashery revised this gist Nov 23, 2023. 7 changed files with 65 additions and 60 deletions.
    26 changes: 13 additions & 13 deletions Api.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -42,57 +42,57 @@ data RootApi mode = RootApi
    { health
    :: mode
    :- "health"
    :> GetNoContent
    :> GetNoContent
    , layout
    :: mode
    :- "layout"
    :> Get '[PlainText] LayoutResponse
    :> Get '[PlainText] LayoutResponse
    , authenticatedApi
    :: mode
    :- Header "Authorization" AuthorizationHeader
    :> NamedRoutes AuthenticatedApi
    :> NamedRoutes AuthenticatedApi
    }
    deriving stock (Generic)

    data AuthenticatedApi mode = AuthenticatedApi
    { listOrganizations
    :: mode
    :- "organizations"
    :> Get '[PlainText] ListOrganizationsResponse
    :> Get '[PlainText] ListOrganizationsResponse
    , projectApi
    :: mode
    :- "organizations"
    :> Capture "organizationId" OrganizationId
    :> "projects"
    :> NamedRoutes ProjectApi
    :> Capture "organizationId" OrganizationId
    :> "projects"
    :> NamedRoutes ProjectApi
    }
    deriving stock (Generic)

    data ProjectApi mode = ProjectApi
    { createProject
    :: mode
    :- ReqBody '[PlainText] CreateProjectRequest
    :> Post '[PlainText] CreateProjectResponse
    :> Post '[PlainText] CreateProjectResponse
    , getProject
    :: mode
    :- Capture "projectId" ProjectId
    :> Get '[PlainText] GetProjectResponse
    :> Get '[PlainText] GetProjectResponse
    , ticketApi
    :: mode
    :- Capture "projectId" ProjectId
    :> "tickets"
    :> NamedRoutes TicketApi
    :> "tickets"
    :> NamedRoutes TicketApi
    }
    deriving stock (Generic)

    data TicketApi mode = TicketApi
    { createTicket
    :: mode
    :- ReqBody '[PlainText] CreateTicketRequest
    :> Post '[PlainText] CreateTicketResponse
    :> Post '[PlainText] CreateTicketResponse
    , getTicket
    :: mode
    :- Capture "ticketId" TicketId
    :> Get '[PlainText] GetTicketResponse
    :> Get '[PlainText] GetTicketResponse
    }
    deriving stock (Generic)
    10 changes: 5 additions & 5 deletions AppAuthenticated.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -113,9 +113,9 @@ listOrganizationsHandler :: AppAuthenticated ListOrganizationsResponse
    listOrganizationsHandler = traced "list_organizations" $ do
    userId <- getUserId
    organizations <- fetchUserOrganizations userId
    logInfo $
    "fetched organizations"
    :# [ "user_id" .= userId
    , "organizations" .= map organizationId organizations
    ]
    logInfo
    $ "fetched organizations"
    :# [ "user_id" .= userId
    , "organizations" .= map organizationId organizations
    ]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}
    29 changes: 15 additions & 14 deletions AppProject.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -108,27 +108,27 @@ createProjectHandler projectName = traced "create_project" $ do
    userId <- getUserId
    organizationId <- organizationId <$> getProjectOrganization
    _ <-
    runDatabase $
    query
    runDatabase
    $ query
    "insert into projects (name, organization_id) values (?, ?) returning id"
    (projectName, organizationId)
    logInfo $
    "created project"
    :# [ "user_id" .= userId
    , "organization_id" .= 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
    ]
    logInfo
    $ "fetched project"
    :# [ "user_id" .= userId
    , "organization_id" .= organizationId
    ]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

    getProjectOrganization
    @@ -142,8 +142,9 @@ findProjectById projectId = do
    query
    "select id, name from projects where id = ?"
    projectId
    pure . Just $
    Project
    pure
    . Just
    $ Project
    { projectId = projectId
    , name = "My project"
    }
    32 changes: 16 additions & 16 deletions AppTicket.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -109,16 +109,16 @@ createTicketHandler ticketName = traced "create_ticket" $ do
    organizationId <- organizationId <$> getProjectOrganization
    projectId <- projectId <$> getTicketProject
    _ <-
    runDatabase $
    query
    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
    ]
    logInfo
    $ "created ticket"
    :# [ "user_id" .= userId
    , "organization_id" .= organizationId
    , "project_id" .= projectId
    ]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

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

    getTicketProject
    5 changes: 3 additions & 2 deletions Authentication.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -31,8 +31,9 @@ authenticateUser
    authenticateUser _authKey maybeAuthHeader =
    case parseAuthHeader maybeAuthHeader of
    Left _ ->
    liftIO . throwIO $
    err401
    liftIO
    . throwIO
    $ err401
    { errBody = "Missing or invalid 'Authorization' header"
    }
    Right userId -> pure userId
    16 changes: 9 additions & 7 deletions Database.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -22,8 +22,8 @@ data Connection = Connection

    createDbPool :: Text -> Int -> IO (Pool Connection)
    createDbPool _databaseUrl poolSize = do
    newPool $
    defaultPoolConfig
    newPool
    $ defaultPoolConfig
    create
    destroy
    poolTtl
    @@ -69,11 +69,13 @@ runDatabase action = do
    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)
    ]
    void
    . flip runLoggingT logger
    . logDebug
    $ "Database.query"
    :# [ "query" .= q
    , "parameters" .= (show parameters :: Text)
    ]
    withConnection $ const (pure [])

    withConnection :: (Connection -> IO a) -> Database a
    7 changes: 4 additions & 3 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -25,13 +25,14 @@ main :: IO ()
    main = do
    authKey <- toText . fromMaybe "abc123" <$> lookupEnv "AUTH_KEY"
    projectServiceUrl <-
    toText . fromMaybe "http://localhost:3001"
    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}
    newManager
    $ defaultManagerSettings {managerConnCount = 20}
    let port = 3000
    appDeps =
    AppDeps
  3. nicolashery revised this gist Jun 7, 2023. 1 changed file with 15 additions and 0 deletions.
    15 changes: 15 additions & 0 deletions .servant-nested-apis.md
    View file
    Original file line number Diff line number Diff line change
    @@ -16,6 +16,21 @@ Environments, from parent to child (or base to extended):
    - `HasAppProject env` (everything from `AppProject`)
    - `ticketProject`

    Files:

    - [`Api.hs`](#file-api-hs)
    - [`App.hs`](#file-app-hs)
    - [`AppAuthenticated.hs`](#file-appauthenticated-hs)
    - [`AppProject.hs`](#file-appproject-hs)
    - [`AppTicket.hs`](#file-appticket-hs)
    - [`Authentication.hs`](#file-authentication-hs)
    - [`Database.hs`](#file-database-hs)
    - [`Logging.hs`](#file-logging-hs)
    - [`Main.hs`](#file-main-hs)
    - [`Organization.hs`](#file-organization-hs)
    - [`Server.hs`](#file-server-hs)
    - [`Tracing.hs`](#file-tracing-hs)

    ```mermaid
    flowchart TB
    App["App"]
  4. nicolashery revised this gist Jun 7, 2023. 1 changed file with 44 additions and 1 deletion.
    45 changes: 44 additions & 1 deletion .servant-nested-apis.md
    View file
    Original file line number Diff line number Diff line change
    @@ -1 +1,44 @@
    Nesting APIs and `ReaderT` environments in Haskell's Servant
    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`

    ```mermaid
    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
    ```
  5. nicolashery revised this gist Jun 7, 2023. 4 changed files with 51 additions and 14 deletions.
    15 changes: 11 additions & 4 deletions AppAuthenticated.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -27,8 +27,10 @@ import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
    import Database (HasDatabase (..))
    import Logging (HasLogFunc (..), monadLoggerLogImpl)
    import Organization (
    HasOrganizationService (..),
    Organization (organizationId),
    OrganizationService (fetchUserOrganizations),
    OrganizationService,
    fetchUserOrganizations,
    )
    import Servant (ServerError (..), err500)
    import Tracing (HasTracing (..), traced)
    @@ -58,7 +60,10 @@ newtype AppAuthenticated a = AppAuthenticated
    instance MonadLogger AppAuthenticated where
    monadLoggerLog = monadLoggerLogImpl

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

    instance HasAppAuthenticated AppAuthenticatedEnv where
    @@ -67,6 +72,9 @@ instance HasAppAuthenticated AppAuthenticatedEnv where
    instance HasAuth AppAuthenticatedEnv where
    getAuth = authEnv

    instance HasOrganizationService AppAuthenticatedEnv where
    getOrganizationService = appOrganizationService

    instance HasApp AppAuthenticatedEnv where
    getApp = appEnv

    @@ -104,8 +112,7 @@ runAppAuthenticated
    listOrganizationsHandler :: AppAuthenticated ListOrganizationsResponse
    listOrganizationsHandler = traced "list_organizations" $ do
    userId <- getUserId
    organizationService <- asks appOrganizationService
    organizations <- liftIO $ fetchUserOrganizations organizationService userId
    organizations <- fetchUserOrganizations userId
    logInfo $
    "fetched organizations"
    :# [ "user_id" .= userId
    11 changes: 6 additions & 5 deletions AppProject.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -32,8 +32,9 @@ import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
    import Database (Database, HasDatabase (..), query, runDatabase)
    import Logging (HasLogFunc (..), monadLoggerLogImpl)
    import Organization (
    HasOrganizationService (..),
    Organization (organizationId),
    OrganizationService (fetchOrganization),
    fetchOrganization,
    )
    import Servant (ServerError (..), err500)
    import Tracing (HasTracing (..), traced)
    @@ -74,6 +75,9 @@ instance HasAppAuthenticated AppProjectEnv where
    instance HasAuth AppProjectEnv where
    getAuth = getAuth . getAppAuthenticated

    instance HasOrganizationService AppProjectEnv where
    getOrganizationService = getOrganizationService . getAppAuthenticated

    instance HasApp AppProjectEnv where
    getApp = getApp . getAppAuthenticated

    @@ -91,10 +95,7 @@ runAppProject
    -> AppProject a
    -> AppAuthenticated a
    runAppProject organizationId action = do
    organizationService <- asks appOrganizationService
    projectOrganization <-
    liftIO $
    fetchOrganization organizationService organizationId
    projectOrganization <- fetchOrganization organizationId
    let mapEnv appAuthenticatedEnv' =
    AppProjectEnv
    { appAuthenticatedEnv = appAuthenticatedEnv'
    5 changes: 4 additions & 1 deletion AppTicket.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -33,7 +33,7 @@ import Control.Monad.Logger (MonadLogger (..))
    import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
    import Database (HasDatabase (..), query, runDatabase)
    import Logging (HasLogFunc (..), monadLoggerLogImpl)
    import Organization (Organization (organizationId))
    import Organization (HasOrganizationService (..), Organization (organizationId))
    import Servant (ServerError (..), err404, err500)
    import Tracing (HasTracing (..), traced)

    @@ -71,6 +71,9 @@ instance HasAppAuthenticated AppTicketEnv where
    instance HasAuth AppTicketEnv where
    getAuth = getAuth . getAppAuthenticated

    instance HasOrganizationService AppTicketEnv where
    getOrganizationService = getOrganizationService . getAppAuthenticated

    instance HasApp AppTicketEnv where
    getApp = getApp . getAppAuthenticated . getAppProject

    34 changes: 30 additions & 4 deletions Organization.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -3,6 +3,10 @@ module Organization (
    Organization (..),
    OrganizationService (..),
    createOrganizationServiceClient,
    HasOrganizationService (..),
    MonadOrganizationService,
    fetchUserOrganizations,
    fetchOrganization,
    ) where

    import Relude
    @@ -17,14 +21,20 @@ data Organization = Organization
    }

    data OrganizationService = OrganizationService
    { fetchUserOrganizations :: UserId -> IO [Organization]
    , fetchOrganization :: OrganizationId -> IO Organization
    { 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
    { fetchUserOrganizations =
    { fetchUserOrganizationsImpl =
    \_userId ->
    pure
    [ Organization
    @@ -36,10 +46,26 @@ createOrganizationServiceClient _httpManager _serviceBaseUrl =
    , name = "Org 2"
    }
    ]
    , fetchOrganization = \organizationId ->
    , 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
  6. nicolashery revised this gist Jun 6, 2023. 5 changed files with 38 additions and 35 deletions.
    11 changes: 4 additions & 7 deletions App.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -1,5 +1,5 @@
    module App (
    Dependencies (..),
    AppDeps (..),
    AppEnv (..),
    App (..),
    HasApp (..),
    @@ -15,16 +15,13 @@ import Control.Exception (try)
    import Control.Monad.Logger (MonadLogger (..))
    import Database (Connection, DatabaseEnv (..), HasDatabase (..), Pool)
    import Logging (HasLogFunc (..), LogFunc, monadLoggerLogImpl)
    import Organization (OrganizationService)
    import Servant (Handler (..), NoContent (..), layout)
    import Tracing (HasTracing (..), Tracer, TracingEnv (..), createNewSpan)

    data Dependencies = Dependencies
    data AppDeps = AppDeps
    { dbPool :: Pool Connection
    , depsLogger :: LogFunc
    , tracer :: Tracer
    , authKey :: Text
    , organizationService :: OrganizationService
    }

    data AppEnv = AppEnv
    @@ -72,9 +69,9 @@ runAppServant
    runAppServant appEnv action =
    Servant.Handler . ExceptT . try $ runAppIO appEnv action

    runApp :: Dependencies -> Maybe TraceParentHeader -> App a -> Handler a
    runApp :: AppDeps -> Maybe TraceParentHeader -> App a -> Handler a
    runApp
    Dependencies {dbPool, depsLogger, tracer}
    AppDeps {dbPool, depsLogger, tracer}
    maybeTraceParentHeader
    action = do
    activeSpan <- createNewSpan maybeTraceParentHeader >>= newIORef
    18 changes: 12 additions & 6 deletions AppAuthenticated.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -1,5 +1,5 @@
    module AppAuthenticated (
    DependenciesAuthenticated (..),
    AppAuthenticatedDeps (..),
    AppAuthenticatedEnv (..),
    AppAuthenticated (..),
    HasAppAuthenticated (..),
    @@ -14,7 +14,13 @@ import Api (
    ListOrganizationsResponse,
    )
    import App (App (..), AppEnv (..), HasApp (..))
    import Authentication (AuthEnv (..), HasAuth (..), authenticateUser, getUserId)
    import Authentication (
    AuthEnv (..),
    AuthKey,
    HasAuth (..),
    authenticateUser,
    getUserId,
    )
    import Control.Exception (throwIO)
    import Control.Monad.Logger (MonadLogger (..))
    import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
    @@ -27,8 +33,8 @@ import Organization (
    import Servant (ServerError (..), err500)
    import Tracing (HasTracing (..), traced)

    data DependenciesAuthenticated = DependenciesAuthenticated
    { authKey :: Text
    data AppAuthenticatedDeps = AppAuthenticatedDeps
    { authKey :: AuthKey
    , organizationService :: OrganizationService
    }

    @@ -74,12 +80,12 @@ instance HasTracing AppAuthenticatedEnv where
    getTracing = getTracing . getApp

    runAppAuthenticated
    :: DependenciesAuthenticated
    :: AppAuthenticatedDeps
    -> Maybe AuthorizationHeader
    -> AppAuthenticated a
    -> App a
    runAppAuthenticated
    DependenciesAuthenticated {authKey, organizationService}
    AppAuthenticatedDeps {authKey, organizationService}
    maybeAuthHeader
    action = do
    userId <- authenticateUser authKey maybeAuthHeader
    4 changes: 3 additions & 1 deletion Authentication.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -1,5 +1,6 @@
    -- | Fake authentication
    module Authentication (
    AuthKey,
    UserId,
    parseAuthHeader,
    authenticateUser,
    @@ -15,6 +16,7 @@ import Api (AuthorizationHeader)
    import Control.Exception (throwIO)
    import Servant (err401, errBody)

    type AuthKey = Text
    type UserId = Text

    parseAuthHeader :: Maybe AuthorizationHeader -> Either Text UserId
    @@ -23,7 +25,7 @@ parseAuthHeader _ = Right "d42ed530-adba-41f0-99af-60bd6c476617"

    authenticateUser
    :: (MonadIO m)
    => Text
    => AuthKey
    -> Maybe AuthorizationHeader
    -> m UserId
    authenticateUser _authKey maybeAuthHeader =
    14 changes: 9 additions & 5 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -6,7 +6,8 @@ module Main (main) where
    import Relude

    import Api (Api)
    import App (Dependencies (..))
    import App (AppDeps (..))
    import AppAuthenticated (AppAuthenticatedDeps (..))
    import Control.Monad.Logger.Aeson qualified as Logger (defaultOutput)
    import Database (createDbPool)
    import Network.HTTP.Client (
    @@ -32,16 +33,19 @@ main = do
    newManager $
    defaultManagerSettings {managerConnCount = 20}
    let port = 3000
    dependencies =
    Dependencies
    appDeps =
    AppDeps
    { dbPool = dbPool
    , depsLogger = Logger.defaultOutput stdout
    , tracer = tracer
    , authKey = authKey
    }
    appAuthenticatedDeps =
    AppAuthenticatedDeps
    { authKey = authKey
    , organizationService =
    createOrganizationServiceClient
    httpManager
    projectServiceUrl
    }
    waiApp = serve (Proxy @Api) (server dependencies)
    waiApp = serve (Proxy @Api) (server appDeps appAuthenticatedDeps)
    Warp.run port waiApp
    26 changes: 10 additions & 16 deletions Server.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -12,10 +12,10 @@ import Api (
    TicketApi (..),
    TraceParentHeader,
    )
    import App (App, Dependencies (..), healthHandler, layoutHandler, runApp)
    import App (App, AppDeps, healthHandler, layoutHandler, runApp)
    import AppAuthenticated (
    AppAuthenticated,
    DependenciesAuthenticated (..),
    AppAuthenticatedDeps (..),
    listOrganizationsHandler,
    runAppAuthenticated,
    )
    @@ -35,17 +35,18 @@ import Servant (Handler, NamedRoutes, hoistServer)
    import Servant.Server.Generic (AsServerT)

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

    rootServer :: Dependencies -> RootApi (AsServerT App)
    rootServer deps =
    rootServer :: AppAuthenticatedDeps -> RootApi (AsServerT App)
    rootServer appAuthenticatedDeps =
    RootApi
    { health = healthHandler
    , layout = layoutHandler
    @@ -55,16 +56,9 @@ rootServer deps =
    authenticatedServer' maybeAuthHeader =
    hoistServer
    (Proxy @(NamedRoutes AuthenticatedApi))
    (runAppAuthenticated (getDependenciesAuthenticated deps) maybeAuthHeader)
    (runAppAuthenticated appAuthenticatedDeps maybeAuthHeader)
    (authenticatedServer maybeAuthHeader)

    getDependenciesAuthenticated :: Dependencies -> DependenciesAuthenticated
    getDependenciesAuthenticated Dependencies {authKey, organizationService} =
    DependenciesAuthenticated
    { authKey = authKey
    , organizationService = organizationService
    }

    authenticatedServer
    :: Maybe AuthorizationHeader
    -> AuthenticatedApi (AsServerT AppAuthenticated)
  7. nicolashery revised this gist Jun 6, 2023. 8 changed files with 616 additions and 518 deletions.
    103 changes: 103 additions & 0 deletions App.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,103 @@
    module App (
    Dependencies (..),
    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 Organization (OrganizationService)
    import Servant (Handler (..), NoContent (..), layout)
    import Tracing (HasTracing (..), Tracer, TracingEnv (..), createNewSpan)

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

    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 :: Dependencies -> Maybe TraceParentHeader -> App a -> Handler a
    runApp
    Dependencies {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)
    108 changes: 108 additions & 0 deletions AppAuthenticated.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,108 @@
    module AppAuthenticated (
    DependenciesAuthenticated (..),
    AppAuthenticatedEnv (..),
    AppAuthenticated (..),
    HasAppAuthenticated (..),
    runAppAuthenticated,
    listOrganizationsHandler,
    ) where

    import Relude

    import Api (
    AuthorizationHeader,
    ListOrganizationsResponse,
    )
    import App (App (..), AppEnv (..), HasApp (..))
    import Authentication (AuthEnv (..), 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 (
    Organization (organizationId),
    OrganizationService (fetchUserOrganizations),
    )
    import Servant (ServerError (..), err500)
    import Tracing (HasTracing (..), traced)

    data DependenciesAuthenticated = DependenciesAuthenticated
    { authKey :: Text
    , 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) => HasAppAuthenticated env where
    getAppAuthenticated :: env -> AppAuthenticatedEnv

    instance HasAppAuthenticated AppAuthenticatedEnv where
    getAppAuthenticated = identity

    instance HasAuth AppAuthenticatedEnv where
    getAuth = authEnv

    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
    :: DependenciesAuthenticated
    -> Maybe AuthorizationHeader
    -> AppAuthenticated a
    -> App a
    runAppAuthenticated
    DependenciesAuthenticated {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
    organizationService <- asks appOrganizationService
    organizations <- liftIO $ fetchUserOrganizations organizationService userId
    logInfo $
    "fetched organizations"
    :# [ "user_id" .= userId
    , "organizations" .= map organizationId organizations
    ]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}
    148 changes: 148 additions & 0 deletions AppProject.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,148 @@
    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 (
    Organization (organizationId),
    OrganizationService (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 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
    organizationService <- asks appOrganizationService
    projectOrganization <-
    liftIO $
    fetchOrganization organizationService 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"
    }
    142 changes: 142 additions & 0 deletions AppTicket.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,142 @@
    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 (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 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)
    1 change: 1 addition & 0 deletions Database.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -1,5 +1,6 @@
    -- | Fake database
    module Database (
    Pool,
    Connection,
    createDbPool,
    DatabaseEnv (..),
    525 changes: 7 additions & 518 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -5,531 +5,20 @@ module Main (main) where

    import Relude

    import Api (
    Api,
    AuthenticatedApi (..),
    AuthorizationHeader,
    OrganizationId,
    ProjectApi (..),
    ProjectId,
    RootApi (..),
    TicketApi (..),
    TicketId,
    TraceParentHeader,
    )
    import Api qualified
    import Authentication (
    AuthEnv (..),
    HasAuth (..),
    authenticateUser,
    getUserId,
    )
    import Control.Exception (throwIO, try)
    import Control.Monad.Logger (MonadLogger (..))
    import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
    import Api (Api)
    import App (Dependencies (..))
    import Control.Monad.Logger.Aeson qualified as Logger (defaultOutput)
    import Data.Pool (Pool)
    import Database (
    Connection,
    Database,
    DatabaseEnv (..),
    HasDatabase (..),
    createDbPool,
    query,
    runDatabase,
    )
    import Logging (HasLogFunc (..), LogFunc, monadLoggerLogImpl)
    import Database (createDbPool)
    import Network.HTTP.Client (
    defaultManagerSettings,
    managerConnCount,
    newManager,
    )
    import Network.Wai.Handler.Warp qualified as Warp
    import Organization (
    Organization (..),
    OrganizationService (..),
    createOrganizationServiceClient,
    )
    import Servant (
    NamedRoutes,
    NoContent (..),
    ServerError (..),
    err404,
    err500,
    hoistServer,
    serve,
    )
    import Servant qualified (Handler (..))
    import Servant.Server qualified as Servant (layout)
    import Servant.Server.Internal (AsServerT)
    import Tracing (
    HasTracing (..),
    Tracer,
    TracingEnv (..),
    createNewSpan,
    createTracer,
    traced,
    )

    -- App (Root)
    -- ----------------------------------------------------------------------------

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

    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 :: Dependencies -> Maybe TraceParentHeader -> App a -> Servant.Handler a
    runApp
    Dependencies {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

    server
    :: Dependencies
    -> Maybe TraceParentHeader
    -> RootApi (AsServerT Servant.Handler)
    server deps maybeTraceParentHeader =
    hoistServer
    (Proxy @(NamedRoutes RootApi))
    (runApp deps maybeTraceParentHeader)
    (rootServer deps)

    rootServer :: Dependencies -> RootApi (AsServerT App)
    rootServer deps =
    RootApi
    { health = healthHandler
    , layout = layoutHandler
    , authenticatedApi = authenticatedServer'
    }
    where
    authenticatedServer' maybeAuthHeader =
    hoistServer
    (Proxy @(NamedRoutes AuthenticatedApi))
    (runAppAuthenticated (getDependenciesAuthenticated deps) maybeAuthHeader)
    (authenticatedServer maybeAuthHeader)

    getDependenciesAuthenticated :: Dependencies -> DependenciesAuthenticated
    getDependenciesAuthenticated Dependencies {authKey, organizationService} =
    DependenciesAuthenticated
    { authKey = authKey
    , organizationService = organizationService
    }

    healthHandler :: App NoContent
    healthHandler = pure NoContent

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

    -- AppAuthenticated
    -- ----------------------------------------------------------------------------

    data DependenciesAuthenticated = DependenciesAuthenticated
    { authKey :: Text
    , 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) => HasAppAuthenticated env where
    getAppAuthenticated :: env -> AppAuthenticatedEnv

    instance HasAppAuthenticated AppAuthenticatedEnv where
    getAppAuthenticated = identity

    instance HasAuth AppAuthenticatedEnv where
    getAuth = authEnv

    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
    :: DependenciesAuthenticated
    -> Maybe AuthorizationHeader
    -> AppAuthenticated a
    -> App a
    runAppAuthenticated
    DependenciesAuthenticated {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 Api.ListOrganizationsResponse
    listOrganizationsHandler = traced "list_organizations" $ do
    userId <- getUserId
    organizationService <- asks appOrganizationService
    organizations <- liftIO $ fetchUserOrganizations organizationService userId
    logInfo $
    "fetched organizations"
    :# [ "user_id" .= userId
    , "organizations" .= map organizationId organizations
    ]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

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

    -- AppProject
    -- ----------------------------------------------------------------------------

    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 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
    organizationService <- asks appOrganizationService
    projectOrganization <-
    liftIO $
    fetchOrganization organizationService organizationId
    let mapEnv appAuthenticatedEnv' =
    AppProjectEnv
    { appAuthenticatedEnv = appAuthenticatedEnv'
    , projectOrganization = projectOrganization
    }
    AppAuthenticated $ withReaderT mapEnv (unAppProject action)

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

    createProjectHandler
    :: Api.CreateProjectRequest -> AppProject Api.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 Api.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
    -- ----------------------------------------------------------------------------

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

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

    createTicketHandler
    :: Api.CreateTicketRequest -> AppTicket Api.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 Api.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)

    -- Main
    -- ----------------------------------------------------------------------------
    import Organization (createOrganizationServiceClient)
    import Servant (serve)
    import Server (server)
    import Tracing (createTracer)

    main :: IO ()
    main = do
    102 changes: 102 additions & 0 deletions Server.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,102 @@
    module Server (server) where

    import Relude

    import Api (
    AuthenticatedApi (..),
    AuthorizationHeader,
    OrganizationId,
    ProjectApi (..),
    ProjectId,
    RootApi (..),
    TicketApi (..),
    TraceParentHeader,
    )
    import App (App, Dependencies (..), healthHandler, layoutHandler, runApp)
    import AppAuthenticated (
    AppAuthenticated,
    DependenciesAuthenticated (..),
    listOrganizationsHandler,
    runAppAuthenticated,
    )
    import AppProject (
    AppProject,
    createProjectHandler,
    getProjectHandler,
    runAppProject,
    )
    import AppTicket (
    AppTicket,
    createTicketHandler,
    getTicketHandler,
    runAppTicket,
    )
    import Servant (Handler, NamedRoutes, hoistServer)
    import Servant.Server.Generic (AsServerT)

    server
    :: Dependencies
    -> Maybe TraceParentHeader
    -> RootApi (AsServerT Handler)
    server deps maybeTraceParentHeader =
    hoistServer
    (Proxy @(NamedRoutes RootApi))
    (runApp deps maybeTraceParentHeader)
    (rootServer deps)

    rootServer :: Dependencies -> RootApi (AsServerT App)
    rootServer deps =
    RootApi
    { health = healthHandler
    , layout = layoutHandler
    , authenticatedApi = authenticatedServer'
    }
    where
    authenticatedServer' maybeAuthHeader =
    hoistServer
    (Proxy @(NamedRoutes AuthenticatedApi))
    (runAppAuthenticated (getDependenciesAuthenticated deps) maybeAuthHeader)
    (authenticatedServer maybeAuthHeader)

    getDependenciesAuthenticated :: Dependencies -> DependenciesAuthenticated
    getDependenciesAuthenticated Dependencies {authKey, organizationService} =
    DependenciesAuthenticated
    { authKey = authKey
    , organizationService = organizationService
    }

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

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

    ticketServer :: ProjectId -> TicketApi (AsServerT AppTicket)
    ticketServer _projectId =
    TicketApi
    { createTicket = createTicketHandler
    , getTicket = getTicketHandler
    }
    5 changes: 5 additions & 0 deletions servant-nested-apis.cabal
    View file
    Original file line number Diff line number Diff line change
    @@ -40,9 +40,14 @@ executable servant-nested-apis
    main-is: Main.hs
    other-modules:
    Api
    App
    AppAuthenticated
    AppProject
    AppTicket
    Authentication
    Database
    Logging
    Organization
    Server
    Tracing
    hs-source-dirs: .
  8. nicolashery revised this gist Jun 6, 2023. 8 changed files with 412 additions and 309 deletions.
    98 changes: 98 additions & 0 deletions Api.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,98 @@
    {-# 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)
    48 changes: 48 additions & 0 deletions Authentication.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,48 @@
    -- | Fake authentication
    module Authentication (
    UserId,
    parseAuthHeader,
    authenticateUser,
    AuthEnv (..),
    HasAuth (..),
    MonadAuth,
    getUserId,
    ) where

    import Relude

    import Api (AuthorizationHeader)
    import Control.Exception (throwIO)
    import Servant (err401, errBody)

    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
    81 changes: 81 additions & 0 deletions Database.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,81 @@
    -- | Fake database
    module Database (
    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
    35 changes: 35 additions & 0 deletions Logging.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,35 @@
    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)
    363 changes: 54 additions & 309 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -1,332 +1,75 @@
    {-# 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 Relude

    import Api (
    Api,
    AuthenticatedApi (..),
    AuthorizationHeader,
    OrganizationId,
    ProjectApi (..),
    ProjectId,
    RootApi (..),
    TicketApi (..),
    TicketId,
    TraceParentHeader,
    )
    import Control.Monad.Logger.Aeson (
    Message ((:#)),
    logDebug,
    logInfo,
    runLoggingT,
    (.=),
    import Api qualified
    import Authentication (
    AuthEnv (..),
    HasAuth (..),
    authenticateUser,
    getUserId,
    )
    import Control.Exception (throwIO, try)
    import Control.Monad.Logger (MonadLogger (..))
    import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
    import Control.Monad.Logger.Aeson qualified as Logger (defaultOutput)
    import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
    import Data.Pool (Pool)
    import Database (
    Connection,
    Database,
    DatabaseEnv (..),
    HasDatabase (..),
    createDbPool,
    query,
    runDatabase,
    )
    import Logging (HasLogFunc (..), LogFunc, monadLoggerLogImpl)
    import Network.HTTP.Client (
    Manager,
    defaultManagerSettings,
    managerConnCount,
    newManager,
    )
    import Network.Wai.Handler.Warp qualified as Warp
    import Organization (
    Organization (..),
    OrganizationService (..),
    createOrganizationServiceClient,
    )
    import Servant (
    NamedRoutes,
    NoContent (..),
    ServerError (..),
    err401,
    err404,
    err500,
    hoistServer,
    serve,
    )
    import Servant qualified (Handler (..))
    import Servant.API (
    Capture,
    GenericMode ((:-)),
    Get,
    GetNoContent,
    Header,
    NoContent (..),
    PlainText,
    Post,
    ReqBody,
    (:>),
    )
    import Servant.Server qualified as Servant (layout)
    import Servant.Server.Internal (AsServerT)

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

    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)

    -- Logging
    -- ----------------------------------------------------------------------------

    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)

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

    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 organization service client
    -- ----------------------------------------------------------------------------

    data Organization = Organization
    { organizationId :: OrganizationId
    , name :: Text
    }

    data OrganizationService = OrganizationService
    { fetchUserOrganizations :: UserId -> IO [Organization]
    , fetchOrganization :: OrganizationId -> IO Organization
    }

    createOrganizationServiceClient :: Manager -> Text -> OrganizationService
    createOrganizationServiceClient _httpManager _serviceBaseUrl =
    OrganizationService
    { fetchUserOrganizations =
    \_userId ->
    pure
    [ Organization
    { organizationId = "90ee1361-ee8b-4b22-be38-14bf46a28cfd"
    , name = "Org 1"
    }
    , Organization
    { organizationId = "6e0549c0-15da-4262-9046-4357413c2791"
    , name = "Org 2"
    }
    ]
    , fetchOrganization = \organizationId ->
    pure
    Organization
    { organizationId = organizationId
    , name = "Org 1"
    }
    }
    import Tracing (
    HasTracing (..),
    Tracer,
    TracingEnv (..),
    createNewSpan,
    createTracer,
    traced,
    )

    -- App (Root)
    -- ----------------------------------------------------------------------------
    @@ -516,7 +259,7 @@ runAppAuthenticated
    }
    App $ withReaderT mapEnv (unAppAuthenticated action)

    listOrganizationsHandler :: AppAuthenticated ListOrganizationsResponse
    listOrganizationsHandler :: AppAuthenticated Api.ListOrganizationsResponse
    listOrganizationsHandler = traced "list_organizations" $ do
    userId <- getUserId
    organizationService <- asks appOrganizationService
    @@ -624,7 +367,8 @@ projectServer _organizationId =
    (runAppTicket projectId)
    (ticketServer projectId)

    createProjectHandler :: CreateProjectRequest -> AppProject CreateProjectResponse
    createProjectHandler
    :: Api.CreateProjectRequest -> AppProject Api.CreateProjectResponse
    createProjectHandler projectName = traced "create_project" $ do
    userId <- getUserId
    organizationId <- organizationId <$> getProjectOrganization
    @@ -640,7 +384,7 @@ createProjectHandler projectName = traced "create_project" $ do
    ]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

    getProjectHandler :: ProjectId -> AppProject GetProjectResponse
    getProjectHandler :: ProjectId -> AppProject Api.GetProjectResponse
    getProjectHandler projectId = traced "get_project" $ do
    userId <- getUserId
    organizationId <- organizationId <$> getProjectOrganization
    @@ -742,7 +486,8 @@ ticketServer _projectId =
    , getTicket = getTicketHandler
    }

    createTicketHandler :: CreateTicketRequest -> AppTicket CreateTicketResponse
    createTicketHandler
    :: Api.CreateTicketRequest -> AppTicket Api.CreateTicketResponse
    createTicketHandler ticketName = traced "create_ticket" $ do
    userId <- getUserId
    organizationId <- organizationId <$> getProjectOrganization
    @@ -760,7 +505,7 @@ createTicketHandler ticketName = traced "create_ticket" $ do
    ]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

    getTicketHandler :: TicketId -> AppTicket GetTicketResponse
    getTicketHandler :: TicketId -> AppTicket Api.GetTicketResponse
    getTicketHandler ticketId = traced "get_ticket" $ do
    userId <- getUserId
    organizationId <- organizationId <$> getProjectOrganization
    45 changes: 45 additions & 0 deletions Organization.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,45 @@
    -- | Fake organization service client
    module Organization (
    Organization (..),
    OrganizationService (..),
    createOrganizationServiceClient,
    ) where

    import Relude

    import Api (OrganizationId)
    import Authentication (UserId)
    import Network.HTTP.Client (Manager)

    data Organization = Organization
    { organizationId :: OrganizationId
    , name :: Text
    }

    data OrganizationService = OrganizationService
    { fetchUserOrganizations :: UserId -> IO [Organization]
    , fetchOrganization :: OrganizationId -> IO Organization
    }

    createOrganizationServiceClient :: Manager -> Text -> OrganizationService
    createOrganizationServiceClient _httpManager _serviceBaseUrl =
    OrganizationService
    { fetchUserOrganizations =
    \_userId ->
    pure
    [ Organization
    { organizationId = "90ee1361-ee8b-4b22-be38-14bf46a28cfd"
    , name = "Org 1"
    }
    , Organization
    { organizationId = "6e0549c0-15da-4262-9046-4357413c2791"
    , name = "Org 2"
    }
    ]
    , fetchOrganization = \organizationId ->
    pure
    Organization
    { organizationId = organizationId
    , name = "Org 1"
    }
    }
    44 changes: 44 additions & 0 deletions Tracing.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,44 @@
    -- | 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
    7 changes: 7 additions & 0 deletions servant-nested-apis.cabal
    View file
    Original file line number Diff line number Diff line change
    @@ -38,4 +38,11 @@ common options
    executable servant-nested-apis
    import: options
    main-is: Main.hs
    other-modules:
    Api
    Authentication
    Database
    Logging
    Organization
    Tracing
    hs-source-dirs: .
  9. nicolashery revised this gist Jun 6, 2023. 1 changed file with 65 additions and 32 deletions.
    97 changes: 65 additions & 32 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -356,23 +356,23 @@ newtype App a = App
    , MonadReader AppEnv
    )

    class HasApp env where
    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 (HasApp env) => HasLogFunc env where
    getLogFunc = appLogger . getApp
    instance HasLogFunc AppEnv where
    getLogFunc = appLogger

    instance MonadLogger App where
    monadLoggerLog = monadLoggerLogImpl

    instance (HasApp env) => HasDatabase env where
    getDatabase = databaseEnv . getApp
    instance HasDatabase AppEnv where
    getDatabase = databaseEnv

    instance (HasApp env) => HasTracing env where
    getTracing = tracingEnv . getApp
    instance HasTracing AppEnv where
    getTracing = tracingEnv

    runAppIO :: AppEnv -> App a -> IO a
    runAppIO appEnv action = runReaderT (unApp action) appEnv
    @@ -470,20 +470,29 @@ newtype AppAuthenticated a = AppAuthenticated
    , MonadReader AppAuthenticatedEnv
    )

    class (HasApp env) => HasAppAuthenticated env where
    instance MonadLogger AppAuthenticated where
    monadLoggerLog = monadLoggerLogImpl

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

    instance HasAppAuthenticated AppAuthenticatedEnv where
    getAppAuthenticated = identity

    instance HasAuth AppAuthenticatedEnv where
    getAuth = authEnv

    instance HasApp AppAuthenticatedEnv where
    getApp = appEnv

    instance HasAppAuthenticated AppAuthenticatedEnv where
    getAppAuthenticated = identity
    instance HasLogFunc AppAuthenticatedEnv where
    getLogFunc = getLogFunc . getApp

    instance MonadLogger AppAuthenticated where
    monadLoggerLog = monadLoggerLogImpl
    instance HasDatabase AppAuthenticatedEnv where
    getDatabase = getDatabase . getApp

    instance (HasAppAuthenticated env) => HasAuth env where
    getAuth = authEnv . getAppAuthenticated
    instance HasTracing AppAuthenticatedEnv where
    getTracing = getTracing . getApp

    runAppAuthenticated
    :: DependenciesAuthenticated
    @@ -558,20 +567,32 @@ newtype AppProject a = AppProject
    , MonadReader AppProjectEnv
    )

    instance MonadLogger AppProject where
    monadLoggerLog = monadLoggerLogImpl

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

    instance HasApp AppProjectEnv where
    getApp = appEnv . appAuthenticatedEnv
    instance HasAppProject AppProjectEnv where
    getAppProject = identity

    instance HasAppAuthenticated AppProjectEnv where
    getAppAuthenticated = appAuthenticatedEnv

    instance HasAppProject AppProjectEnv where
    getAppProject = identity
    instance HasAuth AppProjectEnv where
    getAuth = getAuth . getAppAuthenticated

    instance MonadLogger AppProject where
    monadLoggerLog = monadLoggerLogImpl
    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
    @@ -667,23 +688,35 @@ newtype AppTicket a = AppTicket
    , MonadReader AppTicketEnv
    )

    instance MonadLogger AppTicket where
    monadLoggerLog = monadLoggerLogImpl

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

    instance HasApp AppTicketEnv where
    getApp = appEnv . appAuthenticatedEnv . appProjectEnv

    instance HasAppAuthenticated AppTicketEnv where
    getAppAuthenticated = appAuthenticatedEnv . appProjectEnv
    instance HasAppTicket AppTicketEnv where
    getAppTicket = identity

    instance HasAppProject AppTicketEnv where
    getAppProject = appProjectEnv

    instance HasAppTicket AppTicketEnv where
    getAppTicket = identity
    instance HasAppAuthenticated AppTicketEnv where
    getAppAuthenticated = getAppAuthenticated . getAppProject

    instance MonadLogger AppTicket where
    monadLoggerLog = monadLoggerLogImpl
    instance HasAuth AppTicketEnv where
    getAuth = getAuth . 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
  10. nicolashery revised this gist Jun 6, 2023. 1 changed file with 17 additions and 12 deletions.
    29 changes: 17 additions & 12 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -146,6 +146,19 @@ type LogFunc =
    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)

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

    @@ -353,9 +366,7 @@ instance (HasApp env) => HasLogFunc env where
    getLogFunc = appLogger . getApp

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

    instance (HasApp env) => HasDatabase env where
    getDatabase = databaseEnv . getApp
    @@ -469,9 +480,7 @@ instance HasAppAuthenticated AppAuthenticatedEnv where
    getAppAuthenticated = identity

    instance MonadLogger AppAuthenticated where
    monadLoggerLog loc logSource logLevel msg = do
    logger <- asks getLogFunc
    liftIO $ logger loc logSource logLevel (toLogStr msg)
    monadLoggerLog = monadLoggerLogImpl

    instance (HasAppAuthenticated env) => HasAuth env where
    getAuth = authEnv . getAppAuthenticated
    @@ -562,9 +571,7 @@ instance HasAppProject AppProjectEnv where
    getAppProject = identity

    instance MonadLogger AppProject where
    monadLoggerLog loc logSource logLevel msg = do
    logger <- asks getLogFunc
    liftIO $ logger loc logSource logLevel (toLogStr msg)
    monadLoggerLog = monadLoggerLogImpl

    runAppProject
    :: OrganizationId
    @@ -676,9 +683,7 @@ instance HasAppTicket AppTicketEnv where
    getAppTicket = identity

    instance MonadLogger AppTicket where
    monadLoggerLog loc logSource logLevel msg = do
    logger <- asks getLogFunc
    liftIO $ logger loc logSource logLevel (toLogStr msg)
    monadLoggerLog = monadLoggerLogImpl

    runAppTicket
    :: ProjectId
  11. nicolashery revised this gist Jun 6, 2023. 2 changed files with 816 additions and 0 deletions.
    775 changes: 775 additions & 0 deletions Main.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,775 @@
    {-# 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,
    err404,
    err500,
    hoistServer,
    serve,
    )
    import Servant qualified (Handler (..))
    import Servant.API (
    Capture,
    GenericMode ((:-)),
    Get,
    GetNoContent,
    Header,
    NoContent (..),
    PlainText,
    Post,
    ReqBody,
    (:>),
    )
    import Servant.Server qualified as Servant (layout)
    import Servant.Server.Internal (AsServerT)

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

    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)

    -- Logging
    -- ----------------------------------------------------------------------------

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

    class HasLogFunc env where
    getLogFunc :: env -> LogFunc

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

    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 organization service client
    -- ----------------------------------------------------------------------------

    data Organization = Organization
    { organizationId :: OrganizationId
    , name :: Text
    }

    data OrganizationService = OrganizationService
    { fetchUserOrganizations :: UserId -> IO [Organization]
    , fetchOrganization :: OrganizationId -> IO Organization
    }

    createOrganizationServiceClient :: Manager -> Text -> OrganizationService
    createOrganizationServiceClient _httpManager _serviceBaseUrl =
    OrganizationService
    { fetchUserOrganizations =
    \_userId ->
    pure
    [ Organization
    { organizationId = "90ee1361-ee8b-4b22-be38-14bf46a28cfd"
    , name = "Org 1"
    }
    , Organization
    { organizationId = "6e0549c0-15da-4262-9046-4357413c2791"
    , name = "Org 2"
    }
    ]
    , fetchOrganization = \organizationId ->
    pure
    Organization
    { organizationId = organizationId
    , name = "Org 1"
    }
    }

    -- App (Root)
    -- ----------------------------------------------------------------------------

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

    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
    )

    class HasApp env where
    getApp :: env -> AppEnv

    instance HasApp AppEnv where
    getApp = identity

    instance (HasApp env) => HasLogFunc env where
    getLogFunc = appLogger . getApp

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

    instance (HasApp env) => HasDatabase env where
    getDatabase = databaseEnv . getApp

    instance (HasApp env) => HasTracing env where
    getTracing = tracingEnv . getApp

    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 :: Dependencies -> Maybe TraceParentHeader -> App a -> Servant.Handler a
    runApp
    Dependencies {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

    server
    :: Dependencies
    -> Maybe TraceParentHeader
    -> RootApi (AsServerT Servant.Handler)
    server deps maybeTraceParentHeader =
    hoistServer
    (Proxy @(NamedRoutes RootApi))
    (runApp deps maybeTraceParentHeader)
    (rootServer deps)

    rootServer :: Dependencies -> RootApi (AsServerT App)
    rootServer deps =
    RootApi
    { health = healthHandler
    , layout = layoutHandler
    , authenticatedApi = authenticatedServer'
    }
    where
    authenticatedServer' maybeAuthHeader =
    hoistServer
    (Proxy @(NamedRoutes AuthenticatedApi))
    (runAppAuthenticated (getDependenciesAuthenticated deps) maybeAuthHeader)
    (authenticatedServer maybeAuthHeader)

    getDependenciesAuthenticated :: Dependencies -> DependenciesAuthenticated
    getDependenciesAuthenticated Dependencies {authKey, organizationService} =
    DependenciesAuthenticated
    { authKey = authKey
    , organizationService = organizationService
    }

    healthHandler :: App NoContent
    healthHandler = pure NoContent

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

    -- AppAuthenticated
    -- ----------------------------------------------------------------------------

    data DependenciesAuthenticated = DependenciesAuthenticated
    { authKey :: Text
    , 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
    )

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

    instance HasApp AppAuthenticatedEnv where
    getApp = appEnv

    instance HasAppAuthenticated AppAuthenticatedEnv where
    getAppAuthenticated = identity

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

    instance (HasAppAuthenticated env) => HasAuth env where
    getAuth = authEnv . getAppAuthenticated

    runAppAuthenticated
    :: DependenciesAuthenticated
    -> Maybe AuthorizationHeader
    -> AppAuthenticated a
    -> App a
    runAppAuthenticated
    DependenciesAuthenticated {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
    organizationService <- asks appOrganizationService
    organizations <- liftIO $ fetchUserOrganizations organizationService userId
    logInfo $
    "fetched organizations"
    :# [ "user_id" .= userId
    , "organizations" .= map organizationId organizations
    ]
    liftIO $ throwIO $ err500 {errBody = "Not implemented"}

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

    -- AppProject
    -- ----------------------------------------------------------------------------

    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
    )

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

    instance HasApp AppProjectEnv where
    getApp = appEnv . appAuthenticatedEnv

    instance HasAppAuthenticated AppProjectEnv where
    getAppAuthenticated = appAuthenticatedEnv

    instance HasAppProject AppProjectEnv where
    getAppProject = identity

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

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

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

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

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

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

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

    instance HasApp AppTicketEnv where
    getApp = appEnv . appAuthenticatedEnv . appProjectEnv

    instance HasAppAuthenticated AppTicketEnv where
    getAppAuthenticated = appAuthenticatedEnv . appProjectEnv

    instance HasAppProject AppTicketEnv where
    getAppProject = appProjectEnv

    instance HasAppTicket AppTicketEnv where
    getAppTicket = identity

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

    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)

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

    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)

    -- 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
    , organizationService =
    createOrganizationServiceClient
    httpManager
    projectServiceUrl
    }
    waiApp = serve (Proxy @Api) (server dependencies)
    Warp.run port waiApp
    41 changes: 41 additions & 0 deletions servant-nested-apis.cabal
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,41 @@
    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
    hs-source-dirs: .
  12. nicolashery created this gist May 31, 2023.
    1 change: 1 addition & 0 deletions .servant-nested-apis.md
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1 @@
    Nesting APIs and `ReaderT` environments in Haskell's Servant