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

flake.lock

@@ -64,11 +64,11 @@
         ]
       },
       "locked": {
-        "lastModified": 1755721341,
-        "narHash": "sha256-/3sjTUQG48VaMu3XC82tq1TbHTgx/xsgYHD4szQXyGM=",
+        "lastModified": 1756064767,
+        "narHash": "sha256-SaJK9VYc/oF5aBSMSW+We8TggER4+uTAHvc2ztnLpYo=",
         "ref": "main",
-        "rev": "1c32e4244eb64d31bbd49f6db8f609862225bfda",
-        "revCount": 63,
+        "rev": "af16429d827816cf9bec69026e13f50acc3d2691",
+        "revCount": 65,
         "type": "git",
         "url": "https://git.pbrinkmeier.de/paul/opium"
       },

src/Yore/DB.hs

@@ -28,12 +28,9 @@ import GHC.Generics (Generic)
 
 import qualified Database.PostgreSQL.Opium as Opium
 
-newtype DB = DB (Pool (Either Opium.ConnectionError Opium.Connection))
+import Yore.Error (Error (..))
 
-data Error
-  = ConnectionError Opium.ConnectionError
-  | Error Opium.Error
-  deriving (Show)
+newtype DB = DB (Pool (Either Opium.ConnectionError Opium.Connection))
 
 initDB :: Text -> IO DB
 initDB connString = do
@@ -54,7 +51,7 @@ withConn (DB connPool) f =
     Left connectionError ->
       pure $ Left $ ConnectionError connectionError
     Right conn ->
-      either (Left . Error) Right <$> f conn
+      either (Left . DBError) Right <$> f conn
 
 data DayIndex = DayIndex
   { day_index_id :: Int

src/Yore/Error.hs

@@ -0,0 +1,11 @@
+module Yore.Error (Error (..)) where
+
+import Data.Text (Text)
+
+import qualified Database.PostgreSQL.Opium as Opium
+
+data Error
+  = ConnectionError Opium.ConnectionError
+  | DBError Opium.Error
+  | GenericError Text
+  deriving (Show)

src/Yore/Repl.hs

@@ -34,9 +34,9 @@ getToday = do
   print now
   let currentDay = localDay $ zonedTimeToLocalTime now
   case addYears (-100) currentDay of
-    Just then_ ->
+    Right then_ ->
       getIssuesByDay then_
-    Nothing ->
+    Left _ ->
       pure []
 
 indexDay :: Day -> IO ()

src/Yore/Time.hs

@@ -1,5 +1,6 @@
 module Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight) where
 
+import Data.Text (Text)
 import Data.Time
   ( Day
   , addGregorianYearsClip
@@ -11,13 +12,16 @@ import Data.Time
   , toGregorian
   , zonedTimeToLocalTime
   )
+import Text.Printf (printf)
 
-addYears :: Integer -> Day -> Maybe Day
+import qualified Data.Text as Text
+
+addYears :: Integer -> Day -> Either Text Day
 addYears yearOffset date
   | isFebruary29th && not (isLeapYear year') =
-      Nothing
+      Left $ Text.pack $ printf "year %d is not a leap year"
   | otherwise =
-      Just $ addGregorianYearsClip yearOffset date
+      Right $ addGregorianYearsClip yearOffset date
   where
     (year, month, day) = toGregorian date
     year' = year + yearOffset

yore.cabal

@@ -35,6 +35,7 @@ library
   exposed-modules:
       Yore.DB
     , Yore.Download
+    , Yore.Error
     , Yore.Index
     , Yore.Log
     , Yore.Repl
@@ -80,5 +81,6 @@ executable yore
     , servant-server
     , text
     , time
+    , transformers
     , wai
     , warp