Cache schema structure between tests for speed

Causes one test to fail

test/Feature/AuthSpec.hs

@@ -6,11 +6,15 @@ import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 
+import Hasql as H
+import Hasql.Postgres as P
+
 import SpecHelper
+import PostgREST.Types (DbStructure(..))
 -- }}}
 
-spec :: Spec
+spec :: DbStructure -> H.Pool P.Postgres -> Spec
-spec = around (withApp cfgDefault)
+spec struct pool = around (withApp cfgDefault struct pool)
   $ describe "authorization" $ do
 
   it "hides tables that anonymous does not own" $

test/Feature/CorsSpec.hs

@@ -6,13 +6,17 @@ import Test.Hspec.Wai
 import Network.Wai.Test (SResponse(simpleHeaders, simpleBody))
 import qualified Data.ByteString.Lazy as BL
 
+import Hasql as H
+import Hasql.Postgres as P
+
 import SpecHelper
+import PostgREST.Types (DbStructure(..))
 
 import Network.HTTP.Types
 -- }}}
 
-spec :: Spec
+spec :: DbStructure -> H.Pool P.Postgres -> Spec
-spec = around (withApp cfgDefault) $ describe "CORS" $ do
+spec struct pool = around (withApp cfgDefault struct pool) $ describe "CORS" $ do
     let preflightHeaders = [
           ("Accept", "*/*"),
           ("Origin", "http://example.com"),

test/Feature/DeleteSpec.hs

@@ -2,13 +2,18 @@ module Feature.DeleteSpec where
 
 import Test.Hspec
 import Test.Hspec.Wai
+
+import Hasql as H
+import Hasql.Postgres as P
+
 import SpecHelper
+import PostgREST.Types (DbStructure(..))
 
 import Network.HTTP.Types
 
-spec :: Spec
+spec :: DbStructure -> H.Pool P.Postgres -> Spec
-spec = beforeAll resetDb
+spec struct pool = beforeAll resetDb
-  . around (withApp cfgDefault) $
+  . around (withApp cfgDefault struct pool) $
   describe "Deleting" $ do
     context "existing record" $ do
       it "succeeds with 204 and deletion count" $

test/Feature/InsertSpec.hs

@@ -5,7 +5,11 @@ 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)
@@ -16,8 +20,8 @@ import Control.Monad (replicateM_)
 
 import TestTypes(IncPK(..), CompoundPK(..))
 
-spec :: Spec
+spec :: DbStructure -> H.Pool P.Postgres -> Spec
-spec = beforeAll_ resetDb $ around (withApp cfgDefault) $ do
+spec struct pool = beforeAll_ resetDb $ around (withApp cfgDefault struct pool) $ do
   describe "Posting new record" $ do
     after_ (clearTable "menagerie") . context "disparate csv types" $ do
       it "accepts disparate json types" $ do

test/Feature/QueryLimitedSpec.hs

@@ -6,12 +6,16 @@ import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus))
 
-import SpecHelper
+import Hasql as H
+import Hasql.Postgres as P
 
-spec :: Spec
+import SpecHelper
-spec =
+import PostgREST.Types (DbStructure(..))
+
+spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec struct pool =
   beforeAll resetDb
-   . around (withApp $ cfgLimitRows 3) $
+   . around (withApp (cfgLimitRows 3) struct pool) $
   describe "Requesting many items with server limits enabled" $ do
     it "restricts results" $
       get "/items"

test/Feature/QuerySpec.hs

@@ -6,12 +6,15 @@ import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders))
 
+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 :: Spec
+spec struct pool = around (withApp cfgDefault struct pool) $ do
-spec = around (withApp cfgDefault) $ do
 
   describe "Querying a table with a column called count" $
     it "should not confuse count column with pg_catalog.count aggregate" $

test/Feature/RangeSpec.hs

@@ -6,11 +6,15 @@ import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
 
-import SpecHelper
+import Hasql as H
+import Hasql.Postgres as P
 
-spec :: Spec
+import SpecHelper
-spec = beforeAll resetDb
+import PostgREST.Types (DbStructure(..))
-  . around (withApp cfgDefault) $
+
+spec :: DbStructure -> H.Pool P.Postgres -> Spec
+spec struct pool = beforeAll resetDb
+  . around (withApp cfgDefault struct pool) $
   describe "GET /items" $ do
 
     context "without range headers" $ do

test/Feature/StructureSpec.hs

@@ -4,12 +4,16 @@ import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 
+import Hasql as H
+import Hasql.Postgres as P
+
 import SpecHelper
+import PostgREST.Types (DbStructure(..))
 
 import Network.HTTP.Types
 
-spec :: Spec
+spec :: DbStructure -> H.Pool P.Postgres -> Spec
-spec = around (withApp cfgDefault) $ do
+spec struct pool = around (withApp cfgDefault struct pool) $ do
   describe "GET /" $ do
     it "lists views in schema" $
       request methodGet "/" [] ""

test/Main.hs

@@ -2,7 +2,37 @@ module Main where
 
 import Test.Hspec
 import SpecHelper
-import Spec
+
+import PostgREST.Types (DbStructure(..))
+
+import qualified Feature.AuthSpec
+import qualified Feature.CorsSpec
+import qualified Feature.DeleteSpec
+import qualified Feature.InsertSpec
+import qualified Feature.QueryLimitedSpec
+import qualified Feature.QuerySpec
+import qualified Feature.RangeSpec
+import qualified Feature.StructureSpec
 
 main :: IO ()
-main = setupDb >> hspec spec
+main = do
+  setupDb
+
+  pool <- specDbPool
+  dbStructure <- specDbStructure pool
+
+  -- Not using hspec-discover because we want to precompute
+  -- the db structure and pass it to specs for speed
+  mapM_ (hspec . ($ pool) . ($ dbStructure)) specs
+
+ where
+  specs = [
+      Feature.AuthSpec.spec
+    , Feature.CorsSpec.spec
+    , Feature.DeleteSpec.spec
+    , Feature.InsertSpec.spec
+    , Feature.QueryLimitedSpec.spec
+    , Feature.QuerySpec.spec
+    , Feature.RangeSpec.spec
+    , Feature.StructureSpec.spec
+    ]

test/Spec.hs

@@ -1 +0,0 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}

test/SpecHelper.hs

@@ -30,6 +30,7 @@ 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"
@@ -49,20 +50,23 @@ testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
 pgSettings :: P.Settings
 pgSettings = P.StringSettings $ cs dbString
 
-withApp :: AppConfig -> ActionWith Application -> IO ()
+specDbPool :: IO (H.Pool P.Postgres)
-withApp config perform = do
+specDbPool = H.acquirePool pgSettings testPoolOpts
-  pool :: H.Pool P.Postgres
-    <- H.acquirePool pgSettings testPoolOpts
 
-  let txSettings = Just (H.ReadCommitted, Just True)
+specDbStructure :: H.Pool P.Postgres -> IO DbStructure
-  dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema config)
+specDbStructure pool = do
-  db <- either (fail . show) return dbOrError
+  dbOrError <- H.session pool $ H.tx specTxSettings
+    $ getDbStructure "postgrest_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
     time <- getPOSIXTime
     body <- strictRequestBody req
-    result <- liftIO $ H.session pool $ H.tx txSettings
+    result <- liftIO $ H.session pool $ H.tx specTxSettings
-      $ runWithClaims config time (app db config body) req
+      $ runWithClaims config time (app dbStructure config body) req
     either (resp . pgErrResponse) resp result
 
   where middle = defaultMiddle
@@ -111,3 +115,5 @@ 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 = Just (H.ReadCommitted, Just True)