postgrest 6.0.2 → 7.0.0
raw patch · 56 files changed
+3308/−1718 lines, 56 filesdep ~basedep ~configurator-pgdep ~hasql-transaction
Dependency ranges changed: base, configurator-pg, hasql-transaction, hspec-wai, hspec-wai-json, http-types, insert-ordered-containers, lens, lens-aeson, network, optparse-applicative, regex-tdfa, swagger2, time, warp
Files
- CHANGELOG.md +32/−0
- LICENSE +1/−0
- main/Main.hs +39/−46
- main/UnixSocket.hs +40/−0
- postgrest.cabal +73/−30
- src/PostgREST/ApiRequest.hs +109/−76
- src/PostgREST/App.hs +228/−202
- src/PostgREST/Config.hs +36/−13
- src/PostgREST/DbRequestBuilder.hs +182/−192
- src/PostgREST/DbStructure.hs +131/−137
- src/PostgREST/Error.hs +36/−6
- src/PostgREST/Middleware.hs +20/−10
- src/PostgREST/OpenAPI.hs +21/−14
- src/PostgREST/Parsers.hs +9/−5
- src/PostgREST/Private/Common.hs +25/−0
- src/PostgREST/Private/QueryFragment.hs +205/−0
- src/PostgREST/QueryBuilder.hs +122/−94
- src/PostgREST/QueryBuilder/Private.hs +0/−237
- src/PostgREST/QueryBuilder/Procedure.hs +0/−85
- src/PostgREST/QueryBuilder/ReadStatement.hs +0/−32
- src/PostgREST/QueryBuilder/WriteStatement.hs +0/−53
- src/PostgREST/RangeQuery.hs +31/−1
- src/PostgREST/Statements.hs +179/−0
- src/PostgREST/Types.hs +134/−48
- test/Feature/AndOrParamsSpec.hs +1/−1
- test/Feature/AsymmetricJwtSpec.hs +1/−1
- test/Feature/AudienceJwtSecretSpec.hs +1/−1
- test/Feature/AuthSpec.hs +1/−1
- test/Feature/BinaryJwtSecretSpec.hs +1/−1
- test/Feature/ConcurrentSpec.hs +6/−6
- test/Feature/CorsSpec.hs +1/−1
- test/Feature/DeleteSpec.hs +24/−2
- test/Feature/EmbedDisambiguationSpec.hs +434/−0
- test/Feature/ExtraSearchPathSpec.hs +1/−1
- test/Feature/HtmlRawOutputSpec.hs +1/−1
- test/Feature/InsertSpec.hs +128/−41
- test/Feature/JsonOperatorSpec.hs +8/−3
- test/Feature/MultipleSchemaSpec.hs +324/−0
- test/Feature/NoJwtSpec.hs +1/−1
- test/Feature/NonexistentSchemaSpec.hs +1/−1
- test/Feature/PgVersion95Spec.hs +1/−1
- test/Feature/PgVersion96Spec.hs +97/−3
- test/Feature/ProxySpec.hs +1/−1
- test/Feature/QueryLimitedSpec.hs +34/−5
- test/Feature/QuerySpec.hs +33/−265
- test/Feature/RangeSpec.hs +66/−2
- test/Feature/RawOutputTypesSpec.hs +1/−1
- test/Feature/RootSpec.hs +1/−1
- test/Feature/RpcSpec.hs +139/−12
- test/Feature/SingularSpec.hs +85/−18
- test/Feature/StructureSpec.hs +21/−2
- test/Feature/UnicodeSpec.hs +1/−1
- test/Feature/UpsertSpec.hs +52/−1
- test/Main.hs +84/−52
- test/QueryCost.hs +76/−0
- test/SpecHelper.hs +29/−10
CHANGELOG.md view
@@ -9,6 +9,38 @@ ### Fixed +## [7.0.0] - 2020-04-03++### Added++- #1417, `Accept: application/vnd.pgrst.object+json` behavior is now enforced for POST/PATCH/DELETE regardless of `Prefer: return=representation/minimal` - @dwagin+- #1415, Add support for user defined socket permission via `server-unix-socket-mode` config option - @Dansvidania+- #1383, Add support for HEAD request - @steve-chavez+- #1378, Add support for `Prefer: count=planned` and `Prefer: count=estimated` on GET /table - @steve-chavez, @LorenzHenk+- #1327, Add support for optional query parameter `on_conflict` to upsert with specified keys for POST - @ykst+- #1430, Allow specifying the foreign key constraint name(`/source?select=fk_constraint(*)`) to disambiguate an embedding - @steve-chavez+- #1168, Allow access to the `Authorization` header through the `request.header.authorization` GUC - @steve-chavez+- #1435, Add `request.method` and `request.path` GUCs - @steve-chavez+- #1088, Allow adding headers to GET/POST/PATCH/PUT/DELETE responses through the `response.headers` GUC - @steve-chavez+- #1427, Allow overriding provided headers(Location, Content-Type, etc) through the `response.headers` GUC - @steve-chavez+- #1450, Allow multiple schemas to be exposed in one instance. The schema to use can be selected through the headers `Accept-Profile` for GET/HEAD and `Content-Profile` for POST/PATCH/PUT/DELETE - @steve-chavez, @mahmoudkassem++### Fixed++- #1301, Fix self join resource embedding on PATCH - @herulume, @steve-chavez+- #1389, Fix many to many resource embedding on RPC/PATCH - @steve-chavez+- #1355, Allow PATCH/DELETE without `return=minimal` on tables with no select privileges - @steve-chavez+- #1361, Fix embedding a VIEW when its source foreign key is UNIQUE - @bwbroersma++### Changed++- #1385, bulk RPC call now should be done by specifying a `Prefer: params=multiple-objects` header - @steve-chavez+- #1401, resource embedding now outputs an error when multiple relationships between two tables are found - @steve-chavez+- #1423, default Unix Socket file mode from 755 to 660 - @dwagin+- #1430, Remove embedding with duck typed column names `GET /projects?select=client(*)`- @steve-chavez+ + You can rename the foreign key to `client` to make this request work in the new version: `alter table projects rename constraint projects_client_id_fkey to client`+- #1413, Change `server-proxy-uri` config option to `openapi-server-proxy-uri` - @steve-chavez+ ## [6.0.2] - 2019-08-22 ### Fixed
LICENSE view
@@ -1,4 +1,5 @@ Copyright (c) 2014 Joe Nelson+Copyright (c) 2019 Steve Chavez Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
main/Main.hs view
@@ -12,25 +12,17 @@ import Control.Retry (RetryStatus, capDelay, exponentialBackoff, retrying, rsPreviousDelay)+import Data.Either.Combinators (whenLeft) import Data.IORef (IORef, atomicWriteIORef, newIORef, readIORef) import Data.String (IsString (..))-import Data.Text (pack, replace, strip, stripPrefix,- unpack)+import Data.Text (pack, replace, strip, stripPrefix) 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)+ setHost, setPort, setServerName) import System.IO (BufferMode (..), hSetBuffering)-import System.IO.Error (isDoesNotExistError) import PostgREST.App (postgrest) import PostgREST.Config (AppConfig (..), configPoolTimeout',@@ -42,13 +34,15 @@ import PostgREST.Types (ConnectionStatus (..), DbStructure, PgVersion (..), Schema, minimumPgVersion)-import Protolude hiding (hPutStrLn, replace)+import Protolude hiding (hPutStrLn, head, replace) #ifndef mingw32_HOST_OS import System.Posix.Signals+import UnixSocket #endif + {-| The purpose of this worker is to fill the refDbStructure created in 'main' with the 'DbStructure' returned from calling 'getDbStructure'. This method@@ -70,11 +64,11 @@ connectionWorker :: ThreadId -- ^ This thread is killed if pg version is unsupported -> P.Pool -- ^ The PostgreSQL connection pool- -> Schema -- ^ Schema PostgREST is serving up+ -> [Schema] -- ^ Schemas PostgREST is serving up -> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure' -> IORef Bool -- ^ Used as a binary Semaphore -> IO ()-connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do+connectionWorker mainTid pool schemas refDbStructure refIsWorkerOn = do isWorkerOn <- readIORef refIsWorkerOn unless isWorkerOn $ do atomicWriteIORef refIsWorkerOn True@@ -90,7 +84,7 @@ NotConnected -> return () -- Unreachable Connected actualPgVersion -> do -- Procede with initialization result <- P.use pool $ do- dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schema actualPgVersion+ dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schemas actualPgVersion liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure case result of Left e -> do@@ -159,10 +153,12 @@ -- readOptions builds the 'AppConfig' from the config file specified on the -- command line conf <- loadDbUriFile =<< loadSecretFile =<< readOptions- let host = configHost conf+ let schemas = toList $ configSchemas conf+ host = configHost conf port = configPort conf- proxy = configProxyUri conf+ proxy = configOpenAPIProxyUri conf maybeSocketAddr = configSocket conf+ socketFileMode = configSocketMode conf pgSettings = toS (configDatabase conf) -- is the db-uri roleClaimKey = configRoleClaimKey conf appSettings =@@ -171,16 +167,18 @@ . setServerName (toS $ "postgrest/" <> prettyVersion) $ defaultSettings ++ whenLeft socketFileMode panic+ -- Checks that the provided proxy uri is formated correctly when (isMalformedProxyUri $ toS <$> proxy) $ panic "Malformed proxy uri, a correct example: https://example.com:8443/basePath" -- Checks that the provided jspath is valid- when (isLeft roleClaimKey) $+ whenLeft roleClaimKey $ panic $ show roleClaimKey - -- -- create connection pool with the provided settings, returns either -- a 'Connection' or a 'ConnectionError'. Does not throw. pool <- P.acquire (configPool conf, configPoolTimeout' conf, pgSettings)@@ -199,7 +197,7 @@ connectionWorker mainTid pool- (configSchema conf)+ schemas refDbStructure refIsWorkerOn --@@ -221,7 +219,7 @@ Catch $ connectionWorker mainTid pool- (configSchema conf)+ schemas refDbStructure refIsWorkerOn ) Nothing@@ -240,23 +238,21 @@ (connectionWorker mainTid pool- (configSchema conf)+ schemas 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 + -- run the postgrest application with user defined socket. Only for UNIX systems.+#ifndef mingw32_HOST_OS+ whenJust maybeSocketAddr $+ runAppInSocket appSettings postgrestApplication socketFileMode+#endif++ -- run the postgrest application+ whenNothing maybeSocketAddr $ do+ putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)+ runSettings appSettings postgrestApplication+ {-| The purpose of this function is to load the JWT secret from a file if configJwtSecret is actually a filepath and replaces some characters if the JWT@@ -324,14 +320,11 @@ 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+-- Utilitarian functions.+whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()+whenJust (Just x) f = f x+whenJust Nothing _ = pass++whenNothing :: Applicative f => Maybe a -> f () -> f ()+whenNothing Nothing f = f+whenNothing _ _ = pass
+ main/UnixSocket.hs view
@@ -0,0 +1,40 @@+module UnixSocket (+ runAppInSocket+)where++import Network.Socket (Family (AF_UNIX),+ SockAddr (SockAddrUnix), Socket,+ SocketType (Stream), bind, close,+ defaultProtocol, listen,+ maxListenQueue, socket)+import Network.Wai (Application)+import Network.Wai.Handler.Warp+import System.Directory (removeFile)+import System.IO.Error (isDoesNotExistError)+import System.Posix.Files (setFileMode)+import System.Posix.Types (FileMode)++import Protolude++createAndBindSocket :: FilePath -> Maybe FileMode -> IO Socket+createAndBindSocket socketFilePath maybeSocketFileMode = do+ deleteSocketFileIfExist socketFilePath+ sock <- socket AF_UNIX Stream defaultProtocol+ bind sock $ SockAddrUnix socketFilePath+ mapM_ (setFileMode socketFilePath) maybeSocketFileMode+ return sock+ where+ deleteSocketFileIfExist path = removeFile path `catch` handleDoesNotExist+ handleDoesNotExist e+ | isDoesNotExistError e = return ()+ | otherwise = throwIO e++-- run the postgrest application with user defined socket.+runAppInSocket :: Settings -> Application -> Either Text FileMode -> FilePath -> IO ()+runAppInSocket settings app socketFileMode sockPath = do+ sock <- createAndBindSocket sockPath (rightToMaybe socketFileMode)+ putStrLn $ ("Listening on unix socket " :: Text) <> show sockPath+ listen sock maxListenQueue+ runSettingsSocket settings sock app+ -- clean socket up when done+ close sock
postgrest.cabal view
@@ -1,13 +1,13 @@ name: postgrest-version: 6.0.2+version: 7.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>+author: Joe Nelson, Adam Baker, Steve Chavez+maintainer: Steve Chavez <stevechavezast@gmail.com> category: Executable, PostgreSQL, Network APIs homepage: https://postgrest.org bug-reports: https://github.com/PostgREST/postgrest/issues@@ -36,15 +36,14 @@ PostgREST.OpenAPI PostgREST.Parsers PostgREST.QueryBuilder+ PostgREST.Statements PostgREST.RangeQuery PostgREST.Types other-modules: Paths_postgrest- PostgREST.QueryBuilder.Private- PostgREST.QueryBuilder.Procedure- PostgREST.QueryBuilder.ReadStatement- PostgREST.QueryBuilder.WriteStatement+ PostgREST.Private.Common+ PostgREST.Private.QueryFragment hs-source-dirs: src- build-depends: base >= 4.9 && < 4.13+ build-depends: base >= 4.9 && < 4.14 , HTTP >= 4000.3.7 && < 4000.4 , Ranged-sets >= 0.3 && < 0.5 , aeson >= 0.11.3 && < 1.5@@ -53,7 +52,7 @@ , bytestring >= 0.10.8 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , cassava >= 0.4.5 && < 0.6- , configurator-pg >= 0.1 && < 0.2+ , configurator-pg >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7 , contravariant >= 1.4 && < 1.6 , contravariant-extras >= 0.3.3 && < 0.4@@ -62,23 +61,23 @@ , gitrev >= 1.2 && < 1.4 , hasql >= 1.4 && < 1.5 , hasql-pool >= 0.5 && < 0.6- , hasql-transaction >= 0.7.2 && < 0.8+ , hasql-transaction >= 0.7.2 && < 1.1 , heredoc >= 0.2 && < 0.3 , http-types >= 0.12.2 && < 0.13- , insert-ordered-containers >= 0.1 && < 0.3+ , insert-ordered-containers >= 0.2.2 && < 0.3 , interpolatedstring-perl6 >= 1 && < 1.1 , jose >= 0.8.1 && < 0.9- , lens >= 4.14 && < 4.18- , lens-aeson >= 1.0.1 && < 1.1+ , lens >= 4.14 && < 4.19+ , lens-aeson >= 1.0.1 && < 1.2 , network-uri >= 2.6.1 && < 2.7- , optparse-applicative >= 0.13 && < 0.15+ , optparse-applicative >= 0.13 && < 0.16 , parsec >= 3.1.11 && < 3.2 , protolude >= 0.2.2 && < 0.3- , regex-tdfa >= 1.2.2 && < 1.3+ , regex-tdfa >= 1.2.2 && < 1.4 , scientific >= 0.3.4 && < 0.4- , swagger2 >= 2.1.4 && < 2.4+ , swagger2 >= 2.4 && < 2.6 , text >= 1.2.2 && < 1.3- , time >= 1.6 && < 1.9+ , time >= 1.6 && < 1.10 , unordered-containers >= 0.2.8 && < 0.3 , vector >= 0.11 && < 0.13 , wai >= 3.2.1 && < 3.3@@ -93,21 +92,23 @@ executable postgrest main-is: Main.hs hs-source-dirs: main- build-depends: base >= 4.9 && < 4.13+ build-depends: base >= 4.9 && < 4.14 , auto-update >= 0.1.4 && < 0.2 , base64-bytestring >= 1 && < 1.1 , bytestring >= 0.10.8 && < 0.11 , directory >= 1.2.6 && < 1.4+ , either >= 4.4.1 && < 5.1 , hasql >= 1.4 && < 1.5 , hasql-pool >= 0.5 && < 0.6- , hasql-transaction >= 0.7.2 && < 0.8- , network < 2.9+ , hasql-transaction >= 0.7.2 && < 1.1+ , network < 3.2 , 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+ , time >= 1.6 && < 1.10+ , wai >= 3.2.1 && < 3.3+ , warp >= 3.2.12 && < 3.4 default-language: Haskell2010 default-extensions: OverloadedStrings QuasiQuotes@@ -116,6 +117,7 @@ if !os(windows) build-depends: unix+ other-modules: UnixSocket test-suite spec type: exitcode-stdio-1.0@@ -128,6 +130,7 @@ Feature.ConcurrentSpec Feature.CorsSpec Feature.DeleteSpec+ Feature.EmbedDisambiguationSpec Feature.ExtraSearchPathSpec Feature.InsertSpec Feature.JsonOperatorSpec@@ -147,10 +150,11 @@ Feature.UpsertSpec Feature.RawOutputTypesSpec Feature.HtmlRawOutputSpec+ Feature.MultipleSchemaSpec SpecHelper TestTypes hs-source-dirs: test- build-depends: base >= 4.9 && < 4.13+ build-depends: base >= 4.9 && < 4.14 , aeson >= 0.11.3 && < 1.5 , aeson-qq >= 0.8.1 && < 0.9 , async >= 2.1.1 && < 2.3@@ -163,21 +167,21 @@ , contravariant >= 1.4 && < 1.6 , hasql >= 1.4 && < 1.5 , hasql-pool >= 0.5 && < 0.6- , hasql-transaction >= 0.7.2 && < 0.8+ , hasql-transaction >= 0.7.2 && < 1.1 , heredoc >= 0.2 && < 0.3 , hspec >= 2.3 && < 2.8- , hspec-wai >= 0.7 && < 0.10- , hspec-wai-json >= 0.7 && < 0.10+ , hspec-wai >= 0.10 && < 0.11+ , hspec-wai-json >= 0.10 && < 0.11 , http-types >= 0.12.3 && < 0.13- , lens >= 4.14 && < 4.18- , lens-aeson >= 1.0.1 && < 1.1+ , lens >= 4.14 && < 4.19+ , lens-aeson >= 1.0.1 && < 1.2 , 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+ , regex-tdfa >= 1.2.2 && < 1.4 , text >= 1.2.2 && < 1.3- , time >= 1.6 && < 1.9+ , time >= 1.6 && < 1.10 , transformers-base >= 0.4.4 && < 0.5 , wai >= 3.2.1 && < 3.3 , wai-extra >= 3.0.19 && < 3.1@@ -186,3 +190,42 @@ QuasiQuotes NoImplicitPrelude ghc-options: -threaded -rtsopts -with-rtsopts=-N++Test-Suite spec-querycost+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude+ Hs-Source-Dirs: test+ Main-Is: QueryCost.hs+ Other-Modules: SpecHelper+ Build-Depends: base >= 4.9 && < 4.14+ , 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 && < 1.1+ , heredoc >= 0.2 && < 0.3+ , hspec >= 2.3 && < 2.8+ , hspec-wai >= 0.10 && < 0.11+ , hspec-wai-json >= 0.10 && < 0.11+ , http-types >= 0.12.3 && < 0.13+ , lens >= 4.14 && < 4.19+ , lens-aeson >= 1.0.1 && < 1.2+ , 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.4+ , text >= 1.2.2 && < 1.3+ , time >= 1.6 && < 1.10+ , transformers-base >= 0.4.4 && < 0.5+ , wai >= 3.2.1 && < 3.3+ , wai-extra >= 3.0.19 && < 3.1
src/PostgREST/ApiRequest.hs view
@@ -3,13 +3,14 @@ Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. -} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} module PostgREST.ApiRequest ( ApiRequest(..)+, InvokeMethod(..) , ContentType(..) , Action(..) , Target(..)-, PreferRepresentation (..) , mutuallyAgreeable , userApiRequest ) where@@ -27,7 +28,8 @@ import Control.Arrow ((***)) import Data.Aeson.Types (emptyArray, emptyObject)-import Data.List (last, lookup, partition)+import Data.List (elem, last, lookup, partition)+import Data.List.NonEmpty (NonEmpty, head) import Data.Maybe (fromJust) import Data.Ranged.Ranges (Range (..), emptyRange, rangeIntersection)@@ -47,24 +49,23 @@ rangeLimit, rangeOffset, rangeRequested, restrictRange) import PostgREST.Types-import Protolude+import Protolude hiding (head) type RequestBody = BL.ByteString +data InvokeMethod = InvHead | InvGet | InvPost deriving Eq -- | Types of things a user wants to do to tables/views/procs-data Action = ActionCreate | ActionRead- | ActionUpdate | ActionDelete- | ActionInfo | ActionInvoke{isReadOnly :: Bool}- | ActionInspect | ActionSingleUpsert+data Action = ActionCreate | ActionRead{isHead :: Bool}+ | ActionUpdate | ActionDelete+ | ActionSingleUpsert | ActionInvoke InvokeMethod+ | ActionInfo | ActionInspect{isHead :: Bool} deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier | TargetProc{tpQi :: QualifiedIdentifier, tpIsRootSpec :: Bool}- | TargetDefaultSpec -- The default spec offered at root "/"+ | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/" | TargetUnknown [Text] deriving Eq--- | How to return the inserted data-data PreferRepresentation = Full | HeadersOnly | None deriving Eq {-| Describes what the user wants to do. This data type is a@@ -74,65 +75,61 @@ if it is an action we are able to perform. -} data ApiRequest = ApiRequest {- -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST- iAction :: Action- -- | Requested range of rows within response- , iRange :: M.HashMap ByteString NonnegRange- -- | The target, be it calling a proc or accessing a table- , iTarget :: Target- -- | Content types the client will accept, [CTAny] if no Accept header- , iAccepts :: [ContentType]- -- | Data sent by client and used for mutation actions- , iPayload :: Maybe PayloadJSON- -- | If client wants created items echoed back- , 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- -- | Whether the client wants to UPSERT or ignore records on PK conflict- , iPreferResolution :: Maybe PreferResolution- -- | Filters on the result ("id", "eq.10")- , iFilters :: [(Text, Text)]- -- | &and and &or parameters used for complex boolean logic- , iLogic :: [(Text, Text)]- -- | &select parameter used to shape the response- , iSelect :: Text- -- | &columns parameter used to shape the payload- , iColumns :: Maybe Text- -- | &order parameters for each level- , iOrder :: [(Text, Text)]- -- | Alphabetized (canonical) request query string for response URLs- , iCanonicalQS :: ByteString- -- | JSON Web Token- , iJWT :: Text- -- | HTTP request headers- , iHeaders :: [(Text, Text)]- -- | Request Cookies- , iCookies :: [(Text, Text)]+ iAction :: Action -- ^ Similar but not identical to HTTP verb, e.g. Create/Invoke both POST+ , iRange :: M.HashMap ByteString NonnegRange -- ^ Requested range of rows within response+ , iTopLevelRange :: NonnegRange -- ^ Requested range of rows from the top level+ , iTarget :: Target -- ^ The target, be it calling a proc or accessing a table+ , iAccepts :: [ContentType] -- ^ Content types the client will accept, [CTAny] if no Accept header+ , iPayload :: Maybe PayloadJSON -- ^ Data sent by client and used for mutation actions+ , iPreferRepresentation :: PreferRepresentation -- ^ If client wants created items echoed back+ , iPreferParameters :: Maybe PreferParameters -- ^ How to pass parameters to a stored procedure+ , iPreferCount :: Maybe PreferCount -- ^ Whether the client wants a result count+ , iPreferResolution :: Maybe PreferResolution -- ^ Whether the client wants to UPSERT or ignore records on PK conflict+ , iFilters :: [(Text, Text)] -- ^ Filters on the result ("id", "eq.10")+ , iLogic :: [(Text, Text)] -- ^ &and and &or parameters used for complex boolean logic+ , iSelect :: Maybe Text -- ^ &select parameter used to shape the response+ , iOnConflict :: Maybe Text -- ^ &on_conflict parameter used to upsert on specific unique keys+ , iColumns :: Maybe Text -- ^ &columns parameter used to shape the payload+ , iOrder :: [(Text, Text)] -- ^ &order parameters for each level+ , iCanonicalQS :: ByteString -- ^ Alphabetized (canonical) request query string for response URLs+ , iJWT :: Text -- ^ JSON Web Token+ , iHeaders :: [(Text, Text)] -- ^ HTTP request headers+ , iCookies :: [(Text, Text)] -- ^ Request Cookies+ , iPath :: ByteString -- ^ Raw request path+ , iMethod :: ByteString -- ^ Raw request method+ , iProfile :: Maybe Schema -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/.+ , iSchema :: Schema -- ^ The request schema. Can vary depending on iProfile. } -- | Examines HTTP request and translates it into user intent.-userApiRequest :: Schema -> Maybe QualifiedIdentifier -> Request -> RequestBody -> Either ApiRequestError ApiRequest-userApiRequest schema rootSpec req reqBody- | isTargetingProc && method `notElem` ["GET", "POST"] = Left ActionInappropriate+userApiRequest :: NonEmpty Schema -> Maybe Text -> Request -> RequestBody -> Either ApiRequestError ApiRequest+userApiRequest confSchemas rootSpec req reqBody+ | isJust profile && fromJust profile `notElem` confSchemas = Left $ UnacceptableSchema $ toList confSchemas+ | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate | topLevelRange == emptyRange = Left InvalidRange | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload | otherwise = Right ApiRequest { iAction = action , iTarget = target , iRange = ranges+ , iTopLevelRange = topLevelRange , iAccepts = maybe [CTAny] (map decodeContentType . parseHttpAccept) $ lookupHeader "accept" , iPayload = relevantPayload , iPreferRepresentation = representation- , iPreferSingleObjectParameter = singleObject- , iPreferCount = hasPrefer "count=exact"- , iPreferResolution = if hasPrefer (show MergeDuplicates) then Just MergeDuplicates- else if hasPrefer (show IgnoreDuplicates) then Just IgnoreDuplicates- else Nothing+ , iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject+ | hasPrefer (show MultipleObjects) -> Just MultipleObjects+ | otherwise -> Nothing+ , iPreferCount = if | hasPrefer (show ExactCount) -> Just ExactCount+ | hasPrefer (show PlannedCount) -> Just PlannedCount+ | hasPrefer (show EstimatedCount) -> Just EstimatedCount+ | otherwise -> Nothing+ , iPreferResolution = if | hasPrefer (show MergeDuplicates) -> Just MergeDuplicates+ | hasPrefer (show IgnoreDuplicates) -> Just IgnoreDuplicates+ | otherwise -> Nothing , iFilters = filters , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]- , iSelect = toS $ fromMaybe "*" $ join $ lookup "select" qParams+ , iSelect = toS <$> join (lookup "select" qParams)+ , iOnConflict = toS <$> join (lookup "on_conflict" qParams) , iColumns = columns , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] , iCanonicalQS = toS $ urlEncodeVars@@ -140,8 +137,12 @@ . map (join (***) toS . second (fromMaybe BS.empty)) $ qString , iJWT = tokenStr- , iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hAuthorization, k /= hCookie]+ , iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hCookie] , iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie"+ , iPath = rawPathInfo req+ , iMethod = method+ , iProfile = profile+ , iSchema = schema } where -- queryString with '+' converted to ' '(space)@@ -149,8 +150,10 @@ -- 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, [])+ ActionInvoke InvGet -> partitionFlts+ ActionInvoke InvHead -> partitionFlts+ _ -> (flts, [])+ partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts flts = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v,@@ -163,13 +166,17 @@ isTargetingProc = case target of TargetProc _ _ -> True _ -> False+ isTargetingDefaultSpec = case target of+ TargetDefaultSpec _ -> 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+ columns+ | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)+ | otherwise = Nothing payload = case (contentType, action) of- (_, ActionInvoke{isReadOnly=True}) ->- Right $ ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams)+ (_, ActionInvoke InvGet) -> Right rpcPrmsToJson+ (_, ActionInvoke InvHead) -> Right rpcPrmsToJson (CTApplicationJSON, _) -> if isJust columns then Right $ RawJSON reqBody@@ -186,30 +193,55 @@ Right $ ProcessedJSON (JSON.encode json) PJObject keys (ct, _) -> Left $ toS $ "Content-Type not acceptable: " <> toMime ct- topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges+ rpcPrmsToJson = ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams)+ PJObject (S.fromList $ fst <$> rpcQParams)+ topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows action = case method of- "GET" | target == TargetDefaultSpec -> ActionInspect- | isTargetingProc -> ActionInvoke{isReadOnly=True}- | otherwise -> ActionRead-+ -- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response+ -- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4+ "HEAD" | isTargetingDefaultSpec -> ActionInspect{isHead=True}+ | isTargetingProc -> ActionInvoke InvHead+ | otherwise -> ActionRead{isHead=True}+ "GET" | isTargetingDefaultSpec -> ActionInspect{isHead=False}+ | isTargetingProc -> ActionInvoke InvGet+ | otherwise -> ActionRead{isHead=False} "POST" -> if isTargetingProc- then ActionInvoke{isReadOnly=False}+ then ActionInvoke InvPost else ActionCreate "PATCH" -> ActionUpdate "PUT" -> ActionSingleUpsert "DELETE" -> ActionDelete "OPTIONS" -> ActionInfo- _ -> ActionInspect+ _ -> ActionInspect{isHead=False}++ defaultSchema = head confSchemas+ profile+ | length confSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config+ = Nothing+ | action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionDelete] -- POST/PATCH/PUT/DELETE don't use the same header as per the spec+ = Just $ maybe defaultSchema toS $ lookupHeader "Content-Profile"+ | action `elem` [ActionRead True, ActionRead False, ActionInvoke InvGet, ActionInvoke InvHead, ActionInvoke InvPost,+ ActionInspect False, ActionInspect True, ActionInfo]+ = Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile"+ | otherwise = Nothing+ schema = fromMaybe defaultSchema profile target = case path of [] -> case rootSpec of- Just rsQi -> TargetProc rsQi True- Nothing -> TargetDefaultSpec+ Just pName -> TargetProc (QualifiedIdentifier schema pName) True+ Nothing -> TargetDefaultSpec schema [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}]+ shouldParsePayload =+ action `elem`+ [ActionCreate, ActionUpdate, ActionSingleUpsert,+ ActionInvoke InvPost,+ -- Though ActionInvoke{isGet=True}(a GET /rpc/..) doesn't really have a payload, we use the payload variable as a way+ -- to store the query string arguments to the function.+ ActionInvoke InvGet,+ ActionInvoke InvHead] relevantPayload | shouldParsePayload = rightToMaybe payload | otherwise = Nothing path = pathInfo req@@ -222,11 +254,12 @@ where split :: BS.ByteString -> [Text] split = map T.strip . T.split (==',') . toS- singleObject = hasPrefer "params=single-object" representation- | hasPrefer "return=representation" = Full- | hasPrefer "return=minimal" = None- | otherwise = HeadersOnly+ | hasPrefer (show Full) = Full+ | hasPrefer (show None) = None+ | otherwise = if action == ActionCreate+ then HeadersOnly -- Assume the user wants the Location header(for POST) by default+ else None auth = fromMaybe "" $ lookupHeader hAuthorization tokenStr = case T.split (== ' ') (toS auth) of ("Bearer" : t : _) -> t
src/PostgREST/App.hs view
@@ -1,4 +1,16 @@+{-|+Module : PostgREST.App+Description : PostgREST main application++This module is in charge of mapping HTTP requests to PostgreSQL queries.+Some of its functionality includes:++- Mapping HTTP request methods to proper SQL statements. For example, a GET request is translated to executing a SELECT query in a read-only TRANSACTION.+- Producing HTTP Headers according to RFCs.+- Content Negotiation+-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -15,7 +27,6 @@ import qualified Hasql.Transaction as HT import qualified Hasql.Transaction.Sessions as HT -import Data.Aeson as JSON import Data.Function (id) import Data.IORef (IORef, readIORef) import Data.Time.Clock (UTCTime)@@ -30,26 +41,28 @@ import PostgREST.ApiRequest (Action (..), ApiRequest (..), ContentType (..),- PreferRepresentation (..),- Target (..), mutuallyAgreeable,- userApiRequest)+ InvokeMethod (..), Target (..),+ mutuallyAgreeable, userApiRequest) import PostgREST.Auth (containsRole, jwtClaims, parseSecret) import PostgREST.Config (AppConfig (..))-import PostgREST.DbRequestBuilder (fieldNames, mutateRequest,- readRequest)+import PostgREST.DbRequestBuilder (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,+import PostgREST.QueryBuilder (limitedQuery, mutateRequestToQuery,+ readRequestToCountQuery,+ readRequestToQuery,+ requestToCallProcQuery)+import PostgREST.RangeQuery (allRange, contentRangeH,+ rangeStatusHeader)+import PostgREST.Statements (callProcStatement,+ createExplainStatement, createReadStatement,- createWriteStatement,- requestToCountQuery,- requestToQuery)-import PostgREST.RangeQuery (allRange, rangeOffset)+ createWriteStatement) import PostgREST.Types import Protolude hiding (Proxy, intercalate) @@ -65,8 +78,9 @@ Nothing -> respond . errorResponseFor $ ConnectionLostError Just dbStructure -> do response <- do- -- Need to parse ?columns early because findProc needs it to solve overloaded functions- let apiReq = userApiRequest (configSchema conf) (configRootSpec conf) req body+ -- Need to parse ?columns early because findProc needs it to solve overloaded functions.+ -- TODO: move this logic to the app function+ let apiReq = userApiRequest (configSchemas conf) (configRootSpec conf) req body apiReqCols = (,) <$> apiReq <*> (pRequestColumns =<< iColumns <$> apiReq) case apiReqCols of Left err -> return . errorResponseFor $ err@@ -78,7 +92,7 @@ (Just RawJSON{}, Just cls) -> cls _ -> S.empty proc = case iTarget apiRequest of- TargetProc qi _ -> findProc qi cols (iPreferSingleObjectParameter apiRequest) $ dbProcs dbStructure+ TargetProc qi _ -> findProc qi cols (iPreferParameters apiRequest == Just SingleObject) $ dbProcs dbStructure _ -> Nothing handleReq = runWithClaims conf eClaims (app dbStructure proc cols conf) apiRequest txMode = transactionMode proc (iAction apiRequest)@@ -90,46 +104,57 @@ transactionMode :: Maybe ProcDescription -> Action -> HT.Mode transactionMode proc action = case action of- ActionRead -> HT.Read- ActionInfo -> HT.Read- ActionInspect -> HT.Read- ActionInvoke{isReadOnly=False} ->+ ActionRead _ -> HT.Read+ ActionInfo -> HT.Read+ ActionInspect _ -> HT.Read+ ActionInvoke InvGet -> HT.Read+ ActionInvoke InvHead -> HT.Read+ ActionInvoke InvPost -> 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 -> S.Set FieldName -> AppConfig -> ApiRequest -> H.Transaction Response app dbStructure proc cols conf apiRequest =+ let rawContentTypes = (decodeContentType <$> configRawMediaTypes conf) `L.union` [ CTOctetStream, CTTextPlain ] in case responseContentTypeOrError (iAccepts apiRequest) rawContentTypes (iAction apiRequest) (iTarget apiRequest) of Left errorResponse -> return errorResponse Right contentType -> case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of - (ActionRead, TargetIdent qi, Nothing) ->- let partsField = (,) <$> readSqlParts- <*> (binaryField contentType rawContentTypes =<< fldNames) in- case partsField of+ (ActionRead headersOnly, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) ->+ case readSqlParts tSchema tName of Left errorResponse -> return errorResponse- Right ((q, cq), bField) -> do- let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount- (contentType == CTTextCSV) bField+ Right (q, cq, bField) -> do+ let cQuery = if estimatedCount+ then limitedQuery cq ((+ 1) <$> maxRows) -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed+ else cq+ stm = createReadStatement q cQuery (contentType == CTSingularJSON) shouldCount+ (contentType == CTTextCSV) bField pgVer+ explStm = createExplainStatement cq row <- H.statement () stm- let (tableTotal, queryTotal, _ , body) = row- (status, contentRange) = rangeHeader queryTotal tableTotal- canonical = iCanonicalQS apiRequest- return $- if contentType == CTSingularJSON && queryTotal /= 1- then errorResponseFor . singularityError $ queryTotal- else responseLBS status- [toHeader contentType, contentRange,- ("Content-Location",- "/" <> toS (qiName qi) <>- if BS.null canonical then "" else "?" <> toS canonical- )- ] (toS body)+ let (tableTotal, queryTotal, _ , body, gucHeaders) = row+ case gucHeaders of+ Left _ -> return . errorResponseFor $ GucHeadersError+ Right ghdrs -> do+ total <- if | plannedCount -> H.statement () explStm+ | estimatedCount -> if tableTotal > (fromIntegral <$> maxRows)+ then do estTotal <- H.statement () explStm+ pure $ if estTotal > tableTotal then estTotal else tableTotal+ else pure tableTotal+ | otherwise -> pure tableTotal+ let (status, contentRange) = rangeStatusHeader topLevelRange queryTotal total+ headers = addHeadersIfNotIncluded (catMaybes [+ Just $ toHeader contentType, Just contentRange,+ Just $ contentLocationH tName (iCanonicalQS apiRequest), profileH])+ (unwrapGucHeader <$> ghdrs)+ rBody = if headersOnly then mempty else toS body+ return $+ if contentType == CTSingularJSON && queryTotal /= 1+ then errorResponseFor . singularityError $ queryTotal+ else responseLBS status headers rBody (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> case mutateSqlParts tSchema tName of@@ -138,32 +163,31 @@ let pkCols = tablePKCols dbStructure tSchema tName stm = createWriteStatement sq mq (contentType == CTSingularJSON) True- (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols+ (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols pgVer 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- && queryTotal /= 1- && iPreferRepresentation apiRequest == Full- then do- HT.condemn- return . errorResponseFor . singularityError $ queryTotal- else- return . responseLBS status201 headers $- if iPreferRepresentation apiRequest == Full- then toS body else ""+ let (_, queryTotal, fields, body, gucHeaders) = row+ case gucHeaders of+ Left _ -> return . errorResponseFor $ GucHeadersError+ Right ghdrs -> do+ let+ (ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full+ then ([Just $ toHeader contentType, profileH], toS body)+ else ([], mempty)+ headers = addHeadersIfNotIncluded (catMaybes ([+ if null fields+ then Nothing+ else Just $ locationH tName fields+ , Just $ contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing+ , if null pkCols && isNothing (iOnConflict apiRequest)+ then Nothing+ else (\x -> ("Preference-Applied", show x)) <$> iPreferResolution apiRequest+ ] ++ ctHeaders)) (unwrapGucHeader <$> ghdrs)+ if contentType == CTSingularJSON && queryTotal /= 1+ then do+ HT.condemn+ return . errorResponseFor . singularityError $ queryTotal+ else+ return $ responseLBS status201 headers rBody (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> case mutateSqlParts tSchema tName of@@ -171,31 +195,28 @@ Right (sq, mq) -> do let stm = createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV)- (iPreferRepresentation apiRequest) []+ (iPreferRepresentation apiRequest) [] pgVer row <- H.statement (toS $ pjRaw pJson) stm- let (_, queryTotal, _, body) = extractQueryResult row-- 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-+ let (_, queryTotal, _, body, gucHeaders) = row+ case gucHeaders of+ Left _ -> return . errorResponseFor $ GucHeadersError+ Right ghdrs -> do+ let+ updateIsNoOp = S.null cols+ status | queryTotal == 0 && not updateIsNoOp = status404+ | iPreferRepresentation apiRequest == Full = status200+ | otherwise = status204+ contentRangeHeader = contentRangeH 0 (queryTotal - 1) $ if shouldCount then Just queryTotal else Nothing+ (ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full+ then ([Just $ toHeader contentType, profileH], toS body)+ else ([], mempty)+ headers = addHeadersIfNotIncluded (catMaybes ctHeaders ++ [contentRangeHeader]) (unwrapGucHeader <$> ghdrs)+ if contentType == CTSingularJSON && queryTotal /= 1+ then do+ HT.condemn+ return . errorResponseFor . singularityError $ queryTotal+ else+ return $ responseLBS status headers rBody (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just ProcessedJSON{pjRaw, pjType, pjKeys}) -> case mutateSqlParts tSchema tName of@@ -214,19 +235,22 @@ else do row <- H.statement (toS pjRaw) $ createWriteStatement sq mq (contentType == CTSingularJSON) False- (contentType == CTTextCSV) (iPreferRepresentation apiRequest) []- let (_, queryTotal, _, body) = extractQueryResult row- -- Makes sure the querystring pk matches the payload pk- -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, PUT /items?id=eq.14 { "id" : 2, .. } is rejected- -- If this condition is not satisfied then nothing is inserted, check the WHERE for INSERT in QueryBuilder.hs to see how it's done- if queryTotal /= 1- then do- HT.condemn- return . errorResponseFor $ PutMatchingPkError- else- return $ if iPreferRepresentation apiRequest == Full- then responseLBS status200 [toHeader contentType] (toS body)- else responseLBS status204 [] ""+ (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] pgVer+ let (_, queryTotal, _, body, gucHeaders) = row+ case gucHeaders of+ Left _ -> return . errorResponseFor $ GucHeadersError+ Right ghdrs -> do+ let headers = addHeadersIfNotIncluded (catMaybes [Just $ toHeader contentType, profileH]) (unwrapGucHeader <$> ghdrs)+ (status, rBody) = if iPreferRepresentation apiRequest == Full then (status200, toS body) else (status204, mempty)+ -- Makes sure the querystring pk matches the payload pk+ -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, PUT /items?id=eq.14 { "id" : 2, .. } is rejected+ -- If this condition is not satisfied then nothing is inserted, check the WHERE for INSERT in QueryBuilder.hs to see how it's done+ if queryTotal /= 1+ then do+ HT.condemn+ return . errorResponseFor $ PutMatchingPkError+ else+ return $ responseLBS status headers rBody (ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) -> case mutateSqlParts tSchema tName of@@ -235,65 +259,68 @@ let stm = createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV)- (iPreferRepresentation apiRequest) []+ (iPreferRepresentation apiRequest) [] pgVer row <- H.statement mempty stm- let (_, queryTotal, _, body) = extractQueryResult row- r = contentRangeH 1 0 $- if shouldCount then Just queryTotal else Nothing- if contentType == CTSingularJSON- && queryTotal /= 1- && iPreferRepresentation apiRequest == Full- then do- HT.condemn- return . errorResponseFor . singularityError $ queryTotal- else- return $ if iPreferRepresentation apiRequest == Full- then responseLBS status200 [toHeader contentType, r] (toS body)- else responseLBS status204 [r] ""+ let (_, queryTotal, _, body, gucHeaders) = row+ case gucHeaders of+ Left _ -> return . errorResponseFor $ GucHeadersError+ Right ghdrs -> do+ let+ status = if iPreferRepresentation apiRequest == Full then status200 else status204+ contentRangeHeader = contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing+ (ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full+ then ([Just $ toHeader contentType, profileH], toS body)+ else ([], mempty)+ headers = addHeadersIfNotIncluded (catMaybes ctHeaders ++ [contentRangeHeader]) (unwrapGucHeader <$> ghdrs)+ if contentType == CTSingularJSON+ && queryTotal /= 1+ then do+ HT.condemn+ return . errorResponseFor . singularityError $ queryTotal+ else+ return $ responseLBS status headers rBody (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in case mTable of Nothing -> return notFound Just table ->- let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in- return $ responseLBS status200 [allOrigins, acceptH] ""+ let allowH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET")+ allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in+ return $ responseLBS status200 [allOrigins, allowH] mempty - (ActionInvoke _, TargetProc qi _, Just pJson) ->- let returnsScalar = case proc of- Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True- _ -> False- rpcBinaryField = if returnsScalar- then Right Nothing- else binaryField contentType rawContentTypes =<< fldNames- parts = (,) <$> readSqlParts <*> rpcBinaryField in- case parts of+ (ActionInvoke invMethod, TargetProc qi@(QualifiedIdentifier tSchema pName) _, Just pJson) ->+ let tName = fromMaybe pName $ procTableName =<< proc in+ case readSqlParts tSchema tName of Left errorResponse -> return errorResponse- Right ((q, cq), bField) -> do- 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 `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+ Right (q, cq, bField) -> do+ let+ preferParams = iPreferParameters apiRequest+ pq = requestToCallProcQuery qi (specifiedProcArgs cols proc) returnsScalar preferParams+ stm = callProcStatement returnsScalar pq q cq shouldCount (contentType == CTSingularJSON)+ (contentType == CTTextCSV) (contentType `elem` rawContentTypes) (preferParams == Just MultipleObjects)+ bField pgVer+ row <- H.statement (toS $ pjRaw pJson) stm+ let (tableTotal, queryTotal, body, gucHeaders) = row+ case gucHeaders of Left _ -> return . errorResponseFor $ GucHeadersError- Right hs ->- if singular && queryTotal /= 1+ Right ghdrs -> do+ let (status, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal+ headers = addHeadersIfNotIncluded+ (catMaybes [Just $ toHeader contentType, Just contentRange, profileH])+ (unwrapGucHeader <$> ghdrs)+ rBody = if invMethod == InvHead then mempty else toS body+ if contentType == CTSingularJSON && queryTotal /= 1 then do HT.condemn return . errorResponseFor . singularityError $ queryTotal- else return $ responseLBS status ([toHeader contentType, contentRange] ++ toHeaders hs) (toS body)+ else+ return $ responseLBS status headers rBody - (ActionInspect, TargetDefaultSpec, Nothing) -> do+ (ActionInspect headersOnly, TargetDefaultSpec tSchema, Nothing) -> do let host = configHost conf port = toInteger $ configPort conf- proxy = pickProxy $ toS <$> configProxyUri conf+ proxy = pickProxy $ toS <$> configOpenAPIProxyUri conf uri Nothing = ("http", host, port, "/") uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) uri' = uri proxy@@ -301,43 +328,49 @@ 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+ body <- encodeApi <$>+ H.statement tSchema accessibleTables <*>+ H.statement tSchema schemaDescription <*>+ H.statement tSchema accessibleProcs+ return $ responseLBS status200 (catMaybes [Just $ toHeader CTOpenAPI, profileH]) (if headersOnly then mempty else toS body) _ -> return notFound - where- notFound = responseLBS status404 [] ""- allOrigins = ("Access-Control-Allow-Origin", "*") :: Header- shouldCount = iPreferCount apiRequest- schema = toS $ configSchema conf- topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest- rangeHeader queryTotal tableTotal =- let lower = rangeOffset topLevelRange- upper = lower + toInteger queryTotal - 1- contentRange = contentRangeH lower upper (toInteger <$> tableTotal)- status = rangeStatus lower upper (toInteger <$> tableTotal)- in (status, contentRange)+ where+ notFound = responseLBS status404 [] ""+ maxRows = configMaxRows conf+ exactCount = iPreferCount apiRequest == Just ExactCount+ estimatedCount = iPreferCount apiRequest == Just EstimatedCount+ plannedCount = iPreferCount apiRequest == Just PlannedCount+ shouldCount = exactCount || estimatedCount+ topLevelRange = iTopLevelRange apiRequest+ returnsScalar = maybe False procReturnsScalar proc+ pgVer = pgVersion dbStructure+ profileH = contentProfileH <$> iProfile apiRequest - readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) proc apiRequest- fldNames = fieldNames <$> readReq- readDbRequest = DbRead <$> readReq- 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 <$> mutationDbRequest s t)- rawContentTypes =- (decodeContentType <$> configRawMediaTypes conf) `L.union`- [ CTOctetStream, CTTextPlain ]+ readSqlParts s t =+ let+ readReq = readRequest s t maxRows (dbRelations dbStructure) apiRequest+ in+ (,,) <$>+ (readRequestToQuery <$> readReq) <*>+ (readRequestToCountQuery <$> readReq) <*>+ (binaryField contentType rawContentTypes returnsScalar =<< readReq) + mutateSqlParts s t =+ let+ readReq = readRequest s t maxRows (dbRelations dbStructure) apiRequest+ mutReq = mutateRequest s t apiRequest cols (tablePKCols dbStructure s t) =<< readReq+ in+ (,) <$>+ (readRequestToQuery <$> readReq) <*>+ (mutateRequestToQuery <$> mutReq)+ responseContentTypeOrError :: [ContentType] -> [ContentType] -> Action -> Target -> Either Response ContentType responseContentTypeOrError accepts rawContentTypes action target = serves contentTypesForRequest accepts where contentTypesForRequest = case action of- ActionRead -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]+ ActionRead _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] ++ rawContentTypes ActionCreate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] ActionUpdate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]@@ -345,7 +378,7 @@ ActionInvoke _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] ++ rawContentTypes ++ [CTOpenAPI | tpIsRootSpec target]- ActionInspect -> [CTOpenAPI, CTApplicationJSON]+ ActionInspect _ -> [CTOpenAPI, CTApplicationJSON] ActionInfo -> [CTTextCSV] ActionSingleUpsert -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] serves sProduces cAccepts =@@ -357,41 +390,34 @@ | 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 -> [ContentType]-> [FieldName] -> Either Response (Maybe FieldName)-binaryField ct rawContentTypes fldNames+binaryField :: ContentType -> [ContentType] -> Bool -> ReadRequest -> Either Response (Maybe FieldName)+binaryField ct rawContentTypes isScalarProc readReq+ | isScalarProc = Right Nothing | 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)- where (k, v) = BS.break (== '=') kv--renderLocationFields :: [BS.ByteString] -> BS.ByteString-renderLocationFields fields =- renderSimpleQuery True $ map splitKeyValue fields+ where+ fldNames = fstFieldNames readReq -rangeStatus :: Integer -> Integer -> Maybe Integer -> Status-rangeStatus _ _ Nothing = status200-rangeStatus lower upper (Just total)- | lower > total = status416- | (1 + upper - lower) < total = status206- | otherwise = status200+locationH :: TableName -> [BS.ByteString] -> Header+locationH tName fields =+ let+ locationFields = renderSimpleQuery True $ splitKeyValue <$> fields+ in+ (hLocation, "/" <> toS tName <> locationFields)+ where+ splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)+ splitKeyValue kv =+ let (k, v) = BS.break (== '=') kv+ in (k, BS.tail v) -contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header-contentRangeH lower upper total =- ("Content-Range", headerValue)- where- headerValue = rangeString <> "/" <> totalString- rangeString- | totalNotZero && fromInRange = show lower <> "-" <> show upper- | otherwise = "*"- totalString = maybe "*" show total- totalNotZero = maybe True (0 /=) total- fromInRange = lower <= upper+contentLocationH :: TableName -> ByteString -> Header+contentLocationH tName qString =+ ("Content-Location", "/" <> toS tName <> if BS.null qString then mempty else "?" <> toS qString) -extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount-extractQueryResult = fromMaybe (Nothing, 0, [], "")+contentProfileH :: Schema -> Header+contentProfileH schema =+ ("Content-Profile", toS schema)
src/PostgREST/Config.hs view
@@ -37,6 +37,7 @@ import Control.Monad (fail) import Crypto.JWT (StringOrURI, stringOrUri) import Data.List (lookup)+import Data.List.NonEmpty (NonEmpty, fromList) import Data.Scientific (floatingOrInteger) import Data.Text (dropEnd, dropWhileEnd, intercalate, lines, splitOn,@@ -46,8 +47,10 @@ import Data.Version (versionBranch) import Development.GitRev (gitHash) import Network.Wai.Middleware.Cors (CorsResourcePolicy (..))+import Numeric (readOct) import Paths_postgrest (version) import System.IO.Error (IOError)+import System.Posix.Types (FileMode) import Control.Applicative import Data.Monoid@@ -58,21 +61,22 @@ import PostgREST.Error (ApiRequestError (..)) import PostgREST.Parsers (pRoleClaimKey)-import PostgREST.Types (JSPath, JSPathExp (..),- QualifiedIdentifier (..))+import PostgREST.Types (JSPath, JSPathExp (..)) import Protolude hiding (concat, hPutStrLn, intercalate, null, take, (<>)) + -- | Config file settings for the server data AppConfig = AppConfig { configDatabase :: Text , configAnonRole :: Text- , configProxyUri :: Maybe Text- , configSchema :: Text+ , configOpenAPIProxyUri :: Maybe Text+ , configSchemas :: NonEmpty Text , configHost :: Text , configPort :: Int- , configSocket :: Maybe Text+ , configSocket :: Maybe FilePath+ , configSocketMode :: Either Text FileMode , configJwtSecret :: Maybe B.ByteString , configJwtSecretIsBase64 :: Bool@@ -87,7 +91,7 @@ , configRoleClaimKey :: Either ApiRequestError JSPath , configExtraSearchPath :: [Text] - , configRootSpec :: Maybe QualifiedIdentifier+ , configRootSpec :: Maybe Text , configRawMediaTypes :: [B.ByteString] } @@ -137,7 +141,7 @@ -- Now read the actual config file 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)+ , Handler (\(C.ParseError err) -> exitErr $ "Error parsing config file:\n" <> err) ] case C.runParser parseConfig conf of@@ -147,16 +151,16 @@ return appConf where- dbSchema = reqString "db-schema" parseConfig = AppConfig <$> reqString "db-uri" <*> reqString "db-anon-role" <*> optString "server-proxy-uri"- <*> dbSchema+ <*> (fromList . splitOnCommas <$> reqValue "db-schema") <*> (fromMaybe "!4" <$> optString "server-host") <*> (fromMaybe 3000 <$> optInt "server-port")- <*> optString "server-unix-socket"+ <*> (fmap unpack <$> optString "server-unix-socket")+ <*> parseSocketFileMode "server-unix-socket-mode" <*> (fmap encodeUtf8 <$> optString "jwt-secret") <*> (fromMaybe False <$> optBool "secret-is-base64") <*> parseJwtAudience "jwt-aud"@@ -168,9 +172,22 @@ <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value) <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key") <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path")- <*> ((\x y -> QualifiedIdentifier x <$> y) <$> dbSchema <*> optString "root-spec")+ <*> optString "root-spec" <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types") + parseSocketFileMode :: C.Key -> C.Parser C.Config (Either Text FileMode)+ parseSocketFileMode k =+ C.optional k C.string >>= \case+ Nothing -> pure $ Right 432 -- return default 660 mode if no value was provided+ Just fileModeText ->+ case (readOct . unpack) fileModeText of+ [] ->+ pure $ Left "Invalid server-unix-socket-mode: not an octal"+ (fileMode, _):_ ->+ if fileMode < 384 || fileMode > 511+ then pure $ Left "Invalid server-unix-socket-mode: needs to be between 600 and 777"+ else pure $ Right fileMode+ parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI) parseJwtAudience k = C.optional k C.string >>= \case@@ -183,6 +200,9 @@ reqString :: C.Key -> C.Parser C.Config Text reqString k = C.required k C.string + reqValue :: C.Key -> C.Parser C.Config C.Value+ reqValue k = C.required k C.value+ optString :: C.Key -> C.Parser C.Config (Maybe Text) optString k = mfilter (/= "") <$> C.optional k C.string @@ -250,13 +270,16 @@ |## unix socket location |## if specified it takes precedence over server-port |# server-unix-socket = "/tmp/pgrst.sock"+ |## unix socket file mode+ |## when none is provided, 660 is applied by default+ |# server-unix-socket-mode = "660" | |## base url for swagger output- |# server-proxy-uri = ""+ |# openapi-server-proxy-uri = "" | |## choose a secret, JSON Web Key (or set) to enable JWT auth |## (use "@filename" to load from separate file)- |# jwt-secret = "foo"+ |# jwt-secret = "secret_with_at_least_32_characters" |# secret-is-base64 = false |# jwt-aud = "your_audience_claim" |
src/PostgREST/DbRequestBuilder.hs view
@@ -14,249 +14,218 @@ module PostgREST.DbRequestBuilder ( readRequest , mutateRequest-, fieldNames ) where -import qualified Data.ByteString.Char8 as BS-import qualified Data.HashMap.Strict as M-import qualified Data.Set as S+import qualified Data.HashMap.Strict as M+import qualified Data.Set as S 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 Control.Applicative import Data.Tree import Network.Wai -import PostgREST.ApiRequest (Action (..), ApiRequest (..),- PreferRepresentation (..),- PreferRepresentation (..), Target (..))+import PostgREST.ApiRequest (Action (..), ApiRequest (..)) 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 =+readRequest :: Schema -> TableName -> Maybe Integer -> [Relation] -> ApiRequest -> Either Response ReadRequest+readRequest schema rootTableName maxRows allRels apiRequest = mapLeft errorResponseFor $ treeRestrictRange maxRows =<<- augumentRequestWithJoin schema relations =<<+ augumentRequestWithJoin schema rootRels =<< addFiltersOrdersRanges apiRequest <*>- (buildReadRequest <$> pRequestSelect (iSelect apiRequest))+ (initReadRequest rootName <$> pRequestSelect sel) where- action = iAction apiRequest- (schema, rootTableName) = fromJust $ -- Make it safe- let target = iTarget apiRequest in- case target of- (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)- (TargetProc (QualifiedIdentifier s pName) _ ) -> Just (s, tName)- where- tName = case pdReturnType <$> proc of- Just (SetOf (Composite qi)) -> qiName qi- Just (Single (Composite qi)) -> qiName qi- _ -> pName-- _ -> Nothing-- -- Build tree with a Depth attribute so when a self join occurs we can differentiate the parent and child tables by having- -- an alias like "table_depth", this is related to issue #987.- buildReadRequest :: [Tree SelectItem] -> ReadRequest- buildReadRequest fieldTree =- let rootDepth = 0- rootNodeName = if action == ActionRead then rootTableName else sourceCTEName in- 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) =- let nxtDepth = succ depth in- case fldForest of- [] -> Node (q {select=fld:select q}, i) rForest- _ -> Node (q, i) $- foldr (treeEntry nxtDepth) (Node (Select [] fn Nothing [] [] [] [] allRange, (fn, Nothing, alias, relationDetail, nxtDepth)) []) fldForest:rForest+ sel = fromMaybe "*" $ iSelect apiRequest -- default to all columns requested (SELECT *) for a non existent ?select querystring param+ (rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest) - relations :: [Relation]- relations = case action of- ActionCreate -> fakeSourceRelations ++ allRels- ActionUpdate -> fakeSourceRelations ++ allRels- ActionDelete -> fakeSourceRelations ++ allRels- ActionInvoke _ -> fakeSourceRelations ++ allRels- _ -> allRels- where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels+-- Get the root table name with its relationships according to the Action type.+-- This is done because of the shape of the final SQL Query. The mutation cases are wrapped in a WITH {sourceCTEName}(see Statements.hs).+-- So we need a FROM {sourceCTEName} instead of FROM {tableName}.+rootWithRels :: Schema -> TableName -> [Relation] -> Action -> (QualifiedIdentifier, [Relation])+rootWithRels schema rootTableName allRels action = case action of+ ActionRead _ -> (QualifiedIdentifier schema rootTableName, allRels) -- normal read case+ _ -> (QualifiedIdentifier mempty sourceCTEName, mapMaybe toSourceRel allRels ++ allRels) -- mutation cases and calling proc+ where+ -- To enable embedding in the sourceCTEName cases we need to replace the foreign key tableName in the Relation+ -- with {sourceCTEName}. This way findRel can find relationships with sourceCTEName.+ toSourceRel :: Relation -> Maybe Relation+ toSourceRel r@Relation{relTable=t}+ | rootTableName == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}+ | otherwise = Nothing --- in a relation where one of the tables matches "TableName"--- replace the name to that table with pg_source--- this "fake" relations is needed so that in a mutate query--- we can look at the "returning *" part which is wrapped with a "with"--- as just another table that has relations with other tables-toSourceRelation :: TableName -> Relation -> Maybe Relation-toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)- | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}- | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}- | Just mt == (tableName <$> rt) = Just $ r {relLinkTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}- | otherwise = Nothing+-- Build the initial tree with a Depth attribute so when a self join occurs we can differentiate the parent and child tables by having+-- an alias like "table_depth", this is related to http://github.com/PostgREST/postgrest/issues/987.+initReadRequest :: QualifiedIdentifier -> [Tree SelectItem] -> ReadRequest+initReadRequest rootQi =+ foldr (treeEntry rootDepth) initial+ where+ rootDepth = 0+ rootSchema = qiSchema rootQi+ rootName = qiName rootQi+ initial = Node (Select [] rootQi Nothing [] [] [] [] allRange, (rootName, Nothing, Nothing, Nothing, rootDepth)) []+ treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest+ treeEntry depth (Node fld@((fn, _),_,alias, embedHint) fldForest) (Node (q, i) rForest) =+ let nxtDepth = succ depth in+ case fldForest of+ [] -> Node (q {select=fld:select q}, i) rForest+ _ -> Node (q, i) $+ foldr (treeEntry nxtDepth)+ (Node (Select [] (QualifiedIdentifier rootSchema fn) Nothing [] [] [] [] allRange,+ (fn, Nothing, alias, embedHint, nxtDepth)) [])+ fldForest:rForest treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest-treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request+treeRestrictRange maxRows request = pure $ nodeRestrictRange maxRows <$> request where nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) -augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest+augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest augumentRequestWithJoin schema allRels request =- addRelations schema allRels Nothing request- >>= addJoinConditions schema Nothing+ addRels schema allRels Nothing request+ >>= addJoinConditions Nothing -addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest-addRelations schema allRelations parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, relationDetail, depth)) forest) =+addRels :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest+addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, hint, depth)) forest) = case parentNode of- Just (Node (Select{from=parentNodeTable}, _) _) ->- let newFrom r = if tbl == nodeName then tableName (relTable r) else tbl+ Just (Node (Select{from=parentNodeQi}, _) _) ->+ let newFrom r = if qiName tbl == nodeName then tableQi (relFTable 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) $- findRelation schema allRelations nodeName parentNodeTable relationDetail in+ rel = findRel schema allRels (qiName parentNodeQi) nodeName hint+ in Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest) _ ->- let rn = (query, (nodeName, Just r, alias, Nothing, depth))- r = Relation t [] t [] Root Nothing Nothing Nothing- t = Table schema nodeName Nothing True in -- !!! TODO find another way to get the table from the query+ let rn = (query, (nodeName, Nothing, alias, Nothing, depth)) in Node rn <$> updateForest (Just $ Node rn forest) where updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]- updateForest rq = mapM (addRelations schema allRelations rq) forest--findRelation :: Schema -> [Relation] -> NodeName -> TableName -> Maybe RelationDetail -> Maybe Relation-findRelation schema allRelations nodeTableName parentNodeTableName relationDetail =- find (\Relation{relTable, relColumns, relFTable, relFColumns, relType, relLinkTable} ->- -- Both relation ends need to be on the exposed schema- schema == tableSchema relTable && schema == tableSchema relFTable &&- case relationDetail of- Nothing ->-- -- (request) => projects { ..., clients{...} }- -- will match- -- (relation type) => parent- -- (entity) => clients {id}- -- (foriegn entity) => projects {client_id}- (- nodeTableName == tableName relTable && -- match relation table name- parentNodeTableName == tableName relFTable -- match relation foreign table name- ) ||+ updateForest rq = mapM (addRels schema allRels rq) forest - -- (request) => projects { ..., client_id{...} }- -- will match- -- (relation type) => parent- -- (entity) => clients {id}- -- (foriegn entity) => projects {client_id}+-- Finds a relationship between an origin and a target in the request: /origin?select=target(*)+-- If more than one relationship is found then the request is ambiguous and we return an error.+-- In that case the request can be disambiguated by adding precision to the target or by using a hint: /origin?select=target!hint(*)+-- The elements will be matched according to these rules:+-- origin = table / view+-- target = table / view / constraint / column-from-origin+-- hint = table / view / constraint / column-from-origin / column-from-target+-- (hint can take table / view values to aid in finding the junction in an m2m relationship)+findRel :: Schema -> [Relation] -> NodeName -> NodeName -> Maybe EmbedHint -> Either ApiRequestError Relation+findRel schema allRels origin target hint =+ case rel of+ [] -> Left $ NoRelBetween origin target+ [r] -> Right r+ rs ->+ -- Return error if more than one relationship is found, unless we're in a self reference case.+ --+ -- Here we handle a self reference relationship to not cause a breaking change:+ -- In a self reference we get two relationships with the same foreign key and relTable/relFtable but with different cardinalities(m2o/o2m)+ -- We output the O2M rel, the M2O rel can be obtained by using the origin column as an embed hint.+ let [rel0, rel1] = take 2 rs in+ if length rs == 2 && relConstraint rel0 == relConstraint rel1 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1+ then note (NoRelBetween origin target) (find (\r -> relType r == O2M) rs)+ else Left $ AmbiguousRelBetween origin target rs+ where+ matchFKSingleCol hint_ cols = length cols == 1 && hint_ == (colName <$> head cols)+ rel = filter (+ \Relation{relTable, relColumns, relConstraint, relFTable, relFColumns, relType, relJunction} ->+ -- Both relationship ends need to be on the exposed schema+ schema == tableSchema relTable && schema == tableSchema relFTable && (- parentNodeTableName == tableName relFTable &&- length relFColumns == 1 &&- -- match common foreign key names(table_name_id, table_name_fk) to table_name- (toS ("^" <> colName (unsafeHead relFColumns) <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS nodeTableName :: BS.ByteString)- )-- -- (request) => project_id { ..., client_id{...} }- -- will match- -- (relation type) => parent- -- (entity) => clients {id}- -- (foriegn entity) => projects {client_id}- -- this case works becasue before reaching this place- -- addRelation will turn project_id to project so the above condition will match+ -- /projects?select=clients(*)+ origin == tableName relTable && -- projects+ target == tableName relFTable || -- clients - Just rd ->+ -- /projects?select=projects_client_id_fkey(*)+ (+ origin == tableName relTable && -- projects+ Just target == relConstraint -- projects_client_id_fkey+ ) ||+ -- /projects?select=client_id(*)+ (+ origin == tableName relTable && -- projects+ matchFKSingleCol (Just target) relColumns -- client_id+ )+ ) && (+ isNothing hint || -- hint is optional - -- (request) => clients { ..., projects.client_id{...} }- -- will match- -- (relation type) => child- -- (entity) => clients {id}- -- (foriegn entity) => projects {client_id}- (- relType == Child &&- nodeTableName == tableName relTable && -- match relation table name- parentNodeTableName == tableName relFTable && -- match relation foreign table name- length relColumns == 1 &&- rd == colName (unsafeHead relColumns)- ) ||+ -- /projects?select=clients!projects_client_id_fkey(*)+ hint == relConstraint || -- projects_client_id_fkey - -- (request) => message { ..., person_detail.sender{...} }- -- will match- -- (relation type) => parent- -- (entity) => message {sender}- -- (foriegn entity) => person_detail {id}- (- relType == Parent &&- nodeTableName == tableName relTable && -- match relation table name- parentNodeTableName == tableName relFTable && -- match relation foreign table name- length relFColumns == 1 &&- rd == colName (unsafeHead relFColumns)- ) ||+ -- /projects?select=clients!client_id(*) or /projects?select=clients!id(*)+ matchFKSingleCol hint relColumns || -- client_id+ matchFKSingleCol hint relFColumns || -- id - -- (request) => tasks { ..., users.tasks_users{...} }- -- will match- -- (relation type) => many- -- (entity) => users- -- (foriegn entity) => tasks- (- relType == Many &&- nodeTableName == tableName relTable && -- match relation table name- parentNodeTableName == tableName relFTable && -- match relation foreign table name- rd == tableName (fromJust relLinkTable)+ -- /users?select=tasks!users_tasks(*)+ (+ relType == M2M && -- many-to-many between users and tasks+ hint == (tableName . junTable <$> relJunction) -- users_tasks+ ) )- ) allRelations+ ) allRels -- 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 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{implicitJoins=tableName linkTable:implicitJoins rq}, nodeProps) <$> updatedForest- _ -> Left UnknownRelation+addJoinConditions :: Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest+addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, rel, _, _, depth)) forest) =+ case rel of+ Just r@Relation{relType=O2M} -> Node (augmentQuery r, nodeProps) <$> updatedForest+ Just r@Relation{relType=M2O} -> Node (augmentQuery r, nodeProps) <$> updatedForest+ Just r@Relation{relType=M2M, relJunction=junction} ->+ case junction of+ Just Junction{junTable} ->+ let rq = augmentQuery r in+ Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest+ Nothing ->+ Left UnknownRelation+ Nothing -> Node node <$> updatedForest where- newAlias = case isSelfJoin <$> relation of+ newAlias = case isSelfReference <$> rel of Just True- | depth /= 0 -> Just (tbl <> "_" <> show depth) -- root node doesn't get aliased+ | depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased | otherwise -> Nothing _ -> Nothing- augmentQuery rel =+ augmentQuery r = foldr (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs}) query{fromAlias=newAlias}- (getJoinConditions previousAlias newAlias rel)- updatedForest = mapM (addJoinConditions schema newAlias) forest+ (getJoinConditions previousAlias newAlias r)+ updatedForest = mapM (addJoinConditions newAlias) forest -- 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) =+getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, tableName=tN} cols _ Table{tableName=ftN} fCols typ jun) = case typ of- Child ->+ O2M -> zipWith (toJoinCondition tN ftN) cols fCols- Parent ->+ M2O -> 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)- Root -> witness+ M2M -> case jun of+ Just (Junction jt _ jc1 _ jc2) ->+ let jtn = tableName jt in+ zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2+ Nothing -> [] where toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition toJoinCondition tb ftb c 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)+ let qi1 = removeSourceCTESchema tSchema tb+ qi2 = removeSourceCTESchema tSchema ftb in+ JoinCondition (maybe qi1 (QualifiedIdentifier mempty) previousAlias, colName c)+ (maybe qi2 (QualifiedIdentifier mempty) newAlias, colName fc) + -- On mutation and calling proc cases we wrap the target table in a WITH {sourceCTEName}+ -- if this happens remove the schema `FROM "schema"."{sourceCTEName}"` and use only the+ -- `FROM "{sourceCTEName}"`. If the schema remains the FROM would be invalid.+ removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier+ removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then mempty else schema) tbl+ addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest) addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ flip (foldr addFilter) <$> filters,@@ -266,7 +235,7 @@ ] {- The esence of what is going on above is that we are composing tree functions- of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context+ of type (ReadRequest->ReadRequest) that are in (Either ApiRequestError a) context -} where filters :: Either ApiRequestError [(EmbedPath, Filter)]@@ -278,7 +247,7 @@ (flts, logFrst) = case action of ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest)- ActionRead -> (iFilters apiRequest, iLogic apiRequest)+ ActionRead _ -> (iFilters apiRequest, iLogic apiRequest) _ -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest) orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])] orders = mapM pRequestOrder $ iOrder apiRequest@@ -318,11 +287,15 @@ where pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest -mutateRequest :: ApiRequest -> TableName -> S.Set FieldName -> [FieldName] -> [FieldName] -> Either Response MutateRequest-mutateRequest apiRequest tName cols pkCols fldNames = mapLeft errorResponseFor $+mutateRequest :: Schema -> TableName -> ApiRequest -> S.Set FieldName -> [FieldName] -> ReadRequest -> Either Response MutateRequest+mutateRequest schema tName apiRequest cols pkCols readReq = mapLeft errorResponseFor $ case action of- ActionCreate -> Right $ Insert tName cols ((,) <$> iPreferResolution apiRequest <*> Just pkCols) [] returnings- ActionUpdate -> Update tName cols <$> combinedLogic <*> pure returnings+ ActionCreate -> do+ confCols <- case iOnConflict apiRequest of+ Nothing -> pure pkCols+ Just param -> pRequestOnConflict param+ pure $ Insert qi cols ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings+ ActionUpdate -> Update qi cols <$> combinedLogic <*> pure returnings ActionSingleUpsert -> (\flts -> if null (iLogic apiRequest) &&@@ -331,14 +304,18 @@ all (\case Filter _ (OpExpr False (Op "eq" _)) -> True _ -> False) flts- then Insert tName cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings+ then Insert qi cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings else Left InvalidFilters) =<< filters- ActionDelete -> Delete tName <$> combinedLogic <*> pure returnings+ ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings _ -> Left UnsupportedVerb where+ qi = QualifiedIdentifier schema tName action = iAction apiRequest- returnings = if iPreferRepresentation apiRequest == None then [] else fldNames+ returnings =+ if iPreferRepresentation apiRequest == None+ then []+ else returningCols readReq filters = map snd <$> mapM pRequestFilter mutateFilters logic = map snd <$> mapM pRequestLogicTree logicFilters combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters@@ -346,13 +323,26 @@ (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest) onlyRoot = filter (not . ( "." `isInfixOf` ) . fst) -fieldNames :: ReadRequest -> [FieldName]-fieldNames (Node (sel, _) forest) =- map (fst . view _1) (select sel) ++ map colName fks+returningCols :: ReadRequest -> [FieldName]+returningCols rr@(Node _ forest) = returnings where- fks = concatMap (fromMaybe [] . f) forest- f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _, _, _)) _) = Just cols- f _ = Nothing+ fldNames = fstFieldNames rr+ -- Without fkCols, when a mutateRequest to /projects?select=name,clients(name) occurs, the RETURNING SQL part would be+ -- `RETURNING name`(see QueryBuilder).+ -- This would make the embedding fail because the following JOIN would need the "client_id" column from projects.+ -- So this adds the foreign key columns to ensure the embedding succeeds, result would be `RETURNING name, client_id`.+ -- This also works for the other relType's.+ fkCols = concat $ mapMaybe (\case+ Node (_, (_, Just Relation{relColumns=cols, relType=relTyp}, _, _, _)) _ -> case relTyp of+ O2M -> Just cols+ M2O -> Just cols+ M2M -> Just cols+ _ -> Nothing+ ) forest+ -- However if the "client_id" is present, e.g. mutateRequest to /projects?select=client_id,name,clients(name)+ -- we would get `RETURNING client_id, name, client_id` and then we would produce the "column reference \"client_id\" is ambiguous"+ -- error from PostgreSQL. So we deduplicate with Set:+ returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols) -- Traditional filters(e.g. id=eq.1) are added as root nodes of the LogicTree -- they are later concatenated with AND in the QueryBuilder
src/PostgREST/DbStructure.hs view
@@ -40,34 +40,23 @@ import Control.Applicative +import PostgREST.Private.Common 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- tabs <- HT.statement () allTables- cols <- HT.statement schema $ allColumns tabs- syns <- HT.statement schema $ allSynonyms cols pgVer- childRels <- HT.statement () $ allChildRelations tabs cols- keys <- HT.statement () $ allPrimaryKeys tabs- procs <- HT.statement schema allProcs+getDbStructure :: [Schema] -> PgVersion -> HT.Transaction DbStructure+getDbStructure schemas pgVer = do+ HT.sql "set local schema ''" -- This voids the search path. The following queries need this for getting the fully qualified name(schema.name) of every db object+ tabs <- HT.statement () allTables+ cols <- HT.statement schemas $ allColumns tabs+ srcCols <- HT.statement schemas $ allSourceColumns cols pgVer+ m2oRels <- HT.statement () $ allM2ORels tabs cols+ keys <- HT.statement () $ allPrimaryKeys tabs+ procs <- HT.statement schemas allProcs - let rels = addManyToManyRelations . addParentRelations $ addViewChildRelations syns childRels+ let rels = addM2MRels . addO2MRels $ addViewM2ORels srcCols m2oRels cols' = addForeignKeys rels cols- keys' = addViewPrimaryKeys syns keys+ keys' = addViewPrimaryKeys srcCols keys return DbStructure { dbTables = tabs@@ -102,13 +91,14 @@ <*> nullableColumn HD.text <*> nullableColumn HD.text -decodeRelations :: [Table] -> [Column] -> HD.Result [Relation]-decodeRelations tables cols =- mapMaybe (relationFromRow tables cols) <$> HD.rowList relRow+decodeRels :: [Table] -> [Column] -> HD.Result [Relation]+decodeRels tables cols =+ mapMaybe (relFromRow tables cols) <$> HD.rowList relRow where- relRow = (,,,,,)+ relRow = (,,,,,,) <$> column HD.text <*> column HD.text+ <*> column HD.text <*> column (HD.array (HD.dimension replicateM (element HD.text))) <*> column HD.text <*> column HD.text@@ -120,22 +110,30 @@ where pkRow = (,,) <$> column HD.text <*> column HD.text <*> column HD.text -decodeSynonyms :: [Column] -> HD.Result [Synonym]-decodeSynonyms cols =- mapMaybe (synonymFromRow cols) <$> HD.rowList synRow+decodeSourceColumns :: [Column] -> HD.Result [SourceColumn]+decodeSourceColumns cols =+ mapMaybe (sourceColumnFromRow cols) <$> HD.rowList srcColRow where- synRow = (,,,,,)+ srcColRow = (,,,,,) <$> 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])+sourceColumnFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe SourceColumn+sourceColumnFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2+ where+ col1 = findCol s1 t1 c1+ col2 = findCol s2 t2 c2+ findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols++decodeProcs :: HD.Result ProcsMap decodeProcs = -- Duplicate rows for a function means they're overloaded, order these by least args according to ProcDescription Ord instance- map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowList tblRow+ map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addKey) <$> HD.rowList procRow where- tblRow = ProcDescription+ procRow = ProcDescription <$> column HD.text+ <*> column HD.text <*> nullableColumn HD.text <*> (parseArgs <$> column HD.text) <*> (parseRetType@@ -145,8 +143,8 @@ <*> column HD.char) <*> (parseVolatility <$> column HD.char) - addName :: ProcDescription -> (Text, ProcDescription)- addName pd = (pdName pd, pd)+ addKey :: ProcDescription -> (QualifiedIdentifier, ProcDescription)+ addKey pd = (QualifiedIdentifier (pdSchema pd) (pdName pd), pd) parseArgs :: Text -> [PgArg] parseArgs = mapMaybe parseArg . filter (not . isPrefixOf "OUT" . toS) . map strip . split (==',')@@ -179,31 +177,34 @@ | v == 's' = Stable | otherwise = Volatile -- only 'v' can happen here -allProcs :: H.Statement Schema (M.HashMap Text [ProcDescription])-allProcs = H.Statement (toS procsSqlQuery) (param HE.text) decodeProcs True+allProcs :: H.Statement [Schema] ProcsMap+allProcs = H.Statement (toS sql) (arrayParam HE.text) decodeProcs True+ where+ sql = procsSqlQuery <> " WHERE pn.nspname = ANY($1)" -accessibleProcs :: H.Statement Schema (M.HashMap Text [ProcDescription])+accessibleProcs :: H.Statement Schema ProcsMap accessibleProcs = H.Statement (toS sql) (param HE.text) decodeProcs True where- sql = procsSqlQuery <> " AND has_function_privilege(p.oid, 'execute')"+ sql = procsSqlQuery <> " WHERE pn.nspname = $1 AND has_function_privilege(p.oid, 'execute')" procsSqlQuery :: SqlQuery procsSqlQuery = [q|- SELECT p.proname as "proc_name",- d.description as "proc_description",- pg_get_function_arguments(p.oid) as "args",- tn.nspname as "rettype_schema",- coalesce(comp.relname, t.typname) as "rettype_name",- p.proretset as "rettype_is_setof",- t.typtype as "rettype_typ",- p.provolatile+ SELECT+ pn.nspname as "proc_schema",+ p.proname as "proc_name",+ d.description as "proc_description",+ pg_get_function_arguments(p.oid) as "args",+ tn.nspname as "rettype_schema",+ coalesce(comp.relname, t.typname) as "rettype_name",+ p.proretset as "rettype_is_setof",+ t.typtype as "rettype_typ",+ p.provolatile FROM pg_proc p JOIN pg_namespace pn ON pn.oid = p.pronamespace JOIN pg_type t ON t.oid = p.prorettype JOIN pg_namespace tn ON tn.oid = t.typnamespace LEFT JOIN pg_class comp ON comp.oid = t.typrelid LEFT JOIN pg_catalog.pg_description as d on d.objoid = p.oid- WHERE pn.nspname = $1 |] schemaDescription :: H.Statement Schema (Maybe Text)@@ -254,20 +255,20 @@ addFk col = col { colFK = fk col } fk col = find (lookupFn col) rels >>= relToFk col lookupFn :: Column -> Relation -> Bool- lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child+ lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==M2O relToFk col Relation{relColumns=cols, relFColumns=colsF} = do pos <- L.elemIndex col cols colF <- atMay colsF pos return $ ForeignKey colF {--Adds Views Child Relations based on Synonyms found, the logic is as follows:+Adds Views M2O Relations based on SourceColumns found, the logic is as follows: -Having a Relation{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relType=Child} represented by:+Having a Relation{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relType=M2O} represented by: t1.c1------t2.c2 -When only having a t1_view.c1 synonym, we need to add a View to Table Child Relation+When only having a t1_view.c1 source column, we need to add a View-Table M2O Relation t1.c1----t2.c2 t1.c1----------t2.c2 -> ________/@@ -275,70 +276,72 @@ t1_view.c1 t1_view.c1 -When only having a t2_view.c2 synonym, we need to add a Table to View Child Relation+When only having a t2_view.c2 source column, we need to add a Table-View M2O Relation t1.c1----t2.c2 t1.c1----------t2.c2 -> \________ \ t2_view.c2 t2_view.c1 -When having t1_view.c1 and a t2_view.c2 synonyms, we need to add a View to View Child Relation in addition to the prior+When having t1_view.c1 and a t2_view.c2 source columns, we need to add a View-View M2O Relation in addition to the prior t1.c1----t2.c2 t1.c1----------t2.c2 -> \________/ / \ t1_view.c1 t2_view.c2 t1_view.c1-------t2_view.c1 -The logic for composite pks is similar just need to make sure all the Relation columns have synonyms.+The logic for composite pks is similar just need to make sure all the Relation columns have source columns. -}-addViewChildRelations :: [Synonym] -> [Relation] -> [Relation]-addViewChildRelations allSyns = concatMap (\rel ->+addViewM2ORels :: [SourceColumn] -> [Relation] -> [Relation]+addViewM2ORels allSrcCols = concatMap (\rel -> rel : case rel of- Relation{relType=Child, relTable, relColumns, relFTable, relFColumns} ->+ Relation{relType=M2O, relTable, relColumns, relConstraint, relFTable, relFColumns} -> - let colSynsGroupedByView :: [Column] -> [[Synonym]]- colSynsGroupedByView relCols = L.groupBy (\(_, viewCol1) (_, viewCol2) -> colTable viewCol1 == colTable viewCol2) $- filter (\(c, _) -> c `elem` relCols) allSyns- colsSyns = colSynsGroupedByView relColumns- fColsSyns = colSynsGroupedByView relFColumns- getView :: [Synonym] -> Table+ let srcColsGroupedByView :: [Column] -> [[SourceColumn]]+ srcColsGroupedByView relCols = L.groupBy (\(_, viewCol1) (_, viewCol2) -> colTable viewCol1 == colTable viewCol2) $+ filter (\(c, _) -> c `elem` relCols) allSrcCols+ relSrcCols = srcColsGroupedByView relColumns+ relFSrcCols = srcColsGroupedByView relFColumns+ getView :: [SourceColumn] -> Table getView = colTable . snd . unsafeHead- syns `allSynsOf` cols = S.fromList (fst <$> syns) == S.fromList cols+ srcCols `allSrcColsOf` cols = S.fromList (fst <$> srcCols) == S.fromList cols -- 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+ -- So we need to change the order of the SourceColumns to match the relColumns+ -- TODO: This could be avoided if the Relation type is improved with a structure that maintains the association of relColumns and relFColumns+ srcCols `sortAccordingTo` cols = sortOn (\(k, _) -> L.lookup k $ zip cols [0::Int ..]) srcCols - viewTableChild =- [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns)- relFTable relFColumns- Child Nothing Nothing Nothing- | syns <- colsSyns, syns `allSynsOf` relColumns ]+ viewTableM2O =+ [ Relation (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)+ relConstraint relFTable relFColumns+ M2O Nothing+ | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns ] - tableViewChild =+ tableViewM2O = [ Relation relTable relColumns- (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns)- Child Nothing Nothing Nothing- | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ]+ relConstraint+ (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns)+ M2O Nothing+ | fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` 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 ]+ viewViewM2O =+ [ Relation (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)+ relConstraint+ (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns)+ M2O Nothing+ | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns+ , fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relFColumns ] - in viewTableChild ++ tableViewChild ++ viewViewChild+ in viewTableM2O ++ tableViewM2O ++ viewViewM2O _ -> []) -addParentRelations :: [Relation] -> [Relation]-addParentRelations = concatMap (\rel@(Relation t c ft fc _ _ _ _) -> [rel, Relation ft fc t c Parent Nothing Nothing Nothing])+addO2MRels :: [Relation] -> [Relation]+addO2MRels = concatMap (\rel@(Relation t c cn ft fc _ _) -> [rel, Relation ft fc cn t c O2M Nothing]) -addManyToManyRelations :: [Relation] -> [Relation]-addManyToManyRelations rels = rels ++ addMirrorRelation (mapMaybe link2Relation links)+addM2MRels :: [Relation] -> [Relation]+addM2MRels rels = rels ++ addMirrorRel (mapMaybe junction2Rel junctions) where- links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels+ junctions = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==M2O). relType) rels groupFn :: Relation -> Text groupFn Relation{relTable=Table{tableSchema=s, tableName=t}} = s <> "_" <> t -- Reference : https://wiki.haskell.org/99_questions/Solutions/26@@ -346,19 +349,20 @@ combinations 0 _ = [ [] ] combinations n xs = [ y:ys | y:xs' <- tails xs , ys <- combinations (n-1) xs']- addMirrorRelation = concatMap (\rel@(Relation t c ft fc _ lt lc1 lc2) -> [rel, Relation ft fc t c Many lt lc2 lc1])- link2Relation [- Relation{relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c},- Relation{ relColumns=lc2, relFTable=ft, relFColumns=fc}+ junction2Rel [+ Relation{relTable=jt, relColumns=jc1, relConstraint=const1, relFTable=t, relFColumns=c},+ Relation{ relColumns=jc2, relConstraint=const2, relFTable=ft, relFColumns=fc} ]- | lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation t c ft fc Many (Just lt) (Just lc1) (Just lc2)+ | jc1 /= jc2 && length jc1 == 1 && length jc2 == 1 = Just $ Relation t c Nothing ft fc M2M (Just $ Junction jt const1 jc1 const2 jc2) | otherwise = Nothing- link2Relation _ = Nothing+ junction2Rel _ = Nothing+ addMirrorRel = concatMap (\rel@(Relation t c _ ft fc _ (Just (Junction jt const1 jc1 const2 jc2))) ->+ [rel, Relation ft fc Nothing t c M2M (Just (Junction jt const2 jc2 const1 jc1))]) -addViewPrimaryKeys :: [Synonym] -> [PrimaryKey] -> [PrimaryKey]-addViewPrimaryKeys syns = concatMap (\pk ->+addViewPrimaryKeys :: [SourceColumn] -> [PrimaryKey] -> [PrimaryKey]+addViewPrimaryKeys srcCols = concatMap (\pk -> let viewPks = (\(_, viewCol) -> PrimaryKey{pkTable=colTable viewCol, pkName=colName viewCol}) <$>- filter (\(col, _) -> colTable col == pkTable pk && colName col == pkName pk) syns in+ filter (\(col, _) -> colTable col == pkTable pk && colName col == pkName pk) srcCols in pk : viewPks) allTables :: H.Statement () [Table]@@ -384,9 +388,9 @@ GROUP BY table_schema, table_name, insertable ORDER BY table_schema, table_name |] -allColumns :: [Table] -> H.Statement Schema [Column]+allColumns :: [Table] -> H.Statement [Schema] [Column] allColumns tabs =- H.Statement sql (param HE.text) (decodeColumns tabs) True+ H.Statement sql (arrayParam HE.text) (decodeColumns tabs) True where sql = [q| SELECT DISTINCT@@ -404,7 +408,7 @@ array_to_string(enum_info.vals, ',') AS enum FROM ( /*- -- CTE based on pg_catalog to get only Primary and Foreign key columns outside api schema+ -- CTE based on pg_catalog to get PRIMARY/FOREIGN key and UNIQUE columns outside api schema */ WITH key_columns AS ( SELECT@@ -420,11 +424,11 @@ pg_catalog.pg_class c, pg_catalog.pg_namespace n WHERE- r.contype IN ('f', 'p')+ r.contype IN ('f', 'p', 'u') AND c.relkind IN ('r', 'v', 'f', 'm') AND r.conrelid = c.oid AND c.relnamespace = n.oid- AND n.nspname NOT IN ('pg_catalog', 'information_schema', $1)+ AND n.nspname <> ANY (ARRAY['pg_catalog', 'information_schema'] || $1) ), /* -- CTE based on information_schema.columns@@ -526,7 +530,7 @@ AND a.attnum > 0 AND NOT a.attisdropped AND (c.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char", 'm'::"char"]))- AND (nc.nspname = $1 OR kc.r_oid IS NOT NULL) /*--filter only columns that are FK/PK or in the api schema */+ AND (nc.nspname = ANY ($1) OR kc.r_oid IS NOT NULL) /*--filter only columns that are FK/PK or in the api schema */ /*--AND (pg_has_role(c.relowner, 'USAGE'::text) OR has_column_privilege(c.oid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/ ) SELECT@@ -571,39 +575,36 @@ parseEnum :: Maybe Text -> [Text] parseEnum = maybe [] (split (==',')) -allChildRelations :: [Table] -> [Column] -> H.Statement () [Relation]-allChildRelations tabs cols =- H.Statement sql HE.noParams (decodeRelations tabs cols) True+allM2ORels :: [Table] -> [Column] -> H.Statement () [Relation]+allM2ORels tabs cols =+ H.Statement sql HE.noParams (decodeRels tabs cols) True where sql = [q| SELECT ns1.nspname AS table_schema, tab.relname AS table_name,+ conname AS constraint_name, column_info.cols AS columns, ns2.nspname AS foreign_table_schema, other.relname AS foreign_table_name, column_info.refs AS foreign_columns FROM pg_constraint,- LATERAL (SELECT array_agg(cols.attname) AS cols,- array_agg(cols.attnum) AS nums,- array_agg(refs.attname) AS refs- FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,- LATERAL (SELECT * FROM pg_attribute- WHERE attrelid = conrelid AND attnum = col)- AS cols,- LATERAL (SELECT * FROM pg_attribute- WHERE attrelid = confrelid AND attnum = ref)- AS refs)- AS column_info,- LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = connamespace) AS ns1,- LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,- LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other,- LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2+ LATERAL (+ SELECT array_agg(cols.attname) AS cols,+ array_agg(cols.attnum) AS nums,+ array_agg(refs.attname) AS refs+ FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,+ LATERAL (SELECT * FROM pg_attribute WHERE attrelid = conrelid AND attnum = col) AS cols,+ LATERAL (SELECT * FROM pg_attribute WHERE attrelid = confrelid AND attnum = ref) AS refs) AS column_info,+ LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = connamespace) AS ns1,+ LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,+ LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other,+ LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2 WHERE confrelid != 0 ORDER BY (conrelid, column_info.nums) |] -relationFromRow :: [Table] -> [Column] -> (Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation-relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) =- Relation <$> table <*> cols <*> tableF <*> colsF <*> pure Child <*> pure Nothing <*> pure Nothing <*> pure Nothing+relFromRow :: [Table] -> [Column] -> (Text, Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation+relFromRow allTabs allCols (rs, rt, cn, rcs, frs, frt, frcs) =+ Relation <$> table <*> cols <*> pure (Just cn) <*> tableF <*> colsF <*> pure M2O <*> pure Nothing where findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs findCol s t c = find (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col == c) allCols@@ -722,9 +723,9 @@ pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs -allSynonyms :: [Column] -> PgVersion -> H.Statement Schema [Synonym]-allSynonyms cols pgVer =- H.Statement sql (param HE.text) (decodeSynonyms cols) True+allSourceColumns :: [Column] -> PgVersion -> H.Statement [Schema] [SourceColumn]+allSourceColumns cols pgVer =+ H.Statement sql (arrayParam HE.text) (decodeSourceColumns cols) True -- query explanation at https://gist.github.com/steve-chavez/7ee0e6590cddafb532e5f00c46275569 where subselectRegex :: Text@@ -743,7 +744,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 in ('v', 'm')) and n.nspname = $1+ where (c.relkind in ('v', 'm')) and n.nspname = ANY ($1) ), removed_subselects as( select@@ -790,13 +791,6 @@ join pg_namespace sch on sch.oid = tbl.relnamespace where resorigtbl <> '0' order by view_schema, view_name, view_colum_name; |]--synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe Synonym-synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2- where- col1 = findCol s1 t1 c1- col2 = findCol s2 t2 c2- 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.noParams versionRow False
src/PostgREST/Error.hs view
@@ -16,12 +16,12 @@ ) where import qualified Data.Aeson as JSON+import qualified Data.Text as T import qualified Hasql.Pool as P import qualified Hasql.Session as H import qualified Network.HTTP.Types.Status as HT import Data.Aeson ((.=))-import Data.Text (unwords) import Network.Wai (Response, responseLBS) import Text.Read (readMaybe) @@ -48,8 +48,10 @@ | InvalidRange | InvalidBody ByteString | ParseRequestError Text Text- | NoRelationBetween Text Text+ | NoRelBetween Text Text+ | AmbiguousRelBetween Text Text [Relation] | InvalidFilters+ | UnacceptableSchema [Text] | UnknownRelation -- Unreachable? | UnsupportedVerb -- Unreachable? deriving (Show, Eq)@@ -62,7 +64,9 @@ status UnknownRelation = HT.status404 status ActionInappropriate = HT.status405 status (ParseRequestError _ _) = HT.status400- status (NoRelationBetween _ _) = HT.status400+ status (NoRelBetween _ _) = HT.status400+ status AmbiguousRelBetween{} = HT.status300+ status (UnacceptableSchema _) = HT.status406 headers _ = [toHeader CTApplicationJSON] @@ -77,13 +81,39 @@ "message" .= ("HTTP Range error" :: Text)] toJSON UnknownRelation = JSON.object [ "message" .= ("Unknown relation" :: Text)]- toJSON (NoRelationBetween parent child) = JSON.object [- "message" .= ("Could not find foreign keys between these entities, No relation found between " <> parent <> " and " <> child :: Text)]+ toJSON (NoRelBetween parent child) = JSON.object [+ "message" .= ("Could not find foreign keys between these entities. No relationship found between " <> parent <> " and " <> child :: Text)]+ toJSON (AmbiguousRelBetween parent child rels) = JSON.object [+ "hint" .= ("By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)" :: Text),+ "message" .= ("More than one relationship was found for " <> parent <> " and " <> child :: Text),+ "details" .= (compressedRel <$> rels) ] toJSON UnsupportedVerb = JSON.object [ "message" .= ("Unsupported HTTP verb" :: Text)] toJSON InvalidFilters = JSON.object [ "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)]+ toJSON (UnacceptableSchema schemas) = JSON.object [+ "message" .= ("The schema must be one of the following: " <> T.intercalate ", " schemas)] +compressedRel :: Relation -> JSON.Value+compressedRel rel =+ let+ fmtTbl tbl = tableSchema tbl <> "." <> tableName tbl+ fmtEls els = "[" <> T.intercalate ", " els <> "]"+ in+ JSON.object $ [+ "origin" .= fmtTbl (relTable rel)+ , "target" .= fmtTbl (relFTable rel)+ , "cardinality" .= (show $ relType rel :: Text)+ ] +++ case (relType rel, relJunction rel, relConstraint rel) of+ (M2M, Just (Junction jt (Just const1) _ (Just const2) _), _) -> [+ "relationship" .= (fmtTbl jt <> fmtEls [const1] <> fmtEls [const2])+ ]+ (_, _, Just relCon) -> [+ "relationship" .= (relCon <> fmtEls (colName <$> relColumns rel) <> fmtEls (colName <$> relFColumns rel))+ ]+ (_, _, _) ->+ mempty data PgError = PgError Authenticated P.UsageError type Authenticated = Bool@@ -241,7 +271,7 @@ "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"]]+ "details" .= T.unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]] toJSON JwtTokenMissing = JSON.object [ "message" .= ("Server lacks JWT secret" :: Text)]
src/PostgREST/Middleware.hs view
@@ -10,6 +10,8 @@ import qualified Data.Aeson as JSON import qualified Data.HashMap.Strict as M+import Data.Scientific (FPFormat (..), formatScientific,+ isInteger) import qualified Hasql.Transaction as H import Network.Wai (Application, Response)@@ -24,9 +26,8 @@ import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (SimpleError (JwtTokenInvalid, JwtTokenMissing), errorResponseFor)-import PostgREST.QueryBuilder (pgFmtSetLocal, pgFmtSetLocalSearchPath,- unquoted)-import Protolude+import PostgREST.QueryBuilder (setLocalQuery, setLocalSearchPathQuery)+import Protolude hiding (head) runWithClaims :: AppConfig -> JWTAttempt -> (ApiRequest -> H.Transaction Response) ->@@ -37,17 +38,19 @@ 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+ H.sql $ toS . mconcat $ setSearchPathSql : setRoleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql mapM_ H.sql customReqCheck app req where- headersSql = pgFmtSetLocal "request.header." <$> iHeaders req- cookiesSql = pgFmtSetLocal "request.cookie." <$> iCookies req- claimsSql = pgFmtSetLocal "request.jwt.claim." <$> [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]- appSettingsSql = pgFmtSetLocal mempty <$> configSettings conf+ methodSql = setLocalQuery mempty ("request.method", toS $ iMethod req)+ pathSql = setLocalQuery mempty ("request.path", toS $ iPath req)+ headersSql = setLocalQuery "request.header." <$> iHeaders req+ cookiesSql = setLocalQuery "request.cookie." <$> iCookies req+ claimsSql = setLocalQuery "request.jwt.claim." <$> [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]+ appSettingsSql = setLocalQuery mempty <$> configSettings conf setRoleSql = maybeToList $ (\x ->- pgFmtSetLocal mempty ("role", unquoted x)) <$> M.lookup "role" claimsWithRole- setSearchPathSql = pgFmtSetLocalSearchPath $ configSchema conf : configExtraSearchPath conf+ setLocalQuery mempty ("role", unquoted x)) <$> M.lookup "role" claimsWithRole+ setSearchPathSql = setLocalSearchPathQuery (iSchema req : configExtraSearchPath conf) -- role claim defaults to anon if not specified in jwt claimsWithRole = M.union claims (M.singleton "role" anon) anon = JSON.String . toS $ configAnonRole conf@@ -58,3 +61,10 @@ gzip def . cors corsPolicy . staticPolicy (only [("favicon.ico", "static/favicon.ico")])++unquoted :: JSON.Value -> Text+unquoted (JSON.String t) = t+unquoted (JSON.Number n) =+ toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n+unquoted (JSON.Bool b) = show b+unquoted v = toS $ JSON.encode v
src/PostgREST/OpenAPI.hs view
@@ -10,7 +10,7 @@ , pickProxy ) where -import qualified Data.Set as Set+import qualified Data.HashSet.InsOrd as Set import Control.Arrow ((&&&)) import Data.Aeson (decode, encode)@@ -55,7 +55,7 @@ let tn = tableName t in (tn, (mempty :: Schema) & description .~ tableDescription t- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties .~ fromList (map (makeProperty pks) cs) & required .~ map colName (filter (not . colNullable) cs)) @@ -84,13 +84,13 @@ & enum_ .~ e & format ?~ colType c & maxLength .~ (fromIntegral <$> colMaxLen c)- & type_ .~ toSwaggerType (colType c)+ & type_ ?~ toSwaggerType (colType c) makeProcSchema :: ProcDescription -> Schema makeProcSchema pd = (mempty :: Schema) & description .~ pdDescription pd- & type_ .~ SwaggerObject+ & type_ ?~ SwaggerObject & properties .~ fromList (map makeProcProperty (pdArgs pd)) & required .~ map pgaName (filter pgaReq (pdArgs pd)) @@ -98,7 +98,7 @@ makeProcProperty (PgArg n t _) = (n, Inline s) where s = (mempty :: Schema)- & type_ .~ toSwaggerType t+ & type_ ?~ toSwaggerType t & format ?~ t makePreferParam :: [Text] -> Param@@ -109,7 +109,7 @@ & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamHeader- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & enum_ .~ decode (encode ts)) makeProcParam :: ProcDescription -> [Referenced Param]@@ -132,28 +132,35 @@ & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamQuery- & type_ .~ SwaggerString))+ & type_ ?~ SwaggerString))+ , ("on_conflict", (mempty :: Param)+ & name .~ "on_conflict"+ & description ?~ "On Conflict"+ & required ?~ False+ & schema .~ ParamOther ((mempty :: ParamOtherSchema)+ & in_ .~ ParamQuery+ & type_ ?~ SwaggerString)) , ("order", (mempty :: Param) & name .~ "order" & description ?~ "Ordering" & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamQuery- & type_ .~ SwaggerString))+ & type_ ?~ SwaggerString)) , ("range", (mempty :: Param) & name .~ "Range" & description ?~ "Limiting and Pagination" & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamHeader- & type_ .~ SwaggerString))+ & type_ ?~ SwaggerString)) , ("rangeUnit", (mempty :: Param) & name .~ "Range-Unit" & description ?~ "Limiting and Pagination" & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamHeader- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & default_ .~ decode "\"items\"")) , ("offset", (mempty :: Param) & name .~ "offset"@@ -161,14 +168,14 @@ & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamQuery- & type_ .~ SwaggerString))+ & type_ ?~ SwaggerString)) , ("limit", (mempty :: Param) & name .~ "limit" & description ?~ "Limiting and Pagination" & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamQuery- & type_ .~ SwaggerString))+ & type_ ?~ SwaggerString)) ] <> concat [ makeObjectBody (tableName t) : makeRowFilters (tableName t) cs | (t, cs, _) <- ti@@ -190,7 +197,7 @@ & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamQuery- & type_ .~ SwaggerString+ & type_ ?~ SwaggerString & format ?~ colType c)) makeRowFilters :: Text -> [Column] -> [(Text, Param)]@@ -213,7 +220,7 @@ & at 200 ?~ Inline ((mempty :: Response) & description .~ "OK" & schema ?~ Inline (mempty- & type_ .~ SwaggerArray+ & type_ ?~ SwaggerArray & items ?~ (SwaggerItemsObject $ Ref $ Reference $ tableName t) ) )
src/PostgREST/Parsers.hs view
@@ -30,6 +30,10 @@ pRequestSelect selStr = mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) +pRequestOnConflict :: Text -> Either ApiRequestError [FieldName]+pRequestOnConflict oncStr =+ mapError $ parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr)+ pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper) where@@ -130,12 +134,12 @@ pRelationSelect = lexeme $ try ( do alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) fld <- pField- relationDetail <- optionMaybe (- try ( char '!' *> pFieldName ) <|>- try ( char '.' *> pFieldName ) -- TODO deprecated, remove in next major version+ hint <- optionMaybe (+ try ( char '!' *> pFieldName) <|>+ -- deprecated, remove in next major version+ try ( char '.' *> pFieldName) )-- return (fld, Nothing, alias, relationDetail)+ return (fld, Nothing, alias, hint) ) pFieldSelect :: Parser SelectItem
+ src/PostgREST/Private/Common.hs view
@@ -0,0 +1,25 @@+{-|+Module : PostgREST.Common+Description : Common helper functions.+-}+module PostgREST.Private.Common where++import Data.Maybe+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+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++arrayParam :: HE.Value a -> HE.Params [a]+arrayParam = param . HE.array . HE.dimension foldl' . HE.element . HE.nonNullable
+ src/PostgREST/Private/QueryFragment.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE LambdaCase #-}+{-|+Module : PostgREST.Private.QueryFragment+Description : Helper functions for PostgREST.QueryBuilder.++Any function that outputs a SqlFragment should be in this module.+-}+module PostgREST.Private.QueryFragment where++import qualified Data.HashMap.Strict as HM+import Data.Maybe+import Data.Text (intercalate,+ isInfixOf, replace,+ toLower, unwords)+import qualified Data.Text as T (map, null,+ takeWhile)+import PostgREST.Types+import Protolude hiding (cast,+ intercalate, replace)+import Text.InterpolatedString.Perl6 (qc)++noLocationF :: SqlFragment+noLocationF = "array[]::text[]"++-- Due to the use of the `unknown` encoder we need to cast '$1' when the value is not used in the main query+-- otherwise the query will err with a `could not determine data type of parameter $1`.+-- This happens because `unknown` relies on the context to determine the value type.+-- The error also happens on raw libpq used with C.+ignoredBody :: SqlFragment+ignoredBody = "pgrst_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)"++pgFmtLit :: SqlFragment -> SqlFragment+pgFmtLit x =+ let trimmed = trimNullChars x+ escaped = "'" <> replace "'" "''" trimmed <> "'"+ slashed = replace "\\" "\\\\" escaped in+ if "\\" `isInfixOf` escaped+ then "E" <> slashed+ else slashed++pgFmtIdent :: SqlFragment -> SqlFragment+pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""++asCsvF :: SqlFragment+asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF+ where+ asCsvHeaderF =+ "(SELECT coalesce(string_agg(a.k, ','), '')" <>+ " FROM (" <>+ " SELECT json_object_keys(r)::TEXT as k" <>+ " FROM ( " <>+ " SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>+ " ) s" <>+ " ) a" <>+ ")"+ asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"++asJsonF :: SqlFragment+asJsonF = "coalesce(json_agg(_postgrest_t), '[]')::character varying"++asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element+asJsonSingleF = "coalesce(string_agg(row_to_json(_postgrest_t)::text, ','), '')::character varying "++asBinaryF :: FieldName -> SqlFragment+asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"++locationF :: [Text] -> SqlFragment+locationF pKeys = [qc|(+ WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1)+ SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))+ FROM data CROSS JOIN json_each_text(data.row) AS json_data+ {("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys}+)|]++fromQi :: QualifiedIdentifier -> SqlFragment+fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n+ where+ n = qiName t+ s = qiSchema t++emptyOnFalse :: Text -> Bool -> Text+emptyOnFalse val cond = if cond then "" else val++pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment+pgFmtColumn table "*" = fromQi table <> ".*"+pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c++pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment+pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp++pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment+pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs fName jp alias+pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs fName jp alias++pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment+pgFmtOrderTerm qi ot = unwords [+ toS . pgFmtField qi $ otTerm ot,+ maybe "" show $ otDirection ot,+ maybe "" show $ otNullOrder ot]++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++ In vals -> pgFmtField table fld <> " " <>+ let emptyValForIn = "= any('{}') " in -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"+ case (&&) (length vals == 1) . T.null <$> headMay vals of+ Just False -> sqlOperator "in" <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "+ Just True -> emptyValForIn+ Nothing -> emptyValForIn++ Fts op lang val ->+ pgFmtFieldOp op+ <> "("+ <> maybe "" ((<> ", ") . pgFmtLit) lang+ <> unknownLiteral val+ <> ") "+ where+ pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op+ sqlOperator o = HM.lookupDefault "=" o operators+ notOp = if hasNot then "NOT" else ""+ star c = if c == '*' then '%' else c+ unknownLiteral = (<> "::unknown ") . pgFmtLit+ whiteList :: Text -> SqlFragment+ whiteList v = fromMaybe+ (toS (pgFmtLit v) <> "::unknown ")+ (find ((==) . toLower $ v) ["null","true","false"])++pgFmtJoinCondition :: JoinCondition -> SqlFragment+pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) =+ pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2++pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment+pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")"+ where notOp = if hasNot then "NOT" else ""+pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt++pgFmtJsonPath :: JsonPath -> SqlFragment+pgFmtJsonPath = \case+ [] -> ""+ (JArrow x:xs) -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs+ (J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs+ where+ pgFmtJsonOperand (JKey k) = pgFmtLit k+ pgFmtJsonOperand (JIdx i) = pgFmtLit i <> "::int"++pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment+pgFmtAs _ [] Nothing = ""+pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of+ Just (JKey key) -> " AS " <> pgFmtIdent key+ Just (JIdx _) -> " AS " <> pgFmtIdent (fromMaybe fName lastKey)+ -- We get the lastKey because on:+ -- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ]+ -- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ]+ where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp)+ Nothing -> ""+pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias++trimNullChars :: Text -> Text+trimNullChars = T.takeWhile (/= '\x0')++countF :: SqlQuery -> Bool -> (SqlFragment, SqlFragment)+countF countQuery shouldCount =+ if shouldCount+ then (+ ", pg_source_count AS (" <> countQuery <> ")"+ , "(SELECT pg_catalog.count(*) FROM pg_source_count)" )+ else (+ mempty+ , "null::bigint")++returningF :: QualifiedIdentifier -> [FieldName] -> SqlFragment+returningF qi returnings =+ if null returnings+ then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified+ else "RETURNING " <> intercalate ", " (pgFmtColumn qi <$> returnings)++responseHeadersF :: PgVersion -> SqlFragment+responseHeadersF pgVer =+ 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
src/PostgREST/QueryBuilder.hs view
@@ -4,58 +4,38 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module : PostgREST.QueryBuilder-Description : PostgREST SQL generating functions.+Description : PostgREST SQL queries generating functions. This module provides functions to consume data types that-represent database objects (e.g. Relation, Schema, SqlQuery)-and produces SQL Statements.--Any function that outputs a SQL fragment should be in this module.+represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment+to produce SqlQuery type outputs. -} module PostgREST.QueryBuilder (- callProc- , createReadStatement- , createWriteStatement- , requestToQuery- , requestToCountQuery- , unquoted- , ResultsWithCount- , pgFmtSetLocal- , pgFmtSetLocalSearchPath+ readRequestToQuery+ , mutateRequestToQuery+ , readRequestToCountQuery+ , requestToCallProcQuery+ , limitedQuery+ , setLocalQuery+ , setLocalSearchPathQuery ) where -import qualified Data.Aeson as JSON-import qualified Data.Set as S+import qualified Data.Set as S -import Data.Scientific (FPFormat (..), formatScientific, isInteger)-import Data.Text (intercalate, unwords)-import Data.Tree (Tree (..))+import Data.Text (intercalate, unwords)+import Data.Tree (Tree (..)) import Data.Maybe -import PostgREST.QueryBuilder.Private-import PostgREST.QueryBuilder.Procedure-import PostgREST.QueryBuilder.ReadStatement-import PostgREST.QueryBuilder.WriteStatement-import PostgREST.RangeQuery (allRange, rangeLimit,- rangeOffset)+import PostgREST.Private.QueryFragment+import PostgREST.RangeQuery (allRange, rangeLimit,+ rangeOffset) import PostgREST.Types-import Protolude hiding (cast,- intercalate, replace)--requestToCountQuery :: Schema -> DbRequest -> SqlQuery-requestToCountQuery _ (DbMutate _) = witness-requestToCountQuery schema (DbRead (Node (Select{where_=logicForest}, (mainTbl, _, _, _, _)) _)) =- unwords [- "SELECT pg_catalog.count(*)",- "FROM ", fromQi qi,- ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest- ]- where- qi = removeSourceCTESchema schema mainTbl+import Protolude hiding (cast, intercalate,+ replace) -requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery-requestToQuery schema isParent (DbRead (Node (Select colSelects tbl tblAlias implJoins logicForest joinConditions_ ordts range, _) forest)) =+readRequestToQuery :: ReadRequest -> SqlQuery+readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) = unwords [ "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), "FROM " <> intercalate ", " (tabl : implJs),@@ -63,51 +43,42 @@ ("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) ]-+ ("LIMIT " <> maybe "ALL" show (rangeLimit range) <> " OFFSET " <> show (rangeOffset range)) `emptyOnFalse` (range == allRange)+ ] where- implJs = fromQi . QualifiedIdentifier schema <$> implJoins- mainQi = removeSourceCTESchema schema tbl+ implJs = fromQi <$> implJoins tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias+ (joins, selects) = foldr getJoinsSelects ([],[]) forest - (joins, selects) = foldr getQueryParts ([],[]) forest+getJoinsSelects :: ReadRequest -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])+getJoinsSelects rr@(Node (_, (name, Just Relation{relType=relTyp,relTable=Table{tableName=table}}, alias, _, _)) _) (j,s) =+ let subquery = readRequestToQuery rr in+ case relTyp of+ M2O ->+ let aliasOrName = fromMaybe name alias+ localTableName = pgFmtIdent $ table <> "_" <> aliasOrName+ sel = "row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName+ joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> localTableName <> " ON TRUE " in+ (joi:j,sel:s)+ _ ->+ let sel = "COALESCE (("+ <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) "+ <> "FROM (" <> subquery <> ") " <> pgFmtIdent table+ <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias) in+ (j,sel:s)+getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], []) - getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])- getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (j,sel:s)- where- sel = "COALESCE(("- <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) "- <> "FROM (" <> subquery <> ") " <> pgFmtIdent table- <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)- where subquery = requestToQuery schema False (DbRead (Node n forst))- getQueryParts (Node n@(_, (name, Just Relation{relType=Parent,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (joi:j,sel:s)- where- aliasOrName = fromMaybe name alias- localTableName = pgFmtIdent $ table <> "_" <> aliasOrName- sel = "row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName- joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> localTableName <> " ON TRUE "- where subquery = requestToQuery schema True (DbRead (Node n forst))- getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (j,sel:s)- where- sel = "COALESCE (("- <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) "- <> "FROM (" <> subquery <> ") " <> pgFmtIdent table- <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)- where subquery = requestToQuery schema False (DbRead (Node n forst))- --the following is just to remove the warning- --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 iCols onConflct putConditions returnings)) =+mutateRequestToQuery :: MutateRequest -> SqlQuery+mutateRequestToQuery (Insert mainQi iCols onConflct putConditions returnings) = unwords [ "WITH " <> normalizedBody,- "INSERT INTO ", fromQi qi, if S.null iCols then " " else "(" <> cols <> ")",+ "INSERT INTO ", fromQi mainQi, if S.null iCols then " " else "(" <> cols <> ")", unwords [ "SELECT " <> cols <> " FROM",- "json_populate_recordset", "(null::", fromQi qi, ", " <> selectBody <> ") _",+ "json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ") _", -- Only used for PUT- ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier "" "_") <$> putConditions)) `emptyOnFalse` null putConditions],+ ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) `emptyOnFalse` null putConditions], maybe "" (\(oncDo, oncCols) -> ( "ON CONFLICT(" <> intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of IgnoreDuplicates ->@@ -117,37 +88,94 @@ 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]+ returningF mainQi returnings+ ] where- qi = QualifiedIdentifier schema mainTbl cols = intercalate ", " $ pgFmtIdent <$> S.toList iCols-requestToQuery schema _ (DbMutate (Update mainTbl uCols logicForest returnings)) =+mutateRequestToQuery (Update mainQi 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 json_populate_recordset", "(null::", fromQi qi, ", " <> selectBody <> ")) _ ",- ("WHERE " <> intercalate " AND " (pgFmtLogicTree qi <$> logicForest)) `emptyOnFalse` null logicForest,- ("RETURNING " <> intercalate ", " (pgFmtColumn qi <$> returnings)) `emptyOnFalse` null returnings+ "UPDATE " <> fromQi mainQi <> " SET " <> cols,+ "FROM (SELECT * FROM json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ")) _ ",+ ("WHERE " <> intercalate " AND " (pgFmtLogicTree mainQi <$> logicForest)) `emptyOnFalse` null logicForest,+ returningF mainQi returnings ] where- qi = QualifiedIdentifier schema mainTbl cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)-requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) =+mutateRequestToQuery (Delete mainQi logicForest returnings) = unwords [ "WITH " <> ignoredBody,- "DELETE FROM ", fromQi qi,- ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,- ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings+ "DELETE FROM ", fromQi mainQi,+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree mainQi) logicForest)) `emptyOnFalse` null logicForest,+ returningF mainQi returnings ]++requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Bool -> Maybe PreferParameters -> SqlQuery+requestToCallProcQuery qi pgArgs returnsScalar preferParams =+ unwords [+ "WITH",+ argsCTE,+ sourceBody ] where- qi = QualifiedIdentifier schema mainTbl+ paramsAsSingleObject = preferParams == Just SingleObject+ paramsAsMulitpleObjects = preferParams == Just MultipleObjects -unquoted :: JSON.Value -> Text-unquoted (JSON.String t) = t-unquoted (JSON.Number n) =- toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n-unquoted (JSON.Bool b) = show b-unquoted v = toS $ JSON.encode v+ (argsCTE, args)+ | null pgArgs = (ignoredBody, "")+ | paramsAsSingleObject = ("pgrst_args AS (SELECT NULL)", "$1::json")+ | otherwise = (+ unwords [+ normalizedBody <> ",",+ "pgrst_args AS (",+ "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (\a -> " " <> pgaType a) <> ")",+ ")"]+ , if paramsAsMulitpleObjects+ then fmtArgs (\a -> " := pgrst_args." <> pgFmtIdent (pgaName a))+ else fmtArgs (\a -> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM pgrst_args LIMIT 1)")+ )++ fmtArgs :: (PgArg -> SqlFragment) -> SqlFragment+ fmtArgs argFrag = intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> argFrag a) <$> pgArgs)++ sourceBody :: SqlFragment+ sourceBody+ | paramsAsMulitpleObjects =+ if returnsScalar+ then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"+ else unwords [ "SELECT pgrst_lat_args.*"+ , "FROM pgrst_args,"+ , "LATERAL ( SELECT * FROM " <> callIt <> " ) pgrst_lat_args" ]+ | otherwise =+ if returnsScalar+ then "SELECT " <> callIt <> " AS pgrst_scalar"+ else "SELECT * FROM " <> callIt++ callIt :: SqlFragment+ callIt = fromQi qi <> "(" <> args <> ")"+++-- | SQL query meant for COUNTing the root node of the Tree.+-- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT.+-- SELECT 1 is done instead of SELECT * to prevent doing expensive operations(like functions based on the columns)+-- inside the FROM target.+readRequestToCountQuery :: ReadRequest -> SqlQuery+readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) =+ unwords [+ "SELECT 1",+ "FROM " <> fromQi qi,+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest+ ]++limitedQuery :: SqlQuery -> Maybe Integer -> SqlQuery+limitedQuery query maxRows = query <> maybe mempty (\x -> " LIMIT " <> show x) maxRows++setLocalQuery :: Text -> (Text, Text) -> SqlQuery+setLocalQuery prefix (k, v) =+ "SET LOCAL " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";"++setLocalSearchPathQuery :: [Text] -> SqlQuery+setLocalSearchPathQuery vals =+ "SET LOCAL search_path = " <> intercalate ", " (pgFmtLit <$> vals) <> ";"
− src/PostgREST/QueryBuilder/Private.hs
@@ -1,237 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-|-Module : PostgREST.QueryBuilder.Private-Description : Helper functions for PostgREST.QueryBuilder.--}-module PostgREST.QueryBuilder.Private where--import qualified Data.ByteString.Char8 as BS-import qualified Data.HashMap.Strict as HM-import Data.Maybe-import Data.Text (intercalate,- isInfixOf, replace,- toLower, unwords)-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 PostgREST.Types-import Protolude hiding (cast,- intercalate, replace)-import Text.InterpolatedString.Perl6 (qc)--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.--}-type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString)--standardRow :: HD.Row ResultsWithCount-standardRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8- <*> column header <*> column HD.bytea- where- header = HD.array $ HD.dimension replicateM $ element HD.bytea--noLocationF :: Text-noLocationF = "array[]::text[]"--{-| Read and Write api requests use a similar response format which includes- various record counts and possible location header. This is the decoder- for that common type of query.--}-decodeStandard :: HD.Result ResultsWithCount-decodeStandard =- HD.singleRow standardRow--decodeStandardMay :: HD.Result (Maybe ResultsWithCount)-decodeStandardMay =- HD.rowMaybe standardRow--removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier-removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl---- Due to the use of the `unknown` encoder we need to cast '$1' when the value is not used in the main query--- otherwise the query will err with a `could not determine data type of parameter $1`.--- This happens because `unknown` relies on the context to determine the value type.--- The error also happens on raw libpq used with C.-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)"--pgFmtLit :: SqlFragment -> SqlFragment-pgFmtLit x =- let trimmed = trimNullChars x- escaped = "'" <> replace "'" "''" trimmed <> "'"- slashed = replace "\\" "\\\\" escaped in- if "\\" `isInfixOf` escaped- then "E" <> slashed- else slashed--pgFmtIdent :: SqlFragment -> SqlFragment-pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""--asCsvF :: SqlFragment-asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF- where- asCsvHeaderF =- "(SELECT coalesce(string_agg(a.k, ','), '')" <>- " FROM (" <>- " SELECT json_object_keys(r)::TEXT as k" <>- " FROM ( " <>- " SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>- " ) s" <>- " ) a" <>- ")"- asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"--asJsonF :: SqlFragment-asJsonF = "coalesce(json_agg(_postgrest_t), '[]')::character varying"--asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element-asJsonSingleF = "coalesce(string_agg(row_to_json(_postgrest_t)::text, ','), '')::character varying "--asBinaryF :: FieldName -> SqlFragment-asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"--locationF :: [Text] -> SqlFragment-locationF pKeys = [qc|(- WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1)- SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))- FROM data CROSS JOIN json_each_text(data.row) AS json_data- {("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys}-)|]--fromQi :: QualifiedIdentifier -> SqlFragment-fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n- where- n = qiName t- s = qiSchema t--unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Statement a b-unicodeStatement = H.Statement . T.encodeUtf8--emptyOnFalse :: Text -> Bool -> Text-emptyOnFalse val cond = if cond then "" else val--pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment-pgFmtColumn table "*" = fromQi table <> ".*"-pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c--pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment-pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp--pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment-pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs fName jp alias-pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs fName jp alias--pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment-pgFmtOrderTerm qi ot = unwords [- toS . pgFmtField qi $ otTerm ot,- maybe "" show $ otDirection ot,- maybe "" show $ otNullOrder ot]--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-- In vals -> pgFmtField table fld <> " " <>- let emptyValForIn = "= any('{}') " in -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"- case (&&) (length vals == 1) . T.null <$> headMay vals of- Just False -> sqlOperator "in" <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "- Just True -> emptyValForIn- Nothing -> emptyValForIn-- Fts op lang val ->- pgFmtFieldOp op- <> "("- <> maybe "" ((<> ", ") . pgFmtLit) lang- <> unknownLiteral val- <> ") "- where- pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op- sqlOperator o = HM.lookupDefault "=" o operators- notOp = if hasNot then "NOT" else ""- star c = if c == '*' then '%' else c- unknownLiteral = (<> "::unknown ") . pgFmtLit- whiteList :: Text -> SqlFragment- whiteList v = fromMaybe- (toS (pgFmtLit v) <> "::unknown ")- (find ((==) . toLower $ v) ["null","true","false"])--pgFmtJoinCondition :: JoinCondition -> SqlFragment-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) <> ")"- where notOp = if hasNot then "NOT" else ""-pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt--pgFmtJsonPath :: JsonPath -> SqlFragment-pgFmtJsonPath = \case- [] -> ""- (JArrow x:xs) -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs- (J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs- where- pgFmtJsonOperand (JKey k) = pgFmtLit k- pgFmtJsonOperand (JIdx i) = pgFmtLit i <> "::int"--pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment-pgFmtAs _ [] Nothing = ""-pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of- Just (JKey key) -> " AS " <> pgFmtIdent key- Just (JIdx _) -> " AS " <> pgFmtIdent (fromMaybe fName lastKey)- -- We get the lastKey because on:- -- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ]- -- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ]- where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp)- Nothing -> ""-pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias--pgFmtSetLocal :: Text -> (Text, Text) -> SqlFragment-pgFmtSetLocal prefix (k, v) =- "SET LOCAL " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";"--pgFmtSetLocalSearchPath :: [Text] -> SqlFragment-pgFmtSetLocalSearchPath vals =- "SET LOCAL search_path = " <> intercalate ", " (pgFmtLit <$> vals) <> ";"--trimNullChars :: Text -> Text-trimNullChars = T.takeWhile (/= '\x0')
− src/PostgREST/QueryBuilder/Procedure.hs
@@ -1,85 +0,0 @@-module PostgREST.QueryBuilder.Procedure where--import Data.Maybe-import Data.Text (intercalate, unwords)-import qualified Hasql.Decoders as HD-import qualified Hasql.Encoders as HE-import qualified Hasql.Statement as H-import PostgREST.QueryBuilder.Private-import PostgREST.Types-import Protolude hiding (cast,- intercalate, replace)-import Text.InterpolatedString.Perl6 (qc)--type ProcResults = (Maybe Int64, Int64, ByteString, ByteString)-callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool ->- Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->- H.Statement ByteString (Maybe ProcResults)-callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField pgVer =- unicodeStatement sql (param HE.unknown) decodeProc True- where- 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 [- 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 = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8- <*> column HD.bytea <*> column HD.bytea-
− src/PostgREST/QueryBuilder/ReadStatement.hs
@@ -1,32 +0,0 @@-module PostgREST.QueryBuilder.ReadStatement where--import Data.Maybe-import Data.Text (intercalate)-import qualified Hasql.Encoders as HE-import qualified Hasql.Statement as H-import PostgREST.QueryBuilder.Private-import PostgREST.Types-import Protolude hiding (cast,- intercalate, replace)-import Text.InterpolatedString.Perl6 (qc)--createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName ->- H.Statement () ResultsWithCount-createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =- unicodeStatement sql HE.noParams decodeStandard False- where- sql = [qc|- WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}- FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |]- countResultF = if countTotal then "("<>countQuery<>")" else "null"- cols = intercalate ", " [- countResultF <> " AS total_result_set",- "pg_catalog.count(_postgrest_t) AS page_total",- noLocationF <> " AS header",- bodyF <> " AS body"- ]- bodyF- | asCsv = asCsvF- | isSingle = asJsonSingleF- | isJust binaryField = asBinaryF $ fromJust binaryField- | otherwise = asJsonF
− src/PostgREST/QueryBuilder/WriteStatement.hs
@@ -1,53 +0,0 @@-module PostgREST.QueryBuilder.WriteStatement where--import Data.Maybe-import Data.Text (intercalate, unwords)-import qualified Hasql.Encoders as HE-import qualified Hasql.Statement as H-import PostgREST.ApiRequest (PreferRepresentation (..))-import PostgREST.QueryBuilder.Private-import PostgREST.Types-import Protolude hiding (cast,- intercalate, replace)-import Text.InterpolatedString.Perl6 (qc)--createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->- PreferRepresentation -> [Text] ->- H.Statement ByteString (Maybe ResultsWithCount)-createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys =- unicodeStatement sql (param HE.unknown) decodeStandardMay True-- where- sql = case rep of- None -> [qc|- WITH {sourceCTEName} AS ({mutateQuery})- SELECT '', 0, {noLocationF}, '' |]- HeadersOnly -> [qc|- WITH {sourceCTEName} AS ({mutateQuery})- SELECT {cols}- FROM (SELECT 1 FROM {sourceCTEName}) _postgrest_t |]- Full -> [qc|- WITH {sourceCTEName} AS ({mutateQuery})- SELECT {cols}- FROM ({selectQuery}) _postgrest_t |]-- cols = intercalate ", " [- "'' AS total_result_set", -- when updateing it does not make sense- "pg_catalog.count(_postgrest_t) AS page_total",- 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 "''"- ]-- bodyF- | asCsv = asCsvF- | wantSingle = asJsonSingleF- | otherwise = asJsonF
src/PostgREST/RangeQuery.hs view
@@ -1,6 +1,6 @@ {-| Module : PostgREST.RangeQuery-Description : Logic regarding the `Range` header and `limit`, `offset` querystring arguments.+Description : Logic regarding the `Range`/`Content-Range` headers and `limit`/`offset` querystring arguments. -} module PostgREST.RangeQuery ( rangeParse@@ -11,6 +11,8 @@ , rangeGeq , allRange , NonnegRange+, rangeStatusHeader+, contentRangeH ) where import qualified Data.ByteString.Char8 as BS@@ -22,6 +24,7 @@ import Data.Ranged.Boundaries import Data.Ranged.Ranges import Network.HTTP.Types.Header+import Network.HTTP.Types.Status import Protolude @@ -70,3 +73,30 @@ rangeLeq :: Integer -> NonnegRange rangeLeq n = Range BoundaryBelowAll (BoundaryAbove n)++rangeStatusHeader :: NonnegRange -> Int64 -> Maybe Int64 -> (Status, Header)+rangeStatusHeader topLevelRange queryTotal tableTotal =+ let lower = rangeOffset topLevelRange+ upper = lower + toInteger queryTotal - 1+ contentRange = contentRangeH lower upper (toInteger <$> tableTotal)+ status = rangeStatus lower upper (toInteger <$> tableTotal)+ in (status, contentRange)+ where+ rangeStatus :: Integer -> Integer -> Maybe Integer -> Status+ rangeStatus _ _ Nothing = status200+ rangeStatus lower upper (Just total)+ | lower > total = status416 -- 416 Range Not Satisfiable+ | (1 + upper - lower) < total = status206 -- 206 Partial Content+ | otherwise = status200 -- 200 OK++contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header+contentRangeH lower upper total =+ ("Content-Range", headerValue)+ where+ headerValue = rangeString <> "/" <> totalString+ rangeString+ | totalNotZero && fromInRange = show lower <> "-" <> show upper+ | otherwise = "*"+ totalString = maybe "*" show total+ totalNotZero = maybe True (0 /=) total+ fromInRange = lower <= upper
+ src/PostgREST/Statements.hs view
@@ -0,0 +1,179 @@+{-|+Module : PostgREST.Statements+Description : PostgREST single SQL statements.++This module constructs single SQL statements that can be parametrized and prepared.++- It consumes the SqlQuery types generated by the QueryBuilder module.+- It generates the body format and some headers of the final HTTP response.++TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718.+-}+module PostgREST.Statements (+ createWriteStatement+ , createReadStatement+ , callProcStatement+ , createExplainStatement+) where+++import Control.Lens ((^?))+import Data.Aeson as JSON+import qualified Data.Aeson.Lens as L+import qualified Data.ByteString.Char8 as BS+import Data.Maybe+import Data.Text (unwords)+import Data.Text.Encoding (encodeUtf8)+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Statement as H+import PostgREST.Private.Common+import PostgREST.Private.QueryFragment+import PostgREST.Types+import Protolude hiding (cast,+ replace)+import Text.InterpolatedString.Perl6 (qc)++{-| 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.+-}+type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString, Either Text [GucHeader])++createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->+ PreferRepresentation -> [Text] -> PgVersion ->+ H.Statement ByteString ResultsWithCount+createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer =+ unicodeStatement sql (param HE.unknown) decodeStandard True+ where+ sql = [qc|+ WITH+ {sourceCTEName} AS ({mutateQuery})+ SELECT+ '' AS total_result_set,+ pg_catalog.count(_postgrest_t) AS page_total,+ {locF} AS header,+ {bodyF} AS body,+ {responseHeadersF pgVer} AS response_headers+ FROM ({selectQuery}) _postgrest_t |]++ locF =+ if isInsert && rep `elem` [Full, HeadersOnly]+ then unwords [+ "CASE WHEN pg_catalog.count(_postgrest_t) = 1",+ "THEN coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")",+ "ELSE " <> noLocationF,+ "END"]+ else noLocationF++ bodyF+ | rep `elem` [None, HeadersOnly] = "''"+ | asCsv = asCsvF+ | wantSingle = asJsonSingleF+ | otherwise = asJsonF++ decodeStandard :: HD.Result ResultsWithCount+ decodeStandard =+ fromMaybe (Nothing, 0, [], mempty, Right []) <$> HD.rowMaybe standardRow++createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->+ H.Statement () ResultsWithCount+createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField pgVer =+ unicodeStatement sql HE.noParams decodeStandard False+ where+ sql = [qc|+ WITH+ {sourceCTEName} AS ({selectQuery})+ {countCTEF}+ SELECT+ {countResultF} AS total_result_set,+ pg_catalog.count(_postgrest_t) AS page_total,+ {noLocationF} AS header,+ {bodyF} AS body,+ {responseHeadersF pgVer} AS response_headers+ FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |]++ (countCTEF, countResultF) = countF countQuery countTotal++ bodyF+ | asCsv = asCsvF+ | isSingle = asJsonSingleF+ | isJust binaryField = asBinaryF $ fromJust binaryField+ | otherwise = asJsonF++ decodeStandard :: HD.Result ResultsWithCount+ decodeStandard =+ HD.singleRow standardRow++{-| Read and Write api requests use a similar response format which includes+ various record counts and possible location header. This is the decoder+ for that common type of query.+-}+standardRow :: HD.Row ResultsWithCount+standardRow = (,,,,) <$> nullableColumn HD.int8 <*> column HD.int8+ <*> column header <*> column HD.bytea <*> column decodeGucHeaders+ where+ header = HD.array $ HD.dimension replicateM $ element HD.bytea++type ProcResults = (Maybe Int64, Int64, ByteString, Either Text [GucHeader])++callProcStatement :: Bool -> SqlQuery -> SqlQuery -> SqlQuery -> Bool ->+ Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->+ H.Statement ByteString ProcResults+callProcStatement returnsScalar callProcQuery selectQuery countQuery countTotal isSingle asCsv asBinary multObjects binaryField pgVer =+ unicodeStatement sql (param HE.unknown) decodeProc True+ where+ sql = [qc|+ WITH {sourceCTEName} AS ({callProcQuery})+ {countCTEF}+ SELECT+ {countResultF} AS total_result_set,+ pg_catalog.count(_postgrest_t) AS page_total,+ {bodyF} AS body,+ {responseHeadersF pgVer} AS response_headers+ FROM ({selectQuery}) _postgrest_t;|]++ (countCTEF, countResultF) = countF countQuery countTotal++ bodyF+ | returnsScalar = scalarBodyF+ | isSingle = asJsonSingleF+ | asCsv = asCsvF+ | isJust binaryField = asBinaryF $ fromJust binaryField+ | otherwise = asJsonF++ scalarBodyF+ | asBinary = asBinaryF "pgrst_scalar"+ | multObjects = "json_agg(_postgrest_t.pgrst_scalar)::character varying"+ | otherwise = "(json_agg(_postgrest_t.pgrst_scalar)->0)::character varying"++ decodeProc :: HD.Result ProcResults+ decodeProc =+ fromMaybe (Just 0, 0, mempty, Right []) <$> HD.rowMaybe procRow+ where+ procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8+ <*> column HD.bytea <*> column decodeGucHeaders++createExplainStatement :: SqlQuery -> H.Statement () (Maybe Int64)+createExplainStatement countQuery =+ unicodeStatement sql HE.noParams decodeExplain False+ where+ sql = [qc| EXPLAIN (FORMAT JSON) {countQuery} |]+ -- |+ -- An `EXPLAIN (FORMAT JSON) select * from items;` output looks like this:+ -- [{+ -- "Plan": {+ -- "Node Type": "Seq Scan", "Parallel Aware": false, "Relation Name": "items",+ -- "Alias": "items", "Startup Cost": 0.00, "Total Cost": 32.60,+ -- "Plan Rows": 2260,"Plan Width": 8} }]+ -- We only obtain the Plan Rows here.+ decodeExplain :: HD.Result (Maybe Int64)+ decodeExplain =+ let row = HD.singleRow $ column HD.bytea in+ (^? L.nth 0 . L.key "Plan" . L.key "Plan Rows" . L._Integral) <$> row++unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Statement a b+unicodeStatement = H.Statement . encodeUtf8++decodeGucHeaders :: HD.Value (Either Text [GucHeader])+decodeGucHeaders = first toS . JSON.eitherDecode . toS <$> HD.bytea
src/PostgREST/Types.hs view
@@ -2,10 +2,14 @@ Module : PostgREST.Types Description : PostgREST common types and functions used by the rest of the modules -}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} module PostgREST.Types where +import Control.Lens.Getter (view)+import Control.Lens.Tuple (_1)+ import qualified Data.Aeson as JSON import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS (c2w)@@ -56,18 +60,53 @@ "*/*" -> CTAny ct' -> CTOther ct' +-- | A SQL query that can be executed independently+type SqlQuery = Text++-- | A part of a SQL query that cannot be executed independently+type SqlFragment = Text+ data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq instance Show PreferResolution where show MergeDuplicates = "resolution=merge-duplicates" show IgnoreDuplicates = "resolution=ignore-duplicates" +-- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2+data PreferRepresentation = Full -- ^ Return the body plus the Location header(in case of POST).+ | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.+ | None -- ^ Return nothing from the mutated data.+ deriving Eq+instance Show PreferRepresentation where+ show Full = "return=representation"+ show None = "return=minimal"+ show HeadersOnly = mempty++data PreferParameters+ = SingleObject -- ^ Pass all parameters as a single json object to a stored procedure+ | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure+ deriving Eq++instance Show PreferParameters where+ show SingleObject = "params=single-object"+ show MultipleObjects = "params=multiple-objects"++data PreferCount+ = ExactCount -- ^ exact count(slower)+ | PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.+ | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count.+ deriving Eq++instance Show PreferCount where+ show ExactCount = "count=exact"+ show PlannedCount = "count=planned"+ show EstimatedCount = "count=estimated"+ data DbStructure = DbStructure { dbTables :: [Table] , dbColumns :: [Column] , dbRelations :: [Relation] , dbPrimaryKeys :: [PrimaryKey]--- ProcDescription is a list because a function can be overloaded-, dbProcs :: M.HashMap Text [ProcDescription]+, dbProcs :: ProcsMap , pgVersion :: PgVersion } deriving (Show, Eq) @@ -93,7 +132,8 @@ deriving (Eq, Show, Ord) data ProcDescription = ProcDescription {- pdName :: Text+ pdSchema :: Schema+, pdName :: Text , pdDescription :: Maybe Text , pdArgs :: [PgArg] , pdReturnType :: RetType@@ -102,18 +142,23 @@ -- Order by least number of args in the case of overloaded functions instance Ord ProcDescription where- ProcDescription name1 des1 args1 rt1 vol1 `compare` ProcDescription name2 des2 args2 rt2 vol2- | name1 == name2 && length args1 < length args2 = LT- | name1 == name2 && length args1 > length args2 = GT- | otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2)+ ProcDescription schema1 name1 des1 args1 rt1 vol1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2+ | schema1 == schema2 && name1 == name2 && length args1 < length args2 = LT+ | schema2 == schema2 && name1 == name2 && length args1 > length args2 = GT+ | otherwise = (schema1, name1, des1, args1, rt1, vol1) `compare` (schema2, name2, des2, args2, rt2, vol2) +-- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription).+-- | It uses a HashMap for a faster lookup.+type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]+ {-| 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.+ Ideally, handling overloaded functions should be left to pg itself. But we need to know certain proc attributes in advance. -}-findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription+findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> Maybe ProcDescription findProc qi payloadKeys paramsAsSingleObject allProcs =- case M.lookup (qiName qi) allProcs of+ case M.lookup 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@@ -135,10 +180,19 @@ in (\k -> fromMaybe (PgArg k "text" True) (find ((==) k . pgaName) args)) <$> S.toList keys +procReturnsScalar :: ProcDescription -> Bool+procReturnsScalar proc = case proc of+ ProcDescription{pdReturnType = (Single (Scalar _))} -> True+ _ -> False++procTableName :: ProcDescription -> Maybe TableName+procTableName proc = case pdReturnType proc of+ SetOf (Composite qi) -> Just $ qiName qi+ Single (Composite qi) -> Just $ qiName qi+ _ -> Nothing+ type Schema = Text type TableName = Text-type SqlQuery = Text-type SqlFragment = Text data Table = Table { tableSchema :: Schema@@ -150,6 +204,9 @@ instance Eq Table where Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2 +tableQi :: Table -> QualifiedIdentifier+tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n+ newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord) data Column =@@ -171,8 +228,8 @@ 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)+-- | The source table column a view column refers to+type SourceColumn = (Column, ViewColumn) type ViewColumn = Column data PrimaryKey = PrimaryKey {@@ -203,34 +260,49 @@ data QualifiedIdentifier = QualifiedIdentifier { qiSchema :: Schema , qiName :: TableName-} deriving (Show, Eq, Ord)+} deriving (Show, Eq, Ord, Generic)+instance Hashable QualifiedIdentifier +-- | The relationship [cardinality](https://en.wikipedia.org/wiki/Cardinality_(data_modeling)).+-- | TODO: missing one-to-one+data Cardinality = O2M -- ^ one-to-many, previously known as Parent+ | M2O -- ^ many-to-one, previously known as Child+ | M2M -- ^ many-to-many, previously known as Many+ deriving Eq+instance Show Cardinality where+ show O2M = "o2m"+ show M2O = "m2o"+ show M2M = "m2m" -data RelationType = Child | Parent | Many | Root deriving (Show, Eq)+type ConstraintName = Text {-|- The name 'Relation' here is used with the meaning- "What is the relation between the current node and the parent node".- It has nothing to do with PostgreSQL referring to tables/views as relations.- The order of the relColumns and relFColumns should be maintained to get- the join conditions right.+ "Relation"ship between two tables.+ The order of the relColumns and relFColumns should be maintained to get the join conditions right. TODO merge relColumns and relFColumns to a tuple or Data.Bimap -} data Relation = Relation {- 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]+ relTable :: Table+, relColumns :: [Column]+, relConstraint :: Maybe ConstraintName -- ^ Just on O2M/M2O, Nothing on M2M+, relFTable :: Table+, relFColumns :: [Column]+, relType :: Cardinality+, relJunction :: Maybe Junction -- ^ Junction for M2M Cardinality } deriving (Show, Eq) -isSelfJoin :: Relation -> Bool-isSelfJoin r = relType r /= Root && relTable r == relFTable r+-- | Junction table on an M2M relationship+data Junction = Junction {+ junTable :: Table+, junConstraint1 :: Maybe ConstraintName+, junCols1 :: [Column]+, junConstraint2 :: Maybe ConstraintName+, junCols2 :: [Column]+} deriving (Show, Eq) +isSelfReference :: Relation -> Bool+isSelfReference r = relTable r == relFTable r+ data PayloadJSON = -- | Cached attributes of a JSON payload ProcessedJSON {@@ -333,24 +405,33 @@ Custom guc header, it's obtained by parsing the json in a: `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]' -}-newtype GucHeader = GucHeader (Text, Text)+newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)+ deriving (Show, Eq) instance JSON.FromJSON GucHeader where parseJSON (JSON.Object o) = case headMay (M.toList o) of- Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (k, s)+ Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s) | otherwise -> mzero _ -> mzero parseJSON _ = mzero -toHeaders :: [GucHeader] -> [Header]-toHeaders = map $ \(GucHeader (k, v)) -> (CI.mk $ toS k, toS v)+unwrapGucHeader :: GucHeader -> Header+unwrapGucHeader (GucHeader (k, v)) = (k, v) +-- | Add headers not already included to allow the user to override them instead of duplicating them+addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]+addHeadersIfNotIncluded newHeaders initialHeaders =+ filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders +++ initialHeaders+ {-| This type will hold information about which particular 'Relation' between two tables to choose when there are multiple ones. Specifically, it will contain the name of the foreign key or the join table in many to many relations. -}-type RelationDetail = Text-type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe RelationDetail)+type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)+-- | Disambiguates an embedding operation when there's multiple relationships between two tables.+-- | Can be the name of a foreign key constraint, column name or the junction in an m2m relationship.+type EmbedHint = Text -- | 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)@@ -359,11 +440,11 @@ data ReadQuery = Select { select :: [SelectItem]- , from :: TableName+ , from :: QualifiedIdentifier -- | 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]+ , implicitJoins :: [QualifiedIdentifier] , where_ :: [LogicTree] , joinConditions :: [JoinCondition] , order :: [OrderTerm]@@ -372,31 +453,35 @@ data MutateQuery = Insert {- in_ :: TableName+ in_ :: QualifiedIdentifier , insCols :: S.Set FieldName , onConflict :: Maybe (PreferResolution, [FieldName]) , where_ :: [LogicTree] , returning :: [FieldName] }| Update {- in_ :: TableName+ in_ :: QualifiedIdentifier , updCols :: S.Set FieldName , where_ :: [LogicTree] , returning :: [FieldName] }| Delete {- in_ :: TableName+ in_ :: QualifiedIdentifier , 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 +type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth))+type Depth = Integer++-- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))+fstFieldNames :: ReadRequest -> [FieldName]+fstFieldNames (Node (sel, _) _) =+ fst . view _1 <$> select sel+ data PgVersion = PgVersion { pgvNum :: Int32 , pgvName :: Text@@ -433,6 +518,9 @@ pgVersion114 :: PgVersion pgVersion114 = PgVersion 110004 "11.4" +pgVersion121 :: PgVersion+pgVersion121 = PgVersion 120001 "12.1"+ sourceCTEName :: SqlFragment sourceCTEName = "pg_source" @@ -440,8 +528,6 @@ 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
test/Feature/AndOrParamsSpec.hs view
@@ -11,7 +11,7 @@ import Protolude hiding (get) import SpecHelper -spec :: PgVersion -> SpecWith Application+spec :: PgVersion -> SpecWith ((), Application) spec actualPgVersion = describe "and/or params used for complex boolean logic" $ do context "used with GET" $ do
test/Feature/AsymmetricJwtSpec.hs view
@@ -11,7 +11,7 @@ import SpecHelper -- }}} -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "server started with asymmetric JWK" $ -- this test will stop working 9999999999s after the UNIX EPOCH
test/Feature/AudienceJwtSecretSpec.hs view
@@ -11,7 +11,7 @@ import SpecHelper -- }}} -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "test handling of aud claims in JWT" $ do -- this test will stop working 9999999999s after the UNIX EPOCH
test/Feature/AuthSpec.hs view
@@ -12,7 +12,7 @@ import Protolude hiding (get) import SpecHelper -spec :: PgVersion -> SpecWith Application+spec :: PgVersion -> SpecWith ((), Application) spec actualPgVersion = describe "authorization" $ do let single = ("Accept","application/vnd.pgrst.object+json")
test/Feature/BinaryJwtSecretSpec.hs view
@@ -11,7 +11,7 @@ import SpecHelper -- }}} -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "server started with binary JWT secret" $ -- this test will stop working 9999999999s after the UNIX EPOCH
test/Feature/ConcurrentSpec.hs view
@@ -19,9 +19,9 @@ import Protolude hiding (get) -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec =- describe "Queryiny in parallel" $+ describe "Querying in parallel" $ it "should not raise 'transaction in progress' error" $ raceTest 10 $ get "/fakefake"@@ -35,13 +35,13 @@ , matchHeaders = [] } -raceTest :: Int -> WaiExpectation -> WaiExpectation+raceTest :: Int -> WaiExpectation st -> WaiExpectation st raceTest times = liftBaseDiscard go where go test = void $ mapConcurrently (const test) [1..times] -instance MonadBaseControl IO WaiSession where- type StM WaiSession a = StM Session a+instance MonadBaseControl IO (WaiSession st) where+ type StM (WaiSession st) a = StM Session a liftBaseWith f = WaiSession $ liftBaseWith $ \runInBase -> f $ \k -> runInBase (unWaiSession k)@@ -49,5 +49,5 @@ {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} -instance MonadBase IO WaiSession where+instance MonadBase IO (WaiSession st) where liftBase = liftIO
test/Feature/CorsSpec.hs view
@@ -14,7 +14,7 @@ import SpecHelper -- }}} -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "CORS" $ do let preflightHeaders = [
test/Feature/DeleteSpec.hs view
@@ -5,11 +5,12 @@ import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai+import Test.Hspec.Wai.JSON import Text.Heredoc import Protolude hiding (get) -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "Deleting" $ do context "existing record" $ do@@ -36,7 +37,7 @@ request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] "" `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|] it "can embed (parent) entities" $- request methodDelete "/tasks?id=eq.8&select=id,name,project(id)" [("Prefer", "return=representation")] ""+ request methodDelete "/tasks?id=eq.8&select=id,name,project:projects(id)" [("Prefer", "return=representation")] "" `shouldRespondWith` [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "*/*"]@@ -62,3 +63,24 @@ context "totally unknown route" $ it "fails with 404" $ request methodDelete "/foozle?id=eq.101" [] "" `shouldRespondWith` 404++ context "table with limited privileges" $ do+ it "fails deleting the row when return=representation and selecting all the columns" $+ request methodDelete "/app_users?id=eq.1" [("Prefer", "return=representation")] mempty+ `shouldRespondWith` 401++ it "succeeds deleting the row when return=representation and selecting only the privileged columns" $+ request methodDelete "/app_users?id=eq.1&select=id,email" [("Prefer", "return=representation")]+ [json| { "password": "passxyz" } |]+ `shouldRespondWith` [json|[ { "id": 1, "email": "test@123.com" } ]|]+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "*/*"]+ }++ it "suceeds deleting the row with no explicit select when using return=minimal" $+ request methodDelete "/app_users?id=eq.2" [("Prefer", "return=minimal")] mempty+ `shouldRespondWith` 204++ it "suceeds deleting the row with no explicit select by default" $+ request methodDelete "/app_users?id=eq.3" [] mempty+ `shouldRespondWith` 204
+ test/Feature/EmbedDisambiguationSpec.hs view
@@ -0,0 +1,434 @@+module Feature.EmbedDisambiguationSpec where++import Network.Wai (Application)++import Test.Hspec hiding (pendingWith)+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON+import Text.Heredoc++import Protolude hiding (get)+import SpecHelper++spec :: SpecWith ((), Application)+spec =+ describe "resource embedding disambiguation" $ do+ context "ambiguous requests that give 300 Multiple Choices" $ do+ it "errs when there's a table and view that point to the same fk" $+ get "/message?select=id,body,sender(name,sent)" `shouldRespondWith`+ [json|+ {+ "details": [+ {+ "cardinality": "m2o",+ "relationship": "message_sender_fkey[sender][id]",+ "origin": "test.message",+ "target": "test.person"+ },+ {+ "cardinality": "m2o",+ "relationship": "message_sender_fkey[sender][id]",+ "origin": "test.message",+ "target": "test.person_detail"+ }+ ],+ "hint": "By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)",+ "message": "More than one relationship was found for message and sender"+ }+ |]+ { matchStatus = 300+ , matchHeaders = [matchContentTypeJson]+ }++ it "errs when there are o2m and m2m cardinalities to the target table" $+ get "/sites?select=*,big_projects(*)" `shouldRespondWith`+ [json|+ {+ "details": [+ {+ "cardinality": "m2o",+ "relationship": "main_project[main_project_id][big_project_id]",+ "origin": "test.sites",+ "target": "test.big_projects"+ },+ {+ "cardinality": "m2m",+ "relationship": "test.jobs[jobs_site_id_fkey][jobs_big_project_id_fkey]",+ "origin": "test.sites",+ "target": "test.big_projects"+ },+ {+ "cardinality": "m2m",+ "relationship": "test.main_jobs[jobs_site_id_fkey][jobs_big_project_id_fkey]",+ "origin": "test.sites",+ "target": "test.big_projects"+ }+ ],+ "hint": "By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)",+ "message": "More than one relationship was found for sites and big_projects"+ }+ |]+ { matchStatus = 300+ , matchHeaders = [matchContentTypeJson]+ }++ it "errs on an ambiguous embed that has a circular reference" $+ get "/agents?select=*,departments(*)" `shouldRespondWith`+ [json|+ {+ "details": [+ {+ "cardinality": "m2o",+ "relationship": "agents_department_id_fkey[department_id][id]",+ "origin": "test.agents",+ "target": "test.departments"+ },+ {+ "cardinality": "o2m",+ "relationship": "departments_head_id_fkey[id][head_id]",+ "origin": "test.agents",+ "target": "test.departments"+ }+ ],+ "hint": "By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)",+ "message": "More than one relationship was found for agents and departments"+ }+ |]+ { matchStatus = 300+ , matchHeaders = [matchContentTypeJson]+ }++ it "errs when there are more than two fks on a junction table(currently impossible to disambiguate, only choice is to split the table)" $+ -- We have 4 possibilities for doing the junction JOIN here.+ -- This could be solved by specifying two additional fks, like whatev_projects!fk1!fk2(*)+ -- If the need arises this capability can be added later without causing a breaking change+ get "/whatev_sites?select=*,whatev_projects(*)" `shouldRespondWith`+ [json|+ {+ "details": [+ {+ "cardinality": "m2m",+ "relationship": "test.whatev_jobs[whatev_jobs_site_id_1_fkey][whatev_jobs_project_id_1_fkey]",+ "origin": "test.whatev_sites",+ "target": "test.whatev_projects"+ },+ {+ "cardinality": "m2m",+ "relationship": "test.whatev_jobs[whatev_jobs_site_id_1_fkey][whatev_jobs_project_id_2_fkey]",+ "origin": "test.whatev_sites",+ "target": "test.whatev_projects"+ },+ {+ "cardinality": "m2m",+ "relationship": "test.whatev_jobs[whatev_jobs_site_id_2_fkey][whatev_jobs_project_id_1_fkey]",+ "origin": "test.whatev_sites",+ "target": "test.whatev_projects"+ },+ {+ "cardinality": "m2m",+ "relationship": "test.whatev_jobs[whatev_jobs_site_id_2_fkey][whatev_jobs_project_id_2_fkey]",+ "origin": "test.whatev_sites",+ "target": "test.whatev_projects"+ }+ ],+ "hint": "By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)",+ "message": "More than one relationship was found for whatev_sites and whatev_projects"+ }+ |]+ { matchStatus = 300+ , matchHeaders = [matchContentTypeJson]+ }++ context "disambiguating requests with embed hints" $ do++ context "using FK to specify the relationship" $ do+ it "can embed by FK name" $+ get "/projects?id=in.(1,3)&select=id,name,client(id,name)" `shouldRespondWith`+ [json|[{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client":{"id":2,"name":"Apple"}}]|]+ { matchHeaders = [matchContentTypeJson] }++ it "can embed by FK name and select the FK column at the same time" $+ get "/projects?id=in.(1,3)&select=id,name,client_id,client(id,name)" `shouldRespondWith`+ [json|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|]+ { matchHeaders = [matchContentTypeJson] }++ it "can embed parent with view!fk and grandparent by using fk" $+ get "/tasks?id=eq.1&select=id,name,projects_view!project(id,name,client(id,name))" `shouldRespondWith`+ [str|[{"id":1,"name":"Design w7","projects_view":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]++ it "can embed by using a composite FK name" $+ get "/unit_workdays?select=unit_id,day,fst_shift(car_id,schedule(name)),snd_shift(camera_id,schedule(name))" `shouldRespondWith`+ [json| [+ {+ "day": "2019-12-02",+ "fst_shift": {+ "car_id": "CAR-349",+ "schedule": {+ "name": "morning"+ }+ },+ "snd_shift": {+ "camera_id": "CAM-123",+ "schedule": {+ "name": "night"+ }+ },+ "unit_id": 1+ }+ ] |]+ { matchHeaders = [matchContentTypeJson] }++ it "embeds by using two fks pointing to the same table" $+ get "/orders?id=eq.1&select=id, name, billing(address), shipping(address)" `shouldRespondWith`+ [json|[{"id":1,"name":"order 1","billing":{"address": "address 1"},"shipping":{"address": "address 2"}}]|]+ { matchHeaders = [matchContentTypeJson] }++ it "fails if the fk is not known" $+ get "/message?select=id,sender:person!space(name)&id=lt.4" `shouldRespondWith`+ [json|{"message":"Could not find foreign keys between these entities. No relationship found between message and person"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson] }++ it "can request a parent with fk" $+ get "/comments?select=content,user(name)" `shouldRespondWith`+ [json|[ { "content": "Needs to be delivered ASAP", "user": { "name": "Angela Martin" } } ]|]+ { matchHeaders = [matchContentTypeJson] }++ it "can request two parents with fks" $+ 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"}}]|]+ { matchHeaders = [matchContentTypeJson] }++ it "can specify a view!fk" $+ get "/message?select=id,body,sender:person_detail!message_sender_fkey(name,sent),recipient:person_detail!message_recipient_fkey(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}},+ {"id":3,"body":"How are you doing?","sender":{"name":"John","sent":2},"recipient":{"name":"Jane","received":2}}] |]+ { matchHeaders = [matchContentTypeJson] }++ it "can specify a table!fk hint and request children 2 levels" $+ get "/clients?id=eq.1&select=id,projects:projects!client(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 "can disambiguate with the fk in case of an o2m and m2m relationship to the same table" $+ get "/sites?select=name,main_project(name)&site_id=eq.1" `shouldRespondWith`+ [json| [ { "name": "site 1", "main_project": { "name": "big project 1" } } ] |]+ { matchHeaders = [matchContentTypeJson] }++ context "using the column name of the FK to specify the relationship" $ do+ it "can embed by column" $+ get "/projects?id=in.(1,3)&select=id,name,client_id(id,name)" `shouldRespondWith`+ [json|[{"id":1,"name":"Windows 7","client_id":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":{"id":2,"name":"Apple"}}]|]+ { matchHeaders = [matchContentTypeJson] }++ it "can embed by column and select the column at the same time, if aliased" $+ get "/projects?id=in.(1,3)&select=id,name,client_id,client:client_id(id,name)" `shouldRespondWith`+ [json|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|]+ { matchHeaders = [matchContentTypeJson] }++ it "can embed parent by using view!column and grandparent by using the column" $+ get "/tasks?id=eq.1&select=id,name,project:projects_view!project_id(id,name,client:client_id(id,name))" `shouldRespondWith`+ [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]++ it "can specify table!column" $+ get "/message?select=id,body,sender:person!sender(name),recipient:person!recipient(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 "will embed using a column that has uppercase chars" $+ get "/ghostBusters?select=escapeId(*)" `shouldRespondWith`+ [json| [{"escapeId":{"so6meIdColumn":1}},{"escapeId":{"so6meIdColumn":3}},{"escapeId":{"so6meIdColumn":5}}] |]+ { matchHeaders = [matchContentTypeJson] }++ it "embeds by using two columns pointing to the same table" $+ get "/orders?id=eq.1&select=id, name, billing_address_id(id), shipping_address_id(id)" `shouldRespondWith`+ [json|[{"id":1,"name":"order 1","billing_address_id":{"id":1},"shipping_address_id":{"id":2}}]|]+ { matchHeaders = [matchContentTypeJson] }++ it "can disambiguate with the column in case of an o2m and m2m relationship to the same table" $+ get "/sites?select=name,main_project_id(name)&site_id=eq.1" `shouldRespondWith`+ [json| [ { "name": "site 1", "main_project_id": { "name": "big project 1" } } ] |]+ { matchHeaders = [matchContentTypeJson] }++ context "using the junction to disambiguate the request" $+ it "can specify the junction of an m2m relationship" $ do+ get "/sites?select=*,big_projects!jobs(name)&site_id=in.(1,2)" `shouldRespondWith`+ [json|+ [+ {+ "big_projects": [+ {+ "name": "big project 1"+ }+ ],+ "main_project_id": 1,+ "name": "site 1",+ "site_id": 1+ },+ {+ "big_projects": [+ {+ "name": "big project 1"+ },+ {+ "name": "big project 2"+ }+ ],+ "main_project_id": null,+ "name": "site 2",+ "site_id": 2+ }+ ]+ |]+ get "/sites?select=*,big_projects!main_jobs(name)&site_id=in.(1,2)" `shouldRespondWith`+ [json|+ [+ {+ "big_projects": [+ {+ "name": "big project 1"+ }+ ],+ "main_project_id": 1,+ "name": "site 1",+ "site_id": 1+ },+ {+ "big_projects": [],+ "main_project_id": null,+ "name": "site 2",+ "site_id": 2+ }+ ]+ |]+ { matchHeaders = [matchContentTypeJson] }++ context "using a FK column and a FK to specify the relationship" $+ it "embeds by using a column and a fk pointing to the same table" $+ get "/orders?id=eq.1&select=id, name, billing_address_id(id), shipping(id)" `shouldRespondWith`+ [json|[{"id":1,"name":"order 1","billing_address_id":{"id":1},"shipping":{"id":2}}]|]+ { matchHeaders = [matchContentTypeJson] }++ context "tables with self reference foreign keys" $ do+ context "one self reference foreign key" $ do+ it "embeds parents recursively" $+ get "/family_tree?id=in.(3,4)&select=id,parent(id,name,parent(*))" `shouldRespondWith`+ [json|[+ { "id": "3", "parent": { "id": "1", "name": "Parental Unit", "parent": null } },+ { "id": "4", "parent": { "id": "2", "name": "Kid One", "parent": { "id": "1", "name": "Parental Unit", "parent": null } } }+ ]|]+ { 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`+ [json|[{+ "id": "1", "name": "Parental Unit", "childs": [+ { "id": "2", "name": "Kid One", "childs": [ { "id": "4", "name": "Grandkid One" } ] },+ { "id": "3", "name": "Kid Two", "childs": [ { "id": "5", "name": "Grandkid Two" } ] }+ ]+ }]|] { 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`+ [json|[{+ "id": "2", "name": "Kid One", "parent": {+ "id": "1", "name": "Parental Unit", "childs": [ { "id": "2", "name": "Kid One" }, { "id": "3", "name": "Kid Two"} ]+ }+ }]|] { matchHeaders = [matchContentTypeJson] }++ context "two self reference foreign keys" $ do+ it "embeds parents" $+ get "/organizations?select=id,name,referee(id,name),auditor(id,name)&id=eq.3" `shouldRespondWith`+ [json|[{+ "id": 3, "name": "Acme",+ "referee": {+ "id": 1,+ "name": "Referee Org"+ },+ "auditor": {+ "id": 2,+ "name": "Auditor Org"+ }+ }]|] { matchHeaders = [matchContentTypeJson] }++ it "embeds childs" $ do+ get "/organizations?select=id,name,refereeds:organizations!referee(id,name)&id=eq.1" `shouldRespondWith`+ [json|[{+ "id": 1, "name": "Referee Org",+ "refereeds": [+ {+ "id": 3,+ "name": "Acme"+ },+ {+ "id": 4,+ "name": "Umbrella"+ }+ ]+ }]|] { matchHeaders = [matchContentTypeJson] }+ get "/organizations?select=id,name,auditees:organizations!auditor(id,name)&id=eq.2" `shouldRespondWith`+ [json|[{+ "id": 2, "name": "Auditor Org",+ "auditees": [+ {+ "id": 3,+ "name": "Acme"+ },+ {+ "id": 4,+ "name": "Umbrella"+ }+ ]+ }]|] { 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!auditor(name,manager(name),refereeds:organizations!referee(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] }++ -- TODO Remove in next major version+ 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] }+
test/Feature/ExtraSearchPathSpec.hs view
@@ -9,7 +9,7 @@ import Protolude import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "extra search path" $ do it "finds the ltree <@ operator on the public schema" $
test/Feature/HtmlRawOutputSpec.hs view
@@ -10,7 +10,7 @@ import Protolude hiding (get) import SpecHelper (acceptHdrs) -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "When raw-media-types is set to \"text/html\"" $ it "can get raw output with Accept: text/html" $ request methodGet "/rpc/welcome.html" (acceptHdrs "text/html") ""
test/Feature/InsertSpec.hs view
@@ -20,7 +20,7 @@ import Protolude hiding (get) import SpecHelper -spec :: PgVersion -> SpecWith Application+spec :: PgVersion -> SpecWith ((), Application) spec actualPgVersion = do describe "Posting new record" $ do context "disparate json types" $ do@@ -148,15 +148,6 @@ simpleBody p `shouldBe` [json| [] |] simpleStatus p `shouldBe` created201 - it "can insert in tables with no select privileges" $ do- p <- request methodPost "/insertonly"- [("Prefer", "return=minimal")]- [json| { "v":"some value" } |]- liftIO $ do- simpleBody p `shouldBe` ""- simpleStatus p `shouldBe` created201-- it "can post nulls" $ do p <- request methodPost "/no_pk" [("Prefer", "return=representation")]@@ -260,36 +251,6 @@ , 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")]- [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` [str|[{"article_id":2,"user_id":1}]|]- { matchStatus = 201- , matchHeaders = []- }- 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` (- 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` (- 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 = []- }- context "POST with ?columns parameter" $ do it "ignores json keys not included in ?columns" $ do request methodPost "/articles?columns=id,body" [("Prefer", "return=representation")]@@ -537,7 +498,7 @@ matchHeaders = ["Content-Range" <:> "*/*"] } - it "makes no updates and and returns 200, when patching with an empty json object and return=rep" $+ it "makes no updates and returns 200, when patching with an empty json object and return=rep" $ request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |] `shouldRespondWith` "[]" {@@ -588,3 +549,129 @@ liftIO $ do simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|] simpleStatus p2 `shouldBe` created201++ context "tables with self reference foreign keys" $ do+ it "embeds parent after insert" $+ request methodPost "/web_content?select=id,name,parent_content:p_web_id(name)"+ [("Prefer", "return=representation")]+ [json|{"id":6, "name":"wot", "p_web_id":4}|]+ `shouldRespondWith`+ [json|[{"id":6,"name":"wot","parent_content":{"name":"wut"}}]|]+ { matchStatus = 201+ , matchHeaders = [ matchContentTypeJson , "Location" <:> "/web_content?id=eq.6" ]+ }++ it "embeds childs after update" $+ request methodPatch "/web_content?id=eq.0&select=id,name,web_content(name)"+ [("Prefer", "return=representation")]+ [json|{"name": "tardis-patched"}|]+ `shouldRespondWith`+ [json|+ [ { "id": 0, "name": "tardis-patched", "web_content": [ { "name": "fezz" }, { "name": "foo" }, { "name": "bar" } ]} ]+ |]+ { matchStatus = 200,+ matchHeaders = [matchContentTypeJson]+ }++ it "embeds parent, childs and grandchilds after update" $+ request methodPatch "/web_content?id=eq.0&select=id,name,web_content(name,web_content(name)),parent_content:p_web_id(name)"+ [("Prefer", "return=representation")]+ [json|{"name": "tardis-patched-2"}|]+ `shouldRespondWith`+ [json| [+ {+ "id": 0,+ "name": "tardis-patched-2",+ "parent_content": { "name": "wat" },+ "web_content": [+ { "name": "fezz", "web_content": [ { "name": "wut" } ] },+ { "name": "foo", "web_content": [] },+ { "name": "bar", "web_content": [] }+ ]+ }+ ] |]+ { matchStatus = 200,+ matchHeaders = [matchContentTypeJson]+ }++ it "embeds childs after update without explicitly including the id in the ?select" $+ request methodPatch "/web_content?id=eq.0&select=name,web_content(name)"+ [("Prefer", "return=representation")]+ [json|{"name": "tardis-patched"}|]+ `shouldRespondWith`+ [json|+ [ { "name": "tardis-patched", "web_content": [ { "name": "fezz" }, { "name": "foo" }, { "name": "bar" } ]} ]+ |]+ { matchStatus = 200,+ matchHeaders = [matchContentTypeJson]+ }++ it "embeds an M2M relationship plus parent after update" $+ request methodPatch "/users?id=eq.1&select=name,tasks(name,project:projects(name))"+ [("Prefer", "return=representation")]+ [json|{"name": "Kevin Malone"}|]+ `shouldRespondWith`+ [json|[+ {+ "name": "Kevin Malone",+ "tasks": [+ { "name": "Design w7", "project": { "name": "Windows 7" } },+ { "name": "Code w7", "project": { "name": "Windows 7" } },+ { "name": "Design w10", "project": { "name": "Windows 10" } },+ { "name": "Code w10", "project": { "name": "Windows 10" } }+ ]+ }+ ]|]+ { matchStatus = 200,+ matchHeaders = [matchContentTypeJson]+ }++ context "table with limited privileges" $ do+ it "succeeds inserting if correct select is applied" $+ request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")]+ [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` [str|[{"article_id":2,"user_id":1}]|]+ { matchStatus = 201+ , matchHeaders = []+ }++ it "fails inserting 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` (+ 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 inserting if select is not specified" $+ request methodPost "/limited_article_stars" [("Prefer", "return=representation")]+ [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 = []+ }++ it "can insert in a table with no select and return=minimal" $ do+ p <- request methodPost "/insertonly"+ [("Prefer", "return=minimal")]+ [json| { "v":"some value" } |]+ liftIO $ do+ simpleBody p `shouldBe` ""+ simpleStatus p `shouldBe` created201++ it "succeeds updating row and gives a 204 when using return=minimal" $+ request methodPatch "/app_users?id=eq.1" [("Prefer", "return=minimal")]+ [json| { "password": "passxyz" } |]+ `shouldRespondWith` 204++ it "can update without return=minimal and no explicit select" $+ request methodPatch "/app_users?id=eq.1" []+ [json| { "password": "passabc" } |]+ `shouldRespondWith` 204
test/Feature/JsonOperatorSpec.hs view
@@ -7,11 +7,11 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import PostgREST.Types (PgVersion, pgVersion112)+import PostgREST.Types (PgVersion, pgVersion112, pgVersion121) import Protolude hiding (get) import SpecHelper -spec :: PgVersion -> SpecWith Application+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" $@@ -26,7 +26,12 @@ it "fails on bad casting (data of the wrong format)" $ get "/complex_items?select=settings->foo->>bar::integer"- `shouldRespondWith` [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"baz\""} |]+ `shouldRespondWith` (+ if actualPgVersion >= pgVersion121 then+ [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for type integer: \"baz\""} |]+ else+ [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"baz\""} |]+ ) { matchStatus = 400 , matchHeaders = [] } it "obtains a json subfield two levels (string)" $
+ test/Feature/MultipleSchemaSpec.hs view
@@ -0,0 +1,324 @@+module Feature.MultipleSchemaSpec where++import Control.Lens ((^?))+import Data.Aeson.Lens+import Data.Aeson.QQ++import Network.HTTP.Types+import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleHeaders), simpleBody)++import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON++import Protolude+import SpecHelper++import PostgREST.Types (PgVersion, pgVersion96)++spec :: PgVersion -> SpecWith ((), Application)+spec actualPgVersion =+ describe "multiple schemas in single instance" $ do+ context "Reading tables on different schemas" $ do+ it "succeeds in reading table from default schema v1 if no schema is selected via header" $+ request methodGet "/parents" [] "" `shouldRespondWith`+ [json|[+ {"id":1,"name":"parent v1-1"},+ {"id":2,"name":"parent v1-2"}+ ]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"]+ }++ it "succeeds in reading table from default schema v1 after explicitly passing it in the header" $+ request methodGet "/parents" [("Accept-Profile", "v1")] "" `shouldRespondWith`+ [json|[+ {"id":1,"name":"parent v1-1"},+ {"id":2,"name":"parent v1-2"}+ ]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"]+ }++ it "succeeds in reading table from schema v2" $+ request methodGet "/parents" [("Accept-Profile", "v2")] "" `shouldRespondWith`+ [json|[+ {"id":3,"name":"parent v2-3"},+ {"id":4,"name":"parent v2-4"}+ ]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]+ }++ it "succeeds in reading another_table from schema v2" $+ request methodGet "/another_table" [("Accept-Profile", "v2")] "" `shouldRespondWith`+ [json|[+ {"id":5,"another_value":"value 5"},+ {"id":6,"another_value":"value 6"}+ ]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]+ }++ it "doesn't find another_table in schema v1" $+ request methodGet "/another_table" [("Accept-Profile", "v1")] "" `shouldRespondWith` 404++ it "fails trying to read table from unkown schema" $+ request methodGet "/parents" [("Accept-Profile", "unkown")] "" `shouldRespondWith`+ [json|{"message":"The schema must be one of the following: v1, v2"}|]+ {+ matchStatus = 406+ }++ context "Inserting tables on different schemas" $ do+ it "succeeds inserting on default schema and returning it" $+ request methodPost "/childs" [("Prefer", "return=representation")] [json|{"name": "child v1-1", "parent_id": 1}|]+ `shouldRespondWith`+ [json|[{"id":1, "name": "child v1-1", "parent_id": 1}]|]+ {+ matchStatus = 201+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"]+ }++ it "succeeds inserting on the v1 schema and returning its parent" $+ request methodPost "/childs?select=id,parent(*)" [("Prefer", "return=representation"), ("Content-Profile", "v1")]+ [json|{"name": "child v1-2", "parent_id": 2}|]+ `shouldRespondWith`+ [json|[{"id":2, "parent": {"id": 2, "name": "parent v1-2"}}]|]+ {+ matchStatus = 201+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"]+ }++ it "succeeds inserting on the v2 schema and returning its parent" $+ request methodPost "/childs?select=id,parent(*)" [("Prefer", "return=representation"), ("Content-Profile", "v2")]+ [json|{"name": "child v2-3", "parent_id": 3}|]+ `shouldRespondWith`+ [json|[{"id":1, "parent": {"id": 3, "name": "parent v2-3"}}]|]+ {+ matchStatus = 201+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]+ }++ it "fails when inserting on an unknown schema" $+ request methodPost "/childs" [("Content-Profile", "unknown")]+ [json|{"name": "child 4", "parent_id": 4}|]+ `shouldRespondWith`+ [json|{"message":"The schema must be one of the following: v1, v2"}|]+ {+ matchStatus = 406+ }++ context "calling procs on different schemas" $ do+ it "succeeds in calling the default schema proc" $+ request methodGet "/rpc/get_parents_below?id=6" [] ""+ `shouldRespondWith`+ [json|[{"id":1,"name":"parent v1-1"}, {"id":2,"name":"parent v1-2"}]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"]+ }++ it "succeeds in calling the v1 schema proc and embedding" $+ request methodGet "/rpc/get_parents_below?id=6&select=id,name,childs(id,name)" [("Accept-Profile", "v1")] ""+ `shouldRespondWith`+ [json| [+ {"id":1,"name":"parent v1-1","childs":[{"id":1,"name":"child v1-1"}]},+ {"id":2,"name":"parent v1-2","childs":[{"id":2,"name":"child v1-2"}]}] |]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"]+ }++ it "succeeds in calling the v2 schema proc and embedding" $+ request methodGet "/rpc/get_parents_below?id=6&select=id,name,childs(id,name)" [("Accept-Profile", "v2")] ""+ `shouldRespondWith`+ [json| [+ {"id":3,"name":"parent v2-3","childs":[{"id":1,"name":"child v2-3"}]},+ {"id":4,"name":"parent v2-4","childs":[]}] |]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]+ }++ context "Modifying tables on different schemas" $ do+ it "succeeds in patching on the v1 schema and returning its parent" $+ request methodPatch "/childs?select=name,parent(name)&id=eq.1" [("Content-Profile", "v1"), ("Prefer", "return=representation")]+ [json|{"name": "child v1-1 updated"}|]+ `shouldRespondWith`+ [json|[{"name":"child v1-1 updated", "parent": {"name": "parent v1-1"}}]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"]+ }++ it "succeeds in patching on the v2 schema and returning its parent" $+ request methodPatch "/childs?select=name,parent(name)&id=eq.1" [("Content-Profile", "v2"), ("Prefer", "return=representation")]+ [json|{"name": "child v2-1 updated"}|]+ `shouldRespondWith`+ [json|[{"name":"child v2-1 updated", "parent": {"name": "parent v2-3"}}]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]+ }++ it "succeeds on deleting on the v2 schema" $ do+ request methodDelete "/childs?id=eq.1" [("Content-Profile", "v2"), ("Prefer", "return=representation")] ""+ `shouldRespondWith` [json|[{"id": 1, "name": "child v2-1 updated", "parent_id": 3}]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]+ }+ request methodGet "/childs?id=eq.1" [("Accept-Profile", "v2")] ""+ `shouldRespondWith` "[]"+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]+ }++ when (actualPgVersion >= pgVersion96) $+ it "succeeds on PUT on the v2 schema" $+ request methodPut "/childs?id=eq.111" [("Content-Profile", "v2"), ("Prefer", "return=representation")]+ [json| [ { "id": 111, "name": "child v2-111", "parent_id": null } ]|]+ `shouldRespondWith`+ [json|[{ "id": 111, "name": "child v2-111", "parent_id": null }]|]+ {+ matchStatus = 200+ , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]+ }++ context "OpenAPI output" $ do+ it "succeeds in reading table definition from default schema v1 if no schema is selected via header" $ do+ req <- request methodGet "/" [] ""++ liftIO $ do+ simpleHeaders req `shouldSatisfy` matchHeader "Content-Profile" "v1"++ let def = simpleBody req ^? key "definitions" . key "parents"++ def `shouldBe` Just+ [aesonQQ|+ {+ "type" : "object",+ "properties" : {+ "id" : {+ "description" : "Note:\nThis is a Primary Key.<pk/>",+ "format" : "integer",+ "type" : "integer"+ },+ "name" : {+ "format" : "text",+ "type" : "string"+ }+ },+ "required" : [+ "id"+ ]+ }+ |]++ it "succeeds in reading table definition from default schema v1 after explicitly passing it in the header" $ do+ r <- request methodGet "/" [("Accept-Profile", "v1")] ""++ liftIO $ do+ simpleHeaders r `shouldSatisfy` matchHeader "Content-Profile" "v1"++ let def = simpleBody r ^? key "definitions" . key "parents"++ def `shouldBe` Just+ [aesonQQ|+ {+ "type" : "object",+ "properties" : {+ "id" : {+ "description" : "Note:\nThis is a Primary Key.<pk/>",+ "format" : "integer",+ "type" : "integer"+ },+ "name" : {+ "format" : "text",+ "type" : "string"+ }+ },+ "required" : [+ "id"+ ]+ }+ |]++ it "succeeds in reading table definition from schema v2" $ do+ r <- request methodGet "/" [("Accept-Profile", "v2")] ""++ liftIO $ do+ simpleHeaders r `shouldSatisfy` matchHeader "Content-Profile" "v2"++ let def = simpleBody r ^? key "definitions" . key "parents"++ def `shouldBe` Just+ [aesonQQ|+ {+ "type" : "object",+ "properties" : {+ "id" : {+ "description" : "Note:\nThis is a Primary Key.<pk/>",+ "format" : "integer",+ "type" : "integer"+ },+ "name" : {+ "format" : "text",+ "type" : "string"+ }+ },+ "required" : [+ "id"+ ]+ }+ |]++ it "succeeds in reading another_table definition from schema v2" $ do+ r <- request methodGet "/" [("Accept-Profile", "v2")] ""++ liftIO $ do+ simpleHeaders r `shouldSatisfy` matchHeader "Content-Profile" "v2"++ let def = simpleBody r ^? key "definitions" . key "another_table"++ def `shouldBe` Just+ [aesonQQ|+ {+ "type" : "object",+ "properties" : {+ "id" : {+ "description" : "Note:\nThis is a Primary Key.<pk/>",+ "format" : "integer",+ "type" : "integer"+ },+ "another_value" : {+ "format" : "text",+ "type" : "string"+ }+ },+ "required" : [+ "id"+ ]+ }+ |]++ it "doesn't find another_table definition in schema v1" $ do+ r <- request methodGet "/" [("Accept-Profile", "v1")] ""++ liftIO $ do+ let def = simpleBody r ^? key "definitions" . key "another_table"+ def `shouldBe` Nothing++ it "fails trying to read definitions from unkown schema" $+ request methodGet "/" [("Accept-Profile", "unkown")] "" `shouldRespondWith`+ [json|{"message":"The schema must be one of the following: v1, v2"}|]+ {+ matchStatus = 406+ }
test/Feature/NoJwtSpec.hs view
@@ -13,7 +13,7 @@ import SpecHelper -- }}} -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "server started without JWT secret" $ do -- this test will stop working 9999999999s after the UNIX EPOCH
test/Feature/NonexistentSchemaSpec.hs view
@@ -7,7 +7,7 @@ import Protolude hiding (get) -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "Non existent api schema" $ do it "succeeds when requesting root path" $
test/Feature/PgVersion95Spec.hs view
@@ -9,7 +9,7 @@ import Protolude hiding (get) import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "features supported on PostgreSQL 9.5" $ context "json array negative index" $ do it "can select with negative indexes" $ do
test/Feature/PgVersion96Spec.hs view
@@ -1,6 +1,8 @@ module Feature.PgVersion96Spec where -import Network.Wai (Application)+import Network.HTTP.Types+import Network.Wai (Application)+import Network.Wai.Test (SResponse (simpleHeaders)) import Test.Hspec import Test.Hspec.Wai@@ -9,10 +11,10 @@ import Protolude hiding (get) import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "features supported on PostgreSQL 9.6" $ do- context "GUC headers" $ do+ context "GUC headers on function calls" $ do it "succeeds setting the headers" $ do get "/rpc/get_projects_and_guc_headers?id=eq.2&select=id" `shouldRespondWith` [json|[{"id": 2}]|]@@ -66,6 +68,98 @@ matchContentTypeJson, "Set-Cookie" <:> "sessionid=38afes7a8; HttpOnly; Path=/", "Set-Cookie" <:> "id=a3fWa; Expires=Wed, 21 Oct 2015 07:28:00 GMT; Secure; HttpOnly"]}++ context "GUC headers on all other methods via pre-request" $ do+ it "succeeds setting the headers on GET and HEAD" $ do+ request methodGet "/items?id=eq.1" [("User-Agent", "MSIE 6.0")] mempty+ `shouldRespondWith` [json|[{"id": 1}]|]+ {matchHeaders = [+ matchContentTypeJson,+ "Cache-Control" <:> "no-cache, no-store, must-revalidate"]}++ request methodHead "/items?id=eq.1" [("User-Agent", "MSIE 7.0")] mempty+ `shouldRespondWith` ""+ {matchHeaders = ["Cache-Control" <:> "no-cache, no-store, must-revalidate"]}++ request methodHead "/projects" [("Accept", "text/csv")] mempty+ `shouldRespondWith` ""+ {matchHeaders = ["Content-Disposition" <:> "attachment; filename=projects.csv"]}++ it "succeeds setting the headers on POST" $+ request methodPost "/items" [] [json|[{"id": 11111}]|]+ `shouldRespondWith` ""+ { matchStatus = 201+ , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]+ }++ it "succeeds setting the headers on PATCH" $+ request methodPatch "/items?id=eq.11111" [] [json|[{"id": 11111}]|]+ `shouldRespondWith` ""+ { matchStatus = 204+ , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]+ }++ it "succeeds setting the headers on PUT" $+ request methodPut "/items?id=eq.11111" [] [json|[{"id": 11111}]|]+ `shouldRespondWith` ""+ { matchStatus = 204+ , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]+ }++ it "succeeds setting the headers on DELETE" $+ request methodDelete "/items?id=eq.11111" [] mempty+ `shouldRespondWith` ""+ { matchStatus = 204+ , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]+ }++ context "Override provided headers by using GUC headers" $ do+ it "can override the Content-Type header" $ do+ request methodHead "/clients?id=eq.1" [] mempty+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/geo+json"]+ }+ request methodHead "/rpc/getallprojects" [] mempty+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/geo+json"]+ }++ it "can override the Location header" $+ request methodPost "/stuff" [] [json|[{"id": 1, "name": "stuff 1"}]|]+ `shouldRespondWith` ""+ { matchStatus = 201+ , matchHeaders = ["Location" <:> "/stuff?id=eq.1&overriden=true"]+ }++ -- On https://github.com/PostgREST/postgrest/issues/1427#issuecomment-595907535+ -- it was reported that blank headers ` : ` where added and that cause proxies to fail the requests.+ -- These tests are to ensure no blank headers are added.+ context "Blank headers bug" $ do+ it "shouldn't add blank headers on POST" $ do+ r <- request methodPost "/loc_test" [] [json|{"id": "1", "c": "c1"}|]+ liftIO $ do+ let respHeaders = simpleHeaders r+ respHeaders `shouldSatisfy` noBlankHeader++ it "shouldn't add blank headers on PATCH" $ do+ r <- request methodPatch "/loc_test?id=eq.1" [] [json|{"c": "c2"}|]+ liftIO $ do+ let respHeaders = simpleHeaders r+ respHeaders `shouldSatisfy` noBlankHeader++ it "shouldn't add blank headers on GET" $ do+ r <- request methodGet "/loc_test" [] ""+ liftIO $ do+ let respHeaders = simpleHeaders r+ respHeaders `shouldSatisfy` noBlankHeader++ it "shouldn't add blank headers on DELETE" $ do+ r <- request methodDelete "/loc_test?id=eq.1" [] ""+ liftIO $ do+ let respHeaders = simpleHeaders r+ respHeaders `shouldSatisfy` noBlankHeader context "Use of the phraseto_tsquery function" $ do it "finds matches" $
test/Feature/ProxySpec.hs view
@@ -6,7 +6,7 @@ import Protolude import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "GET / with proxy" $ it "returns a valid openapi spec with proxy" $
test/Feature/QueryLimitedSpec.hs view
@@ -11,9 +11,9 @@ import Protolude hiding (get) import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec =- describe "Requesting many items with server limits enabled" $ do+ describe "Requesting many items with server limits(max-rows) enabled" $ do it "restricts results" $ get "/items" `shouldRespondWith` [json| [{"id":1},{"id":2}] |]@@ -29,16 +29,45 @@ matchHeader "Content-Range" "0-0/*" simpleStatus r `shouldBe` ok200 - it "limit works on all levels" $+ it "works on all levels" $ get "/users?select=id,tasks(id)&order=id.asc&tasks.order=id.asc" `shouldRespondWith` [json|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "0-1/*"] } - it "limit is not applied to parent embeds" $- get "/tasks?select=id,project(id)&id=gt.5"+ it "succeeds in getting parent embeds despite the limit, see #647" $+ get "/tasks?select=id,project:projects(id)&id=gt.5" `shouldRespondWith` [json|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "0-1/*"] }++ it "can offset the parent embed, being consistent with the other embed types" $+ get "/tasks?select=id,project:projects(id)&id=gt.5&project.offset=1"+ `shouldRespondWith` [json|[{"id":6,"project":null}, {"id":7,"project":null}]|]+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-1/*"]+ }++ context "count=estimated" $ do+ it "uses the query planner guess when query rows > maxRows" $+ request methodHead "/getallprojects_view" [("Prefer", "count=estimated")] ""+ `shouldRespondWith` ""+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-1/2019"]+ }++ it "gives exact count when query rows <= maxRows" $+ request methodHead "/getallprojects_view?id=lt.3" [("Prefer", "count=estimated")] ""+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-1/2"]+ }++ it "only uses the query planner guess if it's indeed greater than the exact count" $+ request methodHead "/get_projects_above_view" [("Prefer", "count=estimated")] ""+ `shouldRespondWith` ""+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-1/3"]+ }
test/Feature/QuerySpec.hs view
@@ -4,17 +4,17 @@ import Network.Wai.Test (SResponse (simpleHeaders)) import Network.HTTP.Types-import Test.Hspec+import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Text.Heredoc -import PostgREST.Types (PgVersion, pgVersion112)+import PostgREST.Types (PgVersion, pgVersion112, pgVersion121) import Protolude hiding (get) import SpecHelper -spec :: PgVersion -> SpecWith Application+spec :: PgVersion -> SpecWith ((), Application) spec actualPgVersion = do describe "Querying a table with a column called count" $@@ -198,7 +198,7 @@ it "matches filtering nested items 2" $ get "/clients?select=id,projects(id,tasks2(id,name))&projects.tasks.name=like.Design*"- `shouldRespondWith` [json| {"message":"Could not find foreign keys between these entities, No relation found between projects and tasks2"}|]+ `shouldRespondWith` [json| {"message":"Could not find foreign keys between these entities. No relationship found between projects and tasks2"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }@@ -265,19 +265,8 @@ [json|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] { matchHeaders = [matchContentTypeJson] } - it "requesting parent without specifying primary key" $- get "/projects?select=name,client(name)" `shouldRespondWith`- [json|[- {"name":"Windows 7","client":{"name": "Microsoft"}},- {"name":"Windows 10","client":{"name": "Microsoft"}},- {"name":"IOS","client":{"name": "Apple"}},- {"name":"OSX","client":{"name": "Apple"}},- {"name":"Orphan","client":null}- ]|]- { matchHeaders = [matchContentTypeJson] }- it "requesting parent and renaming primary key" $- get "/projects?select=name,client(clientId:id,name)" `shouldRespondWith`+ get "/projects?select=name,client:clients(clientId:id,name)" `shouldRespondWith` [json|[ {"name":"Windows 7","client":{"name": "Microsoft", "clientId": 1}}, {"name":"Windows 10","client":{"name": "Microsoft", "clientId": 1}},@@ -295,24 +284,11 @@ [json|[{"id":1,"commenter_id":1,"user_id":2,"task_id":6,"content":"Needs to be delivered ASAP","users_tasks":{"taskId": 6}}]|] { matchHeaders = [matchContentTypeJson] } - it "embed data with two fk pointing to the same table" $- get "/orders?id=eq.1&select=id, name, billing_address_id(id), shipping_address_id(id)" `shouldRespondWith`- [str|[{"id":1,"name":"order 1","billing_address_id":{"id":1},"shipping_address_id":{"id":2}}]|]-- it "requesting parents and children while renaming them" $- get "/projects?id=eq.1&select=myId:id, name, project_client:client_id(*), project_tasks:tasks(id, name)" `shouldRespondWith`+ get "/projects?id=eq.1&select=myId:id, name, project_client:clients(*), project_tasks:tasks(id, name)" `shouldRespondWith` [json|[{"myId":1,"name":"Windows 7","project_client":{"id":1,"name":"Microsoft"},"project_tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] { matchHeaders = [matchContentTypeJson] } - it "requesting parents two levels up while using FK to specify the link" $- get "/tasks?id=eq.1&select=id,name,project:project_id(id,name,client:client_id(id,name))" `shouldRespondWith`- [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]-- it "requesting parents two levels up while using FK to specify the link (with rename)" $- get "/tasks?id=eq.1&select=id,name,project:project_id(id,name,client:client_id(id,name))" `shouldRespondWith`- [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]- it "requesting parents and filtering parent columns" $ get "/projects?id=eq.1&select=id, name, clients(id)" `shouldRespondWith` [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|]@@ -351,21 +327,6 @@ [json|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|] { matchHeaders = [matchContentTypeJson] } - it "can embed by FK column name" $- get "/projects?id=in.(1,3)&select=id,name,client_id(id,name)" `shouldRespondWith`- [json|[{"id":1,"name":"Windows 7","client_id":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":{"id":2,"name":"Apple"}}]|]- { matchHeaders = [matchContentTypeJson] }-- it "can embed by FK column name and select the FK value at the same time, if aliased" $- get "/projects?id=in.(1,3)&select=id,name,client_id,client:client_id(id,name)" `shouldRespondWith`- [json|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|]- { matchHeaders = [matchContentTypeJson] }-- it "can select by column name sans id" $- get "/projects?id=in.(1,3)&select=id,name,client_id,client(id,name)" `shouldRespondWith`- [json|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|]- { matchHeaders = [matchContentTypeJson] }- describe "view embedding" $ do it "can detect fk relations through views to tables in the public schema" $ get "/consumers_view?select=*,orders_view(*)" `shouldRespondWith` 200@@ -373,8 +334,8 @@ 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`+ it "can request two parents" $+ get "/articleStars?select=createdAt,article:articles(owner),user:users(name)&limit=1" `shouldRespondWith` [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"owner": "postgrest_test_authenticator"},"user":{"name": "Angela Martin"}}]|] { matchHeaders = [matchContentTypeJson] } @@ -394,16 +355,16 @@ { matchHeaders = [matchContentTypeJson] } it "detects parent relations when having many views of a private table" $ do- get "/books?select=title,author(name)&id=eq.5" `shouldRespondWith`+ get "/books?select=title,author:authors(name)&id=eq.5" `shouldRespondWith` [json|[ { "title": "Farenheit 451", "author": { "name": "Ray Bradbury" } } ]|] { matchHeaders = [matchContentTypeJson] }- get "/forties_books?select=title,author(name)&limit=1" `shouldRespondWith`+ get "/forties_books?select=title,author:authors(name)&limit=1" `shouldRespondWith` [json|[ { "title": "1984", "author": { "name": "George Orwell" } } ]|] { matchHeaders = [matchContentTypeJson] }- get "/fifties_books?select=title,author(name)&limit=1" `shouldRespondWith`+ get "/fifties_books?select=title,author:authors(name)&limit=1" `shouldRespondWith` [json|[ { "title": "The Catcher in the Rye", "author": { "name": "J.D. Salinger" } } ]|] { matchHeaders = [matchContentTypeJson] }- get "/sixties_books?select=title,author(name)&limit=1" `shouldRespondWith`+ get "/sixties_books?select=title,author:authors(name)&limit=1" `shouldRespondWith` [json|[ { "title": "To Kill a Mockingbird", "author": { "name": "Harper Lee" } } ]|] { matchHeaders = [matchContentTypeJson] } @@ -466,7 +427,7 @@ { matchHeaders = [matchContentTypeJson] } it "can embed a view that has group by" $- get "/projects_count_grouped_by?select=number_of_projects,client(name)&order=number_of_projects" `shouldRespondWith`+ get "/projects_count_grouped_by?select=number_of_projects,client:clients(name)&order=number_of_projects" `shouldRespondWith` [json| [{"number_of_projects":1,"client":null}, {"number_of_projects":2,"client":{"name":"Microsoft"}},@@ -478,49 +439,6 @@ [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`- [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`- [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`- [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}},- {"id":3,"body":"How are you doing?","sender":{"name":"John","sent":2},"recipient":{"name":"Jane","received":2}}] |]- { matchHeaders = [matchContentTypeJson] }-- it "works with many<->many relation" $- 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] }-- -- TODO Remove in next major version(7.0)- 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`@@ -578,114 +496,6 @@ { "id":4,"childs":[]} ]|] { matchHeaders = [matchContentTypeJson] } - describe "tables with self reference foreign keys" $ do- context "one self reference foreign key" $ do- it "embeds parents recursively" $- get "/family_tree?id=in.(3,4)&select=id,parent(id,name,parent(*))" `shouldRespondWith`- [json|[- { "id": "3", "parent": { "id": "1", "name": "Parental Unit", "parent": null } },- { "id": "4", "parent": { "id": "2", "name": "Kid One", "parent": { "id": "1", "name": "Parental Unit", "parent": null } } }- ]|]- { 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`- [json|[{- "id": "1", "name": "Parental Unit", "childs": [- { "id": "2", "name": "Kid One", "childs": [ { "id": "4", "name": "Grandkid One" } ] },- { "id": "3", "name": "Kid Two", "childs": [ { "id": "5", "name": "Grandkid Two" } ] }- ]- }]|] { 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`- [json|[{- "id": "2", "name": "Kid One", "parent": {- "id": "1", "name": "Parental Unit", "childs": [ { "id": "2", "name": "Kid One" }, { "id": "3", "name": "Kid Two"} ]- }- }]|] { matchHeaders = [matchContentTypeJson] }-- context "two self reference foreign keys" $ do- it "embeds parents" $- get "/organizations?select=id,name,referee(id,name),auditor(id,name)&id=eq.3" `shouldRespondWith`- [json|[{- "id": 3, "name": "Acme",- "referee": {- "id": 1,- "name": "Referee Org"- },- "auditor": {- "id": 2,- "name": "Auditor Org"- }- }]|] { matchHeaders = [matchContentTypeJson] }-- it "embeds childs" $ do- get "/organizations?select=id,name,refereeds:organizations!referee(id,name)&id=eq.1" `shouldRespondWith`- [json|[{- "id": 1, "name": "Referee Org",- "refereeds": [- {- "id": 3,- "name": "Acme"- },- {- "id": 4,- "name": "Umbrella"- }- ]- }]|] { matchHeaders = [matchContentTypeJson] }- get "/organizations?select=id,name,auditees:organizations!auditor(id,name)&id=eq.2" `shouldRespondWith`- [json|[{- "id": 2, "name": "Auditor Org",- "auditees": [- {- "id": 3,- "name": "Acme"- },- {- "id": 4,- "name": "Umbrella"- }- ]- }]|] { 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!auditor(name,manager(name),refereeds:organizations!referee(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"@@ -781,10 +591,6 @@ get "/projects?id=eq.1&select=id, name, clients(id, name)&clients.order=name.asc" `shouldRespondWith` [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"}}]|] - it "ordering embeded parents does not break things when using ducktape names" $- get "/projects?id=eq.1&select=id, name, client(id, name)&client.order=name.asc" `shouldRespondWith`- [str|[{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}]|]- context "order syntax errors" $ do it "gives meaningful error messages when asc/desc/nulls{first,last} are misspelled" $ do get "/items?order=id.ac" `shouldRespondWith`@@ -914,11 +720,6 @@ [json| [{"ghostBusters":[{"escapeId":1}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":3}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":5}]}] |] { matchHeaders = [matchContentTypeJson] } - it "will embed using a column" $- get "/ghostBusters?select=escapeId(*)" `shouldRespondWith`- [json| [{"escapeId":{"so6meIdColumn":1}},{"escapeId":{"so6meIdColumn":3}},{"escapeId":{"so6meIdColumn":5}}] |]- { matchHeaders = [matchContentTypeJson] }- it "will select and filter a column that has spaces" $ get "/Server%20Today?select=Just%20A%20Server%20Model&Just%20A%20Server%20Model=like.*91*" `shouldRespondWith` [json|[@@ -967,58 +768,6 @@ , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"] } - describe "HTTP request env vars" $ do- it "custom header is set" $- request methodPost "/rpc/get_guc_value"- [("Custom-Header", "test")]- [json| { "name": "request.header.custom-header" } |]- `shouldRespondWith`- [str|"test"|]- { matchStatus = 200- , matchHeaders = [ matchContentTypeJson ]- }- it "standard header is set" $- request methodPost "/rpc/get_guc_value"- [("Origin", "http://example.com")]- [json| { "name": "request.header.origin" } |]- `shouldRespondWith`- [str|"http://example.com"|]- { matchStatus = 200- , matchHeaders = [ matchContentTypeJson ]- }- it "current role is available as GUC claim" $- request methodPost "/rpc/get_guc_value" []- [json| { "name": "request.jwt.claim.role" } |]- `shouldRespondWith`- [str|"postgrest_test_anonymous"|]- { matchStatus = 200- , matchHeaders = [ matchContentTypeJson ]- }- it "single cookie ends up as claims" $- request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue")]- [json| {"name":"request.cookie.acookie"} |]- `shouldRespondWith`- [str|"cookievalue"|]- { matchStatus = 200- , matchHeaders = []- }- it "multiple cookies ends up as claims" $- request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue;secondcookie=anothervalue")]- [json| {"name":"request.cookie.secondcookie"} |]- `shouldRespondWith`- [str|"anothervalue"|]- { matchStatus = 200- , matchHeaders = []- }- it "app settings available" $- request methodPost "/rpc/get_guc_value" []- [json| { "name": "app.settings.app_host" } |]- `shouldRespondWith`- [str|"localhost"|]- { matchStatus = 200- , matchHeaders = [ matchContentTypeJson ]- }- describe "values with quotes in IN and NOT IN" $ do it "succeeds when only quoted values are present" $ do get "/w_or_wo_comma_names?name=in.(\"Hebdon, John\")" `shouldRespondWith`@@ -1084,8 +833,12 @@ 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`+ `shouldRespondWith` (+ if actualPgVersion >= pgVersion121 then+ [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for type integer: \"\""} |]+ else [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"\""} |]+ ) { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }@@ -1112,3 +865,18 @@ it "cannot use ltree(in public schema) extension operators if no extra search path added" $ get "/ltree_sample?path=cd.Top.Science.Astronomy" `shouldRespondWith` 400++ context "VIEW that has a source FK based on a UNIQUE key" $+ it "can be embedded" $+ get "/referrals?select=site,link:pages(url)" `shouldRespondWith`+ [json| [+ {"site":"github.com", "link":{"url":"http://postgrest.org/en/v6.0/api.html"}},+ {"site":"hub.docker.com", "link":{"url":"http://postgrest.org/en/v6.0/admin.html"}}+ ]|]+ { matchHeaders = [matchContentTypeJson] }++ it "shouldn't produce a Content-Profile header since only a single schema is exposed" $ do+ r <- get "/items"+ liftIO $ do+ let respHeaders = simpleHeaders r+ respHeaders `shouldSatisfy` noProfileHeader
test/Feature/RangeSpec.hs view
@@ -19,7 +19,7 @@ emptyRange :: BL.ByteString emptyRange = [json| { "min": 2, "max": 2 } |] -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = do describe "POST /rpc/getitemrange" $ do context "without range headers" $ do@@ -155,12 +155,17 @@ , matchHeaders = ["Content-Range" <:> "0-0/*"] } - it "limit and offset works on first level" $+ it "limit and offset works on first level" $ do get "/items?select=id&order=id.asc&limit=3&offset=2" `shouldRespondWith` [json|[{"id":3},{"id":4},{"id":5}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "2-4/*"] }+ request methodHead "/items?select=id&order=id.asc&limit=3&offset=2" [] mempty+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "2-4/*"]+ } it "succeeds if offset equals 0 as a no-op" $ get "/items?select=id&offset=0"@@ -190,6 +195,65 @@ `shouldRespondWith` [json|{"message":"HTTP Range error"}|] { matchStatus = 416 , matchHeaders = [matchContentTypeJson]+ }++ context "when count=planned" $ do+ it "obtains a filtered range" $ do+ request methodGet "/items?select=id&id=gt.8" [("Prefer", "count=planned")] ""+ `shouldRespondWith` [json|[{"id":9}, {"id":10}, {"id":11}, {"id":12}, {"id":13}, {"id":14}, {"id":15}]|]+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-6/8"]+ }+ request methodGet "/child_entities?select=id&id=gt.3" [("Prefer", "count=planned")] ""+ `shouldRespondWith` [json|[{"id":4}, {"id":5}, {"id":6}]|]+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-2/4"]+ }+ request methodGet "/getallprojects_view?select=id&id=lt.3" [("Prefer", "count=planned")] ""+ `shouldRespondWith` [json|[{"id":1}, {"id":2}]|]+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-1/673"]+ }++ it "obtains the full range" $ do+ request methodHead "/items" [("Prefer", "count=planned")] ""+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-14/15"]+ }+ request methodHead "/child_entities" [("Prefer", "count=planned")] ""+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-5/6"]+ }+ request methodHead "/getallprojects_view" [("Prefer", "count=planned")] ""+ `shouldRespondWith` ""+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-4/2019"]+ }++ it "ignores limit/offset on the planned count" $ do+ request methodHead "/items?limit=2&offset=3" [("Prefer", "count=planned")] ""+ `shouldRespondWith` ""+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "3-4/15"]+ }+ request methodHead "/child_entities?limit=2" [("Prefer", "count=planned")] ""+ `shouldRespondWith` ""+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-1/6"]+ }+ request methodHead "/getallprojects_view?limit=2" [("Prefer", "count=planned")] ""+ `shouldRespondWith` ""+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-1/2019"]+ }++ it "works with two levels" $+ request methodHead "/child_entities?select=*,entities(*)" [("Prefer", "count=planned")] ""+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-5/6"] } context "with range headers" $ do
test/Feature/RawOutputTypesSpec.hs view
@@ -10,7 +10,7 @@ import Protolude import SpecHelper (acceptHdrs) -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "When raw-media-types config variable is missing or left empty" $ do let firefoxAcceptHdrs = acceptHdrs "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8" chromeAcceptHdrs = acceptHdrs "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3"
test/Feature/RootSpec.hs view
@@ -11,7 +11,7 @@ import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "root spec function" $ do it "accepts application/openapi+json" $
test/Feature/RpcSpec.hs view
@@ -17,7 +17,7 @@ import Protolude hiding (get) import SpecHelper -spec :: PgVersion -> SpecWith Application+spec :: PgVersion -> SpecWith ((), Application) spec actualPgVersion = describe "remote procedure call" $ do context "a proc that returns a set" $ do@@ -34,6 +34,12 @@ { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "0-0/*"] }+ request methodHead "/rpc/getitemrange?min=2&max=4"+ (rangeHdrs (ByteRangeFromTo 0 0)) ""+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-0/*"]+ } it "includes total count if requested" $ do request methodPost "/rpc/getitemrange"@@ -49,6 +55,12 @@ { matchStatus = 206 , matchHeaders = ["Content-Range" <:> "0-0/2"] }+ request methodHead "/rpc/getitemrange?min=2&max=4"+ (rangeHdrsWithCount (ByteRangeFromTo 0 0)) ""+ `shouldRespondWith` ""+ { matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-0/2"]+ } it "returns proper json" $ do post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`@@ -72,6 +84,12 @@ { matchStatus = 200 , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"] }+ request methodHead "/rpc/getitemrange?min=2&max=4"+ (acceptHdrs "text/csv") ""+ `shouldRespondWith` ""+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]+ } context "unknown function" $ do it "returns 404" $@@ -140,10 +158,10 @@ context "foreign entities embedding" $ do it "can embed if related tables are in the exposed schema" $ do- post "/rpc/getproject?select=id,name,client(id),tasks(id)" [json| { "id": 1} |] `shouldRespondWith`+ post "/rpc/getproject?select=id,name,client:clients(id),tasks(id)" [json| { "id": 1} |] `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|] { matchHeaders = [matchContentTypeJson] }- get "/rpc/getproject?id=1&select=id,name,client(id),tasks(id)" `shouldRespondWith`+ get "/rpc/getproject?id=1&select=id,name,client:clients(id),tasks(id)" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|] { matchHeaders = [matchContentTypeJson] } @@ -161,6 +179,29 @@ `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|] { matchHeaders = [matchContentTypeJson] } + it "can embed an M2M relationship table" $+ get "/rpc/getallusers?select=name,tasks(name)&id=gt.1"+ `shouldRespondWith` [json|[+ {"name":"Michael Scott", "tasks":[{"name":"Design IOS"}, {"name":"Code IOS"}, {"name":"Design OSX"}]},+ {"name":"Dwight Schrute","tasks":[{"name":"Design w7"}, {"name":"Design IOS"}]}+ ]|]+ { matchHeaders = [matchContentTypeJson] }++ it "can embed an M2M relationship table that has a parent relationship table" $+ get "/rpc/getallusers?select=name,tasks(name,project:projects(name))&id=gt.1"+ `shouldRespondWith` [json|[+ {"name":"Michael Scott","tasks":[+ {"name":"Design IOS","project":{"name":"IOS"}},+ {"name":"Code IOS","project":{"name":"IOS"}},+ {"name":"Design OSX","project":{"name":"OSX"}}+ ]},+ {"name":"Dwight Schrute","tasks":[+ {"name":"Design w7","project":{"name":"Windows 7"}},+ {"name":"Design IOS","project":{"name":"IOS"}}+ ]}+ ]|]+ { matchHeaders = [matchContentTypeJson] }+ context "a proc that returns an empty rowset" $ it "returns empty json array" $ do post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith`@@ -415,24 +456,34 @@ 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|{"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" $+ it "only takes the first object in case of array of objects payload" $ post "/rpc/add_them" [json|[ {"a": 1, "b": 2}, {"a": 4, "b": 6},- {"a": 100, "b": 200}- ]|] `shouldRespondWith`+ {"a": 100, "b": 200} ]|]+ `shouldRespondWith` "3"+ { matchHeaders = [matchContentTypeJson] }++ context "bulk RPC with params=multiple-objects" $ do+ it "works with a scalar function an returns a json array" $+ request methodPost "/rpc/add_them" [("Prefer", "params=multiple-objects")]+ [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")]+ request methodPost "/rpc/add_them" [("Content-Type", "text/csv"), ("Prefer", "params=multiple-objects")] "a,b\n1,2\n4,6\n100,200" `shouldRespondWith` [json|@@ -443,17 +494,93 @@ } it "works with a non-scalar result" $- post "/rpc/get_projects_below?select=id,name"+ request methodPost "/rpc/get_projects_below?select=id,name" [("Prefer", "params=multiple-objects")] [json|[ {"id": 1},- {"id": 5}- ]|] `shouldRespondWith`+ {"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 "HTTP request env vars" $ do+ it "custom header is set" $+ request methodPost "/rpc/get_guc_value"+ [("Custom-Header", "test")]+ [json| { "name": "request.header.custom-header" } |]+ `shouldRespondWith`+ [str|"test"|]+ { matchStatus = 200+ , matchHeaders = [ matchContentTypeJson ]+ }+ it "standard header is set" $+ request methodPost "/rpc/get_guc_value"+ [("Origin", "http://example.com")]+ [json| { "name": "request.header.origin" } |]+ `shouldRespondWith`+ [str|"http://example.com"|]+ { matchStatus = 200+ , matchHeaders = [ matchContentTypeJson ]+ }+ it "current role is available as GUC claim" $+ request methodPost "/rpc/get_guc_value" []+ [json| { "name": "request.jwt.claim.role" } |]+ `shouldRespondWith`+ [str|"postgrest_test_anonymous"|]+ { matchStatus = 200+ , matchHeaders = [ matchContentTypeJson ]+ }+ it "single cookie ends up as claims" $+ request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue")]+ [json| {"name":"request.cookie.acookie"} |]+ `shouldRespondWith`+ [str|"cookievalue"|]+ { matchStatus = 200+ , matchHeaders = []+ }+ it "multiple cookies ends up as claims" $+ request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue;secondcookie=anothervalue")]+ [json| {"name":"request.cookie.secondcookie"} |]+ `shouldRespondWith`+ [str|"anothervalue"|]+ { matchStatus = 200+ , matchHeaders = []+ }+ it "app settings available" $+ request methodPost "/rpc/get_guc_value" []+ [json| { "name": "app.settings.app_host" } |]+ `shouldRespondWith`+ [str|"localhost"|]+ { matchStatus = 200+ , matchHeaders = [ matchContentTypeJson ]+ }+ it "gets the Authorization value" $+ request methodPost "/rpc/get_guc_value" [authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"]+ [json| {"name":"request.header.authorization"} |]+ `shouldRespondWith`+ [str|"Bearer eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"|]+ { matchStatus = 200+ , matchHeaders = []+ }+ it "gets the http method" $+ request methodPost "/rpc/get_guc_value" []+ [json| {"name":"request.method"} |]+ `shouldRespondWith`+ [str|"POST"|]+ { matchStatus = 200+ , matchHeaders = []+ }+ it "gets the http path" $+ request methodPost "/rpc/get_guc_value" []+ [json| {"name":"request.path"} |]+ `shouldRespondWith`+ [str|"/rpc/get_guc_value"|]+ { matchStatus = 200+ , matchHeaders = []+ } context "binary output" $ do context "Proc that returns scalar" $ do
test/Feature/SingularSpec.hs view
@@ -13,7 +13,7 @@ import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "Requesting singular json object" $ do let pgrstObj = "application/vnd.pgrst.object+json"@@ -56,7 +56,7 @@ _ <- 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]+ [singular] [json| { address: "zzz" } |] liftIO $ do simpleStatus p `shouldBe` notAcceptable406@@ -65,8 +65,30 @@ -- the rows should not be updated, either get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|] + it "raises an error for multiple rows with return=rep" $ do+ _ <- post "/addresses" [json| { id: 100, address: "xxx" } |]+ _ <- post "/addresses" [json| { id: 101, address: "yyy" } |]+ 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++ -- the rows should not be updated, either+ get "/addresses?id=eq.100" `shouldRespondWith` [str|[{"id":100,"address":"xxx"}]|]+ it "raises an error for zero rows" $ request methodPatch "/items?id=gt.0&id=lt.0"+ [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"]+ }++ it "raises an error for zero rows with return=rep" $+ 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"}|]@@ -79,20 +101,20 @@ p <- request methodPost "/addresses" [("Prefer", "return=representation"), singular]- [json| [ { id: 100, address: "xxx" } ] |]- liftIO $ simpleBody p `shouldBe` [str|{"id":100,"address":"xxx"}|]+ [json| [ { id: 102, address: "xxx" } ] |]+ liftIO $ simpleBody p `shouldBe` [str|{"id":102,"address":"xxx"}|] it "works for one row even with return=minimal" $ do request methodPost "/addresses" [("Prefer", "return=minimal"), singular]- [json| [ { id: 101, address: "xxx" } ] |]+ [json| [ { id: 103, address: "xxx" } ] |] `shouldRespondWith` "" { matchStatus = 201 , matchHeaders = ["Content-Range" <:> "*/*"] } -- and the element should exist- get "/addresses?id=eq.101"- `shouldRespondWith` [str|[{"id":101,"address":"xxx"}]|]+ get "/addresses?id=eq.103"+ `shouldRespondWith` [str|[{"id":103,"address":"xxx"}]|] { matchStatus = 200 , matchHeaders = [] }@@ -100,24 +122,48 @@ it "raises an error when attempting to create multiple entities" $ do p <- request methodPost "/addresses"- [("Prefer", "return=representation"), singular]+ [singular] [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |] liftIO $ simpleStatus p `shouldBe` notAcceptable406 -- the rows should not exist, either get "/addresses?id=eq.200" `shouldRespondWith` "[]" - it "return=minimal allows request to create multiple elements" $+ it "raises an error when attempting to create multiple entities with return=rep" $ do+ p <- request methodPost+ "/addresses"+ [("Prefer", "return=representation"), singular]+ [json| [ { id: 202, address: "xxx" }, { id: 203, address: "yyy" } ] |]+ liftIO $ simpleStatus p `shouldBe` notAcceptable406++ -- the rows should not exist, either+ get "/addresses?id=eq.202" `shouldRespondWith` "[]"++ it "raises an error regardless of return=minimal" $ do request methodPost "/addresses"- [("Prefer", "return=minimal"), singular]- [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]- `shouldRespondWith` ""- { matchStatus = 201- , matchHeaders = ["Content-Range" <:> "*/*"]- }+ [("Prefer", "return=minimal"), singular]+ [json| [ { id: 204, address: "xxx" }, { id: 205, address: "yyy" } ] |]+ `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"]+ } + -- the rows should not exist, either+ get "/addresses?id=eq.204" `shouldRespondWith` "[]"+ it "raises an error when creating zero entities" $ request methodPost "/addresses"+ [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"]+ }++ it "raises an error when creating zero entities with return=rep" $+ request methodPost "/addresses" [("Prefer", "return=representation"), singular] [json| [ ] |] `shouldRespondWith`@@ -134,18 +180,39 @@ liftIO $ simpleBody p `shouldBe` [str|{"id":11}|] it "raises an error when attempting to delete multiple entities" $ do- let firstItems = "/items?id=gt.0&id=lt.11"+ let firstItems = "/items?id=gt.0&id=lt.6" request methodDelete firstItems+ [singular] ""+ `shouldRespondWith` 406++ get firstItems+ `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5}] |]+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-4/*"]+ }++ it "raises an error when attempting to delete multiple entities with return=rep" $ do+ let firstItems = "/items?id=gt.5&id=lt.11"+ request methodDelete firstItems [("Prefer", "return=representation"), singular] "" `shouldRespondWith` 406 get firstItems- `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10}] |]+ `shouldRespondWith` [json| [{"id":6},{"id":7},{"id":8},{"id":9},{"id":10}] |] { matchStatus = 200- , matchHeaders = ["Content-Range" <:> "0-9/*"]+ , matchHeaders = ["Content-Range" <:> "0-4/*"] } it "raises an error when deleting zero entities" $+ request methodDelete "/items?id=lt.0"+ [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"]+ }++ it "raises an error when deleting zero entities with return=rep" $ request methodDelete "/items?id=lt.0" [("Prefer", "return=representation"), singular] "" `shouldRespondWith`
test/Feature/StructureSpec.hs view
@@ -17,12 +17,14 @@ import Protolude hiding (get) import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = do describe "OpenAPI" $ do- it "root path returns a valid openapi spec" $+ it "root path returns a valid openapi spec" $ do validateOpenApiResponse [("Accept", "application/openapi+json")]+ request methodHead "/" (acceptHdrs "application/openapi+json") ""+ `shouldRespondWith` "" { matchStatus = 200 } it "should respond to openapi request on none root path with 415" $ request methodGet "/items"@@ -227,6 +229,23 @@ { "$ref": "#/parameters/limit" }, { "$ref": "#/parameters/preferCount" } ]+ |]++ describe "VIEW that has a source FK based on a UNIQUE key" $++ it "includes fk description" $ do+ r <- simpleBody <$> get "/"++ let referralLink = r ^? key "definitions" . key "referrals" . key "properties" . key "link"++ liftIO $+ referralLink `shouldBe` Just+ [aesonQQ|+ {+ "format": "integer",+ "type": "integer",+ "description": "Note:\nThis is a Foreign Key to `pages.link`.<fk table='pages' column='link'/>"+ } |] describe "PostgreSQL to Swagger Type Mapping" $ do
test/Feature/UnicodeSpec.hs view
@@ -10,7 +10,7 @@ import Protolude hiding (get) import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "Reading and writing to unicode schema and table names" $ it "Can read and write values" $ do
test/Feature/UpsertSpec.hs view
@@ -11,7 +11,7 @@ import Protolude hiding (get, put) import SpecHelper -spec :: SpecWith Application+spec :: SpecWith ((), Application) spec = describe "UPSERT" $ do context "with POST" $ do@@ -49,7 +49,32 @@ [json|[]|] `shouldRespondWith` [json|[]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] } + it "INSERTs and UPDATEs rows on single unique key conflict" $+ request methodPost "/single_unique?on_conflict=unique_key" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]+ [json| [+ { "unique_key": 1, "value": "B" },+ { "unique_key": 2, "value": "C" }+ ]|] `shouldRespondWith` [json| [+ { "unique_key": 1, "value": "B" },+ { "unique_key": 2, "value": "C" }+ ]|]+ { matchStatus = 201+ , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson]+ } + it "INSERTs and UPDATEs rows on compound unique keys conflict" $+ request methodPost "/compound_unique?on_conflict=key1,key2" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]+ [json| [+ { "key1": 1, "key2": 1, "value": "B" },+ { "key1": 1, "key2": 2, "value": "C" }+ ]|] `shouldRespondWith` [json| [+ { "key1": 1, "key2": 1, "value": "B" },+ { "key1": 1, "key2": 2, "value": "C" }+ ]|]+ { matchStatus = 201+ , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", 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")]@@ -70,6 +95,32 @@ { "first_name": "Sara M.", "last_name": "Torpey", "salary": 60000, "company": "Burstein-Applebee", "occupation": "Soil scientist" } ]|] `shouldRespondWith` [json|[ { "first_name": "Sara M.", "last_name": "Torpey", "salary": "$60,000.00", "company": "Burstein-Applebee", "occupation": "Soil scientist" }+ ]|]+ { matchStatus = 201+ , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson]+ }++ it "INSERTs and ignores rows on single unique key conflict" $+ request methodPost "/single_unique?on_conflict=unique_key" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]+ [json| [+ { "unique_key": 1, "value": "B" },+ { "unique_key": 2, "value": "C" },+ { "unique_key": 3, "value": "D" }+ ]|] `shouldRespondWith` [json| [+ { "unique_key": 3, "value": "D" }+ ]|]+ { matchStatus = 201+ , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson]+ }++ it "INSERTs and UPDATEs rows on compound unique keys conflict" $+ request methodPost "/compound_unique?on_conflict=key1,key2" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]+ [json| [+ { "key1": 1, "key2": 1, "value": "B" },+ { "key1": 1, "key2": 2, "value": "C" },+ { "key1": 1, "key2": 3, "value": "D" }+ ]|] `shouldRespondWith` [json| [+ { "key1": 1, "key2": 3, "value": "D" } ]|] { matchStatus = 201 , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson]
test/Main.hs view
@@ -6,16 +6,17 @@ import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction) import Data.Function (id)+import Data.List.NonEmpty (toList) import Data.Time.Clock (getCurrentTime) import Data.IORef import Test.Hspec import PostgREST.App (postgrest)+import PostgREST.Config (AppConfig (..)) import PostgREST.DbStructure (getDbStructure, getPgVersion)-import PostgREST.Types (DbStructure (..), pgVersion95,- pgVersion96)-import Protolude+import PostgREST.Types (pgVersion95, pgVersion96)+import Protolude hiding (toList) import SpecHelper import qualified Feature.AndOrParamsSpec@@ -26,10 +27,12 @@ import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec+import qualified Feature.EmbedDisambiguationSpec import qualified Feature.ExtraSearchPathSpec import qualified Feature.HtmlRawOutputSpec import qualified Feature.InsertSpec import qualified Feature.JsonOperatorSpec+import qualified Feature.MultipleSchemaSpec import qualified Feature.NoJwtSpec import qualified Feature.NonexistentSchemaSpec import qualified Feature.PgVersion95Spec@@ -49,108 +52,137 @@ main :: IO () main = do+ getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }+ testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test" setupDb testDbConn pool <- P.acquire (3, 10, toS testDbConn) - result <- P.use pool $ do- ver <- getPgVersion- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure "test" ver+ actualPgVersion <- either (panic.show) id <$> P.use pool getPgVersion - let dbStructure = either (panic.show) id result+ refDbStructure <- (newIORef . Just) =<< setupDbStructure pool (configSchemas $ testCfg testDbConn) actualPgVersion - getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }+ let+ -- For tests that run with the same refDbStructure+ app cfg = return ((), postgrest (cfg testDbConn) refDbStructure pool getTime $ pure ()) - refDbStructure <- newIORef $ Just dbStructure+ -- For tests that run with a different DbStructure(depends on configSchemas)+ appDbs cfg = do+ dbs <- (newIORef . Just) =<< setupDbStructure pool (configSchemas $ cfg testDbConn) actualPgVersion+ return ((), postgrest (cfg testDbConn) dbs pool getTime $ pure ()) - let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool getTime $ pure ()- ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool getTime $ pure ()- unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool getTime $ pure ()- proxyApp = return $ postgrest (testProxyCfg testDbConn) refDbStructure pool getTime $ pure ()- noJwtApp = return $ postgrest (testCfgNoJWT testDbConn) refDbStructure pool getTime $ pure ()- binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime $ pure ()- audJwtApp = return $ postgrest (testCfgAudienceJWT testDbConn) refDbStructure pool getTime $ pure ()- asymJwkApp = return $ postgrest (testCfgAsymJWK testDbConn) refDbStructure pool getTime $ pure ()- 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 ()- htmlRawOutputApp = return $ postgrest (testCfgHtmlRawOutput testDbConn) refDbStructure pool getTime $ pure ()+ let withApp = app testCfg+ maxRowsApp = app testMaxRowsCfg+ proxyApp = app testProxyCfg+ noJwtApp = app testCfgNoJWT+ binaryJwtApp = app testCfgBinaryJWT+ audJwtApp = app testCfgAudienceJWT+ asymJwkApp = app testCfgAsymJWK+ asymJwkSetApp = app testCfgAsymJWKSet+ extraSearchPathApp = app testCfgExtraSearchPath+ rootSpecApp = app testCfgRootSpec+ htmlRawOutputApp = app testCfgHtmlRawOutput+ responseHeadersApp = app testCfgResponseHeaders - let reset :: IO ()+ unicodeApp = appDbs testUnicodeCfg+ nonexistentSchemaApp = appDbs testNonexistentSchemaCfg+ multipleSchemaApp = appDbs testMultipleSchemaCfg++ let reset, analyze :: IO () reset = resetDb testDbConn+ analyze = do+ analyzeTable testDbConn "items"+ analyzeTable testDbConn "child_entities" - actualPgVersion = pgVersion dbStructure extraSpecs = [("Feature.UpsertSpec", Feature.UpsertSpec.spec) | actualPgVersion >= pgVersion95] ++- [("Feature.PgVersion95Spec", Feature.PgVersion95Spec.spec) | actualPgVersion >= pgVersion95] ++- [("Feature.PgVersion96Spec", Feature.PgVersion96Spec.spec) | actualPgVersion >= pgVersion96]+ [("Feature.PgVersion95Spec", Feature.PgVersion95Spec.spec) | actualPgVersion >= pgVersion95] specs = uncurry describe <$> [- ("Feature.AuthSpec" , Feature.AuthSpec.spec actualPgVersion)- , ("Feature.RawOutputTypesSpec" , Feature.RawOutputTypesSpec.spec)- , ("Feature.ConcurrentSpec" , Feature.ConcurrentSpec.spec)- , ("Feature.CorsSpec" , Feature.CorsSpec.spec)- , ("Feature.DeleteSpec" , Feature.DeleteSpec.spec)+ ("Feature.AuthSpec" , Feature.AuthSpec.spec actualPgVersion)+ , ("Feature.RawOutputTypesSpec" , Feature.RawOutputTypesSpec.spec)+ , ("Feature.ConcurrentSpec" , Feature.ConcurrentSpec.spec)+ , ("Feature.CorsSpec" , Feature.CorsSpec.spec)+ , ("Feature.JsonOperatorSpec" , Feature.JsonOperatorSpec.spec actualPgVersion)+ , ("Feature.QuerySpec" , Feature.QuerySpec.spec actualPgVersion)+ , ("Feature.EmbedDisambiguationSpec" , Feature.EmbedDisambiguationSpec.spec)+ , ("Feature.RpcSpec" , Feature.RpcSpec.spec actualPgVersion)+ , ("Feature.StructureSpec" , Feature.StructureSpec.spec)+ , ("Feature.AndOrParamsSpec" , Feature.AndOrParamsSpec.spec actualPgVersion)+ ] ++ extraSpecs++ mutSpecs = uncurry describe <$> [+ ("Feature.DeleteSpec" , Feature.DeleteSpec.spec) , ("Feature.InsertSpec" , Feature.InsertSpec.spec actualPgVersion)- , ("Feature.JsonOperatorSpec" , Feature.JsonOperatorSpec.spec actualPgVersion)- , ("Feature.QuerySpec" , Feature.QuerySpec.spec actualPgVersion)- , ("Feature.RpcSpec" , Feature.RpcSpec.spec actualPgVersion)- , ("Feature.RangeSpec" , Feature.RangeSpec.spec) , ("Feature.SingularSpec" , Feature.SingularSpec.spec)- , ("Feature.StructureSpec" , Feature.StructureSpec.spec)- , ("Feature.AndOrParamsSpec" , Feature.AndOrParamsSpec.spec actualPgVersion)- ] ++ extraSpecs+ ] hspec $ do- mapM_ (beforeAll_ reset . before withApp) specs+ -- Only certain Specs need a database reset, this should be used with care as it slows down the whole test suite.+ mapM_ (afterAll_ reset . before withApp) mutSpecs + mapM_ (before withApp) specs++ -- we analyze to get accurate results from EXPLAIN+ beforeAll_ analyze . before withApp $+ describe "Feature.RangeSpec" Feature.RangeSpec.spec+ -- this test runs with a raw-output-media-types set to text/html- beforeAll_ reset . before htmlRawOutputApp $+ before htmlRawOutputApp $ describe "Feature.HtmlRawOutputSpec" Feature.HtmlRawOutputSpec.spec -- this test runs with a different server flag- beforeAll_ reset . before ltdApp $+ before maxRowsApp $ describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec -- this test runs with a different schema- beforeAll_ reset . before unicodeApp $+ before unicodeApp $ describe "Feature.UnicodeSpec" Feature.UnicodeSpec.spec -- this test runs with a proxy- beforeAll_ reset . before proxyApp $+ before proxyApp $ describe "Feature.ProxySpec" Feature.ProxySpec.spec -- this test runs without a JWT secret- beforeAll_ reset . before noJwtApp $+ before noJwtApp $ describe "Feature.NoJwtSpec" Feature.NoJwtSpec.spec -- this test runs with a binary JWT secret- beforeAll_ reset . before binaryJwtApp $+ before binaryJwtApp $ describe "Feature.BinaryJwtSecretSpec" Feature.BinaryJwtSecretSpec.spec -- this test runs with a binary JWT secret and an audience claim- beforeAll_ reset . before audJwtApp $+ before audJwtApp $ describe "Feature.AudienceJwtSecretSpec" Feature.AudienceJwtSecretSpec.spec -- this test runs with asymmetric JWK- beforeAll_ reset . before asymJwkApp $+ before asymJwkApp $ describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec -- this test runs with asymmetric JWKSet- beforeAll_ reset . before asymJwkSetApp $+ before asymJwkSetApp $ describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec -- this test runs with a nonexistent db-schema- beforeAll_ reset . before nonexistentSchemaApp $+ before nonexistentSchemaApp $ describe "Feature.NonexistentSchemaSpec" Feature.NonexistentSchemaSpec.spec -- this test runs with an extra search path- beforeAll_ reset . before extraSearchPathApp $+ before extraSearchPathApp $ describe "Feature.ExtraSearchPathSpec" Feature.ExtraSearchPathSpec.spec -- this test runs with a root spec function override- when (actualPgVersion >= pgVersion96) $- beforeAll_ reset . before rootSpecApp $+ when (actualPgVersion >= pgVersion96) $ do+ before rootSpecApp $ describe "Feature.RootSpec" Feature.RootSpec.spec+ before responseHeadersApp $+ describe "Feature.PgVersion96Spec" Feature.PgVersion96Spec.spec++ -- this test runs with multiple schemas+ before multipleSchemaApp $+ describe "Feature.MultipleSchemaSpec" $ Feature.MultipleSchemaSpec.spec actualPgVersion++ where+ setupDbStructure pool schemas ver =+ either (panic.show) id <$> P.use pool (HT.transaction HT.ReadCommitted HT.Read $ getDbStructure (toList schemas) ver)
+ test/QueryCost.hs view
@@ -0,0 +1,76 @@+module Main where++import Control.Lens ((^?))+import qualified Data.Aeson.Lens as L+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Pool as P+import qualified Hasql.Statement as H+import qualified Hasql.Transaction as HT+import qualified Hasql.Transaction.Sessions as HT+import Text.Heredoc++import Protolude hiding (get)++import PostgREST.QueryBuilder (requestToCallProcQuery)+import PostgREST.Types++import SpecHelper (getEnvVarWithDefault)++import Test.Hspec++main :: IO ()+main = do+ testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test"+ -- To speed things up, assume setupDb has ben ran in the previous spec.+ pool <- P.acquire (3, 10, toS testDbConn)++ hspec $ describe "QueryCost" $+ context "call proc query" $ do+ it "should not exceed cost when calling setof composite proc" $ do+ cost <- exec pool [str| {"id": 3} |] $+ requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True] False Nothing+ liftIO $+ cost `shouldSatisfy` (< Just 40)++ it "should not exceed cost when calling setof composite proc with empty params" $ do+ cost <- exec pool mempty $+ requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] False Nothing+ liftIO $+ cost `shouldSatisfy` (< Just 30)++ it "should not exceed cost when calling scalar proc" $ do+ cost <- exec pool [str| {"a": 3, "b": 4} |] $+ requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True, PgArg "b" "int" True] True Nothing+ liftIO $+ cost `shouldSatisfy` (< Just 10)++ context "params=multiple-objects" $ do+ it "should not exceed cost when calling setof composite proc" $ do+ cost <- exec pool [str| [{"id": 1}, {"id": 4}] |] $+ requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True] False (Just MultipleObjects)+ liftIO $ do+ cost `shouldSatisfy` (> Just 2000)+ cost `shouldSatisfy` (< Just 2100)++ it "should not exceed cost when calling scalar proc" $ do+ cost <- exec pool [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |] $+ requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True, PgArg "b" "int" True] True Nothing+ liftIO $+ cost `shouldSatisfy` (< Just 10)+++exec :: P.Pool -> ByteString -> SqlQuery -> IO (Maybe Int64)+exec pool input query =+ join . rightToMaybe <$>+ P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement input $ explainCost query)++explainCost :: SqlQuery -> H.Statement ByteString (Maybe Int64)+explainCost query =+ H.Statement (encodeUtf8 sql) (HE.param $ HE.nonNullable HE.unknown) decodeExplain False+ where+ sql = "EXPLAIN (FORMAT JSON) " <> query+ decodeExplain :: HD.Result (Maybe Int64)+ decodeExplain =+ let row = HD.singleRow $ HD.column $ HD.nonNullable HD.bytea in+ (^? L.nth 0 . L.key "Plan" . L.key "Total Cost" . L._Integral) <$> row
test/SpecHelper.hs view
@@ -11,6 +11,7 @@ import Data.Aeson (Value (..), decode, encode) import Data.CaseInsensitive (CI (..)) import Data.List (lookup)+import Data.List.NonEmpty (fromList) import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus)) import System.Environment (getEnv) import System.Process (readProcess)@@ -23,7 +24,7 @@ import Text.Heredoc import PostgREST.Config (AppConfig (..))-import PostgREST.Types (JSPathExp (..), QualifiedIdentifier (..))+import PostgREST.Types (JSPathExp (..)) import Protolude matchContentTypeJson :: MatchHeader@@ -32,7 +33,7 @@ matchContentTypeSingular :: MatchHeader matchContentTypeSingular = "Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8" -validateOpenApiResponse :: [Header] -> WaiSession ()+validateOpenApiResponse :: [Header] -> WaiSession () () validateOpenApiResponse headers = do r <- request methodGet "/" headers "" liftIO $@@ -63,9 +64,11 @@ _baseCfg :: AppConfig _baseCfg = -- Connection Settings- AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000+ AppConfig mempty "postgrest_test_anonymous" Nothing (fromList ["test"]) "localhost" 3000 -- No user configured Unix Socket Nothing+ -- No user configured Unix Socket file mode (defaults to 660)+ (Right 432) -- Jwt settings (Just $ encodeUtf8 "reallyreallyreallyreallyverysafe") False Nothing -- Connection Modifiers@@ -91,13 +94,13 @@ testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing } testUnicodeCfg :: Text -> AppConfig-testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchema = "تست" }+testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["تست"] } -testLtdRowsCfg :: Text -> AppConfig-testLtdRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 }+testMaxRowsCfg :: Text -> AppConfig+testMaxRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 } testProxyCfg :: Text -> AppConfig-testProxyCfg testDbConn = (testCfg testDbConn) { configProxyUri = Just "https://postgrest.com/openapi.json" }+testProxyCfg testDbConn = (testCfg testDbConn) { configOpenAPIProxyUri = Just "https://postgrest.com/openapi.json" } testCfgBinaryJWT :: Text -> AppConfig testCfgBinaryJWT testDbConn = (testCfg testDbConn) {@@ -125,17 +128,23 @@ } testNonexistentSchemaCfg :: Text -> AppConfig-testNonexistentSchemaCfg testDbConn = (testCfg testDbConn) { configSchema = "nonexistent" }+testNonexistentSchemaCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["nonexistent"] } testCfgExtraSearchPath :: Text -> AppConfig testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configExtraSearchPath = ["public", "extensions"] } testCfgRootSpec :: Text -> AppConfig-testCfgRootSpec testDbConn = (testCfg testDbConn) { configRootSpec = Just $ QualifiedIdentifier "test" "root"}+testCfgRootSpec testDbConn = (testCfg testDbConn) { configRootSpec = Just "root"} testCfgHtmlRawOutput :: Text -> AppConfig testCfgHtmlRawOutput testDbConn = (testCfg testDbConn) { configRawMediaTypes = ["text/html"] } +testCfgResponseHeaders :: Text -> AppConfig+testCfgResponseHeaders testDbConn = (testCfg testDbConn) { configReqCheck = Just "custom_headers" }++testMultipleSchemaCfg :: Text -> AppConfig+testMultipleSchemaCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["v1", "v2"] }+ setupDb :: Text -> IO () setupDb dbConn = do loadFixture dbConn "database"@@ -149,9 +158,13 @@ resetDb :: Text -> IO () resetDb dbConn = loadFixture dbConn "data" +analyzeTable :: Text -> Text -> IO ()+analyzeTable dbConn tableName =+ void $ readProcess "psql" ["--set", "ON_ERROR_STOP=1", toS dbConn, "-a", "-c", toS $ "ANALYZE test.\"" <> tableName <> "\""] []+ loadFixture :: Text -> FilePath -> IO() loadFixture dbConn name =- void $ readProcess "psql" ["--set", "ON_ERROR_STOP=1", toS dbConn, "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []+ void $ readProcess "psql" ["--set", "ON_ERROR_STOP=1", toS dbConn, "-q", "-f", "test/fixtures/" ++ name ++ ".sql"] [] rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]@@ -168,6 +181,12 @@ matchHeader :: CI BS.ByteString -> BS.ByteString -> [Header] -> Bool matchHeader name valRegex headers = maybe False (=~ valRegex) $ lookup name headers++noBlankHeader :: [Header] -> Bool+noBlankHeader = notElem mempty++noProfileHeader :: [Header] -> Bool+noProfileHeader headers = isNothing $ find ((== "Content-Profile") . fst) headers authHeaderBasic :: BS.ByteString -> BS.ByteString -> Header authHeaderBasic u p =