aelve/guide

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | 'Guider' monad with 'Config' to replace servant's 'Handler'.
module Guide.Api.Guider
(
  Guider (..),
  Context (..),
  guiderToHandler,
)
where

import Imports

import Servant (Handler (..), ServantErr (..))

import Guide.Api.Utils (RequestDetails)
import Guide.Config (Config)
import Guide.Logger
import Guide.State (DB)

import qualified Control.Monad.Catch as Exc


-- | A type for Guide handlers. Provides:
--
-- * Logging via 'LoggerT'
-- * Access to 'Context'
--
-- Note that it's not simply a wrapper over 'Handler' -- we throws
-- 'ServantErr's as synchronous exceptions and then catch them in
-- 'guiderToHandler'. It makes our lives easier because now there is exactly
-- one way to throw errors, instead of two.
newtype Guider a = Guider
  -- NB: we don't want to move 'Logger' to the 'Context' because 'LoggerT'
  -- also contains some STM weirdness (even though it's still a reader
  -- monad).
  { runGuider :: ReaderT Context (LoggerT IO) a
  } deriving (Functor, Applicative, Monad, MonadIO, MonadReader Context, HasLogger, Exc.MonadThrow)

-- | Context available to each request.
data Context = Context
  { cConfig  :: Config
  , cDB      :: DB
  , cDetails :: RequestDetails
  }

instance MonadError ServantErr Guider where
  -- | Log an error and rethrow it.
  throwError :: ServantErr -> Guider a
  throwError err = do
    let code = errHTTPCode err
        reason = errReasonPhrase err
    if | code >= 500 -> logError ("error: "+||err||+"")
       | otherwise -> logDebug ("response code "+|code|+": "+|reason|+"")
    Exc.throwM err

  catchError :: Guider a -> (ServantErr -> Guider a) -> Guider a
  catchError (Guider m) f = Guider $ ReaderT $ \context ->
    runReaderT m context `Exc.catch` (\err -> runReaderT (runGuider (f err)) context)

-- | Run a 'Guider' to get the 'Handler' type that Servant expects.
guiderToHandler :: Context -> Logger -> Guider a -> Handler a
guiderToHandler context logger (Guider m) =
  Handler $ ExceptT $ try $ runLoggerT logger $ runReaderT m context