Use hasql-transaction

Also use hspec before-wrapper

postgrest.cabal

@@ -36,6 +36,7 @@ executable postgrest
                      , errors
                      , hasql >= 0.19.3.3 && < 0.20
                      , hasql-pool >= 0.4 && < 0.5
+                     , hasql-transaction >= 0.4 && < 0.5
                      , http-types
                      , interpolatedstring-perl6
                      , jwt
@@ -86,6 +87,7 @@ library
                      , contravariant
                      , errors
                      , hasql
+                     , hasql-transaction
                      , hasql-pool
                      , http-types
                      , interpolatedstring-perl6
@@ -162,6 +164,7 @@ Test-Suite spec
                      , errors
                      , hasql
                      , hasql-pool
+                     , hasql-transaction
                      , heredoc
                      , hspec == 2.2.*
                      , hspec-wai

src/PostgREST/App.hs

@@ -31,7 +31,7 @@ import           Data.Aeson
 import           Data.Aeson.Types (emptyArray)
 import           Data.Monoid
 import qualified Data.Vector               as V
-import qualified Hasql.Session             as H
+import qualified Hasql.Transaction         as H
 
 import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.Parsers
@@ -58,7 +58,7 @@ import           PostgREST.QueryBuilder ( callProc
 
 import           Prelude
 
-app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Session Response
+app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Transaction Response
 app dbStructure conf reqBody req =
   let
       -- TODO: blow up for Left values (there is a middleware that checks the headers)

src/PostgREST/Main.hs

@@ -12,7 +12,6 @@ import           PostgREST.DbStructure
 import           PostgREST.Error                      (pgErrResponse)
 import           PostgREST.Middleware
 import           PostgREST.Types                      (DbStructure)
-import           PostgREST.QueryBuilder               (inTransaction, Isolation(..))
 
 import           Control.Monad
 import           Data.Monoid                          ((<>))
@@ -20,6 +19,7 @@ import           Data.String.Conversions              (cs)
 import           Data.Time.Clock.POSIX                (getPOSIXTime)
 import qualified Hasql.Query                          as H
 import qualified Hasql.Session                        as H
+import qualified Hasql.Transaction                    as HT
 import qualified Hasql.Decoders                       as HD
 import qualified Hasql.Encoders                       as HE
 import qualified Hasql.Pool                           as P
@@ -92,7 +92,8 @@ postgrest conf dbStructure pool =
   middle $ \ req respond -> do
     time <- getPOSIXTime
     body <- strictRequestBody req
-    let handleReq = inTransaction ReadCommitted $
-          runWithClaims conf time (app dbStructure conf body) req
-    resp <- either pgErrResponse id <$> P.use pool handleReq
+
+    let handleReq = runWithClaims conf time (app dbStructure conf body) req
+    resp <- either pgErrResponse id <$> P.use pool
+      (HT.run handleReq HT.ReadCommitted HT.Write)
     respond resp

src/PostgREST/Middleware.hs

@@ -7,7 +7,7 @@ import           Data.Maybe                    (fromMaybe)
 import           Data.Text
 import           Data.String.Conversions       (cs)
 import           Data.Time.Clock               (NominalDiffTime)
-import qualified Hasql.Session                 as H
+import qualified Hasql.Transaction             as H
 
 import           Network.HTTP.Types.Header     (hAccept, hAuthorization)
 import           Network.HTTP.Types.Status     (status415, status400)
@@ -27,8 +27,8 @@ import           Prelude hiding(concat)
 import qualified Data.Map.Lazy           as M
 
 runWithClaims :: AppConfig -> NominalDiffTime ->
-                 (Request -> H.Session Response) ->
-                 Request -> H.Session Response
+                 (Request -> H.Transaction Response) ->
+                 Request -> H.Transaction Response
 runWithClaims conf time app req = do
     H.sql setAnon
     case split (== ' ') (cs auth) of

src/PostgREST/QueryBuilder.hs

@@ -18,7 +18,6 @@ module PostgREST.QueryBuilder (
   , callProc
   , createReadStatement
   , createWriteStatement
-  , inTransaction
   , operators
   , pgFmtIdent
   , pgFmtLit
@@ -27,11 +26,9 @@ module PostgREST.QueryBuilder (
   , sourceCTEName
   , unquoted
   , ResultsWithCount
-  , Isolation(..)
   ) where
 
 import qualified Hasql.Query             as H
-import qualified Hasql.Session           as H
 import qualified Hasql.Encoders          as HE
 import qualified Hasql.Decoders          as HD
 
@@ -504,20 +501,3 @@ pgFmtAsJsonPath (Just xx) = " AS " <> last xx
 
 trimNullChars :: Text -> Text
 trimNullChars = T.takeWhile (/= '\x0')
-
-data Isolation = ReadCommitted | RepeatableRead | Serializable
-
-{- |
-  Wrap a session in a transaction of desired isolation level
--}
-inTransaction :: Isolation -> H.Session a -> H.Session a
-inTransaction lvl f = do
-  H.sql $ "begin " <> isolate <> ";"
-  r <- f
-  H.sql "commit;"
-  return r
- where
-  isolate = case lvl of
-    ReadCommitted  -> "ISOLATION LEVEL READ COMMITTED"
-    RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ"
-    Serializable   -> "ISOLATION LEVEL SERIALIZABLE"

stack.yaml

@@ -2,8 +2,11 @@ resolver: lts-5.0
 extra-deps:
   - hasql-0.19.3.3
   - hasql-pool-0.4
+  - hasql-transaction-0.4.2
   - Ranged-sets-0.3.0
   - packdeps-0.4.2.1
+  - bytestring-tree-builder-0.2.5
+  - postgresql-error-codes-1
 ghc-options:
   postgrest: -O1 -Werror -Wall -fwarn-monomorphism-restriction -fwarn-missing-exported-sigs -fwarn-identities
 

test/Main.hs

@@ -27,9 +27,9 @@ main = do
 
   result <- P.use pool $ getDbStructure "test"
   let dbStructure = either (error.show) id result
-      withApp = ($ postgrest cfgDefault dbStructure pool)
+      withApp = return $ postgrest cfgDefault dbStructure pool
 
-  hspec . sequence_ . map (around withApp) $ specs
+  hspec . sequence_ . map (before withApp) $ specs
 
  where
   specs = map (uncurry describe) [