Introduce application error

app/Main.hs

@@ -7,6 +7,7 @@
 module Main (main) where
 
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Data.Proxy (Proxy (..))
 import Data.Time (Day, toGregorian)
 import Network.HTTP.Media ((//), (/:))
@@ -18,11 +19,12 @@ import Servant
   , Handler
   , MimeRender (..)
   , Raw
-  , Server
   , ServerError (..)
+  , ServerT
   , Tagged (..)
   , err404
   , err500
+  , hoistServer
   , runHandler
   , serve
   , (:<|>) (..)
@@ -45,6 +47,7 @@ import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
 
 import Yore.DB (DayFile (..))
+import Yore.Error (Error (..))
 import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
 
 import qualified Yore.DB as DB
@@ -53,7 +56,7 @@ import qualified Yore.Log as Log
 main :: IO ()
 main = do
   db <- DB.initDB "host=localhost user=yore-test port=5433 dbname=yore-test"
-  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ server db
+  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ hoistServer (Proxy :: Proxy API) nt $ server db
   where
     settings =
       Warp.setLogger logger $
@@ -74,60 +77,60 @@ main = do
         (BS8.unpack $ rawPathInfo req <> rawQueryString req)
 
     onException mbReq ex = do
-      Log.error $ printf "unhandled exception: %s%s" (show ex) (maybe "" ((" in " ++) . requestLine) mbReq)
+      Log.error $ printf "unhandled exception%s: %s%s" (maybe "" ((" in " ++) . requestLine) mbReq) (show ex)
+
+nt :: ExceptT Error IO a -> Handler a
+nt action = MkHandler $ do
+  res <- runExceptT action
+  case res of
+    Left err -> do
+      Log.error $ show err
+      pure $ Left $ toServerError err
+    Right x ->
+      pure $ Right x
 
 type API =
   Get '[HTML] RootModel
     :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel
     :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> Raw
 
-succeed :: (ToServerError e) => IO (Either e a) -> Handler a
-succeed action = MkHandler $ mapLeft toServerError <$> action
-  where
-    mapLeft f = either (Left . f) Right
-
-class ToServerError e where
-  toServerError :: e -> ServerError
-
-instance ToServerError DB.Error where
-  toServerError = \case
-    DB.ConnectionError msg ->
-      err500 {errBody = encodeUtf8LBS $ "database connection failed:\n" ++ show msg}
-    DB.Error (Opium.ErrorNotExactlyOneRow 0) ->
-      err404 {errBody = "could not find record"}
-    e ->
-      err500 {errBody = encodeUtf8LBS $ show e}
-
-instance ToServerError String where
-  toServerError s =
-    err500 {errBody = encodeUtf8LBS s}
+toServerError :: Error -> ServerError
+toServerError = \case
+  ConnectionError msg ->
+    err500 {errBody = encodeUtf8LBS $ "database connection failed:\n" ++ show msg}
+  DBError (Opium.ErrorNotExactlyOneRow 0) ->
+    err404 {errBody = "db error: could not find record"}
+  DBError msg ->
+    err500 {errBody = encodeUtf8LBS $ "db error: " ++ show msg}
+  GenericError msg ->
+    err500 {errBody = encodeUtf8LBS $ "generic error:\n" ++ show msg}
 
 encodeUtf8LBS :: String -> LBS.ByteString
 encodeUtf8LBS = LBS.fromStrict . Encoding.encodeUtf8 . Text.pack
 
-handlerToRaw :: Handler Response -> Tagged t Application
+handlerToRaw :: ExceptT Error IO Response -> Tagged t Application
 handlerToRaw handler = Tagged $ \_ respond -> do
-  r <- runHandler handler
+  r <- runHandler $ nt handler
   case r of
     Left e ->
       respond $ responseLBS (mkStatus e.errHTTPCode $ BS8.pack e.errReasonPhrase) e.errHeaders e.errBody
     Right response ->
       respond response
 
-server :: DB.DB -> Server API
+server :: DB.DB -> ServerT API (ExceptT Error IO)
 server db = rootR :<|> todayR :<|> apiTodayR
   where
     rootR = todayR 0
 
     todayR issue = do
-      dateThen <- succeed get100YearsAgo
-      count <- succeed $ DB.withConn db $ DB.getNumberOfIssues dateThen
-      dayFile <- succeed $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
+      dateThen <- ExceptT get100YearsAgo
+      count <- ExceptT $ DB.withConn db $ DB.getNumberOfIssues dateThen
+      dayFile <- ExceptT $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
       pure $ RootModel dateThen dayFile issue count
 
     apiTodayR issue = handlerToRaw $ do
-      dateThen <- succeed get100YearsAgo
-      dayFile <- succeed $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
+      dateThen <- ExceptT get100YearsAgo
+      dayFile <- ExceptT $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
       let fullPath = "download" </> dayFile.relative_path
       secondsUntilMidnight <- liftIO getSecondsUntilMidnight
       pure $
@@ -178,6 +181,6 @@ data HTML
 instance Accept HTML where
   contentType _ = "text" // "html" /: ("charset", "utf-8")
 
-get100YearsAgo :: IO (Either String Day)
+get100YearsAgo :: IO (Either Error Day)
 get100YearsAgo =
-  maybe (Left "can't go back 100 years") Right . addYears (-100) <$> getCurrentDay
+  either (Left . GenericError . ("can't go back 100 years: " <>)) Right . addYears (-100) <$> getCurrentDay