Архитектура приложения: Env и ReaderT

У нас есть домен, API и запросы к базе. Но запросам нужен пул соединений, обработчикам нужен конфиг и логгер, а доменные ошибки надо превращать в HTTP-коды. Собрать всё это можно по проверенному рецепту, ReaderT-паттерну из урока 39: одно окружение на всё приложение, одна монада поверх него, тонкая граница с Servant. Без трансформерных башен и магии.

Окружение

Всё, что нужно обработчикам во время выполнения, кладём в одну запись Env: пул соединений, конфиг, логгер.

data Env = Env
  { envPool :: ConnectionPool
  , envConfig :: Config
  , envLogger :: Logger
  }

Конфиг читаем из окружения один раз при старте, а не дёргаем getEnv из глубины кода. Так все настройки в одном месте и одного типа:

data Config = Config
  { configPort :: Int
  , configDbUrl :: ByteString
  , configPoolSize :: Int
  , configJwtSecret :: Text
  }

loadConfig :: IO Config
loadConfig = do
  port <- readWithDefault 8080 <$> lookupEnv "MEEPLE_PORT"
  dbUrl <- maybe defaultDbUrl pack <$> lookupEnv "MEEPLE_DB_URL"
  -- ... остальные поля
  pure Config { configPort = port, configDbUrl = dbUrl, ... }

Прикладная монада

Сердце паттерна это ReaderT-паттерн: одна монада AppM, которая несёт Env и умеет то, что нужно обработчику Servant, то есть бросать ServerError.

newtype AppM a = AppM {unAppM :: ReaderT Env Handler a}
  deriving newtype
    ( Functor, Applicative, Monad, MonadIO
    , MonadReader Env
    , MonadError ServerError
    )

Handler это базовая монада Servant (ExceptT ServerError IO). ReaderT Env Handler добавляет к ней неявный доступ к Env. Инстансы MonadReader и MonadError мы не пишем руками, их выводит deriving newtype: AppM наследует способности от обёрнутого ReaderT Env Handler. Внутри обработчика можно asks envPool и throwError, а откуда они берутся, не важно.

Способности через has-классы

Не каждой функции нужен весь Env. Запросу к базе хватает пула, и незачем тащить в его сигнатуру логгер и секреты. Это выражают has-классы:

class HasPool a where getPool :: a -> ConnectionPool
class HasConfig a where getConfig :: a -> Config
class HasLogger a where getLogger :: a -> Logger

instance HasPool Env where getPool = envPool
instance HasConfig Env where getConfig = envConfig
instance HasLogger Env where getLogger = envLogger

Теперь функция, которой нужен только пул, объявляет HasPool r => ..., а не привязывается к Env. Это та же мысль, что в mtl-стиле урока 39: зависеть от способности, а не от конкретного типа.

Запрос к базе

Запросы из урока 44 выполняются через пул из окружения. Одна функция-мост:

runDb :: Db a -> AppM a
runDb action = do
  pool <- asks envPool
  liftIO (runSqlPool action pool)

runSqlPool делает три шага:

1. берёт свободное соединение из пула;
2. оборачивает запрос в транзакцию;
3. возвращает соединение обратно в пул.

Каждый вызов runDb это одна транзакция.

Доменные ошибки в одном месте

Внутри приложение говорит на языке домена. Ошибки это AppError, а перевод в HTTP живёт на самой границе, одной функцией. Не россыпь throwError err404 по обработчикам, а единая точка маппинга.

data AppError
  = NotFound Text
  | BadRequest Text
  | RuleBroken LendError
  | NotAuthorized

toServerError :: AppError -> ServerError
toServerError = \case
  NotFound what -> json err404 ("не найдено: " <> what)
  BadRequest why -> json err400 why
  RuleBroken e -> json err409 (renderLend e)
  NotAuthorized -> json err401 "нужна авторизация"
  where
    json base msg =
      base { errBody = encode (object ["error" .= (msg :: Text)])
           , errHeaders = [(hContentType, "application/json")] }

Заметь связь с доменом: RuleBroken LendError несёт ту самую ошибку из lend урока 42 и переводит её в 409 Conflict. Бросать ошибку из обработчика теперь удобно:

throwApp :: AppError -> AppM a
throwApp = throwError . toServerError