jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

WIP: share server code between tests and program

Browse Source 
- Share server code in Main
- Switch to hasql-pool
- Use pool in tests
- DRY up test runner
This commit is contained in:
Joe Nelson
2016-02-21 12:22:18 -08:00
parent 8a006f07a7
commit d7fe59f0b0
15 changed files with 109 additions and 141 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+8 -3
View File
@@ -23,7 +23,7 @@ Flag CI
executable postgrest
main-is: PostgREST/Main.hs
default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase
default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
build-depends: aeson >= 0.8 && < 0.10
@@ -35,6 +35,7 @@ executable postgrest
, contravariant
, errors
, hasql >= 0.19.3.3 && < 0.20
, hasql-pool >= 0.4 && < 0.5
, http-types
, interpolatedstring-perl6
, jwt
@@ -42,7 +43,6 @@ executable postgrest
, parsec
, postgrest
, regex-tdfa
, resource-pool
, safe >= 0.3 && < 0.4
, scientific
, string-conversions
@@ -86,6 +86,7 @@ library
, contravariant
, errors
, hasql
, hasql-pool
, http-types
, interpolatedstring-perl6
, jwt
@@ -123,7 +124,7 @@ library
Test-Suite spec
Type: exitcode-stdio-1.0
Default-Language: Haskell2010
default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes, LambdaCase
default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes
Hs-Source-Dirs: test, src
Main-Is: Main.hs
Other-Modules: Feature.AuthSpec
@@ -139,6 +140,7 @@ Test-Suite spec
, PostgREST.Auth
, PostgREST.Config
, PostgREST.Error
, PostgREST.Main
, PostgREST.Middleware
, PostgREST.Parsers
, PostgREST.DbStructure
@@ -159,6 +161,7 @@ Test-Suite spec
, contravariant
, errors
, hasql
, hasql-pool
, heredoc
, hspec == 2.2.*
, hspec-wai
@@ -179,10 +182,12 @@ Test-Suite spec
, transformers
, transformers-base
, unordered-containers
, unix
, vector
, wai
, wai-cors
, wai-extra
, wai-middleware-static
, warp
, HTTP
, Ranged-sets
src/PostgREST/Error.hs
+21 -10
View File
@@ -7,11 +7,13 @@ module PostgREST.Error (pgErrResponse, errResponse) where
import Data.Aeson ((.=))
import qualified Data.Aeson as JSON
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Hasql.Session as H
import qualified Hasql.Pool as P
import Network.HTTP.Types.Header
import qualified Network.HTTP.Types.Status as HT
import Network.Wai (Response, responseLBS)
@@ -19,10 +21,17 @@ import Network.Wai (Response, responseLBS)
errResponse :: HT.Status -> Text -> Response
errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"])
pgErrResponse :: H.Error -> Response
pgErrResponse :: P.UsageError -> Response
pgErrResponse e = responseLBS (httpStatus e)
[(hContentType, "application/json")] (JSON.encode e)
instance JSON.ToJSON P.UsageError where
toJSON (P.ConnectionError e) = JSON.object [
"code" .= ("" :: T.Text),
"message" .= ("Connection error" :: T.Text),
"details" .= (cs (fromMaybe "" e) :: T.Text)]
toJSON e = JSON.toJSON e -- H.Error
instance JSON.ToJSON H.Error where
toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [
"code" .= (cs c::T.Text),
@@ -51,15 +60,17 @@ instance JSON.ToJSON H.Error where
"message" .= ("Database client error"::String),
"details" .= (fmap cs d::Maybe T.Text)]
httpStatus :: H.Error -> HT.Status
httpStatus (H.ResultError (H.ServerError c _ _ _)) =
httpStatus :: P.UsageError -> HT.Status
httpStatus (P.ConnectionError _) =
HT.status500
httpStatus (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
case cs c of
'0':'8':_ -> HT.status503 -- pg connection err
'0':'9':_ -> HT.status500 -- triggered action exception
'0':'L':_ -> HT.status403 -- invalid grantor
'0':'P':_ -> HT.status403 -- invalid role specification
"23503" -> HT.status409 -- foreign_key_violation
"23505" -> HT.status409 -- unique_violation
"23503" -> HT.status409 -- foreign_key_violation
"23505" -> HT.status409 -- unique_violation
'2':'5':_ -> HT.status500 -- invalid tx state
'2':'8':_ -> HT.status403 -- invalid auth specification
'2':'D':_ -> HT.status500 -- invalid tx termination
@@ -76,8 +87,8 @@ httpStatus (H.ResultError (H.ServerError c _ _ _)) =
'H':'V':_ -> HT.status500 -- foreign data wrapper error
'P':'0':_ -> HT.status500 -- PL/pgSQL Error
'X':'X':_ -> HT.status500 -- internal Error
"42P01" -> HT.status404 -- undefined table
"42501" -> HT.status404 -- insufficient privilege
_ -> HT.status400
httpStatus (H.ResultError _) = HT.status500
httpStatus (H.ClientError _) = HT.status503
"42P01" -> HT.status404 -- undefined table
"42501" -> HT.status404 -- insufficient privilege
_ -> HT.status400
httpStatus (P.SessionError (H.ResultError _)) = HT.status500
httpStatus (P.SessionError (H.ClientError _)) = HT.status503
src/PostgREST/Main.hs
+29 -36
View File
@@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-}
module Main where
module PostgREST.Main where
import PostgREST.App
@@ -9,21 +9,20 @@ import PostgREST.Config (AppConfig (..),
prettyVersion,
readOptions)
import PostgREST.DbStructure
import PostgREST.Error (errResponse, pgErrResponse)
import PostgREST.Error (pgErrResponse)
import PostgREST.Middleware
import PostgREST.Types (DbStructure)
import PostgREST.QueryBuilder (inTransaction, Isolation(..))
import Control.Monad
import Data.Monoid ((<>))
import Data.Pool
import Data.String.Conversions (cs)
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Hasql.Query as H
import qualified Hasql.Connection as H
import qualified Hasql.Session as H
import qualified Hasql.Decoders as HD
import qualified Hasql.Encoders as HE
import qualified Network.HTTP.Types.Status as HT
import qualified Hasql.Pool as P
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger (logStdout)
@@ -55,51 +54,45 @@ main = do
conf <- readOptions
let port = configPort conf
pgSettings = cs (configDatabase conf)
appSettings = setPort port
. setServerName (cs $ "postgrest/" <> prettyVersion)
$ defaultSettings
unless (secret "secret" /= configJwtSecret conf) $
putStrLn "WARNING, running in insecure mode, JWT secret is the default value"
Prelude.putStrLn $ "Listening on port " ++
(show $ configPort conf :: String)
let pgSettings = cs (configDatabase conf)
appSettings = setPort port
. setServerName (cs $ "postgrest/" <> prettyVersion)
$ defaultSettings
middle = logStdout . defaultMiddle
pool <- createPool (H.acquire pgSettings)
(either (const $ return ()) H.release) 1 1 (configPool conf)
dbStructure <- withResource pool $ \case
Left err -> error $ show err
Right c -> do
supported <- H.run isServerVersionSupported c
case supported of
Left e -> error $ show e
Right good -> unless good $
error (
"Cannot run in this PostgreSQL version, PostgREST needs at least "
<> show minimumPgVersion)
dbOrError <- H.run (getDbStructure (cs $ configSchema conf)) c
either (error . show) return dbOrError
pool <- P.acquire (configPool conf, 10, pgSettings)
#ifndef mingw32_HOST_OS
tid <- myThreadId
void $ installHandler keyboardSignal (Catch $ do
destroyAllResources pool
P.release pool
throwTo tid UserInterrupt
) Nothing
#endif
runSettings appSettings $ middle $ \ req respond -> do
result <- P.use pool $ do
supported <- isServerVersionSupported
unless supported $ error (
"Cannot run in this PostgreSQL version, PostgREST needs at least "
<> show minimumPgVersion)
getDbStructure (cs $ configSchema conf)
let dbStructure = either (error.show) id result
runSettings appSettings $ postgrest conf dbStructure pool
postgrest :: AppConfig -> DbStructure -> P.Pool -> Application
postgrest conf dbStructure pool =
let middle = logStdout . defaultMiddle in
middle $ \ req respond -> do
time <- getPOSIXTime
body <- strictRequestBody req
let handleReq = H.run $ inTransaction ReadCommitted
(runWithClaims conf time (app dbStructure conf body) req)
res <- withResource pool $ \case
Left err -> return $ errResponse HT.status500 (cs . show $ err)
Right c -> do
resOrError <- handleReq c
return $ either pgErrResponse id resOrError
respond res
let handleReq = inTransaction ReadCommitted $
runWithClaims conf time (app dbStructure conf body) req
resp <- either pgErrResponse id <$> P.use pool handleReq
respond resp
stack.yaml
+1
View File
@@ -1,6 +1,7 @@
resolver: lts-5.0
extra-deps:
- hasql-0.19.3.3
- hasql-pool-0.4
- Ranged-sets-0.3.0
- packdeps-0.4.2.1
ghc-options:
test/Feature/AuthSpec.hs
+3 -5
View File
@@ -5,15 +5,13 @@ import Test.Hspec
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import Network.HTTP.Types
import qualified Hasql.Connection as H
import SpecHelper
import PostgREST.Types (DbStructure(..))
import Network.Wai (Application)
-- }}}
spec :: DbStructure -> H.Connection -> Spec
spec struct c = around (withApp cfgDefault struct c)
$ describe "authorization" $ do
spec :: SpecWith Application
spec = describe "authorization" $ do
it "hides tables that anonymous does not own" $
get "/authors_only" `shouldRespondWith` 404
test/Feature/ConcurrentSpec.hs
+3 -6
View File
@@ -13,14 +13,11 @@ import Test.Hspec.Wai.Internal
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import Network.Wai.Test (Session)
import qualified Hasql.Connection as H
import SpecHelper
import PostgREST.Types (DbStructure(..))
spec :: DbStructure -> H.Connection -> Spec
spec struct c = around (withApp cfgDefault struct c) $
import Network.Wai (Application)
spec :: SpecWith Application
spec =
describe "Queryiny in parallel" $
it "should not raise 'transaction in progress' error" $
raceTest 3 $
test/Feature/CorsSpec.hs
+4 -4
View File
@@ -5,16 +5,16 @@ 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 SpecHelper
import PostgREST.Types (DbStructure(..))
import Network.HTTP.Types
import Network.Wai (Application)
-- }}}
spec :: DbStructure -> H.Connection -> Spec
spec struct c = around (withApp cfgDefault struct c) $ describe "CORS" $ do
spec :: SpecWith Application
spec =
describe "CORS" $ do
let preflightHeaders = [
("Accept", "*/*"),
("Origin", "http://example.com"),
test/Feature/DeleteSpec.hs
+3 -7
View File
@@ -4,15 +4,11 @@ import Test.Hspec
import Test.Hspec.Wai
import Text.Heredoc
import SpecHelper
import PostgREST.Types (DbStructure(..))
import qualified Hasql.Connection as H
import Network.HTTP.Types
import Network.Wai (Application)
spec :: DbStructure -> H.Connection -> Spec
spec struct c = beforeAll resetDb
. around (withApp cfgDefault struct c) $
spec :: SpecWith Application
spec =
describe "Deleting" $ do
context "existing record" $ do
it "succeeds with 204 and deletion count" $
test/Feature/InsertSpec.hs
+3 -4
View File
@@ -6,7 +6,6 @@ import Test.Hspec.Wai.JSON
import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus))
import SpecHelper
import PostgREST.Types (DbStructure(..))
import qualified Data.Aeson as JSON
import Data.Maybe (fromJust)
@@ -14,12 +13,12 @@ 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(..))
import Network.Wai (Application)
spec :: DbStructure -> H.Connection -> Spec
spec struct c = beforeAll_ resetDb $ around (withApp cfgDefault struct c) $ do
spec :: SpecWith Application
spec = do
describe "Posting new record" $ do
context "disparate json types" $ do
it "accepts disparate json types" $ do
test/Feature/QueryLimitedSpec.hs
+3 -6
View File
@@ -5,15 +5,12 @@ 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 SpecHelper
import PostgREST.Types (DbStructure(..))
import Network.Wai (Application)
spec :: DbStructure -> H.Connection -> Spec
spec struct c =
beforeAll resetDb
. around (withApp (cfgLimitRows 3) struct c) $
spec :: SpecWith Application
spec =
describe "Requesting many items with server limits enabled" $ do
it "restricts results" $
get "/items"
test/Feature/QuerySpec.hs
+3 -4
View File
@@ -5,14 +5,13 @@ 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 SpecHelper
import PostgREST.Types (DbStructure(..))
import Text.Heredoc
import Network.Wai (Application)
spec :: DbStructure -> H.Connection -> Spec
spec struct c = around (withApp cfgDefault struct c) $ do
spec :: SpecWith Application
spec = 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
+4 -5
View File
@@ -5,14 +5,13 @@ 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 SpecHelper
import PostgREST.Types (DbStructure(..))
import Network.Wai (Application)
spec :: SpecWith Application
spec =
spec :: DbStructure -> H.Connection -> Spec
spec struct c = beforeAll resetDb
. around (withApp cfgDefault struct c) $
describe "GET /items" $ do
context "without range headers" $ do
test/Feature/StructureSpec.hs
+4 -4
View File
@@ -3,15 +3,15 @@ module Feature.StructureSpec where
import Test.Hspec hiding (pendingWith)
import Test.Hspec.Wai
import Test.Hspec.Wai.JSON
import qualified Hasql.Connection as H
import SpecHelper
import PostgREST.Types (DbStructure(..))
import Network.HTTP.Types
import Network.Wai (Application)
spec :: SpecWith Application
spec = do
spec :: DbStructure -> H.Connection -> Spec
spec struct c = around (withApp cfgDefault struct c) $ do
describe "GET /" $ do
it "lists views in schema" $
request methodGet "/" [] ""
test/Main.hs
+20 -20
View File
@@ -3,10 +3,10 @@ module Main where
import Test.Hspec
import SpecHelper
import qualified Hasql.Session as H
import qualified Hasql.Connection as H
import qualified Hasql.Pool as P
import PostgREST.DbStructure (getDbStructure)
import PostgREST.Main (postgrest)
import Data.String.Conversions (cs)
import qualified Feature.AuthSpec
@@ -23,23 +23,23 @@ main :: IO ()
main = do
setupDb
H.acquire (cs dbString) >>= \case
Left err -> error $ show err
Right c -> do
dbOrErr <- H.run (getDbStructure "test") c
-- Not using hspec-discover because we want to precompute
-- the db structure and pass it to specs for speed
either (error.show) (hspec . specs c) dbOrErr
H.release c
pool <- P.acquire (10, 10, cs dbString)
result <- P.use pool $ getDbStructure "test"
let dbStructure = either (error.show) id result
withApp = ($ postgrest cfgDefault dbStructure pool)
hspec . sequence_ . map (around withApp) $ specs
where
specs conn dbStructure = do
describe "Feature.AuthSpec" $ Feature.AuthSpec.spec dbStructure conn
describe "Feature.ConcurrentSpec" $ Feature.ConcurrentSpec.spec dbStructure conn
describe "Feature.CorsSpec" $ Feature.CorsSpec.spec dbStructure conn
describe "Feature.DeleteSpec" $ Feature.DeleteSpec.spec dbStructure conn
describe "Feature.InsertSpec" $ Feature.InsertSpec.spec dbStructure conn
describe "Feature.QueryLimitedSpec" $ Feature.QueryLimitedSpec.spec dbStructure conn
describe "Feature.QuerySpec" $ Feature.QuerySpec.spec dbStructure conn
describe "Feature.RangeSpec" $ Feature.RangeSpec.spec dbStructure conn
describe "Feature.StructureSpec" $ Feature.StructureSpec.spec dbStructure conn
specs = map (uncurry describe) [
("Feature.AuthSpec" , Feature.AuthSpec.spec)
, ("Feature.ConcurrentSpec" , Feature.ConcurrentSpec.spec)
, ("Feature.CorsSpec" , Feature.CorsSpec.spec)
, ("Feature.DeleteSpec" , Feature.DeleteSpec.spec)
, ("Feature.InsertSpec" , Feature.InsertSpec.spec)
, ("Feature.QueryLimitedSpec" , Feature.QueryLimitedSpec.spec)
, ("Feature.QuerySpec" , Feature.QuerySpec.spec)
, ("Feature.RangeSpec" , Feature.RangeSpec.spec)
, ("Feature.StructureSpec" , Feature.StructureSpec.spec)
]
test/SpecHelper.hs
-27
View File
@@ -1,10 +1,6 @@
module SpecHelper where
import Network.Wai
import Test.Hspec
import Data.String.Conversions (cs)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Control.Monad (void)
import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
@@ -16,15 +12,7 @@ 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.Types
import PostgREST.QueryBuilder (inTransaction, Isolation(..))
dbString :: String
dbString = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test"
@@ -38,21 +26,6 @@ cfgDefault = cfg dbString Nothing
cfgLimitRows :: Integer -> AppConfig
cfgLimitRows = cfg dbString . Just
withApp :: AppConfig -> DbStructure -> H.Connection
-> ActionWith Application -> IO ()
withApp config dbStructure c perform =
perform $ defaultMiddle $ \req resp -> do
time <- getPOSIXTime
body <- strictRequestBody req
let handleReq = H.run $ inTransaction ReadCommitted
(runWithClaims config time (app dbStructure config body) req)
handleReq c >>= \case
Left err -> do
void $ H.run (H.sql "rollback;") c
resp $ pgErrResponse err
Right res -> resp res
setupDb :: IO ()
setupDb = do
void $ readProcess "psql" ["-d", "postgres", "-a", "-f", "test/fixtures/database.sql"] []