Tests compile, run, and fail

Temporarily disabled unit tests

dbapi.cabal

@@ -37,6 +37,7 @@ executable dbapi
                      , resource-pool, process
                      , blaze-builder
   Other-Modules:       App
+                     , Config
                      , PgStructure
                      , PgQuery
                      , RangeQuery
@@ -51,7 +52,7 @@ Test-Suite spec
   Hs-Source-Dirs:      test, src
   ghc-options:         -Wall -W -Werror
   Main-Is:             Main.hs
-  Other-Modules:       App, Spec, SpecHelper
+  Other-Modules:       App, Config, Spec, SpecHelper
   Build-Depends:       base, hspec2, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
                      , postgresql-simple >= 0.4.7.0

src/Config.hs

@@ -0,0 +1,49 @@
+module Config where
+
+import Network.Wai
+import Control.Applicative
+import Data.Text (strip)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.ByteString.Char8 as BS
+import Data.String.Conversions (cs)
+import Options.Applicative hiding (columns)
+import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
+
+data AppConfig = AppConfig {
+    configDbUri :: String
+  , configPort  :: Int
+  , configAnonRole :: String
+  , configSecure :: Bool
+  , configPool :: Int
+  }
+
+argParser :: Parser AppConfig
+argParser = AppConfig
+  <$> strOption (long "db" <> short 'd' <> metavar "URI"
+    <> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
+  <*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
+    <> help "port number on which to run HTTP server")
+  <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE"
+    <> help "postgres role to use for non-authenticated requests")
+  <*> switch (long "secure" <> short 's'
+    <> help "Redirect all requests to HTTPS")
+  <*> option (long "db-pool" <> metavar "NUMBER" <> value 10
+    <> help "Max connections in database pool")
+
+defaultCorsPolicy :: CorsResourcePolicy
+defaultCorsPolicy =  CorsResourcePolicy Nothing
+  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
+  (Just $ 60*60*24) False False True
+
+corsPolicy :: Request -> Maybe CorsResourcePolicy
+corsPolicy req = case lookup "origin" headers of
+  Just origin -> Just defaultCorsPolicy {
+      corsOrigins = Just ([origin], True)
+    , corsRequestHeaders = "Authentication":accHeaders
+    }
+  Nothing -> Nothing
+  where
+    headers = requestHeaders req
+    accHeaders = case lookup "access-control-request-headers" headers of
+      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
+      Nothing -> []

src/Main.hs

@@ -5,45 +5,21 @@ import Paths_dbapi (version)
 import App
 import Middleware (inTransaction, authenticated, withSavepoint, clientErrors,
   redirectInsecure, withDBConnection, Environment(..))
-import Data.String.Conversions (cs)
 
-import qualified Data.CaseInsensitive as CI
-import qualified Data.ByteString.Char8 as BS
 import Control.Monad (unless)
-import Control.Applicative
 import Control.Exception(bracket)
-import Options.Applicative hiding (columns)
+import Data.String.Conversions (cs)
-import Network.Wai
+import Network.Wai.Middleware.Cors (cors)
 import Network.Wai.Handler.Warp hiding (Connection)
 import Network.Wai.Middleware.Gzip (gzip, def)
-import Network.Wai.Middleware.Cors (cors, CorsResourcePolicy(..))
 import Network.Wai.Middleware.Static (staticPolicy, only)
 import Data.Pool(createPool, destroyAllResources)
 import Data.List (intercalate)
 import Data.Version (versionBranch)
-import Data.Text (strip)
 import Database.PostgreSQL.Simple
+import Options.Applicative hiding (columns)
 
-data AppConfig = AppConfig {
+import Config (AppConfig(..), argParser, corsPolicy)
-    configDbUri :: String
-  , configPort  :: Int
-  , configAnonRole :: String
-  , configSecure :: Bool
-  , configPool :: Int
-  }
-
-argParser :: Parser AppConfig
-argParser = AppConfig
-  <$> strOption (long "db" <> short 'd' <> metavar "URI"
-    <> help "database uri to expose, e.g. postgres://user:pass@host:port/database")
-  <*> option (long "port" <> short 'p' <> metavar "NUMBER" <> value 3000
-    <> help "port number on which to run HTTP server")
-  <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE"
-    <> help "postgres role to use for non-authenticated requests")
-  <*> switch (long "secure" <> short 's'
-    <> help "Redirect all requests to HTTPS")
-  <*> option (long "db-pool" <> metavar "NUMBER" <> value 10
-    <> help "Max connections in database pool")
 
 main :: IO ()
 main = do
@@ -71,22 +47,3 @@ main = do
   where
     describe = progDesc "create a REST API to an existing Postgres database"
     prettyVersion = intercalate "." $ map show $ versionBranch version
-
-
-defaultCorsPolicy :: CorsResourcePolicy
-defaultCorsPolicy =  CorsResourcePolicy Nothing
-  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
-  (Just $ 60*60*24) False False True
-
-corsPolicy :: Request -> Maybe CorsResourcePolicy
-corsPolicy req = case lookup "origin" headers of
-  Just origin -> Just defaultCorsPolicy {
-      corsOrigins = Just ([origin], True)
-    , corsRequestHeaders = "Authentication":accHeaders
-    }
-  Nothing -> Nothing
-  where
-    headers = requestHeaders req
-    accHeaders = case lookup "access-control-request-headers" headers of
-      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
-      Nothing -> []

test/Main.hs

@@ -1,6 +1,6 @@
 module Main where
 
-import Database.HDBC (runRaw, disconnect)
+import Database.PostgreSQL.Simple
 import Test.Hspec
 import Spec
 import SpecHelper (openConnection, loadFixture)
@@ -8,10 +8,10 @@ import SpecHelper (openConnection, loadFixture)
 main :: IO ()
 main = do
   c <-openConnection
-  runRaw c "drop schema if exists \"1\" cascade"
+  _ <- execute_ c "drop schema if exists \"1\" cascade"
-  runRaw c "drop schema if exists private cascade"
+  _ <- execute_ c "drop schema if exists private cascade"
-  runRaw c "drop schema if exists dbapi cascade"
+  _ <- execute_ c "drop schema if exists dbapi cascade"
   loadFixture "roles" c
   loadFixture "schema" c
-  disconnect c
+  close c
   hspec spec

test/SpecHelper.hs

@@ -4,11 +4,12 @@ import Network.Wai
 import Test.Hspec
 import Test.Hspec.Wai
 
-import Database.HDBC
+import Database.PostgreSQL.Simple
-import Database.HDBC.PostgreSQL
+import Database.PostgreSQL.Simple.Types
 
 import Data.String.Conversions (cs)
 import Control.Exception.Base (bracket, finally)
+import Control.Monad (void)
 
 import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
                                   hRange, hAuthorization)
@@ -20,8 +21,9 @@ import Network.Wai.Middleware.Cors (cors)
 
 import Middleware(clientErrors, withSavepoint, authenticated, Environment(..))
 
-import Dbapi (app, corsPolicy, AppConfig(..))
+import App (app)
-import PgQuery(addUser)
+import Config (corsPolicy, AppConfig(..))
+import Auth (addUser)
 
 isLeft :: Either a b -> Bool
 isLeft (Left _ ) = True
@@ -31,41 +33,41 @@ cfg :: AppConfig
 cfg = AppConfig "postgres://dbapi_test:@localhost:5432/dbapi_test" 9000 "dbapi_anonymous" False 10
 
 openConnection :: IO Connection
-openConnection = connectPostgreSQL' $ configDbUri cfg
+openConnection = connectPostgreSQL $ cs $ configDbUri cfg
 
 withDatabaseConnection :: (Connection -> IO ()) -> IO ()
-withDatabaseConnection = bracket openConnection disconnect
+withDatabaseConnection = bracket openConnection close
 
 loadFixture :: String -> Connection -> IO ()
 loadFixture name conn = do
   sql <- readFile $ "test/fixtures/" ++ name ++ ".sql"
-  runRaw conn sql
+  void $ execute_ conn $ Query (cs sql)
 
 dbWithSchema :: ActionWith Connection -> IO ()
 dbWithSchema action = withDatabaseConnection $ \c -> do
-  runRaw c "begin;"
+  _ <- 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 name pass role conn
+  _ <- addUser conn name pass role
   finally (action conn) $ do
-    _ <- run conn "delete from dbapi.auth where id=?" [toSql name]
+    _ <- execute conn "delete from dbapi.auth where id=?" $ Only name
-    runRaw conn "commit"
+    execute_ conn "commit"
 
 withApp :: ActionWith Application -> ActionWith Connection
 withApp action conn = do
-  runRaw conn "begin;"
+  _ <- execute_ conn "begin;"
   action $ cors corsPolicy $ authenticated "dbapi_anonymous" app conn
   rollback conn
 
 appWithFixture :: ActionWith Application -> IO ()
 appWithFixture action = withDatabaseConnection $ \c -> do
-  runRaw c "begin;"
+  _ <- execute_ c "begin;"
   action $ cors corsPolicy . clientErrors  $
-    (authenticated "dbapi_anonymous" . withSavepoint Test) app c
+    (authenticated "dbapi_anonymous" . Middleware.withSavepoint Test) app c
   rollback c
 
 rangeHdrs :: ByteRange -> [Header]

test/TestTypes.hs

@@ -1,18 +1,16 @@
 module TestTypes (
   IncPK(..)
 , CompoundPK(..)
-, incFromList
+-- , incFromList
-, compoundFromList
+-- , compoundFromList
 ) where
 
 import qualified Data.Aeson as JSON
 import Data.Aeson ((.:))
-import Data.Maybe (fromJust)
+-- import Data.Maybe (fromJust)
 import Control.Applicative ((<$>), (<*>))
 import Control.Monad (mzero)
 
-import Database.HDBC (SqlValue, fromSql)
-
 data IncPK = IncPK {
   incId :: Int
 , incNullableStr :: Maybe String
@@ -28,12 +26,12 @@ instance JSON.FromJSON IncPK where
     r .: "inserted_at"
   parseJSON _ = mzero
 
-incFromList :: [(String, SqlValue)] -> IncPK
+-- incFromList :: [(String, SqlValue)] -> IncPK
-incFromList row = IncPK
+-- incFromList row = IncPK
-  (fromSql . fromJust $ lookup "id" row)
+--   (fromSql . fromJust $ lookup "id" row)
-  (fromSql . fromJust $ lookup "nullable_string" row)
+--   (fromSql . fromJust $ lookup "nullable_string" row)
-  (fromSql . fromJust $ lookup "non_nullable_string" row)
+--   (fromSql . fromJust $ lookup "non_nullable_string" row)
-  (fromSql . fromJust $ lookup "inserted_at" row)
+--   (fromSql . fromJust $ lookup "inserted_at" row)
 
 data CompoundPK = CompoundPK {
   compoundK1 :: Int
@@ -48,8 +46,8 @@ instance JSON.FromJSON CompoundPK where
     r .: "extra"
   parseJSON _ = mzero
 
-compoundFromList :: [(String, SqlValue)] -> CompoundPK
+-- compoundFromList :: [(String, SqlValue)] -> CompoundPK
-compoundFromList row = CompoundPK
+-- compoundFromList row = CompoundPK
-  (fromSql . fromJust $ lookup "k1" row)
+--   (fromSql . fromJust $ lookup "k1" row)
-  (fromSql . fromJust $ lookup "k2" row)
+--   (fromSql . fromJust $ lookup "k2" row)
-  (fromSql . fromJust $ lookup "extra" row)
+--   (fromSql . fromJust $ lookup "extra" row)

test/fixtures/roles.sql

@@ -11,7 +11,6 @@ BEGIN
 END;
 $$;
 
-select pg_temp.create_role_if_not_exists('dbapi_anonymous', 'with nologin');
+select pg_temp.create_role_if_not_exists('dbapi_anonymous', 'with nologin') as a
-select pg_temp.create_role_if_not_exists('test_default_role', 'with nologin');
+     , pg_temp.create_role_if_not_exists('test_default_role', 'with nologin') as b
-
+     , pg_temp.create_role_if_not_exists('dbapi_test_author', 'with nologin') into temp shh;
-select pg_temp.create_role_if_not_exists('dbapi_test_author', 'with nologin');