diff --git a/dbapi.cabal b/dbapi.cabal index a100bf093..14f0b90b0 100644 --- a/dbapi.cabal +++ b/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 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs index 55e754d9c..91198be1b 100644 --- a/test/Feature/AuthSpec.hs +++ b/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 diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs index 4d25b04aa..a08a64d9f 100644 --- a/test/Feature/CorsSpec.hs +++ b/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", "*/*"), diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs index 8f047dc69..df5d56593 100644 --- a/test/Feature/InsertSpec.hs +++ b/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" diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 06328b685..5de26a271 100644 --- a/test/Feature/QuerySpec.hs +++ b/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 diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs index 8beba88bb..e9909556f 100644 --- a/test/Feature/RangeSpec.hs +++ b/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" $ diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hx similarity index 100% rename from test/Feature/StructureSpec.hs rename to test/Feature/StructureSpec.hx diff --git a/test/Main.hs b/test/Main.hs index abe226374..a3380388c 100644 --- a/test/Main.hs +++ b/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, []) diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index ca42e9092..a86d7c567 100644 --- a/test/SpecHelper.hs +++ b/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 ()