From 4c5ff2f319da54434629bb4f3f5f3cbaeb22a615 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Thu, 21 Aug 2025 23:40:32 +0200 Subject: [PATCH] Add some basic error handling --- app/Main.hs | 131 ++++++++++++++++++++++++++++++------------------ flake.lock | 8 +-- src/Yore/DB.hs | 44 ++++++++++++---- src/Yore/Log.hs | 5 +- yore.cabal | 3 +- 5 files changed, 127 insertions(+), 64 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index b6db1f7..b181240 100644 --- a/app/Main.hs +++ b/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 - let maxResources = capabilities - 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 + db <- DB.initDB "host=localhost user=yore-test port=5433 dbname=yore-test" + Warp.runSettings settings $ serve (Proxy :: Proxy API) $ server db where - unsafeConnect s = either throwIO pure =<< Opium.connect s - - settings = Warp.setLogger logger Warp.defaultSettings + settings = + Warp.setLogger logger $ + Warp.setOnException onException Warp.defaultSettings logger req status _ = do Log.info $ printf - "%d %s %s" + "%d %s" (statusCode status) - (BS8.unpack $ requestMethod req) - (BS8.unpack $ rawPathInfo req <> rawQueryString req) + (requestLine 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 -server connPool = rootR :<|> todayR :<|> apiTodayR +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} + +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 - Right count <- liftIO $ withResource connPool $ DB.getNumberOfIssues dateThen - Right dayFile <- liftIO $ withResource connPool $ DB.getDayFileByIssue dateThen issue + dateThen <- succeed get100YearsAgo + count <- succeed $ DB.withConn db $ DB.getNumberOfIssues dateThen + dayFile <- succeed $ DB.withConn db $ DB.getDayFileByIssue dateThen issue pure $ RootModel dateThen dayFile issue count - apiTodayR issue = - Tagged $ \_ respond -> do - dateThen <- get100YearsAgo - res <- withResource connPool $ DB.getDayFileByIssue dateThen issue - dayFile <- either throwIO pure res - let fullPath = "download" dayFile.relative_path - secondsUntilMidnight <- getSecondsUntilMidnight - - respond $ - responseFile - status200 - [ ("content-type", "application/pdf") - , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight) - ] - fullPath - Nothing + apiTodayR issue = handlerToRaw $ do + dateThen <- succeed get100YearsAgo + dayFile <- succeed $ DB.withConn db $ DB.getDayFileByIssue dateThen issue + let fullPath = "download" dayFile.relative_path + secondsUntilMidnight <- liftIO getSecondsUntilMidnight + pure $ + responseFile + status200 + [ ("content-type", "application/pdf") + , ("cache-control", BS8.pack $ printf "public, max-age=%d" secondsUntilMidnight) + ] + 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 = do - dateNow <- getCurrentDay - maybe (throwIO $ ErrorCall "cant go back 100 years") pure $ addYears (-100) dateNow +get100YearsAgo :: IO (Either String Day) +get100YearsAgo = + maybe (Left "can't go back 100 years") Right . addYears (-100) <$> getCurrentDay diff --git a/flake.lock b/flake.lock index 1284f87..645b3e1 100644 --- a/flake.lock +++ b/flake.lock @@ -64,11 +64,11 @@ ] }, "locked": { - "lastModified": 1753685821, - "narHash": "sha256-X6YaJuZHcZKCytmMnTj2lLPGGwhypU6YPfUdbGB/px4=", + "lastModified": 1755721341, + "narHash": "sha256-/3sjTUQG48VaMu3XC82tq1TbHTgx/xsgYHD4szQXyGM=", "ref": "main", - "rev": "9e9e0204bb4c84915c2133d6fc9d9028a24b0e81", - "revCount": 62, + "rev": "1c32e4244eb64d31bbd49f6db8f609862225bfda", + "revCount": 63, "type": "git", "url": "https://git.pbrinkmeier.de/paul/opium" }, diff --git a/src/Yore/DB.hs b/src/Yore/DB.hs index 601855c..fd685b0 100644 --- a/src/Yore/DB.hs +++ b/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 - { schema :: String - , name :: String - } - deriving (Show, Generic, Opium.FromRow) +newtype DB = DB (Pool (Either Opium.ConnectionError Opium.Connection)) -getTables :: Opium.Connection -> IO (Either Opium.Error [Table]) -getTables = Opium.fetch_ "SELECT table_schema AS schema, table_name AS name FROM information_schema.tables" +data Error + = 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 diff --git a/src/Yore/Log.hs b/src/Yore/Log.hs index 997f95b..845eb07 100644 --- a/src/Yore/Log.hs +++ b/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 diff --git a/yore.cabal b/yore.cabal index d29a6d0..301400c 100644 --- a/yore.cabal +++ b/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