Disable transactions for read-only requests

src/Main.hs

@@ -4,7 +4,7 @@ import Paths_dbapi (version)
 
 import Dbapi
 import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
-  redirectInsecure, withDBConnection)
+  redirectInsecure, withDBConnection, Environment(..))
 import Network.Wai.Handler.Warp hiding (Connection)
 import Data.String.Conversions (cs)
 
@@ -54,8 +54,8 @@ main = do
       runSettings settings $ (if configSecure conf then redirectInsecure else id)
         . gzip def . cors corsPolicy . clientErrors
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
-        . withDBConnection pool . inTransaction
-        . authenticated (cs $ configAnonRole conf) . withSavepoint $ app
+        . withDBConnection pool . inTransaction Production
+        . authenticated (cs $ configAnonRole conf) . withSavepoint Production $ app
       )
   where
     describe = progDesc "create a REST API to an existing Postgres database"

src/Middleware.hs

@@ -20,26 +20,41 @@ import Network.HTTP.Types.Header (RequestHeaders, hContentType, hAuthorization,
   hLocation)
 import Network.HTTP.Types.Status (status400, status401, status404, status301)
 import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
-                   rawQueryString, isSecure)
+                   rawQueryString, isSecure, requestMethod, Request)
 import Network.URI (URI(..), parseURI)
 
 import PgQuery(LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
+import Debug.Trace
+
+data Environment = Test | Production deriving (Eq)
 
 withDBConnection :: Pool Connection -> (Connection -> Application) -> Application
 withDBConnection pool app req respond =
   withResource pool (\c -> app c req respond)
 
-inTransaction :: (Connection -> Application) -> Connection -> Application
-inTransaction app conn req respond =
-  finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
+inTransaction :: Environment -> (Connection -> Application) ->
+                 Connection -> Application
+inTransaction env app conn req respond =
+  if env == Production && readOnlyRequest req
+    then
+      app conn req respond
+    else
+      finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
 
-withSavepoint :: (Connection -> Application) -> Connection -> Application
-withSavepoint app conn req respond = do
-  runRaw conn "savepoint req_sp"
-  catch (app conn req respond) (\e -> let _ = (e::SomeException) in
-    runRaw conn "rollback to savepoint req_sp" >> throw e)
+readOnlyRequest :: Request -> Bool
+readOnlyRequest req = requestMethod req `elem` ["GET", "HEAD", "OPTIONS"]
+
+withSavepoint :: Environment -> (Connection -> Application) ->
+                 Connection -> Application
+withSavepoint env app conn req respond =
+  if env == Production && readOnlyRequest req
+    then app conn req respond
+    else do
+      runRaw conn "savepoint req_sp"
+      catch (app conn req respond) (\e -> let _ = (e::SomeException) in
+        runRaw conn "rollback to savepoint req_sp" >> throw e)
 
 authenticated :: BS.ByteString -> (Connection -> Application) ->
                  Connection -> Application
@@ -84,7 +99,7 @@ clientErrors app req respond =
 
   where
     isPgException :: SqlError -> Maybe SqlError
-    isPgException = Just
+    isPgException x = Just (traceShow x x)
 
 
 redirectInsecure :: Application -> Application