postgrest 5.2.0 → 6.0.0
raw patch · 44 files changed
+2693/−1583 lines, 44 filesdep +configurator-pgdep +directorydep +networkdep −configurator-ngdep −hjsonschemadep ~HTTPdep ~Ranged-setsdep ~aeson
Dependencies added: configurator-pg, directory, network
Dependencies removed: configurator-ng, hjsonschema
Dependency ranges changed: HTTP, Ranged-sets, aeson, aeson-qq, ansi-wl-pprint, async, auto-update, base, base64-bytestring, bytestring, case-insensitive, cassava, containers, contravariant, contravariant-extras, cookie, either, gitrev, hasql, hasql-transaction, heredoc, hspec, hspec-wai, hspec-wai-json, http-types, insert-ordered-containers, interpolatedstring-perl6, jose, lens, lens-aeson, monad-control, network-uri, parsec, process, protolude, regex-tdfa, retry, scientific, swagger2, text, time, transformers-base, unordered-containers, vector, wai, wai-cors, wai-extra, wai-middleware-static, warp
Files
- CHANGELOG.md +35/−0
- main/Main.hs +128/−86
- postgrest.cabal +175/−169
- src/PostgREST/ApiRequest.hs +106/−97
- src/PostgREST/App.hs +165/−178
- src/PostgREST/Auth.hs +13/−11
- src/PostgREST/Config.hs +127/−86
- src/PostgREST/DbRequestBuilder.hs +82/−64
- src/PostgREST/DbStructure.hs +108/−74
- src/PostgREST/Error.hs +197/−132
- src/PostgREST/Middleware.hs +25/−28
- src/PostgREST/OpenAPI.hs +46/−32
- src/PostgREST/Parsers.hs +44/−18
- src/PostgREST/QueryBuilder.hs +166/−136
- src/PostgREST/RangeQuery.hs +13/−11
- src/PostgREST/Types.hs +181/−81
- test/Feature/AndOrParamsSpec.hs +5/−4
- test/Feature/AsymmetricJwtSpec.hs +4/−4
- test/Feature/AudienceJwtSecretSpec.hs +5/−5
- test/Feature/AuthSpec.hs +28/−9
- test/Feature/BinaryJwtSecretSpec.hs +4/−4
- test/Feature/ConcurrentSpec.hs +9/−8
- test/Feature/CorsSpec.hs +5/−5
- test/Feature/DeleteSpec.hs +3/−3
- test/Feature/ExtraSearchPathSpec.hs +3/−4
- test/Feature/InsertSpec.hs +182/−67
- test/Feature/JsonOperatorSpec.hs +23/−8
- test/Feature/NoJwtSpec.hs +11/−5
- test/Feature/NonexistentSchemaSpec.hs +3/−1
- test/Feature/PgVersion95Spec.hs +3/−3
- test/Feature/PgVersion96Spec.hs +27/−7
- test/Feature/ProxySpec.hs +2/−4
- test/Feature/QueryLimitedSpec.hs +6/−5
- test/Feature/QuerySpec.hs +114/−58
- test/Feature/RangeSpec.hs +37/−10
- test/Feature/RootSpec.hs +30/−0
- test/Feature/RpcSpec.hs +188/−13
- test/Feature/SingularSpec.hs +58/−50
- test/Feature/StructureSpec.hs +171/−11
- test/Feature/UnicodeSpec.hs +4/−4
- test/Feature/UpsertSpec.hs +75/−21
- test/Main.hs +35/−25
- test/SpecHelper.hs +41/−36
- test/TestTypes.hs +6/−6
CHANGELOG.md view
@@ -9,6 +9,41 @@ ### Fixed +## [6.0.0] - 2019-06-21++### Added++- #1186, Add support for user defined unix socket via `server-unix-socket` config option+- #690, Add `?columns` query parameter for faster bulk inserts, also ignores unspecified json keys in a payload - @steve-chavez+- #1239, Add support for resource embedding on materialized views - @vitorbaptista+- #1264, Add support for bulk RPC call - @steve-chavez+- #1278, Add db-pool-timeout config option - @qu4tro+- #1285, Abort on wrong database password - @qu4tro+- #790, Allow override of OpenAPI spec through `root-spec` config option - @steve-chavez+- #1308, Accept `text/plain` and `text/html` for raw output - @steve-chavez++### Fixed++- #1223, Fix incorrect OpenAPI externalDocs url - @steve-chavez+- #1221, Fix embedding other resources when having a self join - @steve-chavez+- #1242, Fix embedding a view having a select in a where - @steve-chavez+- #1238, Fix PostgreSQL to OpenAPI type mappings for numeric and character types - @fpusch+- #1265, Fix query generated on bulk upsert with an empty array - @qu4tro+- #1273, Fix RPC ignoring unknown arguments by default - @steve-chavez+- #1257, Fix incorrect status when a PATCH request doesn't find rows to change - @qu4tro++### Changed++- #1288, Change server-host default of 127.0.0.1 to !4++### Deprecated++- #1288, Deprecate `.` symbol for disambiguating resource embedding(added in #918). '+' should be used instead. Though '+' is url safe, certain clients might need to encode it to '%2B'.++### Removed++- #1288, Removed support for schema reloading with SIGHUP, SIGUSR1 should be used instead - @steve-chavez+ ## [5.2.0] - 2018-12-12 ### Added
main/Main.hs view
@@ -2,42 +2,51 @@ module Main where --import PostgREST.App (postgrest)-import PostgREST.Config (AppConfig (..),- prettyVersion, readOptions)-import PostgREST.DbStructure (getDbStructure, getPgVersion)-import PostgREST.Error (encodeError)-import PostgREST.OpenAPI (isMalformedProxyUri)-import PostgREST.Types (DbStructure, Schema, PgVersion(..), minimumPgVersion)-import Protolude hiding (hPutStrLn, replace)---import Control.AutoUpdate (defaultUpdateSettings,- mkAutoUpdate, updateAction)-import Control.Retry (RetryStatus, capDelay,- exponentialBackoff,- retrying, rsPreviousDelay) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64-import Data.IORef (IORef, atomicWriteIORef,- newIORef, readIORef)-import Data.String (IsString (..))-import Data.Text (pack, replace, stripPrefix, strip)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Data.Text.IO (hPutStrLn, readFile)-import Data.Time.Clock (getCurrentTime) import qualified Hasql.Pool as P-import qualified Hasql.Session as H import qualified Hasql.Transaction.Sessions as HT-import Network.Wai.Handler.Warp (defaultSettings,- runSettings, setHost,- setPort, setServerName)-import System.IO (BufferMode (..),- hSetBuffering) +import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,+ updateAction)+import Control.Retry (RetryStatus, capDelay,+ exponentialBackoff, retrying,+ rsPreviousDelay)+import Data.IORef (IORef, atomicWriteIORef, newIORef,+ readIORef)+import Data.String (IsString (..))+import Data.Text (pack, replace, strip, stripPrefix,+ unpack)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Text.IO (hPutStrLn, readFile)+import Data.Time.Clock (getCurrentTime)+import Network.Socket (Family (AF_UNIX),+ SockAddr (SockAddrUnix), Socket,+ SocketType (Stream), bind, close,+ defaultProtocol, listen,+ maxListenQueue, socket)+import Network.Wai.Handler.Warp (defaultSettings, runSettings,+ runSettingsSocket, setHost, setPort,+ setServerName)+import System.Directory (removeFile)+import System.IO (BufferMode (..), hSetBuffering)+import System.IO.Error (isDoesNotExistError)++import PostgREST.App (postgrest)+import PostgREST.Config (AppConfig (..), configPoolTimeout',+ prettyVersion, readOptions)+import PostgREST.DbStructure (getDbStructure, getPgVersion)+import PostgREST.Error (PgError (PgError), checkIsFatal,+ errorPayload)+import PostgREST.OpenAPI (isMalformedProxyUri)+import PostgREST.Types (ConnectionStatus (..), DbStructure,+ PgVersion (..), Schema,+ minimumPgVersion)+import Protolude hiding (hPutStrLn, replace)++ #ifndef mingw32_HOST_OS-import System.Posix.Signals+import System.Posix.Signals #endif {-|@@ -74,26 +83,25 @@ work = do atomicWriteIORef refDbStructure Nothing putStrLn ("Attempting to connect to the database..." :: Text)- connected <- connectingSucceeded pool- when connected $ do- result <- P.use pool $ do- actualPgVersion <- getPgVersion- unless (actualPgVersion >= minimumPgVersion) $ liftIO $ do- hPutStrLn stderr- ("Cannot run in this PostgreSQL version, PostgREST needs at least "- <> pgvName minimumPgVersion)- killThread mainTid- dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schema actualPgVersion- liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure- case result of- Left e -> do- putStrLn ("Failed to query the database. Retrying." :: Text)- hPutStrLn stderr (toS $ encodeError e)- work- Right _ -> do- atomicWriteIORef refIsWorkerOn False- putStrLn ("Connection successful" :: Text)+ connected <- connectionStatus pool+ case connected of+ FatalConnectionError reason -> hPutStrLn stderr reason+ >> killThread mainTid -- Fatal error when connecting+ NotConnected -> return () -- Unreachable+ Connected actualPgVersion -> do -- Procede with initialization+ result <- P.use pool $ do+ dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schema actualPgVersion+ liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure+ case result of+ Left e -> do+ putStrLn ("Failed to query the database. Retrying." :: Text)+ hPutStrLn stderr . toS . errorPayload $ PgError False e+ work + Right _ -> do+ atomicWriteIORef refIsWorkerOn False+ putStrLn ("Connection successful" :: Text)+ {-| Used by 'connectionWorker' to check if the provided db-uri lets the application access the PostgreSQL database. This method is used@@ -103,26 +111,37 @@ The connection tries are capped, but if the connection times out no error is thrown, just 'False' is returned. -}-connectingSucceeded :: P.Pool -> IO Bool-connectingSucceeded pool =+connectionStatus :: P.Pool -> IO ConnectionStatus+connectionStatus pool = retrying (capDelay 32000000 $ exponentialBackoff 1000000) shouldRetry- (const $ P.release pool >> isConnectionSuccessful)+ (const $ P.release pool >> getConnectionStatus) where- isConnectionSuccessful :: IO Bool- isConnectionSuccessful = do- testConn <- P.use pool $ H.sql "SELECT 1"- case testConn of- Left e -> hPutStrLn stderr (toS $ encodeError e) >> pure False- _ -> pure True- shouldRetry :: RetryStatus -> Bool -> IO Bool+ getConnectionStatus :: IO ConnectionStatus+ getConnectionStatus = do+ pgVersion <- P.use pool getPgVersion+ case pgVersion of+ Left e -> do+ let err = PgError False e+ hPutStrLn stderr . toS $ errorPayload err+ case checkIsFatal err of+ Just reason -> return $ FatalConnectionError reason+ Nothing -> return NotConnected++ Right version ->+ if version < minimumPgVersion+ then return . FatalConnectionError $ "Cannot run in this PostgreSQL version, PostgREST needs at least " <> pgvName minimumPgVersion+ else return . Connected $ version++ shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool shouldRetry rs isConnSucc = do- delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000- itShould <- pure $ not isConnSucc+ let delay = fromMaybe 0 (rsPreviousDelay rs) `div` 1000000+ itShould = NotConnected == isConnSucc when itShould $ putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..." return itShould + {-| This is where everything starts. -}@@ -143,6 +162,7 @@ let host = configHost conf port = configPort conf proxy = configProxyUri conf+ maybeSocketAddr = configSocket conf pgSettings = toS (configDatabase conf) -- is the db-uri roleClaimKey = configRoleClaimKey conf appSettings =@@ -160,11 +180,10 @@ when (isLeft roleClaimKey) $ panic $ show roleClaimKey - putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) -- -- create connection pool with the provided settings, returns either -- a 'Connection' or a 'ConnectionError'. Does not throw.- pool <- P.acquire (configPool conf, 10, pgSettings)+ pool <- P.acquire (configPool conf, configPoolTimeout' conf, pgSettings) -- -- To be filled in by connectionWorker refDbStructure <- newIORef Nothing@@ -198,34 +217,45 @@ throwTo mainTid UserInterrupt ) Nothing - forM_ [sigHUP, sigUSR1] $ \sig ->- void $ installHandler sig (- Catch $ connectionWorker- mainTid- pool- (configSchema conf)- refDbStructure- refIsWorkerOn- ) Nothing+ void $ installHandler sigUSR1 (+ Catch $ connectionWorker+ mainTid+ pool+ (configSchema conf)+ refDbStructure+ refIsWorkerOn+ ) Nothing #endif -- ask for the OS time at most once per second getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} - -- run the postgrest application- runSettings appSettings $- postgrest- conf- refDbStructure- pool- getTime- (connectionWorker- mainTid- pool- (configSchema conf)- refDbStructure- refIsWorkerOn)+ let postgrestApplication =+ postgrest+ conf+ refDbStructure+ pool+ getTime+ (connectionWorker+ mainTid+ pool+ (configSchema conf)+ refDbStructure+ refIsWorkerOn)+ in case maybeSocketAddr of+ Nothing -> do+ -- run the postgrest application+ putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)+ runSettings appSettings postgrestApplication+ Just socketAddr -> do+ -- run postgrest application with user defined socket+ sock <- createAndBindSocket (unpack socketAddr)+ listen sock maxListenQueue+ putStrLn $ ("Listening on unix socket " :: Text) <> show socketAddr+ runSettingsSocket appSettings sock postgrestApplication+ -- clean socket up when done+ close sock {-| The purpose of this function is to load the JWT secret from a file if@@ -290,6 +320,18 @@ extractDbUri dbUri = fmap setDbUri $ case stripPrefix "@" dbUri of- Nothing -> return dbUri+ Nothing -> return dbUri Just filename -> strip <$> readFile (toS filename) setDbUri dbUri = conf {configDatabase = dbUri}++createAndBindSocket :: FilePath -> IO Socket+createAndBindSocket filePath = do+ deleteSocketFileIfExist filePath+ sock <- socket AF_UNIX Stream defaultProtocol+ bind sock $ SockAddrUnix filePath+ return sock+ where+ deleteSocketFileIfExist path = removeFile path `catch` handleDoesNotExist+ handleDoesNotExist e+ | isDoesNotExistError e = return ()+ | otherwise = throwIO e
postgrest.cabal view
@@ -1,176 +1,182 @@-name: postgrest-description: Reads the schema of a PostgreSQL database and creates RESTful routes- for the tables and views, supporting all HTTP verbs that security- permits.-version: 5.2.0-synopsis: REST API for any Postgres database-license: MIT-license-file: LICENSE-author: Joe Nelson, Adam Baker-homepage: https://postgrest.org-maintainer: Steve Chávez <stevechavezast@gmail.com>-bug-reports: https://github.com/PostgREST/postgrest/issues-category: Executable, PostgreSQL, Network APIs-extra-source-files: CHANGELOG.md-build-type: Simple-cabal-version: >=1.10+name: postgrest+version: 6.0.0+synopsis: REST API for any Postgres database+description: Reads the schema of a PostgreSQL database and creates RESTful routes+ for the tables and views, supporting all HTTP verbs that security+ permits.+license: MIT+license-file: LICENSE+author: Joe Nelson, Adam Baker+maintainer: Steve Chávez <stevechavezast@gmail.com>+category: Executable, PostgreSQL, Network APIs+homepage: https://postgrest.org+bug-reports: https://github.com/PostgREST/postgrest/issues+build-type: Simple+extra-source-files: CHANGELOG.md+cabal-version: >= 1.10+ source-repository head- type: git+ type: git location: git://github.com/PostgREST/postgrest.git -Flag CI- Description: No warnings allowed in continuous integration- Manual: True- Default: False--executable postgrest- main-is: Main.hs- default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude- ghc-options:- -threaded- -rtsopts- "-with-rtsopts=-N -I2"- default-language: Haskell2010- build-depends: auto-update- , base >= 4.8 && < 4.10- , hasql >= 1.3 && < 1.4- , hasql-pool >= 0.5 && < 0.6- , hasql-transaction >= 0.7 && < 0.8- , postgrest- , protolude == 0.2.2- , text- , time- , warp- , bytestring- , base64-bytestring- , retry- if !os(windows)- build-depends: unix-- hs-source-dirs: main+flag ci+ default: False+ manual: True+ description: No warnings allowed in continuous integration library- default-language: Haskell2010- default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude- build-depends: aeson- , ansi-wl-pprint- , base >= 4.8 && < 4.10- , base64-bytestring- , bytestring- , case-insensitive- , cassava- , configurator-ng == 0.0.0.1- , containers- , contravariant- , contravariant-extras- , either- , gitrev- , hasql >= 1.3 && < 1.4- , hasql-pool >= 0.5 && < 0.6- , hasql-transaction >= 0.7 && < 0.8- , heredoc- , HTTP- , http-types- , insert-ordered-containers- , interpolatedstring-perl6- , jose == 0.7.0.0- , lens- , lens-aeson- , network-uri- , optparse-applicative >= 0.13 && < 0.15- , parsec- , protolude == 0.2.2- , Ranged-sets == 0.3.0- , regex-tdfa- , scientific- , swagger2- , text- , time- , unordered-containers- , vector- , wai- , wai-cors- , wai-extra- , wai-middleware-static- , cookie+ exposed-modules: PostgREST.ApiRequest+ PostgREST.App+ PostgREST.Auth+ PostgREST.Config+ PostgREST.DbRequestBuilder+ PostgREST.DbStructure+ PostgREST.Error+ PostgREST.Middleware+ PostgREST.OpenAPI+ PostgREST.Parsers+ PostgREST.QueryBuilder+ PostgREST.RangeQuery+ PostgREST.Types+ other-modules: Paths_postgrest+ hs-source-dirs: src+ build-depends: base >= 4.9 && < 4.13+ , HTTP >= 4000.3.7 && < 4000.4+ , Ranged-sets >= 0.3 && < 0.5+ , aeson >= 0.11.3 && < 1.5+ , ansi-wl-pprint >= 0.6.7 && < 0.7+ , base64-bytestring >= 1 && < 1.1+ , bytestring >= 0.10.8 && < 0.11+ , case-insensitive >= 1.2 && < 1.3+ , cassava >= 0.4.5 && < 0.6+ , configurator-pg >= 0.1 && < 0.2+ , containers >= 0.5.7 && < 0.7+ , contravariant >= 1.4 && < 1.6+ , contravariant-extras >= 0.3.3 && < 0.4+ , cookie >= 0.4.2 && < 0.5+ , either >= 4.4.1 && < 5.1+ , gitrev >= 1.2 && < 1.4+ , hasql >= 1.4 && < 1.5+ , hasql-pool >= 0.5 && < 0.6+ , hasql-transaction >= 0.7.2 && < 0.8+ , heredoc >= 0.2 && < 0.3+ , http-types >= 0.12.2 && < 0.13+ , insert-ordered-containers >= 0.1 && < 0.3+ , interpolatedstring-perl6 >= 1 && < 1.1+ , jose >= 0.7 && < 0.8+ , lens >= 4.14 && < 4.18+ , lens-aeson >= 1.0.1 && < 1.1+ , network-uri >= 2.6.1 && < 2.7+ , optparse-applicative >= 0.13 && < 0.15+ , parsec >= 3.1.11 && < 3.2+ , protolude >= 0.2.2 && < 0.3+ , regex-tdfa >= 1.2.2 && < 1.3+ , scientific >= 0.3.4 && < 0.4+ , swagger2 >= 2.1.4 && < 2.4+ , text >= 1.2.2 && < 1.3+ , time >= 1.6 && < 1.9+ , unordered-containers >= 0.2.8 && < 0.3+ , vector >= 0.11 && < 0.13+ , wai >= 3.2.1 && < 3.3+ , wai-cors >= 0.2.5 && < 0.3+ , wai-extra >= 3.0.19 && < 3.1+ , wai-middleware-static >= 0.8.1 && < 0.9+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ QuasiQuotes+ NoImplicitPrelude - Other-Modules: Paths_postgrest- Exposed-Modules: PostgREST.ApiRequest- , PostgREST.App- , PostgREST.Auth- , PostgREST.Config- , PostgREST.DbStructure- , PostgREST.DbRequestBuilder- , PostgREST.Error- , PostgREST.Middleware- , PostgREST.OpenAPI- , PostgREST.Parsers- , PostgREST.QueryBuilder- , PostgREST.RangeQuery- , PostgREST.Types- hs-source-dirs: src+executable postgrest+ main-is: Main.hs+ hs-source-dirs: main+ build-depends: base >= 4.9 && < 4.13+ , auto-update >= 0.1.4 && < 0.2+ , base64-bytestring >= 1 && < 1.1+ , bytestring >= 0.10.8 && < 0.11+ , directory >= 1.2.6 && < 1.4+ , hasql >= 1.4 && < 1.5+ , hasql-pool >= 0.5 && < 0.6+ , hasql-transaction >= 0.7.2 && < 0.8+ , network < 2.9+ , postgrest+ , protolude >= 0.2.2 && < 0.3+ , retry >= 0.7.4 && < 0.9+ , text >= 1.2.2 && < 1.3+ , time >= 1.6 && < 1.9+ , warp >= 3.2.12 && < 3.3+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ QuasiQuotes+ NoImplicitPrelude+ ghc-options: -threaded -rtsopts "-with-rtsopts=-N -I2" -Test-Suite spec- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude- ghc-options: -threaded -rtsopts -with-rtsopts=-N- Hs-Source-Dirs: test- Main-Is: Main.hs- Other-Modules: Feature.AudienceJwtSecretSpec- , Feature.AuthSpec- , Feature.AsymmetricJwtSpec- , Feature.BinaryJwtSecretSpec- , Feature.ConcurrentSpec- , Feature.CorsSpec- , Feature.DeleteSpec- , Feature.ExtraSearchPathSpec- , Feature.InsertSpec- , Feature.JsonOperatorSpec- , Feature.NoJwtSpec- , Feature.PgVersion95Spec- , Feature.PgVersion96Spec- , Feature.ProxySpec- , Feature.QueryLimitedSpec- , Feature.QuerySpec- , Feature.RangeSpec- , Feature.SingularSpec- , Feature.StructureSpec- , Feature.UnicodeSpec- , Feature.AndOrParamsSpec- , Feature.RpcSpec- , Feature.NonexistentSchemaSpec- , Feature.UpsertSpec- , SpecHelper- , TestTypes- Build-Depends: aeson- , aeson-qq- , async- , auto-update- , base >= 4.8 && < 4.10- , bytestring- , base64-bytestring- , case-insensitive- , cassava- , containers- , contravariant- , hasql >= 1.3 && < 1.4- , hasql-pool >= 0.5 && < 0.6- , hasql-transaction >= 0.7 && < 0.8- , heredoc- , hjsonschema == 1.5.0.1- , hspec- , hspec-wai >= 0.7.0- , hspec-wai-json- , http-types- , lens- , lens-aeson- , monad-control- , postgrest- , process- , protolude == 0.2.2- , regex-tdfa- , time- , transformers-base- , wai- , wai-extra+ if !os(windows)+ build-depends: unix++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: Feature.AndOrParamsSpec+ Feature.AsymmetricJwtSpec+ Feature.AudienceJwtSecretSpec+ Feature.AuthSpec+ Feature.BinaryJwtSecretSpec+ Feature.ConcurrentSpec+ Feature.CorsSpec+ Feature.DeleteSpec+ Feature.ExtraSearchPathSpec+ Feature.InsertSpec+ Feature.JsonOperatorSpec+ Feature.NoJwtSpec+ Feature.NonexistentSchemaSpec+ Feature.PgVersion95Spec+ Feature.PgVersion96Spec+ Feature.ProxySpec+ Feature.QueryLimitedSpec+ Feature.QuerySpec+ Feature.RangeSpec+ Feature.RootSpec+ Feature.RpcSpec+ Feature.SingularSpec+ Feature.StructureSpec+ Feature.UnicodeSpec+ Feature.UpsertSpec+ SpecHelper+ TestTypes+ hs-source-dirs: test+ build-depends: base >= 4.9 && < 4.13+ , aeson >= 0.11.3 && < 1.5+ , aeson-qq >= 0.8.1 && < 0.9+ , async >= 2.1.1 && < 2.3+ , auto-update >= 0.1.4 && < 0.2+ , base64-bytestring >= 1 && < 1.1+ , bytestring >= 0.10.8 && < 0.11+ , case-insensitive >= 1.2 && < 1.3+ , cassava >= 0.4.5 && < 0.6+ , containers >= 0.5.7 && < 0.7+ , contravariant >= 1.4 && < 1.6+ , hasql >= 1.4 && < 1.5+ , hasql-pool >= 0.5 && < 0.6+ , hasql-transaction >= 0.7.2 && < 0.8+ , heredoc >= 0.2 && < 0.3+ , hspec >= 2.3 && < 2.8+ , hspec-wai >= 0.7 && < 0.10+ , hspec-wai-json >= 0.7 && < 0.10+ , http-types >= 0.12.3 && < 0.13+ , lens >= 4.14 && < 4.18+ , lens-aeson >= 1.0.1 && < 1.1+ , monad-control >= 1.0.1 && < 1.1+ , postgrest+ , process >= 1.4.2 && < 1.7+ , protolude >= 0.2.2 && < 0.3+ , regex-tdfa >= 1.2.2 && < 1.3+ , text >= 1.2.2 && < 1.3+ , time >= 1.6 && < 1.9+ , transformers-base >= 0.4.4 && < 0.5+ , wai >= 3.2.1 && < 3.3+ , wai-extra >= 3.0.19 && < 3.1+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ QuasiQuotes+ NoImplicitPrelude+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
src/PostgREST/ApiRequest.hs view
@@ -1,44 +1,54 @@-{-# LANGUAGE LambdaCase #-} {-| Module : PostgREST.ApiRequest Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. -}-module PostgREST.ApiRequest ( ApiRequest(..)- , ContentType(..)- , Action(..)- , Target(..)- , PreferRepresentation (..)- , mutuallyAgreeable- , userApiRequest- ) where+{-# LANGUAGE LambdaCase #-} -import Protolude-import qualified Data.Aeson as JSON-import Data.Aeson.Types (emptyObject, emptyArray)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BS (c2w)-import qualified Data.ByteString.Lazy as BL-import qualified Data.Csv as CSV-import qualified Data.List as L-import Data.List (lookup, last, partition)-import qualified Data.HashMap.Strict as M-import qualified Data.Set as S-import Data.Maybe (fromJust)-import Control.Arrow ((***))-import qualified Data.Text as T-import qualified Data.Vector as V-import Network.HTTP.Base (urlEncodeVars)-import Network.HTTP.Types.Header (hAuthorization, hCookie)-import Network.HTTP.Types.URI (parseSimpleQuery)-import Network.Wai (Request (..))-import Network.Wai.Parse (parseHttpAccept)-import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)-import Data.Ranged.Boundaries-import PostgREST.Types-import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange)-import qualified Data.CaseInsensitive as CI-import Web.Cookie (parseCookiesText)+module PostgREST.ApiRequest (+ ApiRequest(..)+, ContentType(..)+, Action(..)+, Target(..)+, PreferRepresentation (..)+, mutuallyAgreeable+, userApiRequest+) where +import qualified Data.Aeson as JSON+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.CaseInsensitive as CI+import qualified Data.Csv as CSV+import qualified Data.HashMap.Strict as M+import qualified Data.List as L+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Vector as V++import Control.Arrow ((***))+import Data.Aeson.Types (emptyArray, emptyObject)+import Data.List (last, lookup, partition)+import Data.Maybe (fromJust)+import Data.Ranged.Ranges (Range (..), emptyRange,+ rangeIntersection)+import Network.HTTP.Base (urlEncodeVars)+import Network.HTTP.Types.Header (hAuthorization, hCookie)+import Network.HTTP.Types.URI (parseQueryReplacePlus,+ parseSimpleQuery)+import Network.Wai (Request (..))+import Network.Wai.Parse (parseHttpAccept)+import Web.Cookie (parseCookiesText)+++import Data.Ranged.Boundaries++import PostgREST.Error (ApiRequestError (..))+import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq,+ rangeLimit, rangeOffset, rangeRequested,+ restrictRange)+import PostgREST.Types+import Protolude+ type RequestBody = BL.ByteString -- | Types of things a user wants to do to tables/views/procs@@ -49,8 +59,8 @@ deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier- | TargetProc QualifiedIdentifier- | TargetRoot+ | TargetProc{tpQi :: QualifiedIdentifier, tpIsRootSpec :: Bool}+ | TargetDefaultSpec -- The default spec offered at root "/" | TargetUnknown [Text] deriving Eq -- | How to return the inserted data@@ -65,44 +75,46 @@ -} data ApiRequest = ApiRequest { -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST- iAction :: Action+ iAction :: Action -- | Requested range of rows within response- , iRange :: M.HashMap ByteString NonnegRange+ , iRange :: M.HashMap ByteString NonnegRange -- | The target, be it calling a proc or accessing a table- , iTarget :: Target+ , iTarget :: Target -- | Content types the client will accept, [CTAny] if no Accept header- , iAccepts :: [ContentType]+ , iAccepts :: [ContentType] -- | Data sent by client and used for mutation actions- , iPayload :: Maybe PayloadJSON+ , iPayload :: Maybe PayloadJSON -- | If client wants created items echoed back- , iPreferRepresentation :: PreferRepresentation+ , iPreferRepresentation :: PreferRepresentation -- | Pass all parameters as a single json object to a stored procedure , iPreferSingleObjectParameter :: Bool -- | Whether the client wants a result count (slower)- , iPreferCount :: Bool+ , iPreferCount :: Bool -- | Whether the client wants to UPSERT or ignore records on PK conflict- , iPreferResolution :: Maybe PreferResolution+ , iPreferResolution :: Maybe PreferResolution -- | Filters on the result ("id", "eq.10")- , iFilters :: [(Text, Text)]+ , iFilters :: [(Text, Text)] -- | &and and &or parameters used for complex boolean logic- , iLogic :: [(Text, Text)]+ , iLogic :: [(Text, Text)] -- | &select parameter used to shape the response- , iSelect :: Text+ , iSelect :: Text+ -- | &columns parameter used to shape the payload+ , iColumns :: Maybe Text -- | &order parameters for each level- , iOrder :: [(Text, Text)]+ , iOrder :: [(Text, Text)] -- | Alphabetized (canonical) request query string for response URLs- , iCanonicalQS :: ByteString+ , iCanonicalQS :: ByteString -- | JSON Web Token- , iJWT :: Text+ , iJWT :: Text -- | HTTP request headers- , iHeaders :: [(Text, Text)]+ , iHeaders :: [(Text, Text)] -- | Request Cookies- , iCookies :: [(Text, Text)]+ , iCookies :: [(Text, Text)] } -- | Examines HTTP request and translates it into user intent.-userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest-userApiRequest schema req reqBody+userApiRequest :: Schema -> Maybe QualifiedIdentifier -> Request -> RequestBody -> Either ApiRequestError ApiRequest+userApiRequest schema rootSpec req reqBody | isTargetingProc && method `notElem` ["GET", "POST"] = Left ActionInappropriate | topLevelRange == emptyRange = Left InvalidRange | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload@@ -120,51 +132,64 @@ else Nothing , iFilters = filters , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]- , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams+ , iSelect = toS $ fromMaybe "*" $ join $ lookup "select" qParams+ , iColumns = columns , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] , iCanonicalQS = toS $ urlEncodeVars- . L.sortBy (comparing fst)- . map (join (***) toS)- . parseSimpleQuery- $ rawQueryString req+ . L.sortOn fst+ . map (join (***) toS . second (fromMaybe BS.empty))+ $ queryStringWPlus , iJWT = tokenStr , iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hAuthorization, k /= hCookie] , iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie" } where+ -- queryString with '+' not converted to ' '+ queryStringWPlus = parseQueryReplacePlus False $ rawQueryString req -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..) (filters, rpcQParams) = case action of ActionInvoke{isReadOnly=True} -> partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts _ -> (flts, [])- flts = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ]+ flts =+ [ (toS k, toS $ fromJust v) |+ (k,v) <- qParams, isJust v,+ k `notElem` ["select", "columns"],+ not (endingIn ["order", "limit", "offset", "and", "or"] k) ] hasOperator val = any (`T.isPrefixOf` val) $ ((<> ".") <$> "not":M.keys operators) ++ ((<> "(") <$> M.keys ftsOperators) isEmbedPath = T.isInfixOf "."- isTargetingProc = (== Just "rpc") $ listToMaybe path+ isTargetingProc = case target of+ TargetProc _ _ -> True+ _ -> False+ contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"+ columns | action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}] = toS <$> join (lookup "columns" qParams)+ | otherwise = Nothing payload =- case (decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type", action) of+ case (contentType, action) of (_, ActionInvoke{isReadOnly=True}) ->- Right $ PayloadJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams)+ Right $ ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams) (CTApplicationJSON, _) ->- note "All object keys must match" . payloadAttributes reqBody- =<< if BL.null reqBody && isTargetingProc- then Right emptyObject- else JSON.eitherDecode reqBody+ if isJust columns+ then Right $ RawJSON reqBody+ else note "All object keys must match" . payloadAttributes reqBody+ =<< if BL.null reqBody && isTargetingProc+ then Right emptyObject+ else JSON.eitherDecode reqBody (CTTextCSV, _) -> do json <- csvToJson <$> CSV.decodeByName reqBody note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json (CTOther "application/x-www-form-urlencoded", _) -> let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody keys = S.fromList $ M.keys json in- Right $ PayloadJSON (JSON.encode json) PJObject keys+ Right $ ProcessedJSON (JSON.encode json) PJObject keys (ct, _) -> Left $ toS $ "Content-Type not acceptable: " <> toMime ct topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges action = case method of- "GET" | target == TargetRoot -> ActionInspect+ "GET" | target == TargetDefaultSpec -> ActionInspect | isTargetingProc -> ActionInvoke{isReadOnly=True} | otherwise -> ActionRead @@ -177,19 +202,20 @@ "OPTIONS" -> ActionInfo _ -> ActionInspect target = case path of- [] -> TargetRoot- [table] -> TargetIdent- $ QualifiedIdentifier schema table- ["rpc", proc] -> TargetProc- $ QualifiedIdentifier schema proc- other -> TargetUnknown other+ [] -> case rootSpec of+ Just rsQi -> TargetProc rsQi True+ Nothing -> TargetDefaultSpec+ [table] -> TargetIdent $ QualifiedIdentifier schema table+ ["rpc", proc] -> TargetProc (QualifiedIdentifier schema proc) False+ other -> TargetUnknown other+ shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke{isReadOnly=False}, ActionInvoke{isReadOnly=True}] relevantPayload | shouldParsePayload = rightToMaybe payload | otherwise = Nothing path = pathInfo req method = requestMethod req hdrs = requestHeaders req- qParams = [(toS k, v)|(k,v) <- queryString req]+ qParams = [(toS k, v)|(k,v) <- queryStringWPlus] lookupHeader = flip lookup hdrs hasPrefer :: Text -> Bool hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs@@ -237,23 +263,6 @@ then listToMaybe sProduces else exact --- PRIVATE -----------------------------------------------------------------{-|- Warning: discards MIME parameters--}-decodeContentType :: BS.ByteString -> ContentType-decodeContentType ct =- case BS.takeWhile (/= BS.c2w ';') ct of- "application/json" -> CTApplicationJSON- "text/csv" -> CTTextCSV- "application/openapi+json" -> CTOpenAPI- "application/vnd.pgrst.object+json" -> CTSingularJSON- "application/vnd.pgrst.object" -> CTSingularJSON- "application/octet-stream" -> CTOctetStream- "*/*" -> CTAny- ct' -> CTOther ct'- type CsvData = V.Vector (M.HashMap Text BL.ByteString) {-|@@ -291,14 +300,14 @@ JSON.Object x -> S.fromList (M.keys x) == canonicalKeys _ -> False) arr in if areKeysUniform- then Just $ PayloadJSON raw (PJArray $ V.length arr) canonicalKeys+ then Just $ ProcessedJSON raw (PJArray $ V.length arr) canonicalKeys else Nothing Just _ -> Nothing Nothing -> Just emptyPJArray - JSON.Object o -> Just $ PayloadJSON raw PJObject (S.fromList $ M.keys o)+ JSON.Object o -> Just $ ProcessedJSON raw PJObject (S.fromList $ M.keys o) -- truncate everything else to an empty array. _ -> Just emptyPJArray where- emptyPJArray = PayloadJSON (JSON.encode emptyArray) (PJArray 0) S.empty+ emptyPJArray = ProcessedJSON (JSON.encode emptyArray) (PJArray 0) S.empty
src/PostgREST/App.hs view
@@ -1,66 +1,56 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NamedFieldPuns #-} module PostgREST.App ( postgrest ) where -import Control.Applicative-import Data.Aeson as JSON-import qualified Data.ByteString.Char8 as BS-import Data.Maybe-import Data.IORef (IORef, readIORef)-import Data.Text (intercalate)-import Data.Time.Clock (UTCTime)-import qualified Data.Set as S-+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashMap.Strict as M+import qualified Data.Set as S import qualified Hasql.Pool as P+import qualified Hasql.Transaction as H import qualified Hasql.Transaction as HT import qualified Hasql.Transaction.Sessions as HT -import Network.HTTP.Types.Header-import Network.HTTP.Types.Status-import Network.HTTP.Types.URI (renderSimpleQuery)-import Network.Wai-import Network.Wai.Middleware.RequestLogger (logStdout)--import qualified Hasql.Transaction as H--import qualified Data.HashMap.Strict as M+import Data.Aeson as JSON+import Data.Function (id)+import Data.IORef (IORef, readIORef)+import Data.Time.Clock (UTCTime)+import Network.HTTP.Types.URI (renderSimpleQuery)+import Network.Wai.Middleware.RequestLogger (logStdout) -import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..)- , Action(..), Target(..)- , PreferRepresentation (..)- , mutuallyAgreeable- , userApiRequest- )-import PostgREST.Auth (jwtClaims, containsRole, parseSecret)-import PostgREST.Config (AppConfig (..))-import PostgREST.DbStructure-import PostgREST.DbRequestBuilder( readRequest- , mutateRequest- , fieldNames- )-import PostgREST.Error ( simpleError, pgError- , apiRequestError- , singularityError, binaryFieldError- , connectionLostError, gucHeadersError- )-import PostgREST.RangeQuery (allRange, rangeOffset)-import PostgREST.Middleware-import PostgREST.QueryBuilder ( callProc- , requestToQuery- , requestToCountQuery- , createReadStatement- , createWriteStatement- , ResultsWithCount- )-import PostgREST.Types-import PostgREST.OpenAPI+import Control.Applicative+import Data.Maybe+import Network.HTTP.Types.Header+import Network.HTTP.Types.Status+import Network.Wai -import Data.Function (id)-import Protolude hiding (intercalate, Proxy)+import PostgREST.ApiRequest (Action (..), ApiRequest (..),+ ContentType (..),+ PreferRepresentation (..),+ Target (..), mutuallyAgreeable,+ userApiRequest)+import PostgREST.Auth (containsRole, jwtClaims,+ parseSecret)+import PostgREST.Config (AppConfig (..))+import PostgREST.DbRequestBuilder (fieldNames, mutateRequest,+ readRequest)+import PostgREST.DbStructure+import PostgREST.Error (PgError (..), SimpleError (..),+ errorResponseFor, singularityError)+import PostgREST.Middleware+import PostgREST.OpenAPI+import PostgREST.Parsers (pRequestColumns)+import PostgREST.QueryBuilder (ResultsWithCount, callProc,+ createReadStatement,+ createWriteStatement,+ requestToCountQuery,+ requestToQuery)+import PostgREST.RangeQuery (allRange, rangeOffset)+import PostgREST.Types+import Protolude hiding (Proxy, intercalate) postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application postgrest conf refDbStructure pool getTime worker =@@ -72,36 +62,31 @@ body <- strictRequestBody req maybeDbStructure <- readIORef refDbStructure case maybeDbStructure of- Nothing -> respond connectionLostError+ Nothing -> respond . errorResponseFor $ ConnectionLostError Just dbStructure -> do- response <- case userApiRequest (configSchema conf) req body of- Left err -> return $ apiRequestError err- Right apiRequest -> do- eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)-- let authed = containsRole eClaims- proc = case (iTarget apiRequest, iPayload apiRequest, iPreferSingleObjectParameter apiRequest) of- (TargetProc qi, Just PayloadJSON{pjKeys}, s) -> findProc qi pjKeys s $ dbProcs dbStructure- _ -> Nothing- handleReq = runWithClaims conf eClaims (app dbStructure proc conf) apiRequest- txMode = transactionMode proc (iAction apiRequest)- response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq- return $ either (pgError authed) identity response+ response <- do+ -- Need to parse ?columns early because findProc needs it to solve overloaded functions+ let apiReq = userApiRequest (configSchema conf) (configRootSpec conf) req body+ apiReqCols = (,) <$> apiReq <*> (pRequestColumns =<< iColumns <$> apiReq)+ case apiReqCols of+ Left err -> return . errorResponseFor $ err+ Right (apiRequest, maybeCols) -> do+ eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)+ let authed = containsRole eClaims+ cols = case (iPayload apiRequest, maybeCols) of+ (Just ProcessedJSON{pjKeys}, _) -> pjKeys+ (Just RawJSON{}, Just cls) -> cls+ _ -> S.empty+ proc = case iTarget apiRequest of+ TargetProc qi _ -> findProc qi cols (iPreferSingleObjectParameter apiRequest) $ dbProcs dbStructure+ _ -> Nothing+ handleReq = runWithClaims conf eClaims (app dbStructure proc cols conf) apiRequest+ txMode = transactionMode proc (iAction apiRequest)+ response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq+ return $ either (errorResponseFor . PgError authed) identity response when (responseStatus response == status503) worker respond response -findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription-findProc qi payloadKeys paramsAsSingleObject allProcs =- let procs = M.lookup (qiName qi) allProcs in- -- Handle overloaded functions case- join $ (case length <$> procs of- Just 1 -> headMay -- if it's not an overloaded function then immediatly get the ProcDescription- _ -> find (\x ->- if paramsAsSingleObject- then length (pdArgs x) == 1 -- if the arg is not of json type let the db give the err- else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x))- ) <$> procs- transactionMode :: Maybe ProcDescription -> Action -> HT.Mode transactionMode proc action = case action of@@ -109,16 +94,16 @@ ActionInfo -> HT.Read ActionInspect -> HT.Read ActionInvoke{isReadOnly=False} ->- let v = maybe Volatile pdVolatility proc in+ let v = maybe Volatile pdVolatility proc in if v == Stable || v == Immutable then HT.Read else HT.Write ActionInvoke{isReadOnly=True} -> HT.Read _ -> HT.Write -app :: DbStructure -> Maybe ProcDescription -> AppConfig -> ApiRequest -> H.Transaction Response-app dbStructure proc conf apiRequest =- case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of+app :: DbStructure -> Maybe ProcDescription -> S.Set FieldName -> AppConfig -> ApiRequest -> H.Transaction Response+app dbStructure proc cols conf apiRequest =+ case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) (iTarget apiRequest) of Left errorResponse -> return errorResponse Right contentType -> case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of@@ -137,7 +122,7 @@ canonical = iCanonicalQS apiRequest return $ if contentType == CTSingularJSON && queryTotal /= 1- then singularityError (toInteger queryTotal)+ then errorResponseFor . singularityError $ queryTotal else responseLBS status [toHeader contentType, contentRange, ("Content-Location",@@ -146,83 +131,86 @@ ) ] (toS body) - (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType}) ->+ (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> case mutateSqlParts tSchema tName of Left errorResponse -> return errorResponse Right (sq, mq) -> do- let (isSingle, nRows) = case pjType of- PJArray len -> (len == 1, len)- PJObject -> (True, 1)+ let pkCols = tablePKCols dbStructure tSchema tName+ stm = createWriteStatement sq mq+ (contentType == CTSingularJSON) True+ (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols+ row <- H.statement (toS $ pjRaw pJson) stm+ let (_, queryTotal, fs, body) = extractQueryResult row+ headers = catMaybes [+ if null fs+ then Nothing+ else Just (hLocation, "/" <> toS tName <> renderLocationFields fs)+ , if iPreferRepresentation apiRequest == Full+ then Just $ toHeader contentType+ else Nothing+ , Just $ contentRangeH 1 0 $+ if shouldCount then Just queryTotal else Nothing+ , if null pkCols+ then Nothing+ else (\x -> ("Preference-Applied", show x)) <$> iPreferResolution apiRequest+ ] if contentType == CTSingularJSON- && not isSingle+ && queryTotal /= 1 && iPreferRepresentation apiRequest == Full- then return $ singularityError (toInteger nRows)- else do- let pkCols = tablePKCols dbStructure tSchema tName- stm = createWriteStatement sq mq- (contentType == CTSingularJSON) isSingle- (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols- row <- H.statement (toS pjRaw) stm- let (_, _, fs, body) = extractQueryResult row- headers = catMaybes [- if null fs- then Nothing- else Just (hLocation, "/" <> toS tName <> renderLocationFields fs)- , if iPreferRepresentation apiRequest == Full- then Just $ toHeader contentType- else Nothing- , Just . contentRangeH 1 0 $- toInteger <$> if shouldCount then Just nRows else Nothing- , if null pkCols- then Nothing- else (\x -> ("Preference-Applied", show x)) <$> iPreferResolution apiRequest- ]-- return . responseLBS status201 headers $- if iPreferRepresentation apiRequest == Full- then toS body else ""+ then do+ HT.condemn+ return . errorResponseFor . singularityError $ queryTotal+ else+ return . responseLBS status201 headers $+ if iPreferRepresentation apiRequest == Full+ then toS body else "" - (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just p@PayloadJSON{pjRaw}) ->- case (mutateSqlParts tSchema tName, pjIsEmpty p, iPreferRepresentation apiRequest == Full) of- (Left errorResponse, _, _) -> return errorResponse- (_, True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"- (_, True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""- (Right (sq, mq), _, _) -> do+ (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->+ case mutateSqlParts tSchema tName of+ Left errorResponse -> return errorResponse+ Right (sq, mq) -> do let stm = createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) []- row <- H.statement (toS pjRaw) stm+ row <- H.statement (toS $ pjRaw pJson) stm let (_, queryTotal, _, body) = extractQueryResult row- if contentType == CTSingularJSON- && queryTotal /= 1- && iPreferRepresentation apiRequest == Full- then do- HT.condemn- return $ singularityError (toInteger queryTotal)- else do- let r = contentRangeH 0 (toInteger $ queryTotal-1)- (toInteger <$> if shouldCount then Just queryTotal else Nothing)- s = if iPreferRepresentation apiRequest == Full- then status200- else status204- return $ if iPreferRepresentation apiRequest == Full- then responseLBS s [toHeader contentType, r] (toS body)- else responseLBS s [r] "" - (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType, pjKeys}) ->+ updateIsNoOp = S.null cols+ contentRangeHeader = contentRangeH 0 (queryTotal - 1) $+ if shouldCount then Just queryTotal else Nothing+ minimalHeaders = [contentRangeHeader]+ fullHeaders = toHeader contentType : minimalHeaders++ status | queryTotal == 0 && not updateIsNoOp = status404+ | iPreferRepresentation apiRequest == Full = status200+ | otherwise = status204++ case (contentType, iPreferRepresentation apiRequest) of+ (CTSingularJSON, Full)+ | queryTotal == 1 -> return $ responseLBS status fullHeaders (toS body)+ | otherwise -> HT.condemn >> (return . errorResponseFor . singularityError) queryTotal++ (_, Full) ->+ return $ responseLBS status fullHeaders (toS body)++ (_, _) ->+ return $ responseLBS status minimalHeaders mempty+++ (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just ProcessedJSON{pjRaw, pjType, pjKeys}) -> case mutateSqlParts tSchema tName of Left errorResponse -> return errorResponse Right (sq, mq) -> do let isSingle = case pjType of PJArray len -> len == 1- PJObject -> True+ PJObject -> True colNames = colName <$> tableCols dbStructure tSchema tName if topLevelRange /= allRange- then return $ simpleError status400 [] "Range header and limit/offset querystring parameters are not allowed for PUT"+ then return . errorResponseFor $ PutRangeNotAllowedError else if not isSingle- then return $ simpleError status400 [] "PUT payload must contain a single row"+ then return . errorResponseFor $ PutSingletonError else if S.fromList colNames /= pjKeys- then return $ simpleError status400 [] "You must specify all columns in the payload when using PUT"+ then return . errorResponseFor $ PutPayloadIncompleteError else do row <- H.statement (toS pjRaw) $ createWriteStatement sq mq (contentType == CTSingularJSON) False@@ -234,7 +222,7 @@ if queryTotal /= 1 then do HT.condemn- return $ simpleError status400 [] "Payload values do not match URL in primary key column(s)"+ return . errorResponseFor $ PutMatchingPkError else return $ if iPreferRepresentation apiRequest == Full then responseLBS status200 [toHeader contentType] (toS body)@@ -251,13 +239,13 @@ row <- H.statement mempty stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 1 0 $- toInteger <$> if shouldCount then Just queryTotal else Nothing+ if shouldCount then Just queryTotal else Nothing if contentType == CTSingularJSON && queryTotal /= 1 && iPreferRepresentation apiRequest == Full then do HT.condemn- return $ singularityError (toInteger queryTotal)+ return . errorResponseFor . singularityError $ queryTotal else return $ if iPreferRepresentation apiRequest == Full then responseLBS status200 [toHeader contentType, r] (toS body)@@ -271,7 +259,7 @@ let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in return $ responseLBS status200 [allOrigins, acceptH] "" - (ActionInvoke _, TargetProc qi, Just PayloadJSON{pjRaw, pjType, pjKeys}) ->+ (ActionInvoke _, TargetProc qi _, Just pJson) -> let returnsScalar = case proc of Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True _ -> False@@ -282,31 +270,27 @@ case parts of Left errorResponse -> return errorResponse Right ((q, cq), bField) -> do- let isObject = case pjType of- PJObject -> True- PJArray _ -> False- singular = contentType == CTSingularJSON- specifiedPgArgs = filter ((`S.member` pjKeys) . pgaName) $ maybe [] pdArgs proc- row <- H.statement (toS pjRaw) $- callProc qi specifiedPgArgs returnsScalar q cq shouldCount+ let singular = contentType == CTSingularJSON+ row <- H.statement (toS $ pjRaw pJson) $+ callProc qi (specifiedProcArgs cols proc) returnsScalar q cq shouldCount singular (iPreferSingleObjectParameter apiRequest) (contentType == CTTextCSV)- (contentType == CTOctetStream) bField isObject+ (contentType `elem` rawContentTypes) bField (pgVersion dbStructure) let (tableTotal, queryTotal, body, jsonHeaders) = fromMaybe (Just 0, 0, "[]", "[]") row (status, contentRange) = rangeHeader queryTotal tableTotal decodedHeaders = first toS $ JSON.eitherDecode $ toS jsonHeaders :: Either Text [GucHeader] case decodedHeaders of- Left _ -> return gucHeadersError+ Left _ -> return . errorResponseFor $ GucHeadersError Right hs -> if singular && queryTotal /= 1 then do HT.condemn- return $ singularityError (toInteger queryTotal)+ return . errorResponseFor . singularityError $ queryTotal else return $ responseLBS status ([toHeader contentType, contentRange] ++ toHeaders hs) (toS body) - (ActionInspect, TargetRoot, Nothing) -> do+ (ActionInspect, TargetDefaultSpec, Nothing) -> do let host = configHost conf port = toInteger $ configPort conf proxy = pickProxy $ toS <$> configProxyUri conf@@ -316,6 +300,7 @@ toTableInfo :: [Table] -> [(Table, [Column], [Text])] toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn)) encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure+ body <- encodeApi <$> H.statement schema accessibleTables <*> H.statement schema schemaDescription <*> H.statement schema accessibleProcs return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body @@ -340,39 +325,41 @@ selectQuery = requestToQuery schema False <$> readDbRequest countQuery = requestToCountQuery schema <$> readDbRequest readSqlParts = (,) <$> selectQuery <*> countQuery+ mutationDbRequest s t = mutateRequest apiRequest t cols (tablePKCols dbStructure s t) =<< fldNames mutateSqlParts s t = (,) <$> selectQuery- <*> (requestToQuery schema False . DbMutate <$> (mutateRequest apiRequest t (tablePKCols dbStructure s t) =<< fldNames))+ <*> (requestToQuery schema False . DbMutate <$> mutationDbRequest s t) -responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType-responseContentTypeOrError accepts action = serves contentTypesForRequest accepts+responseContentTypeOrError :: [ContentType] -> Action -> Target -> Either Response ContentType+responseContentTypeOrError accepts action target = serves contentTypesForRequest accepts where- contentTypesForRequest =- case action of- ActionRead -> [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]- ActionCreate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]- ActionUpdate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]- ActionDelete -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]- ActionInvoke _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]- ActionInspect -> [CTOpenAPI, CTApplicationJSON]- ActionInfo -> [CTTextCSV]- ActionSingleUpsert -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]+ contentTypesForRequest = case action of+ ActionRead -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] ++ rawContentTypes+ ActionCreate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]+ ActionUpdate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]+ ActionDelete -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]+ ActionInvoke _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] ++ rawContentTypes +++ [CTOpenAPI | tpIsRootSpec target]+ ActionInspect -> [CTOpenAPI, CTApplicationJSON]+ ActionInfo -> [CTTextCSV]+ ActionSingleUpsert -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] serves sProduces cAccepts = case mutuallyAgreeable sProduces cAccepts of- Nothing -> do- let failed = intercalate ", " $ map (toS . toMime) cAccepts- Left $ simpleError status415 [] $- "None of these Content-Types are available: " <> failed+ Nothing -> Left . errorResponseFor . ContentTypeError . map toMime $ cAccepts Just ct -> Right ct +{-+ | If raw(binary) output is requested, check that ContentType is one of the admitted rawContentTypes and that+ | `?select=...` contains only one field other than `*`+-} binaryField :: ContentType -> [FieldName] -> Either Response (Maybe FieldName)-binaryField CTOctetStream fldNames =- if length fldNames == 1 && fieldName /= Just "*"- then Right fieldName- else Left binaryFieldError- where- fieldName = headMay fldNames-binaryField _ _ = Right Nothing+binaryField ct fldNames+ | ct `elem` rawContentTypes =+ let fieldName = headMay fldNames in+ if length fldNames == 1 && fieldName /= Just "*"+ then Right fieldName+ else Left . errorResponseFor $ BinaryFieldError ct+ | otherwise = Right Nothing splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) splitKeyValue kv = (k, BS.tail v)@@ -389,7 +376,7 @@ | (1 + upper - lower) < total = status206 | otherwise = status200 -contentRangeH :: Integer -> Integer -> Maybe Integer -> Header+contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header contentRangeH lower upper total = ("Content-Range", headerValue) where
src/PostgREST/Auth.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase #-} {-| Module : PostgREST.Auth Description : PostgREST authorization functions.@@ -19,17 +19,19 @@ , parseSecret ) where -import Control.Lens.Operators-import Control.Lens (set)-import qualified Data.Aeson as JSON-import qualified Data.HashMap.Strict as M-import Data.Time.Clock (UTCTime)-import Data.Vector as V-import PostgREST.Types-import Protolude+import qualified Crypto.JOSE.Types as JOSE.Types+import qualified Data.Aeson as JSON+import qualified Data.HashMap.Strict as M+import Data.Vector as V -import qualified Crypto.JOSE.Types as JOSE.Types-import Crypto.JWT+import Control.Lens (set)+import Data.Time.Clock (UTCTime)++import Control.Lens.Operators+import Crypto.JWT++import PostgREST.Types+import Protolude {-| Possible situations encountered with client JWTs
src/PostgREST/Config.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE LambdaCase, TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} {-| Module : PostgREST.Config Description : Manages PostgREST configuration options.@@ -14,51 +12,58 @@ Other hardcoded options such as the minimum version number also belong here. -}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+ module PostgREST.Config ( prettyVersion , docsVersion , readOptions , corsPolicy , AppConfig (..)+ , configPoolTimeout' ) where -import Control.Applicative-import Control.Monad (fail)-import Control.Lens (preview)-import Crypto.JWT (StringOrURI,- stringOrUri) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI import qualified Data.Configurator as C-import qualified Data.Configurator.Parser as C-import Data.Configurator.Types as C-import Data.List (lookup)-import Data.Monoid-import Data.Scientific (floatingOrInteger)-import Data.String (String)-import Data.Text (dropAround,- intercalate, lines,- strip, take, splitOn)-import Data.Text.Encoding (encodeUtf8)-import Data.Text.IO (hPutStrLn)-import Data.Version (versionBranch)-import Development.GitRev (gitHash)-import Network.Wai-import Network.Wai.Middleware.Cors (CorsResourcePolicy (..))-import Options.Applicative hiding (str)-import Paths_postgrest (version)-import PostgREST.Parsers (pRoleClaimKey)-import PostgREST.Types (ApiRequestError(..),- JSPath, JSPathExp(..))-import Protolude hiding (hPutStrLn, take,- intercalate, (<>))-import System.IO (hPrint)-import System.IO.Error (IOError)-import Text.Heredoc-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) import qualified Text.PrettyPrint.ANSI.Leijen as L +import Control.Exception (Handler (..))+import Control.Lens (preview)+import Control.Monad (fail)+import Crypto.JWT (StringOrURI, stringOrUri)+import Data.List (lookup)+import Data.Scientific (floatingOrInteger)+import Data.Text (dropEnd, dropWhileEnd,+ intercalate, lines, splitOn,+ strip, take, unpack)+import Data.Text.Encoding (encodeUtf8)+import Data.Text.IO (hPutStrLn)+import Data.Version (versionBranch)+import Development.GitRev (gitHash)+import Network.Wai.Middleware.Cors (CorsResourcePolicy (..))+import Paths_postgrest (version)+import System.IO.Error (IOError)++import Control.Applicative+import Data.Monoid+import Network.Wai+import Options.Applicative hiding (str)+import Text.Heredoc+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))++import PostgREST.Error (ApiRequestError (..))+import PostgREST.Parsers (pRoleClaimKey)+import PostgREST.Types (JSPath, JSPathExp (..),+ QualifiedIdentifier (..))+import Protolude hiding (concat, hPutStrLn, intercalate, null,+ take, (<>))++ -- | Config file settings for the server data AppConfig = AppConfig { configDatabase :: Text@@ -67,20 +72,29 @@ , configSchema :: Text , configHost :: Text , configPort :: Int+ , configSocket :: Maybe Text , configJwtSecret :: Maybe B.ByteString , configJwtSecretIsBase64 :: Bool , configJwtAudience :: Maybe StringOrURI , configPool :: Int+ , configPoolTimeout :: Int , configMaxRows :: Maybe Integer , configReqCheck :: Maybe Text , configQuiet :: Bool , configSettings :: [(Text, Text)] , configRoleClaimKey :: Either ApiRequestError JSPath , configExtraSearchPath :: [Text]++ , configRootSpec :: Maybe QualifiedIdentifier } +configPoolTimeout' :: (Fractional a) => AppConfig -> a+configPoolTimeout' =+ fromRational . toRational . configPoolTimeout++ defaultCorsPolicy :: CorsResourcePolicy defaultCorsPolicy = CorsResourcePolicy Nothing ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing@@ -112,7 +126,7 @@ -- | Version number used in docs docsVersion :: Text-docsVersion = "v" <> dropAround (== '.') (dropAround (/= '.') prettyVersion)+docsVersion = "v" <> dropEnd 1 (dropWhileEnd (/= '.') prettyVersion) -- | Function to read and parse options from the command line readOptions :: IO AppConfig@@ -120,68 +134,87 @@ -- First read the config file path from command line cfgPath <- customExecParser parserPrefs opts -- Now read the actual config file- conf <- catch- (C.readConfig =<< C.load [C.Required cfgPath])- configNotfoundHint-- let (mAppConf, errs) = flip C.runParserM conf $- AppConfig- <$> C.key "db-uri"- <*> C.key "db-anon-role"- <*> (mfilter (/= "") <$> C.key "server-proxy-uri")- <*> C.key "db-schema"- <*> (fromMaybe "127.0.0.1" . mfilter (/= "") <$> C.key "server-host")- <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port")- <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret")- <*> (fromMaybe False . join . fmap coerceBool <$> C.key "secret-is-base64")- <*> parseJwtAudience "jwt-aud"- <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool")- <*> (join . fmap coerceInt <$> C.key "max-rows")- <*> (mfilter (/= "") <$> C.key "pre-request")- <*> pure False- <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings")- <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> C.key "role-claim-key")- <*> (maybe ["public"] splitExtraSearchPath <$> C.key "db-extra-search-path")+ conf <- catches (C.load cfgPath)+ [ Handler (\(ex :: IOError) -> exitErr $ "Cannot open config file:\n\t" <> show ex)+ , Handler (\(C.ParseError err) -> exitErr $ "Error parsing config file:\n\t" <> err)+ ] - case mAppConf of- Nothing -> do- forM_ errs $ hPrint stderr- exitFailure- Just appConf ->+ case C.runParser parseConfig conf of+ Left err ->+ exitErr $ "Error parsing config file:\n\t" <> err+ Right appConf -> return appConf where- parseJwtAudience :: Name -> C.ConfigParserM (Maybe StringOrURI)+ dbSchema = reqString "db-schema"+ parseConfig =+ AppConfig+ <$> reqString "db-uri"+ <*> reqString "db-anon-role"+ <*> optString "server-proxy-uri"+ <*> dbSchema+ <*> (fromMaybe "!4" <$> optString "server-host")+ <*> (fromMaybe 3000 <$> optInt "server-port")+ <*> optString "server-unix-socket"+ <*> (fmap encodeUtf8 <$> optString "jwt-secret")+ <*> (fromMaybe False <$> optBool "secret-is-base64")+ <*> parseJwtAudience "jwt-aud"+ <*> (fromMaybe 10 <$> optInt "db-pool")+ <*> (fromMaybe 10 <$> optInt "db-pool-timeout")+ <*> optInt "max-rows"+ <*> optString "pre-request"+ <*> pure False+ <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value)+ <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key")+ <*> (maybe ["public"] splitExtraSearchPath <$> optValue "db-extra-search-path")+ <*> ((\x y -> QualifiedIdentifier x <$> y) <$> dbSchema <*> optString "root-spec")++ parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI) parseJwtAudience k =- C.key k >>= \case+ C.optional k C.string >>= \case Nothing -> pure Nothing -- no audience in config file- Just aud -> case preview stringOrUri (aud :: String) of+ Just aud -> case preview stringOrUri (unpack aud) of Nothing -> fail "Invalid Jwt audience. Check your configuration." (Just "") -> pure Nothing aud' -> pure aud' - coerceText :: Value -> Text- coerceText (String s) = s- coerceText v = show v+ reqString :: C.Key -> C.Parser C.Config Text+ reqString k = C.required k C.string - coerceInt :: (Read i, Integral i) => Value -> Maybe i- coerceInt (Number x) = rightToMaybe $ floatingOrInteger x- coerceInt (String x) = readMaybe $ toS x- coerceInt _ = Nothing+ optString :: C.Key -> C.Parser C.Config (Maybe Text)+ optString k = mfilter (/= "") <$> C.optional k C.string - coerceBool :: Value -> Maybe Bool- coerceBool (Bool b) = Just b- coerceBool (String b) = readMaybe $ toS b- coerceBool _ = Nothing+ optValue :: C.Key -> C.Parser C.Config (Maybe C.Value)+ optValue k = C.optional k C.value - parseRoleClaimKey :: Value -> Either ApiRequestError JSPath- parseRoleClaimKey (String s) = pRoleClaimKey s- parseRoleClaimKey v = pRoleClaimKey $ show v+ optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i)+ optInt k = join <$> C.optional k (coerceInt <$> C.value) - splitExtraSearchPath :: Value -> [Text]- splitExtraSearchPath (String s) = strip <$> splitOn "," s- splitExtraSearchPath _ = []+ optBool :: C.Key -> C.Parser C.Config (Maybe Bool)+ optBool k = join <$> C.optional k (coerceBool <$> C.value) + coerceText :: C.Value -> Text+ coerceText (C.String s) = s+ coerceText v = show v++ coerceInt :: (Read i, Integral i) => C.Value -> Maybe i+ coerceInt (C.Number x) = rightToMaybe $ floatingOrInteger x+ coerceInt (C.String x) = readMaybe $ toS x+ coerceInt _ = Nothing++ coerceBool :: C.Value -> Maybe Bool+ coerceBool (C.Bool b) = Just b+ coerceBool (C.String b) = readMaybe $ toS b+ coerceBool _ = Nothing++ parseRoleClaimKey :: C.Value -> Either ApiRequestError JSPath+ parseRoleClaimKey (C.String s) = pRoleClaimKey s+ parseRoleClaimKey v = pRoleClaimKey $ show v++ splitExtraSearchPath :: C.Value -> [Text]+ splitExtraSearchPath (C.String s) = strip <$> splitOn "," s+ splitExtraSearchPath _ = []+ opts = info (helper <*> pathParser) $ fullDesc <> progDesc (@@ -196,10 +229,9 @@ parserPrefs = prefs showHelpOnError - configNotfoundHint :: IOError -> IO a- configNotfoundHint e = do- hPutStrLn stderr $- "Cannot open config file:\n\t" <> show e+ exitErr :: Text -> IO a+ exitErr err = do+ hPutStrLn stderr err exitFailure exampleCfg :: Doc@@ -208,10 +240,15 @@ |db-schema = "public" # this schema gets added to the search_path of every request |db-anon-role = "postgres" |db-pool = 10+ |db-pool-timeout = 10 |- |server-host = "127.0.0.1"+ |server-host = "!4" |server-port = 3000 |+ |## unix socket location+ |## if specified it takes precedence over server-port+ |# server-unix-socket = "/tmp/pgrst.sock"+ | |## base url for swagger output |# server-proxy-uri = "" |@@ -232,6 +269,10 @@ | |## extra schemas to add to the search_path of every request |# db-extra-search-path = "extensions, util"+ |+ |## stored proc that overrides the root "/" spec+ |## it must be inside the db-schema+ |# root-spec = "stored_proc_name" |] pathParser :: Parser FilePath
src/PostgREST/DbRequestBuilder.hs view
@@ -1,48 +1,53 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DuplicateRecordFields#-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-}+{-|+Module : PostgREST.DbRequestBuilder+Description : PostgREST database request builder++This module is in charge of building an intermediate representation(ReadRequest, MutateRequest) between the HTTP request and the final resulting SQL query.++A query tree is built in case of resource embedding. By inferring the relationship between tables, join conditions are added for every embedded resource.+-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+ module PostgREST.DbRequestBuilder ( readRequest , mutateRequest , fieldNames ) where -import Control.Applicative-import Control.Arrow ((***))-import Control.Lens.Getter (view)-import Control.Lens.Tuple (_1)-import qualified Data.ByteString.Char8 as BS-import Data.List (delete)-import Data.Maybe (fromJust)-import qualified Data.Set as S-import Data.Text (isInfixOf)-import Data.Tree-import Data.Either.Combinators (mapLeft)--import Network.Wai+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashMap.Strict as M+import qualified Data.Set as S -import Data.Foldable (foldr1)-import qualified Data.HashMap.Strict as M+import Control.Arrow ((***))+import Control.Lens.Getter (view)+import Control.Lens.Tuple (_1)+import Data.Either.Combinators (mapLeft)+import Data.Foldable (foldr1)+import Data.List (delete)+import Data.Maybe (fromJust)+import Data.Text (isInfixOf)+import Text.Regex.TDFA ((=~))+import Unsafe (unsafeHead) -import PostgREST.ApiRequest ( ApiRequest(..)- , PreferRepresentation(..)- , Action(..), Target(..)- , PreferRepresentation (..)- )-import PostgREST.Error (apiRequestError)-import PostgREST.Parsers-import PostgREST.RangeQuery (NonnegRange, restrictRange, allRange)-import PostgREST.Types+import Control.Applicative+import Data.Tree+import Network.Wai -import Protolude hiding (from)-import Text.Regex.TDFA ((=~))-import Unsafe (unsafeHead)+import PostgREST.ApiRequest (Action (..), ApiRequest (..),+ PreferRepresentation (..),+ PreferRepresentation (..), Target (..))+import PostgREST.Error (ApiRequestError (..), errorResponseFor)+import PostgREST.Parsers+import PostgREST.RangeQuery (NonnegRange, allRange, restrictRange)+import PostgREST.Types+import Protolude hiding (from) readRequest :: Maybe Integer -> [Relation] -> Maybe ProcDescription -> ApiRequest -> Either Response ReadRequest readRequest maxRows allRels proc apiRequest =- mapLeft apiRequestError $+ mapLeft errorResponseFor $ treeRestrictRange maxRows =<< augumentRequestWithJoin schema relations =<< addFiltersOrdersRanges apiRequest <*>@@ -53,12 +58,12 @@ let target = iTarget apiRequest in case target of (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)- (TargetProc (QualifiedIdentifier s pName) ) -> Just (s, tName)+ (TargetProc (QualifiedIdentifier s pName) _ ) -> Just (s, tName) where tName = case pdReturnType <$> proc of- Just (SetOf (Composite qi)) -> qiName qi+ Just (SetOf (Composite qi)) -> qiName qi Just (Single (Composite qi)) -> qiName qi- _ -> pName+ _ -> pName _ -> Nothing @@ -68,7 +73,7 @@ buildReadRequest fieldTree = let rootDepth = 0 rootNodeName = if action == ActionRead then rootTableName else sourceCTEName in- foldr (treeEntry rootDepth) (Node (Select [] [rootNodeName] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing, rootDepth)) []) fieldTree+ foldr (treeEntry rootDepth) (Node (Select [] rootNodeName Nothing [] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing, rootDepth)) []) fieldTree where treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest treeEntry depth (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) =@@ -76,7 +81,7 @@ case fldForest of [] -> Node (q {select=fld:select q}, i) rForest _ -> Node (q, i) $- foldr (treeEntry nxtDepth) (Node (Select [] [fn] [] [] [] allRange, (fn, Nothing, alias, relationDetail, nxtDepth)) []) fldForest:rForest+ foldr (treeEntry nxtDepth) (Node (Select [] fn Nothing [] [] [] [] allRange, (fn, Nothing, alias, relationDetail, nxtDepth)) []) fldForest:rForest relations :: [Relation] relations = case action of@@ -84,7 +89,7 @@ ActionUpdate -> fakeSourceRelations ++ allRels ActionDelete -> fakeSourceRelations ++ allRels ActionInvoke _ -> fakeSourceRelations ++ allRels- _ -> allRels+ _ -> allRels where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- in a relation where one of the tables matches "TableName"@@ -108,13 +113,13 @@ augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest augumentRequestWithJoin schema allRels request = addRelations schema allRels Nothing request- >>= addJoinConditions schema+ >>= addJoinConditions schema Nothing addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest-addRelations schema allRelations parentNode (Node (query, (nodeName, _, alias, relationDetail, depth)) forest) =+addRelations schema allRelations parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, relationDetail, depth)) forest) = case parentNode of- Just (Node (Select{from=[parentNodeTable]}, _) _) ->- let newFrom r = (\tName -> if tName == nodeName then tableName (relTable r) else tName) <$> from query+ Just (Node (Select{from=parentNodeTable}, _) _) ->+ let newFrom r = if tbl == nodeName then tableName (relTable r) else tbl newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel rel :: Either ApiRequestError Relation rel = note (NoRelationBetween parentNodeTable nodeName) $@@ -208,35 +213,49 @@ ) ) allRelations -addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest-addJoinConditions schema (Node node@(query, nodeProps@(_, relation, _, _, _)) forest) =+-- previousAlias is only used for the case of self joins+addJoinConditions :: Schema -> Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest+addJoinConditions schema previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, relation, _, _, depth)) forest) = case relation of- Just Relation{relType=Root} -> Node node <$> updatedForest -- this is the root node+ Just Relation{relType=Root} -> Node node <$> updatedForest -- this is the root node Just rel@Relation{relType=Parent} -> Node (augmentQuery rel, nodeProps) <$> updatedForest Just rel@Relation{relType=Child} -> Node (augmentQuery rel, nodeProps) <$> updatedForest Just rel@Relation{relType=Many, relLinkTable=(Just linkTable)} -> let rq = augmentQuery rel in- Node (rq{from=tableName linkTable:from rq}, nodeProps) <$> updatedForest+ Node (rq{implicitJoins=tableName linkTable:implicitJoins rq}, nodeProps) <$> updatedForest _ -> Left UnknownRelation where- updatedForest = mapM (addJoinConditions schema) forest- augmentQuery rel = foldr addJoinCond query (getJoinConditions rel)- addJoinCond :: JoinCondition -> ReadQuery -> ReadQuery- addJoinCond jc rq@Select{joinConditions=jcs} = rq{joinConditions=jc:jcs}+ newAlias = case isSelfJoin <$> relation of+ Just True+ | depth /= 0 -> Just (tbl <> "_" <> show depth) -- root node doesn't get aliased+ | otherwise -> Nothing+ _ -> Nothing+ augmentQuery rel =+ foldr+ (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs})+ query{fromAlias=newAlias}+ (getJoinConditions previousAlias newAlias rel)+ updatedForest = mapM (addJoinConditions schema newAlias) forest -getJoinConditions :: Relation -> [JoinCondition]-getJoinConditions (Relation Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols typ lt lc1 lc2) =- if | typ == Child || typ == Parent ->+-- previousAlias and newAlias are used in the case of self joins+getJoinConditions :: Maybe Alias -> Maybe Alias -> Relation -> [JoinCondition]+getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols typ lt lc1 lc2) =+ case typ of+ Child -> zipWith (toJoinCondition tN ftN) cols fCols- | typ == Many ->+ Parent ->+ zipWith (toJoinCondition tN ftN) cols fCols+ Many -> let ltN = maybe "" tableName lt in zipWith (toJoinCondition tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toJoinCondition ftN ltN) fCols (fromMaybe [] lc2)- | typ == Root -> witness+ Root -> witness where toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition toJoinCondition tb ftb c fc =- JoinCondition (QualifiedIdentifier tSchema tb, Nothing, colName c)- (QualifiedIdentifier tSchema ftb, Nothing, colName fc)+ let qi1 = QualifiedIdentifier tSchema tb+ qi2 = QualifiedIdentifier tSchema ftb in+ JoinCondition (maybe qi1 (QualifiedIdentifier mempty) newAlias, colName c)+ (maybe qi2 (QualifiedIdentifier mempty) previousAlias, colName fc) addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest) addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [@@ -299,11 +318,11 @@ where pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest -mutateRequest :: ApiRequest -> TableName -> [Text] -> [FieldName] -> Either Response MutateRequest-mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $+mutateRequest :: ApiRequest -> TableName -> S.Set FieldName -> [FieldName] -> [FieldName] -> Either Response MutateRequest+mutateRequest apiRequest tName cols pkCols fldNames = mapLeft errorResponseFor $ case action of- ActionCreate -> Right $ Insert tName pkCols payload (iPreferResolution apiRequest) [] returnings- ActionUpdate -> Update tName payload <$> combinedLogic <*> pure returnings+ ActionCreate -> Right $ Insert tName cols ((,) <$> iPreferResolution apiRequest <*> Just pkCols) [] returnings+ ActionUpdate -> Update tName cols <$> combinedLogic <*> pure returnings ActionSingleUpsert -> (\flts -> if null (iLogic apiRequest) &&@@ -312,14 +331,13 @@ all (\case Filter _ (OpExpr False (Op "eq" _)) -> True _ -> False) flts- then Insert tName pkCols payload (Just MergeDuplicates) <$> combinedLogic <*> pure returnings+ then Insert tName cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings else Left InvalidFilters) =<< filters ActionDelete -> Delete tName <$> combinedLogic <*> pure returnings _ -> Left UnsupportedVerb where action = iAction apiRequest- payload = fromJust $ iPayload apiRequest returnings = if iPreferRepresentation apiRequest == None then [] else fldNames filters = map snd <$> mapM pRequestFilter mutateFilters logic = map snd <$> mapM pRequestLogicTree logicFilters
src/PostgREST/DbStructure.hs view
@@ -1,9 +1,19 @@+{-|+Module : PostgREST.DbStructure+Description : PostgREST schema cache++This module contains queries that target PostgreSQL system catalogs, these are used to build the schema cache(DbStructure).++The schema cache is necessary for resource embedding, foreign keys are used for inferring the relationships between tables.++These queries are executed once at startup or when PostgREST is reloaded.+-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE NamedFieldPuns #-} module PostgREST.DbStructure ( getDbStructure , accessibleTables@@ -12,27 +22,39 @@ , getPgVersion ) where -import qualified Hasql.Decoders as HD-import qualified Hasql.Encoders as HE-import qualified Hasql.Statement as H+import qualified Data.HashMap.Strict as M+import qualified Data.List as L+import qualified Data.Text as T+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Session as H+import qualified Hasql.Statement as H+import qualified Hasql.Transaction as HT -import Control.Applicative-import qualified Data.HashMap.Strict as M-import qualified Data.List as L-import Data.Set as S (fromList)-import Data.Text (split, strip,- breakOn, dropAround,- splitOn)-import qualified Data.Text as T-import qualified Hasql.Session as H-import qualified Hasql.Transaction as HT-import PostgREST.Types-import Text.InterpolatedString.Perl6 (q, qc)+import Data.Set as S (fromList)+import Data.Text (breakOn, dropAround, split,+ splitOn, strip)+import GHC.Exts (groupWith)+import Text.InterpolatedString.Perl6 (q, qc)+import Unsafe (unsafeHead) -import GHC.Exts (groupWith)-import Protolude-import Unsafe (unsafeHead)+import Control.Applicative +import PostgREST.Types+import Protolude++column :: HD.Value a -> HD.Row a+column = HD.column . HD.nonNullable++nullableColumn :: HD.Value a -> HD.Row (Maybe a)+nullableColumn = HD.column . HD.nullable++element :: HD.Value a -> HD.Array a+element = HD.element . HD.nonNullable++param :: HE.Value a -> HE.Params a+param = HE.param . HE.nonNullable+ getDbStructure :: Schema -> PgVersion -> HT.Transaction DbStructure getDbStructure schema pgVer = do HT.sql "set local schema ''" -- for getting the fully qualified name(schema.name) of every db object@@ -60,10 +82,10 @@ decodeTables = HD.rowList tblRow where- tblRow = Table <$> HD.column HD.text- <*> HD.column HD.text- <*> HD.nullableColumn HD.text- <*> HD.column HD.bool+ tblRow = Table <$> column HD.text+ <*> column HD.text+ <*> nullableColumn HD.text+ <*> column HD.bool decodeColumns :: [Table] -> HD.Result [Column] decodeColumns tables =@@ -71,41 +93,41 @@ where colRow = (,,,,,,,,,,,)- <$> HD.column HD.text <*> HD.column HD.text- <*> HD.column HD.text <*> HD.nullableColumn HD.text- <*> HD.column HD.int4 <*> HD.column HD.bool- <*> HD.column HD.text <*> HD.column HD.bool- <*> HD.nullableColumn HD.int4- <*> HD.nullableColumn HD.int4- <*> HD.nullableColumn HD.text- <*> HD.nullableColumn HD.text+ <$> column HD.text <*> column HD.text+ <*> column HD.text <*> nullableColumn HD.text+ <*> column HD.int4 <*> column HD.bool+ <*> column HD.text <*> column HD.bool+ <*> nullableColumn HD.int4+ <*> nullableColumn HD.int4+ <*> nullableColumn HD.text+ <*> nullableColumn HD.text decodeRelations :: [Table] -> [Column] -> HD.Result [Relation] decodeRelations tables cols = mapMaybe (relationFromRow tables cols) <$> HD.rowList relRow where relRow = (,,,,,)- <$> HD.column HD.text- <*> HD.column HD.text- <*> HD.column (HD.array (HD.dimension replicateM (HD.element HD.text)))- <*> HD.column HD.text- <*> HD.column HD.text- <*> HD.column (HD.array (HD.dimension replicateM (HD.element HD.text)))+ <$> column HD.text+ <*> column HD.text+ <*> column (HD.array (HD.dimension replicateM (element HD.text)))+ <*> column HD.text+ <*> column HD.text+ <*> column (HD.array (HD.dimension replicateM (element HD.text))) decodePks :: [Table] -> HD.Result [PrimaryKey] decodePks tables = mapMaybe (pkFromRow tables) <$> HD.rowList pkRow where- pkRow = (,,) <$> HD.column HD.text <*> HD.column HD.text <*> HD.column HD.text+ pkRow = (,,) <$> column HD.text <*> column HD.text <*> column HD.text decodeSynonyms :: [Column] -> HD.Result [Synonym] decodeSynonyms cols = mapMaybe (synonymFromRow cols) <$> HD.rowList synRow where synRow = (,,,,,)- <$> HD.column HD.text <*> HD.column HD.text- <*> HD.column HD.text <*> HD.column HD.text- <*> HD.column HD.text <*> HD.column HD.text+ <$> column HD.text <*> column HD.text+ <*> column HD.text <*> column HD.text+ <*> column HD.text <*> column HD.text decodeProcs :: HD.Result (M.HashMap Text [ProcDescription]) decodeProcs =@@ -113,15 +135,15 @@ map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowList tblRow where tblRow = ProcDescription- <$> HD.column HD.text- <*> HD.nullableColumn HD.text- <*> (parseArgs <$> HD.column HD.text)+ <$> column HD.text+ <*> nullableColumn HD.text+ <*> (parseArgs <$> column HD.text) <*> (parseRetType- <$> HD.column HD.text- <*> HD.column HD.text- <*> HD.column HD.bool- <*> HD.column HD.char)- <*> (parseVolatility <$> HD.column HD.char)+ <$> column HD.text+ <*> column HD.text+ <*> column HD.bool+ <*> column HD.char)+ <*> (parseVolatility <$> column HD.char) addName :: ProcDescription -> (Text, ProcDescription) addName pd = (pdName pd, pd)@@ -158,10 +180,10 @@ | otherwise = Volatile -- only 'v' can happen here allProcs :: H.Statement Schema (M.HashMap Text [ProcDescription])-allProcs = H.Statement (toS procsSqlQuery) (HE.param HE.text) decodeProcs True+allProcs = H.Statement (toS procsSqlQuery) (param HE.text) decodeProcs True accessibleProcs :: H.Statement Schema (M.HashMap Text [ProcDescription])-accessibleProcs = H.Statement (toS sql) (HE.param HE.text) decodeProcs True+accessibleProcs = H.Statement (toS sql) (param HE.text) decodeProcs True where sql = procsSqlQuery <> " AND has_function_privilege(p.oid, 'execute')" @@ -186,7 +208,7 @@ schemaDescription :: H.Statement Schema (Maybe Text) schemaDescription =- H.Statement sql (HE.param HE.text) (join <$> HD.rowMaybe (HD.nullableColumn HD.text)) True+ H.Statement sql (param HE.text) (join <$> HD.rowMaybe (nullableColumn HD.text)) True where sql = [q| select@@ -199,7 +221,7 @@ accessibleTables :: H.Statement Schema [Table] accessibleTables =- H.Statement sql (HE.param HE.text) decodeTables True+ H.Statement sql (param HE.text) decodeTables True where sql = [q| select@@ -230,7 +252,7 @@ addForeignKeys rels = map addFk where addFk col = col { colFK = fk col }- fk col = join $ relToFk col <$> find (lookupFn col) rels+ fk col = find (lookupFn col) rels >>= relToFk col lookupFn :: Column -> Relation -> Bool lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child relToFk col Relation{relColumns=cols, relFColumns=colsF} = do@@ -285,20 +307,29 @@ -- Relation is dependent on the order of relColumns and relFColumns to get the join conditions right in the generated query. -- So we need to change the order of the synonyms to match the relColumns -- This could be avoided if the Relation type is improved with a structure that maintains the association of relColumns and relFColumns- syns `sortAccordingTo` columns = sortOn (\(k, _) -> L.lookup k $ zip columns [0::Int ..]) syns in+ syns `sortAccordingTo` columns = sortOn (\(k, _) -> L.lookup k $ zip columns [0::Int ..]) syns - -- View Table Child Relations- [Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) relFTable relFColumns Child Nothing Nothing Nothing- | syns <- colsSyns, syns `allSynsOf` relColumns] +++ viewTableChild =+ [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns)+ relFTable relFColumns+ Child Nothing Nothing Nothing+ | syns <- colsSyns, syns `allSynsOf` relColumns ] - -- Table View Child Relations- [Relation relTable relColumns (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) Child Nothing Nothing Nothing- | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns] +++ tableViewChild =+ [ Relation relTable relColumns+ (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns)+ Child Nothing Nothing Nothing+ | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ] - -- View View Child Relations- [Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) Child Nothing Nothing Nothing- | syns <- colsSyns, fSyns <- fColsSyns, syns `allSynsOf` relColumns, fSyns `allSynsOf` relFColumns]+ viewViewChild =+ [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns)+ (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns)+ Child Nothing Nothing Nothing+ | syns <- colsSyns, syns `allSynsOf` relColumns+ , fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ] + in viewTableChild ++ tableViewChild ++ viewViewChild+ _ -> []) addParentRelations :: [Relation] -> [Relation]@@ -332,7 +363,7 @@ allTables :: H.Statement () [Table] allTables =- H.Statement sql HE.unit decodeTables True+ H.Statement sql HE.noParams decodeTables True where sql = [q| SELECT@@ -355,7 +386,7 @@ allColumns :: [Table] -> H.Statement Schema [Column] allColumns tabs =- H.Statement sql (HE.param HE.text) (decodeColumns tabs) True+ H.Statement sql (param HE.text) (decodeColumns tabs) True where sql = [q| SELECT DISTINCT@@ -542,7 +573,7 @@ allChildRelations :: [Table] -> [Column] -> H.Statement () [Relation] allChildRelations tabs cols =- H.Statement sql HE.unit (decodeRelations tabs cols) True+ H.Statement sql HE.noParams (decodeRelations tabs cols) True where sql = [q| SELECT ns1.nspname AS table_schema,@@ -583,7 +614,7 @@ allPrimaryKeys :: [Table] -> H.Statement () [PrimaryKey] allPrimaryKeys tabs =- H.Statement sql HE.unit (decodePks tabs) True+ H.Statement sql HE.noParams (decodePks tabs) True where sql = [q| /*@@ -693,12 +724,15 @@ allSynonyms :: [Column] -> PgVersion -> H.Statement Schema [Synonym] allSynonyms cols pgVer =- H.Statement sql (HE.param HE.text) (decodeSynonyms cols) True+ H.Statement sql (param HE.text) (decodeSynonyms cols) True -- query explanation at https://gist.github.com/steve-chavez/7ee0e6590cddafb532e5f00c46275569 where subselectRegex :: Text- subselectRegex | pgVer < pgVersion100 = ":subselect {.*?:constraintDeps <>} :location"- | otherwise = ":subselect {.*?:stmt_len 0} :location"+ -- "result" appears when the subselect is used inside "case when", see `authors_have_book_in_decade` fixture+ -- "resno" appears in every other case+ -- when copying the query into pg make sure you omit one backslash from \\d+, it should be like `\d+` for the regex+ subselectRegex | pgVer < pgVersion100 = ":subselect {.*?:constraintDeps <>} :location \\d+} :res(no|ult)"+ | otherwise = ":subselect {.*?:stmt_len 0} :location \\d+} :res(no|ult)" sql = [qc| with views as (@@ -709,7 +743,7 @@ from pg_class c join pg_namespace n on n.oid = c.relnamespace join pg_rewrite r on r.ev_class = c.oid- where (c.relkind = 'v'::char) and n.nspname = $1+ where (c.relkind in ('v', 'm')) and n.nspname = $1 ), removed_subselects as( select@@ -765,7 +799,7 @@ findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols getPgVersion :: H.Session PgVersion-getPgVersion = H.statement () $ H.Statement sql HE.unit versionRow False+getPgVersion = H.statement () $ H.Statement sql HE.noParams versionRow False where sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"- versionRow = HD.singleRow $ PgVersion <$> HD.column HD.int4 <*> HD.column HD.text+ versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text
src/PostgREST/Error.hs view
@@ -1,98 +1,71 @@+{-|+Module : PostgREST.Error+Description : PostgREST error HTTP responses+-} {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-} module PostgREST.Error (- apiRequestError-, pgError-, simpleError+ errorResponseFor+, ApiRequestError(..)+, PgError(..)+, SimpleError(..)+, errorPayload+, checkIsFatal , singularityError-, binaryFieldError-, connectionLostError-, encodeError-, gucHeadersError ) where -import Protolude-import Data.Aeson ((.=)) import qualified Data.Aeson as JSON-import Data.Text (unwords) import qualified Hasql.Pool as P import qualified Hasql.Session as H-import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT-import Network.Wai (Response, responseLBS)-import PostgREST.Types-import Text.Read (readMaybe) -apiRequestError :: ApiRequestError -> Response-apiRequestError err =- errorResponse status- [toHeader CTApplicationJSON] err- where- status =- case err of- ActionInappropriate -> HT.status405- UnsupportedVerb -> HT.status405- InvalidBody _ -> HT.status400- ParseRequestError _ _ -> HT.status400- NoRelationBetween _ _ -> HT.status400- InvalidRange -> HT.status416- UnknownRelation -> HT.status404- InvalidFilters -> HT.status405+import Data.Aeson ((.=))+import Data.Text (unwords)+import Network.Wai (Response, responseLBS)+import Text.Read (readMaybe) -simpleError :: HT.Status -> [Header] -> Text -> Response-simpleError status hdrs message =- errorResponse status (toHeader CTApplicationJSON : hdrs) $- JSON.object ["message" .= message]+import Network.HTTP.Types.Header -errorResponse :: JSON.ToJSON a => HT.Status -> [Header] -> a -> Response-errorResponse status hdrs e =- responseLBS status hdrs $ encodeError e+import PostgREST.Types+import Protolude -pgError :: Bool -> P.UsageError -> Response-pgError authed e =- let status = httpStatus authed e- jsonType = toHeader CTApplicationJSON- wwwAuth = ("WWW-Authenticate", "Bearer")- hdrs = if status == HT.status401- then [jsonType, wwwAuth]- else [jsonType] in- responseLBS status hdrs (encodeError e) -singularityError :: Integer -> Response-singularityError numRows =- responseLBS HT.status406- [toHeader CTSingularJSON]- $ toS . formatGeneralError- "JSON object requested, multiple (or no) rows returned"- $ unwords- [ "Results contain", show numRows, "rows,"- , toS (toMime CTSingularJSON), "requires 1 row"- ]- where- formatGeneralError :: Text -> Text -> Text- formatGeneralError message details = toS . JSON.encode $- JSON.object ["message" .= message, "details" .= details]+class (JSON.ToJSON a) => PgrstError a where+ status :: a -> HT.Status+ headers :: a -> [Header] + errorPayload :: a -> LByteString+ errorPayload = JSON.encode -binaryFieldError :: Response-binaryFieldError =- simpleError HT.status406 [] (toS (toMime CTOctetStream) <>- " requested but a single column was not selected")+ errorResponseFor :: a -> Response+ errorResponseFor err = responseLBS (status err) (headers err) $ errorPayload err -gucHeadersError :: Response-gucHeadersError =- simpleError HT.status500 []- "response.headers guc must be a JSON array composed of objects with a single key and a string value" -connectionLostError :: Response-connectionLostError =- simpleError HT.status503 [] "Database connection lost, retrying the connection." -encodeError :: JSON.ToJSON a => a -> LByteString-encodeError = JSON.encode+data ApiRequestError+ = ActionInappropriate+ | InvalidRange+ | InvalidBody ByteString+ | ParseRequestError Text Text+ | NoRelationBetween Text Text+ | InvalidFilters+ | UnknownRelation -- Unreachable?+ | UnsupportedVerb -- Unreachable?+ deriving (Show, Eq) +instance PgrstError ApiRequestError where+ status InvalidRange = HT.status416+ status InvalidFilters = HT.status405+ status (InvalidBody _) = HT.status400+ status UnsupportedVerb = HT.status405+ status UnknownRelation = HT.status404+ status ActionInappropriate = HT.status405+ status (ParseRequestError _ _) = HT.status400+ status (NoRelationBetween _ _) = HT.status400++ headers _ = [toHeader CTApplicationJSON]+ instance JSON.ToJSON ApiRequestError where toJSON (ParseRequestError message details) = JSON.object [ "message" .= message, "details" .= details]@@ -111,9 +84,24 @@ toJSON InvalidFilters = JSON.object [ "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)] ++data PgError = PgError Authenticated P.UsageError+type Authenticated = Bool++instance PgrstError PgError where+ status (PgError authed usageError) = pgErrorStatus authed usageError++ headers err =+ if status err == HT.status401+ then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]+ else [toHeader CTApplicationJSON]++instance JSON.ToJSON PgError where+ toJSON (PgError _ usageError) = JSON.toJSON usageError+ instance JSON.ToJSON P.UsageError where toJSON (P.ConnectionError e) = JSON.object [- "code" .= ("" :: Text),+ "code" .= ("" :: Text), "message" .= ("Database connection error" :: Text), "details" .= (toS $ fromMaybe "" e :: Text)] toJSON (P.SessionError e) = JSON.toJSON e -- H.Error@@ -123,69 +111,146 @@ instance JSON.ToJSON H.CommandError where toJSON (H.ResultError (H.ServerError c m d h)) = case toS c of- 'P':'T':_ ->- JSON.object [- "details" .= (fmap toS d::Maybe Text),- "hint" .= (fmap toS h::Maybe Text)]- _ ->- JSON.object [- "code" .= (toS c::Text),- "message" .= (toS m::Text),- "details" .= (fmap toS d::Maybe Text),- "hint" .= (fmap toS h::Maybe Text)]+ 'P':'T':_ -> JSON.object [+ "details" .= (fmap toS d :: Maybe Text),+ "hint" .= (fmap toS h :: Maybe Text)]++ _ -> JSON.object [+ "code" .= (toS c :: Text),+ "message" .= (toS m :: Text),+ "details" .= (fmap toS d :: Maybe Text),+ "hint" .= (fmap toS h :: Maybe Text)]+ toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [- "message" .= (m::Text)]+ "message" .= (m :: Text)] toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [- "message" .= ("Row error: end of input"::Text),- "details" .=- ("Attempt to parse more columns than there are in the result"::Text),- "details" .= (("Row number " <> show i)::Text)]+ "message" .= ("Row error: end of input" :: Text),+ "details" .= ("Attempt to parse more columns than there are in the result" :: Text),+ "hint" .= (("Row number " <> show i) :: Text)] toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [- "message" .= ("Row error: unexpected null"::Text),- "details" .= ("Attempt to parse a NULL as some value."::Text),- "details" .= (("Row number " <> show i)::Text)]+ "message" .= ("Row error: unexpected null" :: Text),+ "details" .= ("Attempt to parse a NULL as some value." :: Text),+ "hint" .= (("Row number " <> show i) :: Text)] toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [- "message" .= ("Row error: Wrong value parser used"::Text),+ "message" .= ("Row error: Wrong value parser used" :: Text), "details" .= d,- "details" .= (("Row number " <> show i)::Text)]+ "hint" .= (("Row number " <> show i) :: Text)] toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [- "message" .= ("Unexpected amount of rows"::Text),+ "message" .= ("Unexpected amount of rows" :: Text), "details" .= i] toJSON (H.ClientError d) = JSON.object [- "message" .= ("Database client error"::Text),- "details" .= (fmap toS d::Maybe Text)]+ "message" .= ("Database client error" :: Text),+ "details" .= (fmap toS d :: Maybe Text)] -httpStatus :: Bool -> P.UsageError -> HT.Status-httpStatus _ (P.ConnectionError _) = HT.status503-httpStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError (H.ServerError c m _ _)))) =- case toS 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- '2':'5':_ -> HT.status500 -- invalid tx state- '2':'8':_ -> HT.status403 -- invalid auth specification- '2':'D':_ -> HT.status500 -- invalid tx termination- '3':'8':_ -> HT.status500 -- external routine exception- '3':'9':_ -> HT.status500 -- external routine invocation- '3':'B':_ -> HT.status500 -- savepoint exception- '4':'0':_ -> HT.status500 -- tx rollback- '5':'3':_ -> HT.status503 -- insufficient resources- '5':'4':_ -> HT.status413 -- too complex- '5':'5':_ -> HT.status500 -- obj not on prereq state- '5':'7':_ -> HT.status500 -- operator intervention- '5':'8':_ -> HT.status500 -- system error- 'F':'0':_ -> HT.status500 -- conf file error- 'H':'V':_ -> HT.status500 -- foreign data wrapper error- "P0001" -> HT.status400 -- default code for "raise"- 'P':'0':_ -> HT.status500 -- PL/pgSQL Error- 'X':'X':_ -> HT.status500 -- internal Error- "42883" -> HT.status404 -- undefined function- "42P01" -> HT.status404 -- undefined table- "42501" -> if authed then HT.status403 else HT.status401 -- insufficient privilege- 'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m)- _ -> HT.status400-httpStatus _ (P.SessionError (H.QueryError _ _ (H.ResultError _))) = HT.status500-httpStatus _ (P.SessionError (H.QueryError _ _ (H.ClientError _))) = HT.status503+pgErrorStatus :: Bool -> P.UsageError -> HT.Status+pgErrorStatus _ (P.ConnectionError _) = HT.status503+pgErrorStatus _ (P.SessionError (H.QueryError _ _ (H.ClientError _))) = HT.status503+pgErrorStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError rError))) =+ case rError of+ (H.ServerError c m _ _) ->+ case toS 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+ '2':'5':_ -> HT.status500 -- invalid tx state+ '2':'8':_ -> HT.status403 -- invalid auth specification+ '2':'D':_ -> HT.status500 -- invalid tx termination+ '3':'8':_ -> HT.status500 -- external routine exception+ '3':'9':_ -> HT.status500 -- external routine invocation+ '3':'B':_ -> HT.status500 -- savepoint exception+ '4':'0':_ -> HT.status500 -- tx rollback+ '5':'3':_ -> HT.status503 -- insufficient resources+ '5':'4':_ -> HT.status413 -- too complex+ '5':'5':_ -> HT.status500 -- obj not on prereq state+ '5':'7':_ -> HT.status500 -- operator intervention+ '5':'8':_ -> HT.status500 -- system error+ 'F':'0':_ -> HT.status500 -- conf file error+ 'H':'V':_ -> HT.status500 -- foreign data wrapper error+ "P0001" -> HT.status400 -- default code for "raise"+ 'P':'0':_ -> HT.status500 -- PL/pgSQL Error+ 'X':'X':_ -> HT.status500 -- internal Error+ "42883" -> HT.status404 -- undefined function+ "42P01" -> HT.status404 -- undefined table+ "42501" -> if authed then HT.status403 else HT.status401 -- insufficient privilege+ 'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m)+ _ -> HT.status400++ _ -> HT.status500++checkIsFatal :: PgError -> Maybe Text+checkIsFatal (PgError _ (P.ConnectionError e))+ | isAuthFailureMessage = Just $ toS failureMessage+ | otherwise = Nothing+ where isAuthFailureMessage = "FATAL: password authentication failed" `isPrefixOf` toS failureMessage+ failureMessage = fromMaybe "" e+checkIsFatal _ = Nothing+++data SimpleError+ = GucHeadersError+ | BinaryFieldError ContentType+ | ConnectionLostError+ | PutSingletonError+ | PutMatchingPkError+ | PutRangeNotAllowedError+ | PutPayloadIncompleteError+ | JwtTokenMissing+ | JwtTokenInvalid Text+ | SingularityError Integer+ | ContentTypeError [ByteString]+ deriving (Show, Eq)++instance PgrstError SimpleError where+ status GucHeadersError = HT.status500+ status (BinaryFieldError _) = HT.status406+ status ConnectionLostError = HT.status503+ status PutSingletonError = HT.status400+ status PutMatchingPkError = HT.status400+ status PutRangeNotAllowedError = HT.status400+ status PutPayloadIncompleteError = HT.status400+ status JwtTokenMissing = HT.status500+ status (JwtTokenInvalid _) = HT.unauthorized401+ status (SingularityError _) = HT.status406+ status (ContentTypeError _) = HT.status415++ headers (SingularityError _) = [toHeader CTSingularJSON]+ headers (JwtTokenInvalid m) = [toHeader CTApplicationJSON, invalidTokenHeader m]+ headers _ = [toHeader CTApplicationJSON]++instance JSON.ToJSON SimpleError where+ toJSON GucHeadersError = JSON.object [+ "message" .= ("response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)]+ toJSON (BinaryFieldError ct) = JSON.object [+ "message" .= ((toS (toMime ct) <> " requested but a single column was not selected") :: Text)]+ toJSON ConnectionLostError = JSON.object [+ "message" .= ("Database connection lost, retrying the connection." :: Text)]++ toJSON PutSingletonError = JSON.object [+ "message" .= ("PUT payload must contain a single row" :: Text)]+ toJSON PutRangeNotAllowedError = JSON.object [+ "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)]+ toJSON PutPayloadIncompleteError = JSON.object [+ "message" .= ("You must specify all columns in the payload when using PUT" :: Text)]+ toJSON PutMatchingPkError = JSON.object [+ "message" .= ("Payload values do not match URL in primary key column(s)" :: Text)]++ toJSON (ContentTypeError cts) = JSON.object [+ "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]+ toJSON (SingularityError n) = JSON.object [+ "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),+ "details" .= unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]++ toJSON JwtTokenMissing = JSON.object [+ "message" .= ("Server lacks JWT secret" :: Text)]+ toJSON (JwtTokenInvalid message) = JSON.object [+ "message" .= (message :: Text)]++invalidTokenHeader :: Text -> Header+invalidTokenHeader m =+ ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> show m)++singularityError :: (Integral a) => a -> SimpleError+singularityError = SingularityError . toInteger
src/PostgREST/Middleware.hs view
@@ -1,37 +1,42 @@+{-|+Module : PostgREST.Middleware+Description : Sets the PostgreSQL GUCs, role, search_path and pre-request function. Validates JWT.+-} {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-} module PostgREST.Middleware where -import Crypto.JWT-import qualified Data.Aeson as JSON-import qualified Data.HashMap.Strict as M-import qualified Hasql.Transaction as H+import qualified Data.Aeson as JSON+import qualified Data.HashMap.Strict as M+import qualified Hasql.Transaction as H -import Network.HTTP.Types.Status (unauthorized401, status500)-import Network.Wai (Application, Response)-import Network.Wai.Middleware.Cors (cors)-import Network.Wai.Middleware.Gzip (def, gzip)-import Network.Wai.Middleware.Static (only, staticPolicy)+import Network.Wai (Application, Response)+import Network.Wai.Middleware.Cors (cors)+import Network.Wai.Middleware.Gzip (def, gzip)+import Network.Wai.Middleware.Static (only, staticPolicy) -import PostgREST.ApiRequest (ApiRequest(..))-import PostgREST.Auth (JWTAttempt(..))-import PostgREST.Config (AppConfig (..), corsPolicy)-import PostgREST.Error (simpleError)-import PostgREST.QueryBuilder (unquoted, pgFmtSetLocal, pgFmtSetLocalSearchPath)+import Crypto.JWT -import Protolude+import PostgREST.ApiRequest (ApiRequest (..))+import PostgREST.Auth (JWTAttempt (..))+import PostgREST.Config (AppConfig (..), corsPolicy)+import PostgREST.Error (SimpleError (JwtTokenInvalid, JwtTokenMissing),+ errorResponseFor)+import PostgREST.QueryBuilder (pgFmtSetLocal, pgFmtSetLocalSearchPath,+ unquoted)+import Protolude runWithClaims :: AppConfig -> JWTAttempt -> (ApiRequest -> H.Transaction Response) -> ApiRequest -> H.Transaction Response runWithClaims conf eClaims app req = case eClaims of- JWTInvalid JWTExpired -> return $ unauthed "JWT expired"- JWTInvalid e -> return $ unauthed $ show e- JWTMissingSecret -> return $ simpleError status500 [] "Server lacks JWT secret"- JWTClaims claims -> do+ JWTMissingSecret -> return . errorResponseFor $ JwtTokenMissing+ JWTInvalid JWTExpired -> return . errorResponseFor . JwtTokenInvalid $ "JWT expired"+ JWTInvalid e -> return . errorResponseFor . JwtTokenInvalid . show $ e+ JWTClaims claims -> do H.sql $ toS . mconcat $ setSearchPathSql : setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql ++ appSettingsSql mapM_ H.sql customReqCheck app req@@ -47,14 +52,6 @@ claimsWithRole = M.union claims (M.singleton "role" anon) anon = JSON.String . toS $ configAnonRole conf customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf- where- unauthed message = simpleError- unauthorized401- [( "WWW-Authenticate"- , "Bearer error=\"invalid_token\", " <>- "error_description=" <> show message- )]- message defaultMiddle :: Application -> Application defaultMiddle =
src/PostgREST/OpenAPI.hs view
@@ -1,40 +1,54 @@+{-|+Module : PostgREST.OpenAPI+Description : Generates the OpenAPI output+-} {-# LANGUAGE OverloadedStrings #-} module PostgREST.OpenAPI ( encodeOpenAPI- , isMalformedProxyUri- , pickProxy- ) where+, isMalformedProxyUri+, pickProxy+) where -import Control.Arrow ((&&&))-import Control.Lens-import Data.Aeson (decode, encode)-import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)-import Data.Maybe (fromJust)-import qualified Data.Set as Set-import Data.String (IsString (..))-import Data.Text (unpack, pack, init, tail, toLower, intercalate, append, dropWhile, breakOn)-import Network.URI (parseURI, isAbsoluteURI,- URI (..), URIAuth (..))+import qualified Data.Set as Set -import Protolude hiding ((&), Proxy, get, intercalate, dropWhile)+import Control.Arrow ((&&&))+import Data.Aeson (decode, encode)+import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)+import Data.Maybe (fromJust)+import Data.String (IsString (..))+import Data.Text (append, breakOn, dropWhile, init,+ intercalate, pack, tail, toLower,+ unpack)+import Network.URI (URI (..), URIAuth (..),+ isAbsoluteURI, parseURI) -import Data.Swagger+import Control.Lens+import Data.Swagger -import PostgREST.ApiRequest (ContentType(..))-import PostgREST.Config (prettyVersion, docsVersion)-import PostgREST.Types (Table(..), Column(..), PgArg(..), ForeignKey(..),- PrimaryKey(..), Proxy(..), ProcDescription(..), toMime)+import PostgREST.ApiRequest (ContentType (..))+import PostgREST.Config (docsVersion, prettyVersion)+import PostgREST.Types (Column (..), ForeignKey (..), PgArg (..),+ PrimaryKey (..), ProcDescription (..),+ Proxy (..), Table (..), toMime)+import Protolude hiding (Proxy, dropWhile, get,+ intercalate, (&)) makeMimeList :: [ContentType] -> MimeList makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs toSwaggerType :: Text -> SwaggerType t-toSwaggerType "text" = SwaggerString-toSwaggerType "integer" = SwaggerInteger-toSwaggerType "boolean" = SwaggerBoolean-toSwaggerType "numeric" = SwaggerNumber-toSwaggerType _ = SwaggerString+toSwaggerType "character varying" = SwaggerString+toSwaggerType "character" = SwaggerString+toSwaggerType "text" = SwaggerString+toSwaggerType "boolean" = SwaggerBoolean+toSwaggerType "smallint" = SwaggerInteger+toSwaggerType "integer" = SwaggerInteger+toSwaggerType "bigint" = SwaggerInteger+toSwaggerType "numeric" = SwaggerNumber+toSwaggerType "real" = SwaggerNumber+toSwaggerType "double precision" = SwaggerNumber+toSwaggerType _ = SwaggerString makeTableDef :: [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema) makeTableDef pks (t, cs, _) =@@ -319,7 +333,7 @@ uri = toURI $ fromJust proxy scheme = init $ toLower $ pack $ uriScheme uri path URI {uriPath = ""} = "/"- path URI {uriPath = p} = p+ path URI {uriPath = p} = p path' = pack $ path uri authority = fromJust $ uriAuthority uri host' = pack $ uriRegName authority@@ -327,15 +341,15 @@ readPort = fromMaybe 80 . readMaybe port'' :: Integer port'' = case (port', scheme) of- ("", "http") -> 80+ ("", "http") -> 80 ("", "https") -> 443- _ -> readPort $ unpack $ tail $ pack port'+ _ -> readPort $ unpack $ tail $ pack port' isUriValid:: URI -> Bool isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid] fAnd :: [a -> Bool] -> a -> Bool-fAnd fs x = all ($x) fs+fAnd fs x = all ($ x) fs isSchemeValid :: URI -> Bool isSchemeValid URI {uriScheme = s}@@ -345,7 +359,7 @@ isQueryValid :: URI -> Bool isQueryValid URI {uriQuery = ""} = True-isQueryValid _ = False+isQueryValid _ = False isAuthorityValid :: URI -> Bool isAuthorityValid URI {uriAuthority = a}@@ -354,16 +368,16 @@ isUserInfoValid :: URIAuth -> Bool isUserInfoValid URIAuth {uriUserInfo = ""} = True-isUserInfoValid _ = False+isUserInfoValid _ = False isHostValid :: URIAuth -> Bool isHostValid URIAuth {uriRegName = ""} = False-isHostValid _ = True+isHostValid _ = True isPortValid :: URIAuth -> Bool isPortValid URIAuth {uriPort = ""} = True isPortValid URIAuth {uriPort = (':':p)} = case readMaybe p of- Just i -> i > (0 :: Integer) && i < 65536+ Just i -> i > (0 :: Integer) && i < 65536 Nothing -> False isPortValid _ = False
src/PostgREST/Parsers.hs view
@@ -1,20 +1,31 @@+{-|+Module : PostgREST.Parsers+Description : PostgREST parser combinators++This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.+-} module PostgREST.Parsers where -import Protolude hiding (try, intercalate, replace, option)-import Control.Monad ((>>))-import Data.Foldable (foldl1)-import Data.Functor (($>))-import qualified Data.HashMap.Strict as M-import Data.Text (intercalate, replace, strip)-import Data.List (init, last)-import Data.Tree-import Data.Either.Combinators (mapLeft)-import PostgREST.RangeQuery (NonnegRange)-import PostgREST.Types-import Text.ParserCombinators.Parsec hiding (many, (<|>))-import Text.Parsec.Error-import Text.Read (read)+import qualified Data.HashMap.Strict as M+import qualified Data.Set as S +import Control.Monad ((>>))+import Data.Either.Combinators (mapLeft)+import Data.Foldable (foldl1)+import Data.Functor (($>))+import Data.List (init, last)+import Data.Text (intercalate, replace, strip)+import Text.Read (read)++import Data.Tree+import Text.Parsec.Error+import Text.ParserCombinators.Parsec hiding (many, (<|>))++import PostgREST.Error (ApiRequestError (ParseRequestError))+import PostgREST.RangeQuery (NonnegRange)+import PostgREST.Types+import Protolude hiding (intercalate, option, replace, try)+ pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem] pRequestSelect selStr = mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)@@ -45,10 +56,19 @@ where path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k embedPath = fst <$> path- op = snd <$> path- -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"- logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v)+ logicTree = do+ op <- snd <$> path+ -- Concat op and v to make pLogicTree argument regular,+ -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"+ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v) +pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName))+pRequestColumns colStr =+ case colStr of+ Just str ->+ mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)+ _ -> Right Nothing+ ws :: Parser Text ws = toS <$> many (oneOf " \t") @@ -110,7 +130,10 @@ pRelationSelect = lexeme $ try ( do alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) fld <- pField- relationDetail <- optionMaybe ( try( char '.' *> pFieldName ) )+ relationDetail <- optionMaybe (+ try ( char '+' *> pFieldName ) <|>+ try ( char '.' *> pFieldName ) -- TODO deprecated, remove in next major version+ ) return (fld, Nothing, alias, relationDetail) )@@ -210,6 +233,9 @@ let op = last path notOp = "not." <> op return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)++pColumns :: Parser [FieldName]+pColumns = pFieldName `sepBy1` lexeme (char ',') mapError :: Either ParseError a -> Either ApiRequestError a mapError = mapLeft translateError
src/PostgREST/QueryBuilder.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-|@@ -27,30 +27,42 @@ , pgFmtSetLocalSearchPath ) where -import qualified Hasql.Statement as H-import qualified Hasql.Encoders as HE-import qualified Hasql.Decoders as HD+import qualified Data.Aeson as JSON+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashMap.Strict as HM+import qualified Data.Set as S+import qualified Data.Text as T (map, null, takeWhile)+import qualified Data.Text.Encoding as T+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Statement as H -import qualified Data.Aeson as JSON+import Data.Scientific (FPFormat (..), formatScientific,+ isInteger)+import Data.Text (intercalate, isInfixOf, replace,+ toLower, unwords)+import Data.Tree (Tree (..))+import Text.InterpolatedString.Perl6 (qc) -import PostgREST.RangeQuery (rangeLimit, rangeOffset, allRange)-import qualified Data.HashMap.Strict as HM-import Data.Maybe-import qualified Data.Set as S-import Data.Text (intercalate, unwords, replace, isInfixOf, toLower)-import qualified Data.Text as T (map, takeWhile, null)-import qualified Data.Text.Encoding as T-import Data.Tree (Tree(..))-import PostgREST.Types-import Text.InterpolatedString.Perl6 (qc)-import qualified Data.ByteString.Char8 as BS-import Data.Scientific ( FPFormat (..)- , formatScientific- , isInteger- )-import Protolude hiding ( intercalate, cast, replace)-import PostgREST.ApiRequest (PreferRepresentation (..))+import Data.Maybe +import PostgREST.ApiRequest (PreferRepresentation (..))+import PostgREST.RangeQuery (allRange, rangeLimit, rangeOffset)+import PostgREST.Types+import Protolude hiding (cast, intercalate, replace)++column :: HD.Value a -> HD.Row a+column = HD.column . HD.nonNullable++nullableColumn :: HD.Value a -> HD.Row (Maybe a)+nullableColumn = HD.column . HD.nullable++element :: HD.Value a -> HD.Array a+element = HD.element . HD.nonNullable++param :: HE.Value a -> HE.Params a+param = HE.param . HE.nonNullable+ {-| The generic query result format used by API responses. The location header is represented as a list of strings containing variable bindings like @"k1=eq.42"@, or the empty list if there is no location header.@@ -58,10 +70,10 @@ type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString) standardRow :: HD.Row ResultsWithCount-standardRow = (,,,) <$> HD.nullableColumn HD.int8 <*> HD.column HD.int8- <*> HD.column header <*> HD.column HD.bytea+standardRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8+ <*> column header <*> column HD.bytea where- header = HD.array $ HD.dimension replicateM $ HD.element HD.bytea+ header = HD.array $ HD.dimension replicateM $ element HD.bytea noLocationF :: Text noLocationF = "array[]::text[]"@@ -81,7 +93,7 @@ createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> H.Statement () ResultsWithCount createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =- unicodeStatement sql HE.unit decodeStandard False+ unicodeStatement sql HE.noParams decodeStandard False where sql = [qc| WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}@@ -103,8 +115,8 @@ createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> PreferRepresentation -> [Text] -> H.Statement ByteString (Maybe ResultsWithCount)-createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys =- unicodeStatement sql (HE.param HE.unknown) decodeStandardMay True+createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys =+ unicodeStatement sql (param HE.unknown) decodeStandardMay True where sql = case rep of@@ -123,9 +135,14 @@ cols = intercalate ", " [ "'' AS total_result_set", -- when updateing it does not make sense "pg_catalog.count(_postgrest_t) AS page_total",- if wantHdrs- then "coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")"- else noLocationF <> " AS header",+ if isInsert+ then unwords [+ "CASE",+ "WHEN pg_catalog.count(_postgrest_t) = 1 THEN",+ "coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")",+ "ELSE " <> noLocationF,+ "END AS header"]+ else noLocationF <> "AS header", if rep == Full then bodyF <> " AS body" else "''"@@ -138,62 +155,75 @@ type ProcResults = (Maybe Int64, Int64, ByteString, ByteString) callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool ->- Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool -> PgVersion ->+ Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> H.Statement ByteString (Maybe ProcResults)-callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField isObject pgVer =- unicodeStatement sql (HE.param HE.unknown) decodeProc True+callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField pgVer =+ unicodeStatement sql (param HE.unknown) decodeProc True where- sql =- if returnsScalar then [qc|- WITH {argsRecord},- {sourceCTEName} AS (- SELECT {fromQi qi}({args})- )- SELECT- {countResultF} AS total_result_set,- 1 AS page_total,- {scalarBodyF} AS body,- {responseHeaders} AS response_headers- FROM ({selectQuery}) _postgrest_t;|]- else [qc|- WITH {argsRecord},- {sourceCTEName} AS (- SELECT * FROM {fromQi qi}({args})- )- SELECT- {countResultF} AS total_result_set,- pg_catalog.count(_postgrest_t) AS page_total,- {bodyF} AS body,- {responseHeaders} AS response_headers- FROM ({selectQuery}) _postgrest_t;|]+ sql =[qc|+ WITH+ {argsRecord},+ {sourceCTEName} AS (+ {sourceBody}+ )+ SELECT+ {countResultF} AS total_result_set,+ pg_catalog.count(_postgrest_t) AS page_total,+ {bodyF} AS body,+ {responseHeaders} AS response_headers+ FROM ({selectQuery}) _postgrest_t;|] - (argsRecord, args) | paramsAsSingleObject = ("_args_record AS (SELECT NULL)", "$1::json")- | null pgArgs = (ignoredBody, "")- | otherwise = (- unwords [- "_args_record AS (",- "SELECT * FROM " <> (if isObject then "json_to_record" else "json_to_recordset") <> "($1)",- "AS _(" <> intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " " <> pgaType a) <$> pgArgs) <> ")",- ")"]- , intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM _args_record)") <$> pgArgs))+ (argsRecord, args)+ | paramsAsSingleObject = ("_args_record AS (SELECT NULL)", "$1::json")+ | null pgArgs = (ignoredBody, "")+ | otherwise = (+ unwords [+ normalizedBody <> ",",+ "_args_record AS (",+ "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <>+ intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " " <> pgaType a) <$> pgArgs) <> ")",+ ")"]+ , intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " := _args_record." <> pgFmtIdent (pgaName a)) <$> pgArgs))++ sourceBody :: SqlFragment+ sourceBody+ | paramsAsSingleObject || null pgArgs =+ if returnsScalar+ then [qc| SELECT {fromQi qi}({args}) |]+ else [qc| SELECT * FROM {fromQi qi}({args}) |]+ | otherwise =+ if returnsScalar+ then [qc| SELECT {fromQi qi}({args}) FROM _args_record |]+ else [qc| SELECT _.*+ FROM _args_record,+ LATERAL ( SELECT * FROM {fromQi qi}({args}) ) _ |]++ bodyF+ | returnsScalar = scalarBodyF+ | isSingle = asJsonSingleF+ | asCsv = asCsvF+ | isJust binaryField = asBinaryF $ fromJust binaryField+ | otherwise = asJsonF++ scalarBodyF+ | asBinary = asBinaryF _procName+ | otherwise = unwords [+ "CASE",+ "WHEN pg_catalog.count(_postgrest_t) = 1",+ "THEN (json_agg(_postgrest_t." <> pgFmtIdent _procName <> ")->0)::character varying",+ "ELSE (json_agg(_postgrest_t." <> pgFmtIdent _procName <> "))::character varying",+ "END"]+ countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text _procName = qiName qi responseHeaders = if pgVer >= pgVersion96 then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15 else "'[]'" :: Text- decodeProc = HD.rowMaybe procRow- procRow = (,,,) <$> HD.nullableColumn HD.int8 <*> HD.column HD.int8- <*> HD.column HD.bytea <*> HD.column HD.bytea- scalarBodyF- | asBinary = asBinaryF _procName- | otherwise = "(row_to_json(_postgrest_t)->" <> pgFmtLit _procName <> ")::character varying" - bodyF- | isSingle = asJsonSingleF- | asCsv = asCsvF- | isJust binaryField = asBinaryF $ fromJust binaryField- | otherwise = asJsonF+ decodeProc = HD.rowMaybe procRow+ procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8+ <*> column HD.bytea <*> column HD.bytea pgFmtIdent :: SqlFragment -> SqlFragment pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""@@ -219,32 +249,21 @@ qi = removeSourceCTESchema schema mainTbl requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery-requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest joinConditions_ ordts range, (nodeName, maybeRelation, _, _, depth)) forest)) =+requestToQuery schema isParent (DbRead (Node (Select colSelects tbl tblAlias implJoins logicForest joinConditions_ ordts range, _) forest)) = unwords [ "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),- "FROM " <> intercalate ", " tables,+ "FROM " <> intercalate ", " (tabl : implJs), unwords joins,- ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConds))- `emptyOnFalse` (null logicForest && null joinConds),+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_))+ `emptyOnFalse` (null logicForest && null joinConditions_), ("ORDER BY " <> intercalate ", " (map (pgFmtOrderTerm qi) ordts)) `emptyOnFalse` null ordts, ("LIMIT " <> maybe "ALL" show (rangeLimit range) <> " OFFSET " <> show (rangeOffset range)) `emptyOnFalse` (isParent || range == allRange) ] where- mainTbl = maybe nodeName (tableName . relTable) maybeRelation- isSelfJoin = maybe False (\r -> relType r /= Root && relTable r == relFTable r) maybeRelation- (qi, tables, joinConds) =- let depthAlias name dpth = if dpth /= 0 then name <> "_" <> show dpth else name in -- Root node doesn't get aliased- if isSelfJoin- then (- QualifiedIdentifier "" (depthAlias mainTbl depth),- (\t -> fromQi (removeSourceCTESchema schema t) <> " AS " <> pgFmtIdent (depthAlias t depth)) <$> tbls,- (\(JoinCondition (qi1, _, c1) (qi2, _, c2)) ->- JoinCondition (qi1, Just $ depthAlias (qiName qi1) depth, c1)- (qi2, Just $ depthAlias (qiName qi2) (depth - 1), c2)) <$> joinConditions_)- else (- removeSourceCTESchema schema mainTbl,- fromQi . removeSourceCTESchema schema <$> tbls,- joinConditions_)+ implJs = fromQi . QualifiedIdentifier schema <$> implJoins+ mainQi = removeSourceCTESchema schema tbl+ tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias+ qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias (joins, selects) = foldr getQueryParts ([],[]) forest @@ -274,48 +293,42 @@ --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts _ _ = witness-requestToQuery schema _ (DbMutate (Insert mainTbl pkCols p@(PayloadJSON _ pType pKeys) onConflct logicForest returnings)) =+requestToQuery schema _ (DbMutate (Insert mainTbl iCols onConflct putConditions returnings)) = unwords [- ("WITH " <> ignoredBody) `emptyOnFalse` not payloadIsEmpty,- "INSERT INTO ", fromQi qi, if payloadIsEmpty then " " else "(" <> cols <> ")",- case (pType, payloadIsEmpty) of- (PJArray _, True) -> "SELECT null WHERE false"- (PJObject, True) -> "DEFAULT VALUES"- _ -> unwords [- "SELECT " <> cols <> " FROM",- case pType of- PJObject -> "json_populate_record"- PJArray _ -> "json_populate_recordset", "(null::", fromQi qi, ", $1) _",- -- Only used for PUT- ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier "" "_") <$> logicForest)) `emptyOnFalse` null logicForest],- maybe "" (\x -> (- "ON CONFLICT(" <> intercalate ", " (pgFmtIdent <$> pkCols) <> ") " <> case x of+ "WITH " <> normalizedBody,+ "INSERT INTO ", fromQi qi, if S.null iCols then " " else "(" <> cols <> ")",+ unwords [+ "SELECT " <> cols <> " FROM",+ "json_populate_recordset", "(null::", fromQi qi, ", " <> selectBody <> ") _",+ -- Only used for PUT+ ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier "" "_") <$> putConditions)) `emptyOnFalse` null putConditions],+ maybe "" (\(oncDo, oncCols) -> (+ "ON CONFLICT(" <> intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of IgnoreDuplicates -> "DO NOTHING" MergeDuplicates ->- "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList pKeys)- ) `emptyOnFalse` null pkCols) onConflct,+ if S.null iCols+ then "DO NOTHING"+ else "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)+ ) `emptyOnFalse` null oncCols) onConflct, ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings] where qi = QualifiedIdentifier schema mainTbl- cols = intercalate ", " $ pgFmtIdent <$> S.toList pKeys- payloadIsEmpty = pjIsEmpty p-requestToQuery schema _ (DbMutate (Update mainTbl p@(PayloadJSON _ pType keys) logicForest returnings)) =- if pjIsEmpty p- then "WITH " <> ignoredBody <> "SELECT ''"+ cols = intercalate ", " $ pgFmtIdent <$> S.toList iCols+requestToQuery schema _ (DbMutate (Update mainTbl uCols logicForest returnings)) =+ if S.null uCols+ then "WITH " <> ignoredBody <> "SELECT null WHERE false" -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax else unwords [+ "WITH " <> normalizedBody, "UPDATE " <> fromQi qi <> " SET " <> cols,- "FROM (SELECT * FROM ",- case pType of- PJObject -> " json_populate_record"- PJArray _ -> " json_populate_recordset", "(null::", fromQi qi, ", $1)) _ ",- ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,- ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings+ "FROM (SELECT * FROM json_populate_recordset", "(null::", fromQi qi, ", " <> selectBody <> ")) _ ",+ ("WHERE " <> intercalate " AND " (pgFmtLogicTree qi <$> logicForest)) `emptyOnFalse` null logicForest,+ ("RETURNING " <> intercalate ", " (pgFmtColumn qi <$> returnings)) `emptyOnFalse` null returnings ] where qi = QualifiedIdentifier schema mainTbl- cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList keys)+ cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols) requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) = unwords [ "WITH " <> ignoredBody,@@ -333,6 +346,25 @@ ignoredBody :: SqlFragment ignoredBody = "ignored_body AS (SELECT $1::text) " +-- |+-- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads+-- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays+-- We do this in SQL to avoid processing the JSON in application code+normalizedBody :: SqlFragment+normalizedBody =+ unwords [+ "pgrst_payload AS (SELECT $1::json AS json_data),",+ "pgrst_body AS (",+ "SELECT",+ "CASE WHEN json_typeof(json_data) = 'array'",+ "THEN json_data",+ "ELSE json_build_array(json_data)",+ "END AS val",+ "FROM pgrst_payload)"]++selectBody :: SqlFragment+selectBody = "(SELECT val FROM pgrst_body)"+ removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl @@ -389,7 +421,7 @@ pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment pgFmtColumn table "*" = fromQi table <> ".*"-pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c+pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp@@ -407,10 +439,10 @@ pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of Op op val -> pgFmtFieldOp op <> " " <> case op of- "like" -> unknownLiteral (T.map star val)- "ilike" -> unknownLiteral (T.map star val)- "is" -> whiteList val- _ -> unknownLiteral val+ "like" -> unknownLiteral (T.map star val)+ "ilike" -> unknownLiteral (T.map star val)+ "is" -> whiteList val+ _ -> unknownLiteral val In vals -> pgFmtField table fld <> " " <> let emptyValForIn = "= any('{}') " in -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"@@ -437,11 +469,9 @@ (find ((==) . toLower $ v) ["null","true","false"]) pgFmtJoinCondition :: JoinCondition -> SqlFragment-pgFmtJoinCondition (JoinCondition (qi, al1, col1) (QualifiedIdentifier schema fTable, al2, col2)) =- pgFmtColumn (fromMaybe qi $ aliasToQi al1) col1 <> " = " <>- pgFmtColumn (fromMaybe (removeSourceCTESchema schema fTable) $ aliasToQi al2) col2- where- aliasToQi al = QualifiedIdentifier "" <$> al+pgFmtJoinCondition (JoinCondition (qi, col1) (QualifiedIdentifier schema fTable, col2)) =+ pgFmtColumn qi col1 <> " = " <>+ pgFmtColumn (removeSourceCTESchema schema fTable) col2 pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")"
src/PostgREST/RangeQuery.hs view
@@ -1,3 +1,7 @@+{-|+Module : PostgREST.RangeQuery+Description : Logic regarding the `Range` header and `limit`, `offset` querystring arguments.+-} module PostgREST.RangeQuery ( rangeParse , rangeRequested@@ -9,19 +13,17 @@ , NonnegRange ) where --import Control.Applicative-import Network.HTTP.Types.Header--import qualified Data.ByteString.Char8 as BS-import Data.Ranged.Boundaries-import Data.Ranged.Ranges+import qualified Data.ByteString.Char8 as BS -import Text.Regex.TDFA ((=~))+import Data.List (lookup)+import Text.Regex.TDFA ((=~)) -import Data.List (lookup)+import Control.Applicative+import Data.Ranged.Boundaries+import Data.Ranged.Ranges+import Network.HTTP.Types.Header -import Protolude+import Protolude type NonnegRange = Range Integer @@ -56,7 +58,7 @@ rangeOffset range = case rangeLower range of BoundaryBelow lower -> lower- _ -> panic "range without lower bound" -- should never happen+ _ -> panic "range without lower bound" -- should never happen rangeGeq :: Integer -> NonnegRange rangeGeq n =
src/PostgREST/Types.hs view
@@ -1,31 +1,67 @@-{-# LANGUAGE DuplicateRecordFields #-}+{-|+Module : PostgREST.Types+Description : PostgREST common types and functions used by the rest of the modules+-}+{-# LANGUAGE DuplicateRecordFields #-}+ module PostgREST.Types where-import Protolude++import qualified Data.Aeson as JSON+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS (c2w)+import qualified Data.ByteString.Lazy as BL+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict as M+import qualified Data.Set as S import qualified GHC.Show-import qualified Data.Aeson as JSON-import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI-import qualified Data.HashMap.Strict as M-import qualified Data.Set as S-import Data.Tree-import PostgREST.RangeQuery (NonnegRange)-import Network.HTTP.Types.Header (hContentType, Header) +import Network.HTTP.Types.Header (Header, hContentType)++import Data.Tree++import PostgREST.RangeQuery (NonnegRange)+import Protolude+ -- | Enumeration of currently supported response content types-data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI- | CTSingularJSON | CTOctetStream- | CTAny | CTOther ByteString deriving Eq+data ContentType = CTApplicationJSON | CTSingularJSON+ | CTTextCSV | CTTextPlain | CTTextHtml+ | CTOpenAPI | CTOctetStream+ | CTAny | CTOther ByteString deriving (Show, Eq) -data ApiRequestError = ActionInappropriate- | InvalidBody ByteString- | InvalidRange- | ParseRequestError Text Text- | UnknownRelation- | NoRelationBetween Text Text- | UnsupportedVerb- | InvalidFilters- deriving (Show, Eq)+-- | Convert from ContentType to a full HTTP Header+toHeader :: ContentType -> Header+toHeader ct = (hContentType, toMime ct <> "; charset=utf-8") +-- | Convert from ContentType to a ByteString representing the mime type+toMime :: ContentType -> ByteString+toMime CTApplicationJSON = "application/json"+toMime CTTextCSV = "text/csv"+toMime CTTextPlain = "text/plain"+toMime CTTextHtml = "text/html"+toMime CTOpenAPI = "application/openapi+json"+toMime CTSingularJSON = "application/vnd.pgrst.object+json"+toMime CTOctetStream = "application/octet-stream"+toMime CTAny = "*/*"+toMime (CTOther ct) = ct++-- | Convert from ByteString to ContentType. Warning: discards MIME parameters+decodeContentType :: BS.ByteString -> ContentType+decodeContentType ct = case BS.takeWhile (/= BS.c2w ';') ct of+ "application/json" -> CTApplicationJSON+ "text/csv" -> CTTextCSV+ "text/plain" -> CTTextPlain+ "text/html" -> CTTextHtml+ "application/openapi+json" -> CTOpenAPI+ "application/vnd.pgrst.object+json" -> CTSingularJSON+ "application/vnd.pgrst.object" -> CTSingularJSON+ "application/octet-stream" -> CTOctetStream+ "*/*" -> CTAny+ ct' -> CTOther ct'++-- | ContentTypes that can get a raw/unwrapped response+rawContentTypes :: [ContentType]+rawContentTypes = [CTOctetStream, CTTextPlain, CTTextHtml]+ data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq instance Show PreferResolution where show MergeDuplicates = "resolution=merge-duplicates"@@ -77,6 +113,34 @@ | name1 == name2 && length args1 > length args2 = GT | otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2) +{-|+ Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it.+ An overloaded function can have a different volatility or even a different return type.+-}+findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription+findProc qi payloadKeys paramsAsSingleObject allProcs =+ case M.lookup (qiName qi) allProcs of+ Nothing -> Nothing+ Just [proc] -> Just proc -- if it's not an overloaded function then immediately get the ProcDescription+ Just procs -> find matches procs -- Handle overloaded functions case+ where+ matches proc =+ if paramsAsSingleObject+ -- if the arg is not of json type let the db give the err+ then length (pdArgs proc) == 1+ else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)++{-|+ Search the procedure parameters by matching them with the specified keys.+ If the key doesn't match a parameter, a parameter with a default type "text" is assumed.+-}+specifiedProcArgs :: S.Set FieldName -> Maybe ProcDescription -> [PgArg]+specifiedProcArgs keys proc =+ let+ args = maybe [] pdArgs proc+ in+ (\k -> fromMaybe (PgArg k "text" True) (find ((==) k . pgaName) args)) <$> S.toList keys+ type Schema = Text type TableName = Text type SqlQuery = Text@@ -89,12 +153,15 @@ , tableInsertable :: Bool } deriving (Show, Ord) +instance Eq Table where+ Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2+ newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord) data Column = Column { colTable :: Table- , colName :: Text+ , colName :: FieldName , colDescription :: Maybe Text , colPosition :: Int32 , colNullable :: Bool@@ -107,6 +174,9 @@ , colFK :: Maybe ForeignKey } deriving (Show, Ord) +instance Eq Column where+ Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2+ -- | A view column that refers to a table column type Synonym = (Column, ViewColumn) type ViewColumn = Column@@ -132,6 +202,10 @@ , otNullOrder :: Maybe OrderNulls } deriving (Show, Eq) +{-|+ Represents a pg identifier with a prepended schema name "schema.table"+ When qiSchema is "", the schema is defined by the pg search_path+-} data QualifiedIdentifier = QualifiedIdentifier { qiSchema :: Schema , qiName :: TableName@@ -149,40 +223,42 @@ TODO merge relColumns and relFColumns to a tuple or Data.Bimap -} data Relation = Relation {- relTable :: Table-, relColumns :: [Column]-, relFTable :: Table-, relFColumns :: [Column]-, relType :: RelationType+ relTable :: Table+, relColumns :: [Column]+, relFTable :: Table+, relFColumns :: [Column]+, relType :: RelationType -- The Link attrs are used when RelationType == Many-, relLinkTable :: Maybe Table-, relLinkCols1 :: Maybe [Column]-, relLinkCols2 :: Maybe [Column]+, relLinkTable :: Maybe Table+, relLinkCols1 :: Maybe [Column]+, relLinkCols2 :: Maybe [Column] } deriving (Show, Eq) --- | Cached attributes of a JSON payload-data PayloadJSON = PayloadJSON {--- | This is the raw ByteString that comes from the request body.--- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding--- had high memory usage, see #1005 for more details- pjRaw :: BL.ByteString-, pjType :: PJType--- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects-, pjKeys :: S.Set Text-} deriving (Show, Eq)+isSelfJoin :: Relation -> Bool+isSelfJoin r = relType r /= Root && relTable r == relFTable r -data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq)+data PayloadJSON =+ -- | Cached attributes of a JSON payload+ ProcessedJSON {+ -- | This is the raw ByteString that comes from the request body.+ -- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding+ -- had high memory usage, see #1005 for more details+ pjRaw :: BL.ByteString+ , pjType :: PJType+ -- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects+ , pjKeys :: S.Set Text+ }|+ RawJSON {+ pjRaw :: BL.ByteString+ } deriving (Show, Eq) --- | e.g. whether it is []/{} or not-pjIsEmpty :: PayloadJSON -> Bool-pjIsEmpty (PayloadJSON _ PJObject keys) = S.size keys == 0-pjIsEmpty (PayloadJSON _ (PJArray l) _) = l == 0+data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq) data Proxy = Proxy {- proxyScheme :: Text-, proxyHost :: Text-, proxyPort :: Integer-, proxyPath :: Text+ proxyScheme :: Text+, proxyHost :: Text+, proxyPort :: Integer+, proxyPath :: Text } deriving (Show, Eq) type Operator = Text@@ -227,8 +303,8 @@ data LogicOperator = And | Or deriving Eq instance Show LogicOperator where- show And = "AND"- show Or = "OR"+ show And = "AND"+ show Or = "OR" {-| Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is: @@ -283,40 +359,49 @@ -- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"] type EmbedPath = [Text] data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq)-data JoinCondition = JoinCondition (QualifiedIdentifier, Maybe Alias, FieldName)- (QualifiedIdentifier, Maybe Alias, FieldName) deriving (Show, Eq)+data JoinCondition = JoinCondition (QualifiedIdentifier, FieldName)+ (QualifiedIdentifier, FieldName) deriving (Show, Eq) -data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], joinConditions::[JoinCondition], order::[OrderTerm], range_::NonnegRange } deriving (Show, Eq)-data MutateQuery = Insert { in_::TableName, insPkCols::[Text], qPayload::PayloadJSON, onConflict:: Maybe PreferResolution, where_::[LogicTree], returning::[FieldName] }- | Delete { in_::TableName, where_::[LogicTree], returning::[FieldName] }- | Update { in_::TableName, qPayload::PayloadJSON, where_::[LogicTree], returning::[FieldName] } deriving (Show, Eq)-type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail, Depth))+data ReadQuery = Select {+ select :: [SelectItem]+ , from :: TableName+-- | A table alias is used in case of self joins+ , fromAlias :: Maybe Alias+-- | Only used for Many to Many joins. Parent and Child joins use explicit joins.+ , implicitJoins :: [TableName]+ , where_ :: [LogicTree]+ , joinConditions :: [JoinCondition]+ , order :: [OrderTerm]+ , range_ :: NonnegRange+} deriving (Show, Eq)++data MutateQuery =+ Insert {+ in_ :: TableName+ , insCols :: S.Set FieldName+ , onConflict :: Maybe (PreferResolution, [FieldName])+ , where_ :: [LogicTree]+ , returning :: [FieldName]+ }|+ Update {+ in_ :: TableName+ , updCols :: S.Set FieldName+ , where_ :: [LogicTree]+ , returning :: [FieldName]+ }|+ Delete {+ in_ :: TableName+ , where_ :: [LogicTree]+ , returning :: [FieldName]+ } deriving (Show, Eq)++data DbRequest = DbRead ReadRequest | DbMutate MutateRequest type ReadRequest = Tree ReadNode+type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail, Depth)) -- Depth of the ReadRequest tree type Depth = Integer type MutateRequest = MutateQuery-data DbRequest = DbRead ReadRequest | DbMutate MutateRequest -instance Eq Table where- Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2--instance Eq Column where- Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2---- | Convert from ContentType to a full HTTP Header-toHeader :: ContentType -> Header-toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")---- | Convert from ContentType to a ByteString representing the mime type-toMime :: ContentType -> ByteString-toMime CTApplicationJSON = "application/json"-toMime CTTextCSV = "text/csv"-toMime CTOpenAPI = "application/openapi+json"-toMime CTSingularJSON = "application/vnd.pgrst.object+json"-toMime CTOctetStream = "application/octet-stream"-toMime CTAny = "*/*"-toMime (CTOther ct) = ct- data PgVersion = PgVersion { pgvNum :: Int32 , pgvName :: Text@@ -327,8 +412,11 @@ -- | Tells the minimum PostgreSQL version required by this version of PostgREST minimumPgVersion :: PgVersion-minimumPgVersion = PgVersion 90400 "9.4"+minimumPgVersion = pgVersion94 +pgVersion94 :: PgVersion+pgVersion94 = PgVersion 90400 "9.4"+ pgVersion95 :: PgVersion pgVersion95 = PgVersion 90500 "9.5" @@ -338,6 +426,9 @@ pgVersion100 :: PgVersion pgVersion100 = PgVersion 100000 "10" +pgVersion112 :: PgVersion+pgVersion112 = PgVersion 110002 "11.2"+ sourceCTEName :: SqlFragment sourceCTEName = "pg_source" @@ -345,3 +436,12 @@ type JSPath = [JSPathExp] -- | jspath expression, e.g. .property, .property[0] or ."property-dash" data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show)++++-- | Current database connection status data ConnectionStatus+data ConnectionStatus+ = NotConnected+ | Connected PgVersion+ | FatalConnectionError Text+ deriving (Eq, Show)
test/Feature/AndOrParamsSpec.hs view
@@ -1,13 +1,14 @@ module Feature.AndOrParamsSpec where++import Network.Wai (Application)++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types -import Network.Wai (Application)-+import Protolude hiding (get) import SpecHelper-import Protolude hiding (get) spec :: SpecWith Application
test/Feature/AsymmetricJwtSpec.hs view
@@ -1,14 +1,14 @@ module Feature.AsymmetricJwtSpec where -- {{{ Imports+import Network.Wai (Application)++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai-import Network.HTTP.Types -import SpecHelper-import Network.Wai (Application)- import Protolude+import SpecHelper -- }}} spec :: SpecWith Application
test/Feature/AudienceJwtSecretSpec.hs view
@@ -1,14 +1,14 @@ module Feature.AudienceJwtSecretSpec where -- {{{ Imports+import Network.Wai (Application)++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai-import Network.HTTP.Types +import Protolude hiding (get) import SpecHelper-import Network.Wai (Application)--import Protolude hiding (get) -- }}} spec :: SpecWith Application@@ -44,4 +44,4 @@ `shouldRespondWith` 200 it "requests without JWT token should work" $- get "/has_count_column" `shouldRespondWith` 200 + get "/has_count_column" `shouldRespondWith` 200
test/Feature/AuthSpec.hs view
@@ -1,26 +1,36 @@ module Feature.AuthSpec where -import Text.Heredoc+import Network.Wai (Application)++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types+import Text.Heredoc +import PostgREST.Types (PgVersion, pgVersion112)+import Protolude hiding (get) import SpecHelper-import Network.Wai (Application) -import Protolude hiding (get)--spec :: SpecWith Application-spec = describe "authorization" $ do+spec :: PgVersion -> SpecWith Application+spec actualPgVersion = describe "authorization" $ do let single = ("Accept","application/vnd.pgrst.object+json") it "denies access to tables that anonymous does not own" $- get "/authors_only" `shouldRespondWith` [json| {+ get "/authors_only" `shouldRespondWith` (+ if actualPgVersion >= pgVersion112 then+ [json| { "hint":null, "details":null, "code":"42501",+ "message":"permission denied for table authors_only"} |]+ else+ [json| {+ "hint":null,+ "details":null,+ "code":"42501", "message":"permission denied for relation authors_only"} |]+ ) { matchStatus = 401 , matchHeaders = ["WWW-Authenticate" <:> "Bearer"] }@@ -28,11 +38,20 @@ it "denies access to tables that postgrest_test_author does not own" $ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" in request methodGet "/private_table" [auth] ""- `shouldRespondWith` [json| {+ `shouldRespondWith` (+ if actualPgVersion >= pgVersion112 then+ [json| { "hint":null, "details":null, "code":"42501",+ "message":"permission denied for table private_table"} |]+ else+ [json| {+ "hint":null,+ "details":null,+ "code":"42501", "message":"permission denied for relation private_table"} |]+ ) { matchStatus = 403 , matchHeaders = [] }
test/Feature/BinaryJwtSecretSpec.hs view
@@ -1,14 +1,14 @@ module Feature.BinaryJwtSecretSpec where -- {{{ Imports+import Network.Wai (Application)++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai-import Network.HTTP.Types -import SpecHelper-import Network.Wai (Application)- import Protolude+import SpecHelper -- }}} spec :: SpecWith Application
test/Feature/ConcurrentSpec.hs view
@@ -1,20 +1,21 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Feature.ConcurrentSpec where -import Control.Monad (void)-import Control.Monad.Base+import Control.Concurrent.Async (mapConcurrently)+import Control.Monad (void)+import Network.Wai (Application) +import Control.Monad.Base import Control.Monad.Trans.Control-import Control.Concurrent.Async (mapConcurrently) +import Network.Wai.Test (Session) import Test.Hspec-import Test.Hspec.Wai.Internal import Test.Hspec.Wai+import Test.Hspec.Wai.Internal import Test.Hspec.Wai.JSON-import Network.Wai.Test (Session)--import Network.Wai (Application) import Protolude hiding (get)
test/Feature/CorsSpec.hs view
@@ -1,17 +1,17 @@ module Feature.CorsSpec where -- {{{ Imports-import Test.Hspec-import Test.Hspec.Wai-import Network.Wai.Test (SResponse(simpleHeaders, simpleBody)) import qualified Data.ByteString.Lazy as BL -import SpecHelper+import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleBody, simpleHeaders)) import Network.HTTP.Types-import Network.Wai (Application)+import Test.Hspec+import Test.Hspec.Wai import Protolude+import SpecHelper -- }}} spec :: SpecWith Application
test/Feature/DeleteSpec.hs view
@@ -1,11 +1,11 @@ module Feature.DeleteSpec where +import Network.Wai (Application)++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Text.Heredoc--import Network.HTTP.Types-import Network.Wai (Application) import Protolude hiding (get)
test/Feature/ExtraSearchPathSpec.hs view
@@ -1,14 +1,13 @@ module Feature.ExtraSearchPathSpec where +import Network.HTTP.Types+import Network.Wai (Application) import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types -import SpecHelper-import Network.Wai (Application)- import Protolude+import SpecHelper spec :: SpecWith Application spec = describe "extra search path" $ do
test/Feature/InsertSpec.hs view
@@ -1,28 +1,27 @@ module Feature.InsertSpec where -import Test.Hspec hiding (pendingWith)-import Test.Hspec.Wai-import Test.Hspec.Wai.JSON-import Test.Hspec.Wai.Matcher (bodyEquals)-import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus))+import qualified Data.Aeson as JSON -import SpecHelper+import Control.Monad (replicateM_, void)+import Data.List (lookup)+import Data.Maybe (fromJust)+import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus))+import Test.Hspec hiding (pendingWith)+import Test.Hspec.Wai.Matcher (bodyEquals)+import TestTypes (CompoundPK (..), IncPK (..)) -import qualified Data.Aeson as JSON-import Data.List (lookup)-import Data.Maybe (fromJust)-import Text.Heredoc-import Network.HTTP.Types.Header import Network.HTTP.Types-import Control.Monad (replicateM_, void)--import TestTypes(IncPK(..), CompoundPK(..))-import Network.Wai (Application)+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON+import Text.Heredoc -import Protolude hiding (get)+import PostgREST.Types (PgVersion, pgVersion112)+import Protolude hiding (get)+import SpecHelper -spec :: SpecWith Application-spec = do+spec :: PgVersion -> SpecWith Application+spec actualPgVersion = do describe "Posting new record" $ do context "disparate json types" $ do it "accepts disparate json types" $ do@@ -51,9 +50,22 @@ context "non uniform json array" $ do it "rejects json array that isn't exclusivily composed of objects" $- post "/articles" [json| [{"id": 100, "body": "xxxxx"}, 123, "xxxx", {"id": 111, "body": "xxxx"}] |] `shouldRespondWith` 400+ post "/articles"+ [json| [{"id": 100, "body": "xxxxx"}, 123, "xxxx", {"id": 111, "body": "xxxx"}] |]+ `shouldRespondWith`+ [json| {"message":"All object keys must match"} |]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ }+ it "rejects json array that has objects with different keys" $- post "/articles" [json| [{"id": 100, "body": "xxxxx"}, {"id": 111, "body": "xxxx", "owner": "me"}] |] `shouldRespondWith` 400+ post "/articles"+ [json| [{"id": 100, "body": "xxxxx"}, {"id": 111, "body": "xxxx", "owner": "me"}] |]+ `shouldRespondWith`+ [json| {"message":"All object keys must match"} |]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ } context "requesting full representation" $ do it "includes related data after insert" $@@ -103,11 +115,13 @@ incNullableStr record `shouldBe` Nothing context "into a table with simple pk" $- it "fails with 400 and error" $ do- p <- post "/simple_pk" [json| { "extra":"foo"} |]- liftIO $ do- simpleStatus p `shouldBe` badRequest400- isErrorFormat (simpleBody p) `shouldBe` True+ it "fails with 400 and error" $+ post "/simple_pk" [json| { "extra":"foo"} |]+ `shouldRespondWith`+ [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" violates not-null constraint"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ } context "into a table with no pk" $ do it "succeeds with 201 and a link including all fields" $ do@@ -181,11 +195,13 @@ lookup hLocation (simpleHeaders p) `shouldBe` Nothing context "with invalid json payload" $- it "fails with 400 and error" $ do- p <- post "/simple_pk" "}{ x = 2"- liftIO $ do- simpleStatus p `shouldBe` badRequest400- isErrorFormat (simpleBody p) `shouldBe` True+ it "fails with 400 and error" $+ post "/simple_pk" "}{ x = 2"+ `shouldRespondWith`+ [json|{"message":"Error in $: Failed reading: not a valid json value"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ } context "with valid json payload" $ it "succeeds and returns 201 created" $@@ -193,7 +209,12 @@ context "attempting to insert a row with the same primary key" $ it "fails returning a 409 Conflict" $- post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] `shouldRespondWith` 409+ post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |]+ `shouldRespondWith`+ [json|{"hint":null,"details":"Key (k)=(k1) already exists.","code":"23505","message":"duplicate key value violates unique constraint \"contacts_pkey\""}|]+ { matchStatus = 409+ , matchHeaders = [matchContentTypeJson]+ } context "attempting to insert a row with conflicting unique constraint" $ it "fails returning a 409 Conflict" $@@ -222,12 +243,23 @@ , matchHeaders = ["Location" <:> location] } - context "empty object" $- it "successfully populates table with all-default columns" $+ context "empty objects" $ do+ it "successfully inserts a row with all-default columns" $ do post "/items" "{}" `shouldRespondWith` "" { matchStatus = 201 , matchHeaders = [] }+ post "/items" "[{}]" `shouldRespondWith` ""+ { matchStatus = 201+ , matchHeaders = []+ }++ it "successfully inserts two rows with all-default columns" $+ post "/items" "[{}, {}]" `shouldRespondWith` ""+ { matchStatus = 201+ , matchHeaders = []+ }+ context "table with limited privileges" $ do it "succeeds if correct select is applied" $ request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")]@@ -237,20 +269,75 @@ } it "fails if more columns are selected" $ request methodPost "/limited_article_stars?select=article_id,user_id,created_at" [("Prefer", "return=representation")]- [json| {"article_id": 2, "user_id": 2} |] `shouldRespondWith`- [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]+ [json| {"article_id": 2, "user_id": 2} |] `shouldRespondWith` (+ if actualPgVersion >= pgVersion112 then+ [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for view limited_article_stars"}|]+ else+ [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]+ ) { matchStatus = 401 , matchHeaders = [] } it "fails if select is not specified" $ request methodPost "/limited_article_stars" [("Prefer", "return=representation")]- [json| {"article_id": 3, "user_id": 1} |] `shouldRespondWith` [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]+ [json| {"article_id": 3, "user_id": 1} |] `shouldRespondWith` (+ if actualPgVersion >= pgVersion112 then+ [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for view limited_article_stars"}|]+ else+ [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]+ ) { matchStatus = 401 , matchHeaders = [] } - describe "CSV insert" $ do+ context "POST with ?columns parameter" $ do+ it "ignores json keys not included in ?columns" $ do+ request methodPost "/articles?columns=id,body" [("Prefer", "return=representation")]+ [json| {"id": 200, "body": "xxx", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith`+ [json|[{"id": 200, "body": "xxx", "owner": "postgrest_test_anonymous"}]|]+ { matchStatus = 201+ , matchHeaders = [] }+ request methodPost "/articles?columns=id,body&select=id,body" [("Prefer", "return=representation")]+ [json| [+ {"id": 201, "body": "yyy", "smth": "here", "other": "stuff", "fake_id": 13},+ {"id": 202, "body": "zzz", "garbage": "%%$&", "kkk": "jjj"},+ {"id": 203, "body": "aaa", "hey": "ho"} ]|] `shouldRespondWith`+ [json|[+ {"id": 201, "body": "yyy"},+ {"id": 202, "body": "zzz"},+ {"id": 203, "body": "aaa"} ]|]+ { matchStatus = 201+ , matchHeaders = [] } + -- TODO parse columns error message needs to be improved+ it "disallows blank ?columns" $+ post "/articles?columns="+ [json|[+ {"id": 204, "body": "yyy"},+ {"id": 205, "body": "zzz"}]|]+ `shouldRespondWith`+ [json| {"details":"unexpected end of input expecting field name (* or [a..z0..9_])","message":"\"failed to parse columns parameter ()\" (line 1, column 1)"} |]+ { matchStatus = 400+ , matchHeaders = []+ }++ it "disallows array elements that are not json objects" $+ post "/articles?columns=id,body"+ [json|[+ {"id": 204, "body": "yyy"},+ 333,+ "asdf",+ {"id": 205, "body": "zzz"}]|] `shouldRespondWith`+ [json|{+ "code": "22023",+ "details": null,+ "hint": null,+ "message": "argument of json_populate_recordset must be an array of objects"}|]+ { matchStatus = 400+ , matchHeaders = []+ }++ describe "CSV insert" $ do context "disparate csv types" $ it "succeeds with multipart response" $ do pendingWith "Decide on what to do with CSV insert"@@ -297,11 +384,13 @@ } context "with wrong number of columns" $- it "fails for too few" $ do- p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"- liftIO $ do- simpleStatus p `shouldBe` badRequest400- isErrorFormat (simpleBody p) `shouldBe` True+ it "fails for too few" $+ request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"+ `shouldRespondWith`+ [json|{"message":"All lines must have same number of fields"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ } context "with unicode values" $ it "succeeds and returns usable location header" $ do@@ -317,22 +406,20 @@ r <- get location liftIO $ simpleBody r `shouldBe` "["<>payload<>"]" - describe "Patching record" $ do- context "to unknown uri" $- it "gives a 404" $+ it "indicates no table found by returning 404" $ request methodPatch "/fake" [] [json| { "real": false } |] `shouldRespondWith` 404 context "on an empty table" $- it "indicates no records found to update" $+ it "indicates no records found to update by returning 404" $ request methodPatch "/empty_table" [] [json| { "extra":20 } |] `shouldRespondWith` ""- { matchStatus = 204,- matchHeaders = ["Content-Range" <:> "*/*"]+ { matchStatus = 404,+ matchHeaders = [] } context "in a nonempty table" $ do@@ -359,10 +446,15 @@ [("Prefer", "return=representation")] [json| { "id":999999 } |] `shouldRespondWith` "[]" {- matchStatus = 200,- matchHeaders = ["Content-Range" <:> "*/*"]+ matchStatus = 404,+ matchHeaders = [] } + it "gives a 404 when no rows updated" $+ request methodPatch "/items?id=eq.99999999" []+ [json| { "id": 42 } |]+ `shouldRespondWith` 404+ it "returns updated object as array when return=rep" $ request methodPatch "/items?id=eq.2" [("Prefer", "return=representation")] [json| { "id":2 } |]@@ -390,16 +482,27 @@ [json| [{ a: "keepme", b: null }] |] { matchHeaders = [matchContentTypeJson] } - it "can update based on a computed column" $- request methodPatch- "/items?always_true=eq.false"- [("Prefer", "return=representation")]- [json| { id: 100 } |]- `shouldRespondWith` "[]"- { matchStatus = 200,- matchHeaders = ["Content-Range" <:> "*/*"]- }+ context "filtering by a computed column" $ do+ it "is successful" $+ request methodPatch+ "/items?is_first=eq.true"+ [("Prefer", "return=representation")]+ [json| { id: 100 } |]+ `shouldRespondWith` [json| [{ id: 100 }] |]+ { matchStatus = 200,+ matchHeaders = [matchContentTypeJson, "Content-Range" <:> "0-0/*"]+ } + it "indicates no records updated by returning 404" $+ request methodPatch+ "/items?always_true=eq.false"+ [("Prefer", "return=representation")]+ [json| { id: 100 } |]+ `shouldRespondWith` "[]"+ { matchStatus = 404,+ matchHeaders = []+ }+ it "can provide a representation" $ do _ <- post "/items" [json| { id: 1 } |]@@ -427,21 +530,21 @@ matchHeaders = ["Content-Range" <:> "*/*"] } - get "/items" `shouldRespondWith`- [json|[{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}]|]- { matchHeaders = [matchContentTypeJson] }+ request methodPatch "/items" [] [json| [{}] |]+ `shouldRespondWith` ""+ {+ matchStatus = 204,+ matchHeaders = ["Content-Range" <:> "*/*"]+ } - it "makes no updates and and returns 200, when patching with an empty json object and return=rep" $ do+ it "makes no updates and and returns 200, when patching with an empty json object and return=rep" $ request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |] `shouldRespondWith` "[]" { matchStatus = 200, matchHeaders = ["Content-Range" <:> "*/*"] }- get "/items" `shouldRespondWith`- [json| [{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}] |]- { matchHeaders = [matchContentTypeJson] }- + context "with unicode values" $ it "succeeds and returns values intact" $ do void $ request methodPost "/no_pk" []@@ -452,6 +555,18 @@ liftIO $ do simpleBody p `shouldBe` "["<>payload<>"]" simpleStatus p `shouldBe` ok200++ context "PATCH with ?columns parameter" $ do+ it "ignores json keys not included in ?columns" $+ request methodPatch "/articles?id=eq.200&columns=body" [("Prefer", "return=representation")]+ [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith`+ [json|[{"id": 200, "body": "Some real content", "owner": "postgrest_test_anonymous"}]|]+ { matchStatus = 200+ , matchHeaders = [] }++ it "ignores json keys and gives 404 if no record updated" $+ request methodPatch "/articles?id=eq.2001&columns=body" [("Prefer", "return=representation")]+ [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith` 404 describe "Row level permission" $ it "set user_id when inserting rows" $ do
test/Feature/JsonOperatorSpec.hs view
@@ -1,17 +1,18 @@ module Feature.JsonOperatorSpec where +import Network.Wai (Application)++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types +import PostgREST.Types (PgVersion, pgVersion112)+import Protolude hiding (get) import SpecHelper-import Network.Wai (Application) -import Protolude hiding (get)--spec :: SpecWith Application-spec = describe "json and jsonb operators" $ do+spec :: PgVersion -> SpecWith Application+spec actualPgVersion = describe "json and jsonb operators" $ do context "Shaping response with select parameter" $ do it "obtains a json subfield one level with casting" $ get "/complex_items?id=eq.1&select=settings->>foo::json" `shouldRespondWith`@@ -52,14 +53,28 @@ -- this works fine for /rpc/unexistent requests, but for this case a 500 seems more appropriate it "fails when a double arrow ->> is followed with a single arrow ->" $ do get "/json_arr?select=data->>c->1"- `shouldRespondWith` [json|+ `shouldRespondWith` (+ if actualPgVersion >= pgVersion112 then+ [json|+ {"hint":"No operator matches the given name and argument types. You might need to add explicit type casts.",+ "details":null,"code":"42883","message":"operator does not exist: text -> integer"} |]+ else+ [json| {"hint":"No operator matches the given name and argument type(s). You might need to add explicit type casts.", "details":null,"code":"42883","message":"operator does not exist: text -> integer"} |]+ ) { matchStatus = 404 , matchHeaders = [] } get "/json_arr?select=data->>c->b"- `shouldRespondWith` [json|+ `shouldRespondWith` (+ if actualPgVersion >= pgVersion112 then+ [json|+ {"hint":"No operator matches the given name and argument types. You might need to add explicit type casts.",+ "details":null,"code":"42883","message":"operator does not exist: text -> unknown"} |]+ else+ [json| {"hint":"No operator matches the given name and argument type(s). You might need to add explicit type casts.", "details":null,"code":"42883","message":"operator does not exist: text -> unknown"} |]+ ) { matchStatus = 404 , matchHeaders = [] } context "with array index" $ do
test/Feature/NoJwtSpec.hs view
@@ -1,14 +1,16 @@ module Feature.NoJwtSpec where -- {{{ Imports-import Test.Hspec-import Test.Hspec.Wai-import Network.HTTP.Types -import SpecHelper import Network.Wai (Application) +import Network.HTTP.Types+import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON+ import Protolude+import SpecHelper -- }}} spec :: SpecWith Application@@ -18,7 +20,11 @@ it "responds with error on attempted auth" $ do let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA" request methodGet "/authors_only" [auth] ""- `shouldRespondWith` 500+ `shouldRespondWith`+ [json|{"message":"Server lacks JWT secret"}|]+ { matchStatus = 500+ , matchHeaders = [ matchContentTypeJson ]+ } it "behaves normally when user does not attempt auth" $ request methodGet "/items" [] ""
test/Feature/NonexistentSchemaSpec.hs view
@@ -1,9 +1,11 @@ module Feature.NonexistentSchemaSpec where import Network.Wai (Application)-import Protolude hiding (get)+ import Test.Hspec import Test.Hspec.Wai++import Protolude hiding (get) spec :: SpecWith Application spec =
test/Feature/PgVersion95Spec.hs view
@@ -1,13 +1,13 @@ module Feature.PgVersion95Spec where +import Network.Wai (Application)+ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON +import Protolude hiding (get) import SpecHelper-import Network.Wai (Application)--import Protolude hiding (get) spec :: SpecWith Application spec = describe "features supported on PostgreSQL 9.5" $
test/Feature/PgVersion96Spec.hs view
@@ -1,14 +1,14 @@ module Feature.PgVersion96Spec where +import Network.Wai (Application)+ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON +import Protolude hiding (get) import SpecHelper-import Network.Wai (Application) -import Protolude hiding (get)- spec :: SpecWith Application spec = describe "features supported on PostgreSQL 9.6" $ do@@ -34,10 +34,30 @@ "X-Test-2" <:> "key1=val1"]} it "fails when setting headers with wrong json structure" $ do- get "/rpc/bad_guc_headers_1" `shouldRespondWith` 500- get "/rpc/bad_guc_headers_2" `shouldRespondWith` 500- get "/rpc/bad_guc_headers_3" `shouldRespondWith` 500- post "/rpc/bad_guc_headers_1" [json|{}|] `shouldRespondWith` 500+ get "/rpc/bad_guc_headers_1"+ `shouldRespondWith`+ [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]+ { matchStatus = 500+ , matchHeaders = [ matchContentTypeJson ]+ }+ get "/rpc/bad_guc_headers_2"+ `shouldRespondWith`+ [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]+ { matchStatus = 500+ , matchHeaders = [ matchContentTypeJson ]+ }+ get "/rpc/bad_guc_headers_3"+ `shouldRespondWith`+ [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]+ { matchStatus = 500+ , matchHeaders = [ matchContentTypeJson ]+ }+ post "/rpc/bad_guc_headers_1" [json|{}|]+ `shouldRespondWith`+ [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]+ { matchStatus = 500+ , matchHeaders = [ matchContentTypeJson ]+ } it "can set the same http header twice" $ get "/rpc/set_cookie_twice"
test/Feature/ProxySpec.hs view
@@ -1,12 +1,10 @@ module Feature.ProxySpec where -import Test.Hspec--import SpecHelper- import Network.Wai (Application)+import Test.Hspec hiding (pendingWith) import Protolude+import SpecHelper spec :: SpecWith Application spec =
test/Feature/QueryLimitedSpec.hs view
@@ -1,14 +1,15 @@ module Feature.QueryLimitedSpec where +import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleHeaders, simpleStatus))++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types-import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus))-import SpecHelper-import Network.Wai (Application) -import Protolude hiding (get)+import Protolude hiding (get)+import SpecHelper spec :: SpecWith Application spec =
test/Feature/QuerySpec.hs view
@@ -1,16 +1,17 @@ module Feature.QuerySpec where +import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleHeaders))++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types-import Network.Wai.Test (SResponse(simpleHeaders)) -import SpecHelper import Text.Heredoc-import Network.Wai (Application) -import Protolude hiding (get)+import Protolude hiding (get)+import SpecHelper spec :: SpecWith Application spec = do@@ -181,7 +182,6 @@ { matchHeaders = [matchContentTypeJson] } describe "Shaping response with select parameter" $ do- it "selectStar works in absense of parameter" $ get "/complex_items?id=eq.3" `shouldRespondWith` [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|]@@ -333,6 +333,9 @@ it "can detect fk relations through views to tables in the public schema" $ get "/consumers_view?select=*,orders_view(*)" `shouldRespondWith` 200 + it "can detect fk relations through materialized views to tables in the public schema" $+ get "/materialized_projects?select=*,users(*)" `shouldRespondWith` 200+ it "can request parent without specifying primary key" $ get "/articleStars?select=createdAt,article(owner),user(name)&limit=1" `shouldRespondWith` [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"owner": "postgrest_test_authenticator"},"user":{"name": "Angela Martin"}}]|]@@ -433,22 +436,33 @@ {"number_of_projects":2,"client":{"name":"Apple"}}] |] { matchHeaders = [matchContentTypeJson] } + it "can embed a view that has a subselect containing a select in a where" $+ get "/authors_w_entities?select=name,entities,books(title)&id=eq.1" `shouldRespondWith`+ [json| [{"name":"George Orwell","entities":[3, 4],"books":[{"title":"1984"}]}] |]+ { matchHeaders = [matchContentTypeJson] }+ describe "path fixed" $ do it "works when requesting children 2 levels" $- get "/clients?id=eq.1&select=id,projects:projects.client_id(id,tasks(id))" `shouldRespondWith`+ get "/clients?id=eq.1&select=id,projects:projects%2Bclient_id(id,tasks(id))" `shouldRespondWith` [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|] { matchHeaders = [matchContentTypeJson] } it "works with parent relation" $- get "/message?select=id,body,sender:person.sender(name),recipient:person.recipient(name)&id=lt.4" `shouldRespondWith`+ get "/message?select=id,body,sender:person%2Bsender(name),recipient:person%2Brecipient(name)&id=lt.4" `shouldRespondWith` [json| [{"id":1,"body":"Hello Jane","sender":{"name":"John"},"recipient":{"name":"Jane"}}, {"id":2,"body":"Hi John","sender":{"name":"Jane"},"recipient":{"name":"John"}}, {"id":3,"body":"How are you doing?","sender":{"name":"John"},"recipient":{"name":"Jane"}}] |] { matchHeaders = [matchContentTypeJson] } + it "fails with an unknown relation" $+ get "/message?select=id,sender:person.space(name)&id=lt.4" `shouldRespondWith`+ [json|{"message":"Could not find foreign keys between these entities, No relation found between message and person"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson] }+ it "works with a parent view relation" $- get "/message?select=id,body,sender:person_detail.sender(name,sent),recipient:person_detail.recipient(name,received)&id=lt.4" `shouldRespondWith`+ get "/message?select=id,body,sender:person_detail%2Bsender(name,sent),recipient:person_detail%2Brecipient(name,received)&id=lt.4" `shouldRespondWith` [json| [{"id":1,"body":"Hello Jane","sender":{"name":"John","sent":2},"recipient":{"name":"Jane","received":2}}, {"id":2,"body":"Hi John","sender":{"name":"Jane","sent":1},"recipient":{"name":"John","received":1}},@@ -456,10 +470,19 @@ { matchHeaders = [matchContentTypeJson] } it "works with many<->many relation" $- get "/tasks?select=id,users:users.users_tasks(id)" `shouldRespondWith`+ get "/tasks?select=id,users:users%2Busers_tasks(id)" `shouldRespondWith` [json|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|] { matchHeaders = [matchContentTypeJson] } + describe "old dot '.' symbol, deprecated" $+ it "still works" $ do+ get "/clients?id=eq.1&select=id,projects:projects.client_id(id,tasks(id))" `shouldRespondWith`+ [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|]+ { matchHeaders = [matchContentTypeJson] }+ get "/tasks?select=id,users:users.users_tasks(id)" `shouldRespondWith`+ [json|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|]+ { matchHeaders = [matchContentTypeJson] }+ describe "aliased embeds" $ do it "works with child relation" $ get "/space?select=id,zones:zone(id,name),stores:zone(id,name)&zones.zone_type_id=eq.2&stores.zone_type_id=eq.3" `shouldRespondWith`@@ -528,7 +551,7 @@ { matchHeaders = [matchContentTypeJson] } it "embeds childs recursively" $- get "/family_tree?id=eq.1&select=id,name, childs:family_tree.parent(id,name,childs:family_tree.parent(id,name))" `shouldRespondWith`+ get "/family_tree?id=eq.1&select=id,name, childs:family_tree%2Bparent(id,name,childs:family_tree%2Bparent(id,name))" `shouldRespondWith` [json|[{ "id": "1", "name": "Parental Unit", "childs": [ { "id": "2", "name": "Kid One", "childs": [ { "id": "4", "name": "Grandkid One" } ] },@@ -537,7 +560,7 @@ }]|] { matchHeaders = [matchContentTypeJson] } it "embeds parent and then embeds childs" $- get "/family_tree?id=eq.2&select=id,name,parent(id,name,childs:family_tree.parent(id,name))" `shouldRespondWith`+ get "/family_tree?id=eq.2&select=id,name,parent(id,name,childs:family_tree%2Bparent(id,name))" `shouldRespondWith` [json|[{ "id": "2", "name": "Kid One", "parent": { "id": "1", "name": "Parental Unit", "childs": [ { "id": "2", "name": "Kid One" }, { "id": "3", "name": "Kid Two"} ]@@ -560,7 +583,7 @@ }]|] { matchHeaders = [matchContentTypeJson] } it "embeds childs" $ do- get "/organizations?select=id,name,refereeds:organizations.referee(id,name)&id=eq.1" `shouldRespondWith`+ get "/organizations?select=id,name,refereeds:organizations%2Breferee(id,name)&id=eq.1" `shouldRespondWith` [json|[{ "id": 1, "name": "Referee Org", "refereeds": [@@ -574,7 +597,7 @@ } ] }]|] { matchHeaders = [matchContentTypeJson] }- get "/organizations?select=id,name,auditees:organizations.auditor(id,name)&id=eq.2" `shouldRespondWith`+ get "/organizations?select=id,name,auditees:organizations%2Bauditor(id,name)&id=eq.2" `shouldRespondWith` [json|[{ "id": 2, "name": "Auditor Org", "auditees": [@@ -589,6 +612,42 @@ ] }]|] { matchHeaders = [matchContentTypeJson] } + it "embeds other relations(manager) besides the self reference" $ do+ get "/organizations?select=name,manager(name),referee(name,manager(name),auditor(name,manager(name))),auditor(name,manager(name),referee(name,manager(name)))&id=eq.5" `shouldRespondWith`+ [json|[{+ "name":"Cyberdyne",+ "manager":{"name":"Cyberdyne Manager"},+ "referee":{+ "name":"Acme",+ "manager":{"name":"Acme Manager"},+ "auditor":{+ "name":"Auditor Org",+ "manager":{"name":"Auditor Manager"}}},+ "auditor":{+ "name":"Umbrella",+ "manager":{"name":"Umbrella Manager"},+ "referee":{+ "name":"Referee Org",+ "manager":{"name":"Referee Manager"}}}+ }]|] { matchHeaders = [matchContentTypeJson] }++ get "/organizations?select=name,manager(name),auditees:organizations%2Bauditor(name,manager(name),refereeds:organizations%2Breferee(name,manager(name)))&id=eq.2" `shouldRespondWith`+ [json|[{+ "name":"Auditor Org",+ "manager":{"name":"Auditor Manager"},+ "auditees":[+ {"name":"Acme",+ "manager":{"name":"Acme Manager"},+ "refereeds":[+ {"name":"Cyberdyne",+ "manager":{"name":"Cyberdyne Manager"}},+ {"name":"Oscorp",+ "manager":{"name":"Oscorp Manager"}}]},+ {"name":"Umbrella",+ "manager":{"name":"Umbrella Manager"},+ "refereeds":[]}]+ }]|] { matchHeaders = [matchContentTypeJson] }+ describe "ordering response" $ do it "by a column asc" $ get "/items?id=lte.2&order=id.asc"@@ -737,7 +796,11 @@ it "should respond an unknown accept type with 415" $ request methodGet "/simple_pk" (acceptHdrs "text/unknowntype") ""- `shouldRespondWith` 415+ `shouldRespondWith`+ [json|{"message":"None of these Content-Types are available: text/unknowntype"}|]+ { matchStatus = 415+ , matchHeaders = [matchContentTypeJson]+ } it "should respond correctly to */* in accept header" $ request methodGet "/simple_pk"@@ -793,7 +856,6 @@ respHeaders `shouldSatisfy` matchHeader "Content-Location" "/simple_pk" - describe "weird requests" $ do it "can query as normal" $ do get "/Escap3e;" `shouldRespondWith`@@ -833,50 +895,39 @@ [json|[{":arr->ow::cast":" arrow-1 ","(inside,parens)":" parens-1 ","a.dotted.column":" dotted-1 "," col w space ":" space-1"}]|] { matchHeaders = [matchContentTypeJson] } - describe "binary output" $ do- context "on GET" $ do- it "can query if a single column is selected" $- request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"- { matchStatus = 200- , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]- }-- it "fails if a single column is not selected" $ do- request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` 406- request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` 406- request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` 406-- it "concatenates results if more than one row is returned" $- request methodGet "/images_base64?select=img&name=in.(A.png,B.png)" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="- { matchStatus = 200- , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]- }+ context "binary output" $ do+ it "can query if a single column is selected" $+ request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+ } - context "on RPC" $ do- context "Proc that returns scalar" $- it "can query without selecting column" $- request methodPost "/rpc/ret_base64_bin" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"- { matchStatus = 200- , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]- }+ it "can get raw output with Accept: text/plain" $+ request methodGet "/projects?select=name&id=eq.1" (acceptHdrs "text/plain") ""+ `shouldRespondWith` "Windows 7"+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]+ } - context "Proc that returns rows" $ do- it "can query if a single column is selected" $- request methodPost "/rpc/ret_rows_with_base64_bin?select=img" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="- { matchStatus = 200- , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]- }+ it "fails if a single column is not selected" $ do+ request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith`+ [json| {"message":"application/octet-stream requested but a single column was not selected"} |]+ { matchStatus = 406+ , matchHeaders = [matchContentTypeJson]+ }+ request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` 406+ request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` 406 - it "fails if a single column is not selected" $- request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` 406+ it "concatenates results if more than one row is returned" $+ request methodGet "/images_base64?select=img&name=in.(A.png,B.png)" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+ } describe "HTTP request env vars" $ do it "custom header is set" $@@ -994,7 +1045,12 @@ [json| [] |] { matchHeaders = [matchContentTypeJson] } it "only returns an empty result set if the in value is empty" $- get "/items_with_different_col_types?int_data=in.( ,3,4)" `shouldRespondWith` 400+ get "/items_with_different_col_types?int_data=in.( ,3,4)"+ `shouldRespondWith`+ [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"\""} |]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ } describe "Embedding when column name = table name" $ do it "works with child embeds" $
test/Feature/RangeSpec.hs view
@@ -1,18 +1,18 @@ module Feature.RangeSpec where +import qualified Data.ByteString.Lazy as BL++import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleHeaders, simpleStatus))++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types-import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus)) -import qualified Data.ByteString.Lazy as BL-+import Protolude hiding (get) import SpecHelper-import Network.Wai (Application) -import Protolude hiding (get)- defaultRange :: BL.ByteString defaultRange = [json| { "min": 0, "max": 15 } |] @@ -38,7 +38,6 @@ { matchHeaders = ["Content-Range" <:> "0-14/*"] } context "with range headers" $ do- context "of acceptable range" $ do it "succeeds with partial content" $ do r <- request methodPost "/rpc/getitemrange"@@ -156,7 +155,6 @@ , matchHeaders = ["Content-Range" <:> "0-0/*"] } - it "limit and offset works on first level" $ get "/items?select=id&order=id.asc&limit=3&offset=2" `shouldRespondWith` [json|[{"id":3},{"id":4},{"id":5}]|]@@ -164,8 +162,37 @@ , matchHeaders = ["Content-Range" <:> "2-4/*"] } - context "with range headers" $ do+ it "succeeds if offset equals 0 as a no-op" $+ get "/items?select=id&offset=0"+ `shouldRespondWith`+ [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-14/*"]+ } + it "succeeds if offset is negative as a no-op" $+ get "/items?select=id&offset=-4"+ `shouldRespondWith`+ [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-14/*"]+ }++ it "fails if limit equals 0" $+ get "/items?select=id&limit=0"+ `shouldRespondWith` [json|{"message":"HTTP Range error"}|]+ { matchStatus = 416+ , matchHeaders = [matchContentTypeJson]+ }++ it "fails if limit is negative" $+ get "/items?select=id&limit=-1"+ `shouldRespondWith` [json|{"message":"HTTP Range error"}|]+ { matchStatus = 416+ , matchHeaders = [matchContentTypeJson]+ }++ context "with range headers" $ do context "of acceptable range" $ do it "succeeds with partial content" $ do r <- request methodGet "/items"
+ test/Feature/RootSpec.hs view
@@ -0,0 +1,30 @@+module Feature.RootSpec where++import Network.HTTP.Types+import Network.Wai (Application)++import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON++import Protolude hiding (get)++import SpecHelper++spec :: SpecWith Application+spec =+ describe "root spec function" $ do+ it "accepts application/openapi+json" $+ request methodGet "/"+ [("Accept","application/openapi+json")] "" `shouldRespondWith`+ [json|{+ "swagger": "2.0",+ "info": {"title": "PostgREST API", "description": "This is a dynamic API generated by PostgREST"}+ }|]+ { matchHeaders = ["Content-Type" <:> "application/openapi+json; charset=utf-8"] }++ it "accepts application/json" $+ request methodGet "/"+ [("Accept", "application/json")] "" `shouldRespondWith`+ [json| [{"table": "items"}, {"table": "subitems"}] |]+ { matchHeaders = [matchContentTypeJson] }
test/Feature/RpcSpec.hs view
@@ -1,20 +1,23 @@ module Feature.RpcSpec where -import Test.Hspec-import Test.Hspec.Wai-import Test.Hspec.Wai.JSON-import Network.HTTP.Types-import Network.Wai.Test (SResponse(simpleStatus, simpleBody)) import qualified Data.ByteString.Lazy as BL (empty) -import SpecHelper+import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleBody, simpleStatus))++import Network.HTTP.Types+import Test.Hspec hiding (pendingWith)+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON import Text.Heredoc-import Network.Wai (Application) -import Protolude hiding (get)+import PostgREST.Types (PgVersion, pgVersion100, pgVersion95,+ pgVersion96)+import Protolude hiding (get)+import SpecHelper -spec :: SpecWith Application-spec =+spec :: PgVersion -> SpecWith Application+spec actualPgVersion = describe "remote procedure call" $ do context "a proc that returns a set" $ do it "returns paginated results" $ do@@ -77,6 +80,21 @@ it "should fail with 404 on unknown proc args" $ do get "/rpc/sayhello" `shouldRespondWith` 404 get "/rpc/sayhello?any_arg=value" `shouldRespondWith` 404+ it "should not ignore unknown args and fail with 404" $+ get "/rpc/add_them?a=1&b=2&smthelse=blabla" `shouldRespondWith`+ let+ message :: Text+ message+ | actualPgVersion < pgVersion95 = "function test.add_them(a := integer, b := integer, smthelse := text) does not exist"+ | otherwise = "function test.add_them(a => integer, b => integer, smthelse => text) does not exist"+ in [json| {+ "code": "42883",+ "details": null,+ "hint": "No function matches the given name and argument types. You might need to add explicit type casts.",+ "message": #{message} } |]+ { matchStatus = 404+ , matchHeaders = [matchContentTypeJson]+ } it "works when having uppercase identifiers" $ do get "/rpc/quotedFunction?user=mscott&fullName=Michael Scott&SSN=401-32-XXXX" `shouldRespondWith`@@ -213,6 +231,63 @@ [json|null|] { matchHeaders = [matchContentTypeJson] } + context "proc argument types" $ do+ it "accepts a variety of arguments" $+ post "/rpc/varied_arguments"+ [json| {+ "double": 3.1,+ "varchar": "hello",+ "boolean": true,+ "date": "20190101",+ "money": 0,+ "enum": "foo",+ "integer": 43,+ "json": {"some key": "some value"},+ "jsonb": {"another key": [1, 2, "3"]}+ } |]+ `shouldRespondWith`+ [json|"Hi"|]+ { matchHeaders = [matchContentTypeJson] }++ it "parses embedded JSON arguments as JSON" $+ post "/rpc/json_argument"+ [json| { "arg": { "key": 3 } } |]+ `shouldRespondWith`+ [json|"object"|]+ { matchHeaders = [matchContentTypeJson] }++ when (actualPgVersion <= pgVersion96) $+ it "parses quoted JSON arguments as JSON (Postgres <= 9.6)" $+ post "/rpc/json_argument"+ [json| { "arg": "{ \"key\": 3 }" } |]+ `shouldRespondWith`+ [json|"object"|]+ { matchHeaders = [matchContentTypeJson] }++ when (actualPgVersion >= pgVersion100) $ do+ it "parses quoted JSON arguments as JSON string (Postgres >= 10)" $ do+ -- Postgres bug report:+ -- https://www.postgresql.org/message-id/D6921B37-BD8E-4664-8D5F-DB3525765DCD%40vllmrt.net+ -- * json_to_record fails (see following test)+ -- * jsonb_to_record parses the embedded quoted JSON to a JSON string,+ -- so that's probably the expected behavior for Postgres >= 10+ pendingWith "Postgres >= 10 fails to parse quoted embedded JSON"+ post "/rpc/json_argument"+ [json| { "arg": "{ \"key\": 3 }" } |]+ `shouldRespondWith`+ [json|"string"|]+ { matchHeaders = [matchContentTypeJson] }++ it "fails to parse quoted JSON arguments (Postgres >= 10)" $+ -- Confirming buggy Postgres behavior (see previous test)+ post "/rpc/json_argument"+ [json| { "arg": "{ \"key\": 3 }" } |]+ `shouldRespondWith`+ [json|{"hint":null,"details":"Token \"key\" is invalid.","code":"22P02","message":"invalid input syntax for type json"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ }+ context "improper input" $ do it "rejects unknown content type even if payload is good" $ do request methodPost "/rpc/sayhello"@@ -236,7 +311,11 @@ context "unsupported verbs" $ do it "DELETE fails" $ request methodDelete "/rpc/sayhello" [] ""- `shouldRespondWith` 405+ `shouldRespondWith`+ [json|{"message":"Bad Request"}|]+ { matchStatus = 405+ , matchHeaders = [matchContentTypeJson]+ } it "PATCH fails" $ request methodPatch "/rpc/sayhello" [] "" `shouldRespondWith` 405@@ -302,7 +381,12 @@ } it "defaults to status 500 if RAISE code is PT not followed by a number" $- get "/rpc/raise_bad_pt" `shouldRespondWith` 500+ get "/rpc/raise_bad_pt"+ `shouldRespondWith`+ [json|{"hint": null, "details": null}|]+ { matchStatus = 500+ , matchHeaders = [ matchContentTypeJson ]+ } context "expects a single json object" $ do it "does not expand posted json into parameters" $@@ -339,9 +423,100 @@ get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|] get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [str|"123"|] - context "only for POST rpc" $+ context "only for POST rpc" $ do it "gives a parse filter error if GET style proc args are specified" $ post "/rpc/sayhello?name=John" [json|{}|] `shouldRespondWith` 400++ it "ignores json keys not included in ?columns" $+ post "/rpc/sayhello?columns=name"+ [json|{"name": "John", "smth": "here", "other": "stuff", "fake_id": 13}|] `shouldRespondWith`+ [json|"Hello, John"|]+ { matchHeaders = [matchContentTypeJson] }++ context "bulk RPC" $ do+ it "works with a scalar function an returns a json array" $+ post "/rpc/add_them"+ [json|[+ {"a": 1, "b": 2},+ {"a": 4, "b": 6},+ {"a": 100, "b": 200}+ ]|] `shouldRespondWith`+ [json|+ [3, 10, 300]+ |] { matchHeaders = [matchContentTypeJson] }++ it "works with a scalar function an returns a json array when posting CSV" $+ request methodPost "/rpc/add_them" [("Content-Type", "text/csv")]+ "a,b\n1,2\n4,6\n100,200"+ `shouldRespondWith`+ [json|+ [3, 10, 300]+ |]+ { matchStatus = 200+ , matchHeaders = [matchContentTypeJson]+ }++ it "works with a non-scalar result" $+ post "/rpc/get_projects_below?select=id,name"+ [json|[+ {"id": 1},+ {"id": 5}+ ]|] `shouldRespondWith`+ [json|+ [{"id":1,"name":"Windows 7"},+ {"id":2,"name":"Windows 10"},+ {"id":3,"name":"IOS"},+ {"id":4,"name":"OSX"}]+ |] { matchHeaders = [matchContentTypeJson] }++ context "binary output" $ do+ context "Proc that returns scalar" $ do+ it "can query without selecting column" $+ request methodPost "/rpc/ret_base64_bin" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+ }++ it "can get raw output with Accept: text/html" $+ request methodGet "/rpc/welcome.html" (acceptHdrs "text/html") ""+ `shouldRespondWith`+ [str|+ |<html>+ | <head>+ | <title>PostgREST</title>+ | </head>+ | <body>+ | <h1>Welcome to PostgREST</h1>+ | </body>+ |</html>+ |]+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"]+ }++ it "can get raw output with Accept: text/plain" $+ request methodGet "/rpc/welcome" (acceptHdrs "text/plain") ""+ `shouldRespondWith` "Welcome to PostgREST"+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]+ }++ context "Proc that returns rows" $ do+ it "can query if a single column is selected" $+ request methodPost "/rpc/ret_rows_with_base64_bin?select=img" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+ }++ it "fails if a single column is not selected" $+ request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith`+ [json| {"message":"application/octet-stream requested but a single column was not selected"} |]+ { matchStatus = 406+ , matchHeaders = [matchContentTypeJson]+ } context "only for GET rpc" $ do it "should fail on mutating procs" $ do
test/Feature/SingularSpec.hs view
@@ -1,16 +1,16 @@ module Feature.SingularSpec where -import Text.Heredoc+import Network.Wai (Application)+import Network.Wai.Test (SResponse (..))++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types-import Network.Wai.Test (SResponse(..))--import Network.Wai (Application)+import Text.Heredoc +import Protolude hiding (get) import SpecHelper-import Protolude hiding (get) spec :: SpecWith Application@@ -43,7 +43,6 @@ { matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] } context "when updating rows" $ do- it "works for one row" $ do _ <- post "/addresses" [json| { id: 97, address: "A Street" } |] request methodPatch@@ -56,10 +55,9 @@ it "raises an error for multiple rows" $ do _ <- post "/addresses" [json| { id: 98, address: "xxx" } |] _ <- post "/addresses" [json| { id: 99, address: "yyy" } |]- p <- request methodPatch- "/addresses?id=gt.0"- [("Prefer", "return=representation"), singular]- [json| { address: "zzz" } |]+ p <- request methodPatch "/addresses?id=gt.0"+ [("Prefer", "return=representation"), singular]+ [json| { address: "zzz" } |] liftIO $ do simpleStatus p `shouldBe` notAcceptable406 isErrorFormat (simpleBody p) `shouldBe` True@@ -67,15 +65,16 @@ -- the rows should not be updated, either get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|] - it "raises an error for zero rows" $ do- p <- request methodPatch "/items?id=gt.0&id=lt.0"- [("Prefer", "return=representation"), singular] [json|{"id":1}|]- liftIO $ do- simpleStatus p `shouldBe` notAcceptable406- isErrorFormat (simpleBody p) `shouldBe` True+ it "raises an error for zero rows" $+ request methodPatch "/items?id=gt.0&id=lt.0"+ [("Prefer", "return=representation"), singular] [json|{"id":1}|]+ `shouldRespondWith`+ [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+ { matchStatus = 406+ , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]+ } context "when creating rows" $ do- it "works for one row" $ do p <- request methodPost "/addresses"@@ -117,17 +116,17 @@ , matchHeaders = ["Content-Range" <:> "*/*"] } - it "raises an error when creating zero entities" $ do- p <- request methodPost- "/addresses"- [("Prefer", "return=representation"), singular]- [json| [ ] |]- liftIO $ do- simpleStatus p `shouldBe` notAcceptable406- isErrorFormat (simpleBody p) `shouldBe` True+ it "raises an error when creating zero entities" $+ request methodPost "/addresses"+ [("Prefer", "return=representation"), singular]+ [json| [ ] |]+ `shouldRespondWith`+ [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+ { matchStatus = 406+ , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]+ } context "when deleting rows" $ do- it "works for one row" $ do p <- request methodDelete "/items?id=eq.11"@@ -146,21 +145,24 @@ , matchHeaders = ["Content-Range" <:> "0-9/*"] } - it "raises an error when deleting zero entities" $ do- p <- request methodDelete "/items?id=lt.0"- [("Prefer", "return=representation"), singular] ""- liftIO $ do- simpleStatus p `shouldBe` notAcceptable406- isErrorFormat (simpleBody p) `shouldBe` True+ it "raises an error when deleting zero entities" $+ request methodDelete "/items?id=lt.0"+ [("Prefer", "return=representation"), singular] ""+ `shouldRespondWith`+ [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+ { matchStatus = 406+ , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]+ } context "when calling a stored proc" $ do-- it "fails for zero rows" $ do- p <- request methodPost "/rpc/getproject"- [singular] [json|{ "id": 9999999}|]- liftIO $ do- simpleStatus p `shouldBe` notAcceptable406- isErrorFormat (simpleBody p) `shouldBe` True+ it "fails for zero rows" $+ request methodPost "/rpc/getproject"+ [singular] [json|{ "id": 9999999}|]+ `shouldRespondWith`+ [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+ { matchStatus = 406+ , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]+ } -- this one may be controversial, should vnd.pgrst.object include -- the likes of 2 and "hello?"@@ -174,20 +176,26 @@ [singular] [json|{ "id": 1}|] `shouldRespondWith` [str|{"id":1,"name":"Windows 7","client_id":1}|] - it "fails for multiple rows" $ do- p <- request methodPost "/rpc/getallprojects" [singular] "{}"- liftIO $ do- simpleStatus p `shouldBe` notAcceptable406- isErrorFormat (simpleBody p) `shouldBe` True+ it "fails for multiple rows" $+ request methodPost "/rpc/getallprojects"+ [singular] "{}"+ `shouldRespondWith`+ [str|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+ { matchStatus = 406+ , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]+ } it "executes the proc exactly once per request" $ do request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |] `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]- p <- request methodPost "/rpc/setprojects" [singular]- [json| {"id_l": 1, "id_h": 2, "name": "changed"} |]- liftIO $ do- simpleStatus p `shouldBe` notAcceptable406- isErrorFormat (simpleBody p) `shouldBe` True++ request methodPost "/rpc/setprojects" [singular]+ [json| {"id_l": 1, "id_h": 2, "name": "changed"} |]+ `shouldRespondWith`+ [str|{"details":"Results contain 2 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+ { matchStatus = 406+ , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]+ } -- should not actually have executed the function request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]
test/Feature/StructureSpec.hs view
@@ -1,21 +1,21 @@ module Feature.StructureSpec where -import Test.Hspec-import Test.Hspec.Wai-import Network.HTTP.Types--import PostgREST.Config (docsVersion)-import Control.Lens ((^?))+import Control.Lens ((^?)) import Data.Aeson.Types (Value (..))+import Network.Wai (Application)+import Network.Wai.Test (SResponse (..))+ import Data.Aeson.Lens import Data.Aeson.QQ+import Network.HTTP.Types+import Test.Hspec hiding (pendingWith)+import Test.Hspec.Wai -import SpecHelper -import Network.Wai (Application)-import Network.Wai.Test (SResponse(..)) -import Protolude hiding (get)+import PostgREST.Config (docsVersion)+import Protolude hiding (get)+import SpecHelper spec :: SpecWith Application spec = do@@ -219,6 +219,158 @@ ] |] + describe "PostgreSQL to Swagger Type Mapping" $ do++ it "character varying to string" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character_varying"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "character varying",+ "type": "string"+ }+ |]+ it "character(1) to string" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "maxLength": 1,+ "format": "character",+ "type": "string"+ }+ |]++ it "text to string" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_text"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "text",+ "type": "string"+ }+ |]++ it "boolean to boolean" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_boolean"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "boolean",+ "type": "boolean"+ }+ |]++ it "smallint to integer" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_smallint"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "smallint",+ "type": "integer"+ }+ |]++ it "integer to integer" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_integer"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "integer",+ "type": "integer"+ }+ |]++ it "bigint to integer" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_bigint"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "bigint",+ "type": "integer"+ }+ |]++ it "numeric to number" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_numeric"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "numeric",+ "type": "number"+ }+ |]++ it "real to number" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_real"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "real",+ "type": "number"+ }+ |]++ it "double_precision to number" $ do+ r <- simpleBody <$> get "/"++ let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_double_precision"++ liftIO $++ types `shouldBe` Just+ [aesonQQ|+ {+ "format": "double precision",+ "type": "number"+ }+ |]+ describe "RPC" $ do it "includes function summary/description and body schema for arguments" $ do@@ -249,7 +401,7 @@ "properties": { "double": { "format": "double precision",- "type": "string"+ "type": "number" }, "varchar": { "format": "character varying",@@ -274,6 +426,14 @@ "integer": { "format": "integer", "type": "integer"+ },+ "json": {+ "format": "json",+ "type": "string"+ },+ "jsonb": {+ "format": "jsonb",+ "type": "string" } }, "type": "object",
test/Feature/UnicodeSpec.hs view
@@ -1,14 +1,14 @@ module Feature.UnicodeSpec where +import Control.Monad (void)+import Network.Wai (Application)+ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.Wai (Application)-import Control.Monad (void) +import Protolude hiding (get) import SpecHelper--import Protolude hiding (get) spec :: SpecWith Application spec =
test/Feature/UpsertSpec.hs view
@@ -1,16 +1,16 @@ module Feature.UpsertSpec where +import Network.Wai (Application)++import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Network.HTTP.Types+import Text.Heredoc +import Protolude hiding (get, put) import SpecHelper-import Network.Wai (Application) -import Protolude hiding (get, put)-import Text.Heredoc- spec :: SpecWith Application spec = describe "UPSERT" $ do@@ -44,6 +44,12 @@ , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson] } + it "succeeds when the payload has no elements" $+ request methodPost "/articles" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]+ [json|[]|] `shouldRespondWith`+ [json|[]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] }++ context "when Prefer: resolution=ignore-duplicates is specified" $ do it "INSERTs and ignores rows on pk conflict" $ request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]@@ -104,48 +110,96 @@ context "Restrictions" $ do it "fails if Range is specified" $ request methodPut "/tiobe_pls?name=eq.Javascript" [("Range", "0-5")]- [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400+ [str| [ { "name": "Javascript", "rank": 1 } ]|]+ `shouldRespondWith`+ [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]+ { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if limit is specified" $ put "/tiobe_pls?name=eq.Javascript&limit=1"- [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400+ [str| [ { "name": "Javascript", "rank": 1 } ]|]+ `shouldRespondWith`+ [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]+ { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if offset is specified" $ put "/tiobe_pls?name=eq.Javascript&offset=1"- [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400+ [str| [ { "name": "Javascript", "rank": 1 } ]|]+ `shouldRespondWith`+ [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]+ { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if the payload has more than one row" $ put "/tiobe_pls?name=eq.Go"- [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ]|] `shouldRespondWith` 400+ [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ]|]+ `shouldRespondWith`+ [json|{"message":"PUT payload must contain a single row"}|]+ { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if not all columns are specified" $ do put "/tiobe_pls?name=eq.Go"- [str| [ { "name": "Go" } ]|] `shouldRespondWith` 400+ [str| [ { "name": "Go" } ]|]+ `shouldRespondWith`+ [json|{"message":"You must specify all columns in the payload when using PUT"}|]+ { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }+ put "/employees?first_name=eq.Susan&last_name=eq.Heidt"- [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000" } ]|] `shouldRespondWith` 400+ [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000" } ]|]+ `shouldRespondWith`+ [json|{"message":"You must specify all columns in the payload when using PUT"}|]+ { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "rejects every other filter than pk cols eq's" $ do- put "/tiobe_pls?rank=eq.19" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405- put "/tiobe_pls?id=not.eq.Java" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405- put "/tiobe_pls?id=in.(Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405- put "/tiobe_pls?and=(id.eq.Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405+ put "/tiobe_pls?rank=eq.19"+ [str| [ { "name": "Go", "rank": 19 } ]|]+ `shouldRespondWith`+ [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]+ { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } + put "/tiobe_pls?id=not.eq.Java"+ [str| [ { "name": "Go", "rank": 19 } ]|]+ `shouldRespondWith`+ [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]+ { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }+ put "/tiobe_pls?id=in.(Go)"+ [str| [ { "name": "Go", "rank": 19 } ]|]+ `shouldRespondWith`+ [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]+ { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }+ put "/tiobe_pls?and=(id.eq.Go)"+ [str| [ { "name": "Go", "rank": 19 } ]|]+ `shouldRespondWith`+ [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]+ { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }+ it "fails if not all composite key cols are specified as eq filters" $ do put "/employees?first_name=eq.Susan" [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]- `shouldRespondWith` 405+ `shouldRespondWith`+ [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]+ { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } put "/employees?last_name=eq.Heidt" [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]- `shouldRespondWith` 405+ `shouldRespondWith`+ [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]+ { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } it "fails if the uri primary key doesn't match the payload primary key" $ do- put "/tiobe_pls?name=eq.MATLAB"- [str| [ { "name": "Perl", "rank": 17 } ]|] `shouldRespondWith` 400+ put "/tiobe_pls?name=eq.MATLAB" [str| [ { "name": "Perl", "rank": 17 } ]|]+ `shouldRespondWith`+ [json|{"message":"Payload values do not match URL in primary key column(s)"}|]+ { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } put "/employees?first_name=eq.Wendy&last_name=eq.Anderson"- [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] `shouldRespondWith` 400+ [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]+ `shouldRespondWith`+ [json|{"message":"Payload values do not match URL in primary key column(s)"}|]+ { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if the table has no PK" $- put "/no_pk?a=eq.one&b=eq.two" [str| [ { "a": "one", "b": "two" } ]|] `shouldRespondWith` 405+ put "/no_pk?a=eq.one&b=eq.two" [str| [ { "a": "one", "b": "two" } ]|]+ `shouldRespondWith`+ [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]+ { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } context "Inserting row" $ do it "succeeds on table with single pk col" $ do
test/Main.hs view
@@ -1,23 +1,28 @@ module Main where -import Test.Hspec-import SpecHelper--import qualified Hasql.Pool as P+import qualified Hasql.Pool as P import qualified Hasql.Transaction.Sessions as HT -import PostgREST.App (postgrest)-import PostgREST.DbStructure (getDbStructure, getPgVersion)-import PostgREST.Types (DbStructure(..), pgVersion95, pgVersion96)-import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction)-import Data.Function (id)+import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,+ updateAction)+import Data.Function (id)+import Data.Time.Clock (getCurrentTime)+ import Data.IORef-import Data.Time.Clock (getCurrentTime)+import Test.Hspec -import qualified Feature.AuthSpec+import PostgREST.App (postgrest)+import PostgREST.DbStructure (getDbStructure, getPgVersion)+import PostgREST.Types (DbStructure (..), pgVersion95,+ pgVersion96)+import Protolude+import SpecHelper++import qualified Feature.AndOrParamsSpec import qualified Feature.AsymmetricJwtSpec-import qualified Feature.BinaryJwtSecretSpec import qualified Feature.AudienceJwtSecretSpec+import qualified Feature.AuthSpec+import qualified Feature.BinaryJwtSecretSpec import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec@@ -25,21 +30,20 @@ import qualified Feature.InsertSpec import qualified Feature.JsonOperatorSpec import qualified Feature.NoJwtSpec+import qualified Feature.NonexistentSchemaSpec+import qualified Feature.PgVersion95Spec+import qualified Feature.PgVersion96Spec+import qualified Feature.ProxySpec import qualified Feature.QueryLimitedSpec import qualified Feature.QuerySpec import qualified Feature.RangeSpec-import qualified Feature.StructureSpec+import qualified Feature.RootSpec+import qualified Feature.RpcSpec import qualified Feature.SingularSpec+import qualified Feature.StructureSpec import qualified Feature.UnicodeSpec-import qualified Feature.ProxySpec-import qualified Feature.AndOrParamsSpec-import qualified Feature.RpcSpec-import qualified Feature.NonexistentSchemaSpec-import qualified Feature.PgVersion95Spec-import qualified Feature.PgVersion96Spec import qualified Feature.UpsertSpec -import Protolude main :: IO () main = do@@ -52,7 +56,7 @@ ver <- getPgVersion HT.transaction HT.ReadCommitted HT.Read $ getDbStructure "test" ver - dbStructure <- pure $ either (panic.show) id result+ let dbStructure = either (panic.show) id result getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime } @@ -69,6 +73,7 @@ asymJwkSetApp = return $ postgrest (testCfgAsymJWKSet testDbConn) refDbStructure pool getTime $ pure () nonexistentSchemaApp = return $ postgrest (testNonexistentSchemaCfg testDbConn) refDbStructure pool getTime $ pure () extraSearchPathApp = return $ postgrest (testCfgExtraSearchPath testDbConn) refDbStructure pool getTime $ pure ()+ rootSpecApp = return $ postgrest (testCfgRootSpec testDbConn) refDbStructure pool getTime $ pure () let reset :: IO () reset = resetDb testDbConn@@ -80,14 +85,14 @@ [("Feature.PgVersion96Spec", Feature.PgVersion96Spec.spec) | actualPgVersion >= pgVersion96] specs = uncurry describe <$> [- ("Feature.AuthSpec" , Feature.AuthSpec.spec)+ ("Feature.AuthSpec" , Feature.AuthSpec.spec actualPgVersion) , ("Feature.ConcurrentSpec" , Feature.ConcurrentSpec.spec) , ("Feature.CorsSpec" , Feature.CorsSpec.spec) , ("Feature.DeleteSpec" , Feature.DeleteSpec.spec)- , ("Feature.InsertSpec" , Feature.InsertSpec.spec)- , ("Feature.JsonOperatorSpec" , Feature.JsonOperatorSpec.spec)+ , ("Feature.InsertSpec" , Feature.InsertSpec.spec actualPgVersion)+ , ("Feature.JsonOperatorSpec" , Feature.JsonOperatorSpec.spec actualPgVersion) , ("Feature.QuerySpec" , Feature.QuerySpec.spec)- , ("Feature.RpcSpec" , Feature.RpcSpec.spec)+ , ("Feature.RpcSpec" , Feature.RpcSpec.spec actualPgVersion) , ("Feature.RangeSpec" , Feature.RangeSpec.spec) , ("Feature.SingularSpec" , Feature.SingularSpec.spec) , ("Feature.StructureSpec" , Feature.StructureSpec.spec)@@ -136,3 +141,8 @@ -- this test runs with an extra search path beforeAll_ reset . before extraSearchPathApp $ describe "Feature.ExtraSearchPathSpec" Feature.ExtraSearchPathSpec.spec++ -- this test runs with a root spec function override+ when (actualPgVersion >= pgVersion96) $+ beforeAll_ reset . before rootSpecApp $+ describe "Feature.RootSpec" Feature.RootSpec.spec
test/SpecHelper.hs view
@@ -1,34 +1,29 @@ module SpecHelper where -import Control.Monad (void)+import qualified Data.ByteString.Base64 as B64 (decodeLenient, encode)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified System.IO.Error as E -import qualified System.IO.Error as E-import System.Environment (getEnv)+import Control.Monad (void)+import Data.Aeson (Value (..), decode, encode)+import Data.CaseInsensitive (CI (..))+import Data.List (lookup)+import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus))+import System.Environment (getEnv)+import System.Process (readProcess)+import Text.Regex.TDFA ((=~)) -import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient)-import Data.CaseInsensitive (CI(..))-import qualified Data.Set as S-import qualified Data.Map.Strict as M-import Data.List (lookup)-import Text.Regex.TDFA ((=~))-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as BL-import System.Process (readProcess)-import Text.Heredoc -import PostgREST.Config (AppConfig(..))-import PostgREST.Types (JSPathExp(..))-+import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai--import Network.HTTP.Types-import Network.Wai.Test (SResponse(simpleStatus, simpleHeaders, simpleBody))--import Data.Maybe (fromJust)-import Data.Aeson (decode, Value(..))-import qualified JSONSchema.Draft4 as D4+import Text.Heredoc +import PostgREST.Config (AppConfig (..))+import PostgREST.Types (JSPathExp (..), QualifiedIdentifier (..)) import Protolude matchContentTypeJson :: MatchHeader@@ -48,18 +43,20 @@ let respHeaders = simpleHeaders r in respHeaders `shouldSatisfy` \hs -> ("Content-Type", "application/openapi+json; charset=utf-8") `elem` hs- liftIO $- let respBody = simpleBody r- schema :: D4.Schema- schema = D4.emptySchema { D4._schemaRef = Just "openapi.json" }- schemaContext :: D4.SchemaWithURI D4.Schema- schemaContext = D4.SchemaWithURI- { D4._swSchema = schema- , D4._swURI = Just "test/fixtures/openapi.json"- }- in- D4.fetchFilesystemAndValidate schemaContext ((fromJust . decode) respBody) `shouldReturn` Right ()+ let Just body = decode (simpleBody r)+ Just schema <- liftIO $ decode <$> BL.readFile "test/fixtures/openapi.json"+ let args :: M.Map Text Value+ args = M.fromList+ [ ( "schema", schema )+ , ( "data", body ) ]+ hdrs = acceptHdrs "application/json"+ request methodPost "/rpc/validate_json_schema" hdrs (encode args)+ `shouldRespondWith` "true"+ { matchStatus = 200+ , matchHeaders = []+ } + getEnvVarWithDefault :: Text -> Text -> IO Text getEnvVarWithDefault var def = toS <$> getEnv (toS var) `E.catchIOError` const (return $ toS def)@@ -67,10 +64,12 @@ _baseCfg :: AppConfig _baseCfg = -- Connection Settings AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000+ -- No user configured Unix Socket+ Nothing -- Jwt settings (Just $ encodeUtf8 "reallyreallyreallyreallyverysafe") False Nothing -- Connection Modifiers- 10 Nothing (Just "test.switch_role")+ 10 10 Nothing (Just "test.switch_role") -- Debug Settings True [ ("app.settings.app_host", "localhost")@@ -80,6 +79,8 @@ (Right [JSPKey "role"]) -- Empty db-extra-search-path []+ -- No root spec override+ Nothing testCfg :: Text -> AppConfig testCfg testDbConn = _baseCfg { configDatabase = testDbConn }@@ -127,12 +128,16 @@ testCfgExtraSearchPath :: Text -> AppConfig testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configExtraSearchPath = ["public", "extensions"] } +testCfgRootSpec :: Text -> AppConfig+testCfgRootSpec testDbConn = (testCfg testDbConn) { configRootSpec = Just $ QualifiedIdentifier "test" "root"}+ setupDb :: Text -> IO () setupDb dbConn = do loadFixture dbConn "database" loadFixture dbConn "roles" loadFixture dbConn "schema" loadFixture dbConn "jwt"+ loadFixture dbConn "jsonschema" loadFixture dbConn "privileges" resetDb dbConn @@ -141,7 +146,7 @@ loadFixture :: Text -> FilePath -> IO() loadFixture dbConn name =- void $ readProcess "psql" [toS dbConn, "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []+ void $ readProcess "psql" ["--set", "ON_ERROR_STOP=1", toS dbConn, "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]
test/TestTypes.hs view
@@ -3,16 +3,16 @@ , CompoundPK(..) ) where +import Data.Aeson ((.:)) import qualified Data.Aeson as JSON-import Data.Aeson ((.:)) import Protolude data IncPK = IncPK {- incId :: Int+ incId :: Int , incNullableStr :: Maybe Text-, incStr :: Text-, incInsert :: Text+, incStr :: Text+, incInsert :: Text } deriving (Eq, Show) instance JSON.FromJSON IncPK where@@ -24,8 +24,8 @@ parseJSON _ = mzero data CompoundPK = CompoundPK {- compoundK1 :: Int-, compoundK2 :: Text+ compoundK1 :: Int+, compoundK2 :: Text , compoundExtra :: Maybe Int } deriving (Eq, Show)