diff --git a/src/Dbapi.hs b/src/Dbapi.hs index a0a83c746..fcd1699e9 100644 --- a/src/Dbapi.hs +++ b/src/Dbapi.hs @@ -4,6 +4,7 @@ module Dbapi where import Types (SqlRow, getRow) +import Middleware(reportPgErrors) import Control.Monad (join) import Control.Exception.Base (bracket_) @@ -100,8 +101,17 @@ app anonymous conn req respond = do appWithRole :: Connection -> Application -appWithRole conn req respond = - respond =<< case (path, verb) of +appWithRole conn = reportPgErrors (\req respond -> + let + path = pathInfo req + verb = requestMethod req + qq = queryString req + hdrs = requestHeaders req + ver = fromMaybe "1" $ requestedVersion hdrs + range = requestedRange hdrs + cRange = requestedContentRange hdrs + allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + in respond =<< case (path, verb) of ([], _) -> responseLBS status200 [jsonContentType] <$> printTables ver conn @@ -159,16 +169,7 @@ appWithRole conn req respond = (_, _) -> return $ responseLBS status404 [] "" - - where - path = pathInfo req - verb = requestMethod req - qq = queryString req - hdrs = requestHeaders req - ver = fromMaybe "1" $ requestedVersion hdrs - range = requestedRange hdrs - cRange = requestedContentRange hdrs - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header + ) defaultCorsPolicy :: CorsResourcePolicy defaultCorsPolicy = CorsResourcePolicy Nothing diff --git a/src/Main.hs b/src/Main.hs index c6782cf98..f268f28c5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,7 +4,7 @@ module Main where import Dbapi -import Middleware (reportPgErrors) +import Middleware (inTransaction) import Network.Wai.Handler.Warp hiding (Connection) import Database.HDBC.PostgreSQL (connectPostgreSQL') import Data.String.Conversions (cs) @@ -41,7 +41,8 @@ main = do Prelude.putStrLn $ "Listening on port " ++ (show $ configPort conf :: String) conn <- connectPostgreSQL' dburi - runTLS tls settings $ gzip def $ cors corsPolicy $ reportPgErrors $ app (cs $ configAnonRole conf) conn + runTLS tls settings $ gzip def $ cors corsPolicy $ + inTransaction conn (app (cs $ configAnonRole conf)) where describe = progDesc "create a REST API to an existing Postgres database" diff --git a/src/Middleware.hs b/src/Middleware.hs index ce289346f..89a7d0e16 100644 --- a/src/Middleware.hs +++ b/src/Middleware.hs @@ -5,12 +5,19 @@ 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 Control.Exception (catchJust) -import Network.Wai +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 [ @@ -21,7 +28,7 @@ instance ToJSON SqlError where ] ] -reportPgErrors :: Middleware +reportPgErrors :: Application -> Request -> ResHandler -> IO ResponseReceived reportPgErrors app req respond = catchJust isPgException (app req respond) ( respond . responseLBS status400 [(hContentType, "application/json")]