Merge branch 'selective-transactions'

.travis.yml

@@ -2,8 +2,6 @@ language: haskell
 ghc: 7.8
 addons:
   postgresql: "9.3"
-notifications:
-  slack: looprecur:z2nPS2Cfx2D33LE2obyU2FyQ
 before_install:
   - createuser --superuser --no-password dbapi_test
   - createdb -O dbapi_test -U postgres dbapi_test

dbapi.cabal

@@ -1,5 +1,5 @@
 name:                  dbapi
-version:               0.2.4.4
+version:               0.2.4.5
 synopsis:              The database is your api
 license:               MIT
 license-file:          LICENSE

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
+        . withDBConnection pool . inTransaction Production
-        . authenticated (cs $ configAnonRole conf) . withSavepoint $ app
+        . 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
+safeAction :: Request -> Bool
-inTransaction app conn req respond =
+safeAction = (`notElem` ["PATCH", "PUT"]) . requestMethod
-  finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
 
-withSavepoint :: (Connection -> Application) -> Connection -> Application
+inTransaction :: Environment -> (Connection -> Application) ->
-withSavepoint app conn req respond = do
+                 Connection -> Application
-  runRaw conn "savepoint req_sp"
+inTransaction env app conn req respond =
-  catch (app conn req respond) (\e -> let _ = (e::SomeException) in
+  if env == Production && safeAction req
-    runRaw conn "rollback to savepoint req_sp" >> throw e)
+    then
+      app conn req respond
+    else
+      finally (runRaw conn "begin" >> app conn req respond) (runRaw conn "commit")
+
+withSavepoint :: Environment -> (Connection -> Application) ->
+                 Connection -> Application
+withSavepoint env app conn req respond =
+  if env == Production && safeAction 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

test/SpecHelper.hs

@@ -18,7 +18,7 @@ import Text.Regex.TDFA ((=~))
 import qualified Data.ByteString.Char8 as BS
 import Network.Wai.Middleware.Cors (cors)
 
-import Middleware(clientErrors, withSavepoint, authenticated)
+import Middleware(clientErrors, withSavepoint, authenticated, Environment(..))
 
 import Dbapi (app, corsPolicy, AppConfig(..))
 import PgQuery(addUser)
@@ -65,7 +65,7 @@ appWithFixture :: ActionWith Application -> IO ()
 appWithFixture action = withDatabaseConnection $ \c -> do
   runRaw c "begin;"
   action $ cors corsPolicy . clientErrors  $
-    (authenticated "dbapi_anonymous" . withSavepoint) app c
+    (authenticated "dbapi_anonymous" . withSavepoint Test) app c
   rollback c
 
 rangeHdrs :: ByteRange -> [Header]

test/Unit/ErrorsSpec.hs

@@ -4,7 +4,7 @@ import Test.Hspec
 
 import Database.HDBC (runRaw, quickQuery, fromSql, SqlError)
 import SpecHelper (dbWithSchema)
-import Middleware (withSavepoint)
+import Middleware (withSavepoint, Environment(..))
 import PgQuery (insert)
 import Types(SqlRow(..))
 import Control.Exception(catch)
@@ -24,7 +24,7 @@ spec = let
 
     describe "withSavepoint" $
       it "allows partial rollback of request" $ \c -> do
-        let app = withSavepoint dbErrApp c
+        let app = withSavepoint Test dbErrApp c
         [[beforeCount]] <- quickQuery c "select count(*) from \"1\".items" []
         runRaw c "set role dbapi_anonymous"
         _ <- insert "1" "items" (SqlRow []) c