Feature specs compile

dbapi.cabal

@@ -56,7 +56,7 @@ Test-Suite spec
   ghc-options:         -Wall -W -Werror
   Main-Is:             Main.hs
   Other-Modules:       App, Auth, Config, Spec, SpecHelper
-  Build-Depends:       base, hspec2, QuickCheck
+  Build-Depends:       base, hspec >= 2.0, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
                      , hasql, hasql-backend, hasql-postgres
                      , warp >= 3.0.2, wai >= 3.0.1

test/Feature/AuthSpec.hs

@@ -11,7 +11,7 @@ import SpecHelper
 -- }}}
 
 spec :: Spec
-spec = around appWithFixture $
+spec = around withApp $
   describe "authorization" $ do
     it "hides tables that anonymous does not own" $
       get "/authors_only" `shouldRespondWith` 400 -- TODO: should be 404

test/Feature/CorsSpec.hs

@@ -12,7 +12,7 @@ import Network.HTTP.Types
 -- }}}
 
 spec :: Spec
-spec = around appWithFixture $
+spec = around withApp $
   describe "CORS" $ do
     let preflightHeaders = [
           ("Accept", "*/*"),

test/Feature/InsertSpec.hs

@@ -20,7 +20,7 @@ import TestTypes(IncPK(..), CompoundPK(..))
 -- }}}
 
 spec :: Spec
-spec = around appWithFixture $ do
+spec = around withApp $ do
   describe "Posting new record" $ do
     it "accepts disparate json types" $
       post "/menagerie"

test/Feature/QuerySpec.hs

@@ -5,8 +5,21 @@ import Test.Hspec.Wai
 
 import SpecHelper
 
+-- around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec
+-- type Spec = SpecWith ()
+-- type ActionWith a = a -> IO ()
+--
+-- get :: ByteString -> WaiSession SResponse
+-- newtype WaiSession a = WaiSession {unWaiSession :: Session a}
+-- type Session = ReaderT Application (StateT ClientState IO)
+--
+-- type Application =
+--   Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
+--
+-- runApp :: Request -> (Response -> IO Postgres) -> IO Postgres
+
 spec :: Spec
-spec = around appWithFixture $ do
+spec = around withApp $ do
   describe "Querying a nonexistent table" $
     it "causes a 404" $
       get "/faketable" `shouldRespondWith` 404

test/Feature/RangeSpec.hs

@@ -8,7 +8,7 @@ import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
 import SpecHelper
 
 spec :: Spec
-spec = around appWithFixture $
+spec = around withApp $
   describe "GET /items" $ do
 
     context "without range headers" $

test/Main.hs

@@ -1,17 +1,29 @@
+{-# LANGUAGE QuasiQuotes #-}
 module Main where
 
-import Database.PostgreSQL.Simple
+import qualified Hasql as H
+import qualified Hasql.Backend as H
+import qualified Hasql.Postgres as H
+import qualified Data.ByteString.Char8 as BS
 import Test.Hspec
+import SpecHelper
 import Spec
-import SpecHelper (openConnection, loadFixture)
 
 main :: IO ()
 main = do
-  c <-openConnection
-  _ <- execute_ c "drop schema if exists \"1\" cascade"
-  _ <- execute_ c "drop schema if exists private cascade"
-  _ <- execute_ c "drop schema if exists dbapi cascade"
-  loadFixture "roles" c
-  loadFixture "schema" c
-  close c
+  roles <- loadFixture "roles"
+  schema <- loadFixture "schema"
+  H.session pgSettings testSettings $ do
+    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 dbapi cascade |]
+      H.unit roles
+      H.unit schema
+
   hspec spec
+
+loadFixture :: FilePath -> IO(H.Statement H.Postgres)
+loadFixture name = do
+  query <- BS.readFile $ "test/fixtures/" ++ name ++ ".sql"
+  return (query, [])

test/SpecHelper.hs

@@ -4,71 +4,47 @@ import Network.Wai
 import Test.Hspec
 import Test.Hspec.Wai
 
-import Database.PostgreSQL.Simple
-import Database.PostgreSQL.Simple.Types
+import Hasql as H
+import Hasql.Postgres as H
 
 import Data.String.Conversions (cs)
-import Control.Exception.Base (bracket, finally)
-import Control.Monad (void)
+-- import Control.Exception.Base (bracket, finally)
+import Control.Monad.Reader (runReaderT, ask)
+-- import Control.Monad (void)
+import Control.Applicative ( (<$>) )
 
 import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
                                   hRange, hAuthorization)
 import Codec.Binary.Base64.String (encode)
 import Data.CaseInsensitive (CI(..))
+import Data.Maybe (fromMaybe)
 import Text.Regex.TDFA ((=~))
 import qualified Data.ByteString.Char8 as BS
-import Network.Wai.Middleware.Cors (cors)
-
-import Middleware(clientErrors, withSavepoint, authenticated, Environment(..))
+-- import Network.Wai.Middleware.Cors (cors)
 
 import App (app)
-import Config (corsPolicy, AppConfig(..))
-import Auth (addUser)
+-- import Config (corsPolicy, AppConfig(..))
+-- import Auth (addUser)
 
 isLeft :: Either a b -> Bool
 isLeft (Left _ ) = True
 isLeft _ = False
 
-cfg :: AppConfig
-cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10
+-- cfg :: AppConfig
+-- cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10
 
-openConnection :: IO Connection
-openConnection = connectPostgreSQL $ cs $ configDbUri cfg
+testSettings :: SessionSettings
+testSettings = fromMaybe (error "bad settings") $ H.sessionSettings 1 30
 
-withDatabaseConnection :: (Connection -> IO ()) -> IO ()
-withDatabaseConnection = bracket openConnection close
+pgSettings :: Postgres
+pgSettings = H.Postgres "localhost" 5432 "dbapi_test" "" "dbapi_test"
 
-loadFixture :: String -> Connection -> IO ()
-loadFixture name conn = do
-  sql <- readFile $ "test/fixtures/" ++ name ++ ".sql"
-  void $ execute_ conn $ Query (cs sql)
-
-dbWithSchema :: ActionWith Connection -> IO ()
-dbWithSchema action = withDatabaseConnection $ \c -> do
-  _ <- execute_ c "begin;"
-  action c
-  rollback c
-
-withUser :: BS.ByteString -> BS.ByteString -> BS.ByteString ->
-            ActionWith Connection -> ActionWith Connection
-withUser name pass role action conn = do
-  _ <- addUser conn name pass role
-  finally (action conn) $ do
-    _ <- execute conn "delete from dbapi.auth where id=?" $ Only name
-    execute_ conn "commit"
-
-withApp :: ActionWith Application -> ActionWith Connection
-withApp action conn = do
-  _ <- execute_ conn "begin;"
-  action $ cors corsPolicy $ authenticated "dbapi_anonymous" app conn
-  rollback conn
-
-appWithFixture :: ActionWith Application -> IO ()
-appWithFixture action = withDatabaseConnection $ \c -> do
-  _ <- execute_ c "begin;"
-  action $ cors corsPolicy . clientErrors  $
-    (authenticated "dbapi_anonymous" . Middleware.withSavepoint Test) app c
-  rollback c
+withApp :: ActionWith Application -> IO ()
+withApp perform =
+  perform $ \req resp ->
+    H.session pgSettings testSettings $ do
+      session' <- flip runReaderT <$> ask
+      liftIO $ resp =<< session' (app req)
 
 rangeHdrs :: ByteRange -> [Header]
 rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]
@@ -81,8 +57,8 @@ matchHeader name valRegex headers =
   maybe False (=~ valRegex) $ lookup name headers
 
 authHeader :: String -> String -> Header
-authHeader user pass =
-  (hAuthorization, cs $ "Basic " ++ encode (user ++ ":" ++ pass))
+authHeader u p =
+  (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
 
 -- for hspec-wai
 pending_ :: WaiSession ()