paul/yore
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add some basic error handling

Browse Source
This commit is contained in:
Paul Brinkmeier 2025-08-21 23:40:32 +02:00
parent b264b50b01
commit 4c5ff2f319
5 changed files with 127 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
app/Main.hs
View File

@ -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

8
flake.lock generated
View File

@ -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"
},

44
src/Yore/DB.hs
View File

@ -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

5
src/Yore/Log.hs
View File

@ -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

3
yore.cabal
View File

@ -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