Add some basic error handling

app/Main.hs

@@ -1,28 +1,33 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module Main (main) where
 
-import Control.Concurrent (getNumCapabilities)
-import Control.Exception (ErrorCall (..), Exception, throwIO)
 import Control.Monad.IO.Class (liftIO)
-import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
 import Data.Proxy (Proxy (..))
 import Data.Time (Day, toGregorian)
 import Network.HTTP.Media ((//), (/:))
-import Network.HTTP.Types (Status (..), status200)
+import Network.HTTP.Types (Status (..), mkStatus, status200)
 import Servant
   ( Accept (..)
   , Capture
   , Get
+  , Handler
   , MimeRender (..)
   , Raw
   , Server
+  , ServerError (..)
   , Tagged (..)
+  , err404
+  , err500
+  , runHandler
   , serve
   , (:<|>) (..)
   , (:>)
+  , pattern MkHandler
   )
 import System.FilePath ((</>))
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
@@ -30,9 +35,11 @@ import Text.Blaze.Html5 ((!))
 import Text.Printf (printf)
 
 import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Encoding
 import qualified Database.PostgreSQL.Opium as Opium
-import Network.Wai (Request (..), responseFile)
+import Network.Wai (Application, Request (..), Response, responseFile, responseLBS)
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
@@ -43,65 +50,94 @@ import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight)
 import qualified Yore.DB as DB
 import qualified Yore.Log as Log
 
-instance Exception Opium.ConnectionError
-
 main :: IO ()
 main = do
-  capabilities <- getNumCapabilities
+  db <- DB.initDB "host=localhost user=yore-test port=5433 dbname=yore-test"
-  let maxResources = capabilities
+  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ server db
-  connPool <-
-    newPool $
-      defaultPoolConfig
-        (unsafeConnect "host=localhost port=5433 user=yore-test dbname=yore-test")
-        Opium.close
-        10
-        maxResources
-  Warp.runSettings settings $ serve (Proxy :: Proxy API) $ server connPool
   where
-    unsafeConnect s = either throwIO pure =<< Opium.connect s
+    settings =
-
+      Warp.setLogger logger $
-    settings = Warp.setLogger logger Warp.defaultSettings
+        Warp.setOnException onException Warp.defaultSettings
 
     logger req status _ = do
       Log.info $
         printf
-          "%d %s %s"
+          "%d %s"
           (statusCode status)
-          (BS8.unpack $ requestMethod req)
+          (requestLine req)
-          (BS8.unpack $ rawPathInfo req <> rawQueryString req)
+
+    requestLine :: Request -> String
+    requestLine req =
+      printf
+        "%s %s"
+        (BS8.unpack $ requestMethod req)
+        (BS8.unpack $ rawPathInfo req <> rawQueryString req)
+
+    onException mbReq ex = do
+      Log.error $ printf "unhandled exception: %s%s" (show ex) (maybe "" ((" in " ++) . requestLine) mbReq)
 
 type API =
   Get '[HTML] RootModel
     :<|> "today" :> "issue" :> Capture "issue" Int :> Get '[HTML] RootModel
     :<|> "api" :> "today" :> "issue" :> Capture "issue" Int :> "fz.pdf" :> Raw
 
-server :: Pool Opium.Connection -> Server API
+succeed :: (ToServerError e) => IO (Either e a) -> Handler a
-server connPool = rootR :<|> todayR :<|> apiTodayR
+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}
+
+encodeUtf8LBS :: String -> LBS.ByteString
+encodeUtf8LBS = LBS.fromStrict . Encoding.encodeUtf8 . Text.pack
+
+handlerToRaw :: Handler Response -> Tagged t Application
+handlerToRaw handler = Tagged $ \_ respond -> do
+  r <- runHandler 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 = rootR :<|> todayR :<|> apiTodayR
   where
     rootR = todayR 0
 
     todayR issue = do
-      dateThen <- liftIO get100YearsAgo
+      dateThen <- succeed get100YearsAgo
-      Right count <- liftIO $ withResource connPool $ DB.getNumberOfIssues dateThen
+      count <- succeed $ DB.withConn db $ DB.getNumberOfIssues dateThen
-      Right dayFile <- liftIO $ withResource connPool $ DB.getDayFileByIssue dateThen issue
+      dayFile <- succeed $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
       pure $ RootModel dateThen dayFile issue count
 
-    apiTodayR issue =
+    apiTodayR issue = handlerToRaw $ do
-      Tagged $ \_ respond -> do
+      dateThen <- succeed get100YearsAgo
-        dateThen <- get100YearsAgo
+      dayFile <- succeed $ DB.withConn db $ DB.getDayFileByIssue dateThen issue
-        res <- withResource connPool $ DB.getDayFileByIssue dateThen issue
+      let fullPath = "download" </> dayFile.relative_path
-        dayFile <- either throwIO pure res
+      secondsUntilMidnight <- liftIO getSecondsUntilMidnight
-        let fullPath = "download" </> dayFile.relative_path
+      pure $
-        secondsUntilMidnight <- getSecondsUntilMidnight
+        responseFile
-
+          status200
-        respond $
+          [ ("content-type", "application/pdf")
-          responseFile
+          , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight)
-            status200
+          ]
-            [ ("content-type", "application/pdf")
+          fullPath
-            , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight)
+          Nothing
-            ]
-            fullPath
-            Nothing
 
 data RootModel = RootModel Day DB.DayFile Int Int
 
@@ -142,7 +178,6 @@ data HTML
 instance Accept HTML where
   contentType _ = "text" // "html" /: ("charset", "utf-8")
 
-get100YearsAgo :: IO Day
+get100YearsAgo :: IO (Either String Day)
-get100YearsAgo = do
+get100YearsAgo =
-  dateNow <- getCurrentDay
+  maybe (Left "can't go back 100 years") Right . addYears (-100) <$> getCurrentDay
-  maybe (throwIO $ ErrorCall "cant go back 100 years") pure $ addYears (-100) dateNow

flake.lock

@@ -64,11 +64,11 @@
         ]
       },
       "locked": {
-        "lastModified": 1753685821,
+        "lastModified": 1755721341,
-        "narHash": "sha256-X6YaJuZHcZKCytmMnTj2lLPGGwhypU6YPfUdbGB/px4=",
+        "narHash": "sha256-/3sjTUQG48VaMu3XC82tq1TbHTgx/xsgYHD4szQXyGM=",
         "ref": "main",
-        "rev": "9e9e0204bb4c84915c2133d6fc9d9028a24b0e81",
+        "rev": "1c32e4244eb64d31bbd49f6db8f609862225bfda",
-        "revCount": 62,
+        "revCount": 63,
         "type": "git",
         "url": "https://git.pbrinkmeier.de/paul/opium"
       },

src/Yore/DB.hs

@@ -1,10 +1,15 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -Wno-deriving-defaults #-}
 
 module Yore.DB
-  ( DayIndex (..)
+  ( DB
+  , Error (..)
+  , initDB
+  , withConn
+  , DayIndex (..)
   , DayFile (..)
   , createDayFile
   , createDayIndex
@@ -12,25 +17,44 @@ module Yore.DB
   , readDayPaths
   , getDayFileByIssue
   , getNumberOfIssues
-  , Table (..)
-  , getTables
   ) where
 
+import Control.Concurrent (getNumCapabilities)
 import Data.Functor.Identity (Identity (..))
+import Data.Pool (Pool, defaultPoolConfig, newPool, withResource)
 import Data.Text (Text)
 import Data.Time (Day)
 import GHC.Generics (Generic)
 
 import qualified Database.PostgreSQL.Opium as Opium
 
-data Table = Table
+newtype DB = DB (Pool (Either Opium.ConnectionError Opium.Connection))
-  { schema :: String
-  , name :: String
-  }
-  deriving (Show, Generic, Opium.FromRow)
 
-getTables :: Opium.Connection -> IO (Either Opium.Error [Table])
+data Error
-getTables = Opium.fetch_ "SELECT table_schema AS schema, table_name AS name FROM information_schema.tables"
+  = ConnectionError Opium.ConnectionError
+  | Error Opium.Error
+  deriving (Show)
+
+initDB :: Text -> IO DB
+initDB connString = do
+  capabilities <- getNumCapabilities
+  let maxResources = capabilities
+  DB
+    <$> newPool
+      ( defaultPoolConfig
+          (Opium.connect connString)
+          (either (const $ pure ()) Opium.close)
+          10
+          maxResources
+      )
+
+withConn :: DB -> (Opium.Connection -> IO (Either Opium.Error a)) -> IO (Either Error a)
+withConn (DB connPool) f =
+  withResource connPool $ \case
+    Left connectionError ->
+      pure $ Left $ ConnectionError connectionError
+    Right conn ->
+      either (Left . Error) Right <$> f conn
 
 data DayIndex = DayIndex
   { day_index_id :: Int

src/Yore/Log.hs

@@ -1,4 +1,4 @@
-module Yore.Log (info) where
+module Yore.Log (Yore.Log.error, info) where
 
 import Data.Time (getZonedTime)
 import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack)
@@ -7,6 +7,9 @@ import Text.Printf (printf)
 info :: (HasCallStack) => String -> IO ()
 info = doLog "INF"
 
+error :: (HasCallStack) => String -> IO ()
+error = doLog "ERR"
+
 doLog :: (HasCallStack) => String -> String -> IO ()
 doLog level msg = do
   now <- getZonedTime

yore.cabal

@@ -50,8 +50,10 @@ library
     , html-parse
     , lens
     , modern-uri
+    , mtl
     , opium
     , req
+    , resource-pool
     , text
     , time
     , uuid
@@ -75,7 +77,6 @@ executable yore
     , opium
     , http-media
     , http-types
-    , resource-pool
     , servant-server
     , text
     , time