Upgrade hasql to 0.4.0

dbapi.cabal

@@ -16,7 +16,7 @@ executable dbapi
   default-extensions:  OverloadedStrings
   other-extensions:    QuasiQuotes
   build-depends:       base >=4.6 && <5
-                     , hasql >= 0.2.3 && < 0.3.0, hasql-backend, hasql-postgres
+                     , hasql >= 0.4.0, hasql-backend, hasql-postgres
                      , warp >= 3.0.2, wai >= 3.0.1
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
@@ -58,7 +58,7 @@ Test-Suite spec
   Other-Modules:       App, Auth, Config, Spec, SpecHelper
   Build-Depends:       base, hspec >= 2.0, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
-                     , hasql >= 0.2.3 && < 0.3.0, hasql-backend, hasql-postgres
+                     , hasql >= 0.4.0, hasql-backend, hasql-postgres
                      , warp >= 3.0.2, wai >= 3.0.1
                      , HTTP, convertible
                      , case-insensitive

src/App.hs

@@ -29,7 +29,6 @@ import Data.Aeson
 import Data.Coerce
 import Data.Monoid
 import qualified Hasql as H
-import qualified Hasql.Backend as HB
 import qualified Hasql.Postgres as H
 
 import PgQuery
@@ -37,7 +36,7 @@ import RangeQuery
 import PgStructure
 import Auth
 
-app :: Request -> H.Session H.Postgres IO Response
+app :: Request -> H.Session H.Postgres s IO Response
 app req =
   case (path, verb) of
     ([], _) -> do
@@ -169,12 +168,12 @@ app req =
     allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
 
 
-isSqlError :: HB.Error -> Maybe HB.Error
-isSqlError (HB.ErroneousResult x) = Just $ HB.ErroneousResult x
+isSqlError :: H.Error -> Maybe H.Error
+isSqlError (H.ErroneousResult x) = Just $ H.ErroneousResult x
 isSqlError _ = Nothing
 
-sqlErrHandler :: HB.Error -> IO Response
-sqlErrHandler (HB.ErroneousResult err) =
+sqlErrHandler :: H.Error -> IO Response
+sqlErrHandler (H.ErroneousResult err) =
   return $ if "42P01" `isInfixOf` err
     then responseLBS status404 [] ""
     else responseLBS status400 [] (cs err)

src/Auth.hs

@@ -50,7 +50,7 @@ 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 IO ()
+addUser :: Text -> Text -> Text -> H.Session H.Postgres s IO ()
 addUser identity pass role = do
   Just hashed <- liftIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
   H.tx Nothing $ H.unit $

src/Main.hs

@@ -7,7 +7,6 @@ import Middleware
 
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Reader (runReaderT, ask)
 import Control.Exception
 import Data.String.Conversions (cs)
 import Data.List.Split (splitOn)
@@ -51,12 +50,10 @@ main = do
         . gzip def . cors corsPolicy . clientErrors
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
 
-  H.session pgSettings sessSettings $ do
-    session' <- flip runReaderT <$> ask
-
+  H.session pgSettings sessSettings $ H.sessionUnlifter >>= \unlift ->
     liftIO $ runSettings appSettings $ middle $ \req respond ->
       respond =<< catchJust isSqlError
-        (session' $ authenticated (cs $ configAnonRole conf) app req)
+        (unlift $ authenticated (cs $ configAnonRole conf) app req)
         sqlErrHandler
 
   where

src/Middleware.hs

@@ -38,8 +38,8 @@ import Debug.Trace
 --     else Database.PostgreSQL.Simple.withSavepoint conn go
 --   where go = app conn req respond
 
-authenticated :: Text -> (Request -> H.Session H.Postgres IO Response) ->
-       Request -> H.Session H.Postgres IO Response
+authenticated :: Text -> (Request -> H.Session H.Postgres s IO Response) ->
+       Request -> H.Session H.Postgres s IO Response
 authenticated anon app req = do
   attempt <- httpRequesterRole (requestHeaders req)
   case attempt of
@@ -51,7 +51,7 @@ authenticated anon app req = do
     NoCredentials -> runInRole anon
 
  where
-   httpRequesterRole :: RequestHeaders -> H.Session H.Postgres IO LoginAttempt
+   httpRequesterRole :: RequestHeaders -> H.Session H.Postgres s IO LoginAttempt
    httpRequesterRole hdrs = do
     let auth = fromMaybe "" $ lookup hAuthorization hdrs
     case split (==' ') (cs auth) of
@@ -61,7 +61,6 @@ authenticated anon app req = do
           _ -> return MalformedAuth
       _ -> return NoCredentials
 
-   runInRole :: Text -> H.Session H.Postgres IO Response
    runInRole r = do
      H.tx Nothing $ setRole r
      resp <- app req

test/SpecHelper.hs

@@ -11,9 +11,7 @@ import Hasql.Postgres as H
 
 import Data.String.Conversions (cs)
 -- import Control.Exception.Base (bracket, finally)
-import Control.Monad.Reader (runReaderT, ask)
 import Control.Monad (void)
-import Control.Applicative ( (<$>) )
 import Control.Exception
 
 import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
@@ -47,10 +45,9 @@ pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test"
 withApp :: ActionWith Application -> IO ()
 withApp perform =
   perform $ middle $ \req resp ->
-    H.session pgSettings testSettings $ do
-      session' <- flip runReaderT <$> ask
+    H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift ->
       liftIO $ resp =<< catchJust isSqlError
-          (session' $ authenticated (cs $ configAnonRole cfg) app req)
+          (unlift $ authenticated (cs $ configAnonRole cfg) app req)
           sqlErrHandler
 
   where middle = cors corsPolicy