WIP: fixing compiler errors in specs

postgrest.cabal

@@ -134,7 +134,7 @@ library
 Test-Suite spec
   Type:                exitcode-stdio-1.0
   Default-Language:    Haskell2010
-  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
+  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase
   Hs-Source-Dirs:      test, src
   if flag(ci)
     ghc-options:       -Wall -W -Werror
@@ -185,6 +185,7 @@ Test-Suite spec
                      , parsec
                      , process
                      , regex-tdfa
+                     , resource-pool
                      , safe
                      , scientific
                      , string-conversions

test/Feature/AuthSpec.hs

@@ -1,19 +1,18 @@
 module Feature.AuthSpec where
 
 -- {{{ Imports
+import Data.Pool
 import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
-
+import qualified Hasql.Connection  as H
-import Hasql as H
-import Hasql.Postgres as P
 
 import SpecHelper
 import PostgREST.Types (DbStructure(..))
 -- }}}
 
-spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec :: DbStructure -> Pool H.Connection -> Spec
 spec struct pool = around (withApp cfgDefault struct pool)
   $ describe "authorization" $ do
 

test/Feature/CorsSpec.hs

@@ -1,13 +1,12 @@
 module Feature.CorsSpec where
 
 -- {{{ Imports
+import Data.Pool
 import Test.Hspec
 import Test.Hspec.Wai
 import Network.Wai.Test (SResponse(simpleHeaders, simpleBody))
 import qualified Data.ByteString.Lazy as BL
-
+import qualified Hasql.Connection  as H
-import Hasql as H
-import Hasql.Postgres as P
 
 import SpecHelper
 import PostgREST.Types (DbStructure(..))
@@ -15,7 +14,7 @@ import PostgREST.Types (DbStructure(..))
 import Network.HTTP.Types
 -- }}}
 
-spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec :: DbStructure -> Pool H.Connection -> Spec
 spec struct pool = around (withApp cfgDefault struct pool) $ describe "CORS" $ do
     let preflightHeaders = [
           ("Accept", "*/*"),

test/Feature/DeleteSpec.hs

@@ -1,18 +1,17 @@
 module Feature.DeleteSpec where
 
+import Data.Pool
 import Test.Hspec
 import Test.Hspec.Wai
 import Text.Heredoc
 
-import Hasql as H
-import Hasql.Postgres as P
-
 import SpecHelper
 import PostgREST.Types (DbStructure(..))
+import qualified Hasql.Connection  as H
 
 import Network.HTTP.Types
 
-spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec :: DbStructure -> Pool H.Connection -> Spec
 spec struct pool = beforeAll resetDb
   . around (withApp cfgDefault struct pool) $
   describe "Deleting" $ do

test/Feature/InsertSpec.hs

@@ -5,22 +5,21 @@ import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus))
 
-import Hasql as H
-import Hasql.Postgres as P
-
 import SpecHelper
 import PostgREST.Types (DbStructure(..))
 
 import qualified Data.Aeson as JSON
 import Data.Maybe (fromJust)
+import Data.Pool
 import Text.Heredoc
 import Network.HTTP.Types.Header
 import Network.HTTP.Types
 import Control.Monad (replicateM_)
+import qualified Hasql.Connection  as H
 
 import TestTypes(IncPK(..), CompoundPK(..))
 
-spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec :: DbStructure -> Pool H.Connection -> Spec
 spec struct pool = beforeAll_ resetDb $ around (withApp cfgDefault struct pool) $ do
   describe "Posting new record" $ do
     context "disparate csv types" $ do

test/Feature/QueryLimitedSpec.hs

@@ -1,18 +1,17 @@
 module Feature.QueryLimitedSpec where
 
+import Data.Pool
 import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus))
-
+import qualified Hasql.Connection  as H
-import Hasql as H
-import Hasql.Postgres as P
 
 import SpecHelper
 import PostgREST.Types (DbStructure(..))
 
-spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec :: DbStructure -> Pool H.Connection -> Spec
 spec struct pool =
   beforeAll resetDb
    . around (withApp (cfgLimitRows 3) struct pool) $

test/Feature/QuerySpec.hs

@@ -1,19 +1,18 @@
 module Feature.QuerySpec where
 
+import Data.Pool
 import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders))
-
+import qualified Hasql.Connection  as H
-import Hasql as H
-import Hasql.Postgres as P
 
 import SpecHelper
 import PostgREST.Types (DbStructure(..))
 import Text.Heredoc
 
-spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec :: DbStructure -> Pool H.Connection -> Spec
 spec struct pool = around (withApp cfgDefault struct pool) $ do
 
   describe "Querying a table with a column called count" $

test/Feature/RangeSpec.hs

@@ -1,18 +1,17 @@
 module Feature.RangeSpec where
 
+import Data.Pool
 import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
-
+import qualified Hasql.Connection  as H
-import Hasql as H
-import Hasql.Postgres as P
 
 import SpecHelper
 import PostgREST.Types (DbStructure(..))
 
-spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec :: DbStructure -> Pool H.Connection -> Spec
 spec struct pool = beforeAll resetDb
   . around (withApp cfgDefault struct pool) $
   describe "GET /items" $ do

test/Feature/StructureSpec.hs

@@ -1,18 +1,17 @@
 module Feature.StructureSpec where
 
+import Data.Pool
 import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
-
+import qualified Hasql.Connection  as H
-import Hasql as H
-import Hasql.Postgres as P
 
 import SpecHelper
 import PostgREST.Types (DbStructure(..))
 
 import Network.HTTP.Types
 
-spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec :: DbStructure -> Pool H.Connection -> Spec
 spec struct pool = around (withApp cfgDefault struct pool) $ do
   describe "GET /" $ do
     it "lists views in schema" $

test/Main.hs

@@ -18,7 +18,7 @@ main :: IO ()
 main = do
   setupDb
 
-  pool <- specDbPool
+  pool <- testPool
   dbStructure <- specDbStructure pool
 
   -- Not using hspec-discover because we want to precompute

test/SpecHelper.hs

@@ -2,16 +2,8 @@ module SpecHelper where
 
 import Network.Wai
 import Test.Hspec
-import Test.Hspec.Wai
-
-import Hasql as H
-import Hasql.Backend as B
-import Hasql.Postgres as P
 
 import Data.String.Conversions (cs)
-import Data.Monoid
-import Data.Text hiding (map)
-import qualified Data.Vector as V
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Control.Monad (void)
 
@@ -19,57 +11,44 @@ import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
                                   hRange, hAuthorization, hAccept)
 import Codec.Binary.Base64.String (encode)
 import Data.CaseInsensitive (CI(..))
-import Data.Maybe (fromMaybe)
+import Data.Pool
 import Text.Regex.TDFA ((=~))
 import qualified Data.ByteString.Char8 as BS
 import System.Process (readProcess)
 import Web.JWT (secret)
 
+import qualified Hasql.Connection  as H
+import qualified Hasql.Session     as H
+
 import PostgREST.App (app)
 import PostgREST.Config (AppConfig(..))
 import PostgREST.Middleware
 import PostgREST.Error(pgErrResponse)
-import PostgREST.DbStructure
 import PostgREST.Types
 
 dbString :: String
 dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test"
 
-cfg :: String -> Maybe Int -> AppConfig
+cfg :: String -> Maybe Integer -> AppConfig
 cfg conStr = AppConfig conStr 3000 "postgrest_test_anonymous" "test" (secret "safe") 10
 
 cfgDefault :: AppConfig
 cfgDefault = cfg dbString Nothing
 
-cfgLimitRows :: Int -> AppConfig
+cfgLimitRows :: Integer -> AppConfig
 cfgLimitRows = cfg dbString . Just
 
-testPoolOpts :: PoolSettings
+withApp :: AppConfig -> DbStructure -> Pool H.Connection
-testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
-
-pgSettings :: P.Settings
-pgSettings = P.StringSettings $ cs dbString
-
-specDbPool :: IO (H.Pool P.Postgres)
-specDbPool = H.acquirePool pgSettings testPoolOpts
-
-specDbStructure :: H.Pool P.Postgres -> IO DbStructure
-specDbStructure pool = do
-  dbOrError <- H.session pool $ H.tx specTxSettings
-    $ getDbStructure "test"
-  either (fail . show) return dbOrError
-
-withApp :: AppConfig -> DbStructure -> H.Pool P.Postgres
         -> ActionWith Application -> IO ()
 withApp config dbStructure pool perform = do
-  perform $ middle $ \req resp -> do
+  perform $ defaultMiddle $ \req resp -> do
     time <- getPOSIXTime
     body <- strictRequestBody req
-    result <- liftIO $ H.session pool $ H.tx specTxSettings
+    let handleReq = H.run (runWithClaims config time (app dbStructure config body) req)
-      $ runWithClaims config time (app dbStructure config body) req
-    either (resp . pgErrResponse) resp result
 
-  where middle = defaultMiddle
+    withResource pool $ \c -> do
+      resOrError <- handleReq c
+      either (resp . pgErrResponse) resp resOrError
 
 setupDb :: IO ()
 setupDb = do
@@ -107,14 +86,6 @@ authHeaderJWT :: String -> Header
 authHeaderJWT token =
   (hAuthorization, cs $ "Bearer " ++ token)
 
-testPool :: IO(H.Pool P.Postgres)
+testPool :: IO (Pool (Either H.ConnectionError H.Connection))
-testPool = H.acquirePool pgSettings testPoolOpts
+testPool = createPool (H.acquire . cs $ dbString)
-
+  (either (const $ return ()) H.release) 1 1 1
-clearTable :: Text -> IO ()
-clearTable table = do
-  pool <- testPool
-  void . liftIO $ H.session pool $ H.tx Nothing $
-    H.unitEx $ B.Stmt ("truncate table test." <> table <> " cascade") V.empty True
-
-specTxSettings :: Maybe (TxIsolationLevel, Maybe Bool)
-specTxSettings = Just (H.ReadCommitted, Just True)