Add custom monad for servant handlers

guide.cabal

@@ -45,6 +45,8 @@ executable guide
 library
   exposed-modules:
     Guide.App
+      Guide.App.Error
+      Guide.App.Monad
     Guide.Api
       Guide.Api.Methods
       Guide.Api.Server
@@ -184,6 +186,10 @@ library
                      , DeriveGeneric
                      , TypeApplications
                      , NoImplicitPrelude
+                     , GeneralizedNewtypeDeriving
+                     , ConstraintKinds
+                     , InstanceSigs
+                     , DerivingStrategies
 
 test-suite tests
   main-is:             Main.hs

src/Guide/App/Error.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{- | Custom errors for servant handlers. -}
+
+module Guide.App.Error
+       ( WithError
+       , AppError (..)
+       , toHttpError
+       ) where
+
+import Imports
+
+import Servant.Server (ServantErr, err401, err404, err417, err500, errBody)
+
+
+-- | Type alias for errors.
+type WithError m = MonadError AppError m
+
+data AppError
+    -- | General not found
+    = NotFound
+    -- | Some exceptional circumstance has happened stop execution and
+    -- return. Optional text to provide some context in server logs
+    | ServerError Text
+    -- | A required permission level was not met. Optional text to provide some context.
+    | NotAllowed Text
+    -- | Given inputs do not conform to the expected format or shape. Optional
+    -- text to provide some context in server logs
+    | WrongArguments Text
+    -- | An authentication header that was required was provided but not in a
+    -- format that the server can understand
+    | HeaderError Text
+    deriving (Show, Eq)
+    deriving anyclass (Exception)
+
+toHttpError :: AppError -> ServantErr
+toHttpError = \case
+      NotFound           -> err404
+      ServerError msg    -> err500 { errBody = toLByteString msg }
+      NotAllowed msg     -> err401 { errBody = toLByteString msg }
+      WrongArguments msg -> err417 { errBody = toLByteString msg }
+      HeaderError name   -> err401 { errBody = toLByteString $ "Unable to decode header: " <> name }

src/Guide/App/Monad.hs

@@ -0,0 +1,22 @@
+{- | Application monad for servant handlers. -}
+
+module Guide.App.Monad
+       ( GuideM (..)
+       ) where
+
+import Imports
+
+import Guide.App.Error (AppError)
+import Guide.Config (Config)
+
+
+newtype GuideM a = GuideM
+    { runGuideM :: ReaderT Config IO a
+    } deriving (Functor, Applicative, Monad, MonadIO, MonadReader Config)
+
+instance MonadError AppError GuideM where
+    throwError :: AppError -> GuideM a
+    throwError = liftIO . throwIO
+
+    catchError :: GuideM a -> (AppError -> GuideM a) -> GuideM a
+    catchError = error "to be implemented"

stack.yaml

@@ -6,6 +6,9 @@ packages:
 nix:
   shell-file: shell.nix
 
+ghc-options:
+  "$locals": -fhide-source-paths
+
 extra-deps:
 - Spock-0.13.0.0
 - Spock-core-0.13.0.0