Enclose entire app response in single Tx

postgrest.cabal

@@ -1,4 +1,4 @@
-name:                  dbapi
+name:                  postgrest
 version:               0.2.4.6
 synopsis:              The database is your api
 license:               MIT
@@ -9,7 +9,7 @@ category:              Web
 build-type:            Simple
 cabal-version:         >=1.10
 
-executable dbapi
+executable postgrest
   main-is:             Main.hs
   ghc-options:         -Wall -W -Werror -O2
   default-language:    Haskell2010

src/App.hs

@@ -4,8 +4,6 @@ module App (app, sqlErrHandler, isSqlError) where
 import Control.Monad (join)
 import Control.Arrow ((***))
 import Control.Applicative
-import Control.Monad.IO.Class (liftIO, MonadIO)
--- import Control.Exception.Base
 
 import Data.Text hiding (map)
 import Data.Maybe (fromMaybe)
@@ -18,6 +16,7 @@ import Data.List (sortBy)
 import Data.Functor.Identity
 import Data.Scientific (isInteger, formatScientific, FPFormat(..))
 import qualified Data.Set as S
+import qualified Data.ByteString.Lazy as BL
 
 import Network.HTTP.Types.Status
 import Network.HTTP.Types.Header
@@ -35,16 +34,15 @@ import RangeQuery
 import PgStructure
 import Auth
 
-app :: Request -> H.Session H.Postgres s IO Response
+app :: BL.ByteString -> Request -> H.Tx H.Postgres s Response
-app req =
+app reqBody req =
   case (path, verb) of
     ([], _) -> do
-      body <- H.tx Nothing $ encode <$> tables (cs schema)
+      body <- encode <$> tables (cs schema)
       return $ responseLBS status200 [jsonH] $ cs body
 
     ([table], "OPTIONS") -> do
       let t = QualifiedTable schema (cs table)
-      H.tx Nothing $ do
       cols <- columns t
       pkey <- map cs <$> primaryKeyColumns t
       return $ responseLBS status200 [jsonH, allOrigins]
@@ -66,7 +64,7 @@ app req =
                   . whereT qq
                   $ selectStar qt
                 )
-        row <- H.tx Nothing $ H.single select
+        row <- H.single select
         let (tableTotal, queryTotal, body) =
               fromMaybe (0, 0, Just "" :: Maybe Text) row
             from = fromMaybe 0 $ rangeOffset <$> range
@@ -87,8 +85,7 @@ app req =
           ] (cs $ fromMaybe "[]" body)
 
     (["dbapi", "users"], "POST") -> do
-      body <- liftIO $ strictRequestBody req
+      let user = decode reqBody :: Maybe AuthUser
-      let user = decode body :: Maybe AuthUser
 
       case user of
         Nothing -> return $ responseLBS status400 [jsonH] $
@@ -102,7 +99,7 @@ app req =
             ] ""
 
     ([table], "POST") ->
-      handleJsonObj req $ \obj -> H.tx Nothing $ do
+      handleJsonObj reqBody $ \obj -> do
         let qt = QualifiedTable schema (cs table)
             query = coerce $
               insertInto qt (map cs $ keys obj) (elems obj)
@@ -123,7 +120,7 @@ app req =
           ] ""
 
     ([table], "PUT") ->
-      handleJsonObj req $ \obj -> H.tx Nothing $ do
+      handleJsonObj reqBody $ \obj -> do
         let qt = QualifiedTable schema (cs table)
         primaryKeys <- primaryKeyColumns qt
         let specifiedKeys = map (cs . fst) qq
@@ -147,7 +144,7 @@ app req =
                    "You must specify all columns in PUT request"
 
     ([table], "PATCH") ->
-     handleJsonObj req $ \obj -> H.tx Nothing $ do
+      handleJsonObj reqBody $ \obj -> do
         let qt = QualifiedTable schema (cs table)
         H.unit
           $ coerce
@@ -209,9 +206,10 @@ requestedSchema hdrs =
 jsonH :: Header
 jsonH = (hContentType, "application/json")
 
-handleJsonObj :: MonadIO m => Request -> (Object -> m Response) -> m Response
+handleJsonObj :: BL.ByteString -> (Object -> H.Tx H.Postgres s Response)
-handleJsonObj req handler = do
+              -> H.Tx H.Postgres s Response
-  parse <- liftIO $ fmap eitherDecode . strictRequestBody $ req
+handleJsonObj reqBody handler = do
+  let parse = eitherDecode reqBody
   case parse of
     Left err ->
       return $ responseLBS status400 [jsonH] jErr

src/Auth.hs

@@ -4,7 +4,6 @@ module Auth where
 import Data.Aeson
 import Control.Monad (mzero)
 import Control.Applicative ( (<*>), (<$>) )
-import Control.Monad.IO.Class (liftIO)
 import Crypto.BCrypt
 import Data.Text
 import Data.Monoid
@@ -13,6 +12,8 @@ import qualified Hasql.Postgres as H
 import Data.String.Conversions (cs)
 import PgQuery (pgFmtLit)
 
+import System.IO.Unsafe
+
 data AuthUser = AuthUser {
     userId :: String
   , userPass :: String
@@ -50,10 +51,10 @@ setRole role = H.unit ("set role " <> cs (pgFmtLit role), [], True)
 resetRole :: H.Tx H.Postgres s ()
 resetRole = H.unit [H.q|reset role|]
 
-addUser :: Text -> Text -> Text -> H.Session H.Postgres s IO ()
+addUser :: Text -> Text -> Text -> H.Tx H.Postgres s ()
 addUser identity pass role = do
-  Just hashed <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
+  let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
-  H.tx Nothing $ H.unit $
+  H.unit $
     [H.q|insert into dbapi.auth (id, pass, rolname) values (?, ?, ?)|]
       identity (cs hashed :: Text) role
 

src/Main.hs

@@ -9,6 +9,7 @@ import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Control.Exception
 import Data.String.Conversions (cs)
+import Network.Wai (strictRequestBody)
 import Network.Wai.Middleware.Cors (cors)
 import Network.Wai.Handler.Warp hiding (Connection)
 import Network.Wai.Middleware.Gzip (gzip, def)
@@ -43,11 +44,14 @@ main = do
         (if configSecure conf then redirectInsecure else id)
         . gzip def . cors corsPolicy . clientErrors
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+      anonRole = cs $ configAnonRole conf
 
   H.session pgSettings sessSettings $ H.sessionUnlifter >>= \unlift ->
-    liftIO $ runSettings appSettings $ middle $ \req respond ->
+    liftIO $ runSettings appSettings $ middle $ \req respond -> do
+      body <- strictRequestBody req
       respond =<< catchJust isSqlError
-        (unlift $ authenticated (cs $ configAnonRole conf) app req)
+        (unlift $ H.tx Nothing
+                $ authenticated anonRole (app body) req)
         sqlErrHandler
 
   where

src/Middleware.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Middleware where
 
@@ -38,8 +39,8 @@ import Debug.Trace
 --     else Database.PostgreSQL.Simple.withSavepoint conn go
 --   where go = app conn req respond
 
-authenticated :: Text -> (Request -> H.Session H.Postgres s IO Response) ->
+authenticated :: forall s. Text -> (Request -> H.Tx H.Postgres s Response) ->
-       Request -> H.Session H.Postgres s IO Response
+       Request -> H.Tx H.Postgres s Response
 authenticated anon app req = do
   attempt <- httpRequesterRole (requestHeaders req)
   case attempt of
@@ -51,21 +52,22 @@ authenticated anon app req = do
     NoCredentials -> runInRole anon
 
  where
-   httpRequesterRole :: RequestHeaders -> H.Session H.Postgres s IO LoginAttempt
+   httpRequesterRole :: RequestHeaders -> H.Tx H.Postgres s LoginAttempt
    httpRequesterRole hdrs = do
     let auth = fromMaybe "" $ lookup hAuthorization hdrs
     case split (==' ') (cs auth) of
       ("Basic" : b64 : _) ->
         case split (==':') (cs . decode . cs $ b64) of
-          (u:p:_) -> H.tx Nothing $ signInRole u p
+          (u:p:_) -> signInRole u p
           _ -> return MalformedAuth
       _ -> return NoCredentials
 
+   runInRole :: Text -> H.Tx H.Postgres s Response
    runInRole r = do
-     H.tx Nothing $ setRole r
+     setRole r
-     resp <- app req
+     res <- app req
-     H.tx Nothing resetRole
+     resetRole
-     return resp
+     return res
 
 -- instance ToJSON SqlError where
 --   toJSON t = object [

test/SpecHelper.hs

@@ -44,10 +44,14 @@ pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test"
 
 withApp :: ActionWith Application -> IO ()
 withApp perform =
+  let anonRole = cs $ configAnonRole cfg in
   perform $ middle $ \req resp ->
     H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift ->
-      liftIO $ resp =<< catchJust isSqlError
+      liftIO $ do
-          (unlift $ authenticated (cs $ configAnonRole cfg) app req)
+        body <- strictRequestBody req
+        resp =<< catchJust isSqlError
+          (unlift $ H.tx Nothing
+                  $ authenticated anonRole (app body) req)
           sqlErrHandler
 
   where middle = cors corsPolicy