WIP: Upgrade to hasql 7

Still fails handling query errors

test/SpecHelper.hs

@@ -7,10 +7,13 @@ import Test.Hspec
 import Test.Hspec.Wai
 
 import Hasql as H
+import Hasql.Backend as H
 import Hasql.Postgres as H
 
 import Data.String.Conversions (cs)
 import Data.Monoid
+import Data.Text hiding (map)
+import qualified Data.Vector as V
 -- import Control.Exception.Base (bracket, finally)
 import Control.Monad (void)
 import Control.Exception
@@ -37,35 +40,40 @@ isLeft _ = False
 cfg :: AppConfig
 cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10
 
-testSettings :: SessionSettings
-testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30
+testSettings :: PoolSettings
+testSettings = fromMaybe (error "bad settings") $ H.poolSettings 1 30
 
-pgSettings :: Postgres
 pgSettings = H.ParamSettings "localhost" 5432 "postgrest_test" "" "postgrest_test"
 
 withApp :: ActionWith Application -> IO ()
-withApp perform =
+withApp perform = do
   let anonRole = cs $ configAnonRole cfg
-      currRole = cs $ configDbUser cfg in
-  perform $ middle $ \req resp ->
-    H.session pgSettings testSettings $ H.sessionUnlifter >>= \unlift ->
-      liftIO $ do
-        body <- strictRequestBody req
-        resp =<< catchJust isSqlError
-          (unlift $ H.tx Nothing
-                  $ authenticated currRole anonRole (app body) req)
-          (return . sqlError)
+      currRole = cs $ configDbUser cfg
+  pool :: H.Pool H.Postgres
+          <- H.acquirePool pgSettings testSettings
+
+  perform $ middle $ \req resp -> do
+    body <- strictRequestBody req
+    result <- liftIO
+      $ H.session pool
+      $ H.tx Nothing
+      $ authenticated currRole anonRole (app body) req
+    resp $ case result of
+      Right r -> r
+      Left _ -> error "hahahaha"
 
   where middle = cors corsPolicy
 
 
 resetDb :: IO ()
 resetDb = do
-  H.session pgSettings testSettings $
+  pool :: H.Pool H.Postgres
+    <- H.acquirePool pgSettings testSettings
+  void . liftIO $ H.session pool $
     H.tx Nothing $ do
-      H.unit [H.q| drop schema if exists "1" cascade |]
-      H.unit [H.q| drop schema if exists private cascade |]
-      H.unit [H.q| drop schema if exists postgrest cascade |]
+      H.unitEx [H.stmt| drop schema if exists "1" cascade |]
+      H.unitEx [H.stmt| drop schema if exists private cascade |]
+      H.unitEx [H.stmt| drop schema if exists postgrest cascade |]
 
   loadFixture "roles"
   loadFixture "schema"
@@ -90,15 +98,21 @@ authHeader :: String -> String -> Header
 authHeader u p =
   (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
 
-clearTable :: BS.ByteString -> IO ()
-clearTable table = H.session pgSettings testSettings $ H.tx Nothing $
-  H.unit ("delete from \"1\"."<>table, [], True)
+clearTable :: Text -> IO ()
+clearTable table = do
+  pool :: H.Pool H.Postgres
+    <- H.acquirePool pgSettings testSettings
+  void . liftIO $ H.session pool $ H.tx Nothing $
+    H.unitEx $ H.Stmt ("delete from \"1\"."<>table) V.empty True
 
 createItems :: Int -> IO ()
-createItems n = H.session pgSettings testSettings $ H.tx Nothing txn
+createItems n = do
+  pool :: H.Pool H.Postgres
+    <- H.acquirePool pgSettings testSettings
+  void . liftIO $ H.session pool $ H.tx Nothing txn
   where
-    txn = sequence_ $ map H.unit stmts
-    stmts = map [H.q|insert into "1".items (id) values (?)|] [1..n]
+    txn = sequence_ $ map H.unitEx stmts
+    stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n]
 
 -- for hspec-wai
 pending_ :: WaiSession ()

test/Unit/ErrorsSpec.hs

@@ -1,41 +0,0 @@
-module Unit.ErrorsSpec where
-
-import Test.Hspec
-
-import Text.Parsec
-import PgError
-import Data.Either (rights)
-
-spec :: Spec
-spec =
-  describe "Parsing Hasql errors" $ do
-    it "can handle status and code" $
-      let p = parse message "" "Status: \"foo\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message (Just "foo") "abc" Nothing Nothing
-        ]
-    it "can handle weird redundant quotes in status" $
-      let p = parse message "" "Status: \"\"foo\"\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message (Just "foo") "abc" Nothing Nothing
-        ]
-    it "can handle text and code" $
-      let p = parse message "" "Message: \"foo\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message Nothing "abc" (Just "foo") Nothing
-        ]
-    it "can handle status, text and code" $
-      let p = parse message "" "Status: \"hi\"; Message: \"foo\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message (Just "hi") "abc" (Just "foo") Nothing
-        ]
-    it "can handle unescaped quotes in message" $
-      let p = parse message "" "Status: \"hi\"; Message: \"unknown \"foo\"!\"; Code: \"abc\"." in
-      rights [p] `shouldBe` [
-          Message (Just "hi") "abc" (Just "unknown \"foo\"!") Nothing
-        ]
-    it "can handle periods in message" $
-      let p = parse message "" "Message: \"unknown \"foo\".bar\"; Code: \"42P01\"." in
-      rights [p] `shouldBe` [
-          Message Nothing "42P01" (Just "unknown \"foo\".bar") Nothing
-        ]