nicolashery/.app-vs-hander-env.md

## .app-vs-hander-env.md

      
    Raw
  

              .app-vs-hander-env.md
            
          
    App-wide vs. Handler-specific environments in Haskell's Servant
See files:

Bad.hs
Good.hs

Client requests:
curl -XGET \
  -H 'Authorization: TAEKcxpJndhfFaWqDIHgC' \
  -H 'traceparent: 208327fb-d2ca-473f-9e15-85ce49db7493' \
  'http://localhost:3000/v1/tickets/358541f0-15ad-4149-859c-2dc4654d46bf'

curl -XGET \
  -H 'Authorization: TAEKcxpJndhfFaWqDIHgC' \
  'http://localhost:3000/v1/tickets/7bc52df6-24ee-490c-8b3b-cc1ffcbf65f7'

Server logs (Bad):
# Server startup
# (nothing)

# Request 1
[Info] Created new database connection pool of size 10 for app:app@localhost:5432/app
[Info] Created new HTTP client manager with number of connections kept-alive per host of 20
[Info] Using existing trace ID 208327fb-d2ca-473f-9e15-85ce49db7493
[Info] Authenticated user with ID d42ed530-adba-41f0-99af-60bd6c476617

# Request 2
[Info] Created new database connection pool of size 10 for app:app@localhost:5432/app
[Info] Created new HTTP client manager with number of connections kept-alive per host of 20
[Info] Generating new trace ID 849a577b-7137-4738-9314-3bf9658d883d
[Info] Authenticated user with ID d42ed530-adba-41f0-99af-60bd6c476617

Server logs (Good):
# Server startup
[Info] Created new database connection pool of size 10 for app:app@localhost:5432/app
[Info] Created new HTTP client manager with number of connections kept-alive per host of 20

# Request 1
[Info] Using existing trace ID 208327fb-d2ca-473f-9e15-85ce49db7493
[Info] Authenticated user with ID d42ed530-adba-41f0-99af-60bd6c476617

# Request 2
[Info] Generating new trace ID 849a577b-7137-4738-9314-3bf9658d883d
[Info] Authenticated user with ID d42ed530-adba-41f0-99af-60bd6c476617


## app-vs-handler-env.cabal
cabal-version: 3.0
name: app-vs-handler-env
version: 1.0.0

common options
    build-depends:
        , base
        , http-client
        , monad-logger
        , relude
        , relude
        , resource-pool
        , servant
        , servant-server
        , warp
    ghc-options:
        -Wall
        -Wcompat
        -Widentities
        -Wincomplete-uni-patterns
        -Wincomplete-record-updates
        -Wredundant-constraints
        -Wmissing-export-lists
        -Wpartial-fields
        -Wunused-packages
    default-language: GHC2021
    default-extensions:
        DeriveAnyClass
        DerivingStrategies
        DerivingVia
        DuplicateRecordFields
        NoImplicitPrelude
        OverloadedRecordDot
        OverloadedStrings
        StrictData

executable app-vs-handler-env-good
    import: options
    main-is: Good.hs
    hs-source-dirs: .

executable app-vs-handler-env-bad
    import: options
    main-is: Bad.hs
    hs-source-dirs: .

## Bad.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}

module Main (main) where

import Relude hiding (traceId)

import Control.Exception (throwIO, try)
import Control.Monad.Logger (logInfoN, runStdoutLoggingT)
import Data.Pool (Pool, defaultPoolConfig, newPool)
import Network.HTTP.Client (
  Manager,
  defaultManagerSettings,
  managerConnCount,
  newManager,
 )
import Network.Wai.Handler.Warp qualified as Warp
import Servant (
  HasServer (ServerT),
  NamedRoutes,
  Server,
  ServerError (..),
  err401,
  err500,
  hoistServer,
  serve,
 )
import Servant qualified (Handler (..))
import Servant.API (
  Capture,
  GenericMode ((:-)),
  Get,
  Header,
  PlainText,
  Post,
  ReqBody,
  (:>),
 )

logInfoStdout :: (MonadIO m) => Text -> m ()
logInfoStdout = runStdoutLoggingT . logInfoN

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

type AuthorizationHeader = Text
type TraceParentHeader = Text
type TicketId = Text
type CreateTicketRequest = Text
type CreateTicketResponse = Text
type GetTicketResponse = Text

type Api =
  "v1"
    :> Header "traceparent" TraceParentHeader
    :> Header "Authorization" AuthorizationHeader
    :> "tickets"
    :> NamedRoutes TicketApi

data TicketApi mode = TicketApi
  { createTicket
      :: mode
        :- ReqBody '[PlainText] CreateTicketRequest
          :> Post '[PlainText] CreateTicketResponse
  , getTicket
      :: mode
        :- Capture "ticketId" TicketId
          :> Get '[PlainText] GetTicketResponse
  }
  deriving stock (Generic)

-- Fake database connections
-- ----------------------------------------------------------------------------

data Connection = Connection

createDbPool :: Text -> Int -> IO (Pool Connection)
createDbPool databaseUrl poolSize = do
  pool <-
    newPool
      $ defaultPoolConfig
        create
        destroy
        poolTtl
        poolSize
  logInfoStdout
    $ "Created new database connection pool of size "
    <> show poolSize
    <> " for "
    <> databaseUrl
  pure pool
  where
    create = pure Connection
    destroy = const $ pure ()
    poolTtl = 10

-- HTTP manager
-- ----------------------------------------------------------------------------

createHttpManager :: Int -> IO Manager
createHttpManager connCount = do
  manager <-
    newManager
      $ defaultManagerSettings {managerConnCount = connCount}
  logInfoStdout
    $ "Created new HTTP client manager with number of "
    <> "connections kept-alive per host of "
    <> show connCount
  pure manager

-- Fake user authorization
-- ----------------------------------------------------------------------------

type UserId = Text

data User = User
  { id :: UserId
  , name :: Text
  }

parseAuthHeader :: Maybe AuthorizationHeader -> Either Text UserId
parseAuthHeader Nothing = Left "Missing 'Authorization' header"
parseAuthHeader _ = Right "d42ed530-adba-41f0-99af-60bd6c476617"

fetchUser :: Manager -> UserId -> IO User
fetchUser _ userId =
  pure User {id = userId, name = "John Doe"}

authenticateUser
  :: (MonadIO m)
  => Manager
  -> Maybe AuthorizationHeader
  -> m User
authenticateUser httpManager maybeAuthHeader =
  case parseAuthHeader maybeAuthHeader of
    Left _ ->
      liftIO
        . throwIO
        $ err401
          { errBody = "Missing or invalid 'Authorization' header"
          }
    Right userId -> do
      user <- liftIO $ fetchUser httpManager userId
      logInfoStdout $ "Authenticated user with ID " <> userId
      pure user

-- Fake tracing
-- ----------------------------------------------------------------------------

type TraceId = Text

getOrGenerateTraceId :: Maybe TraceParentHeader -> IO TraceId
getOrGenerateTraceId maybeTraceParentHeader =
  case maybeTraceParentHeader of
    Nothing -> do
      let traceId = "849a577b-7137-4738-9314-3bf9658d883d"
      logInfoStdout $ "Generating new trace ID " <> traceId
      pure traceId
    Just traceId -> do
      logInfoStdout $ "Using existing trace ID " <> traceId
      pure traceId

-- Custom monad
-- ----------------------------------------------------------------------------

data AppEnv = AppEnv
  { dbPool :: Pool Connection
  , httpManager :: Manager
  , user :: User
  , traceId :: TraceId
  }

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

runAppIO :: AppEnv -> App a -> IO a
runAppIO env action = runReaderT (unApp action) env

runAppServant :: AppEnv -> App a -> Servant.Handler a
runAppServant env action =
  Servant.Handler . ExceptT . try $ runAppIO env action

-- Handlers
-- ----------------------------------------------------------------------------

createTicketHandler :: CreateTicketRequest -> App CreateTicketResponse
createTicketHandler _ =
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getTicketHandler :: TicketId -> App GetTicketResponse
getTicketHandler _ =
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

-- Server
-- ----------------------------------------------------------------------------

server
  :: Maybe TraceParentHeader
  -> Maybe AuthorizationHeader
  -> Server (NamedRoutes TicketApi)
server maybeTraceParentHeader maybeAuthHeader =
  hoistServer (Proxy @(NamedRoutes TicketApi)) run ticketServer
  where
    run :: App a -> Servant.Handler a
    run action = do
      -- Bad: These get re-run on every request
      dbPool <- liftIO $ createDbPool "app:app@localhost:5432/app" 10
      httpManager <- liftIO $ createHttpManager 20
      -- Good: These need to get run on every request
      traceId <- liftIO $ getOrGenerateTraceId maybeTraceParentHeader
      user <- liftIO $ authenticateUser httpManager maybeAuthHeader
      let appEnv =
            AppEnv
              { dbPool = dbPool
              , httpManager = httpManager
              , traceId = traceId
              , user = user
              }
      runAppServant appEnv action

ticketServer :: ServerT (NamedRoutes TicketApi) App
ticketServer =
  TicketApi
    { createTicket = createTicketHandler
    , getTicket = getTicketHandler
    }

-- Main
-- ----------------------------------------------------------------------------

main :: IO ()
main = do
  let port = 3000
      waiApp = serve (Proxy @Api) server
  Warp.run port waiApp

## Good.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}

module Main (main) where

import Relude hiding (traceId)

import Control.Exception (throwIO, try)
import Control.Monad.Logger (logInfoN, runStdoutLoggingT)
import Data.Pool (Pool, defaultPoolConfig, newPool)
import Network.HTTP.Client (
  Manager,
  defaultManagerSettings,
  managerConnCount,
  newManager,
 )
import Network.Wai.Handler.Warp qualified as Warp
import Servant (
  HasServer (ServerT),
  NamedRoutes,
  Server,
  ServerError (..),
  err401,
  err500,
  hoistServer,
  serve,
 )
import Servant qualified (Handler (..))
import Servant.API (
  Capture,
  GenericMode ((:-)),
  Get,
  Header,
  PlainText,
  Post,
  ReqBody,
  (:>),
 )

logInfoStdout :: (MonadIO m) => Text -> m ()
logInfoStdout = runStdoutLoggingT . logInfoN

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

type AuthorizationHeader = Text
type TraceParentHeader = Text
type TicketId = Text
type CreateTicketRequest = Text
type CreateTicketResponse = Text
type GetTicketResponse = Text

type Api =
  "v1"
    :> Header "traceparent" TraceParentHeader
    :> Header "Authorization" AuthorizationHeader
    :> "tickets"
    :> NamedRoutes TicketApi

data TicketApi mode = TicketApi
  { createTicket
      :: mode
        :- ReqBody '[PlainText] CreateTicketRequest
          :> Post '[PlainText] CreateTicketResponse
  , getTicket
      :: mode
        :- Capture "ticketId" TicketId
          :> Get '[PlainText] GetTicketResponse
  }
  deriving stock (Generic)

-- Fake database connections
-- ----------------------------------------------------------------------------

data Connection = Connection

createDbPool :: Text -> Int -> IO (Pool Connection)
createDbPool databaseUrl poolSize = do
  pool <-
    newPool
      $ defaultPoolConfig
        create
        destroy
        poolTtl
        poolSize
  logInfoStdout
    $ "Created new database connection pool of size "
    <> show poolSize
    <> " for "
    <> databaseUrl
  pure pool
  where
    create = pure Connection
    destroy = const $ pure ()
    poolTtl = 10

-- HTTP manager
-- ----------------------------------------------------------------------------

createHttpManager :: Int -> IO Manager
createHttpManager connCount = do
  manager <-
    newManager
      $ defaultManagerSettings {managerConnCount = connCount}
  logInfoStdout
    $ "Created new HTTP client manager with number of "
    <> "connections kept-alive per host of "
    <> show connCount
  pure manager

-- Fake user authorization
-- ----------------------------------------------------------------------------

type UserId = Text

data User = User
  { id :: UserId
  , name :: Text
  }

parseAuthHeader :: Maybe AuthorizationHeader -> Either Text UserId
parseAuthHeader Nothing = Left "Missing 'Authorization' header"
parseAuthHeader _ = Right "d42ed530-adba-41f0-99af-60bd6c476617"

fetchUser :: Manager -> UserId -> IO User
fetchUser _ userId =
  pure User {id = userId, name = "John Doe"}

authenticateUser
  :: (MonadIO m)
  => Manager
  -> Maybe AuthorizationHeader
  -> m User
authenticateUser httpManager maybeAuthHeader =
  case parseAuthHeader maybeAuthHeader of
    Left _ ->
      liftIO
        . throwIO
        $ err401
          { errBody = "Missing or invalid 'Authorization' header"
          }
    Right userId -> do
      user <- liftIO $ fetchUser httpManager userId
      logInfoStdout $ "Authenticated user with ID " <> userId
      pure user

-- Fake tracing
-- ----------------------------------------------------------------------------

type TraceId = Text

getOrGenerateTraceId :: Maybe TraceParentHeader -> IO TraceId
getOrGenerateTraceId maybeTraceParentHeader =
  case maybeTraceParentHeader of
    Nothing -> do
      let traceId = "849a577b-7137-4738-9314-3bf9658d883d"
      logInfoStdout $ "Generating new trace ID " <> traceId
      pure traceId
    Just traceId -> do
      logInfoStdout $ "Using existing trace ID " <> traceId
      pure traceId

-- Custom monad
-- ----------------------------------------------------------------------------

data AppServerEnv = AppServerEnv
  { dbPool :: Pool Connection
  , httpManager :: Manager
  }

data AppEnv = AppEnv
  { dbPool :: Pool Connection
  , httpManager :: Manager
  , user :: User
  , traceId :: TraceId
  }

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

runAppIO :: AppEnv -> App a -> IO a
runAppIO env action = runReaderT (unApp action) env

runAppServant :: AppEnv -> App a -> Servant.Handler a
runAppServant env action =
  Servant.Handler . ExceptT . try $ runAppIO env action

-- Handlers
-- ----------------------------------------------------------------------------

createTicketHandler :: CreateTicketRequest -> App CreateTicketResponse
createTicketHandler _ =
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getTicketHandler :: TicketId -> App GetTicketResponse
getTicketHandler _ =
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

-- Server
-- ----------------------------------------------------------------------------

server
  :: AppServerEnv
  -> Maybe TraceParentHeader
  -> Maybe AuthorizationHeader
  -> Server (NamedRoutes TicketApi)
server AppServerEnv {dbPool, httpManager} maybeTraceParentHeader maybeAuthHeader =
  hoistServer (Proxy @(NamedRoutes TicketApi)) run ticketServer
  where
    run :: App a -> Servant.Handler a
    run action = do
      -- Good: Only these get run on every request
      traceId <- liftIO $ getOrGenerateTraceId maybeTraceParentHeader
      user <- liftIO $ authenticateUser httpManager maybeAuthHeader
      let appEnv =
            AppEnv
              { dbPool = dbPool
              , httpManager = httpManager
              , traceId = traceId
              , user = user
              }
      runAppServant appEnv action

ticketServer :: ServerT (NamedRoutes TicketApi) App
ticketServer =
  TicketApi
    { createTicket = createTicketHandler
    , getTicket = getTicketHandler
    }

-- Main
-- ----------------------------------------------------------------------------

main :: IO ()
main = do
  -- Good: These run only once at server startup
  dbPool <- createDbPool "app:app@localhost:5432/app" 10
  httpManager <- createHttpManager 20
  let port = 3000
      appServerEnv =
        AppServerEnv
          { dbPool = dbPool
          , httpManager = httpManager
          }
      waiApp = serve (Proxy @Api) (server appServerEnv)
  Warp.run port waiApp
	cabal-version: 3.0
	name: app-vs-handler-env
	version: 1.0.0

	common options
	build-depends:
	, base
	, http-client
	, monad-logger
	, relude
	, relude
	, resource-pool
	, servant
	, servant-server
	, warp
	ghc-options:
	-Wall
	-Wcompat
	-Widentities
	-Wincomplete-uni-patterns
	-Wincomplete-record-updates
	-Wredundant-constraints
	-Wmissing-export-lists
	-Wpartial-fields
	-Wunused-packages
	default-language: GHC2021
	default-extensions:
	DeriveAnyClass
	DerivingStrategies
	DerivingVia
	DuplicateRecordFields
	NoImplicitPrelude
	OverloadedRecordDot
	OverloadedStrings
	StrictData

	executable app-vs-handler-env-good
	import: options
	main-is: Good.hs
	hs-source-dirs: .

	executable app-vs-handler-env-bad
	import: options
	main-is: Bad.hs
	hs-source-dirs: .
	{-# LANGUAGE DataKinds #-}
	{-# LANGUAGE TypeOperators #-}

	module Main (main) where

	import Relude hiding (traceId)

	import Control.Exception (throwIO, try)
	import Control.Monad.Logger (logInfoN, runStdoutLoggingT)
	import Data.Pool (Pool, defaultPoolConfig, newPool)
	import Network.HTTP.Client (
	Manager,
	defaultManagerSettings,
	managerConnCount,
	newManager,
	)
	import Network.Wai.Handler.Warp qualified as Warp
	import Servant (
	HasServer (ServerT),
	NamedRoutes,
	Server,
	ServerError (..),
	err401,
	err500,
	hoistServer,
	serve,
	)
	import Servant qualified (Handler (..))
	import Servant.API (
	Capture,
	GenericMode ((:-)),
	Get,
	Header,
	PlainText,
	Post,
	ReqBody,
	(:>),
	)

	logInfoStdout :: (MonadIO m) => Text -> m ()
	logInfoStdout = runStdoutLoggingT . logInfoN

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

	type AuthorizationHeader = Text
	type TraceParentHeader = Text
	type TicketId = Text
	type CreateTicketRequest = Text
	type CreateTicketResponse = Text
	type GetTicketResponse = Text

	type Api =
	"v1"
	:> Header "traceparent" TraceParentHeader
	:> Header "Authorization" AuthorizationHeader
	:> "tickets"
	:> NamedRoutes TicketApi

	data TicketApi mode = TicketApi
	{ createTicket
	:: mode
	:- ReqBody '[PlainText] CreateTicketRequest
	:> Post '[PlainText] CreateTicketResponse
	, getTicket
	:: mode
	:- Capture "ticketId" TicketId
	:> Get '[PlainText] GetTicketResponse
	}
	deriving stock (Generic)

	-- Fake database connections
	-- ----------------------------------------------------------------------------

	data Connection = Connection

	createDbPool :: Text -> Int -> IO (Pool Connection)
	createDbPool databaseUrl poolSize = do
	pool <-
	newPool
	$ defaultPoolConfig
	create
	destroy
	poolTtl
	poolSize
	logInfoStdout
	$ "Created new database connection pool of size "
	<> show poolSize
	<> " for "
	<> databaseUrl
	pure pool
	where
	create = pure Connection
	destroy = const $ pure ()
	poolTtl = 10

	-- HTTP manager
	-- ----------------------------------------------------------------------------

	createHttpManager :: Int -> IO Manager
	createHttpManager connCount = do
	manager <-
	newManager
	$ defaultManagerSettings {managerConnCount = connCount}
	logInfoStdout
	$ "Created new HTTP client manager with number of "
	<> "connections kept-alive per host of "
	<> show connCount
	pure manager

	-- Fake user authorization
	-- ----------------------------------------------------------------------------

	type UserId = Text

	data User = User
	{ id :: UserId
	, name :: Text
	}

	parseAuthHeader :: Maybe AuthorizationHeader -> Either Text UserId
	parseAuthHeader Nothing = Left "Missing 'Authorization' header"
	parseAuthHeader _ = Right "d42ed530-adba-41f0-99af-60bd6c476617"

	fetchUser :: Manager -> UserId -> IO User
	fetchUser _ userId =
	pure User {id = userId, name = "John Doe"}

	authenticateUser
	:: (MonadIO m)
	=> Manager
	-> Maybe AuthorizationHeader
	-> m User
	authenticateUser httpManager maybeAuthHeader =
	case parseAuthHeader maybeAuthHeader of
	Left _ ->
	liftIO
	. throwIO
	$ err401
	{ errBody = "Missing or invalid 'Authorization' header"
	}
	Right userId -> do
	user <- liftIO $ fetchUser httpManager userId
	logInfoStdout $ "Authenticated user with ID " <> userId
	pure user

	-- Fake tracing
	-- ----------------------------------------------------------------------------

	type TraceId = Text

	getOrGenerateTraceId :: Maybe TraceParentHeader -> IO TraceId
	getOrGenerateTraceId maybeTraceParentHeader =
	case maybeTraceParentHeader of
	Nothing -> do
	let traceId = "849a577b-7137-4738-9314-3bf9658d883d"
	logInfoStdout $ "Generating new trace ID " <> traceId
	pure traceId
	Just traceId -> do
	logInfoStdout $ "Using existing trace ID " <> traceId
	pure traceId

	-- Custom monad
	-- ----------------------------------------------------------------------------

	data AppEnv = AppEnv
	{ dbPool :: Pool Connection
	, httpManager :: Manager
	, user :: User
	, traceId :: TraceId
	}

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

	runAppIO :: AppEnv -> App a -> IO a
	runAppIO env action = runReaderT (unApp action) env

	runAppServant :: AppEnv -> App a -> Servant.Handler a
	runAppServant env action =
	Servant.Handler . ExceptT . try $ runAppIO env action

	-- Handlers
	-- ----------------------------------------------------------------------------

	createTicketHandler :: CreateTicketRequest -> App CreateTicketResponse
	createTicketHandler _ =
	liftIO $ throwIO $ err500 {errBody = "Not implemented"}

	getTicketHandler :: TicketId -> App GetTicketResponse
	getTicketHandler _ =
	liftIO $ throwIO $ err500 {errBody = "Not implemented"}

	-- Server
	-- ----------------------------------------------------------------------------

	server
	:: Maybe TraceParentHeader
	-> Maybe AuthorizationHeader
	-> Server (NamedRoutes TicketApi)
	server maybeTraceParentHeader maybeAuthHeader =
	hoistServer (Proxy @(NamedRoutes TicketApi)) run ticketServer
	where
	run :: App a -> Servant.Handler a
	run action = do
	-- Bad: These get re-run on every request
	dbPool <- liftIO $ createDbPool "app:app@localhost:5432/app" 10
	httpManager <- liftIO $ createHttpManager 20
	-- Good: These need to get run on every request
	traceId <- liftIO $ getOrGenerateTraceId maybeTraceParentHeader
	user <- liftIO $ authenticateUser httpManager maybeAuthHeader
	let appEnv =
	AppEnv
	{ dbPool = dbPool
	, httpManager = httpManager
	, traceId = traceId
	, user = user
	}
	runAppServant appEnv action

	ticketServer :: ServerT (NamedRoutes TicketApi) App
	ticketServer =
	TicketApi
	{ createTicket = createTicketHandler
	, getTicket = getTicketHandler
	}

	-- Main
	-- ----------------------------------------------------------------------------

	main :: IO ()
	main = do
	let port = 3000
	waiApp = serve (Proxy @Api) server
	Warp.run port waiApp