packages feed

postgrest 7.0.1 → 8.0.0

raw patch · 75 files changed

+8586/−5708 lines, 75 filesdep +fast-loggerdep +hasql-dynamic-statementsdep +hasql-notificationsdep ~hasql-transactiondep ~networksetup-changed

Dependencies added: fast-logger, hasql-dynamic-statements, hasql-notifications, mtl, wai-logger

Dependency ranges changed: hasql-transaction, network

Files

CHANGELOG.md view
@@ -9,6 +9,66 @@  ### Fixed +## [8.0.0] - 2021-07-25++### Added++ - #1525, Allow http status override through response.status guc - @steve-chavez+ - #1512, Allow schema cache reloading with NOTIFY - @steve-chavez+ - #1119, Allow config file reloading with SIGUSR2 - @steve-chavez+ - #1558, Allow 'Bearer' with and without capitalization as authentication schema - @wolfgangwalther+ - #1470, Allow calling RPC with variadic argument by passing repeated params - @wolfgangwalther+ - #1559, No downtime when reloading the schema cache with SIGUSR1 - @steve-chavez+ - #504, Add `log-level` config option. The admitted levels are: crit, error, warn and info - @steve-chavez+ - #1607, Enable embedding through multiple views recursively - @wolfgangwalther+ - #1598, Allow rollback of the transaction with Prefer tx=rollback - @wolfgangwalther+ - #1633, Enable prepared statements for GET filters. When behind a connection pooler, you can disable preparing with `db-prepared-statements=false`+   + This increases throughput by around 30% for simple GET queries(no embedding, with filters applied).+ - #1729, #1760, Get configuration parameters from the db and allow reloading config with NOTIFY  - @steve-chavez+ - #1824, Allow OPTIONS to generate certain HTTP methods for a DB view - @laurenceisla+ - #1872, Show timestamps in startup/worker logs - @steve-chavez+ - #1881, Add `openapi-mode` config option that allows ignoring roles privileges when showing the OpenAPI output - @steve-chavez+ - CLI options(for debugging):+   + #1678, Add --dump-config CLI option that prints loaded config and exits - @wolfgangwalther+   + #1691, Add --example CLI option to show example config file - @wolfgangwalther+   + #1697, #1723, Add --dump-schema CLI option for debugging purposes - @monacoremo, @wolfgangwalther+ - #1794, (Experimental) Add `request.spec` GUC for db-root-spec - @steve-chavez++### Fixed++ - #1592, Removed single column restriction to allow composite foreign keys in join tables - @goteguru+ - #1530, Fix how the PostgREST version is shown in the help text when the `.git` directory is not available - @monacoremo+ - #1094, Fix expired JWTs starting an empty transaction on the db - @steve-chavez+ - #1162, Fix location header for POST request with select= without PK - @wolfgangwalther+ - #1585, Fix error messages on connection failure for localized postgres on Windows - @wolfgangwalther+ - #1636, Fix `application/octet-stream` appending `charset=utf-8` - @steve-chavez+ - #1469, #1638 Fix overloading of functions with unnamed arguments - @wolfgangwalther+ - #1560, Return 405 Method not Allowed for GET of volatile RPC instead of 500 - @wolfgangwalther+ - #1584, Fix RPC return type handling and embedding for domains with composite base type (#1615) - @wolfgangwalther+ - #1608, #1635, Fix embedding through views that have COALESCE with subselect - @wolfgangwalther+ - #1572, Fix parsing of boolean config values for Docker environment variables, now it accepts double quoted truth values ("true", "false") and numbers("1", "0") - @wolfgangwalther+ - #1624, Fix using `app.settings.xxx` config options in Docker, now they can be used as `PGRST_APP_SETTINGS_xxx` - @wolfgangwalther+ - #1814, Fix panic when attempting to run with unix socket on non-unix host and properly close unix domain socket on exit - @monacoremo+ - #1825, Disregard internal junction(in non-exposed schema) when embedding - @steve-chavez+ - #1846, Fix requests for overloaded functions from html forms to no longer hang (#1848) - @laurenceisla+ - #1858, Add a hint and clarification to the no relationship found error - @laurenceisla+ - #1841, Show comprehensive error when an RPC is not found in a stale schema cache - @laurenceisla+ - #1875, Fix Location headers in headers only representation for null PK inserts on views - @laurenceisla++### Changed++ - #1522, #1528, #1535, Docker images are now built from scratch based on a the static PostgREST executable (#1494) and with Nix instead of a `Dockerfile`. This reduces the compressed image size from over 30mb to about 4mb - @monacoremo+ - #1461, Location header for POST request is only included when PK is available on the table - @wolfgangwalther+ - #1560, Volatile RPC called with GET now returns 405 Method not Allowed instead of 500 - @wolfgangwalther+ - #1584, #1849 Functions that declare `returns composite_type` no longer return a single object array by default, only functions with `returns setof composite_type` return an array of objects - @wolfgangwalther+ - #1604, Change the default logging level to `log-level=error`. Only requests with a status greater or equal than 500 will be logged. If you wish to go back to the previous behaviour and log all the requests, use `log-level=info` - @steve-chavez+   + Because currently there's no buffering for logging, defaulting to the `error` level(minimum logging) increases throughput by around 15% for simple GET queries(no embedding, with filters applied).+ - #1617, Dropped support for PostgreSQL 9.4 - @wolfgangwalther+ - #1679, Renamed config settings with fallback aliases. e.g. `max-rows` is now `db-max-rows`, but `max-rows` is still accepted - @wolfgangwalther+ - #1656, Allow `Prefer=headers-only` on POST requests and change default to `minimal` (#1813) - @laurenceisla+ - #1854, Dropped undocumented support for gzip compression (which was surprisingly slow and easily enabled by mistake). In some use-cases this makes Postgres up to 3x faster - @aljungberg+ - #1872, Send startup/worker logs to stderr to differentiate from access logs on stdout - @steve-chavez+ ## [7.0.1] - 2020-05-18  ### Fixed@@ -18,6 +78,10 @@ - #1500, Fix missing `openapi-server-proxy-uri` config option - @steve-chavez - #1508, Fix `Content-Profile` not working for POST RPC - @steve-chavez - #1452, Fix PUT restriction for all columns - @steve-chavez++### Changed++- From this version onwards, the release page will only include a single Linux static executable that can be run on any Linux distribution.  ## [7.0.0] - 2020-04-03
Setup.hs view
@@ -1,2 +1,3 @@+-- This file is required by Hackage. import Distribution.Simple main = defaultMain
main/Main.hs view
@@ -1,330 +1,47 @@ {-# LANGUAGE CPP #-} -module Main where+module Main (main) where -import qualified Data.ByteString            as BS-import qualified Data.ByteString.Base64     as B64-import qualified Hasql.Pool                 as P-import qualified Hasql.Transaction.Sessions as HT+import qualified Data.Map.Strict as M -import Control.AutoUpdate       (defaultUpdateSettings, mkAutoUpdate,-                                 updateAction)-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)-import Data.Text.IO             (hPutStrLn)-import Data.Time.Clock          (getCurrentTime)-import Network.Wai.Handler.Warp (defaultSettings, runSettings,-                                 setHost, setPort, setServerName)-import System.IO                (BufferMode (..), hSetBuffering)+import System.IO (BufferMode (..), hSetBuffering) -import PostgREST.App         (postgrest)-import PostgREST.Config      (AppConfig (..), configPoolTimeout',-                              prettyVersion, readOptions)-import PostgREST.DbStructure (getDbStructure, getPgVersion)-import PostgREST.Error       (PgError (PgError), checkIsFatal,-                              errorPayload)-import PostgREST.OpenAPI     (isMalformedProxyUri)-import PostgREST.Types       (ConnectionStatus (..), DbStructure,-                              PgVersion (..), Schema,-                              minimumPgVersion)-import Protolude             hiding (hPutStrLn, head, replace, toS)-import Protolude.Conv        (toS)+import qualified PostgREST.App as App+import qualified PostgREST.CLI as CLI +import PostgREST.Config (readPGRSTEnvironment) +import Protolude+ #ifndef mingw32_HOST_OS-import System.Posix.Signals-import UnixSocket+import qualified PostgREST.Unix as Unix #endif --{-|-  The purpose of this worker is to fill the refDbStructure created in 'main'-  with the 'DbStructure' returned from calling 'getDbStructure'. This method-  is meant to be called by multiple times by the same thread, but does nothing if-  the previous invocation has not terminated. In all cases this method does not-  halt the calling thread, the work is preformed in a separate thread.--  Note: 'atomicWriteIORef' is essentially a lazy semaphore that prevents two-  threads from running 'connectionWorker' at the same time.--  Background thread that does the following :-  1. Tries to connect to pg server and will keep trying until success.-  2. Checks if the pg version is supported and if it's not it kills the main-     program.-  3. Obtains the dbStructure.-  4. If 2 or 3 fail to give their result it means the connection is down so it-     goes back to 1, otherwise it finishes his work successfully.--}-connectionWorker-  :: ThreadId -- ^ This thread is killed if pg version is unsupported-  -> P.Pool   -- ^ The PostgreSQL connection pool-  -> [Schema] -- ^ Schemas PostgREST is serving up-  -> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure'-  -> IORef Bool                -- ^ Used as a binary Semaphore-  -> IO ()-connectionWorker mainTid pool schemas refDbStructure refIsWorkerOn = do-  isWorkerOn <- readIORef refIsWorkerOn-  unless isWorkerOn $ do-    atomicWriteIORef refIsWorkerOn True-    void $ forkIO work-  where-    work = do-      atomicWriteIORef refDbStructure Nothing-      putStrLn ("Attempting to connect to the database..." :: Text)-      connected <- connectionStatus pool-      case connected of-        FatalConnectionError reason -> hPutStrLn stderr reason-                                      >> killThread mainTid    -- Fatal error when connecting-        NotConnected                -> return ()               -- Unreachable-        Connected actualPgVersion   -> do                      -- Procede with initialization-          result <- P.use pool $ do-            dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schemas actualPgVersion-            liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure-          case result of-            Left e -> do-              putStrLn ("Failed to query the database. Retrying." :: Text)-              hPutStrLn stderr . toS . errorPayload $ PgError False e-              work--            Right _ -> do-              atomicWriteIORef refIsWorkerOn False-              putStrLn ("Connection successful" :: Text)--{-|-  Used by 'connectionWorker' to check if the provided db-uri lets-  the application access the PostgreSQL database. This method is used-  the first time the connection is tested, but only to test before-  calling 'getDbStructure' inside the 'connectionWorker' method.--  The connection tries are capped, but if the connection times out no error is-  thrown, just 'False' is returned.--}-connectionStatus :: P.Pool -> IO ConnectionStatus-connectionStatus pool =-  retrying (capDelay 32000000 $ exponentialBackoff 1000000)-           shouldRetry-           (const $ P.release pool >> getConnectionStatus)-  where-    getConnectionStatus :: IO ConnectionStatus-    getConnectionStatus = do-      pgVersion <- P.use pool getPgVersion-      case pgVersion of-        Left e -> do-          let err = PgError False e-          hPutStrLn stderr . toS $ errorPayload err-          case checkIsFatal err of-            Just reason -> return $ FatalConnectionError reason-            Nothing     -> return NotConnected--        Right version ->-          if version < minimumPgVersion-             then return . FatalConnectionError $ "Cannot run in this PostgreSQL version, PostgREST needs at least " <> pgvName minimumPgVersion-             else return . Connected  $ version--    shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool-    shouldRetry rs isConnSucc = do-      let delay    = fromMaybe 0 (rsPreviousDelay rs) `div` 1000000-          itShould = NotConnected == isConnSucc-      when itShould $-        putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."-      return itShould---{-|-  This is where everything starts.--} main :: IO () main = do-  ---  -- LineBuffering: the entire output buffer is flushed whenever a newline is-  -- output, the buffer overflows, a hFlush is issued or the handle is closed-  ---  -- NoBuffering: output is written immediately and never stored in the buffer-  hSetBuffering stdout LineBuffering-  hSetBuffering stdin LineBuffering-  hSetBuffering stderr NoBuffering-  ---  -- readOptions builds the 'AppConfig' from the config file specified on the-  -- command line-  conf <- loadDbUriFile =<< loadSecretFile =<< readOptions-  let schemas = toList $ configSchemas conf-      host = configHost conf-      port = configPort conf-      proxy = configOpenAPIProxyUri conf-      maybeSocketAddr = configSocket conf-      socketFileMode = configSocketMode conf-      pgSettings = toS (configDatabase conf) -- is the db-uri-      roleClaimKey = configRoleClaimKey conf-      appSettings =-        setHost ((fromString . toS) host) -- Warp settings-        . setPort port-        . 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-  whenLeft roleClaimKey $-    panic $ show roleClaimKey+  setBuffering+  hasPGRSTEnv <- not . M.null <$> readPGRSTEnvironment+  opts <- CLI.readCLIShowHelp hasPGRSTEnv+  CLI.main installSignalHandlers runAppInSocket opts -  -- 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)-  ---  -- To be filled in by connectionWorker-  refDbStructure <- newIORef Nothing-  ---  -- Helper ref to make sure just one connectionWorker can run at a time-  refIsWorkerOn <- newIORef False-  ---  -- This is passed to the connectionWorker method so it can kill the main-  -- thread if the PostgreSQL's version is not supported.-  mainTid <- myThreadId-  ---  -- Sets the refDbStructure-  connectionWorker-    mainTid-    pool-    schemas-    refDbStructure-    refIsWorkerOn-  ---  -- Only for systems with signals:-  ---  -- releases the connection pool whenever the program is terminated,-  -- see issue #268-  ---  -- Plus the SIGHUP signal updates the internal 'DbStructure' by running-  -- 'connectionWorker' exactly as before.+installSignalHandlers :: App.SignalHandlerInstaller #ifndef mingw32_HOST_OS-  forM_ [sigINT, sigTERM] $ \sig ->-    void $ installHandler sig (Catch $ do-        P.release pool-        throwTo mainTid UserInterrupt-      ) Nothing--  void $ installHandler sigUSR1 (-    Catch $ connectionWorker-              mainTid-              pool-              schemas-              refDbStructure-              refIsWorkerOn-    ) Nothing+installSignalHandlers = Unix.installSignalHandlers+#else+installSignalHandlers _ = pass #endif --  -- ask for the OS time at most once per second-  getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime}--  let postgrestApplication =-        postgrest-          conf-          refDbStructure-          pool-          getTime-          (connectionWorker-             mainTid-             pool-             schemas-             refDbStructure-             refIsWorkerOn)--  -- run the postgrest application with user defined socket. Only for UNIX systems.+runAppInSocket :: Maybe App.SocketRunner #ifndef mingw32_HOST_OS-  whenJust maybeSocketAddr $-    runAppInSocket appSettings postgrestApplication socketFileMode+runAppInSocket = Just Unix.runAppWithSocket+#else+runAppInSocket = Nothing #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-  is base64 encoded.--  The reason some characters need to be replaced is because JWT is actually-  base64url encoded which must be turned into just base64 before decoding.--  To check if the JWT secret is provided is in fact a file path, it must be-  decoded as 'Text' to be processed.--  decodeUtf8: Decode a ByteString containing UTF-8 encoded text that is known to-  be valid.--}-loadSecretFile :: AppConfig -> IO AppConfig-loadSecretFile conf = extractAndTransform mSecret-  where-    mSecret = decodeUtf8 <$> configJwtSecret conf-    isB64 = configJwtSecretIsBase64 conf-    ---    -- The Text (variable name secret) here is mSecret from above which is the JWT-    -- decoded as Utf8-    ---    -- stripPrefix: Return the suffix of the second string if its prefix matches-    -- the entire first string.-    ---    -- The configJwtSecret is a filepath instead of the JWT secret itself if the-    -- secret has @ as its prefix.-    extractAndTransform :: Maybe Text -> IO AppConfig-    extractAndTransform Nothing = return conf-    extractAndTransform (Just secret) =-      fmap setSecret $-      transformString isB64 =<<-      case stripPrefix "@" secret of-        Nothing       -> return . encodeUtf8 $ secret-        Just filename -> chomp <$> BS.readFile (toS filename)-      where-        chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs)-    ---    -- Turns the Base64url encoded JWT into Base64-    transformString :: Bool -> ByteString -> IO ByteString-    transformString False t = return t-    transformString True t =-      case B64.decode $ encodeUtf8 $ strip $ replaceUrlChars $ decodeUtf8 t of-        Left errMsg -> panic $ pack errMsg-        Right bs    -> return bs-    setSecret bs = conf {configJwtSecret = Just bs}-    ---    -- replace: Replace every occurrence of one substring with another-    replaceUrlChars =-      replace "_" "/" . replace "-" "+" . replace "." "="--{--  Load database uri from a separate file if `db-uri` is a filepath.--}-loadDbUriFile :: AppConfig -> IO AppConfig-loadDbUriFile conf = extractDbUri mDbUri-  where-    mDbUri = configDatabase conf-    extractDbUri :: Text -> IO AppConfig-    extractDbUri dbUri =-      fmap setDbUri $-      case stripPrefix "@" dbUri of-        Nothing       -> return dbUri-        Just filename -> strip <$> readFile (toS filename)-    setDbUri dbUri = conf {configDatabase = dbUri}---- 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+setBuffering :: IO ()+setBuffering = do+  -- LineBuffering: the entire output buffer is flushed whenever a newline is+  -- output, the buffer overflows, a hFlush is issued or the handle is closed+  hSetBuffering stdout LineBuffering+  hSetBuffering stdin LineBuffering+  hSetBuffering stderr LineBuffering
− main/UnixSocket.hs 
@@ -1,40 +0,0 @@-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,5 +1,5 @@ name:               postgrest-version:            7.0.1+version:            8.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@@ -19,36 +19,59 @@   type:     git   location: git://github.com/PostgREST/postgrest.git -flag FailOnWarn+flag dev   default:     False   manual:      True-  description: No warnings allowed+  description: Development flags +flag hpc+  default:     True+  manual:      True+  description: Enable HPC (dev only)+ library-  exposed-modules:    PostgREST.ApiRequest-                      PostgREST.App+  default-language:   Haskell2010+  default-extensions: OverloadedStrings+                      NoImplicitPrelude+  hs-source-dirs:     src+  exposed-modules:    PostgREST.App+                      PostgREST.AppState                       PostgREST.Auth+                      PostgREST.CLI                       PostgREST.Config-                      PostgREST.DbRequestBuilder+                      PostgREST.Config.Database+                      PostgREST.Config.JSPath+                      PostgREST.Config.PgVersion+                      PostgREST.Config.Proxy+                      PostgREST.ContentType                       PostgREST.DbStructure+                      PostgREST.DbStructure.Identifiers+                      PostgREST.DbStructure.Proc+                      PostgREST.DbStructure.Relationship+                      PostgREST.DbStructure.Table                       PostgREST.Error+                      PostgREST.GucHeader                       PostgREST.Middleware                       PostgREST.OpenAPI-                      PostgREST.Parsers-                      PostgREST.QueryBuilder-                      PostgREST.Statements+                      PostgREST.Query.QueryBuilder+                      PostgREST.Query.SqlFragment+                      PostgREST.Query.Statements                       PostgREST.RangeQuery-                      PostgREST.Types+                      PostgREST.Request.ApiRequest+                      PostgREST.Request.DbRequestBuilder+                      PostgREST.Request.Parsers+                      PostgREST.Request.Preferences+                      PostgREST.Request.Types+                      PostgREST.Version+                      PostgREST.Workers   other-modules:      Paths_postgrest-                      PostgREST.Private.Common-                      PostgREST.Private.QueryFragment-  hs-source-dirs:     src   build-depends:      base                      >= 4.9 && < 4.15                     , HTTP                      >= 4000.3.7 && < 4000.4                     , Ranged-sets               >= 0.3 && < 0.5-                    , aeson                     >= 1.4.7 && < 1.5+                    , aeson                     >= 1.4.7 && < 1.6                     , ansi-wl-pprint            >= 0.6.7 && < 0.7-                    , base64-bytestring         >= 1 && < 1.2+                    , auto-update               >= 0.1.4 && < 0.2+                    , base64-bytestring         >= 1 && < 1.3                     , bytestring                >= 0.10.8 && < 0.11                     , case-insensitive          >= 1.2 && < 1.3                     , cassava                   >= 0.4.5 && < 0.6@@ -58,22 +81,27 @@                     , contravariant-extras      >= 0.3.3 && < 0.4                     , cookie                    >= 0.4.2 && < 0.5                     , either                    >= 4.4.1 && < 5.1+                    , fast-logger               >= 2.4.5                     , gitrev                    >= 1.2 && < 1.4                     , hasql                     >= 1.4 && < 1.5+                    , hasql-dynamic-statements  == 0.3.1+                    , hasql-notifications       >= 0.1 && < 0.3                     , hasql-pool                >= 0.5 && < 0.6-                    , hasql-transaction         >= 0.7.2 && < 1.1+                    , hasql-transaction         >= 1.0.1 && < 1.1                     , heredoc                   >= 0.2 && < 0.3                     , http-types                >= 0.12.2 && < 0.13                     , insert-ordered-containers >= 0.2.2 && < 0.3                     , interpolatedstring-perl6  >= 1 && < 1.1                     , jose                      >= 0.8.1 && < 0.9-                    , lens                      >= 4.14 && < 4.20+                    , lens                      >= 4.14 && < 5.1                     , lens-aeson                >= 1.0.1 && < 1.2+                    , mtl                       >= 2.2.2 && < 2.3                     , network-uri               >= 2.6.1 && < 2.8-                    , optparse-applicative      >= 0.13 && < 0.16+                    , optparse-applicative      >= 0.13 && < 0.17                     , parsec                    >= 3.1.11 && < 3.2                     , protolude                 >= 0.3 && < 0.4                     , regex-tdfa                >= 1.2.2 && < 1.4+                    , retry                     >= 0.7.4 && < 0.9                     , scientific                >= 0.3.4 && < 0.4                     , swagger2                  >= 2.4 && < 2.7                     , text                      >= 1.2.2 && < 1.3@@ -82,63 +110,61 @@                     , vector                    >= 0.11 && < 0.13                     , wai                       >= 3.2.1 && < 3.3                     , wai-cors                  >= 0.2.5 && < 0.3-                    , wai-extra                 >= 3.0.19 && < 3.1-                    , wai-middleware-static     >= 0.8.1 && < 0.9-  default-language:   Haskell2010-  default-extensions: OverloadedStrings-                      QuasiQuotes-                      NoImplicitPrelude-  if flag(FailOnWarn)-    ghc-options: -O2 -Werror -Wall -fwarn-identities-                 -fno-spec-constr -optP-Wno-nonportable-include-path+                    , wai-extra                 >= 3.0.19 && < 3.2+                    , wai-logger                >= 2.3.2+                    , wai-middleware-static     >= 0.8.1 && < 0.10+                    , warp                      >= 3.2.12 && < 3.4+                      -- -fno-spec-constr may help keep compile time memory use in check,+                      --   see https://gitlab.haskell.org/ghc/ghc/issues/16017#note_219304+                      -- -optP-Wno-nonportable-include-path+                      --   prevents build failures on case-insensitive filesystems (macos),+                      --   see https://github.com/commercialhaskell/stack/issues/3918+  ghc-options:        -Wall -fwarn-identities+                      -fno-spec-constr -optP-Wno-nonportable-include-path++  if flag(dev)+    ghc-options: --disable-optimizations+    if flag(hpc)+      ghc-options: --enable-coverage -hpcdir .hpc   else-    ghc-options: -O2 -Wall -fwarn-identities-                 -fno-spec-constr -optP-Wno-nonportable-include-path-          -- -fno-spec-constr may help keep compile time memory use in check,-          --   see https://gitlab.haskell.org/ghc/ghc/issues/16017#note_219304-          -- -optP-Wno-nonportable-include-path-          --   prevents build failures on case-insensitive filesystems (macos),-          --   see https://github.com/commercialhaskell/stack/issues/3918+    ghc-options: -O2 +  if !os(windows)+    build-depends:+      unix+      , directory >= 1.2.6 && < 1.4+      , network   >= 2.6 && < 3.2+    exposed-modules:+      PostgREST.Unix+ executable postgrest-  main-is:            Main.hs-  hs-source-dirs:     main-  build-depends:      base              >= 4.9 && < 4.15-                    , auto-update       >= 0.1.4 && < 0.2-                    , base64-bytestring >= 1 && < 1.2-                    , 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 && < 1.1-                    , network           < 3.2-                    , postgrest-                    , protolude         >= 0.3 && < 0.4-                    , retry             >= 0.7.4 && < 0.9-                    , text              >= 1.2.2 && < 1.3-                    , time              >= 1.6 && < 1.11-                    , wai               >= 3.2.1 && < 3.3-                    , warp              >= 3.2.12 && < 3.4   default-language:   Haskell2010   default-extensions: OverloadedStrings-                      QuasiQuotes                       NoImplicitPrelude-  if flag(FailOnWarn)-    ghc-options:      -threaded -rtsopts "-with-rtsopts=-N -I2"-                      -O2 -Werror -Wall -fwarn-identities-                      -fno-spec-constr -optP-Wno-nonportable-include-path-  else-    ghc-options:      -threaded -rtsopts "-with-rtsopts=-N -I2"+  hs-source-dirs:     main+  main-is:            Main.hs+  build-depends:      base                >= 4.9 && < 4.15+                    , containers          >= 0.5.7 && < 0.7+                    , postgrest+                    , protolude           >= 0.3 && < 0.4+  ghc-options:        -threaded -rtsopts "-with-rtsopts=-N -I2"                       -O2 -Wall -fwarn-identities                       -fno-spec-constr -optP-Wno-nonportable-include-path -  if !os(windows)-    build-depends: unix-    other-modules: UnixSocket+  if flag(dev)+    ghc-options: --disable-optimizations+    if flag(hpc)+      ghc-options: --enable-coverage -hpcdir .hpc+  else+    ghc-options: -O2  test-suite spec   type:               exitcode-stdio-1.0+  default-language:   Haskell2010+  default-extensions: OverloadedStrings+                      QuasiQuotes+                      NoImplicitPrelude+  hs-source-dirs:     test   main-is:            Main.hs   other-modules:      Feature.AndOrParamsSpec                       Feature.AsymmetricJwtSpec@@ -148,36 +174,39 @@                       Feature.ConcurrentSpec                       Feature.CorsSpec                       Feature.DeleteSpec+                      Feature.DisabledOpenApiSpec                       Feature.EmbedDisambiguationSpec                       Feature.ExtraSearchPathSpec+                      Feature.HtmlRawOutputSpec                       Feature.InsertSpec+                      Feature.IgnorePrivOpenApiSpec                       Feature.JsonOperatorSpec+                      Feature.MultipleSchemaSpec                       Feature.NoJwtSpec                       Feature.NonexistentSchemaSpec-                      Feature.PgVersion95Spec-                      Feature.PgVersion96Spec+                      Feature.OpenApiSpec+                      Feature.OptionsSpec                       Feature.ProxySpec                       Feature.QueryLimitedSpec                       Feature.QuerySpec                       Feature.RangeSpec+                      Feature.RawOutputTypesSpec+                      Feature.RollbackSpec                       Feature.RootSpec+                      Feature.RpcPreRequestGucsSpec                       Feature.RpcSpec                       Feature.SingularSpec-                      Feature.StructureSpec                       Feature.UnicodeSpec+                      Feature.UpdateSpec                       Feature.UpsertSpec-                      Feature.RawOutputTypesSpec-                      Feature.HtmlRawOutputSpec-                      Feature.MultipleSchemaSpec                       SpecHelper                       TestTypes-  hs-source-dirs:     test   build-depends:      base              >= 4.9 && < 4.15-                    , aeson             >= 1.4.7 && < 1.5+                    , aeson             >= 1.4.7 && < 1.6                     , aeson-qq          >= 0.8.1 && < 0.9                     , async             >= 2.1.1 && < 2.3                     , auto-update       >= 0.1.4 && < 0.2-                    , base64-bytestring >= 1 && < 1.2+                    , base64-bytestring >= 1 && < 1.3                     , bytestring        >= 0.10.8 && < 0.11                     , case-insensitive  >= 1.2 && < 1.3                     , cassava           >= 0.4.5 && < 0.6@@ -185,13 +214,13 @@                     , contravariant     >= 1.4 && < 1.6                     , hasql             >= 1.4 && < 1.5                     , hasql-pool        >= 0.5 && < 0.6-                    , hasql-transaction >= 0.7.2 && < 1.1+                    , hasql-transaction >= 1.0.1 && < 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+                    , hspec-wai         >= 0.10 && < 0.12+                    , hspec-wai-json    >= 0.10 && < 0.12                     , http-types        >= 0.12.3 && < 0.13-                    , lens              >= 4.14 && < 4.20+                    , lens              >= 4.14 && < 5.1                     , lens-aeson        >= 1.0.1 && < 1.2                     , monad-control     >= 1.0.1 && < 1.1                     , postgrest@@ -202,40 +231,41 @@                     , time              >= 1.6 && < 1.11                     , transformers-base >= 0.4.4 && < 0.5                     , wai               >= 3.2.1 && < 3.3-                    , wai-extra         >= 3.0.19 && < 3.1-  default-language:   Haskell2010-  default-extensions: OverloadedStrings-                      QuasiQuotes-                      NoImplicitPrelude-  ghc-options:        -threaded -rtsopts -with-rtsopts=-N+                    , wai-extra         >= 3.0.19 && < 3.2+  ghc-options:        --disable-optimizations -Wall -fwarn-identities+                      -fno-spec-constr -optP-Wno-nonportable-include-path+                      -fno-warn-missing-signatures -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.15-                     , aeson             >= 1.4.7 && < 1.5+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.15+                     , aeson             >= 1.4.7 && < 1.6                      , aeson-qq          >= 0.8.1 && < 0.9                      , async             >= 2.1.1 && < 2.3                      , auto-update       >= 0.1.4 && < 0.2-                     , base64-bytestring >= 1 && < 1.2+                     , base64-bytestring >= 1 && < 1.3                      , 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-dynamic-statements  == 0.3.1                      , hasql-pool        >= 0.5 && < 0.6-                     , hasql-transaction >= 0.7.2 && < 1.1+                     , hasql-transaction >= 1.0.1 && < 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+                     , hspec-wai         >= 0.10 && < 0.12+                     , hspec-wai-json    >= 0.10 && < 0.12                      , http-types        >= 0.12.3 && < 0.13-                     , lens              >= 4.14 && < 4.20+                     , lens              >= 4.14 && < 5.1                      , lens-aeson        >= 1.0.1 && < 1.2                      , monad-control     >= 1.0.1 && < 1.1                      , postgrest@@ -246,4 +276,6 @@                      , time              >= 1.6 && < 1.11                      , transformers-base >= 0.4.4 && < 0.5                      , wai               >= 3.2.1 && < 3.3-                     , wai-extra         >= 3.0.19 && < 3.1+                     , wai-extra         >= 3.0.19 && < 3.2+  ghc-options:         --disable-optimizations -Wall -fwarn-identities+                       -fno-spec-constr -optP-Wno-nonportable-include-path
− src/PostgREST/ApiRequest.hs 
@@ -1,346 +0,0 @@-{-|-Module      : PostgREST.ApiRequest-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(..)-, mutuallyAgreeable-, userApiRequest-) where--import qualified Data.Aeson           as JSON-import qualified Data.ByteString      as BS-import qualified Data.ByteString.Lazy as BL-import qualified Data.CaseInsensitive as CI-import qualified Data.Csv             as CSV-import qualified Data.HashMap.Strict  as M-import qualified Data.List            as L-import qualified Data.Set             as S-import qualified Data.Text            as T-import qualified Data.Vector          as V--import Control.Arrow             ((***))-import Data.Aeson.Types          (emptyArray, emptyObject)-import Data.List                 (last, lookup, partition)-import Data.List.NonEmpty        (head)-import Data.Maybe                (fromJust)-import Data.Ranged.Ranges        (Range (..), emptyRange,-                                  rangeIntersection)-import Network.HTTP.Base         (urlEncodeVars)-import Network.HTTP.Types.Header (hAuthorization, hCookie)-import Network.HTTP.Types.URI    (parseQueryReplacePlus,-                                  parseSimpleQuery)-import Network.Wai               (Request (..))-import Network.Wai.Parse         (parseHttpAccept)-import Web.Cookie                (parseCookiesText)---import Data.Ranged.Boundaries--import PostgREST.Error      (ApiRequestError (..))-import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq,-                             rangeLimit, rangeOffset, rangeRequested,-                             restrictRange)-import PostgREST.Types-import Protolude            hiding (head, toS)-import Protolude.Conv       (toS)--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{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{tdsSchema :: Schema} -- The default spec offered at root "/"-            | TargetUnknown [Text]-            deriving Eq--{-|-  Describes what the user wants to do. This data type is a-  translation of the raw elements of an HTTP request into domain-  specific language.  There is no guarantee that the intent is-  sensible, it is up to a later stage of processing to determine-  if it is an action we are able to perform.--}-data ApiRequest = ApiRequest {-    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 :: 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-      , 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 <$> 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-        . L.sortOn fst-        . map (join (***) toS . second (fromMaybe BS.empty))-        $ qString-      , iJWT = tokenStr-      , 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)-  qString = parseQueryReplacePlus True $ rawQueryString req-  -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)-  (filters, rpcQParams) =-    case action of-      ActionInvoke 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,-      k `notElem` ["select", "columns"],-      not (endingIn ["order", "limit", "offset", "and", "or"] k) ]-  hasOperator val = any (`T.isPrefixOf` val) $-                      ((<> ".") <$> "not":M.keys operators) ++-                      ((<> "(") <$> M.keys ftsOperators)-  isEmbedPath = T.isInfixOf "."-  isTargetingProc = 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 InvPost] = toS <$> join (lookup "columns" qParams)-    | otherwise = Nothing-  payload =-    case (contentType, action) of-      (_, ActionInvoke InvGet)  -> Right rpcPrmsToJson-      (_, ActionInvoke InvHead) -> Right rpcPrmsToJson-      (CTApplicationJSON, _) ->-        if isJust columns-          then Right $ RawJSON reqBody-          else note "All object keys must match" . payloadAttributes reqBody-                 =<< if BL.null reqBody && isTargetingProc-                       then Right emptyObject-                       else JSON.eitherDecode reqBody-      (CTTextCSV, _) -> do-        json <- csvToJson <$> CSV.decodeByName reqBody-        note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json-      (CTOther "application/x-www-form-urlencoded", _) ->-        let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody-            keys = S.fromList $ M.keys json in-        Right $ ProcessedJSON (JSON.encode json) keys-      (ct, _) ->-        Left $ toS $ "Content-Type not acceptable: " <> toMime ct-  rpcPrmsToJson = ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) (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-      -- 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 InvPost-                    else ActionCreate-      "PATCH"   -> ActionUpdate-      "PUT"     -> ActionSingleUpsert-      "DELETE"  -> ActionDelete-      "OPTIONS" -> ActionInfo-      _         -> 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, ActionInvoke InvPost] -- 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,-                     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 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 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-  method          = requestMethod req-  hdrs            = requestHeaders req-  qParams         = [(toS k, v)|(k,v) <- qString]-  lookupHeader    = flip lookup hdrs-  hasPrefer :: Text -> Bool-  hasPrefer val   = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs-    where-        split :: BS.ByteString -> [Text]-        split = map T.strip . T.split (==',') . toS-  representation-    | 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-    _                  -> ""-  endingIn:: [Text] -> Text -> Bool-  endingIn xx key = lastWord `elem` xx-    where lastWord = last $ T.split (=='.') key--  headerRange = rangeRequested hdrs-  replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]-  limitParams :: M.HashMap ByteString NonnegRange-  limitParams  = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]-  offsetParams :: M.HashMap ByteString NonnegRange-  offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe =<< (toS <$> v))) | (k,v) <- qParams, isJust v, endingIn ["offset"] k]--  urlRange = M.unionWith f limitParams offsetParams-    where-      f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)-        where-          l = fromMaybe 0 $ rangeLimit rl-          o = rangeOffset ro-  ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange--{-|-  Find the best match from a list of content types accepted by the-  client in order of decreasing preference and a list of types-  producible by the server.  If there is no match but the client-  accepts */* then return the top server pick.--}-mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType-mutuallyAgreeable sProduces cAccepts =-  let exact = listToMaybe $ L.intersect cAccepts sProduces in-  if isNothing exact && CTAny `elem` cAccepts-     then listToMaybe sProduces-     else exact--type CsvData = V.Vector (M.HashMap Text BL.ByteString)--{-|-  Converts CSV like-  a,b-  1,hi-  2,bye--  into a JSON array like-  [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]--  The reason for its odd signature is so that it can compose-  directly with CSV.decodeByName--}-csvToJson :: (CSV.Header, CsvData) -> JSON.Value-csvToJson (_, vals) =-  JSON.Array $ V.map rowToJsonObj vals- where-  rowToJsonObj = JSON.Object .-    M.map (\str ->-        if str == "NULL"-          then JSON.Null-          else JSON.String $ toS str-      )--payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON-payloadAttributes raw json =-  -- Test that Array contains only Objects having the same keys-  case json of-    JSON.Array arr ->-      case arr V.!? 0 of-        Just (JSON.Object o) ->-          let canonicalKeys = S.fromList $ M.keys o-              areKeysUniform = all (\case-                JSON.Object x -> S.fromList (M.keys x) == canonicalKeys-                _ -> False) arr in-          if areKeysUniform-            then Just $ ProcessedJSON raw canonicalKeys-            else Nothing-        Just _ -> Nothing-        Nothing -> Just emptyPJArray--    JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ M.keys o)--    -- truncate everything else to an empty array.-    _ -> Just emptyPJArray-  where-    emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
src/PostgREST/App.hs view
@@ -9,411 +9,608 @@ - Producing HTTP Headers according to RFCs. - Content Negotiation -}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE MultiWayIf          #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+module PostgREST.App+  ( SignalHandlerInstaller+  , SocketRunner+  , postgrest+  , run+  ) where -module PostgREST.App (-  postgrest-) where+import Control.Monad.Except     (liftEither)+import Data.Either.Combinators  (mapLeft)+import Data.List                (union)+import Data.String              (IsString (..))+import Data.Time.Clock          (UTCTime)+import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,+                                 setServerName)+import System.Posix.Types       (FileMode) -import qualified Data.ByteString.Char8      as BS-import qualified Data.HashMap.Strict        as M-import qualified Data.List                  as L (union)-import qualified Data.Set                   as S-import qualified Hasql.Pool                 as P-import qualified Hasql.Transaction          as H-import qualified Hasql.Transaction          as HT-import qualified Hasql.Transaction.Sessions as HT+import qualified Data.ByteString.Char8           as BS8+import qualified Data.ByteString.Lazy            as LBS+import qualified Data.HashMap.Strict             as Map+import qualified Data.Set                        as Set+import qualified Hasql.DynamicStatements.Snippet as SQL+import qualified Hasql.Pool                      as SQL+import qualified Hasql.Transaction               as SQL+import qualified Hasql.Transaction.Sessions      as SQL+import qualified Network.HTTP.Types.Header       as HTTP+import qualified Network.HTTP.Types.Status       as HTTP+import qualified Network.HTTP.Types.URI          as HTTP+import qualified Network.Wai                     as Wai+import qualified Network.Wai.Handler.Warp        as Warp -import Data.Function                        (id)-import Data.IORef                           (IORef, readIORef)-import Data.Time.Clock                      (UTCTime)-import Network.HTTP.Types.URI               (renderSimpleQuery)-import Network.Wai.Middleware.RequestLogger (logStdout)+import qualified PostgREST.AppState                 as AppState+import qualified PostgREST.Auth                     as Auth+import qualified PostgREST.DbStructure              as DbStructure+import qualified PostgREST.Error                    as Error+import qualified PostgREST.Middleware               as Middleware+import qualified PostgREST.OpenAPI                  as OpenAPI+import qualified PostgREST.Query.QueryBuilder       as QueryBuilder+import qualified PostgREST.Query.Statements         as Statements+import qualified PostgREST.RangeQuery               as RangeQuery+import qualified PostgREST.Request.ApiRequest       as ApiRequest+import qualified PostgREST.Request.DbRequestBuilder as ReqBuilder -import Control.Applicative-import Data.Maybe-import Network.HTTP.Types.Header-import Network.HTTP.Types.Status-import Network.Wai+import PostgREST.AppState                (AppState)+import PostgREST.Config                  (AppConfig (..),+                                          LogLevel (..),+                                          OpenAPIMode (..))+import PostgREST.Config.PgVersion        (PgVersion (..))+import PostgREST.ContentType             (ContentType (..))+import PostgREST.DbStructure             (DbStructure (..),+                                          tablePKCols)+import PostgREST.DbStructure.Identifiers (FieldName,+                                          QualifiedIdentifier (..),+                                          Schema)+import PostgREST.DbStructure.Proc        (ProcDescription (..),+                                          ProcVolatility (..))+import PostgREST.DbStructure.Table       (Table (..))+import PostgREST.Error                   (Error)+import PostgREST.GucHeader               (GucHeader,+                                          addHeadersIfNotIncluded,+                                          unwrapGucHeader)+import PostgREST.Request.ApiRequest      (Action (..),+                                          ApiRequest (..),+                                          InvokeMethod (..),+                                          Target (..))+import PostgREST.Request.Preferences     (PreferCount (..),+                                          PreferParameters (..),+                                          PreferRepresentation (..))+import PostgREST.Request.Types           (ReadRequest, fstFieldNames)+import PostgREST.Version                 (prettyVersion)+import PostgREST.Workers                 (connectionWorker, listener) -import PostgREST.ApiRequest       (Action (..), ApiRequest (..),-                                   InvokeMethod (..), Target (..),-                                   mutuallyAgreeable, userApiRequest)-import PostgREST.Auth             (containsRole, jwtClaims,-                                   parseSecret)-import PostgREST.Config           (AppConfig (..))-import PostgREST.DbRequestBuilder (mutateRequest, readRequest,-                                   returningCols)-import PostgREST.DbStructure-import PostgREST.Error            (PgError (..), SimpleError (..),-                                   errorResponseFor, singularityError)-import PostgREST.Middleware-import PostgREST.OpenAPI-import PostgREST.Parsers          (pRequestColumns)-import PostgREST.QueryBuilder     (limitedQuery, mutateRequestToQuery,-                                   readRequestToCountQuery,-                                   readRequestToQuery,-                                   requestToCallProcQuery)-import PostgREST.RangeQuery       (allRange, contentRangeH,-                                   rangeStatusHeader)-import PostgREST.Statements       (callProcStatement,-                                   createExplainStatement,-                                   createReadStatement,-                                   createWriteStatement)-import PostgREST.Types-import Protolude                  hiding (Proxy, intercalate, toS)-import Protolude.Conv             (toS)+import qualified PostgREST.ContentType      as ContentType+import qualified PostgREST.DbStructure.Proc as Proc -postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application-postgrest conf refDbStructure pool getTime worker =-  let middle = (if configQuiet conf then id else logStdout) . defaultMiddle-      jwtSecret = parseSecret <$> configJwtSecret conf in-  middle $ \ req respond -> do-    time <- getTime-    body <- strictRequestBody req-    maybeDbStructure <- readIORef refDbStructure-    case maybeDbStructure of-      Nothing -> respond . errorResponseFor $ ConnectionLostError-      Just dbStructure -> do-        response <- do-          -- 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-            Right (apiRequest, maybeCols) -> do-              eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)-              let authed = containsRole eClaims-                  cols = case (iPayload apiRequest, maybeCols) of-                    (Just ProcessedJSON{pjKeys}, _) -> pjKeys-                    (Just RawJSON{}, Just cls)      -> cls-                    _                               -> S.empty-                  proc = case iTarget apiRequest of-                    TargetProc qi _ -> findProc qi cols (iPreferParameters apiRequest == Just SingleObject) $ dbProcs dbStructure-                    _ -> Nothing-                  handleReq = runWithClaims conf eClaims (app dbStructure proc cols conf) apiRequest-                  txMode = transactionMode proc (iAction apiRequest)-              response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq-              return $ either (errorResponseFor . PgError authed) identity response-        when (responseStatus response == status503) worker-        respond response+import Protolude      hiding (Handler, toS)+import Protolude.Conv (toS) -transactionMode :: Maybe ProcDescription -> Action -> HT.Mode-transactionMode proc action =-  case action of-    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-    _ -> 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+data RequestContext = RequestContext+  { ctxConfig      :: AppConfig+  , ctxDbStructure :: DbStructure+  , ctxApiRequest  :: ApiRequest+  , ctxPgVersion   :: PgVersion+  } -        (ActionRead headersOnly, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) ->-          case readSqlParts tSchema tName of-            Left errorResponse -> return errorResponse-            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, 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+type Handler = ExceptT Error -        (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->-          case mutateSqlParts tSchema tName of-            Left errorResponse -> return errorResponse-            Right (sq, mq) -> do-              let pkCols = tablePKCols dbStructure tSchema tName-                  stm = createWriteStatement sq mq-                    (contentType == CTSingularJSON) True-                    (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols pgVer-              row <- H.statement (toS $ pjRaw pJson) stm-              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", encodeUtf8 (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+type DbHandler = Handler SQL.Transaction -        (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->-          case mutateSqlParts tSchema tName of-            Left errorResponse -> return errorResponse-            Right (sq, mq) -> do-              let stm = createWriteStatement sq mq-                    (contentType == CTSingularJSON) False (contentType == CTTextCSV)-                    (iPreferRepresentation apiRequest) [] pgVer-              row <- H.statement (toS $ pjRaw pJson) stm-              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+type SignalHandlerInstaller = AppState -> IO() -        (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->-          case mutateSqlParts tSchema tName of-            Left errorResponse -> return errorResponse-            Right (sq, mq) ->-              if topLevelRange /= allRange-                then return . errorResponseFor $ PutRangeNotAllowedError-              else do-                row <- H.statement (toS $ pjRaw pJson) $-                       createWriteStatement sq mq (contentType == CTSingularJSON) False-                                            (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+type SocketRunner = Warp.Settings -> Wai.Application -> FileMode -> FilePath -> IO() -        (ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) ->-          case mutateSqlParts tSchema tName of-            Left errorResponse -> return errorResponse-            Right (sq, mq) -> do-              let stm = createWriteStatement sq mq-                    (contentType == CTSingularJSON) False-                    (contentType == CTTextCSV)-                    (iPreferRepresentation apiRequest) [] pgVer-              row <- H.statement mempty stm-              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 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+run :: SignalHandlerInstaller -> Maybe SocketRunner -> AppState -> IO ()+run installHandlers maybeRunWithSocket appState = do+  conf@AppConfig{..} <- AppState.getConfig appState+  connectionWorker appState -- Loads the initial DbStructure+  installHandlers appState+  -- reload schema cache + config on NOTIFY+  when configDbChannelEnabled $ listener appState -        (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, returning) -> do-              let-                preferParams = iPreferParameters apiRequest-                pq = requestToCallProcQuery qi (specifiedProcArgs cols proc) returnsScalar preferParams returning-                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 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 headers rBody+  let app = postgrest configLogLevel appState (connectionWorker appState) -        (ActionInspect headersOnly, TargetDefaultSpec tSchema, Nothing) -> do-          let host = configHost conf-              port = toInteger $ configPort 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-              toTableInfo :: [Table] -> [(Table, [Column], [Text])]-              toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn))-              encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure+  case configServerUnixSocket of+    Just socket ->+      -- run the postgrest application with user defined socket. Only for UNIX systems+      case maybeRunWithSocket of+        Just runWithSocket -> do+          AppState.logWithZTime appState $ "Listening on unix socket " <> show socket+          runWithSocket (serverSettings conf) app configServerUnixSocketMode socket+        Nothing ->+          panic "Cannot run with socket on non-unix plattforms."+    Nothing ->+      do+        AppState.logWithZTime appState $ "Listening on port " <> show configServerPort+        Warp.runSettings (serverSettings conf) app -          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)+serverSettings :: AppConfig -> Warp.Settings+serverSettings AppConfig{..} =+  defaultSettings+    & setHost (fromString $ toS configServerHost)+    & setPort configServerPort+    & setServerName (toS $ "postgrest/" <> prettyVersion) -        _ -> return notFound+-- | PostgREST application+postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application+postgrest logLev appState connWorker =+  Middleware.pgrstMiddleware logLev $+    \req respond -> do+      time <- AppState.getTime appState+      conf <- AppState.getConfig appState+      maybeDbStructure <- AppState.getDbStructure appState+      pgVer <- AppState.getPgVersion appState+      jsonDbS <- AppState.getJsonDbS appState -      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+      let+        eitherResponse :: IO (Either Error Wai.Response)+        eitherResponse =+          runExceptT $ postgrestResponse conf maybeDbStructure jsonDbS pgVer (AppState.getPool appState) time req -        readSqlParts s t =-          let-            readReq = readRequest s t maxRows (dbRelations dbStructure) apiRequest-            returnings :: ReadRequest -> Either Response [FieldName]-            returnings rr = Right (returningCols rr)-          in-          (,,,) <$>-          (readRequestToQuery <$> readReq) <*>-          (readRequestToCountQuery <$> readReq) <*>-          (binaryField contentType rawContentTypes returnsScalar =<< readReq) <*>-          (returnings =<< readReq)+      response <- either Error.errorResponseFor identity <$> eitherResponse -        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)+      -- Launch the connWorker when the connection is down.  The postgrest+      -- function can respond successfully (with a stale schema cache) before+      -- the connWorker is done.+      when (Wai.responseStatus response == HTTP.status503) connWorker -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]-                             ++ rawContentTypes-      ActionCreate       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]-      ActionUpdate       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]-      ActionDelete       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]-      ActionInvoke _     ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]-                             ++ rawContentTypes-                             ++ [CTOpenAPI | tpIsRootSpec target]-      ActionInspect _    ->  [CTOpenAPI, CTApplicationJSON]-      ActionInfo         ->  [CTTextCSV]-      ActionSingleUpsert ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]-    serves sProduces cAccepts =-      case mutuallyAgreeable sProduces cAccepts of-        Nothing -> Left . errorResponseFor . ContentTypeError . map toMime $ cAccepts-        Just ct -> Right ct+      respond response -{--  | 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] -> 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+postgrestResponse+  :: AppConfig+  -> Maybe DbStructure+  -> ByteString+  -> PgVersion+  -> SQL.Pool+  -> UTCTime+  -> Wai.Request+  -> Handler IO Wai.Response+postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time req = do+  body <- lift $ Wai.strictRequestBody req++  dbStructure <-+    case maybeDbStructure of+      Just dbStructure ->+        return dbStructure+      Nothing ->+        throwError Error.ConnectionLostError++  apiRequest@ApiRequest{..} <-+    liftEither . mapLeft Error.ApiRequestError $+      ApiRequest.userApiRequest conf dbStructure req body++  -- The JWT must be checked before touching the db+  jwtClaims <- Auth.jwtClaims conf (toS iJWT) time++  let+    handleReq apiReq =+      handleRequest $ RequestContext conf dbStructure apiReq pgVer++  runDbHandler pool (txMode apiRequest) jwtClaims (configDbPreparedStatements conf) .+    Middleware.optionalRollback conf apiRequest $+      Middleware.runPgLocals conf jwtClaims handleReq apiRequest jsonDbS++runDbHandler :: SQL.Pool -> SQL.Mode -> Auth.JWTClaims -> Bool -> DbHandler a -> Handler IO a+runDbHandler pool mode jwtClaims prepared handler = do+  dbResp <-+    let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in+    lift . SQL.use pool . transaction SQL.ReadCommitted mode $ runExceptT handler++  resp <-+    liftEither . mapLeft Error.PgErr $+      mapLeft (Error.PgError $ Auth.containsRole jwtClaims) dbResp++  liftEither resp++handleRequest :: RequestContext -> DbHandler Wai.Response+handleRequest context@(RequestContext _ _ ApiRequest{..} _) =+  case (iAction, iTarget) of+    (ActionRead headersOnly, TargetIdent identifier) ->+      handleRead headersOnly identifier context+    (ActionCreate, TargetIdent identifier) ->+      handleCreate identifier context+    (ActionUpdate, TargetIdent identifier) ->+      handleUpdate identifier context+    (ActionSingleUpsert, TargetIdent identifier) ->+      handleSingleUpsert identifier context+    (ActionDelete, TargetIdent identifier) ->+      handleDelete identifier context+    (ActionInfo, TargetIdent identifier) ->+      handleInfo identifier context+    (ActionInvoke invMethod, TargetProc proc _) ->+      handleInvoke invMethod proc context+    (ActionInspect headersOnly, TargetDefaultSpec tSchema) ->+      handleOpenApi headersOnly tSchema context+    _ ->+      throwError Error.NotFound++handleRead :: Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response+handleRead headersOnly identifier context@RequestContext{..} = do+  req <- readRequest identifier context+  bField <- binaryField context req++  let+    ApiRequest{..} = ctxApiRequest+    AppConfig{..} = ctxConfig+    countQuery = QueryBuilder.readRequestToCountQuery req++  (tableTotal, queryTotal, _ , body, gucHeaders, gucStatus) <-+    lift . SQL.statement mempty $+      Statements.createReadStatement+        (QueryBuilder.readRequestToQuery req)+        (if iPreferCount == Just EstimatedCount then+           -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed+           QueryBuilder.limitedQuery countQuery ((+ 1) <$> configDbMaxRows)+         else+           countQuery+        )+        (iAcceptContentType == CTSingularJSON)+        (shouldCount iPreferCount)+        (iAcceptContentType == CTTextCSV)+        bField+        ctxPgVersion+        configDbPreparedStatements++  total <- readTotal ctxConfig ctxApiRequest tableTotal countQuery+  response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders++  let+    (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange queryTotal total+    headers =+      [ contentRange+      , ( "Content-Location"+        , "/"+            <> toS (qiName identifier)+            <> if BS8.null iCanonicalQS then mempty else "?" <> toS iCanonicalQS+        )+      ]+      ++ contentTypeHeaders context++  failNotSingular iAcceptContentType queryTotal . response status headers $+    if headersOnly then mempty else toS body++readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64)+readTotal AppConfig{..} ApiRequest{..} tableTotal countQuery =+  case iPreferCount of+    Just PlannedCount ->+      explain+    Just EstimatedCount ->+      if tableTotal > (fromIntegral <$> configDbMaxRows) then+        max tableTotal <$> explain+      else+        return tableTotal+    _ ->+      return tableTotal   where-    fldNames = fstFieldNames readReq+    explain =+      lift . SQL.statement mempty . Statements.createExplainStatement countQuery $+        configDbPreparedStatements -locationH :: TableName -> [BS.ByteString] -> Header-locationH tName fields =+handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response+handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do   let-    locationFields = renderSimpleQuery True $ splitKeyValue <$> fields-  in-    (hLocation, "/" <> toS tName <> locationFields)+    ApiRequest{..} = ctxApiRequest+    pkCols = tablePKCols ctxDbStructure qiSchema qiName++  WriteQueryResult{..} <- writeQuery identifier True pkCols context++  let+    response = gucResponse resGucStatus resGucHeaders+    headers =+      catMaybes+        [ if null resFields then+            Nothing+          else+            Just+              ( HTTP.hLocation+              , "/"+                  <> toS qiName+                  <> HTTP.renderSimpleQuery True (splitKeyValue <$> resFields)+              )+        , Just . RangeQuery.contentRangeH 1 0 $+            if shouldCount iPreferCount then Just resQueryTotal else Nothing+        , if null pkCols && isNothing iOnConflict then+            Nothing+          else+            (\x -> ("Preference-Applied", BS8.pack $ show x)) <$> iPreferResolution+        ]++  failNotSingular iAcceptContentType resQueryTotal $+    if iPreferRepresentation == Full then+      response HTTP.status201 (headers ++ contentTypeHeaders context) (toS resBody)+    else+      response HTTP.status201 headers mempty++handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response+handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do+  WriteQueryResult{..} <- writeQuery identifier False mempty context++  let+    response = gucResponse resGucStatus resGucHeaders+    fullRepr = iPreferRepresentation == Full+    updateIsNoOp = Set.null iColumns+    status+      | resQueryTotal == 0 && not updateIsNoOp = HTTP.status404+      | fullRepr = HTTP.status200+      | otherwise = HTTP.status204+    contentRangeHeader =+      RangeQuery.contentRangeH 0 (resQueryTotal - 1) $+        if shouldCount iPreferCount then Just resQueryTotal else Nothing++  failNotSingular iAcceptContentType resQueryTotal $+    if fullRepr then+      response status (contentTypeHeaders context ++ [contentRangeHeader]) (toS resBody)+    else+      response status [contentRangeHeader] mempty++handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response+handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do+  when (iTopLevelRange /= RangeQuery.allRange) $+    throwError Error.PutRangeNotAllowedError++  WriteQueryResult{..} <- writeQuery identifier False mempty context++  let response = gucResponse resGucStatus resGucHeaders++  -- 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+  when (resQueryTotal /= 1) $ do+    lift SQL.condemn+    throwError Error.PutMatchingPkError++  return $+    if iPreferRepresentation == Full then+      response HTTP.status200 (contentTypeHeaders context) (toS resBody)+    else+      response HTTP.status204 (contentTypeHeaders context) mempty++handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response+handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do+  WriteQueryResult{..} <- writeQuery identifier False mempty context++  let+    response = gucResponse resGucStatus resGucHeaders+    contentRangeHeader =+      RangeQuery.contentRangeH 1 0 $+        if shouldCount iPreferCount then Just resQueryTotal else Nothing++  failNotSingular iAcceptContentType resQueryTotal $+    if iPreferRepresentation == Full then+      response HTTP.status200+        (contentTypeHeaders context ++ [contentRangeHeader])+        (toS resBody)+    else+      response HTTP.status204 [contentRangeHeader] mempty++handleInfo :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m Wai.Response+handleInfo identifier RequestContext{..} =+  case find tableMatches $ dbTables ctxDbStructure of+    Just table ->+      return $ Wai.responseLBS HTTP.status200 [allOrigins, allowH table] mempty+    Nothing ->+      throwError Error.NotFound   where-    splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)-    splitKeyValue kv =-      let (k, v) = BS.break (== '=') kv-      in (k, BS.tail v)+    allOrigins = ("Access-Control-Allow-Origin", "*")+    allowH table =+      ( HTTP.hAllow+      , BS8.intercalate "," $+          ["OPTIONS,GET,HEAD"]+          ++ ["POST" | tableInsertable table]+          ++ ["PUT" | tableInsertable table && tableUpdatable table && hasPK]+          ++ ["PATCH" | tableUpdatable table]+          ++ ["DELETE" | tableDeletable table]+      )+    tableMatches table =+      tableName table == qiName identifier+      && tableSchema table == qiSchema identifier+    hasPK =+      not $ null $ tablePKCols ctxDbStructure (qiSchema identifier) (qiName identifier) -contentLocationH :: TableName -> ByteString -> Header-contentLocationH tName qString =-  ("Content-Location", "/" <> toS tName <> if BS.null qString then mempty else "?" <> toS qString)+handleInvoke :: InvokeMethod -> ProcDescription -> RequestContext -> DbHandler Wai.Response+handleInvoke invMethod proc context@RequestContext{..} = do+  let+    ApiRequest{..} = ctxApiRequest -contentProfileH :: Schema -> Header-contentProfileH schema =-   ("Content-Profile", toS schema)+    identifier =+      QualifiedIdentifier+        (pdSchema proc)+        (fromMaybe (pdName proc) $ Proc.procTableName proc)++    returnsSingle (ApiRequest.TargetProc target _) = Proc.procReturnsSingle target+    returnsSingle _                                = False++  req <- readRequest identifier context+  bField <- binaryField context req++  (tableTotal, queryTotal, body, gucHeaders, gucStatus) <-+    lift . SQL.statement mempty $+      Statements.callProcStatement+        (returnsScalar iTarget)+        (returnsSingle iTarget)+        (QueryBuilder.requestToCallProcQuery+          (QualifiedIdentifier (pdSchema proc) (pdName proc))+          (Proc.specifiedProcArgs iColumns proc)+          iPayload+          (returnsScalar iTarget)+          iPreferParameters+          (ReqBuilder.returningCols req [])+        )+        (QueryBuilder.readRequestToQuery req)+        (QueryBuilder.readRequestToCountQuery req)+        (shouldCount iPreferCount)+        (iAcceptContentType == CTSingularJSON)+        (iAcceptContentType == CTTextCSV)+        (iPreferParameters == Just MultipleObjects)+        bField+        ctxPgVersion+        (configDbPreparedStatements ctxConfig)++  response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders++  let+    (status, contentRange) =+      RangeQuery.rangeStatusHeader iTopLevelRange queryTotal tableTotal++  failNotSingular iAcceptContentType queryTotal $+    response status+      (contentTypeHeaders context ++ [contentRange])+      (if invMethod == InvHead then mempty else toS body)++handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response+handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest _) = do+  body <-+    lift $ case configOpenApiMode of+      OAFollowPriv ->+        OpenAPI.encode conf dbStructure+           <$> SQL.statement tSchema (DbStructure.accessibleTables configDbPreparedStatements)+           <*> SQL.statement tSchema (DbStructure.accessibleProcs configDbPreparedStatements)+           <*> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements)+      OAIgnorePriv ->+        OpenAPI.encode conf dbStructure+              (filter (\x -> tableSchema x == tSchema) $ DbStructure.dbTables dbStructure)+              (Map.filterWithKey (\(QualifiedIdentifier sch _) _ ->  sch == tSchema) $ DbStructure.dbProcs dbStructure)+          <$> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements)+      OADisabled ->+        pure mempty++  return $+    Wai.responseLBS HTTP.status200+      (ContentType.toHeader CTOpenAPI : maybeToList (profileHeader apiRequest))+      (if headersOnly then mempty else toS body)++txMode :: ApiRequest -> SQL.Mode+txMode ApiRequest{..} =+  case (iAction, iTarget) of+    (ActionRead _, _) ->+      SQL.Read+    (ActionInfo, _) ->+      SQL.Read+    (ActionInspect _, _) ->+      SQL.Read+    (ActionInvoke InvGet, _) ->+      SQL.Read+    (ActionInvoke InvHead, _) ->+      SQL.Read+    (ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Stable} _) ->+      SQL.Read+    (ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Immutable} _) ->+      SQL.Read+    _ ->+      SQL.Write++-- | Result from executing a write query on the database+data WriteQueryResult = WriteQueryResult+  { resQueryTotal :: Int64+  , resFields     :: [ByteString]+  , resBody       :: ByteString+  , resGucStatus  :: Maybe HTTP.Status+  , resGucHeaders :: [GucHeader]+  }++writeQuery :: QualifiedIdentifier -> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult+writeQuery identifier@QualifiedIdentifier{..} isInsert pkCols context@RequestContext{..} = do+  readReq <- readRequest identifier context++  mutateReq <-+    liftEither $+      ReqBuilder.mutateRequest qiSchema qiName ctxApiRequest+        (tablePKCols ctxDbStructure qiSchema qiName)+        readReq++  (_, queryTotal, fields, body, gucHeaders, gucStatus) <-+    lift . SQL.statement mempty $+      Statements.createWriteStatement+        (QueryBuilder.readRequestToQuery readReq)+        (QueryBuilder.mutateRequestToQuery mutateReq)+        (iAcceptContentType ctxApiRequest == CTSingularJSON)+        isInsert+        (iAcceptContentType ctxApiRequest == CTTextCSV)+        (iPreferRepresentation ctxApiRequest)+        pkCols+        ctxPgVersion+        (configDbPreparedStatements ctxConfig)++  liftEither $ WriteQueryResult queryTotal fields body <$> gucStatus <*> gucHeaders++-- | Response with headers and status overridden from GUCs.+gucResponse+  :: Maybe HTTP.Status+  -> [GucHeader]+  -> HTTP.Status+  -> [HTTP.Header]+  -> LBS.ByteString+  -> Wai.Response+gucResponse gucStatus gucHeaders status headers =+  Wai.responseLBS (fromMaybe status gucStatus) $+    addHeadersIfNotIncluded headers (map unwrapGucHeader gucHeaders)++-- |+-- Fail a response if a single JSON object was requested and not exactly one+-- was found.+failNotSingular :: ContentType -> Int64 -> Wai.Response -> DbHandler Wai.Response+failNotSingular contentType queryTotal response =+  if contentType == CTSingularJSON && queryTotal /= 1 then+    do+      lift SQL.condemn+      throwError $ Error.singularityError queryTotal+  else+    return response++shouldCount :: Maybe PreferCount -> Bool+shouldCount preferCount =+  preferCount == Just ExactCount || preferCount == Just EstimatedCount++returnsScalar :: ApiRequest.Target -> Bool+returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc+returnsScalar _                   = False++readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest+readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest _) =+  liftEither $+    ReqBuilder.readRequest qiSchema qiName configDbMaxRows+      (dbRelationships dbStructure)+      apiRequest++contentTypeHeaders :: RequestContext -> [HTTP.Header]+contentTypeHeaders RequestContext{..} =+  ContentType.toHeader (iAcceptContentType ctxApiRequest) : maybeToList (profileHeader ctxApiRequest)++-- | 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 :: Monad m => RequestContext -> ReadRequest -> Handler m (Maybe FieldName)+binaryField RequestContext{..} readReq+  | returnsScalar (iTarget ctxApiRequest) && iAcceptContentType ctxApiRequest `elem` rawContentTypes ctxConfig =+      return $ Just "pgrst_scalar"+  | iAcceptContentType ctxApiRequest `elem` rawContentTypes ctxConfig =+      let+        fldNames = fstFieldNames readReq+        fieldName = headMay fldNames+      in+      if length fldNames == 1 && fieldName /= Just "*" then+        return fieldName+      else+        throwError $ Error.BinaryFieldError (iAcceptContentType ctxApiRequest)+  | otherwise =+      return Nothing++rawContentTypes :: AppConfig -> [ContentType]+rawContentTypes AppConfig{..} =+  (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]++profileHeader :: ApiRequest -> Maybe HTTP.Header+profileHeader ApiRequest{..} =+  (,) "Content-Profile" <$> (toS <$> iProfile)++splitKeyValue :: ByteString -> (ByteString, ByteString)+splitKeyValue kv =+  (k, BS8.tail v)+  where+    (k, v) = BS8.break (== '=') kv
+ src/PostgREST/AppState.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE RecordWildCards #-}++module PostgREST.AppState+  ( AppState+  , getConfig+  , getDbStructure+  , getIsWorkerOn+  , getJsonDbS+  , getMainThreadId+  , getPgVersion+  , getPool+  , getTime+  , init+  , initWithPool+  , logWithZTime+  , putConfig+  , putDbStructure+  , putIsWorkerOn+  , putJsonDbS+  , putPgVersion+  , releasePool+  , signalListener+  , waitListener+  ) where++import qualified Hasql.Pool as P++import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,+                           updateAction)+import Data.IORef         (IORef, atomicWriteIORef, newIORef,+                           readIORef)+import Data.Time          (ZonedTime, defaultTimeLocale, formatTime,+                           getZonedTime)+import Data.Time.Clock    (UTCTime, getCurrentTime)++import PostgREST.Config           (AppConfig (..))+import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion)+import PostgREST.DbStructure      (DbStructure)++import Protolude      hiding (toS)+import Protolude.Conv (toS)+++data AppState = AppState+  { statePool         :: P.Pool -- | Connection pool, either a 'Connection' or a 'ConnectionError'+  , statePgVersion    :: IORef PgVersion+  -- | No schema cache at the start. Will be filled in by the connectionWorker+  , stateDbStructure  :: IORef (Maybe DbStructure)+  -- | Cached DbStructure in json+  , stateJsonDbS      :: IORef ByteString+  -- | Helper ref to make sure just one connectionWorker can run at a time+  , stateIsWorkerOn   :: IORef Bool+  -- | Binary semaphore used to sync the listener(NOTIFY reload) with the connectionWorker.+  , stateListener     :: MVar ()+  -- | Config that can change at runtime+  , stateConf         :: IORef AppConfig+  -- | Time used for verifying JWT expiration+  , stateGetTime      :: IO UTCTime+  -- | Time with time zone used for worker logs+  , stateGetZTime     :: IO ZonedTime+  -- | Used for killing the main thread in case a subthread fails+  , stateMainThreadId :: ThreadId+  }++init :: AppConfig -> IO AppState+init conf = do+  newPool <- initPool conf+  initWithPool newPool conf++initWithPool :: P.Pool -> AppConfig -> IO AppState+initWithPool newPool conf =+  AppState newPool+    <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step+    <*> newIORef Nothing+    <*> newIORef mempty+    <*> newIORef False+    <*> newEmptyMVar+    <*> newIORef conf+    <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }+    <*> mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime }+    <*> myThreadId++initPool :: AppConfig -> IO P.Pool+initPool AppConfig{..} =+  P.acquire (configDbPoolSize, configDbPoolTimeout, toS configDbUri)++getPool :: AppState -> P.Pool+getPool = statePool++releasePool :: AppState -> IO ()+releasePool AppState{..} = P.release statePool >> throwTo stateMainThreadId UserInterrupt++getPgVersion :: AppState -> IO PgVersion+getPgVersion = readIORef . statePgVersion++putPgVersion :: AppState -> PgVersion -> IO ()+putPgVersion = atomicWriteIORef . statePgVersion++getDbStructure :: AppState -> IO (Maybe DbStructure)+getDbStructure = readIORef . stateDbStructure++putDbStructure :: AppState -> DbStructure -> IO ()+putDbStructure appState structure =+  atomicWriteIORef (stateDbStructure appState) $ Just structure++getJsonDbS :: AppState -> IO ByteString+getJsonDbS = readIORef . stateJsonDbS++putJsonDbS :: AppState -> ByteString -> IO ()+putJsonDbS appState = atomicWriteIORef (stateJsonDbS appState)++getIsWorkerOn :: AppState -> IO Bool+getIsWorkerOn = readIORef . stateIsWorkerOn++putIsWorkerOn :: AppState -> Bool -> IO ()+putIsWorkerOn = atomicWriteIORef . stateIsWorkerOn++getConfig :: AppState -> IO AppConfig+getConfig = readIORef . stateConf++putConfig :: AppState -> AppConfig -> IO ()+putConfig = atomicWriteIORef . stateConf++getTime :: AppState -> IO UTCTime+getTime = stateGetTime++-- | Log to stderr with local time+logWithZTime :: AppState -> Text -> IO ()+logWithZTime appState txt = do+  zTime <- stateGetZTime appState+  hPutStrLn stderr $ toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <> txt++getMainThreadId :: AppState -> ThreadId+getMainThreadId = stateMainThreadId++-- | As this IO action uses `takeMVar` internally, it will only return once+-- `stateListener` has been set using `signalListener`. This is currently used+-- to syncronize workers.+waitListener :: AppState -> IO ()+waitListener = takeMVar . stateListener++-- tryPutMVar doesn't lock the thread. It should always succeed since+-- the connectionWorker is the only mvar producer.+signalListener :: AppState -> IO ()+signalListener appState = void $ tryPutMVar (stateListener appState) ()
src/PostgREST/Auth.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase       #-} {-| Module      : PostgREST.Auth Description : PostgREST authorization functions.@@ -12,103 +10,73 @@ In the test suite there is an example of simple login function that can be used for a very simple authentication system inside the PostgreSQL database. -}-module PostgREST.Auth (-    containsRole+{-# LANGUAGE RecordWildCards #-}+module PostgREST.Auth+  ( containsRole   , jwtClaims-  , JWTAttempt(..)-  , parseSecret+  , JWTClaims   ) where -import qualified Crypto.JOSE.Types   as JOSE.Types+import qualified Crypto.JWT          as JWT import qualified Data.Aeson          as JSON import qualified Data.HashMap.Strict as M-import           Data.Vector         as V+import qualified Data.Vector         as V -import Control.Lens    (set)-import Data.Time.Clock (UTCTime)+import Control.Lens            (set)+import Control.Monad.Except    (liftEither)+import Data.Either.Combinators (mapLeft)+import Data.Time.Clock         (UTCTime) -import Control.Lens.Operators-import Crypto.JWT+import PostgREST.Config (AppConfig (..), JSPath, JSPathExp (..))+import PostgREST.Error  (Error (..)) -import PostgREST.Types-import Protolude       hiding (toS)-import Protolude.Conv  (toS)+import Protolude -{-|-  Possible situations encountered with client JWTs--}-data JWTAttempt = JWTInvalid JWTError-                | JWTMissingSecret-                | JWTClaims (M.HashMap Text JSON.Value)-                deriving (Eq, Show) -{-|-  Receives the JWT secret and audience (from config) and a JWT and returns a map-  of JWT claims.--}-jwtClaims :: Maybe JWKSet -> Maybe StringOrURI -> LByteString -> UTCTime -> Maybe JSPath -> IO JWTAttempt-jwtClaims _ _ "" _ _ = return $ JWTClaims M.empty-jwtClaims secret audience payload time jspath =-  case secret of-    Nothing -> return JWTMissingSecret-    Just s -> do-      let validation = set allowedSkew 1 $ defaultJWTValidationSettings (maybe (const True) (==) audience)-      eJwt <- runExceptT $ do-        jwt <- decodeCompact payload-        verifyClaimsAt validation s time jwt-      return $ case eJwt of-        Left e    -> JWTInvalid e-        Right jwt -> JWTClaims $ claims2map jwt jspath+type JWTClaims = M.HashMap Text JSON.Value -{-|-  Turn JWT ClaimSet into something easier to work with,-  also here the jspath is applied to put the "role" in the map--}-claims2map :: ClaimsSet -> Maybe JSPath -> M.HashMap Text JSON.Value-claims2map claims jspath = (\case-    val@(JSON.Object o) ->-      let role = maybe M.empty (M.singleton "role") $-                 walkJSPath (Just val) =<< jspath in-      M.delete "role" o `M.union` role -- mutating the map-    _ -> M.empty-  ) $ JSON.toJSON claims+-- | Receives the JWT secret and audience (from config) and a JWT and returns a+-- map of JWT claims.+jwtClaims :: Monad m =>+  AppConfig -> LByteString -> UTCTime -> ExceptT Error m JWTClaims+jwtClaims _ "" _ = return M.empty+jwtClaims AppConfig{..} payload time = do+  secret <- liftEither . maybeToRight JwtTokenMissing $ configJWKS+  eitherClaims <-+    lift . runExceptT $+      JWT.verifyClaimsAt validation secret time =<< JWT.decodeCompact payload+  liftEither . mapLeft jwtClaimsError $ claimsMap configJwtRoleClaimKey <$> eitherClaims+  where+    validation =+      JWT.defaultJWTValidationSettings audienceCheck & set JWT.allowedSkew 1 -walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value-walkJSPath x                      []                = x-walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest-walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest-walkJSPath _                      _                 = Nothing+    audienceCheck :: JWT.StringOrURI -> Bool+    audienceCheck = maybe (const True) (==) configJwtAudience -{-|-  Whether a response from jwtClaims contains a role claim--}-containsRole :: JWTAttempt -> Bool-containsRole (JWTClaims claims) = M.member "role" claims-containsRole _                  = False+    jwtClaimsError :: JWT.JWTError -> Error+    jwtClaimsError JWT.JWTExpired = JwtTokenInvalid "JWT expired"+    jwtClaimsError e              = JwtTokenInvalid $ show e -{-|-  Parse `jwt-secret` configuration option and turn into a JWKSet.+-- | Turn JWT ClaimSet into something easier to work with.+--+-- Also, here the jspath is applied to put the "role" in the map.+claimsMap :: JSPath -> JWT.ClaimsSet -> JWTClaims+claimsMap jspath claims =+  case JSON.toJSON claims of+    val@(JSON.Object o) ->+      M.delete "role" o `M.union` role val+    _ ->+      M.empty+  where+    role value =+      maybe M.empty (M.singleton "role") $ walkJSPath (Just value) jspath -  There are three ways to specify `jwt-secret`: text secret, JSON Web Key-  (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JWKSet-  with one key and the last is converted as is.--}-parseSecret :: ByteString -> JWKSet-parseSecret str =-  fromMaybe (maybe secret (\jwk' -> JWKSet [jwk']) maybeJWK)-    maybeJWKSet- where-  maybeJWKSet = JSON.decode (toS str) :: Maybe JWKSet-  maybeJWK = JSON.decode (toS str) :: Maybe JWK-  secret = JWKSet [jwkFromSecret str]+    walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value+    walkJSPath x                      []                = x+    walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest+    walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest+    walkJSPath _                      _                 = Nothing -{-|-  Internal helper to generate a symmetric HMAC-SHA256 JWK from a text secret.--}-jwkFromSecret :: ByteString -> JWK-jwkFromSecret key =-  fromKeyMaterial km-    & jwkUse ?~ Sig-    & jwkAlg ?~ JWSAlg HS256- where-  km = OctKeyMaterial (OctKeyParameters (JOSE.Types.Base64Octets key))+-- | Whether a response from jwtClaims contains a role claim+containsRole :: JWTClaims -> Bool+containsRole = M.member "role"
+ src/PostgREST/CLI.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE RecordWildCards #-}+module PostgREST.CLI+  ( main+  , CLI (..)+  , Command (..)+  , readCLIShowHelp+  ) where++import qualified Data.Aeson                 as Aeson+import qualified Data.ByteString.Lazy       as LBS+import qualified Hasql.Pool                 as P+import qualified Hasql.Transaction.Sessions as HT+import qualified Options.Applicative        as O+import qualified Protolude.Conv             as Conv++import Data.Text.IO (hPutStrLn)+import Text.Heredoc (str)++import PostgREST.AppState    (AppState)+import PostgREST.Config      (AppConfig (..))+import PostgREST.DbStructure (queryDbStructure)+import PostgREST.Version     (prettyVersion)+import PostgREST.Workers     (reReadConfig)++import qualified PostgREST.App      as App+import qualified PostgREST.AppState as AppState+import qualified PostgREST.Config   as Config++import Protolude hiding (hPutStrLn)+++main :: App.SignalHandlerInstaller -> Maybe App.SocketRunner -> CLI -> IO ()+main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do+  conf@AppConfig{..} <-+    either panic identity <$> Config.readAppConfig mempty cliPath Nothing+  appState <- AppState.init conf++  -- Override the config with config options from the db+  -- TODO: the same operation is repeated on connectionWorker, ideally this+  -- would be done only once, but dump CmdDumpConfig needs it for tests.+  when configDbConfig $ reReadConfig True appState++  exec cliCommand appState+  where+    exec :: Command -> AppState -> IO ()+    exec CmdDumpConfig appState = putStr . Config.toText =<< AppState.getConfig appState+    exec CmdDumpSchema appState = putStrLn =<< dumpSchema appState+    exec CmdRun appState = App.run installSignalHandlers runAppWithSocket appState++-- | Dump DbStructure schema to JSON+dumpSchema :: AppState -> IO LBS.ByteString+dumpSchema appState = do+  AppConfig{..} <- AppState.getConfig appState+  result <-+    let transaction = if configDbPreparedStatements then HT.transaction else HT.unpreparedTransaction in+    P.use (AppState.getPool appState) $+      transaction HT.ReadCommitted HT.Read $+        queryDbStructure+          (toList configDbSchemas)+          configDbExtraSearchPath+          configDbPreparedStatements+  P.release $ AppState.getPool appState+  case result of+    Left e -> do+      hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e+      exitFailure+    Right dbStructure -> return $ Aeson.encode dbStructure++-- | Command line interface options+data CLI = CLI+  { cliCommand :: Command+  , cliPath    :: Maybe FilePath+  }++data Command+  = CmdRun+  | CmdDumpConfig+  | CmdDumpSchema++-- | Read command line interface options. Also prints help.+readCLIShowHelp :: Bool -> IO CLI+readCLIShowHelp hasEnvironment =+  O.customExecParser prefs opts+  where+    prefs = O.prefs $ O.showHelpOnError <> O.showHelpOnEmpty+    opts = O.info parser $ O.fullDesc <> progDesc <> footer+    parser = O.helper <*> exampleParser <*> cliParser++    progDesc =+      O.progDesc $+        "PostgREST "+        <> Conv.toS prettyVersion+        <> " / create a REST API to an existing Postgres database"++    footer =+      O.footer $+        "To run PostgREST, please pass the FILENAME argument"+        <> " or set PGRST_ environment variables."++    exampleParser =+      O.infoOption exampleConfigFile $+        O.long "example"+        <> O.short 'e'+        <> O.help "Show an example configuration file"++    cliParser :: O.Parser CLI+    cliParser =+      CLI+        <$> (dumpConfigFlag <|> dumpSchemaFlag)+        <*> optionalIf hasEnvironment configFileOption++    configFileOption =+      O.strArgument $+        O.metavar "FILENAME"+        <> O.help "Path to configuration file (optional with PGRST_ environment variables)"++    dumpConfigFlag =+      O.flag CmdRun CmdDumpConfig $+        O.long "dump-config"+        <> O.help "Dump loaded configuration and exit"++    dumpSchemaFlag =+      O.flag CmdRun CmdDumpSchema $+        O.long "dump-schema"+        <> O.help "Dump loaded schema as JSON and exit (for debugging, output structure is unstable)"++    optionalIf :: Alternative f => Bool -> f a -> f (Maybe a)+    optionalIf True  = O.optional+    optionalIf False = fmap Just++exampleConfigFile :: [Char]+exampleConfigFile =+  [str|### REQUIRED:+      |db-uri = "postgres://user:pass@localhost:5432/dbname"+      |db-schema = "public"+      |db-anon-role = "postgres"+      |+      |### OPTIONAL:+      |## number of open connections in the pool+      |db-pool = 10+      |+      |## Time to live, in seconds, for an idle database pool connection.+      |db-pool-timeout = 10+      |+      |## extra schemas to add to the search_path of every request+      |db-extra-search-path = "public"+      |+      |## limit rows in response+      |# db-max-rows = 1000+      |+      |## stored proc to exec immediately after auth+      |# db-pre-request = "stored_proc_name"+      |+      |## stored proc that overrides the root "/" spec+      |## it must be inside the db-schema+      |# db-root-spec = "stored_proc_name"+      |+      |## Notification channel for reloading the schema cache+      |db-channel = "pgrst"+      |+      |## Enable or disable the notification channel+      |db-channel-enabled = true+      |+      |## Enable in-database configuration+      |db-config = true+      |+      |## how to terminate database transactions+      |## possible values are:+      |## commit (default)+      |##   transaction is always committed, this can not be overriden+      |## commit-allow-override+      |##   transaction is committed, but can be overriden with Prefer tx=rollback header+      |## rollback+      |##   transaction is always rolled back, this can not be overriden+      |## rollback-allow-override+      |##   transaction is rolled back, but can be overriden with Prefer tx=commit header+      |db-tx-end = "commit"+      |+      |## enable or disable prepared statements. disabling is only necessary when behind a connection pooler.+      |## when disabled, statements will be parametrized but won't be prepared.+      |db-prepared-statements = true+      |+      |server-host = "!4"+      |server-port = 3000+      |+      |## 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"+      |+      |## determine if the OpenAPI output should follow or ignore role privileges or be disabled entirely+      |## admitted values: follow-privileges, ignore-privileges, disabled+      |openapi-mode = "follow-privileges"+      |+      |## base url for the OpenAPI output+      |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 = "secret_with_at_least_32_characters"+      |# jwt-aud = "your_audience_claim"+      |jwt-secret-is-base64 = false+      |+      |## jspath to the role claim key+      |jwt-role-claim-key = ".role"+      |+      |## content types to produce raw output+      |# raw-media-types="image/png, image/jpg"+      |+      |## logging level, the admitted values are: crit, error, warn and info.+      |log-level = "error"+      |]
src/PostgREST/Config.hs view
@@ -1,218 +1,364 @@ {-| Module      : PostgREST.Config-Description : Manages PostgREST configuration options.--This module provides a helper function to read the command line-arguments using the optparse-applicative and the AppConfig type to store-them.  It also can be used to define other middleware configuration that-may be delegated to some sort of external configuration.--It currently includes a hardcoded CORS policy but this could easly be-turned in configurable behaviour if needed.+Description : Manages PostgREST configuration type and parser. -Other hardcoded options such as the minimum version number also belong here. -}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards       #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -module PostgREST.Config ( prettyVersion-                        , docsVersion-                        , readOptions-                        , corsPolicy-                        , AppConfig (..)-                        , configPoolTimeout'-                        )-       where+module PostgREST.Config+  ( AppConfig (..)+  , Environment+  , JSPath+  , JSPathExp(..)+  , LogLevel(..)+  , OpenAPIMode(..)+  , Proxy(..)+  , toText+  , isMalformedProxyUri+  , readAppConfig+  , readPGRSTEnvironment+  , toURI+  , parseSecret+  ) where -import qualified Data.ByteString              as B-import qualified Data.ByteString.Char8        as BS-import qualified Data.CaseInsensitive         as CI-import qualified Data.Configurator            as C-import qualified Text.PrettyPrint.ANSI.Leijen as L+import qualified Crypto.JOSE.Types      as JOSE+import qualified Crypto.JWT             as JWT+import qualified Data.Aeson             as JSON+import qualified Data.ByteString        as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Char8  as BS+import qualified Data.Configurator      as C+import qualified Data.Map.Strict        as M+import qualified Data.Text              as T -import Control.Lens                (preview)-import Control.Monad               (fail)-import Crypto.JWT                  (StringOrURI, stringOrUri)-import Data.List                   (lookup)-import Data.List.NonEmpty          (fromList)-import Data.Scientific             (floatingOrInteger)-import Data.Text                   (dropEnd, dropWhileEnd,-                                    intercalate, splitOn, strip, take,-                                    unpack)-import Data.Text.IO                (hPutStrLn)-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 qualified GHC.Show (show) -import Control.Applicative-import Data.Monoid-import Network.Wai-import Options.Applicative          hiding (str)-import Text.Heredoc-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))+import Control.Lens            (preview)+import Control.Monad           (fail)+import Crypto.JWT              (JWK, JWKSet, StringOrURI, stringOrUri)+import Data.Aeson              (encode, toJSON)+import Data.Either.Combinators (mapLeft)+import Data.List               (lookup)+import Data.List.NonEmpty      (fromList, toList)+import Data.Maybe              (fromJust)+import Data.Scientific         (floatingOrInteger)+import Data.Time.Clock         (NominalDiffTime)+import Numeric                 (readOct, showOct)+import System.Environment      (getEnvironment)+import System.Posix.Types      (FileMode) -import PostgREST.Error   (ApiRequestError (..))-import PostgREST.Parsers (pRoleClaimKey)-import PostgREST.Types   (JSPath, JSPathExp (..))-import Protolude         hiding (concat, hPutStrLn, intercalate, null,-                          take, toS, (<>))-import Protolude.Conv    (toS)+import PostgREST.Config.JSPath           (JSPath, JSPathExp (..),+                                          pRoleClaimKey)+import PostgREST.Config.Proxy            (Proxy (..),+                                          isMalformedProxyUri, toURI)+import PostgREST.DbStructure.Identifiers (QualifiedIdentifier, toQi) +import Protolude      hiding (Proxy, toList, toS)+import Protolude.Conv (toS) --- | Config file settings for the server-data AppConfig = AppConfig {-    configDatabase          :: Text-  , configAnonRole          :: Text-  , configOpenAPIProxyUri   :: Maybe Text-  , configSchemas           :: NonEmpty Text-  , configHost              :: Text-  , configPort              :: Int-  , configSocket            :: Maybe FilePath-  , configSocketMode        :: Either Text FileMode -  , configJwtSecret         :: Maybe B.ByteString-  , configJwtSecretIsBase64 :: Bool-  , configJwtAudience       :: Maybe StringOrURI--  , configPool              :: Int-  , configPoolTimeout       :: Int-  , configMaxRows           :: Maybe Integer-  , configReqCheck          :: Maybe Text-  , configQuiet             :: Bool-  , configSettings          :: [(Text, Text)]-  , configRoleClaimKey      :: Either ApiRequestError JSPath-  , configExtraSearchPath   :: [Text]--  , configRootSpec          :: Maybe Text-  , configRawMediaTypes     :: [B.ByteString]+data AppConfig = AppConfig+  { configAppSettings           :: [(Text, Text)]+  , configDbAnonRole            :: Text+  , configDbChannel             :: Text+  , configDbChannelEnabled      :: Bool+  , configDbExtraSearchPath     :: [Text]+  , configDbMaxRows             :: Maybe Integer+  , configDbPoolSize            :: Int+  , configDbPoolTimeout         :: NominalDiffTime+  , configDbPreRequest          :: Maybe QualifiedIdentifier+  , configDbPreparedStatements  :: Bool+  , configDbRootSpec            :: Maybe QualifiedIdentifier+  , configDbSchemas             :: NonEmpty Text+  , configDbConfig              :: Bool+  , configDbTxAllowOverride     :: Bool+  , configDbTxRollbackAll       :: Bool+  , configDbUri                 :: Text+  , configFilePath              :: Maybe FilePath+  , configJWKS                  :: Maybe JWKSet+  , configJwtAudience           :: Maybe StringOrURI+  , configJwtRoleClaimKey       :: JSPath+  , configJwtSecret             :: Maybe B.ByteString+  , configJwtSecretIsBase64     :: Bool+  , configLogLevel              :: LogLevel+  , configOpenApiMode           :: OpenAPIMode+  , configOpenApiServerProxyUri :: Maybe Text+  , configRawMediaTypes         :: [B.ByteString]+  , configServerHost            :: Text+  , configServerPort            :: Int+  , configServerUnixSocket      :: Maybe FilePath+  , configServerUnixSocketMode  :: FileMode   } -configPoolTimeout' :: (Fractional a) => AppConfig -> a-configPoolTimeout' =-  fromRational . toRational . configPoolTimeout+data LogLevel = LogCrit | LogError | LogWarn | LogInfo +instance Show LogLevel where+  show LogCrit  = "crit"+  show LogError = "error"+  show LogWarn  = "warn"+  show LogInfo  = "info" -defaultCorsPolicy :: CorsResourcePolicy-defaultCorsPolicy =  CorsResourcePolicy Nothing-  ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing-  (Just $ 60*60*24) False False True+data OpenAPIMode = OAFollowPriv | OAIgnorePriv | OADisabled+  deriving Eq --- | CORS policy to be used in by Wai Cors middleware-corsPolicy :: Request -> Maybe CorsResourcePolicy-corsPolicy req = case lookup "origin" headers of-  Just origin -> Just defaultCorsPolicy {-      corsOrigins = Just ([origin], True)-    , corsRequestHeaders = "Authentication":accHeaders-    , corsExposedHeaders = Just [-        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"-      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"-      ]-    }-  Nothing -> Nothing+instance Show OpenAPIMode where+  show OAFollowPriv = "follow-privileges"+  show OAIgnorePriv = "ignore-privileges"+  show OADisabled   = "disabled"++-- | Dump the config+toText :: AppConfig -> Text+toText conf =+  unlines $ (\(k, v) -> k <> " = " <> v) <$> pgrstSettings ++ appSettings   where-    headers = requestHeaders req-    accHeaders = case lookup "access-control-request-headers" headers of-      Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs-      Nothing -> []+    -- apply conf to all pgrst settings+    pgrstSettings = (\(k, v) -> (k, v conf)) <$>+      [("db-anon-role",              q . configDbAnonRole)+      ,("db-channel",                q . configDbChannel)+      ,("db-channel-enabled",            T.toLower . show . configDbChannelEnabled)+      ,("db-extra-search-path",      q . T.intercalate "," . configDbExtraSearchPath)+      ,("db-max-rows",                   maybe "\"\"" show . configDbMaxRows)+      ,("db-pool",                       show . configDbPoolSize)+      ,("db-pool-timeout",               show . floor . configDbPoolTimeout)+      ,("db-pre-request",            q . maybe mempty show . configDbPreRequest)+      ,("db-prepared-statements",        T.toLower . show . configDbPreparedStatements)+      ,("db-root-spec",              q . maybe mempty show . configDbRootSpec)+      ,("db-schemas",                q . T.intercalate "," . toList . configDbSchemas)+      ,("db-config",                 q . T.toLower . show . configDbConfig)+      ,("db-tx-end",                 q . showTxEnd)+      ,("db-uri",                    q . configDbUri)+      ,("jwt-aud",                       toS . encode . maybe "" toJSON . configJwtAudience)+      ,("jwt-role-claim-key",        q . T.intercalate mempty . fmap show . configJwtRoleClaimKey)+      ,("jwt-secret",                q . toS . showJwtSecret)+      ,("jwt-secret-is-base64",          T.toLower . show . configJwtSecretIsBase64)+      ,("log-level",                 q . show . configLogLevel)+      ,("openapi-mode",              q . show . configOpenApiMode)+      ,("openapi-server-proxy-uri",  q . fromMaybe mempty . configOpenApiServerProxyUri)+      ,("raw-media-types",           q . toS . B.intercalate "," . configRawMediaTypes)+      ,("server-host",               q . configServerHost)+      ,("server-port",                   show . configServerPort)+      ,("server-unix-socket",        q . maybe mempty T.pack . configServerUnixSocket)+      ,("server-unix-socket-mode",   q . T.pack . showSocketMode)+      ] --- | User friendly version number-prettyVersion :: Text-prettyVersion =-  intercalate "." (map show $ versionBranch version)-  <> " (" <> take 7 $(gitHash) <> ")"+    -- quote all app.settings+    appSettings = second q <$> configAppSettings conf --- | Version number used in docs-docsVersion :: Text-docsVersion = "v" <> dropEnd 1 (dropWhileEnd (/= '.') prettyVersion)+    -- quote strings and replace " with \"+    q s = "\"" <> T.replace "\"" "\\\"" s <> "\"" --- | Function to read and parse options from the command line-readOptions :: IO AppConfig-readOptions = do-  -- First read the config file path from command line-  cfgPath <- customExecParser parserPrefs opts-  -- 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" <> err)-    ]+    showTxEnd c = case (configDbTxRollbackAll c, configDbTxAllowOverride c) of+      ( False, False ) -> "commit"+      ( False, True  ) -> "commit-allow-override"+      ( True , False ) -> "rollback"+      ( True , True  ) -> "rollback-allow-override"+    showJwtSecret c+      | configJwtSecretIsBase64 c = B64.encode secret+      | otherwise                 = toS secret+      where+        secret = fromMaybe mempty $ configJwtSecret c+    showSocketMode c = showOct (configServerUnixSocketMode c) mempty -  case C.runParser parseConfig conf of+-- This class is needed for the polymorphism of overrideFromDbOrEnvironment+-- because C.required and C.optional have different signatures+class JustIfMaybe a b where+  justIfMaybe :: a -> b++instance JustIfMaybe a a where+  justIfMaybe a = a++instance JustIfMaybe a (Maybe a) where+  justIfMaybe a = Just a++-- | Reads and parses the config and overrides its parameters from env vars,+-- files or db settings.+readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> IO (Either Text AppConfig)+readAppConfig dbSettings optPath prevDbUri = do+  env <- readPGRSTEnvironment+  -- if no filename provided, start with an empty map to read config from environment+  conf <- maybe (return $ Right M.empty) loadConfig optPath++  case C.runParser (parser optPath env dbSettings) =<< mapLeft show conf of     Left err ->-      exitErr $ "Error parsing config file:\n\t" <> err-    Right appConf ->-      return appConf+      return . Left $ "Error in config " <> err+    Right parsedConfig ->+      Right <$> decodeLoadFiles parsedConfig+  where+    -- Both C.ParseError and IOError are shown here+    loadConfig :: FilePath -> IO (Either SomeException C.Config)+    loadConfig = try . C.load +    decodeLoadFiles :: AppConfig -> IO AppConfig+    decodeLoadFiles parsedConfig =+      decodeJWKS <$>+        (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig)++parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> C.Parser C.Config AppConfig+parser optPath env dbSettings =+  AppConfig+    <$> parseAppSettings "app.settings"+    <*> reqString "db-anon-role"+    <*> (fromMaybe "pgrst" <$> optString "db-channel")+    <*> (fromMaybe True <$> optBool "db-channel-enabled")+    <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path")+    <*> optWithAlias (optInt "db-max-rows")+                     (optInt "max-rows")+    <*> (fromMaybe 10 <$> optInt "db-pool")+    <*> (fromIntegral . fromMaybe 10 <$> optInt "db-pool-timeout")+    <*> (fmap toQi <$> optWithAlias (optString "db-pre-request")+                                    (optString "pre-request"))+    <*> (fromMaybe True <$> optBool "db-prepared-statements")+    <*> (fmap toQi <$> optWithAlias (optString "db-root-spec")+                                    (optString "root-spec"))+    <*> (fromList . splitOnCommas <$> reqWithAlias (optValue "db-schemas")+                                                   (optValue "db-schema")+                                                   "missing key: either db-schemas or db-schema must be set")+    <*> (fromMaybe True <$> optBool "db-config")+    <*> parseTxEnd "db-tx-end" snd+    <*> parseTxEnd "db-tx-end" fst+    <*> reqString "db-uri"+    <*> pure optPath+    <*> pure Nothing+    <*> parseJwtAudience "jwt-aud"+    <*> parseRoleClaimKey "jwt-role-claim-key" "role-claim-key"+    <*> (fmap encodeUtf8 <$> optString "jwt-secret")+    <*> (fromMaybe False <$> optWithAlias+          (optBool "jwt-secret-is-base64")+          (optBool "secret-is-base64"))+    <*> parseLogLevel "log-level"+    <*> parseOpenAPIMode "openapi-mode"+    <*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri"+    <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")+    <*> (fromMaybe "!4" <$> optString "server-host")+    <*> (fromMaybe 3000 <$> optInt "server-port")+    <*> (fmap T.unpack <$> optString "server-unix-socket")+    <*> parseSocketFileMode "server-unix-socket-mode"   where-    parseConfig =-      AppConfig-        <$> reqString "db-uri"-        <*> reqString "db-anon-role"-        <*> optString "openapi-server-proxy-uri"-        <*> (fromList . splitOnCommas <$> reqValue "db-schema")-        <*> (fromMaybe "!4" <$> optString "server-host")-        <*> (fromMaybe 3000 <$> optInt "server-port")-        <*> (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"-        <*> (fromMaybe 10 <$> optInt "db-pool")-        <*> (fromMaybe 10 <$> optInt "db-pool-timeout")-        <*> optInt "max-rows"-        <*> optString "pre-request"-        <*> pure False-        <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value)-        <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key")-        <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path")-        <*> optString "root-spec"-        <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")+    parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]+    parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value+      where+        addFromEnv f = M.toList $ M.union fromEnv $ M.fromList f+        fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env+        normalize k = ("app.settings." <>) <$> T.stripPrefix "PGRST_APP_SETTINGS_" (toS k) -    parseSocketFileMode :: C.Key -> C.Parser C.Config (Either Text FileMode)+    parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode     parseSocketFileMode k =-      C.optional k C.string >>= \case-        Nothing -> pure $ Right 432 -- return default 660 mode if no value was provided+      optString k >>= \case+        Nothing -> pure 432 -- return default 660 mode if no value was provided         Just fileModeText ->-          case (readOct . unpack) fileModeText of+          case readOct $ T.unpack fileModeText of             []              ->-              pure $ Left "Invalid server-unix-socket-mode: not an octal"+              fail "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+                then fail "Invalid server-unix-socket-mode: needs to be between 600 and 777"+                else pure fileMode +    parseOpenAPIMode :: C.Key -> C.Parser C.Config OpenAPIMode+    parseOpenAPIMode k =+      optString k >>= \case+        Nothing                  -> pure OAFollowPriv+        Just "follow-privileges" -> pure OAFollowPriv+        Just "ignore-privileges" -> pure OAIgnorePriv+        Just "disabled"          -> pure OADisabled+        Just _                   -> fail "Invalid openapi-mode. Check your configuration."++    parseOpenAPIServerProxyURI :: C.Key -> C.Parser C.Config (Maybe Text)+    parseOpenAPIServerProxyURI k =+      optString k >>= \case+        Nothing                            -> pure Nothing+        Just val | isMalformedProxyUri val -> fail "Malformed proxy uri, a correct example: https://example.com:8443/basePath"+                 | otherwise               -> pure $ Just val+     parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI)     parseJwtAudience k =-      C.optional k C.string >>= \case+      optString k >>= \case         Nothing -> pure Nothing -- no audience in config file-        Just aud -> case preview stringOrUri (unpack aud) of+        Just aud -> case preview stringOrUri (T.unpack aud) of           Nothing -> fail "Invalid Jwt audience. Check your configuration."-          (Just "") -> pure Nothing           aud' -> pure aud' -    reqString :: C.Key -> C.Parser C.Config Text-    reqString k = C.required k C.string+    parseLogLevel :: C.Key -> C.Parser C.Config LogLevel+    parseLogLevel k =+      optString k >>= \case+        Nothing      -> pure LogError+        Just "crit"  -> pure LogCrit+        Just "error" -> pure LogError+        Just "warn"  -> pure LogWarn+        Just "info"  -> pure LogInfo+        Just _       -> fail "Invalid logging level. Check your configuration." -    reqValue :: C.Key -> C.Parser C.Config C.Value-    reqValue k = C.required k C.value+    parseTxEnd :: C.Key -> ((Bool, Bool) -> Bool) -> C.Parser C.Config Bool+    parseTxEnd k f =+      optString k >>= \case+        --                                          RollbackAll AllowOverride+        Nothing                        -> pure $ f (False,      False)+        Just "commit"                  -> pure $ f (False,      False)+        Just "commit-allow-override"   -> pure $ f (False,      True)+        Just "rollback"                -> pure $ f (True,       False)+        Just "rollback-allow-override" -> pure $ f (True,       True)+        Just _                         -> fail "Invalid transaction termination. Check your configuration." +    parseRoleClaimKey :: C.Key -> C.Key -> C.Parser C.Config JSPath+    parseRoleClaimKey k al =+      optWithAlias (optString k) (optString al) >>= \case+        Nothing  -> pure [JSPKey "role"]+        Just rck -> either (fail . show) pure $ pRoleClaimKey rck++    reqWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> [Char] -> C.Parser C.Config a+    reqWithAlias orig alias err =+      orig >>= \case+        Just v  -> pure v+        Nothing ->+          alias >>= \case+            Just v  -> pure v+            Nothing -> fail err++    optWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a)+    optWithAlias orig alias =+      orig >>= \case+        Just v  -> pure $ Just v+        Nothing -> alias++    reqString :: C.Key -> C.Parser C.Config Text+    reqString k = overrideFromDbOrEnvironment C.required k coerceText+     optString :: C.Key -> C.Parser C.Config (Maybe Text)-    optString k = mfilter (/= "") <$> C.optional k C.string+    optString k = mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText      optValue :: C.Key -> C.Parser C.Config (Maybe C.Value)-    optValue k = C.optional k C.value+    optValue k = overrideFromDbOrEnvironment C.optional k identity      optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i)-    optInt k = join <$> C.optional k (coerceInt <$> C.value)+    optInt k = join <$> overrideFromDbOrEnvironment C.optional k coerceInt      optBool :: C.Key -> C.Parser C.Config (Maybe Bool)-    optBool k = join <$> C.optional k (coerceBool <$> C.value)+    optBool k = join <$> overrideFromDbOrEnvironment C.optional k coerceBool +    overrideFromDbOrEnvironment :: JustIfMaybe a b =>+                               (C.Key -> C.Parser C.Value a -> C.Parser C.Config b) ->+                               C.Key -> (C.Value -> a) -> C.Parser C.Config b+    overrideFromDbOrEnvironment necessity key coercion =+      case reloadableDbSetting <|> M.lookup envVarName env of+        Just dbOrEnvVal -> pure $ justIfMaybe $ coercion $ C.String dbOrEnvVal+        Nothing  -> necessity key (coercion <$> C.value)+      where+        dashToUnderscore '-' = '_'+        dashToUnderscore c   = c+        envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key)+        reloadableDbSetting =+          let dbSettingName = T.pack $ dashToUnderscore <$> toS key in+          if dbSettingName `notElem` [+            "server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "log_level",+            "db_anon_role", "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_timeout", "db_config"]+          then lookup dbSettingName dbSettings+          else Nothing+     coerceText :: C.Value -> Text     coerceText (C.String s) = s     coerceText v            = show v@@ -224,85 +370,77 @@      coerceBool :: C.Value -> Maybe Bool     coerceBool (C.Bool b)   = Just b-    coerceBool (C.String b) = readMaybe $ toS b+    coerceBool (C.String s) =+      -- parse all kinds of text: True, true, TRUE, "true", ...+      case readMaybe . toS $ T.toTitle $ T.filter isAlpha $ toS s of+        Just b  -> Just b+        -- numeric instead?+        Nothing -> (> 0) <$> (readMaybe $ toS s :: Maybe Integer)     coerceBool _            = Nothing -    parseRoleClaimKey :: C.Value -> Either ApiRequestError JSPath-    parseRoleClaimKey (C.String s) = pRoleClaimKey s-    parseRoleClaimKey v            = pRoleClaimKey $ show v-     splitOnCommas :: C.Value -> [Text]-    splitOnCommas (C.String s) = strip <$> splitOn "," s+    splitOnCommas (C.String s) = T.strip <$> T.splitOn "," s     splitOnCommas _            = [] -    opts = info (helper <*> pathParser) $-             fullDesc-             <> progDesc (-                 "PostgREST "-                 <> toS prettyVersion-                 <> " / create a REST API to an existing Postgres database"-               )-             <> footerDoc (Just $-                 text "Example Config File:"-                 L.<> nest 2 (hardline L.<> exampleCfg)-               )+-- | Read the JWT secret from a file if configJwtSecret is actually a+-- filepath(has @ as its prefix). To check if the JWT secret is provided is+-- in fact a file path, it must be decoded as 'Text' to be processed.+readSecretFile :: AppConfig -> IO AppConfig+readSecretFile conf =+  maybe (return conf) readSecret maybeFilename+  where+    maybeFilename = T.stripPrefix "@" . decodeUtf8 =<< configJwtSecret conf+    readSecret filename = do+      jwtSecret <- chomp <$> BS.readFile (toS filename)+      return $ conf { configJwtSecret = Just jwtSecret }+    chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs) -    parserPrefs = prefs showHelpOnError+decodeSecret :: AppConfig -> IO AppConfig+decodeSecret conf@AppConfig{..} =+  case (configJwtSecretIsBase64, configJwtSecret) of+    (True, Just secret) ->+      either fail (return . updateSecret) $ decodeB64 secret+    _ -> return conf+  where+    updateSecret bs = conf { configJwtSecret = Just bs }+    decodeB64 = B64.decode . encodeUtf8 . T.strip . replaceUrlChars . decodeUtf8+    replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "=" -    exitErr :: Text -> IO a-    exitErr err = do-      hPutStrLn stderr err-      exitFailure+-- | Parse `jwt-secret` configuration option and turn into a JWKSet.+--+-- There are three ways to specify `jwt-secret`: text secret, JSON Web Key+-- (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JWKSet+-- with one key and the last is converted as is.+decodeJWKS :: AppConfig -> AppConfig+decodeJWKS conf =+  conf { configJWKS = parseSecret <$> configJwtSecret conf } -    exampleCfg :: Doc-    exampleCfg = vsep . map (text . toS) . lines $-      [str|db-uri = "postgres://user:pass@localhost:5432/dbname"-          |db-schema = "public" # this schema gets added to the search_path of every request-          |db-anon-role = "postgres"-          |db-pool = 10-          |db-pool-timeout = 10-          |-          |server-host = "!4"-          |server-port = 3000-          |-          |## 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-          |# 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 = "secret_with_at_least_32_characters"-          |# secret-is-base64 = false-          |# jwt-aud = "your_audience_claim"-          |-          |## limit rows in response-          |# max-rows = 1000-          |-          |## stored proc to exec immediately after auth-          |# pre-request = "stored_proc_name"-          |-          |## jspath to the role claim key-          |# role-claim-key = ".role"-          |-          |## extra schemas to add to the search_path of every request-          |# db-extra-search-path = "extensions, util"-          |-          |## stored proc that overrides the root "/" spec-          |## it must be inside the db-schema-          |# root-spec = "stored_proc_name"-          |-          |## content types to produce raw output-          |# raw-media-types="image/png, image/jpg"-          |]+parseSecret :: ByteString -> JWKSet+parseSecret bytes =+  fromMaybe (maybe secret (\jwk' -> JWT.JWKSet [jwk']) maybeJWK)+    maybeJWKSet+  where+    maybeJWKSet = JSON.decode (toS bytes) :: Maybe JWKSet+    maybeJWK = JSON.decode (toS bytes) :: Maybe JWK+    secret = JWT.JWKSet [JWT.fromKeyMaterial keyMaterial]+    keyMaterial = JWT.OctKeyMaterial . JWT.OctKeyParameters $ JOSE.Base64Octets bytes -pathParser :: Parser FilePath-pathParser =-  strArgument $-    metavar "FILENAME" <>-    help "Path to configuration file"+-- | Read database uri from a separate file if `db-uri` is a filepath.+readDbUriFile :: Maybe Text -> AppConfig -> IO AppConfig+readDbUriFile maybeDbUri conf =+  case maybeDbUri of+    Just prevDbUri ->+      pure $ conf { configDbUri = prevDbUri }+    Nothing ->+      case T.stripPrefix "@" $ configDbUri conf of+        Nothing -> return conf+        Just filename -> do+          dbUri <- T.strip <$> readFile (toS filename)+          return $ conf { configDbUri = dbUri }++type Environment = M.Map [Char] Text++-- | Read environment variables that start with PGRST_+readPGRSTEnvironment :: IO Environment+readPGRSTEnvironment =+  M.map T.pack . M.fromList . filter (isPrefixOf "PGRST_" . fst) <$> getEnvironment
+ src/PostgREST/Config/Database.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE QuasiQuotes #-}++module PostgREST.Config.Database+  ( queryDbSettings+  , queryPgVersion+  ) where++import PostgREST.Config.PgVersion (PgVersion (..))++import qualified Hasql.Decoders             as HD+import qualified Hasql.Encoders             as HE+import qualified Hasql.Pool                 as P+import qualified Hasql.Session              as H+import qualified Hasql.Statement            as H+import qualified Hasql.Transaction          as HT+import qualified Hasql.Transaction.Sessions as HT++import Text.InterpolatedString.Perl6 (q)++import Protolude++queryPgVersion :: H.Session PgVersion+queryPgVersion = H.statement mempty $ H.Statement sql HE.noParams versionRow False+  where+    sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"+    versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text++queryDbSettings :: P.Pool -> Bool -> IO (Either P.UsageError [(Text, Text)])+queryDbSettings pool prepared =+  let transaction = if prepared then HT.transaction else HT.unpreparedTransaction in+  P.use pool . transaction HT.ReadCommitted HT.Read $+    HT.statement mempty dbSettingsStatement++-- | Get db settings from the connection role. Global settings will be overridden by database specific settings.+dbSettingsStatement :: H.Statement () [(Text, Text)]+dbSettingsStatement = H.Statement sql HE.noParams decodeSettings False+  where+    sql = [q|+      with+      role_setting as (+        select setdatabase, unnest(setconfig) as setting from pg_catalog.pg_db_role_setting+        where setrole = current_user::regrole::oid+          and setdatabase in (0, (select oid from pg_catalog.pg_database where datname = current_catalog))+      ),+      kv_settings as (+        select setdatabase, split_part(setting, '=', 1) as k, split_part(setting, '=', 2) as value from role_setting+        where setting like 'pgrst.%'+      )+      select distinct on (key) replace(k, 'pgrst.', '') as key, value+      from kv_settings+      order by key, setdatabase desc;+    |]+    decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text++column :: HD.Value a -> HD.Row a+column = HD.column . HD.nonNullable
+ src/PostgREST/Config/JSPath.hs view
@@ -0,0 +1,59 @@+{-|+Module      : PostgREST.Types+Description : PostgREST common types and functions used by the rest of the modules+-}+{-# LANGUAGE DuplicateRecordFields #-}++module PostgREST.Config.JSPath+  ( JSPath+  , JSPathExp(..)+  , pRoleClaimKey+  ) where++import qualified Text.ParserCombinators.Parsec as P++import Data.Either.Combinators       (mapLeft)+import Text.ParserCombinators.Parsec ((<?>))+import Text.Read                     (read)++import qualified GHC.Show (show)++import Protolude      hiding (toS)+import Protolude.Conv (toS)+++-- | full jspath, e.g. .property[0].attr.detail+type JSPath = [JSPathExp]++-- | jspath expression, e.g. .property, .property[0] or ."property-dash"+data JSPathExp+  = JSPKey Text+  | JSPIdx Int++instance Show JSPathExp where+  -- TODO: this needs to be quoted properly for special chars+  show (JSPKey k) = "." <> show k+  show (JSPIdx i) = "[" <> show i <> "]"++-- Used for the config value "role-claim-key"+pRoleClaimKey :: Text -> Either Text JSPath+pRoleClaimKey selStr =+  mapLeft show $ P.parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)++pJSPath :: P.Parser JSPath+pJSPath = toJSPath <$> (period *> pPath `P.sepBy` period <* P.eof)+  where+    toJSPath :: [(Text, Maybe Int)] -> JSPath+    toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))+    period = P.char '.' <?> "period (.)"+    pPath :: P.Parser (Text, Maybe Int)+    pPath = (,) <$> pJSPKey <*> P.optionMaybe pJSPIdx++pJSPKey :: P.Parser Text+pJSPKey = toS <$> P.many1 (P.alphaNum <|> P.oneOf "_$@") <|> pQuotedValue <?> "attribute name [a..z0..9_$@])"++pJSPIdx :: P.Parser Int+pJSPIdx = P.char '[' *> (read <$> P.many1 P.digit) <* P.char ']' <?> "array index [0..n]"++pQuotedValue :: P.Parser Text+pQuotedValue = toS <$> (P.char '"' *> P.many (P.noneOf "\"") <* P.char '"')
+ src/PostgREST/Config/PgVersion.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}+module PostgREST.Config.PgVersion+  ( PgVersion(..)+  , minimumPgVersion+  , pgVersion95+  , pgVersion96+  , pgVersion100+  , pgVersion109+  , pgVersion110+  , pgVersion112+  , pgVersion114+  , pgVersion121+  , pgVersion130+  ) where++import qualified Data.Aeson as JSON++import Protolude+++data PgVersion = PgVersion+  { pgvNum  :: Int32+  , pgvName :: Text+  }+  deriving (Eq, Generic, JSON.ToJSON)++instance Ord PgVersion where+  (PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2++-- | Tells the minimum PostgreSQL version required by this version of PostgREST+minimumPgVersion :: PgVersion+minimumPgVersion = pgVersion95++pgVersion95 :: PgVersion+pgVersion95 = PgVersion 90500 "9.5"++pgVersion96 :: PgVersion+pgVersion96 = PgVersion 90600 "9.6"++pgVersion100 :: PgVersion+pgVersion100 = PgVersion 100000 "10"++pgVersion109 :: PgVersion+pgVersion109 = PgVersion 100009 "10.9"++pgVersion110 :: PgVersion+pgVersion110 = PgVersion 110000 "11.0"++pgVersion112 :: PgVersion+pgVersion112 = PgVersion 110002 "11.2"++pgVersion114 :: PgVersion+pgVersion114 = PgVersion 110004 "11.4"++pgVersion121 :: PgVersion+pgVersion121 = PgVersion 120001 "12.1"++pgVersion130 :: PgVersion+pgVersion130 = PgVersion 130000 "13.0"
+ src/PostgREST/Config/Proxy.hs view
@@ -0,0 +1,78 @@+{-|+Module      : PostgREST.Private.ProxyUri+Description : Proxy Uri validator+-}+module PostgREST.Config.Proxy+  ( Proxy(..)+  , isMalformedProxyUri+  , toURI+  ) where++import Data.Maybe  (fromJust)+import Data.Text   (pack, toLower)+import Network.URI (URI (..), URIAuth (..), isAbsoluteURI, parseURI)++import Protolude      hiding (Proxy, dropWhile, get, intercalate,+                       toLower, toS, (&))+import Protolude.Conv (toS)++data Proxy = Proxy+  { proxyScheme :: Text+  , proxyHost   :: Text+  , proxyPort   :: Integer+  , proxyPath   :: Text+  }++{-|+  Test whether a proxy uri is malformed or not.+  A valid proxy uri should be an absolute uri without query and user info,+  only http(s) schemes are valid, port number range is 1-65535.++  For example+  http://postgrest.com/openapi.json+  https://postgrest.com:8080/openapi.json+-}+isMalformedProxyUri :: Text -> Bool+isMalformedProxyUri uri+  | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri+  | otherwise = True++toURI :: Text -> URI+toURI uri = fromJust $ parseURI (toS uri)++isUriValid:: URI -> Bool+isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]++fAnd :: [a -> Bool] -> a -> Bool+fAnd fs x = all ($ x) fs++isSchemeValid :: URI -> Bool+isSchemeValid URI {uriScheme = s}+  | toLower (pack s) == "https:" = True+  | toLower (pack s) == "http:" = True+  | otherwise = False++isQueryValid :: URI -> Bool+isQueryValid URI {uriQuery = ""} = True+isQueryValid _                   = False++isAuthorityValid :: URI -> Bool+isAuthorityValid URI {uriAuthority = a}+  | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a+  | otherwise = False++isUserInfoValid :: URIAuth -> Bool+isUserInfoValid URIAuth {uriUserInfo = ""} = True+isUserInfoValid _                          = False++isHostValid :: URIAuth -> Bool+isHostValid URIAuth {uriRegName = ""} = False+isHostValid _                         = True++isPortValid :: URIAuth -> Bool+isPortValid URIAuth {uriPort = ""} = True+isPortValid URIAuth {uriPort = (':':p)} =+  case readMaybe p of+    Just i  -> i > (0 :: Integer) && i < 65536+    Nothing -> False+isPortValid _ = False
+ src/PostgREST/ContentType.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE DuplicateRecordFields #-}++module PostgREST.ContentType+  ( ContentType(..)+  , toHeader+  , toMime+  , decodeContentType+  ) where++import qualified Data.ByteString          as BS+import qualified Data.ByteString.Internal as BS (c2w)++import Network.HTTP.Types.Header (Header, hContentType)++import Protolude++-- | Enumeration of currently supported response content types+data ContentType+  = CTApplicationJSON+  | CTSingularJSON+  | CTTextCSV+  | CTTextPlain+  | CTOpenAPI+  | CTUrlEncoded+  | CTOctetStream+  | CTAny+  | CTOther ByteString+  deriving (Eq)++-- | Convert from ContentType to a full HTTP Header+toHeader :: ContentType -> Header+toHeader ct = (hContentType, toMime ct <> charset)+  where+    charset = case ct of+      CTOctetStream -> mempty+      CTOther _     -> mempty+      _             -> "; charset=utf-8"++-- | Convert from ContentType to a ByteString representing the mime type+toMime :: ContentType -> ByteString+toMime CTApplicationJSON = "application/json"+toMime CTTextCSV         = "text/csv"+toMime CTTextPlain       = "text/plain"+toMime CTOpenAPI         = "application/openapi+json"+toMime CTSingularJSON    = "application/vnd.pgrst.object+json"+toMime CTUrlEncoded      = "application/x-www-form-urlencoded"+toMime CTOctetStream     = "application/octet-stream"+toMime CTAny             = "*/*"+toMime (CTOther ct)      = ct++-- | Convert from ByteString to ContentType. Warning: discards MIME parameters+decodeContentType :: BS.ByteString -> ContentType+decodeContentType ct =+  case BS.takeWhile (/= BS.c2w ';') ct of+    "application/json"                  -> CTApplicationJSON+    "text/csv"                          -> CTTextCSV+    "text/plain"                        -> CTTextPlain+    "application/openapi+json"          -> CTOpenAPI+    "application/vnd.pgrst.object+json" -> CTSingularJSON+    "application/vnd.pgrst.object"      -> CTSingularJSON+    "application/x-www-form-urlencoded" -> CTUrlEncoded+    "application/octet-stream"          -> CTOctetStream+    "*/*"                               -> CTAny+    ct'                                 -> CTOther ct'
− src/PostgREST/DbRequestBuilder.hs 
@@ -1,351 +0,0 @@-{-|-Module      : PostgREST.DbRequestBuilder-Description : PostgREST database request builder--This module is in charge of building an intermediate representation(ReadRequest, MutateRequest) between the HTTP request and the final resulting SQL query.--A query tree is built in case of resource embedding. By inferring the relationship between tables, join conditions are added for every embedded resource.--}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE LambdaCase            #-}-{-# LANGUAGE NamedFieldPuns        #-}--module PostgREST.DbRequestBuilder (-  readRequest-, mutateRequest-, returningCols-) where--import qualified Data.HashMap.Strict as M-import qualified Data.Set            as S--import Control.Arrow           ((***))-import Data.Either.Combinators (mapLeft)-import Data.Foldable           (foldr1)-import Data.List               (delete)-import Data.Text               (isInfixOf)--import Control.Applicative-import Data.Tree-import Network.Wai--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 :: Schema -> TableName -> Maybe Integer -> [Relation] -> ApiRequest -> Either Response ReadRequest-readRequest schema rootTableName maxRows allRels apiRequest  =-  mapLeft errorResponseFor $-  treeRestrictRange maxRows =<<-  augmentRequestWithJoin schema rootRels =<<-  addFiltersOrdersRanges apiRequest <*>-  (initReadRequest rootName <$> pRequestSelect sel)-  where-    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)---- 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---- 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 <$> request-  where-    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode-    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)--augmentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest-augmentRequestWithJoin schema allRels request =-  addRels schema allRels Nothing request-  >>= addJoinConditions Nothing--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=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 = findRel schema allRels (qiName parentNodeQi) nodeName hint-      in-      Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest)-    _ ->-      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 (addRels schema allRels rq) forest---- 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 &&-        (-          -- /projects?select=clients(*)-          origin == tableName relTable  &&  -- projects-          target == tableName relFTable ||  -- clients--          -- /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--          -- /projects?select=clients!projects_client_id_fkey(*)-          hint == relConstraint             || -- projects_client_id_fkey--          -- /projects?select=clients!client_id(*) or /projects?select=clients!id(*)-          matchFKSingleCol hint relColumns  || -- client_id-          matchFKSingleCol hint relFColumns || -- id--          -- /users?select=tasks!users_tasks(*)-          (-            relType == M2M &&                              -- many-to-many between users and tasks-            hint == (tableName . junTable <$> relJunction) -- users_tasks-          )-        )-      ) allRels---- previousAlias is only used for the case of self joins-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 isSelfReference <$> rel of-      Just True-        | depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased-        | otherwise  -> Nothing-      _              -> Nothing-    augmentQuery r =-      foldr-        (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs})-        query{fromAlias=newAlias}-        (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 jun) =-  case typ of-    O2M ->-        zipWith (toJoinCondition tN ftN) cols fCols-    M2O ->-        zipWith (toJoinCondition tN ftN) cols fCols-    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 = 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,-    flip (foldr addOrder) <$> orders,-    flip (foldr addRange) <$> ranges,-    flip (foldr addLogicTree) <$> logicForest-  ]-  {--  The esence of what is going on above is that we are composing tree functions-  of type (ReadRequest->ReadRequest) that are in (Either ApiRequestError a) context-  -}-  where-    filters :: Either ApiRequestError [(EmbedPath, Filter)]-    filters = mapM pRequestFilter flts-    logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)]-    logicForest = mapM pRequestLogicTree logFrst-    action = iAction apiRequest-    -- there can be no filters on the root table when we are doing insert/update/delete-    (flts, logFrst) =-      case action of-        ActionInvoke _ -> (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-    ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]-    ranges = mapM pRequestRange $ M.toList $ iRange apiRequest--addFilterToNode :: Filter -> ReadRequest -> ReadRequest-addFilterToNode flt (Node (q@Select {where_=lf}, i) f) = Node (q{where_=addFilterToLogicForest flt lf}::ReadQuery, i) f--addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest-addFilter = addProperty addFilterToNode--addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest-addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f--addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest-addOrder = addProperty addOrderToNode--addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest-addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f--addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest-addRange = addProperty addRangeToNode--addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest-addLogicTreeToNode t (Node (q@Select{where_=lf},i) f) = Node (q{where_=t:lf}::ReadQuery, i) f--addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest-addLogicTree = addProperty addLogicTreeToNode--addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest-addProperty f ([], a) rr = f a rr-addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =-  case pathNode of-    Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path-    Just tn -> Node rn (addProperty f (remainingPath, a) tn:delete tn forest)-  where-    pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest--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 -> 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) &&-           S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols &&-           not (null (S.fromList pkCols)) &&-           all (\case-              Filter _ (OpExpr False (Op "eq" _)) -> True-              _ -> False) flts-          then Insert qi cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings-        else-          Left InvalidFilters) =<< filters-    ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings-    _            -> Left UnsupportedVerb-  where-    qi = QualifiedIdentifier schema tName-    action = iAction apiRequest-    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-    -- update/delete filters can be only on the root table-    (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest)-    onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)--returningCols :: ReadRequest -> [FieldName]-returningCols rr@(Node _ forest) = returnings-  where-    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-addFilterToLogicForest :: Filter -> [LogicTree] -> [LogicTree]-addFilterToLogicForest flt lf = Stmnt flt : lf
src/PostgREST/DbStructure.hs view
@@ -8,64 +8,118 @@  These queries are executed once at startup or when PostgREST is reloaded. -}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeSynonymInstances  #-}-module PostgREST.DbStructure (-  getDbStructure-, accessibleTables-, accessibleProcs-, schemaDescription-, getPgVersion-) where +module PostgREST.DbStructure+  ( DbStructure(..)+  , queryDbStructure+  , accessibleTables+  , accessibleProcs+  , schemaDescription+  , tableCols+  , tablePKCols+  ) where++import qualified Data.Aeson          as JSON import qualified Data.HashMap.Strict as M import qualified Data.List           as L-import qualified Data.Text           as T import qualified Hasql.Decoders      as HD import qualified Hasql.Encoders      as HE-import qualified Hasql.Session       as H import qualified Hasql.Statement     as H import qualified Hasql.Transaction   as HT +import Contravariant.Extras          (contrazip2) import Data.Set                      as S (fromList)-import Data.Text                     (breakOn, dropAround, split,-                                      splitOn, strip)-import GHC.Exts                      (groupWith)-import Protolude                     hiding (toS)-import Protolude.Conv                (toS)-import Protolude.Unsafe              (unsafeHead)-import Text.InterpolatedString.Perl6 (q, qc)+import Data.Text                     (split)+import Text.InterpolatedString.Perl6 (q) -import PostgREST.Private.Common-import PostgREST.Types+import PostgREST.DbStructure.Identifiers  (QualifiedIdentifier (..),+                                           Schema, TableName)+import PostgREST.DbStructure.Proc         (PgArg (..), PgType (..),+                                           ProcDescription (..),+                                           ProcVolatility (..),+                                           ProcsMap, RetType (..))+import PostgREST.DbStructure.Relationship (Cardinality (..),+                                           Junction (..),+                                           PrimaryKey (..),+                                           Relationship (..))+import PostgREST.DbStructure.Table        (Column (..), Table (..)) -getDbStructure :: [Schema] -> PgVersion -> HT.Transaction DbStructure-getDbStructure schemas pgVer = do+import Protolude        hiding (toS)+import Protolude.Conv   (toS)+import Protolude.Unsafe (unsafeHead)+++data DbStructure = DbStructure+  { dbTables        :: [Table]+  , dbColumns       :: [Column]+  , dbRelationships :: [Relationship]+  , dbPrimaryKeys   :: [PrimaryKey]+  , dbProcs         :: ProcsMap+  }+  deriving (Generic, JSON.ToJSON)++-- TODO Table could hold references to all its Columns+tableCols :: DbStructure -> Schema -> TableName -> [Column]+tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs++-- TODO Table could hold references to all its PrimaryKeys+tablePKCols :: DbStructure -> Schema -> TableName -> [Text]+tablePKCols dbs tSchema tName =  pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)++-- | The source table column a view column refers to+type SourceColumn = (Column, ViewColumn)+type ViewColumn = Column++-- | A SQL query that can be executed independently+type SqlQuery = ByteString++queryDbStructure :: [Schema] -> [Schema] -> Bool -> HT.Transaction DbStructure+queryDbStructure schemas extraSearchPath prepared = 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+  tabs    <- HT.statement mempty $ allTables prepared+  cols    <- HT.statement schemas $ allColumns tabs prepared+  srcCols <- HT.statement (schemas, extraSearchPath) $ pfkSourceColumns cols prepared+  m2oRels <- HT.statement mempty $ allM2ORels tabs cols prepared+  keys    <- HT.statement mempty $ allPrimaryKeys tabs prepared+  procs   <- HT.statement schemas $ allProcs prepared -  let rels = addM2MRels . addO2MRels $ addViewM2ORels srcCols m2oRels-      cols' = addForeignKeys rels cols+  let rels = addO2MRels . addM2MRels $ addViewM2ORels srcCols m2oRels       keys' = addViewPrimaryKeys srcCols keys -  return DbStructure {+  return $ removeInternal schemas $ DbStructure {       dbTables = tabs-    , dbColumns = cols'-    , dbRelations = rels+    , dbColumns = cols+    , dbRelationships = rels     , dbPrimaryKeys = keys'     , dbProcs = procs-    , pgVersion = pgVer     } +-- | Remove db objects that belong to an internal schema(not exposed through the API) from the DbStructure.+removeInternal :: [Schema] -> DbStructure -> DbStructure+removeInternal schemas dbStruct =+  DbStructure {+      dbTables        = filter (\x -> tableSchema x `elem` schemas) $ dbTables dbStruct+    , dbColumns       = filter (\x -> tableSchema (colTable x) `elem` schemas) (dbColumns dbStruct)+    , dbRelationships = filter (\x -> tableSchema (relTable x) `elem` schemas &&+                                      tableSchema (relForeignTable x) `elem` schemas &&+                                      not (hasInternalJunction x)) $ dbRelationships dbStruct+    , dbPrimaryKeys   = filter (\x -> tableSchema (pkTable x) `elem` schemas) $ dbPrimaryKeys dbStruct+    , dbProcs         = dbProcs dbStruct -- procs are only obtained from the exposed schemas, no need to filter them.+    }+  where+    hasInternalJunction rel = case relCardinality rel of+      M2M Junction{junTable} -> tableSchema junTable `notElem` schemas+      _                      -> False+ decodeTables :: HD.Result [Table] decodeTables =   HD.rowList tblRow@@ -74,23 +128,26 @@                  <*> column HD.text                  <*> nullableColumn HD.text                  <*> column HD.bool+                 <*> column HD.bool+                 <*> column HD.bool  decodeColumns :: [Table] -> HD.Result [Column] decodeColumns tables =   mapMaybe (columnFromRow tables) <$> HD.rowList colRow  where   colRow =-    (,,,,,,,,,,,)-      <$> column HD.text <*> column HD.text-      <*> column HD.text <*> nullableColumn HD.text-      <*> column HD.int4 <*> column HD.bool-      <*> column HD.text <*> column HD.bool-      <*> nullableColumn HD.int4+    (,,,,,,,,)+      <$> column HD.text+      <*> column HD.text+      <*> column HD.text+      <*> nullableColumn HD.text+      <*> column HD.bool+      <*> column HD.text       <*> nullableColumn HD.int4       <*> nullableColumn HD.text       <*> nullableColumn HD.text -decodeRels :: [Table] -> [Column] -> HD.Result [Relation]+decodeRels :: [Table] -> [Column] -> HD.Result [Relationship] decodeRels tables cols =   mapMaybe (relFromRow tables cols) <$> HD.rowList relRow  where@@ -98,10 +155,10 @@     <$> column HD.text     <*> column HD.text     <*> column HD.text-    <*> column (HD.array (HD.dimension replicateM (element HD.text)))+    <*> arrayColumn HD.text     <*> column HD.text     <*> column HD.text-    <*> column (HD.array (HD.dimension replicateM (element HD.text)))+    <*> arrayColumn HD.text  decodePks :: [Table] -> HD.Result [PrimaryKey] decodePks tables =@@ -134,81 +191,118 @@               <$> column HD.text               <*> column HD.text               <*> nullableColumn HD.text-              <*> (parseArgs <$> column HD.text)+              <*> compositeArrayColumn+                  (PgArg+                  <$> compositeField HD.text+                  <*> compositeField HD.text+                  <*> compositeField HD.bool+                  <*> compositeField HD.bool)               <*> (parseRetType                   <$> column HD.text                   <*> column HD.text                   <*> column HD.bool-                  <*> column HD.char)+                  <*> column HD.bool)               <*> (parseVolatility <$> column HD.char)+              <*> column HD.bool      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 (==',')--    parseArg :: Text -> Maybe PgArg-    parseArg a =-      let arg = lastDef "" $ splitOn "INOUT " a-          (body, def) = breakOn " DEFAULT " arg-          (name, typ) = breakOn " " body in-      if T.null typ-         then Nothing-         else Just $-           PgArg (dropAround (== '"') name) (strip typ) (T.null def)--    parseRetType :: Text -> Text -> Bool -> Char -> RetType-    parseRetType schema name isSetOf typ+    parseRetType :: Text -> Text -> Bool -> Bool -> RetType+    parseRetType schema name isSetOf isComposite       | isSetOf   = SetOf pgType       | otherwise = Single pgType       where         qi = QualifiedIdentifier schema name-        pgType = case typ of-          'c' -> Composite qi-          'p' -> if name == "record" -- Only pg pseudo type that is a row type is 'record'-                   then Composite qi-                   else Scalar qi-          _   -> Scalar qi -- 'b'ase, 'd'omain, 'e'num, 'r'ange+        pgType+          | isComposite = Composite qi+          | otherwise   = Scalar      parseVolatility :: Char -> ProcVolatility     parseVolatility v | v == 'i' = Immutable                       | v == 's' = Stable                       | otherwise = Volatile -- only 'v' can happen here -allProcs :: H.Statement [Schema] ProcsMap-allProcs = H.Statement (toS sql) (arrayParam HE.text) decodeProcs True+allProcs :: Bool -> H.Statement [Schema] ProcsMap+allProcs = H.Statement (toS sql) (arrayParam HE.text) decodeProcs   where     sql = procsSqlQuery <> " WHERE pn.nspname = ANY($1)" -accessibleProcs :: H.Statement Schema ProcsMap-accessibleProcs = H.Statement (toS sql) (param HE.text) decodeProcs True+accessibleProcs :: Bool -> H.Statement Schema ProcsMap+accessibleProcs = H.Statement (toS sql) (param HE.text) decodeProcs   where     sql = procsSqlQuery <> " WHERE pn.nspname = $1 AND has_function_privilege(p.oid, 'execute')"  procsSqlQuery :: SqlQuery procsSqlQuery = [q|+ -- Recursively get the base types of domains+  WITH+  base_types AS (+    WITH RECURSIVE+    recurse AS (+      SELECT+        oid,+        typbasetype,+        COALESCE(NULLIF(typbasetype, 0), oid) AS base+      FROM pg_type+      UNION+      SELECT+        t.oid,+        b.typbasetype,+        COALESCE(NULLIF(b.typbasetype, 0), b.oid) AS base+      FROM recurse t+      JOIN pg_type b ON t.typbasetype = b.oid+    )+    SELECT+      oid,+      base+    FROM recurse+    WHERE typbasetype = 0+  ),+  arguments AS (+    SELECT+      oid,+      array_agg((+        COALESCE(name, ''), -- name+        type::regtype::text, -- type+        idx <= (pronargs - pronargdefaults), -- is_required+        COALESCE(mode = 'v', FALSE) -- is_variadic+      ) ORDER BY idx) AS args+    FROM pg_proc,+         unnest(proargnames, proargtypes, proargmodes)+           WITH ORDINALITY AS _ (name, type, mode, idx)+    WHERE type IS NOT NULL -- only input arguments+    GROUP BY oid+  )   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+    pn.nspname AS proc_schema,+    p.proname AS proc_name,+    d.description AS proc_description,+    COALESCE(a.args, '{}') AS args,+    tn.nspname AS schema,+    COALESCE(comp.relname, t.typname) AS name,+    p.proretset AS rettype_is_setof,+    (t.typtype = 'c'+     -- Only pg pseudo type that is a row type is 'record'+     or t.typtype = 'p' and t.typname = 'record'+     -- if any INOUT or OUT arguments present, treat as composite+     or COALESCE(proargmodes::text[] && '{b,o}', false)+    ) AS rettype_is_composite,+    p.provolatile,+    p.provariadic > 0 as hasvariadic   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+  LEFT JOIN arguments a ON a.oid = p.oid+  JOIN pg_namespace pn ON pn.oid = p.pronamespace+  JOIN base_types bt ON bt.oid = p.prorettype+  JOIN pg_type t ON t.oid = bt.base+  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 |] -schemaDescription :: H.Statement Schema (Maybe Text)+schemaDescription :: Bool -> H.Statement Schema (Maybe Text) schemaDescription =-    H.Statement sql (param HE.text) (join <$> HD.rowMaybe (nullableColumn HD.text)) True+    H.Statement sql (param HE.text) (join <$> HD.rowMaybe (nullableColumn HD.text))   where     sql = [q|       select@@ -219,9 +313,9 @@       where         n.nspname = $1 |] -accessibleTables :: H.Statement Schema [Table]+accessibleTables :: Bool -> H.Statement Schema [Table] accessibleTables =-  H.Statement sql (param HE.text) decodeTables True+  H.Statement sql (param HE.text) decodeTables  where   sql = [q|     select@@ -229,22 +323,40 @@       relname as table_name,       d.description as table_description,       (-        c.relkind in ('r', 'v', 'f')-        and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8-        -- The function `pg_relation_is_updateable` returns a bitmask where 8-        -- corresponds to `1 << CMD_INSERT` in the PostgreSQL source code, i.e.-        -- it's possible to insert into the relation.-        or (exists (-          select 1-          from pg_trigger-          where+        c.relkind IN ('r', 'v','f')+        AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8+        OR EXISTS (+          SELECT 1+          FROM pg_trigger+          WHERE             pg_trigger.tgrelid = c.oid-            and (pg_trigger.tgtype::integer & 69) = 69)-            -- The trigger type `tgtype` is a bitmask where 69 corresponds to-            -- TRIGGER_TYPE_ROW + TRIGGER_TYPE_INSTEAD + TRIGGER_TYPE_INSERT-            -- in the PostgreSQL source code.+            AND (pg_trigger.tgtype::integer & 69) = 69         )-      ) as insertable+      ) AS insertable,+      (+        c.relkind IN ('r', 'v','f')+        AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 4) = 4+        -- CMD_UPDATE+        OR EXISTS (+          SELECT 1+          FROM pg_trigger+          WHERE+            pg_trigger.tgrelid = c.oid+            and (pg_trigger.tgtype::integer & 81) = 81+        )+      ) as updatable,+      (+        c.relkind IN ('r', 'v','f')+        AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 16) = 16+        -- CMD_DELETE+        OR EXISTS (+          SELECT 1+          FROM pg_trigger+          WHERE+            pg_trigger.tgrelid = c.oid+            and (pg_trigger.tgtype::integer & 73) = 73+        )+      ) as deletable     from       pg_class c       join pg_namespace n on n.oid = c.relnamespace@@ -259,26 +371,14 @@       )     order by relname |] -addForeignKeys :: [Relation] -> [Column] -> [Column]-addForeignKeys rels = map addFk-  where-    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==M2O-    relToFk col Relation{relColumns=cols, relFColumns=colsF} = do-      pos <- L.elemIndex col cols-      colF <- atMay colsF pos-      return $ ForeignKey colF- {--Adds Views M2O Relations based on SourceColumns found, the logic is as follows:+Adds Views M2O Relationships based on SourceColumns found, the logic is as follows: -Having a Relation{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relType=M2O} represented by:+Having a Relationship{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relCardinality=M2O} represented by:  t1.c1------t2.c2 -When only having a t1_view.c1 source column, we need to add a View-Table M2O Relation+When only having a t1_view.c1 source column, we need to add a View-Table M2O Relationship           t1.c1----t2.c2         t1.c1----------t2.c2                          ->            ________/@@ -286,88 +386,71 @@       t1_view.c1             t1_view.c1  -When only having a t2_view.c2 source column, we need to add a Table-View M2O Relation+When only having a t2_view.c2 source column, we need to add a Table-View M2O Relationship           t1.c1----t2.c2               t1.c1----------t2.c2                                ->          \________                                                     \                     t2_view.c2                      t2_view.c1 -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+When having t1_view.c1 and a t2_view.c2 source columns, we need to add a View-View M2O Relationship 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 source columns.+The logic for composite pks is similar just need to make sure all the Relationship columns have source columns. -}-addViewM2ORels :: [SourceColumn] -> [Relation] -> [Relation]-addViewM2ORels allSrcCols = concatMap (\rel ->-  rel : case rel of-    Relation{relType=M2O, relTable, relColumns, relConstraint, relFTable, relFColumns} ->--      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-          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 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--          viewTableM2O =-            [ Relation (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)-                       relConstraint relFTable relFColumns-                       M2O Nothing-            | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns ]+addViewM2ORels :: [SourceColumn] -> [Relationship] -> [Relationship]+addViewM2ORels allSrcCols = concatMap (\rel@Relationship{..} -> rel :+  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 relForeignColumns+    getView :: [SourceColumn] -> Table+    getView = colTable . snd . unsafeHead+    srcCols `allSrcColsOf` cols = S.fromList (fst <$> srcCols) == S.fromList cols+    -- Relationship 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 SourceColumns to match the relColumns+    -- TODO: This could be avoided if the Relationship 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 -          tableViewM2O =-            [ Relation relTable relColumns-                       relConstraint-                       (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns)-                       M2O Nothing-            | fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relFColumns ]+    viewTableM2O =+      [ Relationship+          (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)+          relForeignTable relForeignColumns relCardinality+      | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns ] -          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 ]+    tableViewM2O =+      [ Relationship+          relTable relColumns+          (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relForeignColumns)+          relCardinality+      | fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relForeignColumns ] -      in viewTableM2O ++ tableViewM2O ++ viewViewM2O+    viewViewM2O =+      [ Relationship+          (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)+          (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relForeignColumns)+          relCardinality+      | srcCols  <- relSrcCols, srcCols `allSrcColsOf` relColumns+      , fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relForeignColumns ] -    _ -> [])+  in viewTableM2O ++ tableViewM2O ++ viewViewM2O) -addO2MRels :: [Relation] -> [Relation]-addO2MRels = concatMap (\rel@(Relation t c cn ft fc _ _) -> [rel, Relation ft fc cn t c O2M Nothing])+addO2MRels :: [Relationship] -> [Relationship]+addO2MRels rels = rels ++ [ Relationship ft fc t c (O2M cons)+                          | Relationship t c ft fc (M2O cons) <- rels ] -addM2MRels :: [Relation] -> [Relation]-addM2MRels rels = rels ++ addMirrorRel (mapMaybe junction2Rel junctions)-  where-    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-    combinations :: Int -> [a] -> [[a]]-    combinations 0 _  = [ [] ]-    combinations n xs = [ y:ys | y:xs' <- tails xs-                               , ys <- combinations (n-1) xs']-    junction2Rel [-      Relation{relTable=jt, relColumns=jc1, relConstraint=const1, relFTable=t,  relFColumns=c},-      Relation{             relColumns=jc2, relConstraint=const2, relFTable=ft, relFColumns=fc}-      ]-      | 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-    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))])+addM2MRels :: [Relationship] -> [Relationship]+addM2MRels rels = rels ++ [ Relationship t c ft fc (M2M $ Junction jt1 cons1 jc1 cons2 jc2)+                          | Relationship jt1 jc1 t c (M2O cons1) <- rels+                          , Relationship jt2 jc2 ft fc (M2O cons2) <- rels+                          , jt1 == jt2+                          , cons1 /= cons2]  addViewPrimaryKeys :: [SourceColumn] -> [PrimaryKey] -> [PrimaryKey] addViewPrimaryKeys srcCols = concatMap (\pk ->@@ -375,36 +458,77 @@                 filter (\(col, _) -> colTable col == pkTable pk && colName col == pkName pk) srcCols in   pk : viewPks) -allTables :: H.Statement () [Table]+allTables :: Bool -> H.Statement () [Table] allTables =-  H.Statement sql HE.noParams decodeTables True+  H.Statement sql HE.noParams decodeTables  where   sql = [q|     SELECT       n.nspname AS table_schema,       c.relname AS table_name,-      NULL AS table_description,+      d.description AS table_description,       (-        c.relkind IN ('r', 'v','f')-        AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8-        OR EXISTS (-          SELECT 1-          FROM pg_trigger-          WHERE-            pg_trigger.tgrelid = c.oid+        c.relkind = 'r'+        OR (+          c.relkind in ('v','f')+          AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8+          -- The function `pg_relation_is_updateable` returns a bitmask where 8+          -- corresponds to `1 << CMD_INSERT` in the PostgreSQL source code, i.e.+          -- it's possible to insert into the relation.+          OR EXISTS (+            SELECT 1+            FROM pg_trigger+            WHERE+              pg_trigger.tgrelid = c.oid             AND (pg_trigger.tgtype::integer & 69) = 69+            -- The trigger type `tgtype` is a bitmask where 69 corresponds to+            -- TRIGGER_TYPE_ROW + TRIGGER_TYPE_INSTEAD + TRIGGER_TYPE_INSERT+            -- in the PostgreSQL source code.+          )         )-      ) AS insertable+      ) AS insertable,+      (+        c.relkind = 'r'+        OR (+          c.relkind in ('v','f')+          AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 4) = 4+          -- CMD_UPDATE+          OR EXISTS (+            SELECT 1+            FROM pg_trigger+            WHERE+              pg_trigger.tgrelid = c.oid+              and (pg_trigger.tgtype::integer & 81) = 81+              -- TRIGGER_TYPE_ROW + TRIGGER_TYPE_INSTEAD + TRIGGER_TYPE_UPDATE+          )+        )+      ) AS updatable,+      (+        c.relkind = 'r'+        OR (+          c.relkind in ('v','f')+          AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 16) = 16+          -- CMD_DELETE+          OR EXISTS (+            SELECT 1+            FROM pg_trigger+            WHERE+              pg_trigger.tgrelid = c.oid+              and (pg_trigger.tgtype::integer & 73) = 73+              -- TRIGGER_TYPE_ROW + TRIGGER_TYPE_INSTEAD + TRIGGER_TYPE_DELETE+          )+        )+      ) AS deletable     FROM pg_class c     JOIN pg_namespace n ON n.oid = c.relnamespace+    LEFT JOIN pg_catalog.pg_description as d on d.objoid = c.oid and d.objsubid = 0     WHERE c.relkind IN ('v','r','m','f')       AND n.nspname NOT IN ('pg_catalog', 'information_schema')-    GROUP BY table_schema, table_name, insertable     ORDER BY table_schema, table_name |] -allColumns :: [Table] -> H.Statement [Schema] [Column]+allColumns :: [Table] -> Bool -> H.Statement [Schema] [Column] allColumns tabs =- H.Statement sql (arrayParam HE.text) (decodeColumns tabs) True+ H.Statement sql (arrayParam HE.text) (decodeColumns tabs)  where   sql = [q|     SELECT DISTINCT@@ -412,14 +536,12 @@         info.table_name AS table_name,         info.column_name AS name,         info.description AS description,-        info.ordinal_position AS position,         info.is_nullable::boolean AS nullable,         info.data_type AS col_type,-        info.is_updatable::boolean AS updatable,         info.character_maximum_length AS max_len,-        info.numeric_precision AS precision,         info.column_default AS default_value,-        array_to_string(enum_info.vals, ',') AS enum+        array_to_string(enum_info.vals, ',') AS enum,+        info.position     FROM (         -- CTE based on pg_catalog to get PRIMARY/FOREIGN key and UNIQUE columns outside api schema         WITH key_columns AS (@@ -454,7 +576,6 @@                 c.relname::name AS table_name,                 a.attname::name AS column_name,                 d.description AS description,-                a.attnum::integer AS ordinal_position,                 pg_get_expr(ad.adbin, ad.adrelid)::text AS column_default,                 not (a.attnotnull OR t.typtype = 'd' AND t.typnotnull) AS is_nullable,                     CASE@@ -475,15 +596,8 @@                     information_schema._pg_truetypid(a.*, t.*),                     information_schema._pg_truetypmod(a.*, t.*)                 )::integer AS character_maximum_length,-                information_schema._pg_numeric_precision(-                    information_schema._pg_truetypid(a.*, t.*),-                    information_schema._pg_truetypmod(a.*, t.*)-                )::integer AS numeric_precision,                 COALESCE(bt.typname, t.typname)::name AS udt_name,-                (-                    c.relkind in ('r', 'v', 'f')-                    AND pg_column_is_updatable(c.oid::regclass, a.attnum, false)-                )::bool is_updatable+                a.attnum::integer AS position             FROM pg_attribute a                 LEFT JOIN key_columns kc                     ON kc.conkey = a.attnum AND kc.c_oid = a.attrelid@@ -512,14 +626,12 @@             table_name,             column_name,             description,-            ordinal_position,             is_nullable,             data_type,-            is_updatable,             character_maximum_length,-            numeric_precision,             column_default,-            udt_name+            udt_name,+            position         FROM columns         WHERE table_schema NOT IN ('pg_catalog', 'information_schema')     ) AS info@@ -537,20 +649,19 @@  columnFromRow :: [Table] ->                  (Text,        Text,        Text,-                  Maybe Text,  Int32,       Bool,-                  Text,        Bool,        Maybe Int32,+                  Maybe Text,  Bool,        Text,                   Maybe Int32, Maybe Text,  Maybe Text)                  -> Maybe Column-columnFromRow tabs (s, t, n, desc, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table+columnFromRow tabs (s, t, n, desc, nul, typ, l, d, e) = buildColumn <$> table   where-    buildColumn tbl = Column tbl n desc pos nul typ u l p d (parseEnum e) Nothing+    buildColumn tbl = Column tbl n desc nul typ l d (parseEnum e)     table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs     parseEnum :: Maybe Text -> [Text]     parseEnum = maybe [] (split (==',')) -allM2ORels :: [Table] -> [Column] -> H.Statement () [Relation]+allM2ORels :: [Table] -> [Column] -> Bool -> H.Statement () [Relationship] allM2ORels tabs cols =-  H.Statement sql HE.noParams (decodeRels tabs cols) True+  H.Statement sql HE.noParams (decodeRels tabs cols)  where   sql = [q|     SELECT ns1.nspname AS table_schema,@@ -575,9 +686,9 @@     WHERE confrelid != 0     ORDER BY (conrelid, column_info.nums) |] -relFromRow :: [Table] -> [Column] -> (Text, Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation+relFromRow :: [Table] -> [Column] -> (Text, Text, Text, [Text], Text, Text, [Text]) -> Maybe Relationship relFromRow allTabs allCols (rs, rt, cn, rcs, frs, frt, frcs) =-  Relation <$> table <*> cols <*> pure (Just cn) <*> tableF <*> colsF <*> pure M2O <*> pure Nothing+  Relationship <$> table <*> cols <*> tableF <*> colsF <*> pure (M2O cn)   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@@ -586,9 +697,9 @@     cols  = mapM (findCol rs rt) rcs     colsF = mapM (findCol frs frt) frcs -allPrimaryKeys :: [Table] -> H.Statement () [PrimaryKey]+allPrimaryKeys :: [Table] -> Bool -> H.Statement () [PrimaryKey] allPrimaryKeys tabs =-  H.Statement sql HE.noParams (decodePks tabs) True+  H.Statement sql HE.noParams (decodePks tabs)  where   sql = [q|     -- CTE to replace information_schema.table_constraints to remove owner limit@@ -666,77 +777,181 @@ pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n   where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs -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+-- returns all the primary and foreign key columns which are referenced in views+pfkSourceColumns :: [Column] -> Bool -> H.Statement ([Schema], [Schema]) [SourceColumn]+pfkSourceColumns cols =+  H.Statement sql (contrazip2 (arrayParam HE.text) (arrayParam HE.text)) (decodeSourceColumns cols)+  -- query explanation at:+  --  * rationale: https://gist.github.com/wolfgangwalther/5425d64e7b0d20aad71f6f68474d9f19+  --  * json transformation: https://gist.github.com/wolfgangwalther/3a8939da680c24ad767e93ad2c183089   where-    subselectRegex :: Text-    -- "result" appears when the subselect is used inside "case when", see `authors_have_book_in_decade` fixture-    -- "resno"  appears in every other case-    -- when copying the query into pg make sure you omit one backslash from \\d+, it should be like `\d+` for the regex-    subselectRegex | pgVer < pgVersion100 = ":subselect {.*?:constraintDeps <>} :location \\d+} :res(no|ult)"-                   | otherwise = ":subselect {.*?:stmt_len 0} :location \\d+} :res(no|ult)"-    sql = [qc|-      with+    sql = [q|+      with recursive+      pks_fks as (+        -- pk + fk referencing col+        select+          conrelid as resorigtbl,+          unnest(conkey) as resorigcol+        from pg_constraint+        where contype IN ('p', 'f')+        union+        -- fk referenced col+        select+          confrelid,+          unnest(confkey)+        from pg_constraint+        where contype='f'+      ),       views as (         select+          c.oid       as view_id,           n.nspname   as view_schema,           c.relname   as view_name,           r.ev_action as view_definition         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 = ANY ($1)+        where c.relkind in ('v', 'm') and n.nspname = ANY($1 || $2)       ),-      removed_subselects as(+      transform_json as (         select-          view_schema, view_name,-          regexp_replace(view_definition, '{subselectRegex}', '', 'g') as x+          view_id, view_schema, view_name,+          -- the following formatting is without indentation on purpose+          -- to allow simple diffs, with less whitespace noise+          replace(+            replace(+            replace(+            replace(+            replace(+            replace(+            replace(+            replace(+            regexp_replace(+            replace(+            replace(+            replace(+            replace(+            replace(+            replace(+            replace(+            replace(+            replace(+            replace(+              view_definition::text,+            -- This conversion to json is heavily optimized for performance.+            -- The general idea is to use as few regexp_replace() calls as possible.+            -- Simple replace() is a lot faster, so we jump through some hoops+            -- to be able to use regexp_replace() only once.+            -- This has been tested against a huge schema with 250+ different views.+            -- The unit tests do NOT reflect all possible inputs. Be careful when changing this!+            -- -----------------------------------------------+            -- pattern           | replacement         | flags+            -- -----------------------------------------------+            -- `,` is not part of the pg_node_tree format, but used in the regex.+            -- This removes all `,` that might be part of column names.+               ','               , ''+            -- The same applies for `{` and `}`, although those are used a lot in pg_node_tree.+            -- We remove the escaped ones, which might be part of column names again.+            ), '\{'              , ''+            ), '\}'              , ''+            -- The fields we need are formatted as json manually to protect them from the regex.+            ), ' :targetList '   , ',"targetList":'+            ), ' :resno '        , ',"resno":'+            ), ' :resorigtbl '   , ',"resorigtbl":'+            ), ' :resorigcol '   , ',"resorigcol":'+            -- Make the regex also match the node type, e.g. `{QUERY ...`, to remove it in one pass.+            ), '{'               , '{ :'+            -- Protect node lists, which start with `({` or `((` from the greedy regex.+            -- The extra `{` is removed again later.+            ), '(('              , '{(('+            ), '({'              , '{({'+            -- This regex removes all unused fields to avoid the need to format all of them correctly.+            -- This leads to a smaller json result as well.+            -- Removal stops at `,` for used fields (see above) and `}` for the end of the current node.+            -- Nesting can't be parsed correctly with a regex, so we stop at `{` as well and+            -- add an empty key for the followig node.+            ), ' :[^}{,]+'       , ',"":'              , 'g'+            -- For performance, the regex also added those empty keys when hitting a `,` or `}`.+            -- Those are removed next.+            ), ',"":}'           , '}'+            ), ',"":,'           , ','+            -- This reverses the "node list protection" from above.+            ), '{('              , '('+            -- Every key above has been added with a `,` so far. The first key in an object doesn't need it.+            ), '{,'              , '{'+            -- pg_node_tree has `()` around lists, but JSON uses `[]`+            ), '('               , '['+            ), ')'               , ']'+            -- pg_node_tree has ` ` between list items, but JSON uses `,`+            ), ' '             , ','+            -- `<>` in pg_node_tree is the same as `null` in JSON, but due to very poor performance of json_typeof+            -- we need to make this an empty array here to prevent json_array_elements from throwing an error+            -- when the targetList is null.+            ), '<>'              , '[]'+          )::json as view_definition         from views       ),-      target_lists as(-        select-          view_schema, view_name,-          regexp_split_to_array(x, 'targetList') as x-        from removed_subselects-      ),-      last_target_list_wo_tail as(-        select-          view_schema, view_name,-          (regexp_split_to_array(x[array_upper(x, 1)], ':onConflict'))[1] as x-        from target_lists-      ),       target_entries as(         select-          view_schema, view_name,-          unnest(regexp_split_to_array(x, 'TARGETENTRY')) as entry-        from last_target_list_wo_tail+          view_id, view_schema, view_name,+          json_array_elements(view_definition->0->'targetList') as entry+        from transform_json       ),       results as(         select-          view_schema, view_name,-          substring(entry from ':resname (.*?) :') as view_colum_name,-          substring(entry from ':resorigtbl (.*?) :') as resorigtbl,-          substring(entry from ':resorigcol (.*?) :') as resorigcol+          view_id, view_schema, view_name,+          (entry->>'resno')::int as view_column,+          (entry->>'resorigtbl')::oid as resorigtbl,+          (entry->>'resorigcol')::int as resorigcol         from target_entries+      ),+      recursion as(+        select r.*+        from results r+        where view_schema = ANY ($1)+        union all+        select+          view.view_id,+          view.view_schema,+          view.view_name,+          view.view_column,+          tab.resorigtbl,+          tab.resorigcol+        from recursion view+        join results tab on view.resorigtbl=tab.view_id and view.resorigcol=tab.view_column       )       select         sch.nspname as table_schema,         tbl.relname as table_name,         col.attname as table_column_name,-        res.view_schema,-        res.view_name,-        res.view_colum_name-      from results res-      join pg_class tbl on tbl.oid::text = res.resorigtbl-      join pg_attribute col on col.attrelid = tbl.oid and col.attnum::text = res.resorigcol+        rec.view_schema,+        rec.view_name,+        vcol.attname as view_column_name+      from recursion rec+      join pg_class tbl on tbl.oid = rec.resorigtbl+      join pg_attribute col on col.attrelid = tbl.oid and col.attnum = rec.resorigcol+      join pg_attribute vcol on vcol.attrelid = rec.view_id and vcol.attnum = rec.view_column       join pg_namespace sch on sch.oid = tbl.relnamespace-      where resorigtbl <> '0'-      order by view_schema, view_name, view_colum_name; |]+      join pks_fks using (resorigtbl, resorigcol)+      order by view_schema, view_name, view_column_name; |] -getPgVersion :: H.Session PgVersion-getPgVersion = H.statement () $ H.Statement sql HE.noParams versionRow False-  where-    sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"-    versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text+param :: HE.Value a -> HE.Params a+param = HE.param . HE.nonNullable++arrayParam :: HE.Value a -> HE.Params [a]+arrayParam = param . HE.foldableArray . HE.nonNullable++compositeArrayColumn :: HD.Composite a -> HD.Row [a]+compositeArrayColumn = arrayColumn . HD.composite++compositeField :: HD.Value a -> HD.Composite a+compositeField = HD.field . HD.nonNullable++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++arrayColumn :: HD.Value a -> HD.Row [a]+arrayColumn = column . HD.listArray . HD.nonNullable
+ src/PostgREST/DbStructure/Identifiers.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}++module PostgREST.DbStructure.Identifiers+  ( QualifiedIdentifier(..)+  , Schema+  , TableName+  , FieldName+  , toQi+  ) where++import qualified Data.Aeson as JSON+import qualified Data.Text  as T+import qualified GHC.Show++import Protolude+++-- | Represents a pg identifier with a prepended schema name "schema.table".+-- When qiSchema is "", the schema is defined by the pg search_path.+data QualifiedIdentifier = QualifiedIdentifier+  { qiSchema :: Schema+  , qiName   :: TableName+  }+  deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)++instance Hashable QualifiedIdentifier++instance Show QualifiedIdentifier where+  show (QualifiedIdentifier s i) =+    (if T.null s then mempty else toS s <> ".") <> toS i++-- TODO: Handle a case where the QI comes like this: "my.fav.schema"."my.identifier"+-- Right now it only handles the schema.identifier case+toQi :: Text -> QualifiedIdentifier+toQi txt = case T.drop 1 <$> T.breakOn "." txt of+  (i, "") -> QualifiedIdentifier mempty i+  (s, i)  -> QualifiedIdentifier s i++type Schema = Text+type TableName = Text+type FieldName = Text
+ src/PostgREST/DbStructure/Proc.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}++module PostgREST.DbStructure.Proc+  ( PgArg(..)+  , PgType(..)+  , ProcDescription(..)+  , ProcVolatility(..)+  , ProcsMap+  , RetType(..)+  , procReturnsScalar+  , procReturnsSingle+  , procTableName+  , specifiedProcArgs+  ) where++import qualified Data.Aeson          as JSON+import qualified Data.HashMap.Strict as M+import qualified Data.Set            as S++import PostgREST.DbStructure.Identifiers (FieldName,+                                          QualifiedIdentifier (..),+                                          Schema, TableName)++import Protolude+++data PgArg = PgArg+  { pgaName :: Text+  , pgaType :: Text+  , pgaReq  :: Bool+  , pgaVar  :: Bool+  }+  deriving (Eq, Ord, Generic, JSON.ToJSON)++data PgType+  = Scalar+  | Composite QualifiedIdentifier+  deriving (Eq, Ord, Generic, JSON.ToJSON)++data RetType+  = Single PgType+  | SetOf PgType+  deriving (Eq, Ord, Generic, JSON.ToJSON)++data ProcVolatility+  = Volatile+  | Stable+  | Immutable+  deriving (Eq, Ord, Generic, JSON.ToJSON)++data ProcDescription = ProcDescription+  { pdSchema      :: Schema+  , pdName        :: Text+  , pdDescription :: Maybe Text+  , pdArgs        :: [PgArg]+  , pdReturnType  :: RetType+  , pdVolatility  :: ProcVolatility+  , pdHasVariadic :: Bool+  }+  deriving (Eq, Generic, JSON.ToJSON)++-- Order by least number of args in the case of overloaded functions+instance Ord ProcDescription where+  ProcDescription schema1 name1 des1 args1 rt1 vol1 hasVar1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2 hasVar2+    | 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, hasVar1) `compare` (schema2, name2, des2, args2, rt2, vol2, hasVar2)++-- | 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 the procedure parameters by matching them with the specified keys.+  If the key doesn't match a parameter, a parameter with a default type "text" is assumed.+-}+specifiedProcArgs :: S.Set FieldName -> ProcDescription -> [PgArg]+specifiedProcArgs keys proc =+  (\k -> fromMaybe (PgArg k "text" True False) (find ((==) k . pgaName) (pdArgs proc))) <$> S.toList keys++procReturnsScalar :: ProcDescription -> Bool+procReturnsScalar proc = case proc of+  ProcDescription{pdReturnType = (Single Scalar)} -> True+  ProcDescription{pdReturnType = (SetOf Scalar)}  -> True+  _                                               -> False++procReturnsSingle :: ProcDescription -> Bool+procReturnsSingle proc = case proc of+  ProcDescription{pdReturnType = (Single _)} -> 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
+ src/PostgREST/DbStructure/Relationship.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}++module PostgREST.DbStructure.Relationship+  ( Cardinality(..)+  , PrimaryKey(..)+  , Relationship(..)+  , Junction(..)+  , isSelfReference+  ) where++import qualified Data.Aeson as JSON++import PostgREST.DbStructure.Table (Column (..), Table (..))++import Protolude+++-- | Relationship between two tables.+--+-- The order of the relColumns and relForeignColumns should be maintained to get the+-- join conditions right.+--+-- TODO merge relColumns and relForeignColumns to a tuple or Data.Bimap+data Relationship = Relationship+  { relTable          :: Table+  , relColumns        :: [Column]+  , relForeignTable   :: Table+  , relForeignColumns :: [Column]+  , relCardinality    :: Cardinality+  }+  deriving (Eq, Generic, JSON.ToJSON)++-- | The relationship cardinality+-- | https://en.wikipedia.org/wiki/Cardinality_(data_modeling)+-- TODO: missing one-to-one+data Cardinality+  = O2M FKConstraint -- ^ one-to-many cardinality+  | M2O FKConstraint -- ^ many-to-one cardinality+  | M2M Junction     -- ^ many-to-many cardinality+  deriving (Eq, Generic, JSON.ToJSON)++type FKConstraint = Text++-- | Junction table on an M2M relationship+data Junction = Junction+  { junTable       :: Table+  , junConstraint1 :: FKConstraint+  , junColumns1    :: [Column]+  , junConstraint2 :: FKConstraint+  , junColumns2    :: [Column]+  }+  deriving (Eq, Generic, JSON.ToJSON)++isSelfReference :: Relationship -> Bool+isSelfReference r = relTable r == relForeignTable r++data PrimaryKey = PrimaryKey+  { pkTable :: Table+  , pkName  :: Text+  }+  deriving (Generic, JSON.ToJSON)
+ src/PostgREST/DbStructure/Table.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric  #-}++module PostgREST.DbStructure.Table+  ( Column(..)+  , Table(..)+  , tableQi+  ) where++import qualified Data.Aeson as JSON++import PostgREST.DbStructure.Identifiers (FieldName,+                                          QualifiedIdentifier (..),+                                          Schema, TableName)++import Protolude+++data Table = Table+  { tableSchema      :: Schema+  , tableName        :: TableName+  , tableDescription :: Maybe Text+    -- The following fields identify what can be done on the table/view, they're not related to the privileges granted to it+  , tableInsertable  :: Bool+  , tableUpdatable   :: Bool+  , tableDeletable   :: Bool+  }+  deriving (Show, Ord, Generic, JSON.ToJSON)++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++data Column = Column+  { colTable       :: Table+  , colName        :: FieldName+  , colDescription :: Maybe Text+  , colNullable    :: Bool+  , colType        :: Text+  , colMaxLen      :: Maybe Int32+  , colDefault     :: Maybe Text+  , colEnum        :: [Text]+  }+  deriving (Ord, Generic, JSON.ToJSON)++instance Eq Column where+  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2++data PrimaryKey = PrimaryKey+  { pkTable :: Table+  , pkName  :: Text+  }+  deriving (Generic, JSON.ToJSON)
src/PostgREST/Error.hs view
@@ -3,17 +3,17 @@ Description : PostgREST error HTTP responses -} {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-} -module PostgREST.Error (-  errorResponseFor-, ApiRequestError(..)-, PgError(..)-, SimpleError(..)-, errorPayload-, checkIsFatal-, singularityError-) where+module PostgREST.Error+  ( errorResponseFor+  , ApiRequestError(..)+  , PgError(..)+  , Error(..)+  , errorPayload+  , checkIsFatal+  , singularityError+  ) where  import qualified Data.Aeson                as JSON import qualified Data.Text                 as T@@ -24,13 +24,22 @@ import Data.Aeson  ((.=)) import Network.Wai (Response, responseLBS) -import Network.HTTP.Types.Header+import Network.HTTP.Types.Header (Header) -import PostgREST.Types-import Protolude       hiding (toS)-import Protolude.Conv  (toS)+import           PostgREST.ContentType (ContentType (..))+import qualified PostgREST.ContentType as ContentType +import PostgREST.DbStructure.Proc         (PgArg (..),+                                           ProcDescription (..))+import PostgREST.DbStructure.Relationship (Cardinality (..),+                                           Junction (..),+                                           Relationship (..))+import PostgREST.DbStructure.Table        (Column (..), Table (..)) +import Protolude      hiding (toS)+import Protolude.Conv (toS, toSL)++ class (JSON.ToJSON a) => PgrstError a where   status   :: a -> HT.Status   headers  :: a -> [Header]@@ -49,26 +58,29 @@   | InvalidBody ByteString   | ParseRequestError Text Text   | NoRelBetween Text Text-  | AmbiguousRelBetween Text Text [Relation]+  | AmbiguousRelBetween Text Text [Relationship]+  | AmbiguousRpc [ProcDescription]+  | NoRpc Text Text [Text] Bool   | InvalidFilters   | UnacceptableSchema [Text]-  | UnknownRelation                -- Unreachable?+  | ContentTypeError [ByteString]   | UnsupportedVerb                -- Unreachable?-  deriving (Show, Eq)  instance PgrstError ApiRequestError where   status InvalidRange            = HT.status416   status InvalidFilters          = HT.status405   status (InvalidBody _)         = HT.status400   status UnsupportedVerb         = HT.status405-  status UnknownRelation         = HT.status404   status ActionInappropriate     = HT.status405   status (ParseRequestError _ _) = HT.status400   status (NoRelBetween _ _)      = HT.status400   status AmbiguousRelBetween{}   = HT.status300+  status (AmbiguousRpc _)        = HT.status300+  status NoRpc{}                 = HT.status404   status (UnacceptableSchema _)  = HT.status406+  status (ContentTypeError _)    = HT.status415 -  headers _ = [toHeader CTApplicationJSON]+  headers _ = [ContentType.toHeader CTApplicationJSON]  instance JSON.ToJSON ApiRequestError where   toJSON (ParseRequestError message details) = JSON.object [@@ -79,41 +91,51 @@     "message" .= (toS errorMessage :: Text)]   toJSON InvalidRange = JSON.object [     "message" .= ("HTTP Range error" :: Text)]-  toJSON UnknownRelation = JSON.object [-    "message" .= ("Unknown relation" :: Text)]   toJSON (NoRelBetween parent child) = JSON.object [-    "message" .= ("Could not find foreign keys between these entities. No relationship found between " <> parent <> " and " <> child :: Text)]+    "hint"    .= ("If a new foreign key between these entities was created in the database, try reloading the schema cache." :: Text),+    "message" .= ("Could not find a relationship between " <> parent <> " and " <> child <> " in the schema cache" :: 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 (AmbiguousRpc procs)  = JSON.object [+    "hint"    .= ("Overloaded functions with the same argument name but different types are not supported" :: Text),+    "message" .= ("Could not choose the best candidate function between: " <> T.intercalate ", " [pdSchema p <> "." <> pdName p <> "(" <> T.intercalate ", " [pgaName a <> " => " <> pgaType a | a <- pdArgs p] <> ")" | p <- procs])]+  toJSON (NoRpc schema procName payloadKeys hasPreferSingleObject)  = JSON.object [+    "hint"    .= ("If a new function was created in the database with this name and arguments, try reloading the schema cache." :: Text),+    "message" .= ("Could not find the " <> schema <> "." <> procName <> (if hasPreferSingleObject then " function with a single json or jsonb argument" else "(" <> T.intercalate ", " payloadKeys <> ")" <> " function") <> " in the schema cache")]   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)]+  toJSON (ContentTypeError cts)    = JSON.object [+    "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)] -compressedRel :: Relation -> JSON.Value-compressedRel rel =+compressedRel :: Relationship -> JSON.Value+compressedRel Relationship{..} =   let-    fmtTbl tbl = tableSchema tbl <> "." <> tableName tbl+    fmtTbl Table{..} = tableSchema <> "." <> tableName     fmtEls els = "[" <> T.intercalate ", " els <> "]"   in   JSON.object $ [-    "origin"      .= fmtTbl (relTable rel)-  , "target"      .= fmtTbl (relFTable rel)-  , "cardinality" .= (show $ relType rel :: Text)+    "origin"      .= fmtTbl relTable+  , "target"      .= fmtTbl relForeignTable   ] ++-  case (relType rel, relJunction rel, relConstraint rel) of-    (M2M, Just (Junction jt (Just const1) _ (Just const2) _), _) -> [-      "relationship" .= (fmtTbl jt <> fmtEls [const1] <> fmtEls [const2])+  case relCardinality of+    M2M Junction{..} -> [+        "cardinality" .= ("m2m" :: Text)+      , "relationship" .= (fmtTbl junTable <> fmtEls [junConstraint1] <> fmtEls [junConstraint2])       ]-    (_, _, Just relCon) -> [-      "relationship" .= (relCon <> fmtEls (colName <$> relColumns rel) <> fmtEls (colName <$> relFColumns rel))+    M2O cons -> [+        "cardinality" .= ("m2o" :: Text)+      , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns))       ]-    (_, _, _) ->-      mempty+    O2M cons -> [+        "cardinality" .= ("o2m" :: Text)+      , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns))+      ]  data PgError = PgError Authenticated P.UsageError type Authenticated = Bool@@ -123,8 +145,8 @@    headers err =     if status err == HT.status401-       then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]-       else [toHeader CTApplicationJSON]+       then [ContentType.toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]+       else [ContentType.toHeader CTApplicationJSON]  instance JSON.ToJSON PgError where   toJSON (PgError _ usageError) = JSON.toJSON usageError@@ -132,8 +154,8 @@ instance JSON.ToJSON P.UsageError where   toJSON (P.ConnectionError e) = JSON.object [     "code"    .= ("" :: Text),-    "message" .= ("Database connection error" :: Text),-    "details" .= (toS $ fromMaybe "" e :: Text)]+    "message" .= ("Database connection error. Retrying the connection." :: Text),+    "details" .= (toSL $ fromMaybe "" e :: Text)]   toJSON (P.SessionError e) = JSON.toJSON e -- H.Error  instance JSON.ToJSON H.QueryError where@@ -169,7 +191,7 @@     "message" .= ("Unexpected amount of rows" :: Text),     "details" .= i]   toJSON (H.ClientError d) = JSON.object [-    "message" .= ("Database client error" :: Text),+    "message" .= ("Database client error. Retrying the connection." :: Text),     "details" .= (fmap toS d :: Maybe Text)]  pgErrorStatus :: Bool -> P.UsageError -> HT.Status@@ -185,6 +207,7 @@         '0':'P':_ -> HT.status403 -- invalid role specification         "23503"   -> HT.status409 -- foreign_key_violation         "23505"   -> HT.status409 -- unique_violation+        "25006"   -> HT.status405 -- read_only_sql_transaction         '2':'5':_ -> HT.status500 -- invalid tx state         '2':'8':_ -> HT.status403 -- invalid auth specification         '2':'D':_ -> HT.status500 -- invalid tx termination@@ -215,12 +238,29 @@   | isAuthFailureMessage = Just $ toS failureMessage   | otherwise = Nothing   where isAuthFailureMessage = "FATAL:  password authentication failed" `isPrefixOf` toS failureMessage-        failureMessage = fromMaybe "" e+        failureMessage = fromMaybe mempty e+checkIsFatal (PgError _ (P.SessionError (H.QueryError _ _ (H.ResultError serverError))))+  = case serverError of+      -- Check for a syntax error (42601 is the pg code). This would mean the error is on our part somehow, so we treat it as fatal.+      H.ServerError "42601" _ _ _+        -> Just "Hint: This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues"+      -- Check for a "prepared statement <name> already exists" error (Code 42P05: duplicate_prepared_statement).+      -- This would mean that a connection pooler in transaction mode is being used+      -- while prepared statements are enabled in the PostgREST configuration,+      -- both of which are incompatible with each other.+      H.ServerError "42P05" _ _ _+        -> Just "Hint: If you are using connection poolers in transaction mode, try setting db-prepared-statements to false."+      -- Check for a "transaction blocks not allowed in statement pooling mode" error (Code 08P01: protocol_violation).+      -- This would mean that a connection pooler in statement mode is being used which is not supported in PostgREST.+      H.ServerError "08P01" "transaction blocks not allowed in statement pooling mode" _ _+        -> Just "Hint: Connection poolers in statement mode are not supported."+      _ -> Nothing checkIsFatal _ = Nothing  -data SimpleError+data Error   = GucHeadersError+  | GucStatusError   | BinaryFieldError ContentType   | ConnectionLostError   | PutMatchingPkError@@ -228,11 +268,13 @@   | JwtTokenMissing   | JwtTokenInvalid Text   | SingularityError Integer-  | ContentTypeError [ByteString]-  deriving (Show, Eq)+  | NotFound+  | ApiRequestError ApiRequestError+  | PgErr PgError -instance PgrstError SimpleError where+instance PgrstError Error where   status GucHeadersError         = HT.status500+  status GucStatusError          = HT.status500   status (BinaryFieldError _)    = HT.status406   status ConnectionLostError     = HT.status503   status PutMatchingPkError      = HT.status400@@ -240,39 +282,46 @@   status JwtTokenMissing         = HT.status500   status (JwtTokenInvalid _)     = HT.unauthorized401   status (SingularityError _)    = HT.status406-  status (ContentTypeError _)    = HT.status415+  status NotFound                = HT.status404+  status (PgErr err)             = status err+  status (ApiRequestError err)   = status err -  headers (SingularityError _)     = [toHeader CTSingularJSON]-  headers (JwtTokenInvalid m)      = [toHeader CTApplicationJSON, invalidTokenHeader m]-  headers _                        = [toHeader CTApplicationJSON]+  headers (SingularityError _)     = [ContentType.toHeader CTSingularJSON]+  headers (JwtTokenInvalid m)      = [ContentType.toHeader CTApplicationJSON, invalidTokenHeader m]+  headers (PgErr err)              = headers err+  headers (ApiRequestError err)    = headers err+  headers _                        = [ContentType.toHeader CTApplicationJSON] -instance JSON.ToJSON SimpleError where+instance JSON.ToJSON Error where   toJSON GucHeadersError           = JSON.object [     "message" .= ("response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)]+  toJSON GucStatusError           = JSON.object [+    "message" .= ("response.status guc must be a valid status code" :: Text)]   toJSON (BinaryFieldError ct)          = JSON.object [-    "message" .= ((toS (toMime ct) <> " requested but more than one column was selected") :: Text)]+    "message" .= ((toS (ContentType.toMime ct) <> " requested but more than one column was selected") :: Text)]   toJSON ConnectionLostError       = JSON.object [-    "message" .= ("Database connection lost, retrying the connection." :: Text)]+    "message" .= ("Database connection lost. Retrying the connection." :: Text)]    toJSON PutRangeNotAllowedError   = JSON.object [     "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)]   toJSON PutMatchingPkError        = JSON.object [     "message" .= ("Payload values do not match URL in primary key column(s)" :: Text)] -  toJSON (ContentTypeError cts)    = JSON.object [-    "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]   toJSON (SingularityError n)      = JSON.object [     "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),-    "details" .= T.unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]+    "details" .= T.unwords ["Results contain", show n, "rows,", toS (ContentType.toMime CTSingularJSON), "requires 1 row"]]    toJSON JwtTokenMissing           = JSON.object [     "message" .= ("Server lacks JWT secret" :: Text)]   toJSON (JwtTokenInvalid message) = JSON.object [     "message" .= (message :: Text)]+  toJSON NotFound = JSON.object []+  toJSON (PgErr err) = JSON.toJSON err+  toJSON (ApiRequestError err) = JSON.toJSON err  invalidTokenHeader :: Text -> Header invalidTokenHeader m =   ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m)) -singularityError :: (Integral a) => a -> SimpleError+singularityError :: (Integral a) => a -> Error singularityError = SingularityError . toInteger
+ src/PostgREST/GucHeader.hs view
@@ -0,0 +1,37 @@+module PostgREST.GucHeader+  ( GucHeader+  , unwrapGucHeader+  , addHeadersIfNotIncluded+  ) where++import qualified Data.Aeson           as JSON+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict  as M++import Network.HTTP.Types.Header (Header)++import Protolude      hiding (toS)+import Protolude.Conv (toS)+++{-|+  Custom guc header, it's obtained by parsing the json in a:+  `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'+-}+newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)++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 (CI.mk $ toS k, toS s)+                            | otherwise     -> mzero+    _ -> mzero+  parseJSON _          = mzero++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
src/PostgREST/Middleware.hs view
@@ -1,71 +1,183 @@ {-| Module      : PostgREST.Middleware-Description : Sets the PostgreSQL GUCs, role, search_path and pre-request function. Validates JWT.+Description : Sets CORS policy. Also the PostgreSQL GUCs, role, search_path and pre-request function. -}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+module PostgREST.Middleware+  ( runPgLocals+  , pgrstFormat+  , pgrstMiddleware+  , defaultCorsPolicy+  , corsPolicy+  , optionalRollback+  ) where -module PostgREST.Middleware where+import qualified Data.Aeson                           as JSON+import qualified Data.ByteString.Char8                as BS+import qualified Data.CaseInsensitive                 as CI+import qualified Data.HashMap.Strict                  as M+import qualified Data.Text                            as T+import qualified Hasql.Decoders                       as HD+import qualified Hasql.DynamicStatements.Snippet      as H hiding+                                                           (sql)+import qualified Hasql.DynamicStatements.Statement    as H+import qualified Hasql.Transaction                    as H+import qualified Network.HTTP.Types.Header            as HTTP+import qualified Network.Wai                          as Wai+import qualified Network.Wai.Logger                   as Wai+import qualified Network.Wai.Middleware.Cors          as Wai+import qualified Network.Wai.Middleware.Gzip          as Wai+import qualified Network.Wai.Middleware.RequestLogger as Wai+import qualified Network.Wai.Middleware.Static        as Wai -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 Data.Function             (id)+import Data.List                 (lookup)+import Data.Scientific           (FPFormat (..), formatScientific,+                                  isInteger)+import Network.HTTP.Types.Status (Status, status400, status500,+                                  statusCode)+import System.IO.Unsafe          (unsafePerformIO)+import System.Log.FastLogger     (toLogStr) -import Network.Wai                   (Application, Response)-import Network.Wai.Middleware.Cors   (cors)-import Network.Wai.Middleware.Gzip   (def, gzip)-import Network.Wai.Middleware.Static (only, staticPolicy)+import PostgREST.Config             (AppConfig (..), LogLevel (..))+import PostgREST.Error              (Error, errorResponseFor)+import PostgREST.GucHeader          (addHeadersIfNotIncluded)+import PostgREST.Query.SqlFragment  (fromQi, intercalateSnippet,+                                     unknownEncoder)+import PostgREST.Request.ApiRequest (ApiRequest (..), Target (..)) -import Crypto.JWT+import PostgREST.Request.Preferences -import PostgREST.ApiRequest   (ApiRequest (..))-import PostgREST.Auth         (JWTAttempt (..))-import PostgREST.Config       (AppConfig (..), corsPolicy)-import PostgREST.Error        (SimpleError (JwtTokenInvalid, JwtTokenMissing),-                               errorResponseFor)-import PostgREST.QueryBuilder (setLocalQuery, setLocalSearchPathQuery)-import Protolude              hiding (head, toS)-import Protolude.Conv         (toS)+import Protolude      hiding (head, toS)+import Protolude.Conv (toS) -runWithClaims :: AppConfig -> JWTAttempt ->-                 (ApiRequest -> H.Transaction Response) ->-                 ApiRequest -> H.Transaction Response-runWithClaims conf eClaims app req =-  case eClaims of-    JWTMissingSecret      -> return . errorResponseFor $ JwtTokenMissing-    JWTInvalid JWTExpired -> return . errorResponseFor . JwtTokenInvalid $ "JWT expired"-    JWTInvalid e          -> return . errorResponseFor . JwtTokenInvalid . show $ e-    JWTClaims claims      -> do-      H.sql $ toS . mconcat $ setSearchPathSql : setRoleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql-      mapM_ H.sql customReqCheck-      app req-      where-        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 ->-          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-        customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf+-- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function+runPgLocals :: AppConfig   -> M.HashMap Text JSON.Value ->+               (ApiRequest -> ExceptT Error H.Transaction Wai.Response) ->+               ApiRequest  -> ByteString -> ExceptT Error H.Transaction Wai.Response+runPgLocals conf claims app req jsonDbS = do+  lift $ H.statement mempty $ H.dynamicallyParameterized+    ("select " <> intercalateSnippet ", " (searchPathSql : roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql ++ specSql))+    HD.noResult (configDbPreparedStatements conf)+  lift $ traverse_ H.sql preReqSql+  app req+  where+    methodSql = setConfigLocal mempty ("request.method", iMethod req)+    pathSql = setConfigLocal mempty ("request.path", iPath req)+    headersSql = setConfigLocal "request.header." <$> iHeaders req+    cookiesSql = setConfigLocal "request.cookie." <$> iCookies req+    claimsWithRole =+      let anon = JSON.String . toS $ configDbAnonRole conf in -- role claim defaults to anon if not specified in jwt+      M.union claims (M.singleton "role" anon)+    claimsSql = setConfigLocal "request.jwt.claim." <$> [(toS c, toS $ unquoted v) | (c,v) <- M.toList claimsWithRole]+    roleSql = maybeToList $ (\x -> setConfigLocal mempty ("role", toS $ unquoted x)) <$> M.lookup "role" claimsWithRole+    appSettingsSql = setConfigLocal mempty <$> (join bimap toS <$> configAppSettings conf)+    searchPathSql =+      let schemas = T.intercalate ", " (iSchema req : configDbExtraSearchPath conf) in+      setConfigLocal mempty ("search_path", toS schemas)+    preReqSql = (\f -> "select " <> fromQi f <> "();") <$> configDbPreRequest conf+    specSql = case iTarget req of+      TargetProc{tpIsRootSpec=True} -> [setConfigLocal mempty ("request.spec", jsonDbS)]+      _                             -> mempty+    -- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.+    setConfigLocal :: ByteString -> (ByteString, ByteString) -> H.Snippet+    setConfigLocal prefix (k, v) =+      "set_config(" <> unknownEncoder (prefix <> k) <> ", " <> unknownEncoder v <> ", true)" -defaultMiddle :: Application -> Application-defaultMiddle =-    gzip def-  . cors corsPolicy-  . staticPolicy (only [("favicon.ico", "static/favicon.ico")])+-- | Log in apache format. Only requests that have a status greater than minStatus are logged.+-- | There's no way to filter logs in the apache format on wai-extra: https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html#t:OutputFormat.+-- | So here we copy wai-logger apacheLogStr function: https://github.com/kazu-yamamoto/logger/blob/a4f51b909a099c51af7a3f75cf16e19a06f9e257/wai-logger/Network/Wai/Logger/Apache.hs#L45+-- | TODO: Add the ability to filter apache logs on wai-extra and remove this function.+pgrstFormat :: Status -> Wai.OutputFormatter+pgrstFormat minStatus date req status responseSize =+  if status < minStatus+    then mempty+  else toLogStr (getSourceFromSocket req)+    <> " - - ["+    <> toLogStr date+    <> "] \""+    <> toLogStr (Wai.requestMethod req)+    <> " "+    <> toLogStr (Wai.rawPathInfo req <> Wai.rawQueryString req)+    <> " "+    <> toLogStr (show (Wai.httpVersion req)::Text)+    <> "\" "+    <> toLogStr (show (statusCode status)::Text)+    <> " "+    <> toLogStr (maybe "-" show responseSize::Text)+    <> " \""+    <> toLogStr (fromMaybe mempty $ Wai.requestHeaderReferer req)+    <> "\" \""+    <> toLogStr (fromMaybe mempty $ Wai.requestHeaderUserAgent req)+    <> "\"\n"+  where+    getSourceFromSocket = BS.pack . Wai.showSockAddr . Wai.remoteHost +pgrstMiddleware :: LogLevel -> Wai.Application -> Wai.Application+pgrstMiddleware logLevel =+    logger+  . Wai.cors corsPolicy+  . Wai.staticPolicy (Wai.only [("favicon.ico", "static/favicon.ico")])+  where+    logger = case logLevel of+      LogCrit  -> id+      LogError -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status500}+      LogWarn  -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400}+      LogInfo  -> Wai.logStdout++defaultCorsPolicy :: Wai.CorsResourcePolicy+defaultCorsPolicy =  Wai.CorsResourcePolicy Nothing+  ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing+  (Just $ 60*60*24) False False True++-- | CORS policy to be used in by Wai Cors middleware+corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy+corsPolicy req = case lookup "origin" headers of+  Just origin -> Just defaultCorsPolicy {+      Wai.corsOrigins = Just ([origin], True)+    , Wai.corsRequestHeaders = "Authentication" : accHeaders+    , Wai.corsExposedHeaders = Just [+        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"+      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"+      ]+    }+  Nothing -> Nothing+  where+    headers = Wai.requestHeaders req+    accHeaders = case lookup "access-control-request-headers" headers of+      Just hdrs -> map (CI.mk . toS . T.strip . toS) $ BS.split ',' hdrs+      Nothing -> []+ 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++-- | Set a transaction to eventually roll back if requested and set respective+-- headers on the response.+optionalRollback+  :: AppConfig+  -> ApiRequest+  -> ExceptT Error H.Transaction Wai.Response+  -> ExceptT Error H.Transaction Wai.Response+optionalRollback AppConfig{..} ApiRequest{..} transaction = do+  resp <- catchError transaction $ return . errorResponseFor+  when (shouldRollback || (configDbTxRollbackAll && not shouldCommit))+    (lift H.condemn)+  return $ Wai.mapResponseHeaders preferenceApplied resp+  where+    shouldCommit =+      configDbTxAllowOverride && iPreferTransaction == Just Commit+    shouldRollback =+      configDbTxAllowOverride && iPreferTransaction == Just Rollback+    preferenceApplied+      | shouldCommit =+          addHeadersIfNotIncluded+            [(HTTP.hPreferenceApplied, BS.pack (show Commit))]+      | shouldRollback =+          addHeadersIfNotIncluded+            [(HTTP.hPreferenceApplied, BS.pack (show Rollback))]+      | otherwise =+          identity
src/PostgREST/OpenAPI.hs view
@@ -2,41 +2,57 @@ Module      : PostgREST.OpenAPI Description : Generates the OpenAPI output -}-{-# LANGUAGE OverloadedStrings #-}--module PostgREST.OpenAPI (-  encodeOpenAPI-, isMalformedProxyUri-, pickProxy-) where+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}+module PostgREST.OpenAPI (encode) where -import qualified Data.HashSet.InsOrd as Set+import qualified Data.Aeson           as JSON+import qualified Data.ByteString.Lazy as LBS+import qualified Data.HashMap.Strict  as HashMap+import qualified Data.HashSet.InsOrd  as Set+import qualified Data.Text            as T  import Control.Arrow              ((&&&))-import Data.Aeson                 (decode, encode) import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList) import Data.Maybe                 (fromJust) import Data.String                (IsString (..))-import Data.Text                  (append, breakOn, dropWhile, init,-                                   intercalate, pack, tail, toLower,-                                   unpack)-import Network.URI                (URI (..), URIAuth (..),-                                   isAbsoluteURI, parseURI)+import Network.URI                (URI (..), URIAuth (..)) -import Control.Lens+import Control.Lens (at, (.~), (?~))+ import Data.Swagger -import PostgREST.ApiRequest (ContentType (..))-import PostgREST.Config     (docsVersion, prettyVersion)-import PostgREST.Types      (Column (..), ForeignKey (..), PgArg (..),-                             PrimaryKey (..), ProcDescription (..),-                             Proxy (..), Table (..), toMime)-import Protolude            hiding (Proxy, dropWhile, get,-                             intercalate, toLower, toS, (&))-import Protolude.Conv       (toS)+import PostgREST.Config                   (AppConfig (..), Proxy (..),+                                           isMalformedProxyUri, toURI)+import PostgREST.DbStructure              (DbStructure (..),+                                           tableCols, tablePKCols)+import PostgREST.DbStructure.Proc         (PgArg (..),+                                           ProcDescription (..))+import PostgREST.DbStructure.Relationship (Cardinality (..),+                                           PrimaryKey (..),+                                           Relationship (..))+import PostgREST.DbStructure.Table        (Column (..), Table (..))+import PostgREST.Version                  (docsVersion, prettyVersion) +import PostgREST.ContentType++import Protolude      hiding (Proxy, get, toS)+import Protolude.Conv (toS)++encode :: AppConfig -> DbStructure -> [Table] -> HashMap.HashMap k [ProcDescription] -> Maybe Text -> LBS.ByteString+encode conf dbStructure tables procs schemaDescription =+  JSON.encode $+    postgrestSpec+      (dbRelationships dbStructure)+      (concat $ HashMap.elems procs)+      (openApiTableInfo dbStructure <$> tables)+      (proxyUri conf)+      schemaDescription+      (dbPrimaryKeys dbStructure)+ makeMimeList :: [ContentType] -> MimeList-makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs+makeMimeList cs = MimeList $ fmap (fromString . toS . toMime) cs  toSwaggerType :: Text -> SwaggerType t toSwaggerType "character varying" = SwaggerString@@ -51,36 +67,47 @@ toSwaggerType "double precision"  = SwaggerNumber toSwaggerType _                   = SwaggerString -makeTableDef :: [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)-makeTableDef pks (t, cs, _) =+makeTableDef :: [Relationship] -> [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)+makeTableDef rels pks (t, cs, _) =   let tn = tableName t in       (tn, (mempty :: Schema)         & description .~ tableDescription t         & type_ ?~ SwaggerObject-        & properties .~ fromList (map (makeProperty pks) cs)-        & required .~ map colName (filter (not . colNullable) cs))+        & properties .~ fromList (fmap (makeProperty rels pks) cs)+        & required .~ fmap colName (filter (not . colNullable) cs)) -makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema)-makeProperty pks c = (colName c, Inline s)+makeProperty :: [Relationship] -> [PrimaryKey] -> Column -> (Text, Referenced Schema)+makeProperty rels pks c = (colName c, Inline s)   where-    e = if null $ colEnum c then Nothing else decode $ encode $ colEnum c-    fk ForeignKey{fkCol=Column{colTable=Table{tableName=a}, colName=b}} =-      intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]+    e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c+    fk :: Maybe Text+    fk =+      let+        -- Finds the relationship that has a single column foreign key+        rel = find (\case+          Relationship{relColumns, relCardinality=M2O _} -> [c] == relColumns+          _                                                 -> False+          ) rels+        fCol = colName <$> (headMay . relForeignColumns =<< rel)+        fTbl = tableName . relForeignTable <$> rel+        fTblCol = (,) <$> fTbl <*> fCol+      in+        (\(a, b) -> T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]) <$> fTblCol     pk :: Bool     pk = any (\p -> pkTable p == colTable c && pkName p == colName c) pks     n = catMaybes       [ Just "Note:"       , if pk then Just "This is a Primary Key.<pk/>" else Nothing-      , fk <$> colFK c+      , fk       ]     d =       if length n > 1 then-        Just $ append (maybe "" (`append` "\n\n") $ colDescription c) (intercalate "\n" n)+        Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription c) (T.intercalate "\n" n)       else         colDescription c     s =       (mempty :: Schema)-        & default_ .~ (decode . toS =<< colDefault c)+        & default_ .~ (JSON.decode . toS =<< colDefault c)         & description .~ d         & enum_ .~ e         & format ?~ colType c@@ -92,11 +119,11 @@   (mempty :: Schema)   & description .~ pdDescription pd   & type_ ?~ SwaggerObject-  & properties .~ fromList (map makeProcProperty (pdArgs pd))-  & required .~ map pgaName (filter pgaReq (pdArgs pd))+  & properties .~ fromList (fmap makeProcProperty (pdArgs pd))+  & required .~ fmap pgaName (filter pgaReq (pdArgs pd))  makeProcProperty :: PgArg -> (Text, Referenced Schema)-makeProcProperty (PgArg n t _) = (n, Inline s)+makeProcProperty (PgArg n t _ _) = (n, Inline s)   where     s = (mempty :: Schema)           & type_ ?~ toSwaggerType t@@ -111,7 +138,7 @@   & schema .~ ParamOther ((mempty :: ParamOtherSchema)     & in_ .~ ParamHeader     & type_ ?~ SwaggerString-    & enum_ .~ decode (encode ts))+    & enum_ .~ JSON.decode (JSON.encode ts))  makeProcParam :: ProcDescription -> [Referenced Param] makeProcParam pd =@@ -162,7 +189,7 @@       & schema .~ ParamOther ((mempty :: ParamOtherSchema)         & in_ .~ ParamHeader         & type_ ?~ SwaggerString-        & default_ .~ decode "\"items\""))+        & default_ .~ JSON.decode "\"items\""))   , ("offset", (mempty :: Param)       & name        .~ "offset"       & description ?~ "Limiting and Pagination"@@ -192,7 +219,7 @@  makeRowFilter :: Text -> Column -> (Text, Param) makeRowFilter tn c =-  (intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)+  (T.intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)     & name .~ colName c     & description .~ colDescription c     & required ?~ False@@ -202,21 +229,21 @@       & format ?~ colType c))  makeRowFilters :: Text -> [Column] -> [(Text, Param)]-makeRowFilters tn = map (makeRowFilter tn)+makeRowFilters tn = fmap (makeRowFilter tn)  makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)-makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)+makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable t)   where     -- Use first line of table description as summary; rest as description (if present)     -- We strip leading newlines from description so that users can include a blank line between summary and description-    (tSum, tDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $-                    breakOn "\n" <$> tableDescription t+    (tSum, tDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $+                    T.breakOn "\n" <$> tableDescription t     tOp = (mempty :: Operation)       & tags .~ Set.fromList [tn]       & summary .~ tSum       & description .~ mfilter (/="") tDesc     getOp = tOp-      & parameters .~ map ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])+      & parameters .~ fmap ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])       & at 206 ?~ "Partial Content"       & at 200 ?~ Inline ((mempty :: Response)         & description .~ "OK"@@ -226,20 +253,20 @@         )       )     postOp = tOp-      & parameters .~ map ref ["body." <> tn, "select", "preferReturn"]+      & parameters .~ fmap ref ["body." <> tn, "select", "preferReturn"]       & at 201 ?~ "Created"     patchOp = tOp-      & parameters .~ map ref (rs <> ["body." <> tn, "preferReturn"])+      & parameters .~ fmap ref (rs <> ["body." <> tn, "preferReturn"])       & at 204 ?~ "No Content"     deletOp = tOp-      & parameters .~ map ref (rs <> ["preferReturn"])+      & parameters .~ fmap ref (rs <> ["preferReturn"])       & at 204 ?~ "No Content"     pr = (mempty :: PathItem) & get ?~ getOp     pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp     p False = pr     p True  = pw     tn = tableName t-    rs = [ intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]+    rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]     ref = Ref . Reference  makeProcPathItem :: ProcDescription -> (FilePath, PathItem)@@ -247,8 +274,8 @@   where     -- Use first line of proc description as summary; rest as description (if present)     -- We strip leading newlines from description so that users can include a blank line between summary and description-    (pSum, pDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $-                    breakOn "\n" <$> pdDescription pd+    (pSum, pDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $+                    T.breakOn "\n" <$> pdDescription pd     postOp = (mempty :: Operation)       & summary .~ pSum       & description .~ mfilter (/="") pDesc@@ -271,7 +298,7 @@  makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem makePathItems pds ti = fromList $ makeRootPathItem :-  map makePathItem ti ++ map makeProcPathItem pds+  fmap makePathItem ti ++ fmap makeProcPathItem pds  escapeHostName :: Text -> Text escapeHostName "*"  = "0.0.0.0"@@ -281,9 +308,9 @@ escapeHostName "!6" = "0.0.0.0" escapeHostName h    = h -postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger-postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)-  & basePath ?~ unpack b+postgrestSpec :: [Relationship] -> [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger+postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger)+  & basePath ?~ T.unpack b   & schemes ?~ [s']   & info .~ ((mempty :: Info)       & version .~ prettyVersion@@ -293,44 +320,23 @@     & description ?~ "PostgREST Documentation"     & url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))   & host .~ h'-  & definitions .~ fromList (map (makeTableDef pks) ti)+  & definitions .~ fromList (makeTableDef rels pks <$> ti)   & parameters .~ fromList (makeParamDefs ti)   & paths .~ makePathItems pds ti   & produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]   & consumes .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]     where       s' = if s == "http" then Http else Https-      h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))+      h' = Just $ Host (T.unpack $ escapeHostName h) (Just (fromInteger p))       d = fromMaybe "This is a dynamic API generated by PostgREST" sd -encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] ->  LByteString-encodeOpenAPI pds ti uri sd pks = encode $ postgrestSpec pds ti uri sd pks--{-|-  Test whether a proxy uri is malformed or not.-  A valid proxy uri should be an absolute uri without query and user info,-  only http(s) schemes are valid, port number range is 1-65535.--  For example-  http://postgrest.com/openapi.json-  https://postgrest.com:8080/openapi.json--}-isMalformedProxyUri :: Maybe Text -> Bool-isMalformedProxyUri Nothing =  False-isMalformedProxyUri (Just uri)-  | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri-  | otherwise = True--toURI :: Text -> URI-toURI uri = fromJust $ parseURI (toS uri)- pickProxy :: Maybe Text -> Maybe Proxy pickProxy proxy   | isNothing proxy = Nothing   -- should never happen   -- since the request would have been rejected by the middleware if proxy uri   -- is malformed-  | isMalformedProxyUri proxy = Nothing+  | isMalformedProxyUri $ fromMaybe mempty proxy = Nothing   | otherwise = Just Proxy {     proxyScheme = scheme   , proxyHost = host'@@ -339,53 +345,31 @@   }  where    uri = toURI $ fromJust proxy-   scheme = init $ toLower $ pack $ uriScheme uri+   scheme = T.init $ T.toLower $ T.pack $ uriScheme uri    path URI {uriPath = ""} =  "/"    path URI {uriPath = p}  = p-   path' = pack $ path uri+   path' = T.pack $ path uri    authority = fromJust $ uriAuthority uri-   host' = pack $ uriRegName authority+   host' = T.pack $ uriRegName authority    port' = uriPort authority    readPort = fromMaybe 80 . readMaybe    port'' :: Integer    port'' = case (port', scheme) of              ("", "http")  -> 80              ("", "https") -> 443-             _             -> readPort $ unpack $ tail $ pack port'--isUriValid:: URI -> Bool-isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]--fAnd :: [a -> Bool] -> a -> Bool-fAnd fs x = all ($ x) fs--isSchemeValid :: URI -> Bool-isSchemeValid URI {uriScheme = s}-  | toLower (pack s) == "https:" = True-  | toLower (pack s) == "http:" = True-  | otherwise = False--isQueryValid :: URI -> Bool-isQueryValid URI {uriQuery = ""} = True-isQueryValid _                   = False--isAuthorityValid :: URI -> Bool-isAuthorityValid URI {uriAuthority = a}-  | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a-  | otherwise = False--isUserInfoValid :: URIAuth -> Bool-isUserInfoValid URIAuth {uriUserInfo = ""} = True-isUserInfoValid _                          = False+             _             -> readPort $ T.unpack $ T.tail $ T.pack port' -isHostValid :: URIAuth -> Bool-isHostValid URIAuth {uriRegName = ""} = False-isHostValid _                         = True+proxyUri :: AppConfig -> (Text, Text, Integer, Text)+proxyUri AppConfig{..} =+  case pickProxy $ toS <$> configOpenApiServerProxyUri of+    Just Proxy{..} ->+      (proxyScheme, proxyHost, proxyPort, proxyPath)+    Nothing ->+      ("http", configServerHost, toInteger configServerPort, "/") -isPortValid :: URIAuth -> Bool-isPortValid URIAuth {uriPort = ""} = True-isPortValid URIAuth {uriPort = (':':p)} =-  case readMaybe p of-    Just i  -> i > (0 :: Integer) && i < 65536-    Nothing -> False-isPortValid _ = False+openApiTableInfo :: DbStructure -> Table -> (Table, [Column], [Text])+openApiTableInfo dbStructure table =+  ( table+  , tableCols dbStructure (tableSchema table) (tableName table)+  , tablePKCols dbStructure (tableSchema table) (tableName table)+  )
− src/PostgREST/Parsers.hs 
@@ -1,272 +0,0 @@-{-|-Module      : PostgREST.Parsers-Description : PostgREST parser combinators--This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.--}-module PostgREST.Parsers where--import qualified Data.HashMap.Strict as M-import qualified Data.Set            as S--import Data.Either.Combinators (mapLeft)-import Data.Foldable           (foldl1)-import Data.List               (init, last)-import Data.Text               (intercalate, replace, strip)-import Text.Read               (read)--import Data.Tree-import Text.Parsec.Error-import Text.ParserCombinators.Parsec hiding (many, (<|>))--import PostgREST.Error      (ApiRequestError (ParseRequestError))-import PostgREST.RangeQuery (NonnegRange)-import PostgREST.Types-import Protolude            hiding (intercalate, option, replace, toS,-                             try)-import Protolude.Conv       (toS)--pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]-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-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k-    oper = parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v-    path = fst <$> treePath-    fld = snd <$> treePath--pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm])-pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'-  where-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k-    path = fst <$> treePath-    ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v--pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange)-pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v-  where-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k-    path = fst <$> treePath--pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree)-pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree-  where-    path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k-    embedPath = fst <$> path-    logicTree = do-      op <- snd <$> path-      -- Concat op and v to make pLogicTree argument regular,-      -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"-      parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v)--pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName))-pRequestColumns colStr =-  case colStr of-    Just str ->-      mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)-    _ -> Right Nothing--ws :: Parser Text-ws = toS <$> many (oneOf " \t")--lexeme :: Parser a -> Parser a-lexeme p = ws *> p <* ws--pTreePath :: Parser (EmbedPath, Field)-pTreePath = do-  p <- pFieldName `sepBy1` pDelimiter-  jp <- option [] pJsonPath-  return (init p, (last p, jp))--pFieldForest :: Parser [Tree SelectItem]-pFieldForest = pFieldTree `sepBy1` lexeme (char ',')-  where-    pFieldTree :: Parser (Tree SelectItem)-    pFieldTree =  try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|>-                  Node <$> pFieldSelect <*> pure []--pStar :: Parser Text-pStar = toS <$> (string "*" $> ("*"::ByteString))--pFieldName :: Parser Text-pFieldName =-  pQuotedValue <|>-  intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) <?>-  "field name (* or [a..z0..9_])"-  where-    isDash :: GenParser Char st ()-    isDash = try ( char '-' >> notFollowedBy (char '>') )-    dash :: Parser Char-    dash = isDash $> '-'--pJsonPath :: Parser JsonPath-pJsonPath = many pJsonOperation-  where-    pJsonOperation :: Parser JsonOperation-    pJsonOperation = pJsonArrow <*> pJsonOperand--    pJsonArrow   =-      try (string "->>" $> J2Arrow) <|>-      try (string "->" $> JArrow)--    pJsonOperand =-      let pJKey = JKey . toS <$> pFieldName-          pJIdx = JIdx . toS <$> ((:) <$> option '+' (char '-') <*> many1 digit) <* pEnd-          pEnd = try (void $ lookAhead (string "->")) <|>-                 try (void $ lookAhead (string "::")) <|>-                 try eof in-      try pJIdx <|> try pJKey--pField :: Parser Field-pField = lexeme $ (,) <$> pFieldName <*> option [] pJsonPath--aliasSeparator :: Parser ()-aliasSeparator = char ':' >> notFollowedBy (char ':')--pRelationSelect :: Parser SelectItem-pRelationSelect = lexeme $ try ( do-    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )-    fld <- pField-    hint <- optionMaybe (-        try ( char '!' *> pFieldName) <|>-        -- deprecated, remove in next major version-        try ( char '.' *> pFieldName)-      )-    return (fld, Nothing, alias, hint)-  )--pFieldSelect :: Parser SelectItem-pFieldSelect = lexeme $-  try (-    do-      alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )-      fld <- pField-      cast' <- optionMaybe (string "::" *> many letter)-      return (fld, toS <$> cast', alias, Nothing)-  )-  <|> do-    s <- pStar-    return ((s, []), Nothing, Nothing, Nothing)--pOpExpr :: Parser SingleVal -> Parser OpExpr-pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation-  where-    pOperation :: Parser Operation-    pOperation =-          Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal-      <|> In <$> (try (string "in" *> pDelimiter) *> pListVal)-      <|> pFts-      <?> "operator (eq, gt, ...)"--    pFts = do-      op   <- foldl1 (<|>) (try . string . toS <$> ftsOps)-      lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_")))-      pDelimiter >> Fts (toS op) (toS <$> lang) <$> pSVal--    ops = M.filterWithKey (const . flip notElem ("in":ftsOps)) operators-    ftsOps = M.keys ftsOperators--pSingleVal :: Parser SingleVal-pSingleVal = toS <$> many anyChar--pListVal :: Parser ListVal-pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')--pListElement :: Parser Text-pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)"))--pQuotedValue :: Parser Text-pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"')--pDelimiter :: Parser Char-pDelimiter = char '.' <?> "delimiter (.)"--pOrder :: Parser [OrderTerm]-pOrder = lexeme pOrderTerm `sepBy1` char ','--pOrderTerm :: Parser OrderTerm-pOrderTerm = do-  fld <- pField-  dir <- optionMaybe $-         try (pDelimiter *> string "asc" $> OrderAsc) <|>-         try (pDelimiter *> string "desc" $> OrderDesc)-  nls <- optionMaybe pNulls <* pEnd <|>-         pEnd $> Nothing-  return $ OrderTerm fld dir nls-  where-    pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>-             try (pDelimiter *> string "nullslast"  $> OrderNullsLast)-    pEnd = try (void $ lookAhead (char ',')) <|>-           try eof--pLogicTree :: Parser LogicTree-pLogicTree = Stmnt <$> try pLogicFilter-             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')'))-  where-    pLogicFilter :: Parser Filter-    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal-    pNot :: Parser Bool-    pNot = try (string "not" *> pDelimiter $> True)-           <|> pure False-           <?> "negation operator (not)"-    pLogicOp :: Parser LogicOperator-    pLogicOp = try (string "and" $> And)-               <|> string "or" $> Or-               <?> "logic operator (and, or)"--pLogicSingleVal :: Parser SingleVal-pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)"))-  where-    pPgArray :: Parser Text-    pPgArray =  do-      a <- string "{"-      b <- many (noneOf "{}")-      c <- string "}"-      toS <$> pure (a ++ b ++ c)--pLogicPath :: Parser (EmbedPath, Text)-pLogicPath = do-  path <- pFieldName `sepBy1` pDelimiter-  let op = last path-      notOp = "not." <> op-  return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)--pColumns :: Parser [FieldName]-pColumns = pFieldName `sepBy1` lexeme (char ',')--mapError :: Either ParseError a -> Either ApiRequestError a-mapError = mapLeft translateError-  where-    translateError e =-      ParseRequestError message details-      where-        message = show $ errorPos e-        details = strip $ replace "\n" " " $ toS-           $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)---- Used for the config value "role-claim-key"-pRoleClaimKey :: Text -> Either ApiRequestError JSPath-pRoleClaimKey selStr =-  mapError $ parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)--pJSPath :: Parser JSPath-pJSPath = toJSPath <$> (period *> pPath `sepBy` period <* eof)-  where-    toJSPath :: [(Text, Maybe Int)] -> JSPath-    toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))-    period = char '.' <?> "period (.)"-    pPath :: Parser (Text, Maybe Int)-    pPath = (,) <$> pJSPKey <*> optionMaybe pJSPIdx--pJSPKey :: Parser Text-pJSPKey = toS <$> many1 (alphaNum <|> oneOf "_$@") <|> pQuotedValue <?> "attribute name [a..z0..9_$@])"--pJSPIdx :: Parser Int-pJSPIdx = char '[' *> (read <$> many1 digit) <* char ']' <?> "array index [0..n]"
− src/PostgREST/Private/Common.hs 
@@ -1,25 +0,0 @@-{-|-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 
@@ -1,206 +0,0 @@-{-# 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)-import qualified Data.Text                     as T (map, null,-                                                     takeWhile)-import           PostgREST.Types-import           Protolude                     hiding (cast,-                                                intercalate, replace,-                                                toLower)-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 (-        ", pgrst_source_count AS (" <> countQuery <> ")"-      , "(SELECT pg_catalog.count(*) FROM pgrst_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/Query/QueryBuilder.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-|+Module      : PostgREST.Query.QueryBuilder+Description : PostgREST SQL queries generating functions.++This module provides functions to consume data types that+represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment+to produce SqlQuery type outputs.+-}+module PostgREST.Query.QueryBuilder+  ( readRequestToQuery+  , mutateRequestToQuery+  , readRequestToCountQuery+  , requestToCallProcQuery+  , limitedQuery+  ) where++import qualified Data.ByteString.Char8           as BS+import qualified Data.Set                        as S+import qualified Hasql.DynamicStatements.Snippet as H++import Data.Tree (Tree (..))++import PostgREST.DbStructure.Identifiers  (FieldName,+                                           QualifiedIdentifier (..))+import PostgREST.DbStructure.Proc         (PgArg (..))+import PostgREST.DbStructure.Relationship (Cardinality (..),+                                           Relationship (..))+import PostgREST.DbStructure.Table        (Table (..))+import PostgREST.Request.ApiRequest       (PayloadJSON (..))+import PostgREST.Request.Preferences      (PreferParameters (..),+                                           PreferResolution (..))++import PostgREST.Query.SqlFragment+import PostgREST.Request.Types++import Protolude++readRequestToQuery :: ReadRequest -> H.Snippet+readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) =+  "SELECT " <>+  intercalateSnippet ", " ((pgFmtSelectItem qi <$> colSelects) ++ selects) <>+  "FROM " <> H.sql (BS.intercalate ", " (tabl : implJs)) <> " " <>+  intercalateSnippet " " joins <> " " <>+  (if null logicForest && null joinConditions_ then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_))+  <> " " <>+  (if null ordts then mempty else "ORDER BY " <> intercalateSnippet ", " (map (pgFmtOrderTerm qi) ordts)) <> " " <>+  limitOffsetF range+  where+    implJs = fromQi <$> implJoins+    tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias+    qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias+    (joins, selects) = foldr getJoinsSelects ([],[]) forest++getJoinsSelects :: ReadRequest -> ([H.Snippet], [H.Snippet]) -> ([H.Snippet], [H.Snippet])+getJoinsSelects rr@(Node (_, (name, Just Relationship{relCardinality=card,relTable=Table{tableName=table}}, alias, _, _)) _) (j,s) =+  let subquery = readRequestToQuery rr in+  case card of+    M2O _ ->+      let aliasOrName = fromMaybe name alias+          localTableName = pgFmtIdent $ table <> "_" <> aliasOrName+          sel = H.sql ("row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName)+          joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> H.sql localTableName <> " ON TRUE " in+      (joi:j,sel:s)+    _ ->+      let sel = "COALESCE (("+             <> "SELECT json_agg(" <> H.sql (pgFmtIdent table) <> ".*) "+             <> "FROM (" <> subquery <> ") " <> H.sql (pgFmtIdent table) <> " "+             <> "), '[]') AS " <> H.sql (pgFmtIdent (fromMaybe name alias)) in+      (j,sel:s)+getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], [])++mutateRequestToQuery :: MutateRequest -> H.Snippet+mutateRequestToQuery (Insert mainQi iCols body onConflct putConditions returnings) =+  "WITH " <> normalizedBody body <> " " <>+  "INSERT INTO " <> H.sql (fromQi mainQi) <> H.sql (if S.null iCols then " " else "(" <> cols <> ") ") <>+  "SELECT " <> H.sql cols <> " " <>+  H.sql ("FROM json_populate_recordset (null::" <> fromQi mainQi <> ", " <> selectBody <> ") _ ") <>+  -- Only used for PUT+  (if null putConditions then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) <>+  H.sql (BS.unwords [+    maybe "" (\(oncDo, oncCols) ->+      if null oncCols then+        mempty+      else+        "ON CONFLICT(" <> BS.intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of+        IgnoreDuplicates ->+          "DO NOTHING"+        MergeDuplicates  ->+          if S.null iCols+             then "DO NOTHING"+             else "DO UPDATE SET " <> BS.intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)+      ) onConflct,+    returningF mainQi returnings+    ])+  where+    cols = BS.intercalate ", " $ pgFmtIdent <$> S.toList iCols+mutateRequestToQuery (Update mainQi uCols body logicForest returnings) =+  if S.null uCols+    -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax+    -- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select=+    -- the select has to be based on "returnings" to make computed overloaded functions not throw+    then H.sql ("SELECT " <> emptyBodyReturnedColumns <> " FROM " <> fromQi mainQi <> " WHERE false")+    else+      "WITH " <> normalizedBody body <> " " <>+      "UPDATE " <> H.sql (fromQi mainQi) <> " SET " <> H.sql cols <> " " <>+      "FROM (SELECT * FROM json_populate_recordset (null::" <> H.sql (fromQi mainQi) <> " , " <> H.sql selectBody <> " )) _ " <>+      (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)) <> " " <>+      H.sql (returningF mainQi returnings)+  where+    cols = BS.intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)+    emptyBodyReturnedColumns :: SqlFragment+    emptyBodyReturnedColumns+      | null returnings = "NULL"+      | otherwise       = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)+mutateRequestToQuery (Delete mainQi logicForest returnings) =+  "DELETE FROM " <> H.sql (fromQi mainQi) <> " " <>+  (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree mainQi) logicForest)) <> " " <>+  H.sql (returningF mainQi returnings)++requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Maybe PayloadJSON -> Bool -> Maybe PreferParameters -> [FieldName] -> H.Snippet+requestToCallProcQuery qi pgArgs pj returnsScalar preferParams returnings =+  argsCTE <> sourceBody+  where+    body = pjRaw <$> pj+    paramsAsSingleObject    = preferParams == Just SingleObject+    paramsAsMultipleObjects = preferParams == Just MultipleObjects++    (argsCTE, args)+      | null pgArgs = (mempty, mempty)+      | paramsAsSingleObject = ("WITH pgrst_args AS (SELECT NULL)", jsonPlaceHolder body)+      | otherwise = (+          "WITH " <> normalizedBody body <> ", " <>+          H.sql (+            BS.unwords [+            "pgrst_args AS (",+              "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (const mempty) (\a -> " " <> encodeUtf8 (pgaType a)) <> ")",+            ")"])+         , H.sql $ if paramsAsMultipleObjects+             then fmtArgs varadicPrefix (\a -> " := pgrst_args." <> pgFmtIdent (pgaName a))+             else fmtArgs varadicPrefix (\a -> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM pgrst_args LIMIT 1)")+        )++    fmtArgs :: (PgArg -> SqlFragment) -> (PgArg -> SqlFragment) -> SqlFragment+    fmtArgs argFragPre argFragSuf = BS.intercalate ", " ((\a -> argFragPre a <> pgFmtIdent (pgaName a) <> argFragSuf a) <$> pgArgs)++    varadicPrefix :: PgArg -> SqlFragment+    varadicPrefix a = if pgaVar a then "VARIADIC " else mempty++    sourceBody :: H.Snippet+    sourceBody+      | paramsAsMultipleObjects =+          if returnsScalar+            then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"+            else "SELECT pgrst_lat_args.* FROM pgrst_args, " <>+                 "LATERAL ( SELECT " <> returnedColumns <> " FROM " <> callIt <> " ) pgrst_lat_args"+      | otherwise =+          if returnsScalar+            then "SELECT " <> callIt <> " AS pgrst_scalar"+            else "SELECT " <> returnedColumns <> " FROM " <> callIt++    callIt :: H.Snippet+    callIt = H.sql (fromQi qi) <> "(" <> args <> ")"++    returnedColumns :: H.Snippet+    returnedColumns+      | null returnings = "*"+      | otherwise       = H.sql $ BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings)+++-- | 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 -> H.Snippet+readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) =+ "SELECT 1 " <> "FROM " <> H.sql (fromQi qi) <> " " <>+ if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest)++limitedQuery :: H.Snippet -> Maybe Integer -> H.Snippet+limitedQuery query maxRows = query <> H.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows)
+ src/PostgREST/Query/SqlFragment.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE LambdaCase  #-}+{-# LANGUAGE QuasiQuotes #-}+{-|+Module      : PostgREST.Query.SqlFragment+Description : Helper functions for PostgREST.QueryBuilder.++Any function that outputs a SqlFragment should be in this module.+-}+module PostgREST.Query.SqlFragment+  ( noLocationF+  , SqlFragment+  , asBinaryF+  , asCsvF+  , asJsonF+  , asJsonSingleF+  , countF+  , fromQi+  , ftsOperators+  , jsonPlaceHolder+  , limitOffsetF+  , locationF+  , normalizedBody+  , operators+  , pgFmtColumn+  , pgFmtIdent+  , pgFmtJoinCondition+  , pgFmtLogicTree+  , pgFmtOrderTerm+  , pgFmtSelectItem+  , responseHeadersF+  , responseStatusF+  , returningF+  , selectBody+  , sourceCTEName+  , unknownEncoder+  , intercalateSnippet+  ) where++import qualified Data.ByteString.Char8           as BS+import qualified Data.ByteString.Lazy            as BL+import qualified Data.HashMap.Strict             as HM+import qualified Data.Text                       as T+import qualified Hasql.DynamicStatements.Snippet as H+import qualified Hasql.Encoders                  as HE++import Data.Foldable                 (foldr1)+import Text.InterpolatedString.Perl6 (qc)++import PostgREST.Config.PgVersion        (PgVersion, pgVersion96)+import PostgREST.DbStructure.Identifiers (FieldName,+                                          QualifiedIdentifier (..))+import PostgREST.RangeQuery              (NonnegRange, allRange,+                                          rangeLimit, rangeOffset)+import PostgREST.Request.Types           (Alias, Field, Filter (..),+                                          JoinCondition (..),+                                          JsonOperand (..),+                                          JsonOperation (..),+                                          JsonPath, LogicTree (..),+                                          OpExpr (..), Operation (..),+                                          OrderTerm (..), SelectItem)++import Protolude      hiding (cast, toS)+import Protolude.Conv (toS)+++-- | A part of a SQL query that cannot be executed independently+type SqlFragment = ByteString++noLocationF :: SqlFragment+noLocationF = "array[]::text[]"++sourceCTEName :: SqlFragment+sourceCTEName = "pgrst_source"++operators :: HM.HashMap Text SqlFragment+operators = HM.union (HM.fromList [+  ("eq", "="),+  ("gte", ">="),+  ("gt", ">"),+  ("lte", "<="),+  ("lt", "<"),+  ("neq", "<>"),+  ("like", "LIKE"),+  ("ilike", "ILIKE"),+  ("in", "IN"),+  ("is", "IS"),+  ("cs", "@>"),+  ("cd", "<@"),+  ("ov", "&&"),+  ("sl", "<<"),+  ("sr", ">>"),+  ("nxr", "&<"),+  ("nxl", "&>"),+  ("adj", "-|-")]) ftsOperators++ftsOperators :: HM.HashMap Text SqlFragment+ftsOperators = HM.fromList [+  ("fts", "@@ to_tsquery"),+  ("plfts", "@@ plainto_tsquery"),+  ("phfts", "@@ phraseto_tsquery"),+  ("wfts", "@@ websearch_to_tsquery")+  ]++-- |+-- 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 :: Maybe BL.ByteString -> H.Snippet+normalizedBody body =+  "pgrst_payload AS (SELECT " <> jsonPlaceHolder body <> " AS json_data), " <>+  H.sql (BS.unwords [+    "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)"])++-- | Equivalent to "$1::json"+-- | TODO: At this stage there shouldn't be a Maybe since ApiRequest should ensure that an INSERT/UPDATE has a body+jsonPlaceHolder :: Maybe BL.ByteString -> H.Snippet+jsonPlaceHolder body =+  H.encoderAndParam (HE.nullable HE.unknown) (toS <$> body) <> "::json"++selectBody :: SqlFragment+selectBody = "(SELECT val FROM pgrst_body)"++pgFmtLit :: Text -> SqlFragment+pgFmtLit x =+ let trimmed = trimNullChars x+     escaped = "'" <> T.replace "'" "''" trimmed <> "'"+     slashed = T.replace "\\" "\\\\" escaped in+ encodeUtf8 $ if "\\" `T.isInfixOf` escaped+   then "E" <> slashed+   else slashed++-- TODO: refactor by following https://github.com/PostgREST/postgrest/pull/1631#issuecomment-711070833+pgFmtIdent :: Text -> SqlFragment+pgFmtIdent x = encodeUtf8 $ "\"" <> T.replace "\"" "\"\"" (trimNullChars x) <> "\""++trimNullChars :: Text -> Text+trimNullChars = T.takeWhile (/= '\x0')++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 :: Bool -> SqlFragment+asJsonF returnsScalar+  | returnsScalar = "coalesce(json_agg(_postgrest_t.pgrst_scalar), '[]')::character varying"+  | otherwise     = "coalesce(json_agg(_postgrest_t), '[]')::character varying"++asJsonSingleF :: Bool -> SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element+asJsonSingleF returnsScalar+  | returnsScalar = "coalesce(string_agg(to_json(_postgrest_t.pgrst_scalar)::text, ','), 'null')::character varying"+  | otherwise     = "coalesce(string_agg(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 ('{fmtPKeys}')+)|]+  where+    fmtPKeys = T.intercalate "','" pKeys++fromQi :: QualifiedIdentifier -> SqlFragment+fromQi t = (if T.null s then mempty else pgFmtIdent s <> ".") <> pgFmtIdent n+  where+    n = qiName t+    s = qiSchema t++pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment+pgFmtColumn table "*" = fromQi table <> ".*"+pgFmtColumn table c   = fromQi table <> "." <> pgFmtIdent c++pgFmtField :: QualifiedIdentifier -> Field -> H.Snippet+pgFmtField table (c, jp) = H.sql (pgFmtColumn table c) <> pgFmtJsonPath jp++pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> H.Snippet+pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> H.sql (pgFmtAs fName jp alias)+-- Ideally we'd quote the cast with "pgFmtIdent cast". However, that would invalidate common casts such as "int", "bigint", etc.+-- Try doing: `select 1::"bigint"` - it'll err, using "int8" will work though. There's some parser magic that pg does that's invalidated when quoting.+-- Not quoting should be fine, we validate the input on Parsers.+pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> H.sql (encodeUtf8 cast) <> " )" <> H.sql (pgFmtAs fName jp alias)++pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> H.Snippet+pgFmtOrderTerm qi ot =+  pgFmtField qi (otTerm ot) <> " " <>+  H.sql (BS.unwords [+    BS.pack $ maybe mempty show $ otDirection ot,+    BS.pack $ maybe mempty show $ otNullOrder ot])++pgFmtFilter :: QualifiedIdentifier -> Filter -> H.Snippet+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"    -> isAllowed val+     _       -> unknownLiteral val++   -- We don't use "IN", we use "= ANY". IN has the following disadvantages:+   -- + No way to use an empty value on IN: "col IN ()" is invalid syntax. With ANY we can do "= ANY('{}')"+   -- + Can invalidate prepared statements: multiple parameters on an IN($1, $2, $3) will lead to using different prepared statements and not take advantage of caching.+   In vals -> pgFmtField table fld <> " " <>+    case vals of+      [""] -> "= ANY('{}') "+      -- Here we build the pg array, e.g '{"Hebdon, John","Other","Another"}', manually. We quote the values to prevent the "," being treated as an element separator.+      -- TODO: Ideally this would be done on Hasql with an encoder, but the "array unknown" is not working(Hasql doesn't pass any value).+      _    -> "= ANY (" <> unknownLiteral ("{" <> T.intercalate "," ((\x -> "\"" <> x <> "\"") <$> vals) <> "}") <> ")"++   Fts op lang val ->+     pgFmtFieldOp op <> "(" <> ftsLang lang <> unknownLiteral val <> ") "+ where+   ftsLang = maybe mempty (\l -> unknownLiteral l <> ", ")+   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op+   sqlOperator o = H.sql $ HM.lookupDefault "=" o operators+   notOp = if hasNot then "NOT" else mempty+   star c = if c == '*' then '%' else c+   -- IS cannot be prepared. `PREPARE boolplan AS SELECT * FROM projects where id IS $1` will give a syntax error.+   -- The above can be fixed by using `PREPARE boolplan AS SELECT * FROM projects where id IS NOT DISTINCT FROM $1;`+   -- However that would not accept the TRUE/FALSE/NULL keywords. See: https://stackoverflow.com/questions/6133525/proper-way-to-set-preparedstatement-parameter-to-null-under-postgres.+   isAllowed :: Text -> H.Snippet+   isAllowed v = H.sql $ maybe+     (pgFmtLit v <> "::unknown") encodeUtf8+     (find ((==) . T.toLower $ v) ["null","true","false"])++pgFmtJoinCondition :: JoinCondition -> H.Snippet+pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) =+  H.sql $ pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2++pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> H.Snippet+pgFmtLogicTree qi (Expr hasNot op forest) = H.sql notOp <> " (" <> intercalateSnippet (" " <> BS.pack (show op) <> " ") (pgFmtLogicTree qi <$> forest) <> ")"+  where notOp =  if hasNot then "NOT" else mempty+pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt++pgFmtJsonPath :: JsonPath -> H.Snippet+pgFmtJsonPath = \case+  []             -> mempty+  (JArrow x:xs)  -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs+  (J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs+  where+    pgFmtJsonOperand (JKey k) = unknownLiteral k+    pgFmtJsonOperand (JIdx i) = unknownLiteral i <> "::int"++pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment+pgFmtAs _ [] Nothing = mempty+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 -> mempty+pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias++countF :: H.Snippet -> Bool -> (H.Snippet, SqlFragment)+countF countQuery shouldCount =+  if shouldCount+    then (+        ", pgrst_source_count AS (" <> countQuery <> ")"+      , "(SELECT pg_catalog.count(*) FROM pgrst_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 " <> BS.intercalate ", " (pgFmtColumn qi <$> returnings)++limitOffsetF :: NonnegRange -> H.Snippet+limitOffsetF range =+  if range == allRange then mempty else "LIMIT " <> limit <> " OFFSET " <> offset+  where+    limit = maybe "ALL" (\l -> unknownEncoder (BS.pack $ show l)) $ rangeLimit range+    offset = unknownEncoder (BS.pack . show $ rangeOffset range)++responseHeadersF :: PgVersion -> SqlFragment+responseHeadersF pgVer =+  if pgVer >= pgVersion96+    then currentSettingF "response.headers"+    else "null"++responseStatusF :: PgVersion -> SqlFragment+responseStatusF pgVer =+  if pgVer >= pgVersion96+    then currentSettingF "response.status"+    else "null"++currentSettingF :: Text -> SqlFragment+currentSettingF setting =+  -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15+  "nullif(current_setting(" <> pgFmtLit setting <> ", true), '')"++-- Hasql Snippet utilities+unknownEncoder :: ByteString -> H.Snippet+unknownEncoder = H.encoderAndParam (HE.nonNullable HE.unknown)++unknownLiteral :: Text -> H.Snippet+unknownLiteral = unknownEncoder . encodeUtf8++intercalateSnippet :: ByteString -> [H.Snippet] -> H.Snippet+intercalateSnippet _ [] = mempty+intercalateSnippet frag snippets = foldr1 (\a b -> a <> H.sql frag <> b) snippets
+ src/PostgREST/Query/Statements.hs view
@@ -0,0 +1,204 @@+{-|+Module      : PostgREST.Query.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.Query.Statements+  ( createWriteStatement+  , createReadStatement+  , callProcStatement+  , createExplainStatement+  ) where++import qualified Data.Aeson                        as JSON+import qualified Data.Aeson.Lens                   as L+import qualified Data.ByteString.Char8             as BS+import qualified Hasql.Decoders                    as HD+import qualified Hasql.DynamicStatements.Snippet   as H+import qualified Hasql.DynamicStatements.Statement as H+import qualified Hasql.Statement                   as H++import Control.Lens              ((^?))+import Data.Maybe                (fromJust)+import Data.Text.Read            (decimal)+import Network.HTTP.Types.Status (Status)++import PostgREST.Config.PgVersion (PgVersion)+import PostgREST.Error            (Error (..))+import PostgREST.GucHeader        (GucHeader)++import PostgREST.DbStructure.Identifiers (FieldName)+import PostgREST.Query.SqlFragment+import PostgREST.Request.Preferences++import Protolude      hiding (toS)+import Protolude.Conv (toS)++{-| 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 Error [GucHeader], Either Error (Maybe Status))++createWriteStatement :: H.Snippet -> H.Snippet -> Bool -> Bool -> Bool ->+                        PreferRepresentation -> [Text] -> PgVersion -> Bool ->+                        H.Statement () ResultsWithCount+createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer =+  H.dynamicallyParameterized snippet decodeStandard+ where+  snippet =+    "WITH " <> H.sql sourceCTEName <> " AS (" <> mutateQuery <> ") " <>+    H.sql (+    "SELECT " <>+      "'' AS total_result_set, " <>+      "pg_catalog.count(_postgrest_t) AS page_total, " <>+      locF <> " AS header, " <>+      bodyF <> " AS body, " <>+      responseHeadersF pgVer <> " AS response_headers, " <>+      responseStatusF pgVer  <> " AS response_status "+    ) <>+    "FROM (" <> selectF <> ") _postgrest_t"++  locF =+    if isInsert && rep `elem` [Full, HeadersOnly]+      then BS.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 False+    | otherwise = asJsonF False++  selectF+    -- prevent using any of the column names in ?select= when no response is returned from the CTE+    | rep `elem` [None, HeadersOnly] = H.sql ("SELECT * FROM " <> sourceCTEName)+    | otherwise                      = selectQuery++  decodeStandard :: HD.Result ResultsWithCount+  decodeStandard =+   fromMaybe (Nothing, 0, [], mempty, Right [], Right Nothing) <$> HD.rowMaybe standardRow++createReadStatement :: H.Snippet -> H.Snippet -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> Bool ->+                       H.Statement () ResultsWithCount+createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField pgVer =+  H.dynamicallyParameterized snippet decodeStandard+ where+  snippet =+    "WITH " <>+    H.sql sourceCTEName <> " AS ( " <> selectQuery <> " ) " <>+    countCTEF <> " " <>+    H.sql ("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, " <>+      responseStatusF pgVer <> " AS response_status " <>+    "FROM ( SELECT * FROM " <> sourceCTEName <> " ) _postgrest_t")++  (countCTEF, countResultF) = countF countQuery countTotal++  bodyF+    | asCsv = asCsvF+    | isSingle = asJsonSingleF False+    | isJust binaryField = asBinaryF $ fromJust binaryField+    | otherwise = asJsonF False++  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+                      <*> arrayColumn HD.bytea <*> column HD.bytea+                      <*> (fromMaybe (Right []) <$> nullableColumn decodeGucHeaders)+                      <*> (fromMaybe (Right Nothing) <$> nullableColumn decodeGucStatus)++type ProcResults = (Maybe Int64, Int64, ByteString, Either Error [GucHeader], Either Error (Maybe Status))++callProcStatement :: Bool -> Bool -> H.Snippet -> H.Snippet -> H.Snippet -> Bool ->+                     Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> Bool ->+                     H.Statement () ProcResults+callProcStatement returnsScalar returnsSingle callProcQuery selectQuery countQuery countTotal asSingle asCsv multObjects binaryField pgVer =+  H.dynamicallyParameterized snippet decodeProc+  where+    snippet =+      "WITH " <> H.sql sourceCTEName <> " AS (" <> callProcQuery <> ") " <>+      countCTEF <>+      H.sql (+      "SELECT " <>+        countResultF <> " AS total_result_set, " <>+        "pg_catalog.count(_postgrest_t) AS page_total, " <>+        bodyF <> " AS body, " <>+        responseHeadersF pgVer <> " AS response_headers, " <>+        responseStatusF pgVer <> " AS response_status ") <>+      "FROM (" <> selectQuery <> ") _postgrest_t"++    (countCTEF, countResultF) = countF countQuery countTotal++    bodyF+     | asSingle           = asJsonSingleF returnsScalar+     | asCsv              = asCsvF+     | isJust binaryField = asBinaryF $ fromJust binaryField+     | returnsSingle+       && not multObjects = asJsonSingleF returnsScalar+     | otherwise          = asJsonF returnsScalar++    decodeProc :: HD.Result ProcResults+    decodeProc =+      fromMaybe (Just 0, 0, mempty, defGucHeaders, defGucStatus) <$> HD.rowMaybe procRow+      where+        defGucHeaders = Right []+        defGucStatus  = Right Nothing+        procRow = (,,,,) <$> nullableColumn HD.int8 <*> column HD.int8+                         <*> column HD.bytea+                         <*> (fromMaybe defGucHeaders <$> nullableColumn decodeGucHeaders)+                         <*> (fromMaybe defGucStatus <$> nullableColumn decodeGucStatus)++createExplainStatement :: H.Snippet -> Bool -> H.Statement () (Maybe Int64)+createExplainStatement countQuery =+  H.dynamicallyParameterized snippet decodeExplain+  where+    snippet = "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++decodeGucHeaders :: HD.Value (Either Error [GucHeader])+decodeGucHeaders = first (const GucHeadersError) . JSON.eitherDecode . toS <$> HD.bytea++decodeGucStatus :: HD.Value (Either Error (Maybe Status))+decodeGucStatus = first (const GucStatusError) . fmap (Just . toEnum . fst) . decimal <$> HD.text++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++arrayColumn :: HD.Value a -> HD.Row [a]+arrayColumn = column . HD.listArray . HD.nonNullable
− src/PostgREST/QueryBuilder.hs 
@@ -1,193 +0,0 @@-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# OPTIONS_GHC -fno-warn-orphans  #-}-{-|-Module      : PostgREST.QueryBuilder-Description : PostgREST SQL queries generating functions.--This module provides functions to consume data types that-represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment-to produce SqlQuery type outputs.--}-module PostgREST.QueryBuilder (-    readRequestToQuery-  , mutateRequestToQuery-  , readRequestToCountQuery-  , requestToCallProcQuery-  , limitedQuery-  , setLocalQuery-  , setLocalSearchPathQuery-  ) where--import qualified Data.Set as S--import Data.Text (intercalate)-import Data.Tree (Tree (..))--import Data.Maybe--import PostgREST.Private.QueryFragment-import PostgREST.RangeQuery            (allRange, rangeLimit,-                                        rangeOffset)-import PostgREST.Types-import Protolude                       hiding (cast, intercalate,-                                        replace)--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),-    unwords joins,-    ("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` (range == allRange)-    ]-  where-    implJs = fromQi <$> implJoins-    tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias-    qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias-    (joins, selects) = foldr getJoinsSelects ([],[]) 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, _, _, _)) _) _ = ([], [])--mutateRequestToQuery :: MutateRequest -> SqlQuery-mutateRequestToQuery (Insert mainQi iCols onConflct putConditions returnings) =-  unwords [-    "WITH " <> normalizedBody,-    "INSERT INTO ", fromQi mainQi, if S.null iCols then " " else "(" <> cols <> ")",-    unwords [-      "SELECT " <> cols <> " FROM",-      "json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ") _",-      -- Only used for PUT-      ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) `emptyOnFalse` null putConditions],-    maybe "" (\(oncDo, oncCols) -> (-      "ON CONFLICT(" <> intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of-      IgnoreDuplicates ->-        "DO NOTHING"-      MergeDuplicates  ->-        if S.null iCols-           then "DO NOTHING"-           else "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)-                                   ) `emptyOnFalse` null oncCols) onConflct,-    returningF mainQi returnings-    ]-  where-    cols = intercalate ", " $ pgFmtIdent <$> S.toList iCols-mutateRequestToQuery (Update mainQi uCols logicForest returnings) =-  if S.null uCols-    -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax-    -- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select=-    -- the select has to be based on "returnings" to make computed overloaded functions not throw-    then "WITH " <> ignoredBody <> "SELECT " <> empty_body_returned_columns <> " FROM " <> fromQi mainQi <> " WHERE false"-    else-      unwords [-        "WITH " <> normalizedBody,-        "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-    cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)-    empty_body_returned_columns :: SqlFragment-    empty_body_returned_columns-      | null returnings = "NULL"-      | otherwise       = intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)-mutateRequestToQuery (Delete mainQi logicForest returnings) =-  unwords [-    "WITH " <> ignoredBody,-    "DELETE FROM ", fromQi mainQi,-    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree mainQi) logicForest)) `emptyOnFalse` null logicForest,-    returningF mainQi returnings-    ]--requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Bool -> Maybe PreferParameters -> [FieldName] -> SqlQuery-requestToCallProcQuery qi pgArgs returnsScalar preferParams returnings =-  unwords [-    "WITH",-    argsCTE,-    sourceBody ]-  where-    paramsAsSingleObject    = preferParams == Just SingleObject-    paramsAsMultipleObjects = preferParams == Just MultipleObjects--    (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 paramsAsMultipleObjects-             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-      | paramsAsMultipleObjects =-          if returnsScalar-            then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"-            else unwords [ "SELECT pgrst_lat_args.*"-                         , "FROM pgrst_args,"-                         , "LATERAL ( SELECT " <> returned_columns <> " FROM " <> callIt <> " ) pgrst_lat_args" ]-      | otherwise =-          if returnsScalar-            then "SELECT " <> callIt <> " AS pgrst_scalar"-            else "SELECT " <> returned_columns <> " FROM " <> callIt--    callIt :: SqlFragment-    callIt = fromQi qi <> "(" <> args <> ")"--    returned_columns :: SqlFragment-    returned_columns-      | null returnings = "*"-      | otherwise       = intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings)----- | 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/RangeQuery.hs view
@@ -99,5 +99,5 @@         | totalNotZero && fromInRange = show lower <> "-" <> show upper         | otherwise = "*"       totalString   = maybe "*" show total-      totalNotZero  = maybe True (0 /=) total+      totalNotZero  = Just 0 /= total       fromInRange   = lower <= upper
+ src/PostgREST/Request/ApiRequest.hs view
@@ -0,0 +1,516 @@+{-|+Module      : PostgREST.Request.ApiRequest+Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.+-}+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE MultiWayIf      #-}+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}++module PostgREST.Request.ApiRequest+  ( ApiRequest(..)+  , InvokeMethod(..)+  , ContentType(..)+  , Action(..)+  , Target(..)+  , PayloadJSON(..)+  , userApiRequest+  ) where++import qualified Data.Aeson           as JSON+import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.CaseInsensitive as CI+import qualified Data.Csv             as CSV+import qualified Data.HashMap.Strict  as M+import qualified Data.List            as L+import qualified Data.Set             as S+import qualified Data.Text            as T+import qualified Data.Vector          as V++import Control.Arrow             ((***))+import Data.Aeson.Types          (emptyArray, emptyObject)+import Data.List                 (last, lookup, partition, union)+import Data.List.NonEmpty        (head)+import Data.Maybe                (fromJust)+import Data.Ranged.Boundaries    (Boundary (..))+import Data.Ranged.Ranges        (Range (..), emptyRange,+                                  rangeIntersection)+import Network.HTTP.Base         (urlEncodeVars)+import Network.HTTP.Types.Header (hAuthorization, hCookie)+import Network.HTTP.Types.URI    (parseQueryReplacePlus,+                                  parseSimpleQuery)+import Network.Wai               (Request (..))+import Network.Wai.Parse         (parseHttpAccept)+import Web.Cookie                (parseCookies)++import PostgREST.Config                  (AppConfig (..),+                                          OpenAPIMode (..))+import PostgREST.ContentType             (ContentType (..))+import PostgREST.DbStructure             (DbStructure (..))+import PostgREST.DbStructure.Identifiers (FieldName,+                                          QualifiedIdentifier (..),+                                          Schema)+import PostgREST.DbStructure.Proc        (PgArg (..),+                                          ProcDescription (..),+                                          ProcsMap)+import PostgREST.Error                   (ApiRequestError (..))+import PostgREST.Query.SqlFragment       (ftsOperators, operators)+import PostgREST.RangeQuery              (NonnegRange, allRange,+                                          rangeGeq, rangeLimit,+                                          rangeOffset, rangeRequested,+                                          restrictRange)+import PostgREST.Request.Parsers         (pRequestColumns)+import PostgREST.Request.Preferences     (PreferCount (..),+                                          PreferParameters (..),+                                          PreferRepresentation (..),+                                          PreferResolution (..),+                                          PreferTransaction (..))++import qualified PostgREST.ContentType as ContentType++import Protolude      hiding (head, toS)+import Protolude.Conv (toS)+++type RequestBody = BL.ByteString++data PayloadJSON+  = ProcessedJSON -- ^ Cached attributes of a JSON payload+      { pjRaw  :: BL.ByteString+      -- ^ This is the raw ByteString that comes from the request body.  We+      -- cache this instead of an Aeson Value because it was detected that for+      -- large payloads the encoding had high memory usage, see+      -- https://github.com/PostgREST/postgrest/pull/1005 for more details+      , pjKeys :: S.Set Text+      -- ^ Keys of the object or if it's an array these keys are guaranteed to+      -- be the same across all its objects+      }+  | RawJSON { pjRaw  :: 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{isHead :: Bool}+            | ActionUpdate       | ActionDelete+            | ActionSingleUpsert | ActionInvoke InvokeMethod+            | ActionInfo         | ActionInspect{isHead :: Bool}+            deriving Eq+-- | The path info that will be mapped to a target (used to handle validations and errors before defining the Target)+data Path+  = PathInfo+      { pSchema        :: Schema,+        pName          :: Text,+        pHasRpc        :: Bool,+        pIsDefaultSpec :: Bool,+        pIsRootSpec    :: Bool+      }+  | PathUnknown+-- | The target db object of a user action+data Target = TargetIdent QualifiedIdentifier+            | TargetProc{tProc :: ProcDescription, tpIsRootSpec :: Bool}+            | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/"+            | TargetUnknown++-- | RPC query param value `/rpc/func?v=<value>`, used for VARIADIC functions on form-urlencoded POST and GETs+-- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3.+data RpcParamValue = Fixed Text | Variadic [Text]+instance JSON.ToJSON RpcParamValue where+  toJSON (Fixed    v) = JSON.toJSON v+  toJSON (Variadic v) = JSON.toJSON v++toRpcParamValue :: ProcDescription -> (Text, Text) -> (Text, RpcParamValue)+toRpcParamValue proc (k, v) | argIsVariadic k = (k, Variadic [v])+                            | otherwise       = (k, Fixed v)+  where+    argIsVariadic arg = isJust $ find (\PgArg{pgaName, pgaVar} -> pgaName == arg && pgaVar) $ pdArgs proc++-- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"}+jsonRpcParams :: ProcDescription -> [(Text, Text)] -> PayloadJSON+jsonRpcParams proc prms =+  if not $ pdHasVariadic proc then -- if proc has no variadic arg, save steps and directly convert to json+    ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> prms) (S.fromList $ fst <$> prms)+  else+    let paramsMap = M.fromListWith mergeParams $ toRpcParamValue proc <$> prms in+    ProcessedJSON (JSON.encode paramsMap) (S.fromList $ M.keys paramsMap)+  where+    mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue+    mergeParams (Variadic a) (Variadic b) = Variadic $ b ++ a+    mergeParams v _                       = v -- repeated params for non-variadic arguments are not merged++targetToJsonRpcParams :: Maybe Target -> [(Text, Text)] -> Maybe PayloadJSON+targetToJsonRpcParams target params =+  case target of+    Just TargetProc{tProc} -> Just $ jsonRpcParams tProc params+    _                      -> Nothing++{-|+  Describes what the user wants to do. This data type is a+  translation of the raw elements of an HTTP request into domain+  specific language.  There is no guarantee that the intent is+  sensible, it is up to a later stage of processing to determine+  if it is an action we are able to perform.+-}+data ApiRequest = ApiRequest {+    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+  , 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+  , iPreferTransaction    :: Maybe PreferTransaction          -- ^ Whether the clients wants to commit or rollback the transaction+  , 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              :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and 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              :: [(ByteString, ByteString)]       -- ^ HTTP request headers+  , iCookies              :: [(ByteString, ByteString)]       -- ^ 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.+  , iAcceptContentType    :: ContentType+  }++-- | Examines HTTP request and translates it into user intent.+userApiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest+userApiRequest conf@AppConfig{..} dbStructure req reqBody+  | isJust profile && fromJust profile `notElem` configDbSchemas = Left $ UnacceptableSchema $ toList configDbSchemas+  | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate+  | topLevelRange == emptyRange = Left InvalidRange+  | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload+  | isLeft parsedColumns = either Left witness parsedColumns+  | otherwise = do+     acceptContentType <- findAcceptContentType conf action path accepts+     checkedTarget <- target+     return ApiRequest {+      iAction = action+      , iTarget = checkedTarget+      , iRange = ranges+      , iTopLevelRange = topLevelRange+      , iPayload = relevantPayload+      , iPreferRepresentation = representation+      , 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+      , iPreferTransaction = if | hasPrefer (show Commit)           -> Just Commit+                                | hasPrefer (show Rollback)         -> Just Rollback+                                | otherwise                         -> Nothing+      , iFilters = filters+      , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]+      , iSelect = toS <$> join (lookup "select" qParams)+      , iOnConflict = toS <$> join (lookup "on_conflict" qParams)+      , iColumns = payloadColumns+      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]+      , iCanonicalQS = toS $ urlEncodeVars+        . L.sortOn fst+        . map (join (***) toS . second (fromMaybe BS.empty))+        $ qString+      , iJWT = tokenStr+      , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]+      , iCookies = maybe [] parseCookies $ lookupHeader "Cookie"+      , iPath = rawPathInfo req+      , iMethod = method+      , iProfile = profile+      , iSchema = schema+      , iAcceptContentType = acceptContentType+      }+ where+  accepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept"+  -- queryString with '+' converted to ' '(space)+  qString = parseQueryReplacePlus True $ rawQueryString req+  -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)+  (filters, rpcQParams) =+    case action of+      ActionInvoke 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,+      k `notElem` ["select", "columns"],+      not (endingIn ["order", "limit", "offset", "and", "or"] k) ]+  hasOperator val = any (`T.isPrefixOf` val) $+                      ((<> ".") <$> "not":M.keys operators) +++                      ((<> "(") <$> M.keys ftsOperators)+  isEmbedPath = T.isInfixOf "."+  isTargetingProc = case path of+    PathInfo{pHasRpc, pIsRootSpec} -> pHasRpc || pIsRootSpec+    _                              -> False+  isTargetingDefaultSpec = case path of+    PathInfo{pIsDefaultSpec=True} -> True+    _                             -> False+  contentType = ContentType.decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"+  columns+    | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)+    | otherwise = Nothing+  parsedColumns = pRequestColumns columns+  payloadColumns =+    case (contentType, action) of+      (_, ActionInvoke InvGet)  -> S.fromList $ fst <$> rpcQParams+      (_, ActionInvoke InvHead) -> S.fromList $ fst <$> rpcQParams+      (CTUrlEncoded, _)         -> S.fromList $ map (toS . fst) $ parseSimpleQuery $ toS reqBody+      _ -> case (relevantPayload, fromRight Nothing parsedColumns) of+        (Just ProcessedJSON{pjKeys}, _) -> pjKeys+        (Just RawJSON{}, Just cls)      -> cls+        _                               -> S.empty+  payload = case contentType of+    CTApplicationJSON ->+      if isJust columns+        then Right $ RawJSON reqBody+        else note "All object keys must match" . payloadAttributes reqBody+               =<< if BL.null reqBody && isTargetingProc+                     then Right emptyObject+                     else JSON.eitherDecode reqBody+    CTTextCSV -> do+      json <- csvToJson <$> CSV.decodeByName reqBody+      note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json+    CTUrlEncoded ->+      let paramsMap = M.fromList $ (toS *** JSON.String . toS) <$> parseSimpleQuery (toS reqBody) in+      Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (M.keys paramsMap)+    ct ->+      Left $ toS $ "Content-Type not acceptable: " <> ContentType.toMime ct+  topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows+  action =+    case method of+      -- 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 InvPost+                    else ActionCreate+      "PATCH"   -> ActionUpdate+      "PUT"     -> ActionSingleUpsert+      "DELETE"  -> ActionDelete+      "OPTIONS" -> ActionInfo+      _         -> ActionInspect{isHead=False}++  defaultSchema = head configDbSchemas+  profile+    | length configDbSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config+      = Nothing+    | otherwise = case action of+        -- POST/PATCH/PUT/DELETE don't use the same header as per the spec+        ActionCreate         -> contentProfile+        ActionUpdate         -> contentProfile+        ActionSingleUpsert   -> contentProfile+        ActionDelete         -> contentProfile+        ActionInvoke InvPost -> contentProfile+        _                    -> acceptProfile+    where+      contentProfile = Just $ maybe defaultSchema toS $ lookupHeader "Content-Profile"+      acceptProfile = Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile"+  schema = fromMaybe defaultSchema profile+  target =+    let+      callFindProc procSch procNam = findProc (QualifiedIdentifier procSch procNam) payloadColumns (hasPrefer (show SingleObject)) $ dbProcs dbStructure+    in+    case path of+      PathInfo{pSchema, pName, pHasRpc, pIsRootSpec, pIsDefaultSpec}+        | pHasRpc || pIsRootSpec -> (`TargetProc` pIsRootSpec) <$> callFindProc pSchema pName+        | pIsDefaultSpec         -> Right $ TargetDefaultSpec pSchema+        | otherwise              -> Right $ TargetIdent $ QualifiedIdentifier pSchema pName+      PathUnknown -> Right TargetUnknown++  shouldParsePayload = case (contentType, action) of+    (CTUrlEncoded, ActionInvoke InvPost) -> False+    (_, act)                             -> act `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke InvPost]+  relevantPayload = case (contentType, action) of+    -- Though ActionInvoke GET/HEAD 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)             -> targetToJsonRpcParams (rightToMaybe target) rpcQParams+    (_, ActionInvoke InvHead)            -> targetToJsonRpcParams (rightToMaybe target) rpcQParams+    (CTUrlEncoded, ActionInvoke InvPost) -> targetToJsonRpcParams (rightToMaybe target) $ (toS *** toS) <$> parseSimpleQuery (toS reqBody)+    _ | shouldParsePayload               -> rightToMaybe payload+      | otherwise                        -> Nothing+  path =+    case pathInfo req of+      []             -> case configDbRootSpec of+                          Just (QualifiedIdentifier pSch pName)     -> PathInfo (if pSch == mempty then schema else pSch) pName False False True+                          Nothing | configOpenApiMode == OADisabled -> PathUnknown+                                  | otherwise                       -> PathInfo schema "" False True False+      [table]        -> PathInfo schema table False False False+      ["rpc", pName] -> PathInfo schema pName True False False+      _              -> PathUnknown+  method          = requestMethod req+  hdrs            = requestHeaders req+  qParams         = [(toS k, v)|(k,v) <- qString]+  lookupHeader    = flip lookup hdrs+  hasPrefer :: Text -> Bool+  hasPrefer val   = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs+    where+        split :: BS.ByteString -> [Text]+        split = map T.strip . T.split (==',') . toS+  representation+    | hasPrefer (show Full)        = Full+    | hasPrefer (show None)        = None+    | hasPrefer (show HeadersOnly) = HeadersOnly+    | otherwise                    = None+  auth = fromMaybe "" $ lookupHeader hAuthorization+  tokenStr = case T.split (== ' ') (toS auth) of+    ("Bearer" : t : _) -> t+    ("bearer" : t : _) -> t+    _                  -> ""+  endingIn:: [Text] -> Text -> Bool+  endingIn xx key = lastWord `elem` xx+    where lastWord = last $ T.split (=='.') key++  headerRange = rangeRequested hdrs+  replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]+  limitParams :: M.HashMap ByteString NonnegRange+  limitParams  = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe . toS =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]+  offsetParams :: M.HashMap ByteString NonnegRange+  offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe . toS =<< v)) | (k,v) <- qParams, isJust v, endingIn ["offset"] k]++  urlRange = M.unionWith f limitParams offsetParams+    where+      f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)+        where+          l = fromMaybe 0 $ rangeLimit rl+          o = rangeOffset ro+  ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange++{-|+  Find the best match from a list of content types accepted by the+  client in order of decreasing preference and a list of types+  producible by the server.  If there is no match but the client+  accepts */* then return the top server pick.+-}+mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType+mutuallyAgreeable sProduces cAccepts =+  let exact = listToMaybe $ L.intersect cAccepts sProduces in+  if isNothing exact && CTAny `elem` cAccepts+     then listToMaybe sProduces+     else exact++type CsvData = V.Vector (M.HashMap Text BL.ByteString)++{-|+  Converts CSV like+  a,b+  1,hi+  2,bye++  into a JSON array like+  [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]++  The reason for its odd signature is so that it can compose+  directly with CSV.decodeByName+-}+csvToJson :: (CSV.Header, CsvData) -> JSON.Value+csvToJson (_, vals) =+  JSON.Array $ V.map rowToJsonObj vals+ where+  rowToJsonObj = JSON.Object .+    M.map (\str ->+        if str == "NULL"+          then JSON.Null+          else JSON.String $ toS str+      )++payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON+payloadAttributes raw json =+  -- Test that Array contains only Objects having the same keys+  case json of+    JSON.Array arr ->+      case arr V.!? 0 of+        Just (JSON.Object o) ->+          let canonicalKeys = S.fromList $ M.keys o+              areKeysUniform = all (\case+                JSON.Object x -> S.fromList (M.keys x) == canonicalKeys+                _ -> False) arr in+          if areKeysUniform+            then Just $ ProcessedJSON raw canonicalKeys+            else Nothing+        Just _ -> Nothing+        Nothing -> Just emptyPJArray++    JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ M.keys o)++    -- truncate everything else to an empty array.+    _ -> Just emptyPJArray+  where+    emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty++findAcceptContentType :: AppConfig -> Action -> Path -> [ContentType] -> Either ApiRequestError ContentType+findAcceptContentType conf action path accepts =+  case mutuallyAgreeable (requestContentTypes conf action path) accepts of+    Just ct ->+      Right ct+    Nothing ->+      Left . ContentTypeError $ map ContentType.toMime accepts++requestContentTypes :: AppConfig -> Action -> Path -> [ContentType]+requestContentTypes conf action path =+  case action of+    ActionRead _    -> defaultContentTypes ++ rawContentTypes conf+    ActionInvoke _  -> invokeContentTypes+    ActionInspect _ -> [CTOpenAPI, CTApplicationJSON]+    ActionInfo      -> [CTTextCSV]+    _               -> defaultContentTypes+  where+    invokeContentTypes =+      defaultContentTypes+        ++ rawContentTypes conf+        ++ [CTOpenAPI | pIsRootSpec path]+    defaultContentTypes =+      [CTApplicationJSON, CTSingularJSON, CTTextCSV]++rawContentTypes :: AppConfig -> [ContentType]+rawContentTypes AppConfig{..} =+  (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]++{-|+  Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it.+  An overloaded function can have a different volatility or even a different return type.+-}+findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> Either ApiRequestError ProcDescription+findProc qi payloadKeys paramsAsSingleObject allProcs =+  case bestMatch of+    []     -> Left $ NoRpc (qiSchema qi) (qiName qi) (S.toList payloadKeys) paramsAsSingleObject+    [proc] -> Right proc+    procs  -> Left $ AmbiguousRpc (toList procs)+  where+    bestMatch =+      case M.lookup qi allProcs of+        Nothing     -> []+        Just [proc] -> [proc | matches proc]+        Just procs  -> filter matches procs+    -- Find the exact arguments match+    matches proc+      | paramsAsSingleObject = case pdArgs proc of+                               [arg] -> pgaType arg `elem` ["json", "jsonb"]+                               _     -> False+      | otherwise            = case pdArgs proc of+                               []   -> null payloadKeys+                               args -> matchesArg args+    matchesArg args =+      -- The function's required arguments are separated from the ones with a default value assigned.+      -- The set of names of those arguments is compared to the set of keys supplied by the client+      -- 1. If only required arguments are found, the keys must be exactly the same as those arguments+      -- 2. If only optional arguments are found, the keys must be a subset of those arguments+      -- 3. If both required and optional arguments are found, the result of taking away the optional arguments+      --    from the keys must be exactly the same as the required arguments+      case L.partition pgaReq args of+        (reqArgs, [])      -> payloadKeys == S.fromList (pgaName <$> reqArgs)+        ([], defArgs)      -> payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> defArgs)+        (reqArgs, defArgs) -> payloadKeys `S.difference` S.fromList (pgaName <$> defArgs) == S.fromList (pgaName <$> reqArgs)
+ src/PostgREST/Request/DbRequestBuilder.hs view
@@ -0,0 +1,376 @@+{-|+Module      : PostgREST.Request.DbRequestBuilder+Description : PostgREST database request builder++This module is in charge of building an intermediate+representation(ReadRequest, MutateRequest) between the HTTP request and the+final resulting SQL query.++A query tree is built in case of resource embedding. By inferring the+relationship between tables, join conditions are added for every embedded+resource.+-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE RecordWildCards       #-}++module PostgREST.Request.DbRequestBuilder+  ( readRequest+  , mutateRequest+  , returningCols+  ) where++import qualified Data.HashMap.Strict as M+import qualified Data.Set            as S++import Control.Arrow           ((***))+import Data.Either.Combinators (mapLeft)+import Data.List               (delete)+import Data.Text               (isInfixOf)+import Data.Tree               (Tree (..))++import PostgREST.DbStructure.Identifiers  (FieldName,+                                           QualifiedIdentifier (..),+                                           Schema, TableName)+import PostgREST.DbStructure.Relationship (Cardinality (..),+                                           Junction (..),+                                           Relationship (..))+import PostgREST.DbStructure.Table        (Column (..), Table (..),+                                           tableQi)+import PostgREST.Error                    (ApiRequestError (..),+                                           Error (..))+import PostgREST.Query.SqlFragment        (sourceCTEName)+import PostgREST.RangeQuery               (NonnegRange, allRange,+                                           restrictRange)+import PostgREST.Request.ApiRequest       (Action (..),+                                           ApiRequest (..),+                                           PayloadJSON (..))++import PostgREST.Request.Parsers+import PostgREST.Request.Preferences+import PostgREST.Request.Types++import qualified PostgREST.DbStructure.Relationship as Relationship++import Protolude hiding (from)++-- | Builds the ReadRequest tree on a number of stages.+-- | Adds filters, order, limits on its respective nodes.+-- | Adds joins conditions obtained from resource embedding.+readRequest :: Schema -> TableName -> Maybe Integer -> [Relationship] -> ApiRequest -> Either Error ReadRequest+readRequest schema rootTableName maxRows allRels apiRequest  =+  mapLeft ApiRequestError $+  treeRestrictRange maxRows =<<+  augmentRequestWithJoin schema rootRels =<<+  (addFiltersOrdersRanges apiRequest . initReadRequest rootName =<< pRequestSelect sel)+  where+    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)++-- 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 -> [Relationship] -> Action -> (QualifiedIdentifier, [Relationship])+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+    _sourceCTEName = decodeUtf8 sourceCTEName+    -- To enable embedding in the sourceCTEName cases we need to replace the+    -- foreign key tableName in the Relationship with {sourceCTEName}. This way+    -- findRel can find relationships with sourceCTEName.+    toSourceRel :: Relationship -> Maybe Relationship+    toSourceRel r@Relationship{relTable=t}+      | rootTableName == tableName t = Just $ r {relTable=t {tableName=_sourceCTEName}}+      | 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++-- | Enforces the `max-rows` config on the result+treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest+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)++augmentRequestWithJoin :: Schema -> [Relationship] -> ReadRequest -> Either ApiRequestError ReadRequest+augmentRequestWithJoin schema allRels request =+  addRels schema allRels Nothing request+  >>= addJoinConditions Nothing++addRels :: Schema -> [Relationship] -> 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=parentNodeQi}, _) _) ->+      let newFrom r = if qiName tbl == nodeName then tableQi (relForeignTable r) else tbl+          newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel+          rel = findRel schema allRels (qiName parentNodeQi) nodeName hint+      in+      Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest)+    _ ->+      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 = addRels schema allRels rq `traverse` forest++-- 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 -> [Relationship] -> NodeName -> NodeName -> Maybe EmbedHint -> Either ApiRequestError Relationship+findRel schema allRels origin target hint =+  case rel of+    []  -> Left $ NoRelBetween origin target+    [r] -> Right r+    -- 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.+    rs@[rel0, rel1]  -> case (relCardinality rel0, relCardinality rel1, relTable rel0 == relTable rel1 && relForeignTable rel0 == relForeignTable rel1) of+      (O2M cons1, M2O cons2, True) -> if cons1 == cons2 then Right rel0 else Left $ AmbiguousRelBetween origin target rs+      (M2O cons1, O2M cons2, True) -> if cons1 == cons2 then Right rel1 else Left $ AmbiguousRelBetween origin target rs+      _                            -> Left $ AmbiguousRelBetween origin target rs+    rs -> Left $ AmbiguousRelBetween origin target rs+  where+    matchFKSingleCol hint_ cols = length cols == 1 && hint_ == (colName <$> head cols)+    matchConstraint tar card = case card of+      O2M cons -> tar == Just cons+      M2O cons -> tar == Just cons+      _        -> False+    matchJunction hint_ card = case card of+      M2M Junction{junTable} -> hint_ == Just (tableName junTable)+      _                      -> False+    rel = filter (+      \Relationship{..} ->+        -- Both relationship ends need to be on the exposed schema+        schema == tableSchema relTable && schema == tableSchema relForeignTable &&+        (+          -- /projects?select=clients(*)+          origin == tableName relTable  &&  -- projects+          target == tableName relForeignTable ||  -- clients++          -- /projects?select=projects_client_id_fkey(*)+          (+            origin == tableName relTable &&              -- projects+            matchConstraint (Just target) relCardinality -- projects_client_id_fkey+          ) ||+          -- /projects?select=client_id(*)+          (+            origin == tableName relTable &&           -- projects+            matchFKSingleCol (Just target) relColumns -- client_id+          )+        ) && (+          isNothing hint || -- hint is optional++          -- /projects?select=clients!projects_client_id_fkey(*)+          matchConstraint hint relCardinality || -- projects_client_id_fkey++          -- /projects?select=clients!client_id(*) or /projects?select=clients!id(*)+          matchFKSingleCol hint relColumns  || -- client_id+          matchFKSingleCol hint relForeignColumns || -- id++          -- /users?select=tasks!users_tasks(*) many-to-many between users and tasks+          matchJunction hint relCardinality -- users_tasks+        )+      ) allRels++-- previousAlias is only used for the case of self joins+addJoinConditions :: Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest+addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, rel, _, _, depth)) forest) =+  case rel of+    Just r@Relationship{relCardinality=M2M Junction{junTable}} ->+      let rq = augmentQuery r in+      Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest+    Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest+    Nothing -> Node node <$> updatedForest+  where+    newAlias = case Relationship.isSelfReference <$> rel of+      Just True+        | depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased+        | otherwise  -> Nothing+      _              -> Nothing+    augmentQuery r =+      foldr+        (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs})+        query{fromAlias=newAlias}+        (getJoinConditions previousAlias newAlias r)+    updatedForest = addJoinConditions newAlias `traverse` forest++-- previousAlias and newAlias are used in the case of self joins+getJoinConditions :: Maybe Alias -> Maybe Alias -> Relationship -> [JoinCondition]+getJoinConditions previousAlias newAlias (Relationship Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols card) =+  case card of+    M2M (Junction Table{tableName=jtn} _ jc1 _ jc2) ->+      zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2+    _ ->+      zipWith (toJoinCondition tN ftN) cols fCols+  where+    toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition+    toJoinCondition tb ftb c 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 == decodeUtf8 sourceCTEName then mempty else schema) tbl++addFiltersOrdersRanges :: ApiRequest -> ReadRequest -> Either ApiRequestError ReadRequest+addFiltersOrdersRanges apiRequest rReq = do+  rFlts <- foldr addFilter rReq <$> filters+  rOrds <- foldr addOrder rFlts <$> orders+  rRngs <- foldr addRange rOrds <$> ranges+  foldr addLogicTree rRngs      <$> logicForest+  where+    filters :: Either ApiRequestError [(EmbedPath, Filter)]+    filters = pRequestFilter `traverse` flts+    orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]+    orders = pRequestOrder `traverse` iOrder apiRequest+    ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]+    ranges = pRequestRange `traverse` M.toList (iRange apiRequest)+    logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)]+    logicForest = pRequestLogicTree `traverse` logFrst+    action = iAction apiRequest+    -- there can be no filters on the root table when we are doing insert/update/delete+    (flts, logFrst) =+      case action of+        ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest)+        ActionRead _   -> (iFilters apiRequest, iLogic apiRequest)+        _              -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)++addFilterToNode :: Filter -> ReadRequest -> ReadRequest+addFilterToNode flt (Node (q@Select {where_=lf}, i) f) = Node (q{where_=addFilterToLogicForest flt lf}::ReadQuery, i) f++addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest+addFilter = addProperty addFilterToNode++addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest+addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f++addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest+addOrder = addProperty addOrderToNode++addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest+addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f++addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest+addRange = addProperty addRangeToNode++addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest+addLogicTreeToNode t (Node (q@Select{where_=lf},i) f) = Node (q{where_=t:lf}::ReadQuery, i) f++addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest+addLogicTree = addProperty addLogicTreeToNode++addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest+addProperty f ([], a) rr = f a rr+addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =+  case pathNode of+    Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path+    Just tn -> Node rn (addProperty f (remainingPath, a) tn:delete tn forest)+  where+    pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest++mutateRequest :: Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Error MutateRequest+mutateRequest schema tName apiRequest pkCols readReq = mapLeft ApiRequestError $+  case action of+    ActionCreate -> do+        confCols <- case iOnConflict apiRequest of+            Nothing    -> pure pkCols+            Just param -> pRequestOnConflict param+        pure $ Insert qi (iColumns apiRequest) body ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings+    ActionUpdate -> Update qi (iColumns apiRequest) body  <$> combinedLogic <*> pure returnings+    ActionSingleUpsert ->+      (\flts ->+        if null (iLogic apiRequest) &&+           S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols &&+           not (null (S.fromList pkCols)) &&+           all (\case+              Filter _ (OpExpr False (Op "eq" _)) -> True+              _                                   -> False) flts+          then Insert qi (iColumns apiRequest) body (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings+        else+          Left InvalidFilters) =<< filters+    ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings+    _            -> Left UnsupportedVerb+  where+    qi = QualifiedIdentifier schema tName+    action = iAction apiRequest+    returnings =+      if iPreferRepresentation apiRequest == None+        then []+        else returningCols readReq pkCols+    filters = map snd <$> pRequestFilter `traverse` mutateFilters+    logic = map snd <$> pRequestLogicTree `traverse` logicFilters+    combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters+    -- update/delete filters can be only on the root table+    (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest)+    onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)+    body = pjRaw <$> iPayload apiRequest++returningCols :: ReadRequest -> [FieldName] -> [FieldName]+returningCols rr@(Node _ forest) pkCols+  -- if * is part of the select, we must not add pk or fk columns manually -+  -- otherwise those would be selected and output twice+  | "*" `elem` fldNames = ["*"]+  | otherwise           = returnings+  where+    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`.+    fkCols = concat $ mapMaybe (\case+        Node (_, (_, Just Relationship{relColumns=cols}, _, _, _)) _ -> 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: We are adding the primary key columns as well to+    -- make sure, that a proper location header can always be built for+    -- INSERT/POST+    returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols) ++ pkCols++-- Traditional filters(e.g. id=eq.1) are added as root nodes of the LogicTree+-- they are later concatenated with AND in the QueryBuilder+addFilterToLogicForest :: Filter -> [LogicTree] -> [LogicTree]+addFilterToLogicForest flt lf = Stmnt flt : lf
+ src/PostgREST/Request/Parsers.hs view
@@ -0,0 +1,276 @@+{-|+Module      : PostgREST.Request.Parsers+Description : PostgREST parser combinators++This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.+-}+module PostgREST.Request.Parsers+  ( pColumns+  , pLogicPath+  , pLogicSingleVal+  , pLogicTree+  , pOrder+  , pOrderTerm+  , pRequestColumns+  , pRequestFilter+  , pRequestLogicTree+  , pRequestOnConflict+  , pRequestOrder+  , pRequestRange+  , pRequestSelect+  , pSingleVal+  , pTreePath+  ) where++import qualified Data.HashMap.Strict as M+import qualified Data.Set            as S++import Data.Either.Combinators       (mapLeft)+import Data.Foldable                 (foldl1)+import Data.List                     (init, last)+import Data.Text                     (intercalate, replace, strip)+import Data.Tree                     (Tree (..))+import Text.Parsec.Error             (errorMessages,+                                      showErrorMessages)+import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,+                                      anyChar, between, char, digit,+                                      eof, errorPos, letter,+                                      lookAhead, many1, noneOf,+                                      notFollowedBy, oneOf, option,+                                      optionMaybe, parse, sepBy1,+                                      string, try, (<?>))++import PostgREST.DbStructure.Identifiers (FieldName)+import PostgREST.Error                   (ApiRequestError (ParseRequestError))+import PostgREST.Query.SqlFragment       (ftsOperators, operators)+import PostgREST.RangeQuery              (NonnegRange)++import PostgREST.Request.Types++import Protolude      hiding (intercalate, option, replace, toS, try)+import Protolude.Conv (toS)++pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]+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+    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k+    oper = parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v+    path = fst <$> treePath+    fld = snd <$> treePath++pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm])+pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'+  where+    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k+    path = fst <$> treePath+    ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v++pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange)+pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v+  where+    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k+    path = fst <$> treePath++pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree)+pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree+  where+    path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k+    embedPath = fst <$> path+    logicTree = do+      op <- snd <$> path+      -- Concat op and v to make pLogicTree argument regular,+      -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"+      parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v)++pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName))+pRequestColumns colStr =+  case colStr of+    Just str ->+      mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)+    _ -> Right Nothing++ws :: Parser Text+ws = toS <$> many (oneOf " \t")++lexeme :: Parser a -> Parser a+lexeme p = ws *> p <* ws++pTreePath :: Parser (EmbedPath, Field)+pTreePath = do+  p <- pFieldName `sepBy1` pDelimiter+  jp <- option [] pJsonPath+  return (init p, (last p, jp))++pFieldForest :: Parser [Tree SelectItem]+pFieldForest = pFieldTree `sepBy1` lexeme (char ',')+  where+    pFieldTree :: Parser (Tree SelectItem)+    pFieldTree =  try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|>+                  Node <$> pFieldSelect <*> pure []++pStar :: Parser Text+pStar = toS <$> (string "*" $> ("*"::ByteString))++pFieldName :: Parser Text+pFieldName =+  pQuotedValue <|>+  intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) <?>+  "field name (* or [a..z0..9_])"+  where+    isDash :: GenParser Char st ()+    isDash = try ( char '-' >> notFollowedBy (char '>') )+    dash :: Parser Char+    dash = isDash $> '-'++pJsonPath :: Parser JsonPath+pJsonPath = many pJsonOperation+  where+    pJsonOperation :: Parser JsonOperation+    pJsonOperation = pJsonArrow <*> pJsonOperand++    pJsonArrow   =+      try (string "->>" $> J2Arrow) <|>+      try (string "->" $> JArrow)++    pJsonOperand =+      let pJKey = JKey . toS <$> pFieldName+          pJIdx = JIdx . toS <$> ((:) <$> option '+' (char '-') <*> many1 digit) <* pEnd+          pEnd = try (void $ lookAhead (string "->")) <|>+                 try (void $ lookAhead (string "::")) <|>+                 try eof in+      try pJIdx <|> try pJKey++pField :: Parser Field+pField = lexeme $ (,) <$> pFieldName <*> option [] pJsonPath++aliasSeparator :: Parser ()+aliasSeparator = char ':' >> notFollowedBy (char ':')++pRelationSelect :: Parser SelectItem+pRelationSelect = lexeme $ try ( do+    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )+    fld <- pField+    hint <- optionMaybe (+        try ( char '!' *> pFieldName) <|>+        -- deprecated, remove in next major version+        try ( char '.' *> pFieldName)+      )+    return (fld, Nothing, alias, hint)+  )++pFieldSelect :: Parser SelectItem+pFieldSelect = lexeme $+  try (+    do+      alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )+      fld <- pField+      cast' <- optionMaybe (string "::" *> many letter)+      return (fld, toS <$> cast', alias, Nothing)+  )+  <|> do+    s <- pStar+    return ((s, []), Nothing, Nothing, Nothing)++pOpExpr :: Parser SingleVal -> Parser OpExpr+pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation+  where+    pOperation :: Parser Operation+    pOperation =+          Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal+      <|> In <$> (try (string "in" *> pDelimiter) *> pListVal)+      <|> pFts+      <?> "operator (eq, gt, ...)"++    pFts = do+      op   <- foldl1 (<|>) (try . string . toS <$> ftsOps)+      lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_")))+      pDelimiter >> Fts (toS op) (toS <$> lang) <$> pSVal++    ops = M.filterWithKey (const . flip notElem ("in":ftsOps)) operators+    ftsOps = M.keys ftsOperators++pSingleVal :: Parser SingleVal+pSingleVal = toS <$> many anyChar++pListVal :: Parser ListVal+pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')++pListElement :: Parser Text+pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)"))++pQuotedValue :: Parser Text+pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"')++pDelimiter :: Parser Char+pDelimiter = char '.' <?> "delimiter (.)"++pOrder :: Parser [OrderTerm]+pOrder = lexeme pOrderTerm `sepBy1` char ','++pOrderTerm :: Parser OrderTerm+pOrderTerm = do+  fld <- pField+  dir <- optionMaybe $+         try (pDelimiter *> string "asc" $> OrderAsc) <|>+         try (pDelimiter *> string "desc" $> OrderDesc)+  nls <- optionMaybe pNulls <* pEnd <|>+         pEnd $> Nothing+  return $ OrderTerm fld dir nls+  where+    pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>+             try (pDelimiter *> string "nullslast"  $> OrderNullsLast)+    pEnd = try (void $ lookAhead (char ',')) <|>+           try eof++pLogicTree :: Parser LogicTree+pLogicTree = Stmnt <$> try pLogicFilter+             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')'))+  where+    pLogicFilter :: Parser Filter+    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal+    pNot :: Parser Bool+    pNot = try (string "not" *> pDelimiter $> True)+           <|> pure False+           <?> "negation operator (not)"+    pLogicOp :: Parser LogicOperator+    pLogicOp = try (string "and" $> And)+               <|> string "or" $> Or+               <?> "logic operator (and, or)"++pLogicSingleVal :: Parser SingleVal+pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)"))+  where+    pPgArray :: Parser Text+    pPgArray =  do+      a <- string "{"+      b <- many (noneOf "{}")+      c <- string "}"+      pure (toS $ a ++ b ++ c)++pLogicPath :: Parser (EmbedPath, Text)+pLogicPath = do+  path <- pFieldName `sepBy1` pDelimiter+  let op = last path+      notOp = "not." <> op+  return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)++pColumns :: Parser [FieldName]+pColumns = pFieldName `sepBy1` lexeme (char ',')++mapError :: Either ParseError a -> Either ApiRequestError a+mapError = mapLeft translateError+  where+    translateError e =+      ParseRequestError message details+      where+        message = show $ errorPos e+        details = strip $ replace "\n" " " $ toS+           $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
+ src/PostgREST/Request/Preferences.hs view
@@ -0,0 +1,54 @@+module PostgREST.Request.Preferences where++import GHC.Show+import Protolude+++data PreferResolution+  = MergeDuplicates+  | IgnoreDuplicates++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 = "return=headers-only"++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 PreferTransaction+  = Commit   -- Commit transaction - the default.+  | Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests.+  deriving Eq++instance Show PreferTransaction where+  show Commit   = "tx=commit"+  show Rollback = "tx=rollback"
+ src/PostgREST/Request/Types.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DuplicateRecordFields #-}+module PostgREST.Request.Types+  ( Alias+  , Depth+  , EmbedHint+  , EmbedPath+  , Field+  , Filter(..)+  , JoinCondition(..)+  , JsonOperand(..)+  , JsonOperation(..)+  , JsonPath+  , ListVal+  , LogicOperator(..)+  , LogicTree(..)+  , MutateQuery(..)+  , MutateRequest+  , NodeName+  , OpExpr(..)+  , Operation (..)+  , OrderDirection(..)+  , OrderNulls(..)+  , OrderTerm(..)+  , ReadNode+  , ReadQuery(..)+  , ReadRequest+  , SelectItem+  , SingleVal+  , fstFieldNames+  ) where++import qualified Data.ByteString.Lazy as BL+import qualified Data.Set             as S++import Data.Tree (Tree (..))++import qualified GHC.Show (show)++import PostgREST.DbStructure.Identifiers  (FieldName,+                                           QualifiedIdentifier)+import PostgREST.DbStructure.Relationship (Relationship)+import PostgREST.RangeQuery               (NonnegRange)+import PostgREST.Request.Preferences      (PreferResolution)++import Protolude+++type ReadRequest = Tree ReadNode+type MutateRequest = MutateQuery++type ReadNode =+  (ReadQuery, (NodeName, Maybe Relationship, Maybe Alias, Maybe EmbedHint, Depth))++type NodeName = Text+type Depth = Integer++data ReadQuery = Select+  { select         :: [SelectItem]+  , 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  :: [QualifiedIdentifier]+  , where_         :: [LogicTree]+  , joinConditions :: [JoinCondition]+  , order          :: [OrderTerm]+  , range_         :: NonnegRange+  }+  deriving (Eq)++data JoinCondition =+  JoinCondition+    (QualifiedIdentifier, FieldName)+    (QualifiedIdentifier, FieldName)+  deriving (Eq)++data OrderTerm = OrderTerm+  { otTerm      :: Field+  , otDirection :: Maybe OrderDirection+  , otNullOrder :: Maybe OrderNulls+  }+  deriving (Eq)++data OrderDirection+  = OrderAsc+  | OrderDesc+  deriving (Eq)++instance Show OrderDirection where+  show OrderAsc  = "ASC"+  show OrderDesc = "DESC"++data OrderNulls+  = OrderNullsFirst+  | OrderNullsLast+  deriving (Eq)++instance Show OrderNulls where+  show OrderNullsFirst = "NULLS FIRST"+  show OrderNullsLast  = "NULLS LAST"++data MutateQuery+  = Insert+      { in_        :: QualifiedIdentifier+      , insCols    :: S.Set FieldName+      , insBody    :: Maybe BL.ByteString+      , onConflict :: Maybe (PreferResolution, [FieldName])+      , where_     :: [LogicTree]+      , returning  :: [FieldName]+      }+  | Update+      { in_       :: QualifiedIdentifier+      , updCols   :: S.Set FieldName+      , updBody   :: Maybe BL.ByteString+      , where_    :: [LogicTree]+      , returning :: [FieldName]+      }+  | Delete+      { in_       :: QualifiedIdentifier+      , where_    :: [LogicTree]+      , returning :: [FieldName]+      }++-- | The select value in `/tbl?select=alias:field::cast`+type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)++type Field = (FieldName, JsonPath)+type Cast = Text+type Alias = Text++-- | 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]++-- | Json path operations as specified in+-- https://www.postgresql.org/docs/current/static/functions-json.html+type JsonPath = [JsonOperation]++-- | Represents the single arrow `->` or double arrow `->>` operators+data JsonOperation+  = JArrow { jOp :: JsonOperand }+  | J2Arrow { jOp :: JsonOperand }+  deriving (Eq)++-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text+-- because we reuse our escaping functons and let pg do the casting with+-- '1'::int+data JsonOperand+  = JKey { jVal :: Text }+  | JIdx { jVal :: Text }+  deriving (Eq)++-- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))+fstFieldNames :: ReadRequest -> [FieldName]+fstFieldNames (Node (sel, _) _) =+  fst . (\(f, _, _, _) -> f) <$> select sel+++-- | Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:+--+--            And+--           /   \+--  name.eq.N     Or+--               /  \+--         id.eq.1   id.eq.2+data LogicTree+  = Expr Bool LogicOperator [LogicTree]+  | Stmnt Filter+  deriving (Eq)++data LogicOperator+  = And+  | Or+  deriving Eq++instance Show LogicOperator where+  show And = "AND"+  show Or  = "OR"++data Filter = Filter+  { field  :: Field+  , opExpr :: OpExpr+  }+  deriving (Eq)++data OpExpr =+  OpExpr Bool Operation+  deriving (Eq)++data Operation+  = Op Operator SingleVal+  | In ListVal+  | Fts Operator (Maybe Language) SingleVal+  deriving (Eq)++type Operator = Text+type Language = Text++-- | Represents a single value in a filter, e.g. id=eq.singleval+type SingleVal = Text++-- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)+type ListVal = [Text]
− src/PostgREST/Statements.hs 
@@ -1,183 +0,0 @@-{-|-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 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, toS)-import           Protolude.Conv                  (toS)-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 ({selectF}) _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--  selectF-    -- prevent using any of the column names in ?select= when no response is returned from the CTE-    | rep `elem` [None, HeadersOnly] = "SELECT * FROM " <> sourceCTEName-    | otherwise                      = selectQuery--  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 
@@ -1,537 +0,0 @@-{-|-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)-import qualified Data.ByteString.Lazy     as BL-import qualified Data.CaseInsensitive     as CI-import qualified Data.HashMap.Strict      as M-import qualified Data.Set                 as S-import qualified GHC.Show--import Network.HTTP.Types.Header (Header, hContentType)--import Data.Tree--import PostgREST.RangeQuery (NonnegRange)-import Protolude            hiding (toS)-import Protolude.Conv       (toS)---- | Enumeration of currently supported response content types-data ContentType = CTApplicationJSON | CTSingularJSON-                 | CTTextCSV | CTTextPlain-                 | CTOpenAPI | CTOctetStream-                 | CTAny | CTOther ByteString deriving (Show, Eq)---- | Convert from ContentType to a full HTTP Header-toHeader :: ContentType -> Header-toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")---- | Convert from ContentType to a ByteString representing the mime type-toMime :: ContentType -> ByteString-toMime CTApplicationJSON = "application/json"-toMime CTTextCSV         = "text/csv"-toMime CTTextPlain       = "text/plain"-toMime CTOpenAPI         = "application/openapi+json"-toMime CTSingularJSON    = "application/vnd.pgrst.object+json"-toMime CTOctetStream     = "application/octet-stream"-toMime CTAny             = "*/*"-toMime (CTOther ct)      = ct---- | Convert from ByteString to ContentType. Warning: discards MIME parameters-decodeContentType :: BS.ByteString -> ContentType-decodeContentType ct = case BS.takeWhile (/= BS.c2w ';') ct of-  "application/json"                  -> CTApplicationJSON-  "text/csv"                          -> CTTextCSV-  "text/plain"                        -> CTTextPlain-  "application/openapi+json"          -> CTOpenAPI-  "application/vnd.pgrst.object+json" -> CTSingularJSON-  "application/vnd.pgrst.object"      -> CTSingularJSON-  "application/octet-stream"          -> CTOctetStream-  "*/*"                               -> 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]-, dbProcs       :: ProcsMap-, pgVersion     :: PgVersion-} deriving (Show, Eq)---- TODO Table could hold references to all its Columns-tableCols :: DbStructure -> Schema -> TableName -> [Column]-tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs---- TODO Table could hold references to all its PrimaryKeys-tablePKCols :: DbStructure -> Schema -> TableName -> [Text]-tablePKCols dbs tSchema tName =  pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)--data PgArg = PgArg {-  pgaName :: Text-, pgaType :: Text-, pgaReq  :: Bool-} deriving (Show, Eq, Ord)--data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show, Ord)--data RetType = Single PgType | SetOf PgType deriving (Eq, Show, Ord)--data ProcVolatility = Volatile | Stable | Immutable-  deriving (Eq, Show, Ord)--data ProcDescription = ProcDescription {-  pdSchema      :: Schema-, pdName        :: Text-, pdDescription :: Maybe Text-, pdArgs        :: [PgArg]-, pdReturnType  :: RetType-, pdVolatility  :: ProcVolatility-} deriving (Show, Eq)---- Order by least number of args in the case of overloaded functions-instance Ord ProcDescription where-  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 -> ProcsMap -> Maybe ProcDescription-findProc qi payloadKeys paramsAsSingleObject allProcs =-  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-  where-    matches proc =-      if paramsAsSingleObject-        -- if the arg is not of json type let the db give the err-        then length (pdArgs proc) == 1-        else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)--{-|-  Search the procedure parameters by matching them with the specified keys.-  If the key doesn't match a parameter, a parameter with a default type "text" is assumed.--}-specifiedProcArgs :: S.Set FieldName -> Maybe ProcDescription -> [PgArg]-specifiedProcArgs keys proc =-  let-    args = maybe [] pdArgs proc-  in-  (\k -> fromMaybe (PgArg k "text" True) (find ((==) k . pgaName) args)) <$> S.toList keys--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--data Table = Table {-  tableSchema      :: Schema-, tableName        :: TableName-, tableDescription :: Maybe Text-, tableInsertable  :: Bool-} deriving (Show, Ord)--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 =-    Column {-      colTable       :: Table-    , colName        :: FieldName-    , colDescription :: Maybe Text-    , colPosition    :: Int32-    , colNullable    :: Bool-    , colType        :: Text-    , colUpdatable   :: Bool-    , colMaxLen      :: Maybe Int32-    , colPrecision   :: Maybe Int32-    , colDefault     :: Maybe Text-    , colEnum        :: [Text]-    , colFK          :: Maybe ForeignKey-    } deriving (Show, Ord)--instance Eq Column where-  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2---- | The source table column a view column refers to-type SourceColumn = (Column, ViewColumn)-type ViewColumn = Column--data PrimaryKey = PrimaryKey {-    pkTable :: Table-  , pkName  :: Text-} deriving (Show, Eq)--data OrderDirection = OrderAsc | OrderDesc deriving (Eq)-instance Show OrderDirection where-  show OrderAsc  = "ASC"-  show OrderDesc = "DESC"--data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq)-instance Show OrderNulls where-  show OrderNullsFirst = "NULLS FIRST"-  show OrderNullsLast  = "NULLS LAST"--data OrderTerm = OrderTerm {-  otTerm      :: Field-, otDirection :: Maybe OrderDirection-, otNullOrder :: Maybe OrderNulls-} deriving (Show, Eq)--{-|-  Represents a pg identifier with a prepended schema name "schema.table"-  When qiSchema is "", the schema is defined by the pg search_path--}-data QualifiedIdentifier = QualifiedIdentifier {-  qiSchema :: Schema-, qiName   :: TableName-} 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"--type ConstraintName = Text--{-|-  "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]-, 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)---- | 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 {-    -- | This is the raw ByteString that comes from the request body.-    -- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding-    -- had high memory usage, see https://github.com/PostgREST/postgrest/pull/1005 for more details-    pjRaw  :: BL.ByteString-    -- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects-  , pjKeys :: S.Set Text-  }|-  RawJSON {-    pjRaw  :: BL.ByteString-  } deriving (Show, Eq)--data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq)--data Proxy = Proxy {-  proxyScheme :: Text-, proxyHost   :: Text-, proxyPort   :: Integer-, proxyPath   :: Text-} deriving (Show, Eq)--type Operator = Text-operators :: M.HashMap Operator SqlFragment-operators = M.union (M.fromList [-  ("eq", "="),-  ("gte", ">="),-  ("gt", ">"),-  ("lte", "<="),-  ("lt", "<"),-  ("neq", "<>"),-  ("like", "LIKE"),-  ("ilike", "ILIKE"),-  ("in", "IN"),-  ("is", "IS"),-  ("cs", "@>"),-  ("cd", "<@"),-  ("ov", "&&"),-  ("sl", "<<"),-  ("sr", ">>"),-  ("nxr", "&<"),-  ("nxl", "&>"),-  ("adj", "-|-")]) ftsOperators--ftsOperators :: M.HashMap Operator SqlFragment-ftsOperators = M.fromList [-  ("fts", "@@ to_tsquery"),-  ("plfts", "@@ plainto_tsquery"),-  ("phfts", "@@ phraseto_tsquery"),-  ("wfts", "@@ websearch_to_tsquery")-  ]--data OpExpr = OpExpr Bool Operation deriving (Eq, Show)-data Operation = Op Operator SingleVal |-                 In ListVal |-                 Fts Operator (Maybe Language) SingleVal deriving (Eq, Show)-type Language = Text---- | Represents a single value in a filter, e.g. id=eq.singleval-type SingleVal = Text--- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)-type ListVal = [Text]--data LogicOperator = And | Or deriving Eq-instance Show LogicOperator where-  show And = "AND"-  show Or  = "OR"-{-|-  Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:--            And-           /   \-  name.eq.N     Or-               /  \-         id.eq.1   id.eq.2--}-data LogicTree = Expr Bool LogicOperator [LogicTree] | Stmnt Filter deriving (Show, Eq)--type FieldName = Text-{-|-  Json path operations as specified in https://www.postgresql.org/docs/9.4/static/functions-json.html--}-type JsonPath = [JsonOperation]--- | Represents the single arrow `->` or double arrow `->>` operators-data JsonOperation = JArrow{jOp :: JsonOperand} | J2Arrow{jOp :: JsonOperand} deriving (Show, Eq)--- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text because we reuse our escaping functons and let pg do the casting with '1'::int-data JsonOperand = JKey{jVal :: Text} | JIdx{jVal :: Text} deriving (Show, Eq)--type Field = (FieldName, JsonPath)-type Alias = Text-type Cast = Text-type NodeName = Text---- Rpc query param, only used for GET rpcs-type RpcQParam = (Text, Text)--{-|-  Custom guc header, it's obtained by parsing the json in a:-  `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'--}-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 (CI.mk $ toS k, toS s)-                            | otherwise     -> mzero-    _ -> mzero-  parseJSON _          = mzero--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 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)-data JoinCondition = JoinCondition (QualifiedIdentifier, FieldName)-                                   (QualifiedIdentifier, FieldName) deriving (Show, Eq)--data ReadQuery = Select {-    select         :: [SelectItem]-  , 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  :: [QualifiedIdentifier]-  , where_         :: [LogicTree]-  , joinConditions :: [JoinCondition]-  , order          :: [OrderTerm]-  , range_         :: NonnegRange-} deriving (Show, Eq)--data MutateQuery =-  Insert {-    in_        :: QualifiedIdentifier-  , insCols    :: S.Set FieldName-  , onConflict :: Maybe (PreferResolution, [FieldName])-  , where_     :: [LogicTree]-  , returning  :: [FieldName]-  }|-  Update {-    in_       :: QualifiedIdentifier-  , updCols   :: S.Set FieldName-  , where_    :: [LogicTree]-  , returning :: [FieldName]-  }|-  Delete {-    in_       :: QualifiedIdentifier-  , where_    :: [LogicTree]-  , returning :: [FieldName]-  } deriving (Show, Eq)--type ReadRequest = Tree ReadNode-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-} deriving (Eq, Show)--instance Ord PgVersion where-  (PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2---- | Tells the minimum PostgreSQL version required by this version of PostgREST-minimumPgVersion :: PgVersion-minimumPgVersion = pgVersion94--pgVersion94 :: PgVersion-pgVersion94 = PgVersion 90400 "9.4"--pgVersion95 :: PgVersion-pgVersion95 = PgVersion 90500 "9.5"--pgVersion96 :: PgVersion-pgVersion96 = PgVersion 90600 "9.6"--pgVersion100 :: PgVersion-pgVersion100 = PgVersion 100000 "10"--pgVersion109 :: PgVersion-pgVersion109 = PgVersion 100009 "10.9"--pgVersion110 :: PgVersion-pgVersion110 = PgVersion 110000 "11.0"--pgVersion112 :: PgVersion-pgVersion112 = PgVersion 110002 "11.2"--pgVersion114 :: PgVersion-pgVersion114 = PgVersion 110004 "11.4"--pgVersion121 :: PgVersion-pgVersion121 = PgVersion 120001 "12.1"--sourceCTEName :: SqlFragment-sourceCTEName = "pgrst_source"---- | full jspath, e.g. .property[0].attr.detail-type JSPath = [JSPathExp]--- | jspath expression, e.g. .property, .property[0] or ."property-dash"-data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show)---- | Current database connection status data ConnectionStatus-data ConnectionStatus-  = NotConnected-  | Connected PgVersion-  | FatalConnectionError Text-  deriving (Eq, Show)
+ src/PostgREST/Unix.hs view
@@ -0,0 +1,59 @@+module PostgREST.Unix+  ( runAppWithSocket+  , installSignalHandlers+  ) where++import qualified Network.Socket           as Socket+import qualified Network.Wai.Handler.Warp as Warp+import qualified System.Posix.Signals     as Signals++import Network.Wai        (Application)+import System.Directory   (removeFile)+import System.IO.Error    (isDoesNotExistError)+import System.Posix.Files (setFileMode)+import System.Posix.Types (FileMode)++import qualified PostgREST.AppState as AppState+import qualified PostgREST.Workers  as Workers++import Protolude+++-- | Run the PostgREST application with user defined socket.+runAppWithSocket :: Warp.Settings -> Application -> FileMode -> FilePath -> IO ()+runAppWithSocket settings app socketFileMode socketFilePath =+  bracket createAndBindSocket Socket.close $ \socket -> do+    Socket.listen socket Socket.maxListenQueue+    Warp.runSettingsSocket settings socket app+  where+    createAndBindSocket = do+      deleteSocketFileIfExist socketFilePath+      sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol+      Socket.bind sock $ Socket.SockAddrUnix socketFilePath+      setFileMode socketFilePath socketFileMode+      return sock++    deleteSocketFileIfExist path =+      removeFile path `catch` handleDoesNotExist++    handleDoesNotExist e+      | isDoesNotExistError e = return ()+      | otherwise = throwIO e++-- | Set signal handlers, only for systems with signals+installSignalHandlers :: AppState.AppState -> IO ()+installSignalHandlers appState = do+  -- Releases the connection pool whenever the program is terminated,+  -- see https://github.com/PostgREST/postgrest/issues/268+  install Signals.sigINT $ AppState.releasePool appState+  install Signals.sigTERM $ AppState.releasePool appState++  -- The SIGUSR1 signal updates the internal 'DbStructure' by running+  -- 'connectionWorker' exactly as before.+  install Signals.sigUSR1 $ Workers.connectionWorker appState++  -- Re-read the config on SIGUSR2+  install Signals.sigUSR2 $ Workers.reReadConfig False appState+  where+    install signal handler =+      void $ Signals.installHandler signal (Signals.Catch handler) Nothing
+ src/PostgREST/Version.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module PostgREST.Version+  ( docsVersion+  , prettyVersion+  ) where++import qualified Data.Text as T++import Data.Version       (versionBranch)+import Development.GitRev (gitHash)+import Paths_postgrest    (version)++import Protolude+++-- | User friendly version number+prettyVersion :: Text+prettyVersion =+  T.intercalate "." (map show $ versionBranch version) <> gitRev+  where+    gitRev =+      if $(gitHash) == "UNKNOWN"+        then mempty+        else " (" <> T.take 7 $(gitHash) <> ")"++-- | Version number used in docs+docsVersion :: Text+docsVersion = "v" <> T.dropEnd 1 (T.dropWhileEnd (/= '.') prettyVersion)
+ src/PostgREST/Workers.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-}++module PostgREST.Workers+  ( connectionWorker+  , reReadConfig+  , listener+  ) where++import qualified Data.Aeson                 as JSON+import qualified Data.ByteString            as BS+import qualified Hasql.Connection           as C+import qualified Hasql.Notifications        as N+import qualified Hasql.Pool                 as P+import qualified Hasql.Transaction.Sessions as HT++import Control.Retry (RetryStatus, capDelay, exponentialBackoff,+                      retrying, rsPreviousDelay)++import PostgREST.AppState         (AppState)+import PostgREST.Config           (AppConfig (..), readAppConfig)+import PostgREST.Config.Database  (queryDbSettings, queryPgVersion)+import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion)+import PostgREST.DbStructure      (queryDbStructure)+import PostgREST.Error            (PgError (PgError), checkIsFatal,+                                   errorPayload)++import qualified PostgREST.AppState as AppState++import Protolude      hiding (head, toS)+import Protolude.Conv (toS)+++-- | Current database connection status data ConnectionStatus+data ConnectionStatus+  = NotConnected+  | Connected PgVersion+  | FatalConnectionError Text+  deriving (Eq)++-- | Schema cache status+data SCacheStatus+  = SCLoaded+  | SCOnRetry+  | SCFatalFail++-- | The purpose of this worker is to obtain a healthy connection to pg and an+-- up-to-date schema cache(DbStructure).  This method is meant to be called+-- multiple times by the same thread, but does nothing if the previous+-- invocation has not terminated. In all cases this method does not halt the+-- calling thread, the work is preformed in a separate thread.+--+-- Background thread that does the following :+--  1. Tries to connect to pg server and will keep trying until success.+--  2. Checks if the pg version is supported and if it's not it kills the main+--     program.+--  3. Obtains the dbStructure. If this fails, it goes back to 1.+connectionWorker :: AppState -> IO ()+connectionWorker appState = do+  isWorkerOn <- AppState.getIsWorkerOn appState+  -- Prevents multiple workers to be running at the same time. Could happen on+  -- too many SIGUSR1s.+  unless isWorkerOn $ do+    AppState.putIsWorkerOn appState True+    void $ forkIO work+  where+    work = do+      AppConfig{..} <- AppState.getConfig appState+      AppState.logWithZTime appState "Attempting to connect to the database..."+      connected <- connectionStatus appState+      case connected of+        FatalConnectionError reason ->+          -- Fatal error when connecting+          AppState.logWithZTime appState reason >> killThread (AppState.getMainThreadId appState)+        NotConnected ->+          -- Unreachable because connectionStatus will keep trying to connect+          return ()+        Connected actualPgVersion -> do+          -- Procede with initialization+          AppState.putPgVersion appState actualPgVersion+          when configDbChannelEnabled $+            AppState.signalListener appState+          AppState.logWithZTime appState "Connection successful"+          -- this could be fail because the connection drops, but the+          -- loadSchemaCache will pick the error and retry again+          when configDbConfig $ reReadConfig False appState+          scStatus <- loadSchemaCache appState+          case scStatus of+            SCLoaded ->+              -- do nothing and proceed if the load was successful+              return ()+            SCOnRetry ->+              work+            SCFatalFail ->+              -- die if our schema cache query has an error+              killThread $ AppState.getMainThreadId appState+          AppState.putIsWorkerOn appState False++-- | Check if a connection from the pool allows access to the PostgreSQL+-- database.  If not, the pool connections are released and a new connection is+-- tried.  Releasing the pool is key for rapid recovery. Otherwise, the pool+-- timeout would have to be reached for new healthy connections to be acquired.+-- Which might not happen if the server is busy with requests. No idle+-- connection, no pool timeout.+--+-- The connection tries are capped, but if the connection times out no error is+-- thrown, just 'False' is returned.+connectionStatus :: AppState -> IO ConnectionStatus+connectionStatus appState =+  retrying retrySettings shouldRetry $+    const $ P.release pool >> getConnectionStatus+  where+    pool = AppState.getPool appState+    retrySettings = capDelay delayMicroseconds $ exponentialBackoff backoffMicroseconds+    delayMicroseconds = 32000000 -- 32 seconds+    backoffMicroseconds = 1000000 -- 1 second++    getConnectionStatus :: IO ConnectionStatus+    getConnectionStatus = do+      pgVersion <- P.use pool queryPgVersion+      case pgVersion of+        Left e -> do+          let err = PgError False e+          AppState.logWithZTime appState . toS $ errorPayload err+          case checkIsFatal err of+            Just reason ->+              return $ FatalConnectionError reason+            Nothing ->+              return NotConnected+        Right version ->+          if version < minimumPgVersion then+            return . FatalConnectionError $+              "Cannot run in this PostgreSQL version, PostgREST needs at least "+              <> pgvName minimumPgVersion+          else+            return . Connected  $ version++    shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool+    shouldRetry rs isConnSucc = do+      let+        delay = fromMaybe 0 (rsPreviousDelay rs) `div` backoffMicroseconds+        itShould = NotConnected == isConnSucc+      when itShould . AppState.logWithZTime appState $+        "Attempting to reconnect to the database in "+        <> (show delay::Text)+        <> " seconds..."+      return itShould++-- | Load the DbStructure by using a connection from the pool.+loadSchemaCache :: AppState -> IO SCacheStatus+loadSchemaCache appState = do+  AppConfig{..} <- AppState.getConfig appState+  result <-+    let transaction = if configDbPreparedStatements then HT.transaction else HT.unpreparedTransaction in+    P.use (AppState.getPool appState) . transaction HT.ReadCommitted HT.Read $+      queryDbStructure (toList configDbSchemas) configDbExtraSearchPath configDbPreparedStatements+  case result of+    Left e -> do+      let+        err = PgError False e+        putErr = AppState.logWithZTime appState . toS $ errorPayload err+      case checkIsFatal err of+        Just hint -> do+          AppState.logWithZTime appState "A fatal error ocurred when loading the schema cache"+          putErr+          AppState.logWithZTime appState hint+          return SCFatalFail+        Nothing -> do+          AppState.logWithZTime appState "An error ocurred when loading the schema cache"+          putErr+          return SCOnRetry++    Right dbStructure -> do+      AppState.putDbStructure appState dbStructure+      when (isJust configDbRootSpec) $+        AppState.putJsonDbS appState $ toS $ JSON.encode dbStructure+      AppState.logWithZTime appState "Schema cache loaded"+      return SCLoaded++-- | Starts a dedicated pg connection to LISTEN for notifications.  When a+-- NOTIFY <db-channel> - with an empty payload - is done, it refills the schema+-- cache.  It uses the connectionWorker in case the LISTEN connection dies.+listener :: AppState -> IO ()+listener appState = do+  AppConfig{..} <- AppState.getConfig appState+  let dbChannel = toS configDbChannel++  -- The listener has to wait for a signal from the connectionWorker.+  -- This is because when the connection to the db is lost, the listener also+  -- tries to recover the connection, but not with the same pace as the connectionWorker.+  -- Not waiting makes stderr quickly fill with connection retries messages from the listener.+  AppState.waitListener appState++  -- forkFinally allows to detect if the thread dies+  void . flip forkFinally (handleFinally dbChannel) $ do+    dbOrError <- C.acquire $ toS configDbUri+    case dbOrError of+      Right db -> do+        AppState.logWithZTime appState $ "Listening for notifications on the " <> dbChannel <> " channel"+        N.listen db $ N.toPgIdentifier dbChannel+        N.waitForNotifications handleNotification db+      _ ->+        die $ "Could not listen for notifications on the " <> dbChannel <> " channel"+  where+    handleFinally dbChannel _ = do+      -- if the thread dies, we try to recover+      AppState.logWithZTime appState $ "Retrying listening for notifications on the " <> dbChannel <> " channel.."+      -- assume the pool connection was also lost, call the connection worker+      connectionWorker appState+      -- retry the listener+      listener appState++    handleNotification _ msg+      | BS.null msg            = scLoader -- reload the schema cache+      | msg == "reload schema" = scLoader -- reload the schema cache+      | msg == "reload config" = reReadConfig False appState -- reload the config+      | otherwise              = pure () -- Do nothing if anything else than an empty message is sent++    scLoader =+      -- It's not necessary to check the loadSchemaCache success+      -- here. If the connection drops, the thread will die and+      -- proceed to recover.+      void $ loadSchemaCache appState++-- | Re-reads the config plus config options from the db+reReadConfig :: Bool -> AppState -> IO ()+reReadConfig startingUp appState = do+  AppConfig{..} <- AppState.getConfig appState+  dbSettings <-+    if configDbConfig then do+      qDbSettings <- queryDbSettings (AppState.getPool appState) configDbPreparedStatements+      case qDbSettings of+        Left e -> do+          let+            err = PgError False e+            putErr = AppState.logWithZTime appState . toS $ errorPayload err+          AppState.logWithZTime appState+            "An error ocurred when trying to query database settings for the config parameters"+          case checkIsFatal err of+            Just hint -> do+              putErr+              AppState.logWithZTime appState hint+              killThread (AppState.getMainThreadId appState)+            Nothing -> do+              AppState.logWithZTime appState $ show e+          pure []+        Right x -> pure x+    else+      pure mempty+  readAppConfig dbSettings configFilePath (Just configDbUri) >>= \case+    Left err   ->+      if startingUp then+        panic err -- die on invalid config if the program is starting up+      else+        AppState.logWithZTime appState $ "Failed re-loading config: " <> err+    Right newConf -> do+      AppState.putConfig appState newConf+      if startingUp then+        pass+      else+        AppState.logWithZTime appState "Config re-loaded"
test/Feature/AndOrParamsSpec.hs view
@@ -7,8 +7,9 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import PostgREST.Types (PgVersion, pgVersion112)-import Protolude       hiding (get)+import PostgREST.Config.PgVersion (PgVersion, pgVersion112)++import Protolude  hiding (get) import SpecHelper  spec :: PgVersion -> SpecWith ((), Application)@@ -33,13 +34,24 @@               {"id": 1, "child_entities": [ { "id": 1 }, { "id": 2 } ] }, { "id": 2, "child_entities": []},               {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []}             ]|] { matchHeaders = [matchContentTypeJson] }+         it "can do logic on the third level" $-          get "/entities?child_entities.grandchild_entities.or=(id.eq.1,id.eq.2)&select=id,child_entities(id,grandchild_entities(id))" `shouldRespondWith`-            [json|[-              {"id": 1, "child_entities": [ { "id": 1, "grandchild_entities": [ { "id": 1 }, { "id": 2 } ]}, { "id": 2, "grandchild_entities": []}]},-              {"id": 2, "child_entities": [ { "id": 3, "grandchild_entities": []} ]},-              {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []}-            ]|] { matchHeaders = [matchContentTypeJson] }+          get "/entities?child_entities.grandchild_entities.or=(id.eq.1,id.eq.2)&select=id,child_entities(id,grandchild_entities(id))"+            `shouldRespondWith`+              [json|[+                {"id": 1, "child_entities": [+                  { "id": 1, "grandchild_entities": [ { "id": 1 }, { "id": 2 } ]},+                  { "id": 2, "grandchild_entities": []},+                  { "id": 4, "grandchild_entities": []},+                  { "id": 5, "grandchild_entities": []}+                ]},+                {"id": 2, "child_entities": [+                  { "id": 3, "grandchild_entities": []},+                  { "id": 6, "grandchild_entities": []}+                ]},+                {"id": 3, "child_entities": []},+                {"id": 4, "child_entities": []}+              ]|]        context "and/or params combined" $ do         it "can be nested inside the same expression" $@@ -210,12 +222,15 @@     context "used with POST" $       it "includes related data with filters" $         request methodPost "/child_entities?select=id,entities(id)&entities.or=(id.eq.2,id.eq.3)&entities.order=id"-          [("Prefer", "return=representation")]-          [json|[{"id":4,"name":"entity 4","parent_id":1},-                 {"id":5,"name":"entity 5","parent_id":2},-                 {"id":6,"name":"entity 6","parent_id":3}]|] `shouldRespondWith`-          [json|[{"id": 4, "entities":null}, {"id": 5, "entities": {"id": 2}}, {"id": 6, "entities": {"id": 3}}]|]-          { matchStatus = 201, matchHeaders = [matchContentTypeJson] }+            [("Prefer", "return=representation")]+            [json|[+              {"id":7,"name":"entity 4","parent_id":1},+              {"id":8,"name":"entity 5","parent_id":2},+              {"id":9,"name":"entity 6","parent_id":3}+            ]|]+          `shouldRespondWith`+            [json|[{"id": 7, "entities":null}, {"id": 8, "entities": {"id": 2}}, {"id": 9, "entities": {"id": 3}}]|]+            { matchStatus = 201 }      context "used with PATCH" $       it "succeeds when using and/or params" $@@ -228,9 +243,10 @@     context "used with DELETE" $       it "succeeds when using and/or params" $         request methodDelete "/grandchild_entities?or=(id.eq.1,id.eq.2)&select=id,name"-          [("Prefer", "return=representation")] "" `shouldRespondWith`-          [json|[{ "id": 1, "name" : "updated grandchild entity"},{ "id": 2, "name" : "updated grandchild entity"}]|]-          { matchHeaders = [matchContentTypeJson] }+            [("Prefer", "return=representation")]+            ""+          `shouldRespondWith`+            [json|[{ "id": 1, "name" : "grandchild entity 1" },{ "id": 2, "name" : "grandchild entity 2" }]|]      it "can query columns that begin with and/or reserved words" $       get "/grandchild_entities?or=(and_starting_col.eq.smth, or_starting_col.eq.smth)" `shouldRespondWith` 200
test/Feature/AuthSpec.hs view
@@ -6,10 +6,10 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Text.Heredoc -import PostgREST.Types (PgVersion, pgVersion112)-import Protolude       hiding (get)+import PostgREST.Config.PgVersion (PgVersion, pgVersion112)++import Protolude  hiding (get) import SpecHelper  spec :: PgVersion -> SpecWith ((), Application)@@ -85,7 +85,7 @@   it "sql functions can read custom and standard claims variables" $ do     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwfQ.V5fEpXfpb7feqwVqlcDleFdKu86bdwU2cBRT4fcMhXg"     request methodPost "/rpc/reveal_big_jwt" [auth] "{}"-      `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|]+      `shouldRespondWith` [json|[{"iss":"joe","sub":"fun","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|]    it "allows users with permissions to see their tables" $ do     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0"@@ -148,7 +148,7 @@       let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6MX0.gKw7qI50i9hMrSJW8BlTpdMEVmMXJYxlAqueGqpa_mE" in       request methodPost "/rpc/get_current_user" [auth]         [json| {} |]-         `shouldRespondWith` [str|"postgrest_test_author"|]+         `shouldRespondWith` [json|"postgrest_test_author"|]           { matchStatus = 200           , matchHeaders = []           }@@ -157,7 +157,7 @@       let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Mn0.nwzjMI0YLvVGJQTeoCPEBsK983b__gxdpLXisBNaO2A" in       request methodPost "/rpc/get_current_user" [auth]         [json| {} |]-         `shouldRespondWith` [str|"postgrest_test_default_role"|]+         `shouldRespondWith` [json|"postgrest_test_default_role"|]           { matchStatus = 200           , matchHeaders = []           }@@ -166,7 +166,14 @@       let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6M30.OGxEJAf60NKZiTn-tIb2jy4rqKs_ZruLGWZ40TjrJsM" in       request methodPost "/rpc/get_current_user" [auth]         [json| {} |]-         `shouldRespondWith` [str|{"hint":"Please contact administrator","details":null,"code":"P0001","message":"Disabled ID --> 3"}|]+         `shouldRespondWith` [json|{"hint":"Please contact administrator","details":null,"code":"P0001","message":"Disabled ID --> 3"}|]           { matchStatus = 400           , matchHeaders = []           }++  it "allows 'Bearer' and 'bearer' as authentication schemes" $ do+    let token = "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0"+    request methodGet "/authors_only" [authHeader "Bearer" token] ""+      `shouldRespondWith` 200+    request methodGet "/authors_only" [authHeader "bearer" token] ""+      `shouldRespondWith` 200
test/Feature/DeleteSpec.hs view
@@ -6,7 +6,6 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Text.Heredoc  import Protolude hiding (get) @@ -23,7 +22,7 @@        it "returns the deleted item and count if requested" $         request methodDelete "/items?id=eq.2" [("Prefer", "return=representation"), ("Prefer", "count=exact")] ""-          `shouldRespondWith` [str|[{"id":2}]|]+          `shouldRespondWith` [json|[{"id":2}]|]           { matchStatus  = 200           , matchHeaders = ["Content-Range" <:> "*/1"]           }@@ -42,28 +41,20 @@        it "returns the deleted item and shapes the response" $         request methodDelete "/complex_items?id=eq.2&select=id,name" [("Prefer", "return=representation")] ""-          `shouldRespondWith` [str|[{"id":2,"name":"Two"}]|]+          `shouldRespondWith` [json|[{"id":2,"name":"Two"}]|]           { matchStatus  = 200           , matchHeaders = ["Content-Range" <:> "*/*"]           }        it "can rename and cast the selected columns" $         request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] ""-          `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|]+          `shouldRespondWith` [json|[{"ciId":"3","ciName":"Three"}]|]        it "can embed (parent) entities" $         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}}]|]+          `shouldRespondWith` [json|[{"id":8,"name":"Code OSX","project":{"id":4}}]|]           { matchStatus  = 200           , matchHeaders = ["Content-Range" <:> "*/*"]-          }--      it "actually clears items ouf the db" $ do-        _ <- request methodDelete "/items?id=lt.15" [] ""-        get "/items"-          `shouldRespondWith` [str|[{"id":15}]|]-          { matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "0-0/*"]           }      context "known route, no records matched" $
+ test/Feature/DisabledOpenApiSpec.hs view
@@ -0,0 +1,20 @@+module Feature.DisabledOpenApiSpec where++import Network.HTTP.Types+import Network.Wai        (Application)++import Test.Hspec     hiding (pendingWith)+import Test.Hspec.Wai++import Protolude++spec :: SpecWith ((), Application)+spec =+  describe "Disabled OpenApi" $ do+    it "does not accept application/openapi+json and responds with 415" $+      request methodGet "/"+        [("Accept","application/openapi+json")] "" `shouldRespondWith` 415++    it "accepts application/json and responds with 404" $+      request methodGet "/"+        [("Accept","application/json")] "" `shouldRespondWith` 404
test/Feature/EmbedDisambiguationSpec.hs view
@@ -5,7 +5,6 @@ import Test.Hspec          hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Text.Heredoc  import Protolude  hiding (get) import SpecHelper@@ -154,7 +153,7 @@          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"}}}]|]+            [json|[{"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`@@ -185,7 +184,9 @@          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"}|]+            [json|{+              "hint":"If a new foreign key between these entities was created in the database, try reloading the schema cache.",+              "message":"Could not find a relationship between message and person in the schema cache"}|]             { matchStatus = 400             , matchHeaders = [matchContentTypeJson] } @@ -195,9 +196,9 @@             { 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] }+          get "/articleStars?select=createdAt,article(id),user(name)&limit=1"+            `shouldRespondWith`+              [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"id": 1},"user":{"name": "Angela Martin"}}]|]          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`@@ -230,7 +231,7 @@          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"}}}]|]+            [json|[{"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`@@ -432,3 +433,29 @@           [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] } +    context "m2m embed when there's a junction in an internal schema" $ do+      -- https://github.com/PostgREST/postgrest/issues/1736+      it "works with no ambiguity when there's an exposed view of the junction" $ do+        get "/screens?select=labels(name)" `shouldRespondWith`+          [json|[{"labels":[{"name":"fruit"}]}, {"labels":[{"name":"vehicles"}]}, {"labels":[{"name":"vehicles"}, {"name":"fruit"}]}]|]+          { matchHeaders = [matchContentTypeJson] }+        get "/actors?select=*,films(*)" `shouldRespondWith`+          [json|[ {"id":1,"name":"john","films":[{"id":12,"title":"douze commandements"}]},+                  {"id":2,"name":"mary","films":[{"id":2001,"title":"odyssée de l'espace"}]}]|]+          { matchHeaders = [matchContentTypeJson] }+      it "doesn't work if the junction is only internal" $+        get "/end_1?select=end_2(*)" `shouldRespondWith`+          [json|{+            "hint":"If a new foreign key between these entities was created in the database, try reloading the schema cache.",+            "message":"Could not find a relationship between end_1 and end_2 in the schema cache"}|]+          { matchStatus  = 400+          , matchHeaders = [matchContentTypeJson] }+      it "shouldn't try to embed if the private junction has an exposed homonym" $+        -- ensures the "invalid reference to FROM-clause entry for table "rollen" error doesn't happen.+        -- Ref: https://github.com/PostgREST/postgrest/issues/1587#issuecomment-734995669+        get "/schauspieler?select=filme(*)" `shouldRespondWith`+          [json|{+            "hint":"If a new foreign key between these entities was created in the database, try reloading the schema cache.",+            "message":"Could not find a relationship between schauspieler and filme in the schema cache"}|]+          { matchStatus  = 400+          , matchHeaders = [matchContentTypeJson] }
test/Feature/ExtraSearchPathSpec.hs view
@@ -6,7 +6,7 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Protolude+import Protolude  hiding (get) import SpecHelper  spec :: SpecWith ((), Application)@@ -34,3 +34,6 @@     request methodGet "/rpc/is_valid_isbn?input=978-0-393-04002-9" [] ""       `shouldRespondWith` [json|true|]       { matchHeaders = [matchContentTypeJson] }++  it "can detect fk relations through multiple views recursively when middle views are in extra search path" $+    get "/consumers_extra_view?select=*,orders_view(*)" `shouldRespondWith` 200
test/Feature/HtmlRawOutputSpec.hs view
@@ -26,5 +26,5 @@           |</html>           |]       { matchStatus = 200-      , matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"]+      , matchHeaders = ["Content-Type" <:> "text/html"]       }
+ test/Feature/IgnorePrivOpenApiSpec.hs view
@@ -0,0 +1,76 @@+module Feature.IgnorePrivOpenApiSpec 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 (..))++import Test.Hspec     hiding (pendingWith)+import Test.Hspec.Wai++import Protolude  hiding (get)+import SpecHelper++spec :: SpecWith ((), Application)+spec = describe "OpenAPI Ignore Privileges" $ do+  it "root path returns a valid openapi spec" $ do+    validateOpenApiResponse [("Accept", "application/openapi+json")]+    request methodHead "/" (acceptHdrs "application/openapi+json") ""+      `shouldRespondWith` "" { matchStatus  = 200 }++  describe "table" $ do++    it "includes privileged table even if user does not have permission" $ do+      r <- simpleBody <$> get "/"+      let tableTag = r ^? key "paths" . key "/authors_only"+                     . key "post" . key "tags"+                     . nth 0++      liftIO $ tableTag `shouldBe` Just [aesonQQ|"authors_only"|]++    it "only includes tables that belong to another schema if the Accept-Profile header is used" $ do+      r1 <- simpleBody <$> get "/"+      let tableKey1 = r1 ^? key "paths" . key "/children"++      liftIO $ tableKey1 `shouldBe` Nothing++      r2 <- simpleBody <$> request methodGet "/" [("Accept-Profile", "v1")] ""+      let tableKey2 = r2 ^? key "paths" . key "/children"++      liftIO $ tableKey2 `shouldNotBe` Nothing++    it "includes comments on tables" $ do+      r <- simpleBody <$> get "/"++      let grandChildGet s = key "paths" . key "/grandchild_entities" . key "get" . key s+          grandChildGetSummary = r ^? grandChildGet "summary"+          grandChildGetDescription = r ^? grandChildGet "description"++      liftIO $ do+        grandChildGetSummary `shouldBe` Just "grandchild_entities summary"+        grandChildGetDescription `shouldBe` Just "grandchild_entities description\nthat spans\nmultiple lines"++  describe "RPC" $ do++    it "includes privileged function even if user does not have permission" $ do+      r <- simpleBody <$> get "/"+      let funcTag = r ^? key "paths" . key "/rpc/privileged_hello"+                    . key "post" . key "tags"+                    . nth 0++      liftIO $ funcTag `shouldBe` Just [aesonQQ|"(rpc) privileged_hello"|]++    it "only includes functions that belong to another schema if the Accept-Profile header is used" $ do+      r1 <- simpleBody <$> get "/"+      let funcKey1 = r1 ^? key "paths" . key "/rpc/get_parents_below"++      liftIO $ funcKey1 `shouldBe` Nothing++      r2 <- simpleBody <$> request methodGet "/" [("Accept-Profile", "v1")] ""+      let funcKey2 = r2 ^? key "paths" . key "/rpc/get_parents_below"++      liftIO $ funcKey2 `shouldNotBe` Nothing
test/Feature/InsertSpec.hs view
@@ -1,22 +1,20 @@ module Feature.InsertSpec where -import qualified Data.Aeson as JSON- import Data.List              (lookup)-import Data.Maybe             (fromJust) import Network.Wai            (Application)-import Network.Wai.Test       (SResponse (simpleBody, simpleHeaders, simpleStatus))+import Network.Wai.Test       (SResponse (simpleHeaders)) import Test.Hspec             hiding (pendingWith) import Test.Hspec.Wai.Matcher (bodyEquals)-import TestTypes              (CompoundPK (..), IncPK (..))  import Network.HTTP.Types import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Text.Heredoc -import PostgREST.Types (PgVersion, pgVersion112)-import Protolude       hiding (get)+import PostgREST.Config.PgVersion (PgVersion, pgVersion112,+                                   pgVersion130)++import Protolude  hiding (get) import SpecHelper  spec :: PgVersion -> SpecWith ((), Application)@@ -24,17 +22,16 @@   describe "Posting new record" $ do     context "disparate json types" $ do       it "accepts disparate json types" $ do-        p <- post "/menagerie"+        post "/menagerie"           [json| {             "integer": 13, "double": 3.14159, "varchar": "testing!"           , "boolean": false, "date": "1900-01-01", "money": "$3.99"           , "enum": "foo"-          } |]-        liftIO $ do-          simpleBody p `shouldBe` ""-          simpleStatus p `shouldBe` created201-          -- should not have content type set when body is empty-          lookup hContentType (simpleHeaders p) `shouldBe` Nothing+          } |] `shouldRespondWith` ""+          { matchStatus  = 201+            -- should not have content type set when body is empty+          , matchHeaders = [matchHeaderAbsent hContentType]+          }        it "filters columns in result using &select" $         request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]@@ -42,7 +39,7 @@             "integer": 14, "double": 3.14159, "varchar": "testing!"           , "boolean": false, "date": "1900-01-01", "money": "$3.99"           , "enum": "foo"-          }] |] `shouldRespondWith` [str|[{"integer":14,"varchar":"testing!"}]|]+          }] |] `shouldRespondWith` [json|[{"integer":14,"varchar":"testing!"}]|]           { matchStatus  = 201           , matchHeaders = [matchContentTypeJson]           }@@ -86,7 +83,7 @@       it "includes related data after insert" $         request methodPost "/projects?select=id,name,clients(id,name)"                 [("Prefer", "return=representation"), ("Prefer", "count=exact")]-          [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` [str|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|]+          [json|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` [json|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|]           { matchStatus  = 201           , matchHeaders = [ matchContentTypeJson                            , "Location" <:> "/projects?id=eq.6"@@ -96,109 +93,141 @@       it "can rename and cast the selected columns" $         request methodPost "/projects?select=pId:id::text,pName:name,cId:client_id::text"                 [("Prefer", "return=representation")]-          [str|{"id":7,"name":"New Project","client_id":2}|] `shouldRespondWith`-          [str|[{"pId":"7","pName":"New Project","cId":"2"}]|]+          [json|{"id":7,"name":"New Project","client_id":2}|] `shouldRespondWith`+          [json|[{"pId":"7","pName":"New Project","cId":"2"}]|]           { matchStatus  = 201           , matchHeaders = [ matchContentTypeJson                            , "Location" <:> "/projects?id=eq.7"                            , "Content-Range" <:> "*/*" ]           } +      it "should not throw and return location header when selecting without PK" $+        request methodPost "/projects?select=name,client_id" [("Prefer", "return=representation")]+          [json|{"id":10,"name":"New Project","client_id":2}|] `shouldRespondWith`+          [json|[{"name":"New Project","client_id":2}]|]+          { matchStatus  = 201+          , matchHeaders = [ matchContentTypeJson+                           , "Location" <:> "/projects?id=eq.10"+                           , "Content-Range" <:> "*/*" ]+          }++    context "requesting headers only representation" $+      it "should not throw and return location header when selecting without PK" $+        request methodPost "/projects?select=name,client_id" [("Prefer", "return=headers-only")]+          [json|{"id":11,"name":"New Project","client_id":2}|] `shouldRespondWith` ""+          { matchStatus  = 201+          , matchHeaders = [ "Location" <:> "/projects?id=eq.11"+                           , "Content-Range" <:> "*/*" ]+          }++    context "requesting no representation" $+      it "should not throw and return no location header when selecting without PK" $+        request methodPost "/projects?select=name,client_id" []+          [json|{"id":12,"name":"New Project","client_id":2}|] `shouldRespondWith` ""+          { matchStatus  = 201+          , matchHeaders = [ matchHeaderAbsent hLocation ]+          }+     context "from an html form" $       it "accepts disparate json types" $ do-        p <- request methodPost "/menagerie"-               [("Content-Type", "application/x-www-form-urlencoded")]-               ("integer=7&double=2.71828&varchar=forms+are+fun&" <>-                "boolean=false&date=1900-01-01&money=$3.99&enum=foo")-        liftIO $ do-          simpleBody p `shouldBe` ""-          simpleStatus p `shouldBe` created201+        request methodPost "/menagerie"+            [("Content-Type", "application/x-www-form-urlencoded")]+             ("integer=7&double=2.71828&varchar=forms+are+fun&" <>+              "boolean=false&date=1900-01-01&money=$3.99&enum=foo")+          `shouldRespondWith`+            ""+            { matchStatus = 201 }      context "with no pk supplied" $ do       context "into a table with auto-incrementing pk" $-        it "succeeds with 201 and link" $ do-          p <- post "/auto_incrementing_pk" [json| { "non_nullable_string":"not null"} |]-          liftIO $ do-            simpleBody p `shouldBe` ""-            simpleHeaders p `shouldSatisfy` matchHeader hLocation "/auto_incrementing_pk\\?id=eq\\.[0-9]+"-            simpleStatus p `shouldBe` created201-          let Just location = lookup hLocation $ simpleHeaders p-          r <- get location-          let [record] = fromJust (JSON.decode $ simpleBody r :: Maybe [IncPK])-          liftIO $ do-            incStr record `shouldBe` "not null"-            incNullableStr record `shouldBe` Nothing+        it "succeeds with 201 and location header" $ do+          -- reset pk sequence first to make test repeatable+          request methodPost "/rpc/reset_sequence"+              [("Prefer", "tx=commit")]+              [json|{"name": "auto_incrementing_pk_id_seq", "value": 2}|]+            `shouldRespondWith`+              [json|""|] +          request methodPost "/auto_incrementing_pk" [("Prefer", "return=headers-only")]+              [json| { "non_nullable_string":"not null"} |]+            `shouldRespondWith`+              ""+              { matchStatus  = 201+              , matchHeaders = [ "Location" <:> "/auto_incrementing_pk?id=eq.2" ]+              }+       context "into a table with simple pk" $         it "fails with 400 and error" $           post "/simple_pk" [json| { "extra":"foo"} |]           `shouldRespondWith`-          [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" violates not-null constraint"}|]+          (if actualPgVersion >= pgVersion130 then+            [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" of relation \"simple_pk\" violates not-null constraint"}|]+           else+            [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" violates not-null constraint"}|]+          )           { matchStatus  = 400           , matchHeaders = [matchContentTypeJson]           }        context "into a table with no pk" $ do-        it "succeeds with 201 and a link including all fields" $ do-          p <- post "/no_pk" [json| { "a":"foo", "b":"bar" } |]-          liftIO $ do-            simpleBody p `shouldBe` ""-            simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.foo&b=eq.bar"-            simpleStatus p `shouldBe` created201+        it "succeeds with 201 but no location header" $ do+          post "/no_pk" [json| { "a":"foo", "b":"bar" } |]+            `shouldRespondWith`+              ""+              { matchStatus  = 201+              , matchHeaders = [matchHeaderAbsent hLocation]+              }          it "returns full details of inserted record if asked" $ do-          p <- request methodPost "/no_pk"-                       [("Prefer", "return=representation")]-                       [json| { "a":"bar", "b":"baz" } |]-          liftIO $ do-            simpleBody p `shouldBe` [json| [{ "a":"bar", "b":"baz" }] |]-            simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz"-            simpleStatus p `shouldBe` created201+          request methodPost "/no_pk"+              [("Prefer", "return=representation")]+              [json| { "a":"bar", "b":"baz" } |]+            `shouldRespondWith`+              [json| [{ "a":"bar", "b":"baz" }] |]+              { matchStatus  = 201+              , matchHeaders = [matchHeaderAbsent hLocation]+              }          it "returns empty array when no items inserted, and return=rep" $ do-          p <- request methodPost "/no_pk"-                       [("Prefer", "return=representation")]-                       [json| [] |]-          liftIO $ do-            simpleBody p `shouldBe` [json| [] |]-            simpleStatus p `shouldBe` created201+          request methodPost "/no_pk"+              [("Prefer", "return=representation")]+              [json| [] |]+            `shouldRespondWith`+              [json| [] |]+              { matchStatus = 201 }          it "can post nulls" $ do-          p <- request methodPost "/no_pk"-                       [("Prefer", "return=representation")]-                       [json| { "a":null, "b":"foo" } |]-          liftIO $ do-            simpleBody p `shouldBe` [json| [{ "a":null, "b":"foo" }] |]-            simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=is.null&b=eq.foo"-            simpleStatus p `shouldBe` created201+          request methodPost "/no_pk"+              [("Prefer", "return=representation")]+              [json| { "a":null, "b":"foo" } |]+            `shouldRespondWith`+              [json| [{ "a":null, "b":"foo" }] |]+              { matchStatus  = 201+              , matchHeaders = [matchHeaderAbsent hLocation]+              }      context "with compound pk supplied" $       it "builds response location header appropriately" $ do-        let inserted    = [json| { "k1":12, "k2":"Rock & R+ll" } |]-            expectedObj = CompoundPK 12 "Rock & R+ll" Nothing-            expectedLoc = "/compound_pk?k1=eq.12&k2=eq.Rock%20%26%20R%2Bll"-        p <- request methodPost "/compound_pk"-                     [("Prefer", "return=representation")]-                     inserted-        liftIO $ do-          JSON.decode (simpleBody p) `shouldBe` Just [expectedObj]-          simpleStatus p `shouldBe` created201-          lookup hLocation (simpleHeaders p) `shouldBe` Just expectedLoc--        r <- get expectedLoc-        liftIO $ do-          JSON.decode (simpleBody r) `shouldBe` Just [expectedObj]-          simpleStatus r `shouldBe` ok200+        request methodPost "/compound_pk"+            [("Prefer", "return=representation")]+            [json| { "k1":12, "k2":"Rock & R+ll" } |]+          `shouldRespondWith`+            [json|[ { "k1":12, "k2":"Rock & R+ll", "extra": null } ]|]+            { matchStatus  = 201+            , matchHeaders = [ "Location" <:> "/compound_pk?k1=eq.12&k2=eq.Rock%20%26%20R%2Bll" ]+            }      context "with bulk insert" $       it "returns 201 but no location header" $ do         let bulkData = [json| [ {"k1":21, "k2":"hello world"}                               , {"k1":22, "k2":"bye for now"}]                             |]-        p <- request methodPost "/compound_pk" [] bulkData-        liftIO $ do-          simpleStatus p `shouldBe` created201-          lookup hLocation (simpleHeaders p) `shouldBe` Nothing+        request methodPost "/compound_pk" [] bulkData+          `shouldRespondWith`+            ""+            { matchStatus  = 201+            , matchHeaders = [matchHeaderAbsent hLocation]+            }      context "with invalid json payload" $       it "fails with 400 and error" $@@ -224,12 +253,11 @@      context "attempting to insert a row with the same primary key" $       it "fails returning a 409 Conflict" $-        post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |]+        post "/simple_pk"+            [json| { "k":"xyyx", "extra":"e1" } |]           `shouldRespondWith`-          [json|{"hint":null,"details":"Key (k)=(k1) already exists.","code":"23505","message":"duplicate key value violates unique constraint \"contacts_pkey\""}|]-          { matchStatus  = 409-          , matchHeaders = [matchContentTypeJson]-          }+            [json|{"hint":null,"details":"Key (k)=(xyyx) already exists.","code":"23505","message":"duplicate key value violates unique constraint \"simple_pk_pkey\""}|]+            { matchStatus  = 409 }      context "attempting to insert a row with conflicting unique constraint" $       it "fails returning a 409 Conflict" $@@ -238,24 +266,20 @@     context "jsonb" $ do       it "serializes nested object" $ do         let inserted = [json| { "data": { "foo":"bar" } } |]-            location = "/json?data=eq.%7B%22foo%22%3A%22bar%22%7D"-        request methodPost "/json"+        request methodPost "/json_table"                      [("Prefer", "return=representation")]                      inserted-          `shouldRespondWith` [str|[{"data":{"foo":"bar"}}]|]+          `shouldRespondWith` [json|[{"data":{"foo":"bar"}}]|]           { matchStatus  = 201-          , matchHeaders = ["Location" <:> location]           }        it "serializes nested array" $ do         let inserted = [json| { "data": [1,2,3] } |]-            location = "/json?data=eq.%5B1%2C2%2C3%5D"-        request methodPost "/json"+        request methodPost "/json_table"                      [("Prefer", "return=representation")]                      inserted-          `shouldRespondWith` [str|[{"data":[1,2,3]}]|]+          `shouldRespondWith` [json|[{"data":[1,2,3]}]|]           { matchStatus  = 201-          , matchHeaders = ["Location" <:> location]           }      context "empty objects" $ do@@ -275,20 +299,35 @@           , matchHeaders = []           } -      it "successfully inserts a row with all-default columns with prefer=rep" $-        request methodPost "/items" [("Prefer", "return=representation")] "{}"-          `shouldRespondWith` [json|[{ id: 20 }]|]-          { matchStatus  = 201,-            matchHeaders = []-          }+      it "successfully inserts a row with all-default columns with prefer=rep" $ do+        -- reset pk sequence first to make test repeatable+        request methodPost "/rpc/reset_sequence"+            [("Prefer", "tx=commit")]+            [json|{"name": "items2_id_seq", "value": 20}|]+          `shouldRespondWith`+            [json|""|] -      it "successfully inserts a row with all-default columns with prefer=rep and &select=" $-        request methodPost "/items?select=id" [("Prefer", "return=representation")] "{}"-          `shouldRespondWith` [json|[{ id: 21 }]|]-          { matchStatus  = 201,-            matchHeaders = []-          }+        request methodPost "/items2"+            [("Prefer", "return=representation")]+            [json|{}|]+          `shouldRespondWith`+            [json|[{ id: 20 }]|]+            { matchStatus  = 201 } +      it "successfully inserts a row with all-default columns with prefer=rep and &select=" $ do+        -- reset pk sequence first to make test repeatable+        request methodPost "/rpc/reset_sequence"+            [("Prefer", "tx=commit")]+            [json|{"name": "items3_id_seq", "value": 20}|]+          `shouldRespondWith`+            [json|""|]++        request methodPost "/items3?select=id"+            [("Prefer", "return=representation")]+            [json|{}|]+          `shouldRespondWith` [json|[{ id: 20 }]|]+            { matchStatus  = 201 }+     context "POST with ?columns parameter" $ do       it "ignores json keys not included in ?columns" $ do         request methodPost "/articles?columns=id,body" [("Prefer", "return=representation")]@@ -358,8 +397,7 @@                      "a,b\nbar,baz"           `shouldRespondWith` "a,b\nbar,baz"           { matchStatus  = 201-          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",-                            "Location" <:> "/no_pk?a=eq.bar&b=eq.baz"]+          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]           }        it "can post nulls" $@@ -368,8 +406,7 @@                      "a,b\nNULL,foo"           `shouldRespondWith` "a,b\n,foo"           { matchStatus  = 201-          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",-                            "Location" <:> "/no_pk?a=is.null&b=eq.foo"]+          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]           }        it "only returns the requested column header with its associated data" $@@ -393,294 +430,40 @@      context "with unicode values" $       it "succeeds and returns usable location header" $ do-        let payload = [json| { "a":"圍棋", "b":"￥" } |]-        p <- request methodPost "/no_pk"-                     [("Prefer", "return=representation")]-                     payload-        liftIO $ do-          simpleBody p `shouldBe` "["<>payload<>"]"-          simpleStatus p `shouldBe` created201+        p <- request methodPost "/simple_pk2?select=extra,k"+            [("Prefer", "tx=commit"), ("Prefer", "return=representation")]+            [json| { "k":"圍棋", "extra":"￥" } |]+        pure p `shouldRespondWith`+          [json|[ { "k":"圍棋", "extra":"￥" } ]|]+          { matchStatus = 201 }          let Just location = lookup hLocation $ simpleHeaders p-        r <- get location-        liftIO $ simpleBody r `shouldBe` "["<>payload<>"]"--  describe "Patching record" $ do-    context "to unknown uri" $-      it "indicates no table found by returning 404" $-        request methodPatch "/fake" []-          [json| { "real": false } |]-            `shouldRespondWith` 404--    context "on an empty table" $-      it "indicates no records found to update by returning 404" $-        request methodPatch "/empty_table" []-          [json| { "extra":20 } |]-          `shouldRespondWith` ""-          { matchStatus  = 404,-            matchHeaders = []-          }--    context "with invalid json payload" $-      it "fails with 400 and error" $-        request methodPatch "/simple_pk" [] "}{ x = 2"+        get location           `shouldRespondWith`-          [json|{"message":"Error in $: Failed reading: not a valid json value at '}{x=2'"}|]-          { matchStatus  = 400,-            matchHeaders = [matchContentTypeJson]-          }+            [json|[ { "k":"圍棋", "extra":"￥" } ]|] -    context "with no payload" $-      it "fails with 400 and error" $-        request methodPatch "/items" [] ""+        request methodDelete location+            [("Prefer", "tx=commit")]+            ""           `shouldRespondWith`-          [json|{"message":"Error in $: not enough input"}|]-          { matchStatus  = 400,-            matchHeaders = [matchContentTypeJson]-          }--    context "in a nonempty table" $ do-      it "can update a single item" $ do-        g <- get "/items?id=eq.42"-        liftIO $ simpleHeaders g-          `shouldSatisfy` matchHeader "Content-Range" "\\*/\\*"-        p <- request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |]-        pure p `shouldRespondWith` ""-          { matchStatus  = 204,-            matchHeaders = ["Content-Range" <:> "0-0/*"]-          }-        liftIO $ lookup hContentType (simpleHeaders p) `shouldBe` Nothing--        -- check it really got updated-        g' <- get "/items?id=eq.42"-        liftIO $ simpleHeaders g'-          `shouldSatisfy` matchHeader "Content-Range" "0-0/\\*"-        -- put value back for other tests-        void $ request methodPatch "/items?id=eq.42" [] [json| { "id":2 } |]--      it "returns empty array when no rows updated and return=rep" $-        request methodPatch "/items?id=eq.999999"-          [("Prefer", "return=representation")] [json| { "id":999999 } |]-          `shouldRespondWith` "[]"-          {-            matchStatus  = 404,-            matchHeaders = []-          }--      it "gives a 404 when no rows updated" $-        request methodPatch "/items?id=eq.99999999" []-          [json| { "id": 42 } |]-            `shouldRespondWith` 404--      it "returns updated object as array when return=rep" $-        request methodPatch "/items?id=eq.2"-          [("Prefer", "return=representation")] [json| { "id":2 } |]-          `shouldRespondWith` [str|[{"id":2}]|]-          { matchStatus  = 200,-            matchHeaders = ["Content-Range" <:> "0-0/*"]-          }--      it "can update multiple items" $ do-        replicateM_ 10 $ post "/auto_incrementing_pk"-          [json| { non_nullable_string: "a" } |]-        replicateM_ 10 $ post "/auto_incrementing_pk"-          [json| { non_nullable_string: "b" } |]-        _ <- request methodPatch-          "/auto_incrementing_pk?non_nullable_string=eq.a" []-          [json| { non_nullable_string: "c" } |]-        g <- get "/auto_incrementing_pk?non_nullable_string=eq.c"-        liftIO $ simpleHeaders g-          `shouldSatisfy` matchHeader "Content-Range" "0-9/\\*"--      it "can set a column to NULL" $ do-        _ <- post "/no_pk" [json| { a: "keepme", b: "nullme" } |]-        _ <- request methodPatch "/no_pk?b=eq.nullme" [] [json| { b: null } |]-        get "/no_pk?a=eq.keepme" `shouldRespondWith`-          [json| [{ a: "keepme", b: null }] |]-          { matchHeaders = [matchContentTypeJson] }--      context "filtering by a computed column" $ do-        it "is successful" $-          request methodPatch-            "/items?is_first=eq.true"-            [("Prefer", "return=representation")]-            [json| { id: 100 } |]-            `shouldRespondWith` [json| [{ id: 100 }] |]-            { matchStatus  = 200,-              matchHeaders = [matchContentTypeJson, "Content-Range" <:> "0-0/*"]-            }--        it "indicates no records updated by returning 404" $-          request methodPatch-            "/items?always_true=eq.false"-            [("Prefer", "return=representation")]-            [json| { id: 100 } |]-            `shouldRespondWith` "[]"-            { matchStatus  = 404,-              matchHeaders = []-            }--      context "with representation requested" $ do-        it "can provide a representation" $ do-          _ <- post "/items"-            [json| { id: 1 } |]-          request methodPatch-            "/items?id=eq.1"-            [("Prefer", "return=representation")]-            [json| { id: 99 } |]-            `shouldRespondWith` [json| [{id:99}] |]-            { matchHeaders = [matchContentTypeJson] }-          -- put value back for other tests-          void $ request methodPatch "/items?id=eq.99" [] [json| { "id":1 } |]--        it "can return computed columns" $-          request methodPatch-            "/items?id=eq.1&select=id,always_true"-            [("Prefer", "return=representation")]-            [json| { id: 1 } |]-            `shouldRespondWith` [json| [{ id: 1, always_true: true }] |]-            { matchHeaders = [matchContentTypeJson] }--        it "can select overloaded computed columns" $ do-          request methodPatch-            "/items?id=eq.1&select=id,computed_overload"-            [("Prefer", "return=representation")]-            [json| { id: 1 } |]-            `shouldRespondWith` [json| [{ id: 1, computed_overload: true }] |]-            { matchHeaders = [matchContentTypeJson] }-          request methodPatch-            "/items2?id=eq.1&select=id,computed_overload"-            [("Prefer", "return=representation")]-            [json| { id: 1 } |]-            `shouldRespondWith` [json| [{ id: 1, computed_overload: true }] |]-            { matchHeaders = [matchContentTypeJson] }--      it "ignores ?select= when return not set or return=minimal" $ do-        request methodPatch "/items?id=eq.1&select=id" [] [json| { id:1 } |]-          `shouldRespondWith` ""-          {-            matchStatus  = 204,-            matchHeaders = ["Content-Range" <:> "0-0/*"]-          }-        request methodPatch "/items?id=eq.1&select=id" [("Prefer", "return=minimal")] [json| { id:1 } |]-          `shouldRespondWith` ""-          {-            matchStatus  = 204,-            matchHeaders = ["Content-Range" <:> "0-0/*"]-          }--      context "when patching with an empty body" $ do-        it "makes no updates and returns 204 without return= and without ?select=" $ do-          request methodPatch "/items" [] [json| {} |]-            `shouldRespondWith` ""-            {-              matchStatus  = 204,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--          request methodPatch "/items" [] [json| [] |]-            `shouldRespondWith` ""-            {-              matchStatus  = 204,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--          request methodPatch "/items" [] [json| [{}] |]-            `shouldRespondWith` ""-            {-              matchStatus  = 204,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--        it "makes no updates and returns 204 without return= and with ?select=" $ do-          request methodPatch "/items?select=id" [] [json| {} |]-            `shouldRespondWith` ""-            {-              matchStatus  = 204,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--          request methodPatch "/items?select=id" [] [json| [] |]-            `shouldRespondWith` ""-            {-              matchStatus  = 204,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--          request methodPatch "/items?select=id" [] [json| [{}] |]-            `shouldRespondWith` ""-            {-              matchStatus  = 204,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--        it "makes no updates and returns 200 with return=rep and without ?select=" $-          request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |]-            `shouldRespondWith` "[]"-            {-              matchStatus  = 200,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--        it "makes no updates and returns 200 with return=rep and with ?select=" $-          request methodPatch "/items?select=id" [("Prefer", "return=representation")] [json| {} |]-            `shouldRespondWith` "[]"-            {-              matchStatus  = 200,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--        it "makes no updates and returns 200 with return=rep and with ?select= for overloaded computed columns" $-          request methodPatch "/items?select=id,computed_overload" [("Prefer", "return=representation")] [json| {} |]-            `shouldRespondWith` "[]"-            {-              matchStatus  = 200,-              matchHeaders = ["Content-Range" <:> "*/*"]-            }--    context "with unicode values" $-      it "succeeds and returns values intact" $ do-        void $ request methodPost "/no_pk" []-          [json| { "a":"patchme", "b":"patchme" } |]-        let payload = [json| { "a":"圍棋", "b":"￥" } |]-        p <- request methodPatch "/no_pk?a=eq.patchme&b=eq.patchme"-          [("Prefer", "return=representation")] payload-        liftIO $ do-          simpleBody p `shouldBe` "["<>payload<>"]"-          simpleStatus p `shouldBe` ok200--    context "PATCH with ?columns parameter" $ do-      it "ignores json keys not included in ?columns" $-        request methodPatch "/articles?id=eq.200&columns=body" [("Prefer", "return=representation")]-          [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith`-          [json|[{"id": 200, "body": "Some real content", "owner": "postgrest_test_anonymous"}]|]-          { matchStatus  = 200-          , matchHeaders = [] }--      it "ignores json keys and gives 404 if no record updated" $-        request methodPatch "/articles?id=eq.2001&columns=body" [("Prefer", "return=representation")]-          [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith` 404+            204    describe "Row level permission" $     it "set user_id when inserting rows" $ do-      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0"-      _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]-      _ <- post "/postgrest/users" [json| { "id":"jroe", "pass": "1234", "role": "postgrest_test_author" } |]--      p1 <- request methodPost "/authors_only"-        [ auth, ("Prefer", "return=representation") ]-        [json| { "secret": "nyancat" } |]-      liftIO $ do-        simpleBody p1 `shouldBe` [str|[{"owner":"jdoe","secret":"nyancat"}]|]-        simpleStatus p1 `shouldBe` created201+      request methodPost "/authors_only"+          [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0", ("Prefer", "return=representation") ]+          [json| { "secret": "nyancat" } |]+        `shouldRespondWith`+          [json|[{"owner":"jdoe","secret":"nyancat"}]|]+          { matchStatus  = 201 } -      p2 <- request methodPost "/authors_only"-        -- jwt token for jroe-        [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.2e7mx0U4uDcInlbJVOBGlrRufwqWLINDIEDC1vS0nw8", ("Prefer", "return=representation") ]-        [json| { "secret": "lolcat", "owner": "hacker" } |]-      liftIO $ do-        simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|]-        simpleStatus p2 `shouldBe` created201+      request methodPost "/authors_only"+          -- jwt token for jroe+          [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.2e7mx0U4uDcInlbJVOBGlrRufwqWLINDIEDC1vS0nw8", ("Prefer", "return=representation") ]+          [json| { "secret": "lolcat", "owner": "hacker" } |]+        `shouldRespondWith`+          [json|[{"owner":"jroe","secret":"lolcat"}]|]+          { matchStatus  = 201 }    context "tables with self reference foreign keys" $ do     it "embeds parent after insert" $@@ -693,75 +476,10 @@         , matchHeaders = [ matchContentTypeJson , "Location" <:> "/web_content?id=eq.6" ]         } -    it "embeds children 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, children and grandchildren 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 children 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}]|]+        [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` [json|[{"article_id":2,"user_id":1}]|]         { matchStatus  = 201         , matchHeaders = []         }@@ -770,9 +488,9 @@       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"}|]+      [json|{"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"}|]+      [json|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]                                                                       )         { matchStatus  = 401         , matchHeaders = []@@ -782,28 +500,50 @@       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"}|]+      [json|{"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"}|]+      [json|{"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+      request methodPost "/insertonly"+          [("Prefer", "return=minimal")]+          [json| { "v":"some value" } |]+        `shouldRespondWith`+          ""+          { matchStatus = 201 } -    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+  describe "Inserting into VIEWs" $ do+    context "requesting no representation" $+      it "succeeds with 201" $+        post "/compound_pk_view"+            [json|{"k1":1,"k2":"test","extra":2}|]+          `shouldRespondWith`+            ""+            { matchStatus  = 201+            , matchHeaders = [ matchHeaderAbsent hLocation ]+            } -    it "can update without return=minimal and no explicit select" $-      request methodPatch "/app_users?id=eq.1" []-        [json| { "password": "passabc" } |]-          `shouldRespondWith` 204+    context "requesting header only representation" $ do+      it "returns a location header" $+        request methodPost "/compound_pk_view" [("Prefer", "return=headers-only")]+            [json|{"k1":1,"k2":"test","extra":2}|]+          `shouldRespondWith`+            ""+            { matchStatus  = 201+            , matchHeaders = [ "Location" <:> "/compound_pk_view?k1=eq.1&k2=eq.test"+                             , "Content-Range" <:> "*/*" ]+            }++      it "should not throw and return location header when a PK is null" $+        request methodPost "/test_null_pk_competitors_sponsors" [("Prefer", "return=headers-only")]+            [json|{"id":1}|]+          `shouldRespondWith`+            ""+            { matchStatus  = 201+            , matchHeaders = [ "Location" <:> "/test_null_pk_competitors_sponsors?id=eq.1&sponsor_id=is.null"+                             , "Content-Range" <:> "*/*" ]+            }
test/Feature/JsonOperatorSpec.hs view
@@ -7,8 +7,10 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import PostgREST.Types (PgVersion, pgVersion112, pgVersion121)-import Protolude       hiding (get)+import PostgREST.Config.PgVersion (PgVersion, pgVersion112,+                                   pgVersion121, pgVersion95)++import Protolude  hiding (get) import SpecHelper  spec :: PgVersion -> SpecWith ((), Application)@@ -139,20 +141,20 @@    context "filtering response" $ do     it "can filter by properties inside json column" $ do-      get "/json?data->foo->>bar=eq.baz" `shouldRespondWith`+      get "/json_table?data->foo->>bar=eq.baz" `shouldRespondWith`         [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |]         { matchHeaders = [matchContentTypeJson] }-      get "/json?data->foo->>bar=eq.fake" `shouldRespondWith`+      get "/json_table?data->foo->>bar=eq.fake" `shouldRespondWith`         [json| [] |]         { matchHeaders = [matchContentTypeJson] }      it "can filter by properties inside json column using not" $-      get "/json?data->foo->>bar=not.eq.baz" `shouldRespondWith`+      get "/json_table?data->foo->>bar=not.eq.baz" `shouldRespondWith`         [json| [] |]         { matchHeaders = [matchContentTypeJson] }      it "can filter by properties inside json column using ->>" $-      get "/json?data->>id=eq.1" `shouldRespondWith`+      get "/json_table?data->>id=eq.1" `shouldRespondWith`         [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |]         { matchHeaders = [matchContentTypeJson] } @@ -190,20 +192,63 @@    context "ordering response" $ do     it "orders by a json column property asc" $-      get "/json?order=data->>id.asc" `shouldRespondWith`+      get "/json_table?order=data->>id.asc" `shouldRespondWith`         [json| [{"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}, {"data": {"id": 3}}] |]         { matchHeaders = [matchContentTypeJson] }      it "orders by a json column with two level property nulls first" $-      get "/json?order=data->foo->>bar.nullsfirst" `shouldRespondWith`+      get "/json_table?order=data->foo->>bar.nullsfirst" `shouldRespondWith`         [json| [{"data": {"id": 3}}, {"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}] |]         { matchHeaders = [matchContentTypeJson] }    context "Patching record, in a nonempty table" $     it "can set a json column to escaped value" $ do-      _ <- post "/json" [json| { data: {"escaped":"bar"} } |]-      request methodPatch "/json?data->>escaped=eq.bar"-                   [("Prefer", "return=representation")]-                   [json| { "data": { "escaped":" \"bar" } } |]-        `shouldRespondWith` [json| [{ "data": { "escaped":" \"bar" } }] |]-        { matchStatus  = 200 , matchHeaders = [] }+      request methodPatch "/json_table?data->>id=eq.3"+          [("Prefer", "return=representation")]+          [json| { "data": { "id":" \"escaped" } } |]+        `shouldRespondWith`+          [json| [{ "data": { "id":" \"escaped" } }] |]++  when (actualPgVersion >= pgVersion95) $+    context "json array negative index" $ do+      it "can select with negative indexes" $ do+        get "/json_arr?select=data->>-1::int&id=in.(1,2)" `shouldRespondWith`+          [json| [{"data":3}, {"data":6}] |]+          { matchHeaders = [matchContentTypeJson] }+        get "/json_arr?select=data->0->>-2::int&id=in.(3,4)" `shouldRespondWith`+          [json| [{"data":8}, {"data":7}] |]+          { matchHeaders = [matchContentTypeJson] }+        get "/json_arr?select=data->-2->>a&id=in.(5,6)" `shouldRespondWith`+          [json| [{"a":"A"}, {"a":"[1,2,3]"}] |]+          { matchHeaders = [matchContentTypeJson] }++      it "can filter with negative indexes" $ do+        get "/json_arr?select=data&data->>-3=eq.1" `shouldRespondWith`+          [json| [{"data":[1, 2, 3]}] |]+          { matchHeaders = [matchContentTypeJson] }+        get "/json_arr?select=data&data->-1->>-3=eq.11" `shouldRespondWith`+          [json| [{"data":[[9, 8, 7], [11, 12, 13]]}] |]+          { matchHeaders = [matchContentTypeJson] }+        get "/json_arr?select=data&data->-1->>b=eq.B" `shouldRespondWith`+          [json| [{"data":[{"a": "A"}, {"b": "B"}]}] |]+          { matchHeaders = [matchContentTypeJson] }+        get "/json_arr?select=data&data->-1->b->>-1=eq.5" `shouldRespondWith`+          [json| [{"data":[{"a": [1,2,3]}, {"b": [4,5]}]}] |]+          { matchHeaders = [matchContentTypeJson] }++      it "should fail on badly formed negatives" $ do+        get "/json_arr?select=data->>-78xy" `shouldRespondWith`+          [json|+            {"details": "unexpected 'x' expecting digit, \"->\", \"::\" or end of input",+             "message": "\"failed to parse select parameter (data->>-78xy)\" (line 1, column 11)"} |]+          { matchStatus = 400, matchHeaders = [matchContentTypeJson] }+        get "/json_arr?select=data->>--34" `shouldRespondWith`+          [json|+            {"details": "unexpected \"-\" expecting digit",+             "message": "\"failed to parse select parameter (data->>--34)\" (line 1, column 9)"} |]+          { matchStatus = 400, matchHeaders = [matchContentTypeJson] }+        get "/json_arr?select=data->>-xy-4" `shouldRespondWith`+          [json|+            {"details":"unexpected \"x\" expecting digit",+             "message":"\"failed to parse select parameter (data->>-xy-4)\" (line 1, column 9)"} |]+          { matchStatus = 400, matchHeaders = [matchContentTypeJson] }
test/Feature/MultipleSchemaSpec.hs view
@@ -15,7 +15,7 @@ import Protolude import SpecHelper -import PostgREST.Types (PgVersion, pgVersion96)+import PostgREST.Config.PgVersion (PgVersion, pgVersion96)  spec :: PgVersion -> SpecWith ((), Application) spec actualPgVersion =@@ -77,33 +77,37 @@      context "Inserting tables on different schemas" $ do       it "succeeds inserting on default schema and returning it" $-        request methodPost "/children" [("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"]-         }+        request methodPost "/children"+            [("Prefer", "return=representation")]+            [json|{"id": 0, "name": "child v1-1", "parent_id": 1}|]+          `shouldRespondWith`+            [json|[{"id": 0, "name": "child v1-1", "parent_id": 1}]|]+            {+              matchStatus = 201+            , matchHeaders = ["Content-Profile" <:> "v1"]+            }        it "succeeds inserting on the v1 schema and returning its parent" $-        request methodPost "/children?select=id,parent(*)" [("Prefer", "return=representation"), ("Content-Profile", "v1")]-          [json|{"name": "child v1-2", "parent_id": 2}|]+        request methodPost "/children?select=id,parent(*)"+            [("Prefer", "return=representation"), ("Content-Profile", "v1")]+            [json|{"id": 0, "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"]-          }+            [json|[{"id": 0, "parent": {"id": 2, "name": "parent v1-2"}}]|]+            {+              matchStatus = 201+            , matchHeaders = ["Content-Profile" <:> "v1"]+            }        it "succeeds inserting on the v2 schema and returning its parent" $-        request methodPost "/children?select=id,parent(*)" [("Prefer", "return=representation"), ("Content-Profile", "v2")]-          [json|{"name": "child v2-3", "parent_id": 3}|]+        request methodPost "/children?select=id,parent(*)"+            [("Prefer", "return=representation"), ("Content-Profile", "v2")]+            [json|{"id": 0, "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"]-          }+            [json|[{"id": 0, "parent": {"id": 3, "name": "parent v2-3"}}]|]+            {+              matchStatus = 201+            , matchHeaders = ["Content-Profile" <:> "v2"]+            }        it "fails when inserting on an unknown schema" $         request methodPost "/children" [("Content-Profile", "unknown")]@@ -180,18 +184,12 @@           }        it "succeeds on deleting on the v2 schema" $ do-        request methodDelete "/children?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 "/children?id=eq.1" [("Accept-Profile", "v2")] ""-          `shouldRespondWith` "[]"-          {-            matchStatus = 200-          , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"]-          }+        request methodDelete "/children?id=eq.1"+            [("Content-Profile", "v2"), ("Prefer", "return=representation")]+            ""+          `shouldRespondWith`+            [json|[{"id": 1, "name": "child v2-3", "parent_id": 3}]|]+            { matchHeaders = ["Content-Profile" <:> "v2"] }        when (actualPgVersion >= pgVersion96) $         it "succeeds on PUT on the v2 schema" $
+ test/Feature/OpenApiSpec.hs view
@@ -0,0 +1,504 @@+module Feature.OpenApiSpec where++import Control.Lens     ((^?))+import Data.Aeson.Types (Value (..))+import Network.Wai      (Application)+import Network.Wai.Test (SResponse (..))++import Data.Aeson.Lens+import Data.Aeson.QQ+import Network.HTTP.Types+import Test.Hspec         hiding (pendingWith)+import Test.Hspec.Wai++import PostgREST.Version (docsVersion)+import Protolude         hiding (get)+import SpecHelper++spec :: SpecWith ((), Application)+spec = describe "OpenAPI" $ do+  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"+            (acceptHdrs "application/openapi+json") ""+      `shouldRespondWith` 415++  it "includes postgrest.org current version api docs" $ do+    r <- simpleBody <$> get "/"++    let docsUrl = r ^? key "externalDocs" . key "url"++    liftIO $ docsUrl `shouldBe` Just (String ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))++  describe "table" $ do++    it "includes paths to tables" $ do+      r <- simpleBody <$> get "/"++      let method s = key "paths" . key "/child_entities" . key s+          childGetSummary = r ^? method "get" . key "summary"+          childGetDescription = r ^? method "get" . key "description"+          getParameters = r ^? method "get" . key "parameters"+          postParameters = r ^? method "post" . key "parameters"+          postResponse = r ^? method "post" . key "responses" . key "201" . key "description"+          patchResponse = r ^? method "patch" . key "responses" . key "204" . key "description"+          deleteResponse = r ^? method "delete" . key "responses" . key "204" . key "description"++      let grandChildGet s = key "paths" . key "/grandchild_entities" . key "get" . key s+          grandChildGetSummary = r ^? grandChildGet "summary"+          grandChildGetDescription = r ^? grandChildGet "description"++      liftIO $ do++        childGetSummary `shouldBe` Just "child_entities comment"++        childGetDescription `shouldBe` Nothing++        grandChildGetSummary `shouldBe` Just "grandchild_entities summary"++        grandChildGetDescription `shouldBe` Just "grandchild_entities description\nthat spans\nmultiple lines"++        getParameters `shouldBe` Just+          [aesonQQ|+            [+              { "$ref": "#/parameters/rowFilter.child_entities.id" },+              { "$ref": "#/parameters/rowFilter.child_entities.name" },+              { "$ref": "#/parameters/rowFilter.child_entities.parent_id" },+              { "$ref": "#/parameters/select" },+              { "$ref": "#/parameters/order" },+              { "$ref": "#/parameters/range" },+              { "$ref": "#/parameters/rangeUnit" },+              { "$ref": "#/parameters/offset" },+              { "$ref": "#/parameters/limit" },+              { "$ref": "#/parameters/preferCount" }+            ]+          |]++        postParameters `shouldBe` Just+          [aesonQQ|+            [+              { "$ref": "#/parameters/body.child_entities" },+              { "$ref": "#/parameters/select" },+              { "$ref": "#/parameters/preferReturn" }+            ]+          |]++        postResponse `shouldBe` Just "Created"++        patchResponse `shouldBe` Just "No Content"++        deleteResponse `shouldBe` Just "No Content"++    it "includes an array type for GET responses" $ do+      r <- simpleBody <$> get "/"++      let childGetSchema = r ^? key "paths"+            . key "/child_entities"+            . key "get"+            . key "responses"+            . key "200"+            . key "schema"++      liftIO $+        childGetSchema `shouldBe` Just+          [aesonQQ|+            {+              "items": {+                "$ref": "#/definitions/child_entities"+              },+              "type": "array"+            }+          |]++    it "includes definitions to tables" $ do+      r <- simpleBody <$> get "/"++      let def = r ^? key "definitions" . key "child_entities"++      liftIO $++        def `shouldBe` Just+          [aesonQQ|+            {+              "type": "object",+              "description": "child_entities comment",+              "properties": {+                "id": {+                  "description": "child_entities id comment\n\nNote:\nThis is a Primary Key.<pk/>",+                  "format": "integer",+                  "type": "integer"+                },+                "name": {+                  "description": "child_entities name comment. Can be longer than sixty-three characters long",+                  "format": "text",+                  "type": "string"+                },+                "parent_id": {+                  "description": "Note:\nThis is a Foreign Key to `entities.id`.<fk table='entities' column='id'/>",+                  "format": "integer",+                  "type": "integer"+                }+              },+              "required": [+                "id"+              ]+            }+          |]++    it "doesn't include privileged table for anonymous" $ do+      r <- simpleBody <$> get "/"+      let tablePath = r ^? key "paths" . key "/authors_only"++      liftIO $ tablePath `shouldBe` Nothing++    it "includes table if user has permission" $ do+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"+      r <- simpleBody <$> request methodGet "/" [auth] ""+      let tableTag = r ^? key "paths" . key "/authors_only"+                    . key "post"  . key "tags"+                    . nth 0+      liftIO $ tableTag `shouldBe` Just [aesonQQ|"authors_only"|]++  describe "Foreign table" $++    it "includes foreign table properties" $ do+      r <- simpleBody <$> get "/"++      let method s = key "paths" . key "/projects_dump" . key s+          getSummary = r ^? method "get" . key "summary"+          getDescription = r ^? method "get" . key "description"+          getParameters = r ^? method "get" . key "parameters"++      liftIO $ do++        getSummary `shouldBe` Just "A temporary projects dump"++        getDescription `shouldBe` Just "Just a test for foreign tables"++        getParameters `shouldBe` Just+          [aesonQQ|+            [+              { "$ref": "#/parameters/rowFilter.projects_dump.id" },+              { "$ref": "#/parameters/rowFilter.projects_dump.name" },+              { "$ref": "#/parameters/rowFilter.projects_dump.client_id" },+              { "$ref": "#/parameters/select" },+              { "$ref": "#/parameters/order" },+              { "$ref": "#/parameters/range" },+              { "$ref": "#/parameters/rangeUnit" },+              { "$ref": "#/parameters/offset" },+              { "$ref": "#/parameters/limit" },+              { "$ref": "#/parameters/preferCount" }+            ]+          |]++  describe "Materialized view" $++    it "includes materialized view properties" $ do+      r <- simpleBody <$> get "/"++      let method s = key "paths" . key "/materialized_projects" . key s+          summary = r ^? method "get" . key "summary"+          description = r ^? method "get" . key "description"+          parameters = r ^? method "get" . key "parameters"++      liftIO $ do++        summary `shouldBe` Just "A materialized view for projects"++        description `shouldBe` Just "Just a test for materialized views"++        parameters `shouldBe` Just+          [aesonQQ|+            [+              { "$ref": "#/parameters/rowFilter.materialized_projects.id" },+              { "$ref": "#/parameters/rowFilter.materialized_projects.name" },+              { "$ref": "#/parameters/rowFilter.materialized_projects.client_id" },+              { "$ref": "#/parameters/select" },+              { "$ref": "#/parameters/order" },+              { "$ref": "#/parameters/range" },+              { "$ref": "#/parameters/rangeUnit" },+              { "$ref": "#/parameters/offset" },+              { "$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++    it "character varying to string" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character_varying"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "character varying",+              "type": "string"+            }+          |]+    it "character(1) to string" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "maxLength": 1,+              "format": "character",+              "type": "string"+            }+          |]++    it "text to string" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_text"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "text",+              "type": "string"+            }+          |]++    it "boolean to boolean" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_boolean"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "boolean",+              "type": "boolean"+            }+          |]++    it "smallint to integer" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_smallint"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "smallint",+              "type": "integer"+            }+          |]++    it "integer to integer" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_integer"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "integer",+              "type": "integer"+            }+          |]++    it "bigint to integer" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_bigint"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "bigint",+              "type": "integer"+            }+          |]++    it "numeric to number" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_numeric"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "numeric",+              "type": "number"+            }+          |]++    it "real to number" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_real"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "real",+              "type": "number"+            }+          |]++    it "double_precision to number" $ do+      r <- simpleBody <$> get "/"++      let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_double_precision"++      liftIO $++        types `shouldBe` Just+          [aesonQQ|+            {+              "format": "double precision",+              "type": "number"+            }+          |]++  describe "RPC" $ do++    it "includes function summary/description and body schema for arguments" $ do+      r <- simpleBody <$> get "/"++      let method s = key "paths" . key "/rpc/varied_arguments" . key s+          args = r ^? method "post" . key "parameters" . nth 0 . key "schema"+          summary = r ^? method "post" . key "summary"+          description = r ^? method "post" . key "description"++      liftIO $ do++        summary `shouldBe` Just "An RPC function"++        description `shouldBe` Just "Just a test for RPC function arguments"++        args `shouldBe` Just+          [aesonQQ|+            {+              "required": [+                "double",+                "varchar",+                "boolean",+                "date",+                "money",+                "enum",+                "arr"+              ],+              "properties": {+                "double": {+                  "format": "double precision",+                  "type": "number"+                },+                "varchar": {+                  "format": "character varying",+                  "type": "string"+                },+                "boolean": {+                  "format": "boolean",+                  "type": "boolean"+                },+                "date": {+                  "format": "date",+                  "type": "string"+                },+                "money": {+                  "format": "money",+                  "type": "string"+                },+                "enum": {+                  "format": "enum_menagerie_type",+                  "type": "string"+                },+                "arr": {+                  "format": "text[]",+                  "type": "string"+                },+                "integer": {+                  "format": "integer",+                  "type": "integer"+                },+                "json": {+                  "format": "json",+                  "type": "string"+                },+                "jsonb": {+                  "format": "jsonb",+                  "type": "string"+                }+              },+              "type": "object",+              "description": "An RPC function\n\nJust a test for RPC function arguments"+            }+          |]++    it "doesn't include privileged function for anonymous" $ do+      r <- simpleBody <$> get "/"+      let funcPath = r ^? key "paths" . key "/rpc/privileged_hello"++      liftIO $ funcPath `shouldBe` Nothing++    it "includes function if user has permission" $ do+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"+      r <- simpleBody <$> request methodGet "/" [auth] ""+      let funcTag = r ^? key "paths" . key "/rpc/privileged_hello"+                    . key "post"  . key "tags"+                    . nth 0++      liftIO $ funcTag `shouldBe` Just [aesonQQ|"(rpc) privileged_hello"|]++    it "doesn't include OUT params of function as required parameters" $ do+      r <- simpleBody <$> get "/"+      let params = r ^? key "paths" . key "/rpc/many_out_params"+                      . key "post" . key "parameters" .  nth 0+                      . key "schema". key "required"++      liftIO $ params `shouldBe` Nothing++    it "includes INOUT params(with no DEFAULT) of function as required parameters" $ do+      r <- simpleBody <$> get "/"+      let params = r ^? key "paths" . key "/rpc/many_inout_params"+                      . key "post" . key "parameters" .  nth 0+                      . key "schema". key "required"++      liftIO $ params `shouldBe` Just [aesonQQ|["num", "str"]|]+
+ test/Feature/OptionsSpec.hs view
@@ -0,0 +1,71 @@+module Feature.OptionsSpec where++import Network.Wai      (Application)+import Network.Wai.Test (SResponse (..))++import Network.HTTP.Types+import Test.Hspec+import Test.Hspec.Wai++import Protolude+import SpecHelper++spec :: SpecWith ((), Application)+spec = describe "Allow header" $ do+  context "a table" $ do+    it "includes read/write verbs for writeable table" $ do+      r <- request methodOptions "/items" [] ""+      liftIO $+        simpleHeaders r `shouldSatisfy`+          matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PUT,PATCH,DELETE"++  context "a view" $ do+    context "auto updatable" $ do+      it "includes read/write verbs for auto updatable views with pk" $ do+        r <- request methodOptions "/projects_auto_updatable_view_with_pk" [] ""+        liftIO $+          simpleHeaders r `shouldSatisfy`+            matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PUT,PATCH,DELETE"++      it "includes read/write verbs for auto updatable views without pk" $ do+        r <- request methodOptions "/projects_auto_updatable_view_without_pk" [] ""+        liftIO $+          simpleHeaders r `shouldSatisfy`+            matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PATCH,DELETE"++    context "non auto updatable" $ do+      it "includes read verbs for non auto updatable views" $ do+        r <- request methodOptions "/projects_view_without_triggers" [] ""+        liftIO $+          simpleHeaders r `shouldSatisfy`+            matchHeader "Allow" "OPTIONS,GET,HEAD"++      it "includes read/write verbs for insertable, updatable and deletable views with pk" $ do+        r <- request methodOptions "/projects_view_with_all_triggers_with_pk" [] ""+        liftIO $+          simpleHeaders r `shouldSatisfy`+            matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PUT,PATCH,DELETE"++      it "includes read/write verbs for insertable, updatable and deletable views without pk" $ do+        r <- request methodOptions "/projects_view_with_all_triggers_without_pk" [] ""+        liftIO $+          simpleHeaders r `shouldSatisfy`+            matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PATCH,DELETE"++      it "includes read and insert verbs for insertable views" $ do+        r <- request methodOptions "/projects_view_with_insert_trigger" [] ""+        liftIO $+          simpleHeaders r `shouldSatisfy`+            matchHeader "Allow" "OPTIONS,GET,HEAD,POST"++      it "includes read and update verbs for updatable views" $ do+        r <- request methodOptions "/projects_view_with_update_trigger" [] ""+        liftIO $+          simpleHeaders r `shouldSatisfy`+            matchHeader "Allow" "OPTIONS,GET,HEAD,PATCH"++      it "includes read and delete verbs for deletable views" $ do+        r <- request methodOptions "/projects_view_with_delete_trigger" [] ""+        liftIO $+          simpleHeaders r `shouldSatisfy`+            matchHeader "Allow" "OPTIONS,GET,HEAD,DELETE"
− test/Feature/PgVersion95Spec.hs 
@@ -1,55 +0,0 @@-module Feature.PgVersion95Spec where--import Network.Wai (Application)--import Test.Hspec-import Test.Hspec.Wai-import Test.Hspec.Wai.JSON--import Protolude  hiding (get)-import SpecHelper--spec :: SpecWith ((), Application)-spec = describe "features supported on PostgreSQL 9.5" $-  context "json array negative index" $ do-    it "can select with negative indexes" $ do-      get "/json_arr?select=data->>-1::int&id=in.(1,2)" `shouldRespondWith`-        [json| [{"data":3}, {"data":6}] |]-        { matchHeaders = [matchContentTypeJson] }-      get "/json_arr?select=data->0->>-2::int&id=in.(3,4)" `shouldRespondWith`-        [json| [{"data":8}, {"data":7}] |]-        { matchHeaders = [matchContentTypeJson] }-      get "/json_arr?select=data->-2->>a&id=in.(5,6)" `shouldRespondWith`-        [json| [{"a":"A"}, {"a":"[1,2,3]"}] |]-        { matchHeaders = [matchContentTypeJson] }--    it "can filter with negative indexes" $ do-      get "/json_arr?select=data&data->>-3=eq.1" `shouldRespondWith`-        [json| [{"data":[1, 2, 3]}] |]-        { matchHeaders = [matchContentTypeJson] }-      get "/json_arr?select=data&data->-1->>-3=eq.11" `shouldRespondWith`-        [json| [{"data":[[9, 8, 7], [11, 12, 13]]}] |]-        { matchHeaders = [matchContentTypeJson] }-      get "/json_arr?select=data&data->-1->>b=eq.B" `shouldRespondWith`-        [json| [{"data":[{"a": "A"}, {"b": "B"}]}] |]-        { matchHeaders = [matchContentTypeJson] }-      get "/json_arr?select=data&data->-1->b->>-1=eq.5" `shouldRespondWith`-        [json| [{"data":[{"a": [1,2,3]}, {"b": [4,5]}]}] |]-        { matchHeaders = [matchContentTypeJson] }--    it "should fail on badly formed negatives" $ do-      get "/json_arr?select=data->>-78xy" `shouldRespondWith`-        [json|-          {"details": "unexpected 'x' expecting digit, \"->\", \"::\" or end of input",-           "message": "\"failed to parse select parameter (data->>-78xy)\" (line 1, column 11)"} |]-        { matchStatus = 400, matchHeaders = [matchContentTypeJson] }-      get "/json_arr?select=data->>--34" `shouldRespondWith`-        [json|-          {"details": "unexpected \"-\" expecting digit",-           "message": "\"failed to parse select parameter (data->>--34)\" (line 1, column 9)"} |]-        { matchStatus = 400, matchHeaders = [matchContentTypeJson] }-      get "/json_arr?select=data->>-xy-4" `shouldRespondWith`-        [json|-          {"details":"unexpected \"x\" expecting digit",-           "message":"\"failed to parse select parameter (data->>-xy-4)\" (line 1, column 9)"} |]-        { matchStatus = 400, matchHeaders = [matchContentTypeJson] }
− test/Feature/PgVersion96Spec.hs 
@@ -1,195 +0,0 @@-module Feature.PgVersion96Spec where--import Network.HTTP.Types-import Network.Wai        (Application)-import Network.Wai.Test   (SResponse (simpleHeaders))--import Test.Hspec-import Test.Hspec.Wai-import Test.Hspec.Wai.JSON--import Protolude  hiding (get)-import SpecHelper--spec :: SpecWith ((), Application)-spec =-  describe "features supported on PostgreSQL 9.6" $ 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}]|]-          {matchHeaders = [-              matchContentTypeJson,-              "X-Test"   <:> "key1=val1; someValue; key2=val2",-              "X-Test-2" <:> "key1=val1"]}-        get "/rpc/get_int_and_guc_headers?num=1"-          `shouldRespondWith` [json|1|]-          {matchHeaders = [-              matchContentTypeJson,-              "X-Test"   <:> "key1=val1; someValue; key2=val2",-              "X-Test-2" <:> "key1=val1"]}-        post "/rpc/get_int_and_guc_headers" [json|{"num": 1}|]-          `shouldRespondWith` [json|1|]-          {matchHeaders = [-              matchContentTypeJson,-              "X-Test"   <:> "key1=val1; someValue; key2=val2",-              "X-Test-2" <:> "key1=val1"]}--      it "fails when setting headers with wrong json structure" $ do-        get "/rpc/bad_guc_headers_1"-          `shouldRespondWith`-          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]-          { matchStatus  = 500-          , matchHeaders = [ matchContentTypeJson ]-          }-        get "/rpc/bad_guc_headers_2"-          `shouldRespondWith`-          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]-          { matchStatus  = 500-          , matchHeaders = [ matchContentTypeJson ]-          }-        get "/rpc/bad_guc_headers_3"-          `shouldRespondWith`-          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]-          { matchStatus  = 500-          , matchHeaders = [ matchContentTypeJson ]-          }-        post "/rpc/bad_guc_headers_1" [json|{}|]-          `shouldRespondWith`-          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]-          { matchStatus  = 500-          , matchHeaders = [ matchContentTypeJson ]-          }--      it "can set the same http header twice" $-        get "/rpc/set_cookie_twice"-          `shouldRespondWith` "null"-          {matchHeaders = [-              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" $-        get "/tsearch?text_search_vector=phfts.The%20Fat%20Cats" `shouldRespondWith`-          [json| [{"text_search_vector": "'ate':3 'cat':2 'fat':1 'rat':4" }] |]-          { matchHeaders = [matchContentTypeJson] }--      it "finds matches with different dictionaries" $-        get "/tsearch?text_search_vector=phfts(german).Art%20Spass" `shouldRespondWith`-          [json| [{"text_search_vector": "'art':4 'spass':5 'unmog':7" }] |]-          { matchHeaders = [matchContentTypeJson] }--      it "can be negated with not operator" $-        get "/tsearch?text_search_vector=not.phfts(english).The%20Fat%20Cats" `shouldRespondWith`-          [json| [-            {"text_search_vector": "'fun':5 'imposs':9 'kind':3"},-            {"text_search_vector": "'also':2 'fun':3 'possibl':8"},-            {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4"},-            {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|]-          { matchHeaders = [matchContentTypeJson] }--      it "can be used with or query param" $-        get "/tsearch?or=(text_search_vector.phfts(german).Art%20Spass, text_search_vector.phfts(french).amusant, text_search_vector.fts(english).impossible)" `shouldRespondWith`-          [json|[-            {"text_search_vector": "'fun':5 'imposs':9 'kind':3" },-            {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4" },-            {"text_search_vector": "'art':4 'spass':5 'unmog':7"}-          ]|] { matchHeaders = [matchContentTypeJson] }--      it "should work when used with GET RPC" $-        get "/rpc/get_tsearch?text_search_vector=phfts(english).impossible" `shouldRespondWith`-          [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|]-          { matchHeaders = [matchContentTypeJson] }
test/Feature/QueryLimitedSpec.hs view
@@ -1,7 +1,6 @@ module Feature.QueryLimitedSpec where -import Network.Wai      (Application)-import Network.Wai.Test (SResponse (simpleHeaders, simpleStatus))+import Network.Wai (Application)  import Network.HTTP.Types import Test.Hspec@@ -15,59 +14,56 @@ spec =   describe "Requesting many items with server limits(max-rows) enabled" $ do     it "restricts results" $-      get "/items"-        `shouldRespondWith` [json| [{"id":1},{"id":2}] |]-        { matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-1/*"]-        }+      get "/items?order=id"+        `shouldRespondWith`+          [json| [{"id":1},{"id":2}] |]+          { matchHeaders = ["Content-Range" <:> "0-1/*"] }      it "respects additional client limiting" $ do-      r <- request methodGet  "/items"-                   (rangeHdrs $ ByteRangeFromTo 0 0) ""-      liftIO $ do-        simpleHeaders r `shouldSatisfy`-          matchHeader "Content-Range" "0-0/*"-        simpleStatus r `shouldBe` ok200+      request methodGet  "/items"+          (rangeHdrs $ ByteRangeFromTo 0 0)+          ""+        `shouldRespondWith`+          [json| [{"id":1}] |]+          { matchHeaders = ["Content-Range" <:> "0-0/*"] }      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/*"]-        }+        `shouldRespondWith`+          [json|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|]+          { matchHeaders = ["Content-Range" <:> "0-1/*"] }      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/*"]-        }+        `shouldRespondWith`+          [json|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|]+          { 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/*"]-        }+        `shouldRespondWith`+          [json|[{"id":6,"project":null}, {"id":7,"project":null}]|]+          { 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"]-          }+          `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"]-          }+          `shouldRespondWith`+            ""+            { 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"]-          }+          `shouldRespondWith`+            ""+            { matchStatus  = 206+            , matchHeaders = ["Content-Range" <:> "0-1/3"]+            }
test/Feature/QuerySpec.hs view
@@ -8,10 +8,9 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Text.Heredoc--import PostgREST.Types (PgVersion, pgVersion112, pgVersion121)-import Protolude       hiding (get)+import PostgREST.Config.PgVersion (PgVersion, pgVersion112,+                                   pgVersion121, pgVersion96)+import Protolude                  hiding (get) import SpecHelper  spec :: PgVersion -> SpecWith ((), Application)@@ -36,7 +35,7 @@         { matchHeaders = ["Content-Range" <:> "0-0/*"] }      it "matches with equality using not operator" $-      get "/items?id=not.eq.5"+      get "/items?id=not.eq.5&order=id"         `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]         { matchHeaders = ["Content-Range" <:> "0-13/*"] } @@ -71,19 +70,19 @@         [json| [{"a": null, "b": null}] |]         { matchHeaders = [matchContentTypeJson] } -      get "/nullable_integer?a=is.null" `shouldRespondWith` [str|[{"a":null}]|]+      get "/nullable_integer?a=is.null" `shouldRespondWith` [json|[{"a":null}]|]      it "matches with like" $ do       get "/simple_pk?k=like.*yx" `shouldRespondWith`-        [str|[{"k":"xyyx","extra":"u"}]|]+        [json|[{"k":"xyyx","extra":"u"}]|]       get "/simple_pk?k=like.xy*" `shouldRespondWith`-        [str|[{"k":"xyyx","extra":"u"}]|]+        [json|[{"k":"xyyx","extra":"u"}]|]       get "/simple_pk?k=like.*YY*" `shouldRespondWith`-        [str|[{"k":"xYYx","extra":"v"}]|]+        [json|[{"k":"xYYx","extra":"v"}]|]      it "matches with like using not operator" $       get "/simple_pk?k=not.like.*yx" `shouldRespondWith`-        [str|[{"k":"xYYx","extra":"v"}]|]+        [json|[{"k":"xYYx","extra":"v"}]|]      it "matches with ilike" $ do       get "/simple_pk?k=ilike.xy*&order=extra.asc" `shouldRespondWith`@@ -183,6 +182,35 @@                     {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|]                   { matchHeaders = [matchContentTypeJson] } +      when (actualPgVersion >= pgVersion96) $+        context "Use of the phraseto_tsquery function" $ do+          it "finds matches" $+            get "/tsearch?text_search_vector=phfts.The%20Fat%20Cats" `shouldRespondWith`+              [json| [{"text_search_vector": "'ate':3 'cat':2 'fat':1 'rat':4" }] |]+              { matchHeaders = [matchContentTypeJson] }++          it "finds matches with different dictionaries" $+            get "/tsearch?text_search_vector=phfts(german).Art%20Spass" `shouldRespondWith`+              [json| [{"text_search_vector": "'art':4 'spass':5 'unmog':7" }] |]+              { matchHeaders = [matchContentTypeJson] }++          it "can be negated with not operator" $+            get "/tsearch?text_search_vector=not.phfts(english).The%20Fat%20Cats" `shouldRespondWith`+              [json| [+                {"text_search_vector": "'fun':5 'imposs':9 'kind':3"},+                {"text_search_vector": "'also':2 'fun':3 'possibl':8"},+                {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4"},+                {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|]+              { matchHeaders = [matchContentTypeJson] }++          it "can be used with or query param" $+            get "/tsearch?or=(text_search_vector.phfts(german).Art%20Spass, text_search_vector.phfts(french).amusant, text_search_vector.fts(english).impossible)" `shouldRespondWith`+              [json|[+                {"text_search_vector": "'fun':5 'imposs':9 'kind':3" },+                {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4" },+                {"text_search_vector": "'art':4 'spass':5 'unmog':7"}+              ]|] { matchHeaders = [matchContentTypeJson] }+     it "matches with computed column" $       get "/items?always_true=eq.true&order=id.asc" `shouldRespondWith`         [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]@@ -197,8 +225,10 @@       get "/items?always_false=is.false" `shouldRespondWith` 400      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 relationship found between projects and tasks2"}|]+      get "/clients?select=id,projects(id,tasks2(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith`+        [json| {+          "hint":"If a new foreign key between these entities was created in the database, try reloading the schema cache.",+          "message":"Could not find a relationship between projects and tasks2 in the schema cache"}|]         { matchStatus  = 400         , matchHeaders = [matchContentTypeJson]         }@@ -221,11 +251,11 @@   describe "Shaping response with select parameter" $ do     it "selectStar works in absense of parameter" $       get "/complex_items?id=eq.3" `shouldRespondWith`-        [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|]+        [json|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|]      it "dash `-` in column names is accepted" $       get "/complex_items?id=eq.3&select=id,field-with_sep" `shouldRespondWith`-        [str|[{"id":3,"field-with_sep":1}]|]+        [json|[{"id":3,"field-with_sep":1}]|]      it "one simple column" $       get "/complex_items?select=id" `shouldRespondWith`@@ -290,7 +320,7 @@      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}}]|]+        [json|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|]      it "rows with missing parents are included" $       get "/projects?id=in.(1,5)&select=id,clients(id)" `shouldRespondWith`@@ -299,7 +329,7 @@      it "rows with no children return [] instead of null" $       get "/projects?id=in.(5)&select=id,tasks(id)" `shouldRespondWith`-        [str|[{"id":5,"tasks":[]}]|]+        [json|[{"id":5,"tasks":[]}]|]      it "requesting children 2 levels" $       get "/clients?id=eq.1&select=id,projects(id,tasks(id))" `shouldRespondWith`@@ -321,6 +351,21 @@         [json|[{"id":1,"tasks":[{"id":1},{"id":2},{"id":3},{"id":4}]},{"id":2,"tasks":[{"id":5},{"id":6},{"id":7}]},{"id":3,"tasks":[{"id":1},{"id":5}]}]|]         { matchHeaders = [matchContentTypeJson] } +    it "requesting many<->many relation using composite key" $+      get "/files?filename=eq.autoexec.bat&project_id=eq.1&select=filename,users_tasks(user_id,task_id)" `shouldRespondWith`+        [json|[{"filename":"autoexec.bat","users_tasks":[{"user_id":1,"task_id":1},{"user_id":3,"task_id":1}]}]|]+        { matchHeaders = [matchContentTypeJson] }++    it "requesting data using many<->many relation defined by composite keys" $+      get "/users_tasks?user_id=eq.1&task_id=eq.1&select=user_id,files(filename,content)" `shouldRespondWith`+        [json|[{"user_id":1,"files":[{"filename":"command.com","content":"#include <unix.h>"},{"filename":"autoexec.bat","content":"@ECHO OFF"},{"filename":"README.md","content":"# make $$$!"}]}]|]+        { matchHeaders = [matchContentTypeJson] }++    it "requesting data using many<->many (composite keys) relation using hint" $+      get "/users_tasks?user_id=eq.1&task_id=eq.1&select=user_id,files!touched_files(filename,content)" `shouldRespondWith`+        [json|[{"user_id":1,"files":[{"filename":"command.com","content":"#include <unix.h>"},{"filename":"autoexec.bat","content":"@ECHO OFF"},{"filename":"README.md","content":"# make $$$!"}]}]|]+        { matchHeaders = [matchContentTypeJson] }+     it "requesting children with composite key" $       get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments(content)" `shouldRespondWith`         [json|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|]@@ -358,9 +403,9 @@         get "/materialized_projects?select=*,users(*)" `shouldRespondWith` 200        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] }+        get "/articleStars?select=createdAt,article:articles(id),user:users(name)&limit=1"+          `shouldRespondWith`+            [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"id": 1},"user":{"name": "Angela Martin"}}]|]        it "can detect relations in views from exposed schema that are based on tables in private schema and have columns renames" $         get "/articles?id=eq.1&select=id,articleStars(users(*))" `shouldRespondWith`@@ -391,6 +436,9 @@           [json|[ { "title": "To Kill a Mockingbird", "author": { "name": "Harper Lee" } } ]|]           { matchHeaders = [matchContentTypeJson] } +      it "can detect fk relations through multiple views recursively when all views are in api schema" $ do+        get "/consumers_view_view?select=*,orders_view(*)" `shouldRespondWith` 200+       it "works with views that have subselects" $         get "/authors_books_number?select=*,books(title)&id=eq.1" `shouldRespondWith`           [json|[ {"id":1, "name":"George Orwell","num_in_forties":1,"num_in_fifties":0,"num_in_sixties":0,"num_in_all_decades":1,@@ -408,6 +456,12 @@           [json|[{"title":"1984","first_publisher":"Secker & Warburg","author":{"name":"George Orwell"}}]|]           { matchHeaders = [matchContentTypeJson] } +      it "works with views that have subselects in a function call" $+        get "/authors_have_book_in_decade2?select=*,books(title)&id=eq.3"+          `shouldRespondWith`+            [json|[ {"id":3,"name":"Antoine de Saint-Exupéry","has_book_in_forties":true,"has_book_in_fifties":false,+                     "has_book_in_sixties":false,"books":[{"title":"The Little Prince"}]} ]|]+       it "works with views that have CTE" $         get "/odd_years_publications?select=title,publication_year,first_publisher,author:authors(name)&id=in.(1,2,3)" `shouldRespondWith`           [json|[@@ -612,7 +666,7 @@      it "ordering embeded parents does not break things" $       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"}}]|]+        [json|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"}}]|]      context "order syntax errors" $ do       it "gives meaningful error messages when asc/desc/nulls{first,last} are misspelled" $ do@@ -762,7 +816,7 @@       request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") ""         `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"         { matchStatus = 200-        , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+        , matchHeaders = ["Content-Type" <:> "application/octet-stream"]         }      it "can get raw output with Accept: text/plain" $@@ -775,20 +829,28 @@     it "fails if a single column is not selected" $ do       request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") ""         `shouldRespondWith`-        [json| {"message":"application/octet-stream requested but more than one column was selected"} |]-        { matchStatus = 406-        , matchHeaders = [matchContentTypeJson]-        }-      request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") ""-        `shouldRespondWith` 406-      request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") ""-        `shouldRespondWith` 406+          [json| {"message":"application/octet-stream requested but more than one column was selected"} |]+          { matchStatus = 406 } +      request methodGet "/images?select=*&name=eq.A.png"+          (acceptHdrs "application/octet-stream")+          ""+        `shouldRespondWith`+          [json| {"message":"application/octet-stream requested but more than one column was selected"} |]+          { matchStatus = 406 }++      request methodGet "/images?name=eq.A.png"+          (acceptHdrs "application/octet-stream")+          ""+        `shouldRespondWith`+          [json| {"message":"application/octet-stream requested but more than one column was selected"} |]+          { matchStatus = 406 }+     it "concatenates results if more than one row is returned" $       request methodGet "/images_base64?select=img&name=in.(A.png,B.png)" (acceptHdrs "application/octet-stream") ""         `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="         { matchStatus = 200-        , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+        , matchHeaders = ["Content-Type" <:> "application/octet-stream"]         }    describe "values with quotes in IN and NOT IN" $ do@@ -800,7 +862,7 @@         [json| [{"name":"Hebdon, John"},{"name":"Williams, Mary"},{"name":"Smith, Joseph"}] |]         { matchHeaders = [matchContentTypeJson] }       get "/w_or_wo_comma_names?name=not.in.(\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\")" `shouldRespondWith`-        [json| [{"name":"David White"},{"name":"Larry Thompson"}] |]+        [json| [{"name":"David White"},{"name":"Larry Thompson"},{"name":"Double O Seven(007)"}] |]         { matchHeaders = [matchContentTypeJson] }      it "succeeds w/ and w/o quoted values" $ do@@ -808,16 +870,16 @@         [json| [{"name":"Hebdon, John"},{"name":"David White"}] |]         { matchHeaders = [matchContentTypeJson] }       get "/w_or_wo_comma_names?name=not.in.(\"Hebdon, John\",Larry Thompson,\"Smith, Joseph\")" `shouldRespondWith`-        [json| [{"name":"Williams, Mary"},{"name":"David White"}] |]+        [json| [{"name":"Williams, Mary"},{"name":"David White"},{"name":"Double O Seven(007)"}] |]         { matchHeaders = [matchContentTypeJson] }+      get "/w_or_wo_comma_names?name=in.(\"Double O Seven(007)\")" `shouldRespondWith`+        [json| [{"name":"Double O Seven(007)"}] |]+        { matchHeaders = [matchContentTypeJson] } -    it "checks well formed quoted values" $ do-      get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\")" `shouldRespondWith`-        [json| [] |] { matchHeaders = [matchContentTypeJson] }-      get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\"\"Mary)" `shouldRespondWith`-        [json| [] |] { matchHeaders = [matchContentTypeJson] }-      get "/w_or_wo_comma_names?name=in.(Williams\"Hebdon, John\")" `shouldRespondWith`-        [json| [] |] { matchHeaders = [matchContentTypeJson] }+    it "fails on malformed quoted values" $ do+      get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\")" `shouldRespondWith` 400+      get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\"\"Mary)" `shouldRespondWith` 400+      get "/w_or_wo_comma_names?name=in.(Williams\"Hebdon, John\")" `shouldRespondWith` 400    describe "IN and NOT IN empty set" $ do     context "returns an empty result for IN when no value is present" $ do
test/Feature/RangeSpec.hs view
@@ -33,9 +33,11 @@             `shouldRespondWith` [json| [] |] {matchHeaders = ["Content-Range" <:> "*/*"]}          it "returns range Content-Range with range/*" $-          request methodPost "/rpc/getitemrange" [] defaultRange-            `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]-            { matchHeaders = ["Content-Range" <:> "0-14/*"] }+          post "/rpc/getitemrange?order=id"+              defaultRange+            `shouldRespondWith`+              [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]+              { matchHeaders = ["Content-Range" <:> "0-14/*"] }      context "with range headers" $ do       context "of acceptable range" $ do@@ -168,20 +170,16 @@           }        it "succeeds if offset equals 0 as a no-op" $-        get "/items?select=id&offset=0"+        get "/items?select=id&offset=0&order=id"           `shouldRespondWith`-          [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]-          { matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "0-14/*"]-          }+            [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]+            { matchHeaders = ["Content-Range" <:> "0-14/*"] }        it "succeeds if offset is negative as a no-op" $-        get "/items?select=id&offset=-4"+        get "/items?select=id&offset=-4&order=id"           `shouldRespondWith`-          [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]-          { matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "0-14/*"]-          }+            [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]+            { matchHeaders = ["Content-Range" <:> "0-14/*"] }        it "fails if limit equals 0" $         get "/items?select=id&limit=0"@@ -199,62 +197,98 @@      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"]-          }+        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"]-          }+        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"]-          }+        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"]-          }+        request methodHead "/child_entities?select=*,entities(*)"+            [("Prefer", "count=planned")]+            ""+          `shouldRespondWith`+            ""+            { matchStatus  = 200+            , matchHeaders = ["Content-Range" <:> "0-5/6"]+            }      context "with range headers" $ do       context "of acceptable range" $ do
test/Feature/RawOutputTypesSpec.hs view
@@ -24,7 +24,7 @@         { matchHeaders= ["Content-Type" <:> "application/json; charset=utf-8"] }    it "responds json to a GET request to RPC with Firefox Accept headers" $-    request methodGet "/rpc/get_projects_below?id=3" chromeAcceptHdrs ""+    request methodGet "/rpc/get_projects_below?id=3" firefoxAcceptHdrs ""       `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client_id":1}, {"id":2,"name":"Windows 10","client_id":1}]|]         { matchHeaders= ["Content-Type" <:> "application/json; charset=utf-8"] }   it "responds json to a GET request to RPC with Chrome Accept headers" $
+ test/Feature/RollbackSpec.hs view
@@ -0,0 +1,218 @@+module Feature.RollbackSpec where++import Network.Wai (Application)++import Network.HTTP.Types+import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON++import Protolude hiding (get)++-- two helpers functions to make sure that each test can setup and cleanup properly++-- creates Item to work with for PATCH and DELETE+postItem =+  request methodPost "/items"+      [("Prefer", "tx=commit"), ("Prefer", "resolution=ignore-duplicates")]+      [json|{"id":0}|]+    `shouldRespondWith`+      ""+      { matchStatus  = 201 }++-- removes Items left over from POST, PUT, and PATCH+deleteItems =+  request methodDelete "/items?id=lte.0"+      [("Prefer", "tx=commit")]+      ""+    `shouldRespondWith`+      ""+      { matchStatus  = 204 }++preferDefault  = [("Prefer", "return=representation")]+preferCommit   = [("Prefer", "return=representation"), ("Prefer", "tx=commit")]+preferRollback = [("Prefer", "return=representation"), ("Prefer", "tx=rollback")]++withoutPreferenceApplied      = []+withPreferenceCommitApplied   = [ "Preference-Applied" <:> "tx=commit" ]+withPreferenceRollbackApplied = [ "Preference-Applied" <:> "tx=rollback" ]++shouldRespondToReads reqHeaders respHeaders = do+  it "responds to GET" $ do+    request methodGet "/items?id=eq.1"+        reqHeaders+        ""+      `shouldRespondWith`+        [json|[{"id":1}]|]+        { matchHeaders = respHeaders }++  it "responds to HEAD" $ do+    request methodHead "/items?id=eq.1"+        reqHeaders+        ""+      `shouldRespondWith`+        ""+        { matchHeaders = respHeaders }++  it "responds to GET on RPC" $ do+    request methodGet "/rpc/search?id=1"+        reqHeaders+        ""+      `shouldRespondWith`+        [json|[{"id":1}]|]+        { matchHeaders = respHeaders }++  it "responds to POST on RPC" $ do+    request methodPost "/rpc/search"+        reqHeaders+        [json|{"id":1}|]+      `shouldRespondWith`+        [json|[{"id":1}]|]+        { matchHeaders = respHeaders }++shouldPersistMutations reqHeaders respHeaders = do+  it "does persist post" $ do+    request methodPost "/items"+        reqHeaders+        [json|{"id":0}|]+      `shouldRespondWith`+        [json|[{"id":0}]|]+        { matchStatus  = 201+        , matchHeaders = respHeaders }+    get "/items?id=eq.0"+      `shouldRespondWith`+        [json|[{"id":0}]|]+    deleteItems++  it "does persist put" $ do+    request methodPut "/items?id=eq.0"+        reqHeaders+        [json|{"id":0}|]+      `shouldRespondWith`+        [json|[{"id":0}]|]+        { matchHeaders = respHeaders }+    get "/items?id=eq.0"+      `shouldRespondWith`+        [json|[{"id":0}]|]+    deleteItems++  it "does persist patch" $ do+    postItem+    request methodPatch "/items?id=eq.0"+        reqHeaders+        [json|{"id":-1}|]+      `shouldRespondWith`+        [json|[{"id":-1}]|]+        { matchHeaders = respHeaders }+    get "/items?id=eq.0"+      `shouldRespondWith`+        [json|[]|]+    get "/items?id=eq.-1"+      `shouldRespondWith`+        [json|[{"id":-1}]|]+    deleteItems++  it "does persist delete" $ do+    postItem+    request methodDelete "/items?id=eq.0"+        reqHeaders+        ""+      `shouldRespondWith`+        [json|[{"id":0}]|]+        { matchHeaders = respHeaders }+    get "/items?id=eq.0"+      `shouldRespondWith`+        [json|[]|]++shouldNotPersistMutations reqHeaders respHeaders = do+  it "does not persist post" $ do+    request methodPost "/items"+        reqHeaders+        [json|{"id":0}|]+      `shouldRespondWith`+        [json|[{"id":0}]|]+        { matchStatus  = 201+        , matchHeaders = respHeaders }+    get "/items?id=eq.0"+      `shouldRespondWith`+        [json|[]|]++  it "does not persist put" $ do+    request methodPut "/items?id=eq.0"+        reqHeaders+        [json|{"id":0}|]+      `shouldRespondWith`+        [json|[{"id":0}]|]+        { matchHeaders = respHeaders }+    get "/items?id=eq.0"+      `shouldRespondWith`+        [json|[]|]++  it "does not persist patch" $ do+    request methodPatch "/items?id=eq.1"+        reqHeaders+        [json|{"id":0}|]+      `shouldRespondWith`+        [json|[{"id":0}]|]+        { matchHeaders = respHeaders }+    get "/items?id=eq.0"+      `shouldRespondWith`+        [json|[]|]+    get "items?id=eq.1"+      `shouldRespondWith`+        [json|[{"id":1}]|]++  it "does not persist delete" $ do+    request methodDelete "/items?id=eq.1"+        reqHeaders+        ""+      `shouldRespondWith`+        [json|[{"id":1}]|]+        { matchHeaders = respHeaders }+    get "/items?id=eq.1"+      `shouldRespondWith`+        [json|[{"id":1}]|]++allowed :: SpecWith ((), Application)+allowed = describe "tx-allow-override = true" $ do+  describe "without Prefer tx" $ do+    preferDefault `shouldRespondToReads` withoutPreferenceApplied+    preferDefault `shouldNotPersistMutations` withoutPreferenceApplied++  describe "Prefer tx=commit" $ do+    preferCommit `shouldRespondToReads` withPreferenceCommitApplied+    preferCommit `shouldPersistMutations` withPreferenceCommitApplied++  describe "Prefer tx=rollback" $ do+    preferRollback `shouldRespondToReads` withPreferenceRollbackApplied+    preferRollback `shouldNotPersistMutations` withPreferenceRollbackApplied++disallowed :: SpecWith ((), Application)+disallowed = describe "tx-rollback-all = false, tx-allow-override = false" $ do+  describe "without Prefer tx" $ do+    preferDefault `shouldRespondToReads` withoutPreferenceApplied+    preferDefault `shouldPersistMutations` withoutPreferenceApplied++  describe "Prefer tx=commit" $ do+    preferCommit `shouldRespondToReads` withoutPreferenceApplied+    preferCommit `shouldPersistMutations` withoutPreferenceApplied++  describe "Prefer tx=rollback" $ do+    preferRollback `shouldRespondToReads` withoutPreferenceApplied+    preferRollback `shouldPersistMutations` withoutPreferenceApplied+++forced :: SpecWith ((), Application)+forced = describe "tx-rollback-all = true, tx-allow-override = false" $ do+  describe "without Prefer tx" $ do+    preferDefault `shouldRespondToReads` withoutPreferenceApplied+    preferDefault `shouldNotPersistMutations` withoutPreferenceApplied++  describe "Prefer tx=commit" $ do+    preferCommit `shouldRespondToReads` withoutPreferenceApplied+    preferCommit `shouldNotPersistMutations` withoutPreferenceApplied++  describe "Prefer tx=rollback" $ do+    preferRollback `shouldRespondToReads` withoutPreferenceApplied+    preferRollback `shouldNotPersistMutations` withoutPreferenceApplied+
test/Feature/RootSpec.hs view
@@ -26,5 +26,9 @@     it "accepts application/json" $       request methodGet "/"         [("Accept", "application/json")] "" `shouldRespondWith`-        [json| [{"table": "items"}, {"table": "subitems"}] |]+        [json| {+            "tableName": "orders_view", "tableSchema": "test",+            "tableDeletable": true, "tableUpdatable": true,+            "tableInsertable": true, "tableDescription": null+          } |]         { matchHeaders = [matchContentTypeJson] }
+ test/Feature/RpcPreRequestGucsSpec.hs view
@@ -0,0 +1,84 @@+module Feature.RpcPreRequestGucsSpec where++import Network.Wai (Application)++import Network.HTTP.Types+import Test.Hspec          hiding (pendingWith)+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON++import Protolude hiding (get, put)++spec :: SpecWith ((), Application)+spec =+  describe "GUC headers on all methods via pre-request" $ do+    it "succeeds setting the headers on POST" $+      post "/items"+          [json|[{"id": 11111}]|]+        `shouldRespondWith` ""+          { matchStatus = 201+          , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]+          }++    it "succeeds setting the headers on GET and HEAD" $ do+      request methodGet "/items?id=eq.1"+          [("User-Agent", "MSIE 6.0")]+          ""+        `shouldRespondWith`+          [json|[{"id": 1}]|]+          { matchHeaders = ["Cache-Control" <:> "no-cache, no-store, must-revalidate"] }++      request methodHead "/items?id=eq.1"+          [("User-Agent", "MSIE 7.0")]+          ""+        `shouldRespondWith`+          ""+          { matchHeaders = ["Cache-Control" <:> "no-cache, no-store, must-revalidate"] }++      request methodHead "/projects"+          [("Accept", "text/csv")]+          ""+        `shouldRespondWith`+          ""+          { matchHeaders = ["Content-Disposition" <:> "attachment; filename=projects.csv"] }++    it "succeeds setting the headers on PATCH" $+        patch "/items?id=eq.1"+            [json|[{"id": 11111}]|]+          `shouldRespondWith` ""+            { matchStatus = 204+            , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]+            }++    it "succeeds setting the headers on PUT" $+      put "/items?id=eq.1"+          [json|[{"id": 1}]|]+        `shouldRespondWith` ""+          { matchStatus = 204+          , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]+          }++    it "succeeds setting the headers on DELETE" $+      delete "/items?id=eq.1"+        `shouldRespondWith`+          ""+          { matchStatus = 204+          , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]+          }+    it "can override the Content-Type header" $ do+      request methodHead "/clients?id=eq.1"+          []+          ""+        `shouldRespondWith`+          ""+          { matchStatus = 200+          , matchHeaders = ["Content-Type" <:> "application/custom+json"]+          }+      request methodHead "/rpc/getallprojects"+          []+          ""+        `shouldRespondWith`+          ""+          { matchStatus = 200+          , matchHeaders = ["Content-Type" <:> "application/custom+json"]+          }
test/Feature/RpcSpec.hs view
@@ -3,7 +3,7 @@ import qualified Data.ByteString.Lazy as BL (empty)  import Network.Wai      (Application)-import Network.Wai.Test (SResponse (simpleBody, simpleStatus))+import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus))  import Network.HTTP.Types import Test.Hspec          hiding (pendingWith)@@ -11,10 +11,12 @@ import Test.Hspec.Wai.JSON import Text.Heredoc -import PostgREST.Types (PgVersion, pgVersion100, pgVersion109,-                        pgVersion110, pgVersion112, pgVersion114,-                        pgVersion95)-import Protolude       hiding (get)+import PostgREST.Config.PgVersion (PgVersion, pgVersion100,+                                   pgVersion109, pgVersion110,+                                   pgVersion112, pgVersion114,+                                   pgVersion96)++import Protolude  hiding (get) import SpecHelper  spec :: PgVersion -> SpecWith ((), Application)@@ -94,27 +96,61 @@     context "unknown function" $ do       it "returns 404" $         post "/rpc/fakefunc" [json| {} |] `shouldRespondWith` 404+       it "should fail with 404 on unknown proc name" $         get "/rpc/fake" `shouldRespondWith` 404+       it "should fail with 404 on unknown proc args" $ do         get "/rpc/sayhello" `shouldRespondWith` 404         get "/rpc/sayhello?any_arg=value" `shouldRespondWith` 404+       it "should not ignore unknown args and fail with 404" $         get "/rpc/add_them?a=1&b=2&smthelse=blabla" `shouldRespondWith`-        let-          message :: Text-          message-            | actualPgVersion < pgVersion95 = "function test.add_them(a := integer, b := integer, smthelse := text) does not exist"-            | otherwise = "function test.add_them(a => integer, b => integer, smthelse => text) does not exist"-        in [json| {-          "code": "42883",-          "details": null,-          "hint": "No function matches the given name and argument types. You might need to add explicit type casts.",-          "message": #{message} } |]+        [json| {+          "hint":"If a new function was created in the database with this name and arguments, try reloading the schema cache.",+          "message":"Could not find the test.add_them(a, b, smthelse) function in the schema cache" } |]         { matchStatus  = 404         , matchHeaders = [matchContentTypeJson]         } +      it "should fail with 404 when no json arg is found with prefer single object" $+        request methodPost "/rpc/sayhello"+          [("Prefer","params=single-object")]+          [json|{}|]+        `shouldRespondWith`+          [json| {+            "hint":"If a new function was created in the database with this name and arguments, try reloading the schema cache.",+            "message":"Could not find the test.sayhello function with a single json or jsonb argument in the schema cache" } |]+        { matchStatus  = 404+        , matchHeaders = [matchContentTypeJson]+        }++      it "should fail with 404 for overloaded functions with unknown args" $ do+        get "/rpc/overloaded?wrong_arg=value" `shouldRespondWith`+          [json| {+            "hint":"If a new function was created in the database with this name and arguments, try reloading the schema cache.",+            "message":"Could not find the test.overloaded(wrong_arg) function in the schema cache" } |]+          { matchStatus  = 404+          , matchHeaders = [matchContentTypeJson]+          }+        get "/rpc/overloaded?a=1&b=2&wrong_arg=value" `shouldRespondWith`+          [json| {+            "hint":"If a new function was created in the database with this name and arguments, try reloading the schema cache.",+            "message":"Could not find the test.overloaded(a, b, wrong_arg) function in the schema cache" } |]+          { matchStatus  = 404+          , matchHeaders = [matchContentTypeJson]+          }++    context "ambiguous overloaded functions with same arguments but different types" $ do+      it "should fail with 300 Multiple Choices without explicit argument type casts" $+        get "/rpc/overloaded_same_args?arg=value" `shouldRespondWith`+          [json| {+            "hint":"Overloaded functions with the same argument name but different types are not supported",+            "message":"Could not choose the best candidate function between: test.overloaded_same_args(arg => integer), test.overloaded_same_args(arg => xml), test.overloaded_same_args(arg => text, num => integer)" } |]+          { matchStatus  = 300+          , matchHeaders = [matchContentTypeJson]+          }+     it "works when having uppercase identifiers" $ do       get "/rpc/quotedFunction?user=mscott&fullName=Michael Scott&SSN=401-32-XXXX" `shouldRespondWith`         [json|{"user": "mscott", "fullName": "Michael Scott", "SSN": "401-32-XXXX"}|]@@ -128,9 +164,9 @@     context "shaping the response returned by a proc" $ do       it "returns a project" $ do         post "/rpc/getproject" [json| { "id": 1} |] `shouldRespondWith`-          [str|[{"id":1,"name":"Windows 7","client_id":1}]|]+          [json|[{"id":1,"name":"Windows 7","client_id":1}]|]         get "/rpc/getproject?id=1" `shouldRespondWith`-          [str|[{"id":1,"name":"Windows 7","client_id":1}]|]+          [json|[{"id":1,"name":"Windows 7","client_id":1}]|]        it "can filter proc results" $ do         post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id" [json| {} |] `shouldRespondWith`@@ -152,9 +188,9 @@        it "select works on the first level" $ do         post "/rpc/getproject?select=id,name" [json| { "id": 1} |] `shouldRespondWith`-          [str|[{"id":1,"name":"Windows 7"}]|]+          [json|[{"id":1,"name":"Windows 7"}]|]         get "/rpc/getproject?id=1&select=id,name" `shouldRespondWith`-          [str|[{"id":1,"name":"Windows 7"}]|]+          [json|[{"id":1,"name":"Windows 7"}]|]      context "foreign entities embedding" $ do       it "can embed if related tables are in the exposed schema" $ do@@ -172,12 +208,13 @@           `shouldRespondWith` 400        it "can embed if the related tables are in a hidden schema but exposed as views" $ do-        post "/rpc/single_article?select=id,articleStars(userId)" [json|{ "id": 2}|]-          `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|]-          { matchHeaders = [matchContentTypeJson] }+        post "/rpc/single_article?select=id,articleStars(userId)"+            [json|{ "id": 2}|]+          `shouldRespondWith`+            [json|{"id": 2, "articleStars": [{"userId": 3}]}|]         get "/rpc/single_article?id=2&select=id,articleStars(userId)"-          `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|]-          { matchHeaders = [matchContentTypeJson] }+          `shouldRespondWith`+            [json|{"id": 2, "articleStars": [{"userId": 3}]}|]        it "can embed an M2M relationship table" $         get "/rpc/getallusers?select=name,tasks(name)&id=gt.1"@@ -202,6 +239,16 @@           ]|]           { matchHeaders = [matchContentTypeJson] } +      when (actualPgVersion >= pgVersion110) $+        it "can embed if rpc returns domain of table type" $ do+          post "/rpc/getproject_domain?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}]}]|]+          get "/rpc/getproject_domain?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}]}]|]+     context "a proc that returns an empty rowset" $       it "returns empty json array" $ do         post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith`@@ -229,11 +276,10 @@           { matchHeaders = [matchContentTypeJson] }        it "returns setof integers" $-        post "/rpc/ret_setof_integers" [json|{}|] `shouldRespondWith`-          [json|[{ "ret_setof_integers": 1 },-                 { "ret_setof_integers": 2 },-                 { "ret_setof_integers": 3 }]|]-          { matchHeaders = [matchContentTypeJson] }+        post "/rpc/ret_setof_integers"+            [json|{}|]+          `shouldRespondWith`+            [json|[1,2,3]|]        it "returns enum value" $         post "/rpc/ret_enum" [json|{ "val": "foo" }|] `shouldRespondWith`@@ -256,41 +302,154 @@           { matchHeaders = [matchContentTypeJson] }        it "returns composite type in exposed schema" $-        post "/rpc/ret_point_2d" [json|{}|] `shouldRespondWith`-          [json|[{"x": 10, "y": 5}]|]-          { matchHeaders = [matchContentTypeJson] }+        post "/rpc/ret_point_2d"+            [json|{}|]+          `shouldRespondWith`+            [json|{"x": 10, "y": 5}|]        it "cannot return composite type in hidden schema" $         post "/rpc/ret_point_3d" [json|{}|] `shouldRespondWith` 401 +      when (actualPgVersion >= pgVersion110) $+        it "returns domain of composite type" $+          post "/rpc/ret_composite_domain"+              [json|{}|]+            `shouldRespondWith`+              [json|{"x": 10, "y": 5}|]+       it "returns single row from table" $-        post "/rpc/single_article?select=id" [json|{"id": 2}|] `shouldRespondWith`-          [json|[{"id": 2}]|]-          { matchHeaders = [matchContentTypeJson] }+        post "/rpc/single_article?select=id"+            [json|{"id": 2}|]+          `shouldRespondWith`+            [json|{"id": 2}|]        it "returns null for void" $-        post "/rpc/ret_void" [json|{}|] `shouldRespondWith`-          [json|null|]-          { matchHeaders = [matchContentTypeJson] }+        post "/rpc/ret_void"+            [json|{}|]+          `shouldRespondWith`+            "null"+            { matchHeaders = [matchContentTypeJson] } +      it "returns null for an integer with null value" $+        post "/rpc/ret_null"+            [json|{}|]+          `shouldRespondWith`+            "null"+            { matchHeaders = [matchContentTypeJson] }++      context "different types when overloaded" $ do+        it "returns composite type" $+          post "/rpc/ret_point_overloaded"+              [json|{"x": 1, "y": 2}|]+            `shouldRespondWith`+              [json|{"x": 1, "y": 2}|]++        it "returns json scalar with prefer single object" $+          request methodPost "/rpc/ret_point_overloaded" [("Prefer","params=single-object")]+            [json|{"x": 1, "y": 2}|]+            `shouldRespondWith`+            [json|{"x": 1, "y": 2}|]+            { matchHeaders = [matchContentTypeJson] }+     context "proc argument types" $ do-      it "accepts a variety of arguments" $-        post "/rpc/varied_arguments"-            [json| {-              "double": 3.1,-              "varchar": "hello",-              "boolean": true,-              "date": "20190101",-              "money": 0,-              "enum": "foo",-              "integer": 43,-              "json": {"some key": "some value"},-              "jsonb": {"another key": [1, 2, "3"]}-            } |]+      -- different syntax for array needed for pg<10+      when (actualPgVersion < pgVersion100) $+        it "accepts a variety of arguments (Postgres < 10)" $+          post "/rpc/varied_arguments"+              [json| {+                "double": 3.1,+                "varchar": "hello",+                "boolean": true,+                "date": "20190101",+                "money": 0,+                "enum": "foo",+                "arr": "{a,b,c}",+                "integer": 43,+                "json": {"some key": "some value"},+                "jsonb": {"another key": [1, 2, "3"]}+              } |]+            `shouldRespondWith`+              [json| {+                "double": 3.1,+                "varchar": "hello",+                "boolean": true,+                "date": "2019-01-01",+                "money": "$0.00",+                "enum": "foo",+                "arr": ["a", "b", "c"],+                "integer": 43,+                "json": {"some key": "some value"},+                "jsonb": {"another key": [1, 2, "3"]}+              } |]+              { matchHeaders = [matchContentTypeJson] }++      when (actualPgVersion >= pgVersion100) $+        it "accepts a variety of arguments (Postgres >= 10)" $+          post "/rpc/varied_arguments"+              [json| {+                "double": 3.1,+                "varchar": "hello",+                "boolean": true,+                "date": "20190101",+                "money": 0,+                "enum": "foo",+                "arr": ["a", "b", "c"],+                "integer": 43,+                "json": {"some key": "some value"},+                "jsonb": {"another key": [1, 2, "3"]}+              } |]+            `shouldRespondWith`+              [json| {+                "double": 3.1,+                "varchar": "hello",+                "boolean": true,+                "date": "2019-01-01",+                "money": "$0.00",+                "enum": "foo",+                "arr": ["a", "b", "c"],+                "integer": 43,+                "json": {"some key": "some value"},+                "jsonb": {"another key": [1, 2, "3"]}+              } |]+              { matchHeaders = [matchContentTypeJson] }++      it "accepts a variety of arguments with GET" $+        -- without JSON / JSONB here, because passing those via query string is useless - they just become a "json string" all the time+        get "/rpc/varied_arguments?double=3.1&varchar=hello&boolean=true&date=20190101&money=0&enum=foo&arr=%7Ba,b,c%7D&integer=43"           `shouldRespondWith`-            [json|"Hi"|]+              [json| {+                "double": 3.1,+                "varchar": "hello",+                "boolean": true,+                "date": "2019-01-01",+                "money": "$0.00",+                "enum": "foo",+                "arr": ["a", "b", "c"],+                "integer": 43,+                "json": {},+                "jsonb": {}+              } |]             { matchHeaders = [matchContentTypeJson] } +      it "accepts a variety of arguments from an html form" $+        request methodPost "/rpc/varied_arguments"+            [("Content-Type", "application/x-www-form-urlencoded")]+            "double=3.1&varchar=hello&boolean=true&date=20190101&money=0&enum=foo&arr=%7Ba,b,c%7D&integer=43"+          `shouldRespondWith`+              [json| {+                "double": 3.1,+                "varchar": "hello",+                "boolean": true,+                "date": "2019-01-01",+                "money": "$0.00",+                "enum": "foo",+                "arr": ["a", "b", "c"],+                "integer": 43,+                "json": {},+                "jsonb": {}+              } |]+            { matchHeaders = [matchContentTypeJson] }+       it "parses embedded JSON arguments as JSON" $         post "/rpc/json_argument"             [json| { "arg": { "key": 3 } } |]@@ -352,13 +511,25 @@           `shouldRespondWith` 405      it "executes the proc exactly once per request" $ do-      post "/rpc/callcounter" [json| {} |] `shouldRespondWith`-        [json|1|]-        { matchHeaders = [matchContentTypeJson] }-      post "/rpc/callcounter" [json| {} |] `shouldRespondWith`-        [json|2|]-        { matchHeaders = [matchContentTypeJson] }+      -- callcounter is persistent even with rollback, because it uses a sequence+      -- reset counter first to make test repeatable+      request methodPost "/rpc/reset_sequence"+          [("Prefer", "tx=commit")]+          [json|{"name": "callcounter_count", "value": 1}|]+        `shouldRespondWith`+          [json|""|] +      -- now the test+      post "/rpc/callcounter"+          [json|{}|]+        `shouldRespondWith`+          [json|1|]++      post "/rpc/callcounter"+          [json|{}|]+        `shouldRespondWith`+          [json|2|]+     context "a proc that receives no parameters" $ do       it "interprets empty string as empty json object on a post request" $         post "/rpc/noparamsproc" BL.empty `shouldRespondWith`@@ -376,29 +547,101 @@         [json|[{"test":"hello","value":1}]|] { matchHeaders = [matchContentTypeJson] }      context "procs with OUT/INOUT params" $ do-      it "returns a scalar result when there is a single OUT param" $ do-        get "/rpc/single_out_param?num=5" `shouldRespondWith`-          [json|6|] { matchHeaders = [matchContentTypeJson] }-        get "/rpc/single_json_out_param?a=1&b=two" `shouldRespondWith`-          [json|{"a": 1, "b": "two"}|] { matchHeaders = [matchContentTypeJson] }+      it "returns an object result when there is a single OUT param" $ do+        get "/rpc/single_out_param?num=5"+          `shouldRespondWith`+            [json|{"num_plus_one":6}|] -      it "returns a scalar result when there is a single INOUT param" $-        get "/rpc/single_inout_param?num=2" `shouldRespondWith`-          [json|3|] { matchHeaders = [matchContentTypeJson] }+        get "/rpc/single_json_out_param?a=1&b=two"+          `shouldRespondWith`+            [json|{"my_json": {"a": 1, "b": "two"}}|] -      it "returns a row result when there are many OUT params" $-        get "/rpc/many_out_params" `shouldRespondWith`-          [json|[{"my_json":{"a": 1, "b": "two"},"num":3,"str":"four"}]|] { matchHeaders = [matchContentTypeJson] }+      it "returns an object result when there is a single INOUT param" $+        get "/rpc/single_inout_param?num=2"+          `shouldRespondWith`+            [json|{"num":3}|] -      it "returns a row result when there are many INOUT params" $-        get "/rpc/many_inout_params?num=1&str=two&b=false" `shouldRespondWith`-          [json| [{"num":1,"str":"two","b":false}]|] { matchHeaders = [matchContentTypeJson] }+      it "returns an object result when there are many OUT params" $+        get "/rpc/many_out_params"+          `shouldRespondWith`+            [json|{"my_json":{"a": 1, "b": "two"},"num":3,"str":"four"}|] +      it "returns an object result when there are many INOUT params" $+        get "/rpc/many_inout_params?num=1&str=two&b=false"+          `shouldRespondWith`+            [json|{"num":1,"str":"two","b":false}|]++    context "procs with VARIADIC params" $ do+      when (actualPgVersion < pgVersion100) $+        it "works with POST (Postgres < 10)" $+          post "/rpc/variadic_param"+              [json| { "v": "{hi,hello,there}" } |]+            `shouldRespondWith`+              [json|["hi", "hello", "there"]|]++      when (actualPgVersion >= pgVersion100) $ do+        it "works with POST (Postgres >= 10)" $+          post "/rpc/variadic_param"+              [json| { "v": ["hi", "hello", "there"] } |]+            `shouldRespondWith`+              [json|["hi", "hello", "there"]|]++        context "works with GET and repeated params" $ do+          it "n=0 (through DEFAULT)" $+            get "/rpc/variadic_param"+              `shouldRespondWith`+                [json|[]|]++          it "n=1" $+            get "/rpc/variadic_param?v=hi"+              `shouldRespondWith`+                [json|["hi"]|]++          it "n>1" $+            get "/rpc/variadic_param?v=hi&v=there"+              `shouldRespondWith`+                [json|["hi", "there"]|]++        context "works with POST and repeated params from html form" $ do+          it "n=0 (through DEFAULT)" $+            request methodPost "/rpc/variadic_param"+                [("Content-Type", "application/x-www-form-urlencoded")]+                ""+              `shouldRespondWith`+                [json|[]|]++          it "n=1" $+            request methodPost "/rpc/variadic_param"+                [("Content-Type", "application/x-www-form-urlencoded")]+                "v=hi"+              `shouldRespondWith`+                [json|["hi"]|]++          it "n>1" $+            request methodPost "/rpc/variadic_param"+                [("Content-Type", "application/x-www-form-urlencoded")]+                "v=hi&v=there"+              `shouldRespondWith`+                [json|["hi", "there"]|]++    it "returns last value for repeated params without VARIADIC" $+      get "/rpc/sayhello?name=ignored&name=world"+        `shouldRespondWith`+          [json|"Hello, world"|]++    when (actualPgVersion >= pgVersion100) $+      it "returns last value for repeated non-variadic params in function with other VARIADIC arguments" $+        get "/rpc/sayhello_variadic?name=ignored&name=world&v=unused"+          `shouldRespondWith`+            [json|"Hello, world"|]+     it "can handle procs with args that have a DEFAULT value" $ do-      get "/rpc/many_inout_params?num=1&str=two" `shouldRespondWith`-        [json| [{"num":1,"str":"two","b":true}]|] { matchHeaders = [matchContentTypeJson] }-      get "/rpc/three_defaults?b=4" `shouldRespondWith`-        [json|8|] { matchHeaders = [matchContentTypeJson] }+      get "/rpc/many_inout_params?num=1&str=two"+        `shouldRespondWith`+          [json| {"num":1,"str":"two","b":true}|]+      get "/rpc/three_defaults?b=4"+        `shouldRespondWith`+          [json|8|]      it "can map a RAISE error code and message to a http status" $       get "/rpc/raise_pt402"@@ -436,23 +679,56 @@           `shouldRespondWith` [json|{ "p1": "1", "p2": "text"}|]           { matchHeaders = [matchContentTypeJson] } -    it "should work with an overloaded function" $ do-      get "/rpc/overloaded" `shouldRespondWith`-        [json|[{ "overloaded": 1 },-               { "overloaded": 2 },-               { "overloaded": 3 }]|]-        { matchHeaders = [matchContentTypeJson] }-      request methodPost "/rpc/overloaded" [("Prefer","params=single-object")]-        [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]-       `shouldRespondWith`-        [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]-        { matchHeaders = [matchContentTypeJson] }-      get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|]-      get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [str|"123"|]+    context "should work with an overloaded function" $ do+      it "overloaded()" $+        get "/rpc/overloaded"+          `shouldRespondWith`+            [json|[1,2,3]|] +      it "overloaded(json) single-object" $+        request methodPost "/rpc/overloaded"+            [("Prefer","params=single-object")]+            [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]+          `shouldRespondWith`+            [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]++      it "overloaded(int, int)" $+        get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|]++      it "overloaded(text, text, text)" $+        get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [json|"123"|]++      it "overloaded_html_form()" $+        request methodPost "/rpc/overloaded_html_form"+            [("Content-Type", "application/x-www-form-urlencoded")]+            ""+          `shouldRespondWith`+            [json|[1,2,3]|]++      it "overloaded_html_form(json) single-object" $+        request methodPost "/rpc/overloaded_html_form"+            [("Content-Type", "application/x-www-form-urlencoded"), ("Prefer","params=single-object")]+            "a=1&b=2&c=3"+          `shouldRespondWith`+            [json|{"a": "1", "b": "2", "c": "3"}|]++      it "overloaded_html_form(int, int)" $+        request methodPost "/rpc/overloaded_html_form"+            [("Content-Type", "application/x-www-form-urlencoded")]+            "a=1&b=2"+          `shouldRespondWith`+            [str|3|]++      it "overloaded_html_form(text, text, text)" $+        request methodPost "/rpc/overloaded_html_form"+            [("Content-Type", "application/x-www-form-urlencoded")]+            "a=1&b=2&c=3"+          `shouldRespondWith`+            [json|"123"|]+     context "only for POST rpc" $ do       it "gives a parse filter error if GET style proc args are specified" $-        post "/rpc/sayhello?name=John" [json|{}|] `shouldRespondWith` 400+        post "/rpc/sayhello?name=John" [json|{name: "John"}|] `shouldRespondWith` 400        it "ignores json keys not included in ?columns" $         post "/rpc/sayhello?columns=name"@@ -512,7 +788,7 @@                   [("Custom-Header", "test")]             [json| { "name": "request.header.custom-header" } |]             `shouldRespondWith`-            [str|"test"|]+            [json|"test"|]             { matchStatus  = 200             , matchHeaders = [ matchContentTypeJson ]             }@@ -521,7 +797,7 @@                   [("Origin", "http://example.com")]             [json| { "name": "request.header.origin" } |]             `shouldRespondWith`-            [str|"http://example.com"|]+            [json|"http://example.com"|]             { matchStatus  = 200             , matchHeaders = [ matchContentTypeJson ]             }@@ -529,7 +805,7 @@         request methodPost "/rpc/get_guc_value" []             [json| { "name": "request.jwt.claim.role" } |]             `shouldRespondWith`-            [str|"postgrest_test_anonymous"|]+            [json|"postgrest_test_anonymous"|]             { matchStatus  = 200             , matchHeaders = [ matchContentTypeJson ]             }@@ -537,7 +813,7 @@         request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue")]           [json| {"name":"request.cookie.acookie"} |]             `shouldRespondWith`-            [str|"cookievalue"|]+            [json|"cookievalue"|]             { matchStatus = 200             , matchHeaders = []             }@@ -545,7 +821,7 @@         request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue;secondcookie=anothervalue")]           [json| {"name":"request.cookie.secondcookie"} |]             `shouldRespondWith`-            [str|"anothervalue"|]+            [json|"anothervalue"|]             { matchStatus = 200             , matchHeaders = []             }@@ -553,7 +829,7 @@         request methodPost "/rpc/get_guc_value" []           [json| { "name": "app.settings.app_host" } |]             `shouldRespondWith`-            [str|"localhost"|]+            [json|"localhost"|]             { matchStatus  = 200             , matchHeaders = [ matchContentTypeJson ]             }@@ -561,7 +837,7 @@         request methodPost "/rpc/get_guc_value" [authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"]           [json| {"name":"request.header.authorization"} |]             `shouldRespondWith`-            [str|"Bearer eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"|]+            [json|"Bearer eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"|]             { matchStatus = 200             , matchHeaders = []             }@@ -569,7 +845,7 @@         request methodPost "/rpc/get_guc_value" []           [json| {"name":"request.method"} |]             `shouldRespondWith`-            [str|"POST"|]+            [json|"POST"|]             { matchStatus = 200             , matchHeaders = []             }@@ -577,7 +853,7 @@         request methodPost "/rpc/get_guc_value" []           [json| {"name":"request.path"} |]             `shouldRespondWith`-            [str|"/rpc/get_guc_value"|]+            [json|"/rpc/get_guc_value"|]             { matchStatus = 200             , matchHeaders = []             }@@ -588,7 +864,7 @@           request methodPost "/rpc/ret_base64_bin" (acceptHdrs "application/octet-stream") ""             `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"             { matchStatus = 200-            , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+            , matchHeaders = ["Content-Type" <:> "application/octet-stream"]             }          it "can get raw output with Accept: text/plain" $@@ -598,26 +874,36 @@             , matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]             } +      context "Proc that returns set of scalars" $+        it "can query without selecting column" $+          request methodGet "/rpc/welcome_twice"+              (acceptHdrs "text/plain")+              ""+            `shouldRespondWith`+              "Welcome to PostgRESTWelcome to PostgREST"+              { matchStatus = 200+              , matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]+              }+       context "Proc that returns rows" $ do         it "can query if a single column is selected" $           request methodPost "/rpc/ret_rows_with_base64_bin?select=img" (acceptHdrs "application/octet-stream") ""             `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="             { matchStatus = 200-            , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+            , matchHeaders = ["Content-Type" <:> "application/octet-stream"]             }          it "fails if a single column is not selected" $-          request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") ""+          request methodPost "/rpc/ret_rows_with_base64_bin"+              (acceptHdrs "application/octet-stream") ""             `shouldRespondWith`-            [json| {"message":"application/octet-stream requested but more than one column was selected"} |]-            { matchStatus = 406-            , matchHeaders = [matchContentTypeJson]-            }+              [json| {"message":"application/octet-stream requested but more than one column was selected"} |]+              { matchStatus = 406 }      context "only for GET rpc" $ do       it "should fail on mutating procs" $ do-        get "/rpc/callcounter" `shouldRespondWith` 500-        get "/rpc/setprojects?id_l=1&id_h=5&name=FreeBSD" `shouldRespondWith` 500+        get "/rpc/callcounter" `shouldRespondWith` 405+        get "/rpc/setprojects?id_l=1&id_h=5&name=FreeBSD" `shouldRespondWith` 405        it "should filter a proc that has arg name = filter name" $         get "/rpc/get_projects_below?id=5&id=gt.2&select=id" `shouldRespondWith`@@ -647,7 +933,129 @@                 [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|]                 { matchHeaders = [matchContentTypeJson] } +      when (actualPgVersion >= pgVersion96) $+        it "should work with the phraseto_tsquery function" $+          get "/rpc/get_tsearch?text_search_vector=phfts(english).impossible" `shouldRespondWith`+            [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|]+            { matchHeaders = [matchContentTypeJson] }+     it "should work with an argument of custom type in public schema" $         get "/rpc/test_arg?my_arg=something" `shouldRespondWith`           [json|"foobar"|]           { matchHeaders = [matchContentTypeJson] }++    when (actualPgVersion >= pgVersion96) $ 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}]|]+            {matchHeaders = [+                matchContentTypeJson,+                "X-Test"   <:> "key1=val1; someValue; key2=val2",+                "X-Test-2" <:> "key1=val1"]}+          get "/rpc/get_int_and_guc_headers?num=1"+            `shouldRespondWith` [json|1|]+            {matchHeaders = [+                matchContentTypeJson,+                "X-Test"   <:> "key1=val1; someValue; key2=val2",+                "X-Test-2" <:> "key1=val1"]}+          post "/rpc/get_int_and_guc_headers" [json|{"num": 1}|]+            `shouldRespondWith` [json|1|]+            {matchHeaders = [+                matchContentTypeJson,+                "X-Test"   <:> "key1=val1; someValue; key2=val2",+                "X-Test-2" <:> "key1=val1"]}++        it "fails when setting headers with wrong json structure" $ do+          get "/rpc/bad_guc_headers_1"+            `shouldRespondWith`+            [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]+            { matchStatus  = 500+            , matchHeaders = [ matchContentTypeJson ]+            }+          get "/rpc/bad_guc_headers_2"+            `shouldRespondWith`+            [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]+            { matchStatus  = 500+            , matchHeaders = [ matchContentTypeJson ]+            }+          get "/rpc/bad_guc_headers_3"+            `shouldRespondWith`+            [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]+            { matchStatus  = 500+            , matchHeaders = [ matchContentTypeJson ]+            }+          post "/rpc/bad_guc_headers_1" [json|{}|]+            `shouldRespondWith`+            [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]+            { matchStatus  = 500+            , matchHeaders = [ matchContentTypeJson ]+            }++        it "can set the same http header twice" $+          get "/rpc/set_cookie_twice"+            `shouldRespondWith`+              "null"+              { matchHeaders = [ matchContentTypeJson+                               , "Set-Cookie" <:> "sessionid=38afes7a8; HttpOnly; Path=/"+                               , "Set-Cookie" <:> "id=a3fWa; Expires=Wed, 21 Oct 2015 07:28:00 GMT; Secure; HttpOnly" ]}++      it "can override the Location header on a trigger" $+        post "/stuff"+            [json|[{"id": 2, "name": "stuff 2"}]|]+          `shouldRespondWith`+            ""+            { matchStatus = 201+            , matchHeaders = ["Location" <:> "/stuff?id=eq.2&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 "GUC status override" $ do+        it "can override the status on RPC" $+          get "/rpc/send_body_status_403"+            `shouldRespondWith`+            [json|{"message" : "invalid user or password"}|]+            { matchStatus  = 403+            , matchHeaders = [ matchContentTypeJson ]+            }++        it "can override the status through trigger" $+          patch "/stuff?id=eq.1"+              [json|[{"name": "updated stuff 1"}]|]+            `shouldRespondWith`+              205++        it "fails when setting invalid status guc" $+          get "/rpc/send_bad_status"+            `shouldRespondWith`+            [json|{"message":"response.status guc must be a valid status code"}|]+            { matchStatus  = 500+            , matchHeaders = [ matchContentTypeJson ]+            }
test/Feature/SingularSpec.hs view
@@ -7,7 +7,6 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Text.Heredoc  import Protolude  hiding (get) import SpecHelper@@ -16,8 +15,7 @@ spec :: SpecWith ((), Application) spec =   describe "Requesting singular json object" $ do-    let pgrstObj = "application/vnd.pgrst.object+json"-        singular = ("Accept", pgrstObj)+    let singular = ("Accept", "application/vnd.pgrst.object+json")      context "with GET request" $ do       it "fails for zero rows" $@@ -26,140 +24,171 @@        it "will select an existing object" $ do         request methodGet "/items?id=eq.5" [singular] ""-          `shouldRespondWith` [str|{"id":5}|]+          `shouldRespondWith`+            [json|{"id":5}|]+            { matchHeaders = [matchContentTypeSingular] }         -- also test without the +json suffix         request methodGet "/items?id=eq.5"-          [("Accept", "application/vnd.pgrst.object")] ""-          `shouldRespondWith` [str|{"id":5}|]+            [("Accept", "application/vnd.pgrst.object")] ""+          `shouldRespondWith`+            [json|{"id":5}|]+            { matchHeaders = [matchContentTypeSingular] }        it "can combine multiple prefer values" $         request methodGet "/items?id=eq.5" [singular, ("Prefer","count=none")] ""-          `shouldRespondWith` [str|{"id":5}|]+          `shouldRespondWith`+            [json|{"id":5}|]+            { matchHeaders = [matchContentTypeSingular] }        it "can shape plurality singular object routes" $         request methodGet "/projects_view?id=eq.1&select=id,name,clients(*),tasks(id,name)" [singular] ""           `shouldRespondWith`             [json|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|]-            { matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] }+            { matchHeaders = [matchContentTypeSingular] }      context "when updating rows" $ do-      it "works for one row" $ do-        _ <- post "/addresses" [json| { id: 97, address: "A Street" } |]-        request methodPatch-          "/addresses?id=eq.97"-          [("Prefer", "return=representation"), singular]-          [json| { address: "B Street" } |]+      it "works for one row with return=rep" $ do+        request methodPatch "/addresses?id=eq.1"+            [("Prefer", "return=representation"), singular]+            [json| { address: "B Street" } |]           `shouldRespondWith`-            [str|{"id":97,"address":"B Street"}|]+            [json|{"id":1,"address":"B Street"}|]+            { matchHeaders = [matchContentTypeSingular] } +      it "works for one row with return=minimal" $+        request methodPatch "/addresses?id=eq.1"+            [("Prefer", "return=minimal"), singular]+            [json| { address: "C Street" } |]+          `shouldRespondWith`+            ""+            { matchStatus  = 204 }+       it "raises an error for multiple rows" $ do-        _ <- post "/addresses" [json| { id: 98, address: "xxx" } |]-        _ <- post "/addresses" [json| { id: 99, address: "yyy" } |]-        p <- request methodPatch "/addresses?id=gt.0"-                [singular]-                [json| { address: "zzz" } |]-        liftIO $ do-          simpleStatus p `shouldBe` notAcceptable406-          isErrorFormat (simpleBody p) `shouldBe` True+        request methodPatch "/addresses"+            [("Prefer", "tx=commit"), singular]+            [json| { address: "zzz" } |]+          `shouldRespondWith`+            [json|{"details":"Results contain 4 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+            { matchStatus  = 406+            , matchHeaders = [ matchContentTypeSingular+                             , "Preference-Applied" <:> "tx=commit" ]+            }          -- the rows should not be updated, either-        get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|]+        get "/addresses?id=eq.1"+          `shouldRespondWith`+            [json|[{"id":1,"address":"address 1"}]|]        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+        request methodPatch "/addresses"+            [("Prefer", "tx=commit"), ("Prefer", "return=representation"), singular]+            [json| { address: "zzz" } |]+          `shouldRespondWith`+            [json|{"details":"Results contain 4 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+            { matchStatus  = 406+            , matchHeaders = [ matchContentTypeSingular+                             , "Preference-Applied" <:> "tx=commit" ]+            }          -- the rows should not be updated, either-        get "/addresses?id=eq.100" `shouldRespondWith` [str|[{"id":100,"address":"xxx"}]|]+        get "/addresses?id=eq.1"+          `shouldRespondWith`+            [json|[{"id":1,"address":"address 1"}]|]        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"}|]+                  [json|{"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"]+                  , matchHeaders = [matchContentTypeSingular]                   }        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"}|]+                  [json|{"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"]+                  , matchHeaders = [matchContentTypeSingular]                   }      context "when creating rows" $ do-      it "works for one row" $ do-        p <- request methodPost-          "/addresses"-          [("Prefer", "return=representation"), singular]-          [json| [ { id: 102, address: "xxx" } ] |]-        liftIO $ simpleBody p `shouldBe` [str|{"id":102,"address":"xxx"}|]+      it "works for one row with return=rep" $ do+        request methodPost "/addresses"+            [("Prefer", "return=representation"), singular]+            [json| [ { id: 102, address: "xxx" } ] |]+          `shouldRespondWith`+            [json|{"id":102,"address":"xxx"}|]+            { matchStatus  = 201+            , matchHeaders = [matchContentTypeSingular]+            } -      it "works for one row even with return=minimal" $ do+      it "works for one row with return=minimal" $ do         request methodPost "/addresses"-          [("Prefer", "return=minimal"), singular]-          [json| [ { id: 103, address: "xxx" } ] |]+            [("Prefer", "return=minimal"), singular]+            [json| [ { id: 103, address: "xxx" } ] |]           `shouldRespondWith` ""-          { matchStatus  = 201-          , matchHeaders = ["Content-Range" <:> "*/*"]-          }-        -- and the element should exist-        get "/addresses?id=eq.103"-          `shouldRespondWith` [str|[{"id":103,"address":"xxx"}]|]-          { matchStatus  = 200-          , matchHeaders = []-          }+            { matchStatus  = 201+            , matchHeaders = ["Content-Range" <:> "*/*"]+            }        it "raises an error when attempting to create multiple entities" $ do-        p <- request methodPost-          "/addresses"-          [singular]-          [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]-        liftIO $ simpleStatus p `shouldBe` notAcceptable406+        request methodPost "/addresses"+            [("Prefer", "tx=commit"), singular]+            [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]+          `shouldRespondWith`+            [json|{"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 = [ matchContentTypeSingular+                             , "Preference-Applied" <:> "tx=commit" ]+            }          -- the rows should not exist, either-        get "/addresses?id=eq.200" `shouldRespondWith` "[]"+        get "/addresses?id=eq.200"+          `shouldRespondWith`+            "[]"        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+        request methodPost "/addresses"+            [("Prefer", "tx=commit"), ("Prefer", "return=representation"), singular]+            [json| [ { id: 202, address: "xxx" }, { id: 203, address: "yyy" } ] |]+          `shouldRespondWith`+            [json|{"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 = [ matchContentTypeSingular+                             , "Preference-Applied" <:> "tx=commit" ]+            }          -- the rows should not exist, either-        get "/addresses?id=eq.202" `shouldRespondWith` "[]"+        get "/addresses?id=eq.202"+          `shouldRespondWith`+            "[]"        it "raises an error regardless of return=minimal" $ do         request methodPost "/addresses"-                [("Prefer", "return=minimal"), singular]-                [json| [ { id: 204, address: "xxx" }, { id: 205, address: "yyy" } ] |]+            [("Prefer", "tx=commit"), ("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"]-                  }+            [json|{"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 = [ matchContentTypeSingular+                             , "Preference-Applied" <:> "tx=commit" ]+            }          -- the rows should not exist, either-        get "/addresses?id=eq.204" `shouldRespondWith` "[]"+        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"}|]+                  [json|{"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"]+                  , matchHeaders = [matchContentTypeSingular]                   }        it "raises an error when creating zero entities with return=rep" $@@ -167,58 +196,76 @@                 [("Prefer", "return=representation"), singular]                 [json| [ ] |]           `shouldRespondWith`-                  [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+                  [json|{"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"]+                  , matchHeaders = [matchContentTypeSingular]                   }      context "when deleting rows" $ do-      it "works for one row" $ do+      it "works for one row with return=rep" $ do         p <- request methodDelete           "/items?id=eq.11"           [("Prefer", "return=representation"), singular] ""-        liftIO $ simpleBody p `shouldBe` [str|{"id":11}|]+        liftIO $ simpleBody p `shouldBe` [json|{"id":11}|] +      it "works for one row with return=minimal" $ do+        p <- request methodDelete+          "/items?id=eq.12"+          [("Prefer", "return=minimal"), singular] ""+        liftIO $ simpleBody p `shouldBe` ""+       it "raises an error when attempting to delete multiple entities" $ do-        let firstItems = "/items?id=gt.0&id=lt.6"-        request methodDelete firstItems-          [singular] ""-          `shouldRespondWith` 406+        request methodDelete "/items?id=gt.0&id=lt.6"+            [("Prefer", "tx=commit"), singular]+            ""+          `shouldRespondWith`+            [json|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+            { matchStatus  = 406+            , matchHeaders = [ matchContentTypeSingular+                             , "Preference-Applied" <:> "tx=commit" ]+            } -        get firstItems-          `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5}] |]-          { matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "0-4/*"]-          }+        -- the rows should still exist+        get "/items?id=gt.0&id=lt.6&order=id"+          `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+        request methodDelete "/items?id=gt.5&id=lt.11"+            [("Prefer", "tx=commit"), ("Prefer", "return=representation"), singular] ""+          `shouldRespondWith`+            [json|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+            { matchStatus  = 406+            , matchHeaders = [ matchContentTypeSingular+                             , "Preference-Applied" <:> "tx=commit" ]+            } -        get firstItems+        -- the rows should still exist+        get "/items?id=gt.5&id=lt.11"           `shouldRespondWith` [json| [{"id":6},{"id":7},{"id":8},{"id":9},{"id":10}] |]-          { matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "0-4/*"]-          }+            { matchStatus  = 200+            , 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"}|]+                [json|{"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"]+                , matchHeaders = [matchContentTypeSingular]                 }        it "raises an error when deleting zero entities with return=rep" $         request methodDelete "/items?id=lt.0"                 [("Prefer", "return=representation"), singular] ""           `shouldRespondWith`-                [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+                [json|{"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"]+                , matchHeaders = [matchContentTypeSingular]                 }      context "when calling a stored proc" $ do@@ -226,9 +273,9 @@         request methodPost "/rpc/getproject"                 [singular] [json|{ "id": 9999999}|]           `shouldRespondWith`-                [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+                [json|{"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"]+                , matchHeaders = [matchContentTypeSingular]                 }        -- this one may be controversial, should vnd.pgrst.object include@@ -240,30 +287,38 @@        it "returns a single object for json proc" $         request methodPost "/rpc/getproject"-          [singular] [json|{ "id": 1}|] `shouldRespondWith`-          [str|{"id":1,"name":"Windows 7","client_id":1}|]+            [singular] [json|{ "id": 1}|]+          `shouldRespondWith`+            [json|{"id":1,"name":"Windows 7","client_id":1}|]+            { matchHeaders = [matchContentTypeSingular] }        it "fails for multiple rows" $         request methodPost "/rpc/getallprojects"                 [singular] "{}"           `shouldRespondWith`-                [str|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]+                [json|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]                 { matchStatus  = 406-                , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]+                , matchHeaders = [matchContentTypeSingular]                 } -      it "executes the proc exactly once per request" $ do-        request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]-          `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]+      it "fails for multiple rows with rolled back changes" $ do+        post "/rpc/getproject?select=id,name"+            [json| {"id": 1} |]+          `shouldRespondWith`+            [json|[{"id":1,"name":"Windows 7"}]|] -        request methodPost "/rpc/setprojects" [singular]-                [json| {"id_l": 1, "id_h": 2, "name": "changed"} |]+        request methodPost "/rpc/setprojects"+            [("Prefer", "tx=commit"), singular]+            [json| {"id_l": 1, "id_h": 2, "name": "changed"} |]           `shouldRespondWith`-                [str|{"details":"Results contain 2 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|]-                { matchStatus  = 406-                , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"]-                }+            [json|{"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 = [ matchContentTypeSingular+                             , "Preference-Applied" <:> "tx=commit" ]+            } -        -- should not actually have executed the function-        request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]-          `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]+        -- should rollback function+        post "/rpc/getproject?select=id,name"+            [json| {"id": 1} |]+          `shouldRespondWith`+            [json|[{"id":1,"name":"Windows 7"}]|]
− test/Feature/StructureSpec.hs 
@@ -1,516 +0,0 @@-module Feature.StructureSpec where--import Control.Lens     ((^?))-import Data.Aeson.Types (Value (..))-import Network.Wai      (Application)-import Network.Wai.Test (SResponse (..))--import Data.Aeson.Lens-import Data.Aeson.QQ-import Network.HTTP.Types-import Test.Hspec         hiding (pendingWith)-import Test.Hspec.Wai----import PostgREST.Config (docsVersion)-import Protolude        hiding (get)-import SpecHelper--spec :: SpecWith ((), Application)-spec = do--  describe "OpenAPI" $ do-    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"-              (acceptHdrs "application/openapi+json") ""-        `shouldRespondWith` 415--    it "includes postgrest.org current version api docs" $ do-      r <- simpleBody <$> get "/"--      let docsUrl = r ^? key "externalDocs" . key "url"--      liftIO $ docsUrl `shouldBe` Just (String ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))--    describe "table" $ do--      it "includes paths to tables" $ do-        r <- simpleBody <$> get "/"--        let method s = key "paths" . key "/child_entities" . key s-            childGetSummary = r ^? method "get" . key "summary"-            childGetDescription = r ^? method "get" . key "description"-            getParameters = r ^? method "get" . key "parameters"-            postParameters = r ^? method "post" . key "parameters"-            postResponse = r ^? method "post" . key "responses" . key "201" . key "description"-            patchResponse = r ^? method "patch" . key "responses" . key "204" . key "description"-            deleteResponse = r ^? method "delete" . key "responses" . key "204" . key "description"--        let grandChildGet s = key "paths" . key "/grandchild_entities" . key "get" . key s-            grandChildGetSummary = r ^? grandChildGet "summary"-            grandChildGetDescription = r ^? grandChildGet "description"--        liftIO $ do--          childGetSummary `shouldBe` Just "child_entities comment"--          childGetDescription `shouldBe` Nothing--          grandChildGetSummary `shouldBe` Just "grandchild_entities summary"--          grandChildGetDescription `shouldBe` Just "grandchild_entities description\nthat spans\nmultiple lines"--          getParameters `shouldBe` Just-            [aesonQQ|-              [-                { "$ref": "#/parameters/rowFilter.child_entities.id" },-                { "$ref": "#/parameters/rowFilter.child_entities.name" },-                { "$ref": "#/parameters/rowFilter.child_entities.parent_id" },-                { "$ref": "#/parameters/select" },-                { "$ref": "#/parameters/order" },-                { "$ref": "#/parameters/range" },-                { "$ref": "#/parameters/rangeUnit" },-                { "$ref": "#/parameters/offset" },-                { "$ref": "#/parameters/limit" },-                { "$ref": "#/parameters/preferCount" }-              ]-            |]--          postParameters `shouldBe` Just-            [aesonQQ|-              [-                { "$ref": "#/parameters/body.child_entities" },-                { "$ref": "#/parameters/select" },-                { "$ref": "#/parameters/preferReturn" }-              ]-            |]--          postResponse `shouldBe` Just "Created"--          patchResponse `shouldBe` Just "No Content"--          deleteResponse `shouldBe` Just "No Content"--      it "includes an array type for GET responses" $ do-        r <- simpleBody <$> get "/"--        let childGetSchema = r ^? key "paths"-              . key "/child_entities"-              . key "get"-              . key "responses"-              . key "200"-              . key "schema"--        liftIO $-          childGetSchema `shouldBe` Just-            [aesonQQ|-              {-                "items": {-                  "$ref": "#/definitions/child_entities"-                },-                "type": "array"-              }-            |]--      it "includes definitions to tables" $ do-        r <- simpleBody <$> get "/"--        let def = r ^? key "definitions" . key "child_entities"--        liftIO $--          def `shouldBe` Just-            [aesonQQ|-              {-                "type": "object",-                "description": "child_entities comment",-                "properties": {-                  "id": {-                    "description": "child_entities id comment\n\nNote:\nThis is a Primary Key.<pk/>",-                    "format": "integer",-                    "type": "integer"-                  },-                  "name": {-                    "description": "child_entities name comment. Can be longer than sixty-three characters long",-                    "format": "text",-                    "type": "string"-                  },-                  "parent_id": {-                    "description": "Note:\nThis is a Foreign Key to `entities.id`.<fk table='entities' column='id'/>",-                    "format": "integer",-                    "type": "integer"-                  }-                },-                "required": [-                  "id"-                ]-              }-            |]--      it "doesn't include privileged table for anonymous" $ do-        r <- simpleBody <$> get "/"-        let tablePath = r ^? key "paths" . key "/authors_only"--        liftIO $ tablePath `shouldBe` Nothing--      it "includes table if user has permission" $ do-        let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"-        r <- simpleBody <$> request methodGet "/" [auth] ""-        let tableTag = r ^? key "paths" . key "/authors_only"-                      . key "post"  . key "tags"-                      . nth 0-        liftIO $ tableTag `shouldBe` Just [aesonQQ|"authors_only"|]--    describe "Foreign table" $--      it "includes foreign table properties" $ do-        r <- simpleBody <$> get "/"--        let method s = key "paths" . key "/projects_dump" . key s-            getSummary = r ^? method "get" . key "summary"-            getDescription = r ^? method "get" . key "description"-            getParameters = r ^? method "get" . key "parameters"--        liftIO $ do--          getSummary `shouldBe` Just "A temporary projects dump"--          getDescription `shouldBe` Just "Just a test for foreign tables"--          getParameters `shouldBe` Just-            [aesonQQ|-              [-                { "$ref": "#/parameters/rowFilter.projects_dump.id" },-                { "$ref": "#/parameters/rowFilter.projects_dump.name" },-                { "$ref": "#/parameters/rowFilter.projects_dump.client_id" },-                { "$ref": "#/parameters/select" },-                { "$ref": "#/parameters/order" },-                { "$ref": "#/parameters/range" },-                { "$ref": "#/parameters/rangeUnit" },-                { "$ref": "#/parameters/offset" },-                { "$ref": "#/parameters/limit" },-                { "$ref": "#/parameters/preferCount" }-              ]-            |]--    describe "Materialized view" $--      it "includes materialized view properties" $ do-        r <- simpleBody <$> get "/"--        let method s = key "paths" . key "/materialized_projects" . key s-            summary = r ^? method "get" . key "summary"-            description = r ^? method "get" . key "description"-            parameters = r ^? method "get" . key "parameters"--        liftIO $ do--          summary `shouldBe` Just "A materialized view for projects"--          description `shouldBe` Just "Just a test for materialized views"--          parameters `shouldBe` Just-            [aesonQQ|-              [-                { "$ref": "#/parameters/rowFilter.materialized_projects.id" },-                { "$ref": "#/parameters/rowFilter.materialized_projects.name" },-                { "$ref": "#/parameters/rowFilter.materialized_projects.client_id" },-                { "$ref": "#/parameters/select" },-                { "$ref": "#/parameters/order" },-                { "$ref": "#/parameters/range" },-                { "$ref": "#/parameters/rangeUnit" },-                { "$ref": "#/parameters/offset" },-                { "$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--      it "character varying to string" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character_varying"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "character varying",-                "type": "string"-              }-            |]-      it "character(1) to string" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "maxLength": 1,-                "format": "character",-                "type": "string"-              }-            |]--      it "text to string" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_text"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "text",-                "type": "string"-              }-            |]--      it "boolean to boolean" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_boolean"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "boolean",-                "type": "boolean"-              }-            |]--      it "smallint to integer" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_smallint"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "smallint",-                "type": "integer"-              }-            |]--      it "integer to integer" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_integer"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "integer",-                "type": "integer"-              }-            |]--      it "bigint to integer" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_bigint"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "bigint",-                "type": "integer"-              }-            |]--      it "numeric to number" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_numeric"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "numeric",-                "type": "number"-              }-            |]--      it "real to number" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_real"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "real",-                "type": "number"-              }-            |]--      it "double_precision to number" $ do-        r <- simpleBody <$> get "/"--        let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_double_precision"--        liftIO $--          types `shouldBe` Just-            [aesonQQ|-              {-                "format": "double precision",-                "type": "number"-              }-            |]--    describe "RPC" $ do--      it "includes function summary/description and body schema for arguments" $ do-        r <- simpleBody <$> get "/"--        let method s = key "paths" . key "/rpc/varied_arguments" . key s-            args = r ^? method "post" . key "parameters" . nth 0 . key "schema"-            summary = r ^? method "post" . key "summary"-            description = r ^? method "post" . key "description"--        liftIO $ do--          summary `shouldBe` Just "An RPC function"--          description `shouldBe` Just "Just a test for RPC function arguments"--          args `shouldBe` Just-            [aesonQQ|-              {-                "required": [-                  "double",-                  "varchar",-                  "boolean",-                  "date",-                  "money",-                  "enum"-                ],-                "properties": {-                  "double": {-                    "format": "double precision",-                    "type": "number"-                  },-                  "varchar": {-                    "format": "character varying",-                    "type": "string"-                  },-                  "boolean": {-                    "format": "boolean",-                    "type": "boolean"-                  },-                  "date": {-                    "format": "date",-                    "type": "string"-                  },-                  "money": {-                    "format": "money",-                    "type": "string"-                  },-                  "enum": {-                    "format": "enum_menagerie_type",-                    "type": "string"-                  },-                  "integer": {-                    "format": "integer",-                    "type": "integer"-                  },-                  "json": {-                    "format": "json",-                    "type": "string"-                  },-                  "jsonb": {-                    "format": "jsonb",-                    "type": "string"-                  }-                },-                "type": "object",-                "description": "An RPC function\n\nJust a test for RPC function arguments"-              }-            |]--      it "doesn't include privileged function for anonymous" $ do-        r <- simpleBody <$> get "/"-        let funcPath = r ^? key "paths" . key "/rpc/privileged_hello"--        liftIO $ funcPath `shouldBe` Nothing--      it "includes function if user has permission" $ do-        let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"-        r <- simpleBody <$> request methodGet "/" [auth] ""-        let funcTag = r ^? key "paths" . key "/rpc/privileged_hello"-                      . key "post"  . key "tags"-                      . nth 0--        liftIO $ funcTag `shouldBe` Just [aesonQQ|"(rpc) privileged_hello"|]--      it "doesn't include OUT params of function as required parameters" $ do-        r <- simpleBody <$> get "/"-        let params = r ^? key "paths" . key "/rpc/many_out_params"-                        . key "post" . key "parameters" .  nth 0-                        . key "schema". key "required"--        liftIO $ params `shouldBe` Nothing--      it "includes INOUT params(with no DEFAULT) of function as required parameters" $ do-        r <- simpleBody <$> get "/"-        let params = r ^? key "paths" . key "/rpc/many_inout_params"-                        . key "post" . key "parameters" .  nth 0-                        . key "schema". key "required"--        liftIO $ params `shouldBe` Just [aesonQQ|["num", "str"]|]--  describe "Allow header" $ do--    it "includes read/write verbs for writeable table" $ do-      r <- request methodOptions "/items" [] ""-      liftIO $-        simpleHeaders r `shouldSatisfy`-          matchHeader "Allow" "GET,POST,PATCH,DELETE"--    it "includes read verbs for read-only table" $ do-      r <- request methodOptions "/has_count_column" [] ""-      liftIO $-        simpleHeaders r `shouldSatisfy`-          matchHeader "Allow" "GET"
test/Feature/UnicodeSpec.hs view
@@ -2,12 +2,12 @@  import Network.Wai (Application) +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Protolude  hiding (get)-import SpecHelper+import Protolude hiding (get)  spec :: SpecWith ((), Application) spec =@@ -16,9 +16,19 @@       get "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"         `shouldRespondWith` "[]" -      void $ post "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"-        [json| { "هویت": 1 } |]+      request methodPost "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"+          [("Prefer", "tx=commit"), ("Prefer", "return=representation")]+          [json| { "هویت": 1 } |]+        `shouldRespondWith`+          [json| [{ "هویت": 1 }] |]+          { matchStatus = 201 }        get "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"-        `shouldRespondWith` [json| [{ "هویت": 1 }] |]-        { matchHeaders = [matchContentTypeJson] }+        `shouldRespondWith`+          [json| [{ "هویت": 1 }] |]++      request methodDelete "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"+          [("Prefer", "tx=commit")]+          ""+        `shouldRespondWith`+          204
+ test/Feature/UpdateSpec.hs view
@@ -0,0 +1,349 @@+module Feature.UpdateSpec where++import Network.Wai (Application)+import Test.Hspec  hiding (pendingWith)++import Network.HTTP.Types+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON++import Protolude  hiding (get)+import SpecHelper++spec :: SpecWith ((), Application)+spec = do+  describe "Patching record" $ do+    context "to unknown uri" $+      it "indicates no table found by returning 404" $+        request methodPatch "/fake" []+          [json| { "real": false } |]+            `shouldRespondWith` 404++    context "on an empty table" $+      it "indicates no records found to update by returning 404" $+        request methodPatch "/empty_table" []+          [json| { "extra":20 } |]+          `shouldRespondWith` ""+          { matchStatus  = 404,+            matchHeaders = []+          }++    context "with invalid json payload" $+      it "fails with 400 and error" $+        request methodPatch "/simple_pk" [] "}{ x = 2"+          `shouldRespondWith`+          [json|{"message":"Error in $: Failed reading: not a valid json value at '}{x=2'"}|]+          { matchStatus  = 400,+            matchHeaders = [matchContentTypeJson]+          }++    context "with no payload" $+      it "fails with 400 and error" $+        request methodPatch "/items" [] ""+          `shouldRespondWith`+          [json|{"message":"Error in $: not enough input"}|]+          { matchStatus  = 400,+            matchHeaders = [matchContentTypeJson]+          }++    context "in a nonempty table" $ do+      it "can update a single item" $ do+        patch "/items?id=eq.2"+            [json| { "id":42 } |]+          `shouldRespondWith`+            ""+            { matchStatus  = 204+            , matchHeaders = ["Content-Range" <:> "0-0/*"]+            }++      it "returns empty array when no rows updated and return=rep" $+        request methodPatch "/items?id=eq.999999"+          [("Prefer", "return=representation")] [json| { "id":999999 } |]+          `shouldRespondWith` "[]"+          {+            matchStatus  = 404,+            matchHeaders = []+          }++      it "gives a 404 when no rows updated" $+        request methodPatch "/items?id=eq.99999999" []+          [json| { "id": 42 } |]+            `shouldRespondWith` 404++      it "returns updated object as array when return=rep" $+        request methodPatch "/items?id=eq.2"+          [("Prefer", "return=representation")] [json| { "id":2 } |]+          `shouldRespondWith` [json|[{"id":2}]|]+          { matchStatus  = 200,+            matchHeaders = ["Content-Range" <:> "0-0/*"]+          }++      it "can update multiple items" $ do+        get "/no_pk?select=a&b=eq.1"+          `shouldRespondWith`+            [json|[]|]++        request methodPatch "/no_pk?b=eq.0"+            [("Prefer", "tx=commit")]+            [json| { b: "1" } |]+          `shouldRespondWith`+            ""+            { matchStatus  = 204+            , matchHeaders = ["Content-Range" <:> "0-1/*"+                             , "Preference-Applied" <:> "tx=commit" ]+            }++        -- check it really got updated+        get "/no_pk?select=a&b=eq.1"+          `shouldRespondWith`+            [json|[ { a: "1" }, { a: "2" } ]|]++        -- put value back for other tests+        request methodPatch "/no_pk?b=eq.1"+            [("Prefer", "tx=commit")]+            [json| { b: "0" } |]+          `shouldRespondWith`+            204++      it "can set a column to NULL" $ do+        request methodPatch "/no_pk?a=eq.1"+            [("Prefer", "return=representation")]+            [json| { b: null } |]+          `shouldRespondWith`+            [json| [{ a: "1", b: null }] |]++      context "filtering by a computed column" $ do+        it "is successful" $+          request methodPatch+            "/items?is_first=eq.true"+            [("Prefer", "return=representation")]+            [json| { id: 100 } |]+            `shouldRespondWith` [json| [{ id: 100 }] |]+            { matchStatus  = 200,+              matchHeaders = [matchContentTypeJson, "Content-Range" <:> "0-0/*"]+            }++        it "indicates no records updated by returning 404" $+          request methodPatch+            "/items?always_true=eq.false"+            [("Prefer", "return=representation")]+            [json| { id: 100 } |]+            `shouldRespondWith` "[]"+            { matchStatus  = 404,+              matchHeaders = []+            }++      context "with representation requested" $ do+        it "can provide a representation" $ do+          _ <- post "/items"+            [json| { id: 1 } |]+          request methodPatch+            "/items?id=eq.1"+            [("Prefer", "return=representation")]+            [json| { id: 99 } |]+            `shouldRespondWith` [json| [{id:99}] |]+            { matchHeaders = [matchContentTypeJson] }+          -- put value back for other tests+          void $ request methodPatch "/items?id=eq.99" [] [json| { "id":1 } |]++        it "can return computed columns" $+          request methodPatch+            "/items?id=eq.1&select=id,always_true"+            [("Prefer", "return=representation")]+            [json| { id: 1 } |]+            `shouldRespondWith` [json| [{ id: 1, always_true: true }] |]+            { matchHeaders = [matchContentTypeJson] }++        it "can select overloaded computed columns" $ do+          request methodPatch+            "/items?id=eq.1&select=id,computed_overload"+            [("Prefer", "return=representation")]+            [json| { id: 1 } |]+            `shouldRespondWith` [json| [{ id: 1, computed_overload: true }] |]+            { matchHeaders = [matchContentTypeJson] }+          request methodPatch+            "/items2?id=eq.1&select=id,computed_overload"+            [("Prefer", "return=representation")]+            [json| { id: 1 } |]+            `shouldRespondWith` [json| [{ id: 1, computed_overload: true }] |]+            { matchHeaders = [matchContentTypeJson] }++      it "ignores ?select= when return not set or return=minimal" $ do+        request methodPatch "/items?id=eq.1&select=id" [] [json| { id:1 } |]+          `shouldRespondWith` ""+          {+            matchStatus  = 204,+            matchHeaders = ["Content-Range" <:> "0-0/*"]+          }+        request methodPatch "/items?id=eq.1&select=id" [("Prefer", "return=minimal")] [json| { id:1 } |]+          `shouldRespondWith` ""+          {+            matchStatus  = 204,+            matchHeaders = ["Content-Range" <:> "0-0/*"]+          }++      context "when patching with an empty body" $ do+        it "makes no updates and returns 204 without return= and without ?select=" $ do+          request methodPatch "/items" [] [json| {} |]+            `shouldRespondWith` ""+            {+              matchStatus  = 204,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++          request methodPatch "/items" [] [json| [] |]+            `shouldRespondWith` ""+            {+              matchStatus  = 204,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++          request methodPatch "/items" [] [json| [{}] |]+            `shouldRespondWith` ""+            {+              matchStatus  = 204,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++        it "makes no updates and returns 204 without return= and with ?select=" $ do+          request methodPatch "/items?select=id" [] [json| {} |]+            `shouldRespondWith` ""+            {+              matchStatus  = 204,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++          request methodPatch "/items?select=id" [] [json| [] |]+            `shouldRespondWith` ""+            {+              matchStatus  = 204,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++          request methodPatch "/items?select=id" [] [json| [{}] |]+            `shouldRespondWith` ""+            {+              matchStatus  = 204,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++        it "makes no updates and returns 200 with return=rep and without ?select=" $+          request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |]+            `shouldRespondWith` "[]"+            {+              matchStatus  = 200,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++        it "makes no updates and returns 200 with return=rep and with ?select=" $+          request methodPatch "/items?select=id" [("Prefer", "return=representation")] [json| {} |]+            `shouldRespondWith` "[]"+            {+              matchStatus  = 200,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++        it "makes no updates and returns 200 with return=rep and with ?select= for overloaded computed columns" $+          request methodPatch "/items?select=id,computed_overload" [("Prefer", "return=representation")] [json| {} |]+            `shouldRespondWith` "[]"+            {+              matchStatus  = 200,+              matchHeaders = ["Content-Range" <:> "*/*"]+            }++    context "with unicode values" $+      it "succeeds and returns values intact" $ do+        request methodPatch "/no_pk?a=eq.1"+            [("Prefer", "return=representation")]+            [json| { "a":"圍棋", "b":"￥" } |]+          `shouldRespondWith`+            [json|[ { "a":"圍棋", "b":"￥" } ]|]++    context "PATCH with ?columns parameter" $ do+      it "ignores json keys not included in ?columns" $ do+        request methodPatch "/articles?id=eq.1&columns=body"+            [("Prefer", "return=representation")]+            [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |]+          `shouldRespondWith`+            [json|[{"id": 1, "body": "Some real content", "owner": "postgrest_test_anonymous"}]|]++      it "ignores json keys and gives 404 if no record updated" $+        request methodPatch "/articles?id=eq.2001&columns=body" [("Prefer", "return=representation")]+          [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith` 404++  context "tables with self reference foreign keys" $ do+    it "embeds children 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, children and grandchildren 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 children 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 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/UpsertSpec.hs view
@@ -6,7 +6,6 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON-import Text.Heredoc  import Protolude  hiding (get, put) import SpecHelper@@ -101,30 +100,38 @@             }          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]-            }+          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": 2, "value": "C" },+                { "unique_key": 3, "value": "D" }+              ]|]+              { matchStatus = 201+              , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates"]+              }          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]-            }+          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": 2, "value": "C" },+                { "key1": 1, "key2": 3, "value": "D" }+              ]|]+              { matchStatus = 201+              , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates"]+              }        it "succeeds if the table has only PK cols and no other cols" $ do         request methodPost "/only_pk" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]@@ -161,160 +168,205 @@       context "Restrictions" $ do         it "fails if Range is specified" $           request methodPut "/tiobe_pls?name=eq.Javascript" [("Range", "0-5")]-            [str| [ { "name": "Javascript", "rank": 1 } ]|]+            [json| [ { "name": "Javascript", "rank": 1 } ]|]             `shouldRespondWith`             [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]             { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }          it "fails if limit is specified" $           put "/tiobe_pls?name=eq.Javascript&limit=1"-            [str| [ { "name": "Javascript", "rank": 1 } ]|]+            [json| [ { "name": "Javascript", "rank": 1 } ]|]             `shouldRespondWith`             [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]             { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }          it "fails if offset is specified" $           put "/tiobe_pls?name=eq.Javascript&offset=1"-            [str| [ { "name": "Javascript", "rank": 1 } ]|]+            [json| [ { "name": "Javascript", "rank": 1 } ]|]             `shouldRespondWith`             [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]             { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }          it "rejects every other filter than pk cols eq's" $ do           put "/tiobe_pls?rank=eq.19"-            [str| [ { "name": "Go", "rank": 19 } ]|]+            [json| [ { "name": "Go", "rank": 19 } ]|]             `shouldRespondWith`             [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]             { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }            put "/tiobe_pls?id=not.eq.Java"-            [str| [ { "name": "Go", "rank": 19 } ]|]+            [json| [ { "name": "Go", "rank": 19 } ]|]             `shouldRespondWith`             [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]             { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }           put "/tiobe_pls?id=in.(Go)"-            [str| [ { "name": "Go", "rank": 19 } ]|]+            [json| [ { "name": "Go", "rank": 19 } ]|]             `shouldRespondWith`             [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]             { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }           put "/tiobe_pls?and=(id.eq.Go)"-            [str| [ { "name": "Go", "rank": 19 } ]|]+            [json| [ { "name": "Go", "rank": 19 } ]|]             `shouldRespondWith`             [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]             { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }          it "fails if not all composite key cols are specified as eq filters" $ do           put "/employees?first_name=eq.Susan"-            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]+            [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]             `shouldRespondWith`             [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]             { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }           put "/employees?last_name=eq.Heidt"-            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]+            [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]             `shouldRespondWith`             [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]             { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }        it "fails if the uri primary key doesn't match the payload primary key" $ do-        put "/tiobe_pls?name=eq.MATLAB" [str| [ { "name": "Perl", "rank": 17 } ]|]+        put "/tiobe_pls?name=eq.MATLAB" [json| [ { "name": "Perl", "rank": 17 } ]|]           `shouldRespondWith`           [json|{"message":"Payload values do not match URL in primary key column(s)"}|]           { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }         put "/employees?first_name=eq.Wendy&last_name=eq.Anderson"-          [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]+          [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]           `shouldRespondWith`           [json|{"message":"Payload values do not match URL in primary key column(s)"}|]           { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }        it "fails if the table has no PK" $-        put "/no_pk?a=eq.one&b=eq.two" [str| [ { "a": "one", "b": "two" } ]|]+        put "/no_pk?a=eq.one&b=eq.two" [json| [ { "a": "one", "b": "two" } ]|]           `shouldRespondWith`           [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]           { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }        context "Inserting row" $ do         it "succeeds on table with single pk col" $ do-          get "/tiobe_pls?name=eq.Go" `shouldRespondWith` "[]"-          put "/tiobe_pls?name=eq.Go" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 204-          get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json| [ { "name": "Go", "rank": 19 } ]|] { matchHeaders = [matchContentTypeJson] }+          -- assert that the next request will indeed be an insert+          get "/tiobe_pls?name=eq.Go"+            `shouldRespondWith`+              [json|[]|] +          request methodPut "/tiobe_pls?name=eq.Go"+              [("Prefer", "return=representation")]+              [json| [ { "name": "Go", "rank": 19 } ]|]+            `shouldRespondWith`+              [json| [ { "name": "Go", "rank": 19 } ]|]+         it "succeeds on table with composite pk" $ do-          get "/employees?first_name=eq.Susan&last_name=eq.Heidt"-            `shouldRespondWith` "[]"-          put "/employees?first_name=eq.Susan&last_name=eq.Heidt"-            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]-            `shouldRespondWith` 204+          -- assert that the next request will indeed be an insert           get "/employees?first_name=eq.Susan&last_name=eq.Heidt"             `shouldRespondWith`-            [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$48,000.00", "company": "GEX", "occupation": "Railroad engineer" } ]|]-            { matchHeaders = [matchContentTypeJson] }+              [json|[]|] +          request methodPut "/employees?first_name=eq.Susan&last_name=eq.Heidt"+              [("Prefer", "return=representation")]+              [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]+            `shouldRespondWith`+              [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$48,000.00", "company": "GEX", "occupation": "Railroad engineer" } ]|]+         it "succeeds if the table has only PK cols and no other cols" $ do-          get "/only_pk?id=eq.10" `shouldRespondWith` "[]"-          put "/only_pk?id=eq.10" [str|[ { "id": 10 } ]|] `shouldRespondWith` 204-          get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] }+          -- assert that the next request will indeed be an insert+          get "/only_pk?id=eq.10"+            `shouldRespondWith`+              [json|[]|] +          request methodPut "/only_pk?id=eq.10"+              [("Prefer", "return=representation")]+              [json|[ { "id": 10 } ]|]+            `shouldRespondWith`+              [json|[ { "id": 10 } ]|]+       context "Updating row" $ do         it "succeeds on table with single pk col" $ do-          get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json|[ { "name": "Go", "rank": 19 } ]|] { matchHeaders = [matchContentTypeJson] }-          put "/tiobe_pls?name=eq.Go" [str| [ { "name": "Go", "rank": 13 } ]|] `shouldRespondWith` 204-          get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json| [ { "name": "Go", "rank": 13 } ]|] { matchHeaders = [matchContentTypeJson] }+          -- assert that the next request will indeed be an update+          get "/tiobe_pls?name=eq.Java"+            `shouldRespondWith`+              [json|[ { "name": "Java", "rank": 1 } ]|] -        it "succeeds if the payload has more than one row, but it only puts the first element" $-          request methodPut "/tiobe_pls?name=eq.Go"-            [("Prefer", "return=representation"), ("Accept", "application/vnd.pgrst.object+json")]-            [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ] |]+          request methodPut "/tiobe_pls?name=eq.Java"+              [("Prefer", "return=representation")]+              [json| [ { "name": "Java", "rank": 13 } ]|]             `shouldRespondWith`-            [json|{ "name": "Go", "rank": 19 }|]-            { matchStatus = 200 , matchHeaders = [matchContentTypeSingular] }+              [json| [ { "name": "Java", "rank": 13 } ]|] +        -- TODO: move this to SingularSpec?+        it "succeeds if the payload has more than one row, but it only puts the first element" $ do+          -- assert that the next request will indeed be an update+          get "/tiobe_pls?name=eq.Java"+            `shouldRespondWith`+              [json|[ { "name": "Java", "rank": 1 } ]|]++          request methodPut "/tiobe_pls?name=eq.Java"+              [("Prefer", "return=representation"), ("Accept", "application/vnd.pgrst.object+json")]+              [json| [ { "name": "Java", "rank": 19 }, { "name": "Swift", "rank": 12 } ] |]+            `shouldRespondWith`+              [json|{ "name": "Java", "rank": 19 }|]+              { matchHeaders = [matchContentTypeSingular] }+         it "succeeds on table with composite pk" $ do-          get "/employees?first_name=eq.Susan&last_name=eq.Heidt"+          -- assert that the next request will indeed be an update+          get "/employees?first_name=eq.Frances M.&last_name=eq.Roe"             `shouldRespondWith`-            [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$48,000.00", "company": "GEX", "occupation": "Railroad engineer" } ]|]-            { matchHeaders = [matchContentTypeJson] }-          put "/employees?first_name=eq.Susan&last_name=eq.Heidt"-            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "60000", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|]-            `shouldRespondWith` 204-          get "/employees?first_name=eq.Susan&last_name=eq.Heidt"+              [json| [ { "first_name": "Frances M.", "last_name": "Roe", "salary": "$24,000.00", "company": "One-Up Realty", "occupation": "Author" } ]|]++          request methodPut "/employees?first_name=eq.Frances M.&last_name=eq.Roe"+              [("Prefer", "return=representation")]+              [json| [ { "first_name": "Frances M.", "last_name": "Roe", "salary": "60000", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|]             `shouldRespondWith`-            [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$60,000.00", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|]-            { matchHeaders = [matchContentTypeJson] }+              [json| [ { "first_name": "Frances M.", "last_name": "Roe", "salary": "$60,000.00", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|]          it "succeeds if the table has only PK cols and no other cols" $ do-          get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] }-          put "/only_pk?id=eq.10" [str|[ { "id": 10 } ]|] `shouldRespondWith` 204-          get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] }+          -- assert that the next request will indeed be an update+          get "/only_pk?id=eq.1"+            `shouldRespondWith`+              [json|[ { "id": 1 } ]|] +          request methodPut "/only_pk?id=eq.1"+              [("Prefer", "return=representation")]+              [json|[ { "id": 1 } ]|]+            `shouldRespondWith`+              [json|[ { "id": 1 } ]|]++      -- TODO: move this to SingularSpec?       it "works with return=representation and vnd.pgrst.object+json" $         request methodPut "/tiobe_pls?name=eq.Ruby"           [("Prefer", "return=representation"), ("Accept", "application/vnd.pgrst.object+json")]-          [str| [ { "name": "Ruby", "rank": 11 } ]|]+          [json| [ { "name": "Ruby", "rank": 11 } ]|]           `shouldRespondWith` [json|{ "name": "Ruby", "rank": 11 }|] { matchHeaders = [matchContentTypeSingular] }      context "with a camel case pk column" $ do-      it "works with POST and merge-duplicates/ignore-duplicates headers" $ do-        request methodPost "/UnitTest" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]-          [json| [-            { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" },-            { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" }-          ]|] `shouldRespondWith` [json|[-            { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" },-            { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" }-          ]|]-          { matchStatus = 201-          , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson]-          }-        request methodPost "/UnitTest" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]-          [json| [-            { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" },-            { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" }-          ]|] `shouldRespondWith` [json|[]|]-          { matchStatus = 201-          , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson]-          }+      it "works with POST and merge-duplicates" $ do+        request methodPost "/UnitTest"+            [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]+            [json|[+              { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" },+              { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" }+            ]|]+          `shouldRespondWith`+            [json|[+              { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" },+              { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" }+            ]|]+            { matchStatus = 201+            , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates"]+            } +      it "works with POST and ignore-duplicates headers" $ do+        request methodPost "/UnitTest"+            [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]+            [json|[+              { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" },+              { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" }+            ]|]+          `shouldRespondWith`+            [json|[+              { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" }+            ]|]+            { matchStatus = 201+            , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates"]+            }+       it "works with PUT" $ do-        put "/UnitTest?idUnitTest=eq.1" [str| [ { "idUnitTest": 1, "nameUnitTest": "unit test 1" } ]|] `shouldRespondWith` 204+        put "/UnitTest?idUnitTest=eq.1" [json| [ { "idUnitTest": 1, "nameUnitTest": "unit test 1" } ]|] `shouldRespondWith` 204         get "/UnitTest?idUnitTest=eq.1" `shouldRespondWith`-          [json| [ { "idUnitTest": 1, "nameUnitTest": "unit test 1" } ]|] { matchHeaders = [matchContentTypeJson] }+          [json| [ { "idUnitTest": 1, "nameUnitTest": "unit test 1" } ]|]
test/Main.hs view
@@ -1,25 +1,25 @@ module Main where +import qualified Data.Aeson                 as JSON import qualified Hasql.Pool                 as P import qualified Hasql.Transaction.Sessions as HT -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       (pgVersion95, pgVersion96)-import Protolude             hiding (toList, toS)-import Protolude.Conv        (toS)+import PostgREST.App              (postgrest)+import PostgREST.Config           (AppConfig (..), LogLevel (..))+import PostgREST.Config.Database  (queryPgVersion)+import PostgREST.Config.PgVersion (pgVersion96)+import PostgREST.DbStructure      (queryDbStructure)+import Protolude                  hiding (toList, toS)+import Protolude.Conv             (toS) import SpecHelper +import qualified PostgREST.AppState as AppState+ import qualified Feature.AndOrParamsSpec import qualified Feature.AsymmetricJwtSpec import qualified Feature.AudienceJwtSecretSpec@@ -28,161 +28,200 @@ import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec+import qualified Feature.DisabledOpenApiSpec import qualified Feature.EmbedDisambiguationSpec import qualified Feature.ExtraSearchPathSpec import qualified Feature.HtmlRawOutputSpec+import qualified Feature.IgnorePrivOpenApiSpec import qualified Feature.InsertSpec import qualified Feature.JsonOperatorSpec import qualified Feature.MultipleSchemaSpec import qualified Feature.NoJwtSpec import qualified Feature.NonexistentSchemaSpec-import qualified Feature.PgVersion95Spec-import qualified Feature.PgVersion96Spec+import qualified Feature.OpenApiSpec+import qualified Feature.OptionsSpec import qualified Feature.ProxySpec import qualified Feature.QueryLimitedSpec import qualified Feature.QuerySpec import qualified Feature.RangeSpec import qualified Feature.RawOutputTypesSpec+import qualified Feature.RollbackSpec import qualified Feature.RootSpec+import qualified Feature.RpcPreRequestGucsSpec import qualified Feature.RpcSpec import qualified Feature.SingularSpec-import qualified Feature.StructureSpec import qualified Feature.UnicodeSpec+import qualified Feature.UpdateSpec import qualified Feature.UpsertSpec   main :: IO () main = do-  getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }--  testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test"+  testDbConn <- getEnvVarWithDefault "PGRST_DB_URI" "postgres://postgrest_test@localhost/postgrest_test"    pool <- P.acquire (3, 10, toS testDbConn) -  actualPgVersion <- either (panic.show) id <$> P.use pool getPgVersion+  actualPgVersion <- either (panic.show) id <$> P.use pool queryPgVersion -  refDbStructure <- (newIORef . Just) =<< setupDbStructure pool (configSchemas $ testCfg testDbConn) actualPgVersion+  baseDbStructure <-+    loadDbStructure pool+      (configDbSchemas $ testCfg testDbConn)+      (configDbExtraSearchPath $ testCfg testDbConn)    let     -- For tests that run with the same refDbStructure-    app cfg = return ((), postgrest (cfg testDbConn) refDbStructure pool getTime $ pure ())+    app cfg = do+      let config = cfg testDbConn+      appState <- AppState.initWithPool pool config+      AppState.putPgVersion appState actualPgVersion+      AppState.putDbStructure appState baseDbStructure+      when (isJust $ configDbRootSpec config) $+        AppState.putJsonDbS appState $ toS $ JSON.encode baseDbStructure+      return ((), postgrest LogCrit appState $ pure ())      -- 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 config = cfg testDbConn+      customDbStructure <-+        loadDbStructure pool+          (configDbSchemas config)+          (configDbExtraSearchPath config)+      appState <- AppState.initWithPool pool config+      AppState.putDbStructure appState customDbStructure+      when (isJust $ configDbRootSpec config) $+        AppState.putJsonDbS appState $ toS $ JSON.encode baseDbStructure+      return ((), postgrest LogCrit appState $ pure ())    let withApp              = app testCfg       maxRowsApp           = app testMaxRowsCfg+      disabledOpenApi      = app testDisabledOpenApiCfg       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+      disallowRollbackApp  = app testCfgDisallowRollback+      forceRollbackApp     = app testCfgForceRollback +      extraSearchPathApp   = appDbs testCfgExtraSearchPath       unicodeApp           = appDbs testUnicodeCfg       nonexistentSchemaApp = appDbs testNonexistentSchemaCfg       multipleSchemaApp    = appDbs testMultipleSchemaCfg+      ignorePrivOpenApi    = appDbs testIgnorePrivOpenApiCfg -  let reset, analyze :: IO ()-      reset = resetDb testDbConn+  let analyze :: IO ()       analyze = do         analyzeTable testDbConn "items"         analyzeTable testDbConn "child_entities" -      extraSpecs =-        [("Feature.UpsertSpec", Feature.UpsertSpec.spec) | actualPgVersion >= pgVersion95] ++-        [("Feature.PgVersion95Spec", Feature.PgVersion95Spec.spec) | actualPgVersion >= pgVersion95]-       specs = uncurry describe <$> [-          ("Feature.AuthSpec"                , Feature.AuthSpec.spec actualPgVersion)-        , ("Feature.RawOutputTypesSpec"      , Feature.RawOutputTypesSpec.spec)+          ("Feature.AndOrParamsSpec"         , Feature.AndOrParamsSpec.spec actualPgVersion)+        , ("Feature.AuthSpec"                , Feature.AuthSpec.spec actualPgVersion)         , ("Feature.ConcurrentSpec"          , Feature.ConcurrentSpec.spec)         , ("Feature.CorsSpec"                , Feature.CorsSpec.spec)+        , ("Feature.DeleteSpec"              , Feature.DeleteSpec.spec)+        , ("Feature.EmbedDisambiguationSpec" , Feature.EmbedDisambiguationSpec.spec)+        , ("Feature.InsertSpec"              , Feature.InsertSpec.spec actualPgVersion)         , ("Feature.JsonOperatorSpec"        , Feature.JsonOperatorSpec.spec actualPgVersion)+        , ("Feature.OpenApiSpec"             , Feature.OpenApiSpec.spec)+        , ("Feature.OptionsSpec"             , Feature.OptionsSpec.spec)         , ("Feature.QuerySpec"               , Feature.QuerySpec.spec actualPgVersion)-        , ("Feature.EmbedDisambiguationSpec" , Feature.EmbedDisambiguationSpec.spec)+        , ("Feature.RawOutputTypesSpec"      , Feature.RawOutputTypesSpec.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.SingularSpec"           , Feature.SingularSpec.spec)+        , ("Feature.SingularSpec"            , Feature.SingularSpec.spec)+        , ("Feature.UpdateSpec"              , Feature.UpdateSpec.spec)+        , ("Feature.UpsertSpec"              , Feature.UpsertSpec.spec)         ]    hspec $ do-    -- 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+    mapM_ (parallel . before withApp) specs      -- we analyze to get accurate results from EXPLAIN-    beforeAll_ analyze . before withApp $+    parallel $ beforeAll_ analyze . before withApp $       describe "Feature.RangeSpec" Feature.RangeSpec.spec      -- this test runs with a raw-output-media-types set to text/html-    before htmlRawOutputApp $+    parallel $ before htmlRawOutputApp $       describe "Feature.HtmlRawOutputSpec" Feature.HtmlRawOutputSpec.spec      -- this test runs with a different server flag-    before maxRowsApp $+    parallel $ before maxRowsApp $       describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec      -- this test runs with a different schema-    before unicodeApp $+    parallel $ before unicodeApp $       describe "Feature.UnicodeSpec" Feature.UnicodeSpec.spec +    -- this test runs with openapi-mode set to disabled+    parallel $ before disabledOpenApi $+      describe "Feature.DisabledOpenApiSpec" Feature.DisabledOpenApiSpec.spec++    -- this test runs with openapi-mode set to ignore-acl+    parallel $ before ignorePrivOpenApi $+      describe "Feature.IgnorePrivOpenApiSpec" Feature.IgnorePrivOpenApiSpec.spec+     -- this test runs with a proxy-    before proxyApp $+    parallel $ before proxyApp $       describe "Feature.ProxySpec" Feature.ProxySpec.spec      -- this test runs without a JWT secret-    before noJwtApp $+    parallel $ before noJwtApp $       describe "Feature.NoJwtSpec" Feature.NoJwtSpec.spec      -- this test runs with a binary JWT secret-    before binaryJwtApp $+    parallel $ before binaryJwtApp $       describe "Feature.BinaryJwtSecretSpec" Feature.BinaryJwtSecretSpec.spec      -- this test runs with a binary JWT secret and an audience claim-    before audJwtApp $+    parallel $ before audJwtApp $       describe "Feature.AudienceJwtSecretSpec" Feature.AudienceJwtSecretSpec.spec      -- this test runs with asymmetric JWK-    before asymJwkApp $+    parallel $ before asymJwkApp $       describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec      -- this test runs with asymmetric JWKSet-    before asymJwkSetApp $+    parallel $ before asymJwkSetApp $       describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec      -- this test runs with a nonexistent db-schema-    before nonexistentSchemaApp $+    parallel $ before nonexistentSchemaApp $       describe "Feature.NonexistentSchemaSpec" Feature.NonexistentSchemaSpec.spec      -- this test runs with an extra search path-    before extraSearchPathApp $+    parallel $ before extraSearchPathApp $       describe "Feature.ExtraSearchPathSpec" Feature.ExtraSearchPathSpec.spec -    -- this test runs with a root spec function override     when (actualPgVersion >= pgVersion96) $ do-      before rootSpecApp $+      -- this test runs with a root spec function override+      parallel $ before rootSpecApp $         describe "Feature.RootSpec" Feature.RootSpec.spec-      before responseHeadersApp $-        describe "Feature.PgVersion96Spec" Feature.PgVersion96Spec.spec+      parallel $ before responseHeadersApp $+        describe "Feature.RpcPreRequestGucsSpec" Feature.RpcPreRequestGucsSpec.spec      -- this test runs with multiple schemas-    before multipleSchemaApp $+    parallel $ before multipleSchemaApp $       describe "Feature.MultipleSchemaSpec" $ Feature.MultipleSchemaSpec.spec actualPgVersion +    -- Note: the rollback tests can not run in parallel, because they test persistance and+    -- this results in race conditions++    -- this test runs with tx-rollback-all = true and tx-allow-override = true+    before withApp $+      describe"Feature.RollbackAllowedSpec" Feature.RollbackSpec.allowed++    -- this test runs with tx-rollback-all = false and tx-allow-override = false+    before disallowRollbackApp $+      describe "Feature.RollbackDisallowedSpec" Feature.RollbackSpec.disallowed++    -- this test runs with tx-rollback-all = true and tx-allow-override = false+    before forceRollbackApp $+      describe "Feature.RollbackForcedSpec" Feature.RollbackSpec.forced+   where-    setupDbStructure pool schemas ver =-      either (panic.show) id <$> P.use pool (HT.transaction HT.ReadCommitted HT.Read $ getDbStructure (toList schemas) ver)+    loadDbStructure pool schemas extraSearchPath =+      either (panic.show) id <$> P.use pool (HT.transaction HT.ReadCommitted HT.Read $ queryDbStructure (toList schemas) extraSearchPath True)
test/QueryCost.hs view
@@ -1,75 +1,85 @@ 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           Control.Lens                      ((^?))+import qualified Data.Aeson.Lens                   as L+import qualified Hasql.Decoders                    as HD+import qualified Hasql.DynamicStatements.Snippet   as H+import qualified Hasql.DynamicStatements.Statement as H+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, toS) import Protolude.Conv (toS) -import PostgREST.QueryBuilder (requestToCallProcQuery)-import PostgREST.Types+import PostgREST.Query.QueryBuilder (requestToCallProcQuery)+import PostgREST.Request.ApiRequest (PayloadJSON (..)) +import PostgREST.DbStructure.Identifiers+import PostgREST.DbStructure.Proc+import PostgREST.Request.Preferences+ import SpecHelper (getEnvVarWithDefault)  import Test.Hspec  main :: IO () main = do-  testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test"+  testDbConn <- getEnvVarWithDefault "PGRST_DB_URI" "postgres://postgrest_test@localhost/postgrest_test"   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 []+        cost <- exec pool $+          requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False]+          (Just $ RawJSON [str| {"id": 3} |]) 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 []+        cost <- exec pool $+          requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] Nothing 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 []+        cost <- exec pool $+          requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False]+          (Just $ RawJSON [str| {"a": 3, "b": 4} |]) 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) []+          cost <- exec pool $+            requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False]+            (Just $ RawJSON [str| [{"id": 1}, {"id": 4}] |]) False (Just MultipleObjects) []           liftIO $ do+            -- lower bound needed for now to make sure that cost is not Nothing             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 []+          cost <- exec pool $+            requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False]+            (Just $ RawJSON [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |]) True Nothing []           liftIO $             cost `shouldSatisfy` (< Just 10)  -exec :: P.Pool -> ByteString -> SqlQuery -> IO (Maybe Int64)-exec pool input query =+exec :: P.Pool -> H.Snippet -> IO (Maybe Int64)+exec pool query =   join . rightToMaybe <$>-  P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement input $ explainCost query)+  P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement mempty $ explainCost query) -explainCost :: SqlQuery -> H.Statement ByteString (Maybe Int64)+explainCost :: H.Snippet -> H.Statement () (Maybe Int64) explainCost query =-  H.Statement (encodeUtf8 sql) (HE.param $ HE.nonNullable HE.unknown) decodeExplain False+  H.dynamicallyParameterized snippet decodeExplain False  where-   sql = "EXPLAIN (FORMAT JSON) " <> query+   snippet = "EXPLAIN (FORMAT JSON) " <> query    decodeExplain :: HD.Result (Maybe Int64)    decodeExplain =      let row = HD.singleRow $ HD.column $ HD.nonNullable HD.bytea in
test/SpecHelper.hs view
@@ -8,7 +8,7 @@ import qualified System.IO.Error        as E  import Data.Aeson           (Value (..), decode, encode)-import Data.CaseInsensitive (CI (..))+import Data.CaseInsensitive (CI (..), original) import Data.List            (lookup) import Data.List.NonEmpty   (fromList) import Network.Wai.Test     (SResponse (simpleBody, simpleHeaders, simpleStatus))@@ -22,10 +22,14 @@ import Test.Hspec.Wai import Text.Heredoc -import PostgREST.Config (AppConfig (..))-import PostgREST.Types  (JSPathExp (..))-import Protolude        hiding (toS)-import Protolude.Conv   (toS)+import PostgREST.Config                  (AppConfig (..),+                                          JSPathExp (..),+                                          LogLevel (..),+                                          OpenAPIMode (..),+                                          parseSecret)+import PostgREST.DbStructure.Identifiers (QualifiedIdentifier (..))+import Protolude                         hiding (toS)+import Protolude.Conv                    (toS)  matchContentTypeJson :: MatchHeader matchContentTypeJson = "Content-Type" <:> "application/json; charset=utf-8"@@ -33,6 +37,12 @@ matchContentTypeSingular :: MatchHeader matchContentTypeSingular = "Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8" +matchHeaderAbsent :: HeaderName -> MatchHeader+matchHeaderAbsent name = MatchHeader $ \headers _body ->+  case lookup name headers of+    Just _  -> Just $ "unexpected header: " <> toS (original name) <> "\n"+    Nothing -> Nothing+ validateOpenApiResponse :: [Header] -> WaiSession () () validateOpenApiResponse headers = do   r <- request methodGet "/" headers ""@@ -63,87 +73,117 @@   getEnv (toS var) `E.catchIOError` const (return $ toS def)  _baseCfg :: AppConfig-_baseCfg =  -- Connection Settings-  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-            10 10 Nothing (Just "test.switch_role")-            -- Debug Settings-            True-            [ ("app.settings.app_host", "localhost")-            , ("app.settings.external_api_secret", "0123456789abcdef")-            ]-            -- Default role claim key-            (Right [JSPKey "role"])-            -- Empty db-extra-search-path-            []-            -- No root spec override-            Nothing-            -- Raw output media types-            []+_baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in+  AppConfig {+    configAppSettings           = [ ("app.settings.app_host", "localhost") , ("app.settings.external_api_secret", "0123456789abcdef") ]+  , configDbAnonRole            = "postgrest_test_anonymous"+  , configDbChannel             = mempty+  , configDbChannelEnabled      = True+  , configDbExtraSearchPath     = []+  , configDbMaxRows             = Nothing+  , configDbPoolSize            = 10+  , configDbPoolTimeout         = 10+  , configDbPreRequest          = Just $ QualifiedIdentifier "test" "switch_role"+  , configDbPreparedStatements  = True+  , configDbRootSpec            = Nothing+  , configDbSchemas             = fromList ["test"]+  , configDbConfig              = False+  , configDbUri                 = mempty+  , configFilePath              = Nothing+  , configJWKS                  = parseSecret <$> secret+  , configJwtAudience           = Nothing+  , configJwtRoleClaimKey       = [JSPKey "role"]+  , configJwtSecret             = secret+  , configJwtSecretIsBase64     = False+  , configLogLevel              = LogCrit+  , configOpenApiMode           = OAFollowPriv+  , configOpenApiServerProxyUri = Nothing+  , configRawMediaTypes         = []+  , configServerHost            = "localhost"+  , configServerPort            = 3000+  , configServerUnixSocket      = Nothing+  , configServerUnixSocketMode  = 432+  , configDbTxAllowOverride     = True+  , configDbTxRollbackAll       = True+  }  testCfg :: Text -> AppConfig-testCfg testDbConn = _baseCfg { configDatabase = testDbConn }+testCfg testDbConn = _baseCfg { configDbUri = testDbConn } +testCfgDisallowRollback :: Text -> AppConfig+testCfgDisallowRollback testDbConn = (testCfg testDbConn) { configDbTxAllowOverride = False, configDbTxRollbackAll = False }++testCfgForceRollback :: Text -> AppConfig+testCfgForceRollback testDbConn = (testCfg testDbConn) { configDbTxAllowOverride = False, configDbTxRollbackAll = True }+ testCfgNoJWT :: Text -> AppConfig-testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing }+testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing, configJWKS = Nothing }  testUnicodeCfg :: Text -> AppConfig-testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["تست"] }+testUnicodeCfg testDbConn = (testCfg testDbConn) { configDbSchemas = fromList ["تست"] }  testMaxRowsCfg :: Text -> AppConfig-testMaxRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 }+testMaxRowsCfg testDbConn = (testCfg testDbConn) { configDbMaxRows = Just 2 } +testDisabledOpenApiCfg :: Text -> AppConfig+testDisabledOpenApiCfg testDbConn = (testCfg testDbConn) { configOpenApiMode = OADisabled }++testIgnorePrivOpenApiCfg :: Text -> AppConfig+testIgnorePrivOpenApiCfg testDbConn = (testCfg testDbConn) { configOpenApiMode = OAIgnorePriv, configDbSchemas = fromList ["test", "v1"] }+ testProxyCfg :: Text -> AppConfig-testProxyCfg testDbConn = (testCfg testDbConn) { configOpenAPIProxyUri = Just "https://postgrest.com/openapi.json" }+testProxyCfg testDbConn = (testCfg testDbConn) { configOpenApiServerProxyUri = Just "https://postgrest.com/openapi.json" }  testCfgBinaryJWT :: Text -> AppConfig-testCfgBinaryJWT testDbConn = (testCfg testDbConn) {-    configJwtSecret = Just . B64.decodeLenient $-      "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU="+testCfgBinaryJWT testDbConn =+  let secret = Just . B64.decodeLenient $ "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU=" in+  (testCfg testDbConn) {+    configJwtSecret = secret+  , configJWKS = parseSecret <$> secret   }  testCfgAudienceJWT :: Text -> AppConfig-testCfgAudienceJWT testDbConn = (testCfg testDbConn) {-    configJwtSecret = Just . B64.decodeLenient $-      "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU=",-    configJwtAudience = Just "youraudience"+testCfgAudienceJWT testDbConn =+  let secret = Just . B64.decodeLenient $ "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU=" in+  (testCfg testDbConn) {+    configJwtSecret = secret+  , configJwtAudience = Just "youraudience"+  , configJWKS = parseSecret <$> secret   }  testCfgAsymJWK :: Text -> AppConfig-testCfgAsymJWK testDbConn = (testCfg testDbConn) {-    configJwtSecret = Just $ encodeUtf8-      [str|{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}|]+testCfgAsymJWK testDbConn =+  let secret = Just $ encodeUtf8 [str|{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}|]+  in (testCfg testDbConn) {+    configJwtSecret = secret+  , configJWKS = parseSecret <$> secret   }  testCfgAsymJWKSet :: Text -> AppConfig-testCfgAsymJWKSet testDbConn = (testCfg testDbConn) {-    configJwtSecret = Just $ encodeUtf8-      [str|{"keys": [{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}]}|]+testCfgAsymJWKSet testDbConn =+  let secret = Just $ encodeUtf8 [str|{"keys": [{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}]}|]+  in (testCfg testDbConn) {+    configJwtSecret = secret+  , configJWKS = parseSecret <$> secret   }  testNonexistentSchemaCfg :: Text -> AppConfig-testNonexistentSchemaCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["nonexistent"] }+testNonexistentSchemaCfg testDbConn = (testCfg testDbConn) { configDbSchemas = fromList ["nonexistent"] }  testCfgExtraSearchPath :: Text -> AppConfig-testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configExtraSearchPath = ["public", "extensions"] }+testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configDbExtraSearchPath = ["public", "extensions"] }  testCfgRootSpec :: Text -> AppConfig-testCfgRootSpec testDbConn = (testCfg testDbConn) { configRootSpec = Just "root"}+testCfgRootSpec testDbConn = (testCfg testDbConn) { configDbRootSpec = Just $ QualifiedIdentifier mempty "root"}  testCfgHtmlRawOutput :: Text -> AppConfig testCfgHtmlRawOutput testDbConn = (testCfg testDbConn) { configRawMediaTypes = ["text/html"] }  testCfgResponseHeaders :: Text -> AppConfig-testCfgResponseHeaders testDbConn = (testCfg testDbConn) { configReqCheck = Just "custom_headers" }+testCfgResponseHeaders testDbConn = (testCfg testDbConn) { configDbPreRequest = Just $ QualifiedIdentifier mempty "custom_headers" }  testMultipleSchemaCfg :: Text -> AppConfig-testMultipleSchemaCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["v1", "v2"] }+testMultipleSchemaCfg testDbConn = (testCfg testDbConn) { configDbSchemas = fromList ["v1", "v2"] }  resetDb :: Text -> IO () resetDb dbConn = loadFixture dbConn "data"@@ -178,15 +218,18 @@ noProfileHeader :: [Header] -> Bool noProfileHeader headers = isNothing $ find ((== "Content-Profile") . fst) headers +authHeader :: BS.ByteString -> BS.ByteString -> Header+authHeader typ creds =+  (hAuthorization, typ <> " " <> creds)+ authHeaderBasic :: BS.ByteString -> BS.ByteString -> Header authHeaderBasic u p =-  (hAuthorization, "Basic " <> (toS . B64.encode . toS $ u <> ":" <> p))+  authHeader "Basic" $ toS . B64.encode . toS $ u <> ":" <> p  authHeaderJWT :: BS.ByteString -> Header-authHeaderJWT token =-  (hAuthorization, "Bearer " <> token)+authHeaderJWT = authHeader "Bearer" --- | Tests whether the text can be parsed as a json object comtaining+-- | Tests whether the text can be parsed as a json object containing -- the key "message", and optional keys "details", "hint", "code", -- and no extraneous keys isErrorFormat :: BL.ByteString -> Bool