41 lines
1.3 KiB
Haskell
41 lines
1.3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Middleware where
|
|
|
|
import Data.Aeson
|
|
|
|
import Database.HDBC (runRaw)
|
|
import Database.HDBC.PostgreSQL (Connection)
|
|
import Network.HTTP.Types.Header (hContentType)
|
|
import Network.HTTP.Types.Status (status400)
|
|
import Database.HDBC.Types (SqlError(..))
|
|
import Network.Wai (Application, Request, Response, ResponseReceived, responseLBS)
|
|
import Control.Exception (finally, catchJust)
|
|
|
|
type ResHandler = Response -> IO ResponseReceived
|
|
|
|
inTransaction :: Connection -> (Connection -> Application) -> Request -> ResHandler -> IO ResponseReceived
|
|
inTransaction conn app req respond =
|
|
finally (putStrLn "begin txn" >> runRaw conn "begin" >> app conn req respond) (putStrLn "commit txn" >> runRaw conn "commit")
|
|
|
|
instance ToJSON SqlError where
|
|
toJSON t = object [
|
|
"error" .= object [
|
|
"code" .= seNativeError t
|
|
, "message" .= seErrorMsg t
|
|
, "state" .= seState t
|
|
]
|
|
]
|
|
|
|
reportPgErrors :: Application -> Request -> ResHandler -> IO ResponseReceived
|
|
reportPgErrors app req respond =
|
|
catchJust isPgException (app req respond) (
|
|
respond . responseLBS status400 [(hContentType, "application/json")]
|
|
. encode
|
|
)
|
|
|
|
where
|
|
isPgException :: SqlError -> Maybe SqlError
|
|
isPgException = Just
|