From c5846599ea73a013fb2bda17edf9637fbe8258d0 Mon Sep 17 00:00:00 2001 From: Paul Brinkmeier Date: Mon, 25 Aug 2025 08:52:34 +0200 Subject: [PATCH] Introduce application error --- app/Main.hs | 69 ++++++++++++++++++++++++----------------------- flake.lock | 8 +++--- src/Yore/DB.hs | 9 +++---- src/Yore/Error.hs | 11 ++++++++ src/Yore/Repl.hs | 4 +-- src/Yore/Time.hs | 10 ++++--- yore.cabal | 2 ++ 7 files changed, 65 insertions(+), 48 deletions(-) create mode 100644 src/Yore/Error.hs diff --git a/app/Main.hs b/app/Main.hs index b181240..9dce148 100644 --- a/app/Main.hs +++ b/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 diff --git a/flake.lock b/flake.lock index 645b3e1..612ccb2 100644 --- a/flake.lock +++ b/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" }, diff --git a/src/Yore/DB.hs b/src/Yore/DB.hs index fd685b0..2169d84 100644 --- a/src/Yore/DB.hs +++ b/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 diff --git a/src/Yore/Error.hs b/src/Yore/Error.hs new file mode 100644 index 0000000..a6060b7 --- /dev/null +++ b/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) diff --git a/src/Yore/Repl.hs b/src/Yore/Repl.hs index 1fff8ff..8fb126c 100644 --- a/src/Yore/Repl.hs +++ b/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 () diff --git a/src/Yore/Time.hs b/src/Yore/Time.hs index 636eb16..c53ecd4 100644 --- a/src/Yore/Time.hs +++ b/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 diff --git a/yore.cabal b/yore.cabal index 301400c..f26cb0c 100644 --- a/yore.cabal +++ b/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