handle all requests in a transaction.

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

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"

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")]