Bump to v0.5.0.0

Appveyor failed on latest release https://ci.appveyor.com/project/begriffs/postgrest/build/1.0.5
according to https://github.com/commercialhaskell/stack/issues/2617#issuecomment-271966495
this can be fixed by adding `-j1`.

.circleci/config.yml

@@ -53,7 +53,14 @@ build-distro-bin: &build-distro-bin
 
 jobs:
   build-test:
-    machine: true
+    docker:
+      - image: circleci/buildpack-deps:trusty
+        environment:
+          - PGHOST=localhost
+      - image: circleci/postgres:9.4.14
+        environment:
+          - POSTGRES_USER=circleci
+          - POSTGRES_DB=circleci
     steps:
       - checkout
       - restore_cache:
@@ -65,8 +72,9 @@ jobs:
             curl -L https://github.com/commercialhaskell/stack/releases/download/v1.1.2/stack-1.1.2-linux-x86_64.tar.gz | tar zx -C /tmp
             sudo mv /tmp/stack-1.1.2-linux-x86_64/stack /usr/bin
             sudo apt-get update
-            sudo apt-get install libgmp-dev
-            sudo apt-get install --only-upgrade binutils
+            sudo apt-get install -y libgmp-dev
+            sudo apt-get install -y --only-upgrade binutils
+            sudo apt-get install -y postgresql-client
             stack setup
             rm -rf $(stack path --dist-dir) $(stack path --local-install-root)
             stack install hlint packdeps cabal-install
@@ -78,7 +86,6 @@ jobs:
       - run:
           name: run tests
           command: |
-            sudo service postgresql start
             POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://circleci@localhost" postgrest_test) stack test
             test/io-tests.sh
       - run:
@@ -99,6 +106,82 @@ jobs:
             - ".stack-work"
           key: v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
 
+  build-test-9.6:
+    docker:
+      - image: circleci/buildpack-deps:trusty
+        environment:
+          - PGHOST=localhost
+      - image: circleci/postgres:9.6.2
+        environment:
+          - POSTGRES_USER=circleci
+          - POSTGRES_DB=circleci
+    steps:
+      - checkout
+      - restore_cache:
+          keys:
+          - v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
+      - run:
+          name: install stack & dependencies
+          command: |
+            curl -L https://github.com/commercialhaskell/stack/releases/download/v1.1.2/stack-1.1.2-linux-x86_64.tar.gz | tar zx -C /tmp
+            sudo mv /tmp/stack-1.1.2-linux-x86_64/stack /usr/bin
+            sudo apt-get update
+            sudo apt-get install -y libgmp-dev
+            sudo apt-get install -y postgresql-client
+            stack setup
+      - run:
+          name: build src and tests
+          command: |
+            stack build --fast -j1
+            stack build --fast --test --no-run-tests
+      - run:
+          name: run tests
+          command: POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://circleci@localhost" postgrest_test) stack test
+
+  build-prof-test:
+    docker:
+      - image: circleci/buildpack-deps:trusty
+        environment:
+          - PGHOST=localhost
+          - TERM=xterm
+      - image: circleci/postgres:9.6.2
+        environment:
+          - POSTGRES_USER=circleci
+          - POSTGRES_DB=circleci
+    steps:
+      - checkout
+      - restore_cache:
+          keys:
+          - v1-stack-prof-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
+      - run:
+          name: install stack & dependencies
+          command: |
+            curl -L https://github.com/commercialhaskell/stack/releases/download/v1.1.2/stack-1.1.2-linux-x86_64.tar.gz | tar zx -C /tmp
+            sudo mv /tmp/stack-1.1.2-linux-x86_64/stack /usr/bin
+            sudo apt-get update
+            sudo apt-get install -y libgmp-dev
+            sudo apt-get install -y postgresql-client
+            stack setup
+      - run:
+          name: build with profiling enabled
+          command: |
+            stack build --profile -j1
+      - run:
+          name: run memory usage tests
+          command: |
+            test/create_test_db "postgres://circleci@localhost" postgrest_test
+            psql "postgres:///postgrest_test" -f test/fixtures/database.sql
+            psql "postgres:///postgrest_test" -f test/fixtures/roles.sql
+            psql "postgres:///postgrest_test" -f test/fixtures/schema.sql
+            psql "postgres:///postgrest_test" -f test/fixtures/jwt.sql
+            psql "postgres:///postgrest_test" -f test/fixtures/privileges.sql
+            test/memory-tests.sh
+      - save_cache:
+          paths:
+            - "~/.stack"
+            - ".stack-work"
+          key: v1-stack-prof-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
+
   centos6:
     <<: *build-distro-bin
 
@@ -145,9 +228,19 @@ workflows:
           filters:
             tags:
               only: /v[0-9]+(\.[0-9]+)*/
+      - build-test-9.6:
+          filters:
+            tags:
+              only: /v[0-9]+(\.[0-9]+)*/
+      - build-prof-test:
+          filters:
+            tags:
+              only: /v[0-9]+(\.[0-9]+)*/
       - centos6:
           requires:
             - build-test
+            - build-test-9.6
+            - build-prof-test
           filters:
             tags:
               only: /v[0-9]+(\.[0-9]+)*/
@@ -156,6 +249,8 @@ workflows:
       - centos7:
           requires:
             - build-test
+            - build-test-9.6
+            - build-prof-test
           filters:
             tags:
               only: /v[0-9]+(\.[0-9]+)*/
@@ -164,6 +259,8 @@ workflows:
       - ubuntu:
           requires:
             - build-test
+            - build-test-9.6
+            - build-prof-test
           filters:
             tags:
               only: /v[0-9]+(\.[0-9]+)*/
@@ -172,6 +269,8 @@ workflows:
       - ubuntui386:
           requires:
             - build-test
+            - build-test-9.6
+            - build-prof-test
           filters:
             tags:
               only: /v[0-9]+(\.[0-9]+)*/

.github/CONTRIBUTING.md

@@ -51,18 +51,7 @@ your contributions.
 source](https://postgrest.com/en/stable/install.html#build-from-source)
 wiki page.
 
-## Maintenance
-
-### Schedule
-
-Currently I (@begriffs) am the sole maintainer, and while I am
-overjoyed to help resolve issues I also have to balance this with
-my other obligations.  If you don't get a response right away
-don't worry, I will definitely get to it. Also you can join the
-Gitter [chat room](https://gitter.im/begriffs/postgrest) to
-discuss issues you are having.
-
-## Running Tests
+### Running Tests
 
 For instructions on running tests, see the official docs hosted here:
 

.github/ISSUE_TEMPLATE.md

@@ -0,0 +1,11 @@
+### Environment
+
+* Version of postgrest:
+* Operating system:
+* Running in docker:
+  * [ ] yes
+  * [ ] no
+
+### Description of issue
+
+(Expected behavior vs actual behavior.)

CHANGELOG.md

@@ -9,6 +9,62 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ### Fixed
 
+### Changed
+
+## [0.5.0.0] - 2018-05-14
+
+### Added
+
+- The configuration (e.g. `postgrest.conf`) now accepts arbitrary settings that will be passed through as session-local database settings. This can be used to pass in secret keys directly as strings, or via OS environment variables. For instance: `app.settings.jwt_secret = "$(MYAPP_JWT_SECRET)"` will take `MYAPP_JWT_SECRET` from the environment and make it available to postgresql functions as `current_setting('app.settings.jwt_secret')`. Only `app.settings.*` values in the configuration file are treated in this way. - @canadaduane
+- #256, Add support for bulk UPSERT with POST and single UPSERT with PUT - @steve-chavez
+- #1078, Add ability to specify source column in embed - @steve-chavez
+- #821, Allow embeds alias to be used in filters - @steve-chavez
+- #906, Add jspath configurable `role-claim-key` - @steve-chavez
+- #1061, Add foreign tables to OpenAPI output - @rhyamada
+
+### Fixed
+
+- #828, Fix computed column only working in public schema - @steve-chavez
+- #925, Fix RPC high memory usage by using parametrized query and avoiding json encoding - @steve-chavez
+- #987, Fix embedding with self-reference foreign key - @steve-chavez
+- #1044, Fix view parent embedding when having many views - @steve-chavez
+- #781, Fix accepting misspelled desc/asc ordering modificators - @onporat, @steve-chavez
+
+### Changed
+
+- Computed columns now only work if they belong to the db-schema - @steve-chavez
+- To use RPC now the `json_to_record/json_to_recordset` functions are needed, these are available starting from PostgreSQL 9.4 - @steve-chavez
+- Overloaded functions now depend on the `dbStructure`, restart/sighup may be needed for their correct functioning - @steve-chavez
+- #1098, Removed support for:
+  + curly braces `{}` in embeds, i.e. `/clients?select=*,projects{*}` can no longer be used, from now on parens `()` should be used `/clients?select=*,projects(*)` - @steve-chavez
+  + "in" operator without parens, i.e. `/clients?id=in.1,2,3` no longer supported, `/clients?id=in.(1,2,3)` should be used - @steve-chavez
+  + "@@", "@>" and "<@" operators, from now on their mnemonic equivalents should be used "fts", "cs" and "cd" respectively - @steve-chavez
+
+## [0.4.4.0] - 2018-01-08
+
+### Added
+
+- #887, #601, #1007, Allow specifying dictionary and plain/phrase tsquery in full text search - @steve-chavez
+- #328, Allow doing GET on rpc - @steve-chavez
+- #917, Add ability to map RAISE errorcode/message to http status - @steve-chavez
+- #940, Add ability to map GUC to http response headers - @steve-chavez
+- #1022, Include git sha in version report - @begriffs
+- Faster queries using json_agg - @ruslantalpa
+
+### Fixed
+
+- #876, Read secret files as binary, discard final LF if any - @eric-brechemier
+- #968, Treat blank proxy uri as missing - @begriffs
+- #933, OpenAPI externals docs url to current version - @steve-chavez
+- #962, OpenAPI don't err on nonexistent schema - @steve-chavez
+- #954, make OpenAPI rpc output dependent on user privileges - @steve-chavez
+- #955, Support configurable aud claim - @statik
+- #996, Fix embedded column conflicts table name - @grotsev
+- #974, Fix RPC error when function has single OUT param - @steve-chavez
+- #1021, Reduce join size in allColumns for faster program start - @nextstopsun
+- #411, Remove the need for pk in &select for parent embed - @steve-chavez
+- #1016, Fix anonymous requests when configured with jwt-aud - @ruslantalpa
+
 ## [0.4.3.0] - 2017-09-06
 
 ### Added

README.md

@@ -1,11 +1,13 @@
 ![Logo](static/logo.png "Logo")
 
-[![Build Status](https://circleci.com/gh/begriffs/postgrest.png?style=shield&circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2)](https://circleci.com/gh/begriffs/postgrest/tree/master)
-<a href="https://heroku.com/deploy?template=https://github.com/begriffs/postgrest">
+[![Build Status](https://circleci.com/gh/PostgREST/postgrest/tree/master.svg?style=shield)](https://circleci.com/gh/PostgREST/postgrest/tree/master)
+<a href="https://heroku.com/deploy?template=https://github.com/PostgREST/postgrest">
   <img src="https://img.shields.io/badge/%E2%86%91_Deploy_to-Heroku-7056bf.svg" alt="Deploy">
 </a>
 [![Join the chat at https://gitter.im/begriffs/postgrest](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%92-brightgreen.svg)](https://gitter.im/begriffs/postgrest)
-[![Docs](https://img.shields.io/badge/docs-latest-brightgreen.svg?style=flat)](http://postgrest.com)
+[![Docs](https://img.shields.io/badge/docs-latest-brightgreen.svg?style=flat)](http://postgrest.org)
+[![Docker Stars](https://img.shields.io/docker/pulls/postgrest/postgrest.svg)](https://hub.docker.com/r/postgrest/postgrest/)
+[![Donate](https://img.shields.io/badge/patreon-donate-orange.svg?colorB=F96854)](https://www.patreon.com/postgrest)
 
 PostgREST serves a fully RESTful API from any existing PostgreSQL
 database. It provides a cleaner, more standards-compliant, faster
@@ -13,7 +15,7 @@ API than you are likely to write from scratch.
 
 ### Usage
 
-1. Download the binary ([latest release](https://github.com/begriffs/postgrest/releases/latest))
+1. Download the binary ([latest release](https://github.com/PostgREST/postgrest/releases/latest))
    for your platform.
 2. Invoke for help:
 
@@ -49,13 +51,10 @@ by
 * Using the PostgreSQL binary protocol
 * Being stateless to allow horizontal scaling
 
-Other optimizations are possible, and some are outlined in the
-[Future Features](#future-features).
-
 ### Security
 
 PostgREST [handles
-authentication](http://postgrest.com/en/stable/auth.html) (via JSON Web
+authentication](http://postgrest.org/en/stable/auth.html) (via JSON Web
 Tokens) and delegates authorization to the role information defined in
 the database. This ensures there is a single declarative source of truth
 for security.  When dealing with the database the server assumes the
@@ -105,14 +104,14 @@ surprises, such as enforcing idempotent PUT requests.
 
 See examples of [PostgreSQL
 constraints](http://www.tutorialspoint.com/postgresql/postgresql_constraints.htm)
-and the [API guide](http://postgrest.com/en/stable/api.html).
+and the [API guide](http://postgrest.org/en/stable/api.html).
 
 ### Thanks
 
-I'm grateful to the generous project
-[contributors](https://github.com/begriffs/postgrest/graphs/contributors)
+The PostgREST organization is grateful to the generous project
+[contributors](https://github.com/PostgREST/postgrest/graphs/contributors)
 who have improved PostgREST immensely with their code and good
 judgement.  See more details in the
-[changelog](https://github.com/begriffs/postgrest/blob/master/CHANGELOG.md).
+[changelog](https://github.com/PostgREST/postgrest/blob/master/CHANGELOG.md).
 
 The cool logo came from [Mikey Casalaina](https://github.com/casalaina).

app.json

@@ -2,15 +2,15 @@
   "name": "PostgREST",
   "description": "RESTful API for any PostgreSQL database.",
   "logo": "https://halcyon.sh/logo.svg",
-  "repository": "https://github.com/begriffs/postgrest",
+  "repository": "https://github.com/PostgREST/postgrest",
   "env": {
     "BUILDPACK_URL": {
       "description": "Heroku buildpack for deploying Haskell applications",
-      "value": "https://github.com/begriffs/postgrest-heroku"
+      "value": "https://github.com/PostgREST/postgrest-heroku"
     },
     "POSTGREST_VER": {
       "description": "Version of PostgREST to deploy",
-      "value": "0.4.3.0"
+      "value": "0.5.0.0"
     },
     "DB_URI": {
       "description": "Database connection string",
@@ -43,6 +43,10 @@
       "required": false,
       "value": "false"
     },
+    "JWT_AUD": {
+      "description": "The audience that should be validated if the JWT token contains an aud claim",
+      "required": false
+    },
     "MAX_ROWS": {
       "description": "A hard limit to the number of rows PostgREST will fetch from a view, table, or stored procedure",
       "required": false

appveyor.yml

@@ -28,7 +28,7 @@ install:
 
 build_script:
 - stack setup --no-terminal > nul
-- stack build --copy-bins --local-bin-path .
+- stack build -j1 --copy-bins --local-bin-path .
 
 artifacts:
 - path: postgrest.exe

docker/Dockerfile

@@ -13,7 +13,7 @@ RUN BUILD_DEPS="curl ca-certificates xz-utils" && \
     apt-get -qq update && \
     apt-get -qq install -y --no-install-recommends $BUILD_DEPS && \
     cd /tmp && \
-    curl -SLO https://github.com/begriffs/postgrest/releases/download/${POSTGREST_VERSION}/postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
+    curl -SLO https://github.com/PostgREST/postgrest/releases/download/${POSTGREST_VERSION}/postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
     tar -xJvf postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
     mv postgrest /usr/local/bin/postgrest && \
     cd / && \
@@ -30,9 +30,10 @@ ENV PGRST_DB_URI= \
     PGRST_DB_POOL=100 \
     PGRST_SERVER_HOST=*4 \
     PGRST_SERVER_PORT=3000 \
-    PGRST_SERVER_PROXY_URL= \
+    PGRST_SERVER_PROXY_URI= \
     PGRST_JWT_SECRET= \
     PGRST_SECRET_IS_BASE64=false \
+    PGRST_JWT_AUD= \
     PGRST_MAX_ROWS= \
     PGRST_PRE_REQUEST=
 

docker/postgrest.conf

@@ -9,6 +9,7 @@ server-port = "$(PGRST_SERVER_PORT)"
 server-proxy-uri = "$(PGRST_SERVER_PROXY_URI)"
 jwt-secret = "$(PGRST_JWT_SECRET)"
 secret-is-base64 = "$(PGRST_SECRET_IS_BASE64)"
+jwt-aud = "$(PGRST_JWT_AUD)"
 
 max-rows = "$(PGRST_MAX_ROWS)"
 pre-request = "$(PGRST_PRE_REQUEST)"

main/Main.hs

@@ -2,31 +2,34 @@
 
 module Main where
 
+
 import           PostgREST.App            (postgrest)
 import           PostgREST.Config         (AppConfig (..),
-                                           PgVersion (..),
                                            minimumPgVersion,
                                            prettyVersion, readOptions)
-import           PostgREST.DbStructure    (getDbStructure)
+import           PostgREST.DbStructure    (getDbStructure, getPgVersion,
+                                           fillSessionWithSettings)
 import           PostgREST.Error          (encodeError)
 import           PostgREST.OpenAPI        (isMalformedProxyUri)
-import           PostgREST.Types          (DbStructure, Schema)
-import           Protolude hiding         (replace, hPutStrLn)
+import           PostgREST.Types          (DbStructure, Schema, PgVersion(..))
+import           Protolude                hiding (hPutStrLn, replace)
 
+
+import           Control.AutoUpdate       (defaultUpdateSettings,
+                                           mkAutoUpdate, updateAction)
 import           Control.Retry            (RetryStatus, capDelay,
                                            exponentialBackoff,
                                            retrying, rsPreviousDelay)
-import           Data.ByteString.Base64   (decode)
+import qualified Data.ByteString          as BS
+import qualified Data.ByteString.Base64   as B64
 import           Data.IORef               (IORef, atomicWriteIORef,
                                            newIORef, readIORef)
 import           Data.String              (IsString (..))
 import           Data.Text                (pack, replace, stripPrefix, strip)
 import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
-import           Data.Text.IO             (hPutStrLn, readFile)
-import qualified Hasql.Decoders           as HD
-import qualified Hasql.Encoders           as HE
+import           Data.Text.IO             (hPutStrLn)
+import           Data.Time.Clock          (getCurrentTime)
 import qualified Hasql.Pool               as P
-import qualified Hasql.Query              as H
 import qualified Hasql.Session            as H
 import           Network.Wai.Handler.Warp (defaultSettings,
                                            runSettings, setHost,
@@ -34,23 +37,11 @@ import           Network.Wai.Handler.Warp (defaultSettings,
                                            setTimeout)
 import           System.IO                (BufferMode (..),
                                            hSetBuffering)
+
 #ifndef mingw32_HOST_OS
 import           System.Posix.Signals
 #endif
 
-{-|
-	Used by connectionWorker to know if it should throw an error and kill the
-  main thread.
--}
-isServerVersionSupported :: H.Session Bool
-isServerVersionSupported = do
-  ver <- H.query () pgVersion
-  return $ ver >= pgvNum minimumPgVersion
- where
-  pgVersion =
-    H.statement "SELECT current_setting('server_version_num')::integer"
-      HE.unit (HD.singleRow $ HD.value HD.int4) False
-
 {-|
   The purpose of this worker is to fill the refDbStructure created in 'main'
   with the 'DbStructure' returned from calling 'getDbStructure'. This method
@@ -70,13 +61,14 @@ isServerVersionSupported = do
      goes back to 1, otherwise it finishes his work successfully.
 -}
 connectionWorker
-  :: ThreadId -- ^ This thread is killed if 'isServerVersionSupported' returns false
+  :: ThreadId -- ^ This thread is killed if pg version is unsupported
   -> P.Pool   -- ^ The PostgreSQL connection pool
   -> Schema   -- ^ Schema PostgREST is serving up
+  -> [(Text, Text)] -- ^ Settings or Environment passed in through the config
   -> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure'
   -> IORef Bool                -- ^ Used as a binary Semaphore
   -> IO ()
-connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
+connectionWorker mainTid pool schema settings refDbStructure refIsWorkerOn = do
   isWorkerOn <- readIORef refIsWorkerOn
   unless isWorkerOn $ do
     atomicWriteIORef refIsWorkerOn True
@@ -88,13 +80,14 @@ connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
       connected <- connectingSucceeded pool
       when connected $ do
         result <- P.use pool $ do
-          supported <- isServerVersionSupported
-          unless supported $ liftIO $ do
+          actualPgVersion <- getPgVersion
+          unless (actualPgVersion >= minimumPgVersion) $ liftIO $ do
             hPutStrLn stderr
               ("Cannot run in this PostgreSQL version, PostgREST needs at least "
               <> pgvName minimumPgVersion)
             killThread mainTid
-          dbStructure <- getDbStructure schema
+          fillSessionWithSettings settings
+          dbStructure <- getDbStructure schema actualPgVersion
           liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
         case result of
           Left e -> do
@@ -105,7 +98,6 @@ connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = 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
@@ -156,18 +148,23 @@ main = do
       port = configPort conf
       proxy = configProxyUri 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)
         . setTimeout 3600 $
         defaultSettings
-  --
-  -- Checks that the provided proxy uri is formated correctly,
-  -- does not test if it works here.
+
+  -- Checks that the provided proxy uri is formated correctly
   when (isMalformedProxyUri $ toS <$> proxy) $
     panic
       "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
+
+  -- Checks that the provided jspath is valid
+  when (isLeft roleClaimKey) $
+    panic $ show roleClaimKey
+
   putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)
   --
   -- create connection pool with the provided settings, returns either
@@ -189,6 +186,7 @@ main = do
     mainTid
     pool
     (configSchema conf)
+    (configSettings conf)
     refDbStructure
     refIsWorkerOn
   --
@@ -211,22 +209,28 @@ main = do
               mainTid
               pool
               (configSchema conf)
+              (configSettings conf)
               refDbStructure
               refIsWorkerOn
     ) Nothing
 #endif
 
-  --
+
+  -- ask for the OS time at most once per second
+  getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime}
+
   -- run the postgrest application
   runSettings appSettings $
     postgrest
       conf
       refDbStructure
       pool
+      getTime
       (connectionWorker
          mainTid
          pool
          (configSchema conf)
+         (configSettings conf)
          refDbStructure
          refIsWorkerOn)
 
@@ -264,14 +268,16 @@ loadSecretFile conf = extractAndTransform mSecret
       fmap setSecret $
       transformString isB64 =<<
       case stripPrefix "@" secret of
-        Nothing       -> return secret
-        Just filename -> readFile (toS filename)
+        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 -> Text -> IO ByteString
-    transformString False t = return . encodeUtf8 $ t
+    transformString :: Bool -> ByteString -> IO ByteString
+    transformString False t = return t
     transformString True t =
-      case decode (encodeUtf8 $ strip $ replaceUrlChars t) of
+      case B64.decode $ encodeUtf8 $ strip $ replaceUrlChars $ decodeUtf8 t of
         Left errMsg -> panic $ pack errMsg
         Right bs    -> return bs
     setSecret bs = conf {configJwtSecret = Just bs}

postgrest.cabal

@@ -2,19 +2,19 @@ name:                  postgrest
 description:           Reads the schema of a PostgreSQL database and creates RESTful routes
                        for the tables and views, supporting all HTTP verbs that security
                        permits.
-version:               0.4.3.0
+version:               0.5.0.0
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
 author:                Joe Nelson, Adam Baker
-homepage:              https://github.com/begriffs/postgrest
+homepage:              https://github.com/PostgREST/postgrest
 maintainer:            cred+github@begriffs.com
 category:              Web
 build-type:            Simple
 cabal-version:         >=1.10
 source-repository head
   type: git
-  location: git://github.com/begriffs/postgrest.git
+  location: git://github.com/PostgREST/postgrest.git
 
 Flag CI
   Description: No warnings allowed in continuous integration
@@ -29,12 +29,14 @@ executable postgrest
     -rtsopts
     "-with-rtsopts=-N -I2"
   default-language:    Haskell2010
-  build-depends:       base
+  build-depends:       auto-update
+                     , base
                      , hasql
                      , hasql-pool
                      , postgrest
                      , protolude
                      , text
+                     , time
                      , warp
                      , bytestring
                      , base64-bytestring
@@ -57,10 +59,12 @@ library
                      , configurator-ng == 0.0.0.1
                      , containers
                      , contravariant
+                     , contravariant-extras
                      , either
+                     , gitrev
                      , hasql
-                     , hasql-pool == 0.4.1
-                     , hasql-transaction == 0.5
+                     , hasql-pool
+                     , hasql-transaction
                      , heredoc
                      , HTTP
                      , http-types
@@ -79,6 +83,7 @@ library
                      , scientific
                      , swagger2
                      , text
+                     , time
                      , unordered-containers
                      , vector
                      , wai
@@ -110,7 +115,8 @@ Test-Suite spec
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   Hs-Source-Dirs:      test
   Main-Is:             Main.hs
-  Other-Modules:       Feature.AuthSpec
+  Other-Modules:       Feature.AudienceJwtSecretSpec
+                     , Feature.AuthSpec
                      , Feature.AsymmetricJwtSpec
                      , Feature.BinaryJwtSecretSpec
                      , Feature.ConcurrentSpec
@@ -118,6 +124,7 @@ Test-Suite spec
                      , Feature.DeleteSpec
                      , Feature.InsertSpec
                      , Feature.NoJwtSpec
+                     , Feature.PgVersion96Spec
                      , Feature.ProxySpec
                      , Feature.QueryLimitedSpec
                      , Feature.QuerySpec
@@ -126,11 +133,15 @@ Test-Suite spec
                      , Feature.StructureSpec
                      , Feature.UnicodeSpec
                      , Feature.AndOrParamsSpec
+                     , Feature.RpcSpec
+                     , Feature.NonexistentSchemaSpec
+                     , Feature.UpsertSpec
                      , SpecHelper
                      , TestTypes
   Build-Depends:       aeson
                      , aeson-qq
                      , async
+                     , auto-update
                      , base
                      , bytestring
                      , base64-bytestring
@@ -141,7 +152,6 @@ Test-Suite spec
                      , hasql
                      , hasql-pool
                      , heredoc
-                     , hjsonpointer
                      , hjsonschema == 1.5.0.1
                      , hspec
                      , hspec-wai >= 0.7.0
@@ -154,6 +164,7 @@ Test-Suite spec
                      , process
                      , protolude
                      , regex-tdfa
+                     , time
                      , transformers-base
                      , wai
                      , wai-extra

src/PostgREST/ApiRequest.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-|
 Module      : PostgREST.ApiRequest
 Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
@@ -13,13 +14,13 @@ module PostgREST.ApiRequest ( ApiRequest(..)
 
 import           Protolude
 import qualified Data.Aeson                as JSON
-import           Data.Aeson.Types          (emptyObject)
+import           Data.Aeson.Types          (emptyObject, emptyArray)
 import qualified Data.ByteString           as BS
 import qualified Data.ByteString.Internal  as BS (c2w)
 import qualified Data.ByteString.Lazy      as BL
 import qualified Data.Csv                  as CSV
 import qualified Data.List                 as L
-import           Data.List                 (lookup, last)
+import           Data.List                 (lookup, last, partition)
 import qualified Data.HashMap.Strict       as M
 import qualified Data.Set                  as S
 import           Data.Maybe                (fromJust)
@@ -33,12 +34,7 @@ import           Network.Wai               (Request (..))
 import           Network.Wai.Parse         (parseHttpAccept)
 import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
 import           Data.Ranged.Boundaries
-import           PostgREST.Types           ( QualifiedIdentifier (..)
-                                           , Schema
-                                           , PayloadJSON(..)
-                                           , ContentType(..)
-                                           , ApiRequestError(..)
-                                           , toMime)
+import           PostgREST.Types
 import           Data.Ranged.Ranges        (Range(..), rangeIntersection, emptyRange)
 import qualified Data.CaseInsensitive      as CI
 import           Web.Cookie                (parseCookiesText)
@@ -46,10 +42,10 @@ import           Web.Cookie                (parseCookiesText)
 type RequestBody = BL.ByteString
 
 -- | Types of things a user wants to do to tables/views/procs
-data Action = ActionCreate | ActionRead
-            | ActionUpdate | ActionDelete
-            | ActionInfo   | ActionInvoke
-            | ActionInspect
+data Action = ActionCreate  | ActionRead
+            | ActionUpdate  | ActionDelete
+            | ActionInfo    | ActionInvoke{isReadOnly :: Bool}
+            | ActionInspect | ActionSingleUpsert
             deriving Eq
 -- | The target db object of a user action
 data Target = TargetIdent QualifiedIdentifier
@@ -59,7 +55,7 @@ data Target = TargetIdent QualifiedIdentifier
             deriving Eq
 -- | How to return the inserted data
 data PreferRepresentation = Full | HeadersOnly | None deriving Eq
-                          --
+
 {-|
   Describes what the user wants to do. This data type is a
   translation of the raw elements of an HTTP request into domain
@@ -84,6 +80,8 @@ data ApiRequest = ApiRequest {
   , iPreferSingleObjectParameter :: Bool
   -- | Whether the client wants a result count (slower)
   , iPreferCount :: Bool
+  -- | Whether the client wants to UPSERT or ignore records on PK conflict
+  , iPreferResolution :: Maybe PreferResolution
   -- | Filters on the result ("id", "eq.10")
   , iFilters :: [(Text, Text)]
   -- | &and and &or parameters used for complex boolean logic
@@ -105,7 +103,7 @@ data ApiRequest = ApiRequest {
 -- | Examines HTTP request and translates it into user intent.
 userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
 userApiRequest schema req reqBody
-  | isTargetingProc && method /= "POST" = Left ActionInappropriate
+  | isTargetingProc && method `notElem` ["GET", "POST"] = Left ActionInappropriate
   | topLevelRange == emptyRange = Left InvalidRange
   | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) undefined payload
   | otherwise = Right ApiRequest {
@@ -118,7 +116,10 @@ userApiRequest schema req reqBody
       , iPreferRepresentation = representation
       , iPreferSingleObjectParameter = singleObject
       , iPreferCount = hasPrefer "count=exact"
-      , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
+      , iPreferResolution = if hasPrefer (show MergeDuplicates) then Just MergeDuplicates
+                            else if hasPrefer (show IgnoreDuplicates) then Just IgnoreDuplicates
+                            else Nothing
+      , iFilters = filters
       , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
       , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
       , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
@@ -132,35 +133,50 @@ userApiRequest schema req reqBody
       , iCookies = fromMaybe [] $ parseCookiesText <$> lookupHeader "Cookie"
       }
  where
+  -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)
+  (filters, rpcQParams) =
+    case action of
+      ActionInvoke{isReadOnly=True} -> partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts
+      _ -> (flts, [])
+  flts = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
+  hasOperator val = any (`T.isPrefixOf` val) $
+                      ((<> ".") <$> "not":M.keys operators) ++
+                      ((<> "(") <$> M.keys ftsOperators)
+  isEmbedPath = T.isInfixOf "."
   isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
   payload =
-    case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of
-      CTApplicationJSON ->
-        note "All object keys must match" . ensureUniform . pluralize
+    case (decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type", action) of
+      (_, ActionInvoke{isReadOnly=True}) ->
+        Right $ PayloadJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams)
+      (CTApplicationJSON, _) ->
+        note "All object keys must match" . payloadAttributes reqBody
           =<< if BL.null reqBody && isTargetingProc
                then Right emptyObject
                else JSON.eitherDecode reqBody
-      CTTextCSV ->
-        note "All lines must have same number of fields" . ensureUniform . csvToJson
-          =<< CSV.decodeByName reqBody
-      CTOther "application/x-www-form-urlencoded" ->
-        Right . PayloadJSON . V.singleton . M.fromList
-                    . map (toS *** JSON.String . toS) . parseSimpleQuery
-                    $ toS reqBody
-      ct ->
+      (CTTextCSV, _) -> do
+        json <- csvToJson <$> CSV.decodeByName reqBody
+        note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
+      (CTOther "application/x-www-form-urlencoded", _) ->
+        let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody
+            keys = S.fromList $ M.keys json in
+        Right $ PayloadJSON (JSON.encode json) PJObject keys
+      (ct, _) ->
         Left $ toS $ "Content-Type not acceptable: " <> toMime ct
   topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges
-  action = case method of
-            "GET"     -> if target == TargetRoot
-                          then ActionInspect
-                          else ActionRead
-            "POST"    -> if isTargetingProc
-                          then ActionInvoke
-                          else ActionCreate
-            "PATCH"   -> ActionUpdate
-            "DELETE"  -> ActionDelete
-            "OPTIONS" -> ActionInfo
-            _         -> ActionInspect
+  action =
+    case method of
+      "GET"      | target == TargetRoot -> ActionInspect
+                 | isTargetingProc -> ActionInvoke{isReadOnly=True}
+                 | otherwise -> ActionRead
+
+      "POST"    -> if isTargetingProc
+                    then ActionInvoke{isReadOnly=False}
+                    else ActionCreate
+      "PATCH"   -> ActionUpdate
+      "PUT"     -> ActionSingleUpsert
+      "DELETE"  -> ActionDelete
+      "OPTIONS" -> ActionInfo
+      _         -> ActionInspect
   target = case path of
               []            -> TargetRoot
               [table]       -> TargetIdent
@@ -168,10 +184,9 @@ userApiRequest schema req reqBody
               ["rpc", proc] -> TargetProc
                               $ QualifiedIdentifier schema proc
               other         -> TargetUnknown other
-  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke]
-  relevantPayload = if shouldParsePayload
-                      then rightToMaybe payload
-                      else Nothing
+  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke{isReadOnly=False}, ActionInvoke{isReadOnly=True}]
+  relevantPayload | shouldParsePayload = rightToMaybe payload
+                  | otherwise = Nothing
   path            = pathInfo req
   method          = requestMethod req
   hdrs            = requestHeaders req
@@ -254,9 +269,9 @@ type CsvData = V.Vector (M.HashMap Text BL.ByteString)
   The reason for its odd signature is so that it can compose
   directly with CSV.decodeByName
 -}
-csvToJson :: (CSV.Header, CsvData) -> JSON.Array
+csvToJson :: (CSV.Header, CsvData) -> JSON.Value
 csvToJson (_, vals) =
-  V.map rowToJsonObj vals
+  JSON.Array $ V.map rowToJsonObj vals
  where
   rowToJsonObj = JSON.Object .
     M.map (\str ->
@@ -265,27 +280,26 @@ csvToJson (_, vals) =
           else JSON.String $ toS str
       )
 
--- | Convert {foo} to [{foo}], leave arrays unchanged
--- and truncate everything else to an empty array.
-pluralize :: JSON.Value -> JSON.Array
-pluralize obj@(JSON.Object _) = V.singleton obj
-pluralize (JSON.Array arr)    = arr
-pluralize _                   = V.empty
+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 $ PayloadJSON raw (PJArray $ V.length arr) canonicalKeys
+            else Nothing
+        Just _ -> Nothing
+        Nothing -> Just emptyPJArray
 
--- | Test that Array contains only Objects having the same keys
--- and if so mark it as PayloadJSON
-ensureUniform :: JSON.Array -> Maybe PayloadJSON
-ensureUniform arr =
-  let objs :: V.Vector JSON.Object
-      objs = foldr -- filter non-objects, map to raw objects
-               (\val result -> case val of
-                  JSON.Object o -> V.cons o result
-                  _ -> result)
-               V.empty arr
-      keysPerObj = V.map (S.fromList . M.keys) objs
-      canonicalKeys = fromMaybe S.empty $ keysPerObj V.!? 0
-      areKeysUniform = all (==canonicalKeys) keysPerObj in
+    JSON.Object o -> Just $ PayloadJSON raw PJObject (S.fromList $ M.keys o)
 
-  if (V.length objs == V.length arr) && areKeysUniform
-    then Just (PayloadJSON objs)
-    else Nothing
+    -- truncate everything else to an empty array.
+    _ -> Just emptyPJArray
+  where
+    emptyPJArray = PayloadJSON (JSON.encode emptyArray) (PJArray 0) S.empty

src/PostgREST/App.hs

@@ -1,15 +1,19 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module PostgREST.App (
   postgrest
 ) where
 
 import           Control.Applicative
+import           Data.Aeson                as JSON
 import qualified Data.ByteString.Char8     as BS
 import           Data.Maybe
 import           Data.IORef                (IORef, readIORef)
 import           Data.Text                 (intercalate)
+import           Data.Time.Clock           (UTCTime)
+import qualified Data.Set                  as S
 
 import qualified Hasql.Pool                 as P
 import qualified Hasql.Transaction          as HT
@@ -21,7 +25,6 @@ import           Network.HTTP.Types.URI    (renderSimpleQuery)
 import           Network.Wai
 import           Network.Wai.Middleware.RequestLogger (logStdout)
 
-import qualified Data.Vector               as V
 import qualified Hasql.Transaction         as H
 
 import qualified Data.HashMap.Strict       as M
@@ -42,7 +45,7 @@ import           PostgREST.DbRequestBuilder( readRequest
 import           PostgREST.Error           ( simpleError, pgError
                                            , apiRequestError
                                            , singularityError, binaryFieldError
-                                           , connectionLostError
+                                           , connectionLostError, gucHeadersError
                                            )
 import           PostgREST.RangeQuery      (allRange, rangeOffset)
 import           PostgREST.Middleware
@@ -60,12 +63,13 @@ import           Data.Function (id)
 import           Protolude              hiding (intercalate, Proxy)
 import           Safe                   (headMay)
 
-postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO () -> Application
-postgrest conf refDbStructure pool worker =
+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 = parseJWK <$> configJwtSecret conf in
 
   middle $ \ req respond -> do
+    time <- getTime
     body <- strictRequestBody req
     maybeDbStructure <- readIORef refDbStructure
     case maybeDbStructure of
@@ -74,40 +78,47 @@ postgrest conf refDbStructure pool worker =
         response <- case userApiRequest (configSchema conf) req body of
           Left err -> return $ apiRequestError err
           Right apiRequest -> do
-            eClaims <- jwtClaims jwtSecret (toS $ iJWT apiRequest)
+            eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)
 
             let authed = containsRole eClaims
-                handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
-                txMode = transactionMode dbStructure
-                  (iTarget apiRequest) (iAction apiRequest)
+                proc = case (iTarget apiRequest, iPayload apiRequest, iPreferSingleObjectParameter apiRequest) of
+                  (TargetProc qi, Just PayloadJSON{pjKeys}, s) -> findProc qi pjKeys s $ dbProcs dbStructure
+                  _ -> Nothing
+                handleReq = runWithClaims conf eClaims (app dbStructure proc conf) apiRequest
+                txMode = transactionMode proc (iAction apiRequest)
             response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
             return $ either (pgError authed) identity response
-        when (isResponse503 response) worker
+        when (responseStatus response == status503) worker
         respond response
 
-isResponse503 :: Response -> Bool
-isResponse503 resp = statusCode (responseStatus resp) == 503
+findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription
+findProc qi payloadKeys paramsAsSingleObject allProcs =
+  let procs = M.lookup (qiName qi) allProcs in
+ -- Handle overloaded functions case
+  join $ (case length <$> procs of
+    Just 1 -> headMay -- if it's not an overloaded function then immediatly get the ProcDescription
+    _ -> find (\x ->
+           if paramsAsSingleObject
+             then length (pdArgs x) == 1 -- if the arg is not of json type let the db give the err
+             else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x))
+  ) <$> procs
 
-transactionMode :: DbStructure -> Target -> Action -> H.Mode
-transactionMode structure target action =
+transactionMode :: Maybe ProcDescription -> Action -> H.Mode
+transactionMode proc action =
   case action of
     ActionRead -> HT.Read
     ActionInfo -> HT.Read
     ActionInspect -> HT.Read
-    ActionInvoke ->
-      let proc =
-            case target of
-              (TargetProc qi) -> M.lookup (qiName qi) $
-                                   dbProcs structure
-              _               -> Nothing
-          v = fromMaybe Volatile $ pdVolatility <$> proc in
+    ActionInvoke{isReadOnly=False} ->
+      let v = fromMaybe Volatile $ pdVolatility <$> proc in
       if v == Stable || v == Immutable
          then HT.Read
          else HT.Write
+    ActionInvoke{isReadOnly=True} -> HT.Read
     _ -> HT.Write
 
-app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
-app dbStructure conf apiRequest =
+app :: DbStructure -> Maybe ProcDescription -> AppConfig -> ApiRequest -> H.Transaction Response
+app dbStructure proc conf apiRequest =
   case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of
     Left errorResponse -> return errorResponse
     Right contentType ->
@@ -136,48 +147,52 @@ app dbStructure conf apiRequest =
                       )
                     ] (toS body)
 
-        (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->
-          case mutateSqlParts of
+        (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType}) ->
+          case mutateSqlParts tSchema tName of
             Left errorResponse -> return errorResponse
             Right (sq, mq) -> do
-              let isSingle = (==1) $ V.length rows
+              let (isSingle, nRows) = case pjType of
+                                        PJArray len -> (len == 1, len)
+                                        PJObject -> (True, 1)
               if contentType == CTSingularJSON
                  && not isSingle
                  && iPreferRepresentation apiRequest == Full
-                then return $ singularityError (toInteger $ V.length rows)
+                then return $ singularityError (toInteger nRows)
                 else do
-                  let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
+                  let pkCols = tablePKCols dbStructure tSchema tName
                       stm = createWriteStatement sq mq
                         (contentType == CTSingularJSON) isSingle
-                        (contentType == CTTextCSV) (iPreferRepresentation apiRequest)
-                        pKeys
-                  row <- H.query payload stm
+                        (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols
+                  row <- H.query (toS pjRaw) stm
                   let (_, _, fs, body) = extractQueryResult row
                       headers = catMaybes [
                           if null fs
                             then Nothing
-                            else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
+                            else Just (hLocation, "/" <> toS tName <> renderLocationFields fs)
                         , if iPreferRepresentation apiRequest == Full
                             then Just $ toHeader contentType
                             else Nothing
                         , Just . contentRangeH 1 0 $
-                            toInteger <$> if shouldCount then Just (V.length rows) else Nothing
+                            toInteger <$> if shouldCount then Just nRows else Nothing
+                        , if null pkCols
+                            then Nothing
+                            else (\x -> ("Preference-Applied", show x)) <$> iPreferResolution apiRequest
                         ]
 
                   return . responseLBS status201 headers $
                     if iPreferRepresentation apiRequest == Full
                       then toS body else ""
 
-        (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON rows)) ->
-          case (mutateSqlParts, null <$> rows V.!? 0, iPreferRepresentation apiRequest == Full) of
+        (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just p@PayloadJSON{pjRaw}) ->
+          case (mutateSqlParts tSchema tName, pjIsEmpty p, iPreferRepresentation apiRequest == Full) of
             (Left errorResponse, _, _) -> return errorResponse
-            (_, Just True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"
-            (_, Just True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""
+            (_, True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"
+            (_, True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""
             (Right (sq, mq), _, _) -> do
               let stm = createWriteStatement sq mq
                     (contentType == CTSingularJSON) False (contentType == CTTextCSV)
                     (iPreferRepresentation apiRequest) []
-              row <- H.query payload stm
+              row <- H.query (toS pjRaw) stm
               let (_, queryTotal, _, body) = extractQueryResult row
               if contentType == CTSingularJSON
                  && queryTotal /= 1
@@ -195,16 +210,46 @@ app dbStructure conf apiRequest =
                     then responseLBS s [toHeader contentType, r] (toS body)
                     else responseLBS s [r] ""
 
-        (ActionDelete, TargetIdent _, Nothing) ->
-          case mutateSqlParts of
+        (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType, pjKeys}) ->
+          case mutateSqlParts tSchema tName of
             Left errorResponse -> return errorResponse
             Right (sq, mq) -> do
-              let emptyPayload = PayloadJSON V.empty
-                  stm = createWriteStatement sq mq
+              let isSingle = case pjType of
+                               PJArray len -> len == 1
+                               PJObject -> True
+                  colNames = colName <$> tableCols dbStructure tSchema tName
+              if topLevelRange /= allRange
+                then return $ simpleError status400 [] "Range header and limit/offset querystring parameters are not allowed for PUT"
+              else if not isSingle
+                then return $ simpleError status400 [] "PUT payload must contain a single row"
+              else if S.fromList colNames /= pjKeys
+                then return $ simpleError status400 [] "You must specify all columns in the payload when using PUT"
+              else do
+                row <- H.query (toS pjRaw) $
+                       createWriteStatement sq mq (contentType == CTSingularJSON) False
+                                            (contentType == CTTextCSV) (iPreferRepresentation apiRequest) []
+                let (_, queryTotal, _, body) = extractQueryResult row
+                -- Makes sure the querystring pk matches the payload pk
+                -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, PUT /items?id=eq.14 { "id" : 2, .. } is rejected
+                -- If this condition is not satisfied then nothing is inserted, check the WHERE for INSERT in QueryBuilder.hs to see how it's done
+                if queryTotal /= 1
+                  then do
+                    HT.condemn
+                    return $ simpleError status400 [] "Payload values do not match URL in primary key column(s)"
+                  else
+                    return $ if iPreferRepresentation apiRequest == Full
+                      then responseLBS status200 [toHeader contentType] (toS body)
+                      else responseLBS status204 [] ""
+
+        (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) []
-              row <- H.query emptyPayload stm
+              row <- H.query mempty stm
               let (_, queryTotal, _, body) = extractQueryResult row
                   r = contentRangeH 1 0 $
                         toInteger <$> if shouldCount then Just queryTotal else Nothing
@@ -227,34 +272,40 @@ app dbStructure conf apiRequest =
               let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
               return $ responseLBS status200 [allOrigins, acceptH] ""
 
-        (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->
-          let proc = M.lookup (qiName qi) allProcs
-              returnsScalar = case proc of
+        (ActionInvoke _, TargetProc qi, Just PayloadJSON{pjRaw, pjType, pjKeys}) ->
+          let returnsScalar = case proc of
                 Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True
                 _ -> False
               rpcBinaryField = if returnsScalar
                                  then Right Nothing
                                  else binaryField contentType =<< fldNames
-              partsField = (,) <$> readSqlParts <*> rpcBinaryField in
-          case partsField of
+              parts = (,) <$> readSqlParts <*> rpcBinaryField in
+          case parts of
             Left errorResponse -> return errorResponse
             Right ((q, cq), bField) -> do
-              let p = V.head payload
+              let isObject = case pjType of
+                                PJObject  -> True
+                                PJArray _ -> False
                   singular = contentType == CTSingularJSON
-                  paramsAsSingleObject = iPreferSingleObjectParameter apiRequest
-              row <- H.query () $
-                callProc qi p returnsScalar q cq topLevelRange shouldCount
-                         singular paramsAsSingleObject
+                  specifiedPgArgs = filter ((`S.member` pjKeys) . pgaName) $ fromMaybe [] (pdArgs <$> proc)
+              row <- H.query (toS pjRaw) $
+                callProc qi specifiedPgArgs returnsScalar q cq shouldCount
+                         singular (iPreferSingleObjectParameter apiRequest)
                          (contentType == CTTextCSV)
-                         (contentType == CTOctetStream) bField
-              let (tableTotal, queryTotal, body) =
-                    fromMaybe (Just 0, 0, "[]") row
+                         (contentType == CTOctetStream) bField isObject
+                         (pgVersion dbStructure)
+              let (tableTotal, queryTotal, body, jsonHeaders) =
+                    fromMaybe (Just 0, 0, "[]", "[]") row
                   (status, contentRange) = rangeHeader queryTotal tableTotal
-              if singular && queryTotal /= 1
-                then do
-                  HT.condemn
-                  return $ singularityError (toInteger queryTotal)
-                else return $ responseLBS status [toHeader contentType, contentRange] (toS body)
+                  decodedHeaders = first toS $ JSON.eitherDecode $ toS jsonHeaders :: Either Text [GucHeader]
+              case decodedHeaders of
+                Left _ -> return gucHeadersError
+                Right hs ->
+                  if singular && queryTotal /= 1
+                    then do
+                      HT.condemn
+                      return $ singularityError (toInteger queryTotal)
+                    else return $ responseLBS status ([toHeader contentType, contentRange] ++ toHeaders hs) (toS body)
 
         (ActionInspect, TargetRoot, Nothing) -> do
           let host = configHost conf
@@ -263,26 +314,16 @@ app dbStructure conf apiRequest =
               uri Nothing = ("http", host, port, "/")
               uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
               uri' = uri proxy
-              encodeApi ti sd = encodeOpenAPI (M.elems allProcs) (toTableInfo ti) uri' sd (dbPrimaryKeys dbStructure)
-          body <- encodeApi <$> H.query schema accessibleTables <*> H.query schema schemaDescription
+              toTableInfo :: [Table] -> [(Table, [Column], [Text])]
+              toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn))
+              encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure
+          body <- encodeApi <$> H.query schema accessibleTables <*> H.query schema schemaDescription <*> H.query schema accessibleProcs
           return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body
 
         _ -> return notFound
 
     where
-      toTableInfo :: [Table] -> [(Table, [Column], [Text])]
-      toTableInfo = map (\t ->
-        let tSchema = tableSchema t
-            tTable = tableName t
-            cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
-            pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
-        in (t, cols, pkeys))
       notFound = responseLBS status404 [] ""
-      filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
-      filterCol :: Schema -> TableName -> Column -> Bool
-      filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
-      allPrKeys = dbPrimaryKeys dbStructure
-      allProcs = dbProcs dbStructure
       allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
       shouldCount = iPreferCount apiRequest
       schema = toS $ configSchema conf
@@ -294,15 +335,15 @@ app dbStructure conf apiRequest =
             status = rangeStatus lower upper (toInteger <$> tableTotal)
         in (status, contentRange)
 
-      readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) allProcs apiRequest
+      readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) proc apiRequest
       fldNames = fieldNames <$> readReq
       readDbRequest = DbRead <$> readReq
-      mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< fldNames)
       selectQuery = requestToQuery schema False <$> readDbRequest
-      mutateQuery = requestToQuery schema False <$> mutateDbRequest
       countQuery = requestToCountQuery schema <$> readDbRequest
       readSqlParts = (,) <$> selectQuery <*> countQuery
-      mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
+      mutateSqlParts s t =
+        (,) <$> selectQuery
+            <*> (requestToQuery schema False . DbMutate <$> (mutateRequest apiRequest t (tablePKCols dbStructure s t) =<< fldNames))
 
 responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
 responseContentTypeOrError accepts action = serves contentTypesForRequest accepts
@@ -313,9 +354,10 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept
         ActionCreate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
         ActionUpdate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
         ActionDelete ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
+        ActionInvoke _ ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
         ActionInspect -> [CTOpenAPI, CTApplicationJSON]
         ActionInfo ->    [CTTextCSV]
+        ActionSingleUpsert ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
     serves sProduces cAccepts =
       case mutuallyAgreeable sProduces cAccepts of
         Nothing -> do

src/PostgREST/Auth.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-|
 Module      : PostgREST.Auth
 Description : PostgREST authorization functions.
@@ -18,16 +19,15 @@ module PostgREST.Auth (
   , parseJWK
   ) where
 
-import           Protolude        hiding ((&))
-import           Control.Lens
-import           Data.Aeson              (Value (..), decode, toJSON)
-import qualified Data.ByteString.Lazy    as BL
-import qualified Data.HashMap.Strict     as M
+import           Control.Lens.Operators
+import qualified Data.Aeson             as JSON
+import qualified Data.HashMap.Strict    as M
+import           Data.Time.Clock        (UTCTime)
+import           Data.Vector            as V
+import           PostgREST.Types
+import           Protolude
 
-import           Crypto.JOSE.Compact
-import           Crypto.JOSE.JWK
-import           Crypto.JOSE.JWS
-import           Crypto.JOSE.Types
+import qualified Crypto.JOSE.Types      as JOSE.Types
 import           Crypto.JWT
 
 {-|
@@ -35,48 +35,56 @@ import           Crypto.JWT
 -}
 data JWTAttempt = JWTInvalid JWTError
                 | JWTMissingSecret
-                | JWTClaims (M.HashMap Text Value)
+                | JWTClaims (M.HashMap Text JSON.Value)
                 deriving (Eq, Show)
 
 {-|
-  Receives the JWT secret (from config) and a JWT and returns a map
+  Receives the JWT secret and audience (from config) and a JWT and returns a map
   of JWT claims.
 -}
-jwtClaims :: Maybe JWK -> BL.ByteString -> IO JWTAttempt
-jwtClaims _ "" = return $ JWTClaims M.empty
-jwtClaims secret payload =
+jwtClaims :: Maybe JWK -> 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 jwk -> do
-      let validation = defaultJWTValidationSettings
+    Just s -> do
+      let validation = defaultJWTValidationSettings (maybe (const True) (==) audience)
       eJwt <- runExceptT $ do
         jwt <- decodeCompact payload
-        validateJWSJWT validation jwk jwt
-        return jwt
+        verifyClaimsAt validation s time jwt
       return $ case eJwt of
-        Left e -> JWTInvalid e
-        Right jwt -> JWTClaims . claims2map . jwtClaimsSet $ jwt
+        Left e    -> JWTInvalid e
+        Right jwt -> JWTClaims $ claims2map jwt jspath
+
+{-|
+  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
+
+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
 
 {-|
   Whether a response from jwtClaims contains a role claim
 -}
 containsRole :: JWTAttempt -> Bool
 containsRole (JWTClaims claims) = M.member "role" claims
-containsRole _ = False
-
-{-|
-  Internal helper used to turn JWT ClaimSet into something
-  easier to work with
--}
-claims2map :: ClaimsSet -> M.HashMap Text Value
-claims2map = val2map . toJSON
- where
-  val2map (Object o) = o
-  val2map _ = M.empty
+containsRole _                  = False
 
 parseJWK :: ByteString -> JWK
 parseJWK str =
-  fromMaybe (hs256jwk str) (decode (toS str) :: Maybe JWK)
+  fromMaybe (hs256jwk str) (JSON.decode (toS str) :: Maybe JWK)
 
 {-|
   Internal helper to generate HMAC-SHA256. When the jwt key in the
@@ -89,4 +97,4 @@ hs256jwk key =
     & jwkUse .~ Just Sig
     & jwkAlg .~ (Just $ JWSAlg HS256)
  where
-  km = OctKeyMaterial (OctKeyParameters Oct (Base64Octets key))
+  km = OctKeyMaterial (OctKeyParameters (JOSE.Types.Base64Octets key))

src/PostgREST/Config.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase, TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {-|
 Module      : PostgREST.Config
@@ -14,38 +15,52 @@ turned in configurable behaviour if needed.
 Other hardcoded options such as the minimum version number also belong here.
 -}
 module PostgREST.Config ( prettyVersion
+                        , docsVersion
                         , readOptions
                         , corsPolicy
                         , minimumPgVersion
-                        , PgVersion (..)
+                        , pgVersion95
+                        , pgVersion96
                         , AppConfig (..)
                         )
        where
 
-import           System.IO.Error             (IOError)
 import           Control.Applicative
-import qualified Data.ByteString             as B
-import qualified Data.ByteString.Char8       as BS
-import qualified Data.CaseInsensitive        as CI
-import qualified Data.Configurator           as C
-import qualified Data.Configurator.Parser    as C
-import           Data.Configurator.Types     (Value(..))
-import           Data.List                   (lookup)
+import           Control.Monad                (fail)
+import           Control.Lens                 (preview)
+import           Crypto.JWT                   (StringOrURI,
+                                               stringOrUri)
+import qualified Data.ByteString              as B
+import qualified Data.ByteString.Char8        as BS
+import qualified Data.CaseInsensitive         as CI
+import qualified Data.Configurator            as C
+import qualified Data.Configurator.Parser     as C
+import           Data.Configurator.Types      as C
+import           Data.List                    (lookup)
 import           Data.Monoid
-import           Data.Scientific             (floatingOrInteger)
-import           Data.Text                   (strip, intercalate, lines)
-import           Data.Text.Encoding          (encodeUtf8)
-import           Data.Text.IO                (hPutStrLn)
-import           Data.Version                (versionBranch)
+import           Data.Scientific              (floatingOrInteger)
+import           Data.String                  (String)
+import           Data.Text                    (dropAround,
+                                               intercalate, lines,
+                                               strip, take)
+import           Data.Text.Encoding           (encodeUtf8)
+import           Data.Text.IO                 (hPutStrLn)
+import           Data.Version                 (versionBranch)
+import           Development.GitRev           (gitHash)
 import           Network.Wai
-import           Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
-import           Options.Applicative hiding  (str)
-import           Paths_postgrest             (version)
-import           System.IO                   (hPrint)
+import           Network.Wai.Middleware.Cors  (CorsResourcePolicy (..))
+import           Options.Applicative          hiding (str)
+import           Paths_postgrest              (version)
+import           PostgREST.Parsers            (pRoleClaimKey)
+import           PostgREST.Types              (PgVersion(..), ApiRequestError(..),
+                                               JSPath, JSPathExp(..))
+import           Protolude                    hiding (hPutStrLn, take,
+                                               intercalate, (<>))
+import           System.IO                    (hPrint)
+import           System.IO.Error              (IOError)
 import           Text.Heredoc
-import           Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>))
+import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))
 import qualified Text.PrettyPrint.ANSI.Leijen as L
-import           Protolude hiding            (intercalate, (<>), hPutStrLn)
 
 -- | Config file settings for the server
 data AppConfig = AppConfig {
@@ -58,11 +73,14 @@ data AppConfig = AppConfig {
 
   , configJwtSecret         :: Maybe B.ByteString
   , configJwtSecretIsBase64 :: Bool
+  , configJwtAudience       :: Maybe StringOrURI
 
   , configPool              :: Int
   , configMaxRows           :: Maybe Integer
   , configReqCheck          :: Maybe Text
   , configQuiet             :: Bool
+  , configSettings          :: [(Text, Text)]
+  , configRoleClaimKey      :: Either ApiRequestError JSPath
   }
 
 defaultCorsPolicy :: CorsResourcePolicy
@@ -90,7 +108,13 @@ corsPolicy req = case lookup "origin" headers of
 
 -- | User friendly version number
 prettyVersion :: Text
-prettyVersion = intercalate "." $ map show $ versionBranch version
+prettyVersion =
+  intercalate "." (map show $ versionBranch version)
+  <> " (" <> take 7 $(gitHash) <> ")"
+
+-- | Version number used in docs
+docsVersion :: Text
+docsVersion = "v" <> dropAround (== '.') (dropAround (/= '.') prettyVersion)
 
 -- | Function to read and parse options from the command line
 readOptions :: IO AppConfig
@@ -102,20 +126,23 @@ readOptions = do
     (C.readConfig =<< C.load [C.Required cfgPath])
     configNotfoundHint
 
-  let (mAppConf, errs) = flip C.runParserA conf $
-        AppConfig <$>
-            C.key "db-uri"
+  let (mAppConf, errs) = flip C.runParserM conf $
+        AppConfig
+          <$> C.key "db-uri"
           <*> C.key "db-anon-role"
-          <*> C.key "server-proxy-uri"
+          <*> (mfilter (/= "") <$> C.key "server-proxy-uri")
           <*> C.key "db-schema"
           <*> (fromMaybe "*4" . mfilter (/= "") <$> C.key "server-host")
           <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port")
           <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret")
           <*> (fromMaybe False . join . fmap coerceBool <$> C.key "secret-is-base64")
+          <*> parseJwtAudience "jwt-aud"
           <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool")
           <*> (join . fmap coerceInt <$> C.key "max-rows")
           <*> (mfilter (/= "") <$> C.key "pre-request")
           <*> pure False
+          <*> (fmap parsedPairToTextPair <$> C.subassocs "app.settings")
+          <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> C.key "role-claim-key")
 
   case mAppConf of
     Nothing -> do
@@ -124,61 +151,85 @@ readOptions = do
     Just appConf ->
       return appConf
 
- where
-  coerceInt :: (Read i, Integral i) => Value -> Maybe i
-  coerceInt (Number x) = rightToMaybe $ floatingOrInteger x
-  coerceInt (String x) = readMaybe $ toS x
-  coerceInt _ = Nothing
+  where
+    parsedPairToTextPair :: (Name, Value) -> (Text, Text)
+    parsedPairToTextPair (k, v) = (k, newValue)
+      where
+        newValue = case v of
+          String textVal -> textVal
+          _ -> show v
 
-  coerceBool ::  Value -> Maybe Bool
-  coerceBool (Bool b) = Just b
-  coerceBool (String x) = readMaybe $ toS x
-  coerceBool _ = Nothing
+    parseJwtAudience :: Name -> C.ConfigParserM (Maybe StringOrURI)
+    parseJwtAudience k =
+      C.key k >>= \case
+        Nothing -> pure Nothing -- no audience in config file
+        Just aud -> case preview stringOrUri (aud :: String) of
+          Nothing -> fail "Invalid Jwt audience. Check your configuration."
+          (Just "") -> pure Nothing
+          aud' -> pure aud'
 
-  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)
-             )
+    coerceInt :: (Read i, Integral i) => Value -> Maybe i
+    coerceInt (Number x) = rightToMaybe $ floatingOrInteger x
+    coerceInt (String x) = readMaybe $ toS x
+    coerceInt _          = Nothing
 
-  parserPrefs = prefs showHelpOnError
+    coerceBool :: Value -> Maybe Bool
+    coerceBool (Bool b)   = Just b
+    coerceBool (String b) = readMaybe $ toS b
+    coerceBool _          = Nothing
 
-  configNotfoundHint :: IOError -> IO a
-  configNotfoundHint e = do
-    hPutStrLn stderr $
-      "Cannot open config file:\n\t" <> show e
-    exitFailure
+    parseRoleClaimKey :: Value -> Either ApiRequestError JSPath
+    parseRoleClaimKey (String s) = pRoleClaimKey s
+    parseRoleClaimKey v = pRoleClaimKey $ show v
 
-  exampleCfg :: Doc
-  exampleCfg = vsep . map (text . toS) . lines $
-    [str|db-uri = "postgres://user:pass@localhost:5432/dbname"
-        |db-schema = "public"
-        |db-anon-role = "postgres"
-        |db-pool = 10
-        |
-        |server-host = "*4"
-        |server-port = 3000
-        |
-        |## base url for swagger output
-        |# server-proxy-uri = ""
-        |
-        |## choose a secret to enable JWT auth
-        |## (use "@filename" to load from separate file)
-        |# jwt-secret = "foo"
-        |# secret-is-base64 = false
-        |
-        |## limit rows in response
-        |# max-rows = 1000
-        |
-        |## stored proc to exec immediately after auth
-        |# pre-request = "stored_proc_name"
-        |]
+    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)
+               )
+
+    parserPrefs = prefs showHelpOnError
+
+    configNotfoundHint :: IOError -> IO a
+    configNotfoundHint e = do
+      hPutStrLn stderr $
+        "Cannot open config file:\n\t" <> show e
+      exitFailure
+
+    exampleCfg :: Doc
+    exampleCfg = vsep . map (text . toS) . lines $
+      [str|db-uri = "postgres://user:pass@localhost:5432/dbname"
+          |db-schema = "public"
+          |db-anon-role = "postgres"
+          |db-pool = 10
+          |
+          |server-host = "*4"
+          |server-port = 3000
+          |
+          |## base url for swagger output
+          |# server-proxy-uri = ""
+          |
+          |## choose a secret to enable JWT auth
+          |## (use "@filename" to load from separate file)
+          |# jwt-secret = "foo"
+          |# 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"
+          |]
 
 pathParser :: Parser FilePath
 pathParser =
@@ -186,11 +237,12 @@ pathParser =
     metavar "FILENAME" <>
     help "Path to configuration file"
 
-data PgVersion = PgVersion {
-  pgvNum  :: Int32
-, pgvName :: Text
-}
-
 -- | Tells the minimum PostgreSQL version required by this version of PostgREST
 minimumPgVersion :: PgVersion
-minimumPgVersion = PgVersion 90300 "9.3"
+minimumPgVersion = PgVersion 90400 "9.4"
+
+pgVersion96 :: PgVersion
+pgVersion96 = PgVersion 90600 "9.6"
+
+pgVersion95 :: PgVersion
+pgVersion95 = PgVersion 90500 "9.5"

src/PostgREST/DbRequestBuilder.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DuplicateRecordFields    #-}
+{-# LANGUAGE DuplicateRecordFields#-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
 module PostgREST.DbRequestBuilder (
   readRequest
 , mutateRequest
@@ -13,6 +16,7 @@ import           Control.Lens.Tuple        (_1)
 import qualified Data.ByteString.Char8     as BS
 import           Data.List                 (delete)
 import           Data.Maybe                (fromJust)
+import qualified Data.Set                  as S
 import           Data.Text                 (isInfixOf)
 import           Data.Tree
 import           Data.Either.Combinators   (mapLeft)
@@ -29,55 +33,71 @@ import           PostgREST.ApiRequest   ( ApiRequest(..)
                                         )
 import           PostgREST.Error           (apiRequestError)
 import           PostgREST.Parsers
-import           PostgREST.RangeQuery      (NonnegRange, restrictRange)
-import           PostgREST.QueryBuilder (getJoinFilters, sourceCTEName)
+import           PostgREST.RangeQuery      (NonnegRange, restrictRange, allRange)
 import           PostgREST.Types
 
 import           Protolude                hiding (from, dropWhile, drop)
 import           Text.Regex.TDFA         ((=~))
 import           Unsafe                  (unsafeHead)
 
-readRequest :: Maybe Integer -> [Relation] -> M.HashMap Text ProcDescription -> ApiRequest -> Either Response ReadRequest
-readRequest maxRows allRels allProcs apiRequest  =
+readRequest :: Maybe Integer -> [Relation] -> Maybe ProcDescription -> ApiRequest -> Either Response ReadRequest
+readRequest maxRows allRels proc apiRequest  =
   mapLeft apiRequestError $
   treeRestrictRange maxRows =<<
   augumentRequestWithJoin schema relations =<<
-  parseReadRequest
+  addFiltersOrdersRanges apiRequest <*>
+  (buildReadRequest <$> pRequestSelect (iSelect apiRequest))
   where
+    action = iAction apiRequest
     (schema, rootTableName) = fromJust $ -- Make it safe
       let target = iTarget apiRequest in
       case target of
         (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
-        (TargetProc  (QualifiedIdentifier s proc) ) -> Just (s, tName)
+        (TargetProc  (QualifiedIdentifier s pName) ) -> Just (s, tName)
           where
-            retType = pdReturnType <$> M.lookup proc allProcs
-            tName = case retType of
+            tName = case pdReturnType <$> proc of
               Just (SetOf (Composite qi)) -> qiName qi
               Just (Single (Composite qi)) -> qiName qi
-              _ -> proc
+              _ -> pName
 
         _ -> Nothing
 
-    action :: Action
-    action = iAction apiRequest
-
-    parseReadRequest :: Either ApiRequestError ReadRequest
-    parseReadRequest = addFiltersOrdersRanges apiRequest <*>
-      pRequestSelect rootName selStr
+    -- Build tree with a Depth attribute so when a self join occurs we can differentiate the parent and child tables by having
+    -- an alias like "table_depth", this is related to issue #987.
+    buildReadRequest :: [Tree SelectItem] -> ReadRequest
+    buildReadRequest fieldTree =
+      let rootDepth = 0
+          rootNodeName = if action == ActionRead then rootTableName else sourceCTEName in
+      foldr (treeEntry rootDepth) (Node (Select [] [rootNodeName] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing, rootDepth)) []) fieldTree
       where
-        selStr = iSelect apiRequest
-        rootName = if action == ActionRead
-          then rootTableName
-          else sourceCTEName
+        treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest
+        treeEntry depth (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) =
+          let nxtDepth = succ depth in
+          case fldForest of
+            [] -> Node (q {select=fld:select q}, i) rForest
+            _  -> Node (q, i) $
+                  foldr (treeEntry nxtDepth) (Node (Select [] [fn] [] [] [] allRange, (fn, Nothing, alias, relationDetail, nxtDepth)) []) fldForest:rForest
 
     relations :: [Relation]
     relations = case action of
-      ActionCreate -> fakeSourceRelations ++ allRels
-      ActionUpdate -> fakeSourceRelations ++ allRels
-      ActionDelete -> fakeSourceRelations ++ allRels
-      ActionInvoke -> fakeSourceRelations ++ allRels
+      ActionCreate   -> fakeSourceRelations ++ allRels
+      ActionUpdate   -> fakeSourceRelations ++ allRels
+      ActionDelete   -> fakeSourceRelations ++ allRels
+      ActionInvoke _ -> fakeSourceRelations ++ allRels
       _       -> allRels
-      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
+      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels
+
+-- in a relation where one of the tables matches "TableName"
+-- replace the name to that table with pg_source
+-- this "fake" relations is needed so that in a mutate query
+-- we can look a the "returning *" part which is wrapped with a "with"
+-- as just another table that has relations with other tables
+toSourceRelation :: TableName -> Relation -> Maybe Relation
+toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
+  | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}
+  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}
+  | Just mt == (tableName <$> rt) = Just $ r {relLinkTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}
+  | otherwise = Nothing
 
 treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
 treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
@@ -88,121 +108,135 @@ treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` re
 augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either ApiRequestError ReadRequest
 augumentRequestWithJoin schema allRels request =
   addRelations schema allRels Nothing request
-  >>= addJoinFilters schema
+  >>= addJoinConditions schema
 
 addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
-addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias, relationDetail)) forest) =
+addRelations schema allRelations parentNode (Node (query, (nodeName, _, alias, relationDetail, depth)) forest) =
   case parentNode of
-    (Just (Node (Select{from=[parentNodeTable]}, (_, _, _, _)) _)) ->
-      Node <$> readNode' <*> forest'
-      where
-        forest' = updateForest $ hush node'
-        node' = Node <$> readNode' <*> pure forest
-        readNode' = addRel readNode <$> rel
-        rel :: Either ApiRequestError Relation
-        rel = note (NoRelationBetween parentNodeTable name)
-            $ findRelation schema name parentNodeTable relationDetail
-            where
-              
-              findRelation s nodeTableName parentNodeTableName Nothing =
-                find (\r ->
-                  s == tableSchema (relTable r) && -- match schema for relation table
-                  s == tableSchema (relFTable r) && -- match schema for relation foriegn table
-                  (
-
-                    -- (request)        => projects { ..., clients{...} }
-                    -- will match
-                    -- (relation type)  => parent
-                    -- (entity)         => clients  {id}
-                    -- (foriegn entity) => projects {client_id}
-                    (
-                      nodeTableName == tableName (relTable r) && -- match relation table name
-                      parentNodeTableName == tableName (relFTable r) -- match relation foreign table name
-                    ) ||
-
-
-                    -- (request)        => projects { ..., client_id{...} }
-                    -- will match
-                    -- (relation type)  => parent
-                    -- (entity)         => clients  {id}
-                    -- (foriegn entity) => projects {client_id}
-                    (
-                      parentNodeTableName == tableName (relFTable r) &&
-                      length (relFColumns r) == 1 &&
-                      nodeTableName `colMatches` (colName . unsafeHead . relFColumns) r
-                    )
-
-                    -- (request)        => project_id { ..., client_id{...} }
-                    -- will match
-                    -- (relation type)  => parent
-                    -- (entity)         => clients  {id}
-                    -- (foriegn entity) => projects {client_id}
-                    -- this case works becasue before reaching this place
-                    -- addRelation will turn project_id to project so the above condition will match
-                  )
-                ) allRelations
-              
-              findRelation s nodeTableName parentNodeTableName (Just rd) = 
-                find (\r ->
-                  s == tableSchema (relTable r) && -- match schema for relation table
-                  s == tableSchema (relFTable r) && -- match schema for relation foriegn table
-                  (
-
-                    -- (request)        => clients { ..., project.client_id{...} }
-                    -- will match
-                    -- (relation type)  => parent
-                    -- (entity)         => clients  {id}
-                    -- (foriegn entity) => projects {client_id}
-                    (
-                      nodeTableName == tableName (relTable r) && -- match relation table name
-                      parentNodeTableName == tableName (relFTable r) && -- && -- match relation foreign table name
-                      length (relColumns r) == 1 &&
-                      rd == (colName . unsafeHead . relColumns) r
-                    ) 
-                    ||
-
-
-                    -- (request)        => tasks { ..., users.tasks_users{...} }
-                    -- will match
-                    -- (relation type)  => many
-                    -- (entity)         => users
-                    -- (foriegn entity) => tasks
-                    (
-                      relType r == Many &&
-                      nodeTableName == tableName (relTable r) && -- match relation table name
-                      parentNodeTableName == tableName (relFTable r) && -- match relation foreign table name
-                      rd == tableName (fromJust (relLTable r))
-                    ) 
-                  )
-                ) allRelations
-              n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString)
-        addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail))
-        addRel (query', (n, _, a, _)) r = (query' {from=fromRelation}, (n, Just r, a, Nothing))
-          where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query')
-
-    _ -> n' <$> updateForest (Just (n' forest))
-      where
-        n' = Node (query, (name, Just r, alias, Nothing))
-        t = Table schema name Nothing True -- !!! TODO find another way to get the table from the query
-        r = Relation t [] t [] Root Nothing Nothing Nothing
+    Just (Node (Select{from=[parentNodeTable]}, _) _) ->
+      let newFrom r = (\tName -> if tName == nodeName then tableName (relTable r) else tName) <$> from query
+          newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel
+          rel :: Either ApiRequestError Relation
+          rel = note (NoRelationBetween parentNodeTable nodeName) $
+                findRelation schema allRelations nodeName parentNodeTable relationDetail in
+      Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest)
+    _ ->
+      let rn = (query, (nodeName, Just r, alias, Nothing, depth))
+          r = Relation t [] t [] Root Nothing Nothing Nothing
+          t = Table schema nodeName Nothing True in -- !!! TODO find another way to get the table from the query
+      Node rn <$> updateForest (Just $ Node rn forest)
   where
     updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
-    updateForest n = mapM (addRelations schema allRelations n) forest
+    updateForest rq = mapM (addRelations schema allRelations rq) forest
 
-addJoinFilters :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest
-addJoinFilters schema (Node node@(query, nodeProps@(_, relation, _, _)) forest) =
+findRelation :: Schema -> [Relation] -> NodeName -> TableName -> Maybe RelationDetail -> Maybe Relation
+findRelation schema allRelations nodeTableName parentNodeTableName relationDetail =
+  find (\Relation{relTable, relColumns, relFTable, relFColumns, relType, relLinkTable} ->
+    -- Both relation ends need to be on the exposed schema
+    schema == tableSchema relTable && schema == tableSchema relFTable &&
+    case relationDetail of
+      Nothing ->
+
+        -- (request)        => projects { ..., clients{...} }
+        -- will match
+        -- (relation type)  => parent
+        -- (entity)         => clients  {id}
+        -- (foriegn entity) => projects {client_id}
+        (
+          nodeTableName == tableName relTable && -- match relation table name
+          parentNodeTableName == tableName relFTable -- match relation foreign table name
+        ) ||
+
+        -- (request)        => projects { ..., client_id{...} }
+        -- will match
+        -- (relation type)  => parent
+        -- (entity)         => clients  {id}
+        -- (foriegn entity) => projects {client_id}
+        (
+          parentNodeTableName == tableName relFTable &&
+          length relFColumns == 1 &&
+          -- match common foreign key names(table_name_id, table_name_fk) to table_name
+          (toS ("^" <> colName (unsafeHead relFColumns) <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS nodeTableName :: BS.ByteString)
+        )
+
+        -- (request)        => project_id { ..., client_id{...} }
+        -- will match
+        -- (relation type)  => parent
+        -- (entity)         => clients  {id}
+        -- (foriegn entity) => projects {client_id}
+        -- this case works becasue before reaching this place
+        -- addRelation will turn project_id to project so the above condition will match
+
+      Just rd ->
+
+        -- (request)        => clients { ..., projects.client_id{...} }
+        -- will match
+        -- (relation type)  => child
+        -- (entity)         => clients  {id}
+        -- (foriegn entity) => projects {client_id}
+        (
+          relType == Child &&
+          nodeTableName == tableName relTable && -- match relation table name
+          parentNodeTableName == tableName relFTable && -- match relation foreign table name
+          length relColumns == 1 &&
+          rd == colName (unsafeHead relColumns)
+        ) ||
+
+        -- (request)        => message { ..., person_detail.sender{...} }
+        -- will match
+        -- (relation type)  => parent
+        -- (entity)         => message  {sender}
+        -- (foriegn entity) => person_detail {id}
+        (
+          relType == Parent &&
+          nodeTableName == tableName relTable && -- match relation table name
+          parentNodeTableName == tableName relFTable && -- match relation foreign table name
+          length relFColumns == 1 &&
+          rd == colName (unsafeHead relFColumns)
+        ) ||
+
+        -- (request)        => tasks { ..., users.tasks_users{...} }
+        -- will match
+        -- (relation type)  => many
+        -- (entity)         => users
+        -- (foriegn entity) => tasks
+        (
+          relType == Many &&
+          nodeTableName == tableName relTable && -- match relation table name
+          parentNodeTableName == tableName relFTable && -- match relation foreign table name
+          rd == tableName (fromJust relLinkTable)
+        )
+  ) allRelations
+
+addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest
+addJoinConditions schema (Node node@(query, nodeProps@(_, relation, _, _, _)) forest) =
   case relation of
     Just Relation{relType=Root} -> Node node  <$> updatedForest -- this is the root node
-    Just Relation{relType=Parent} -> Node node <$> updatedForest
+    Just rel@Relation{relType=Parent} -> Node (augmentQuery rel, nodeProps) <$> updatedForest
     Just rel@Relation{relType=Child} -> Node (augmentQuery rel, nodeProps) <$> updatedForest
-    Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->
+    Just rel@Relation{relType=Many, relLinkTable=(Just linkTable)} ->
       let rq = augmentQuery rel in
       Node (rq{from=tableName linkTable:from rq}, nodeProps) <$> updatedForest
     _ -> Left UnknownRelation
   where
-    updatedForest = mapM (addJoinFilters schema) forest
-    augmentQuery rel = foldr addFilterToReadQuery query (getJoinFilters rel)
-    addFilterToReadQuery flt rq@Select{where_=lf} = rq{where_=addFilterToLogicForest flt lf}::ReadQuery
+    updatedForest = mapM (addJoinConditions schema) forest
+    augmentQuery rel = foldr addJoinCond query (getJoinConditions rel)
+    addJoinCond :: JoinCondition -> ReadQuery -> ReadQuery
+    addJoinCond jc rq@Select{joinConditions=jcs} = rq{joinConditions=jc:jcs}
+
+getJoinConditions :: Relation -> [JoinCondition]
+getJoinConditions (Relation Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fcs typ lt lc1 lc2) =
+  if | typ == Child || typ == Parent ->
+        zipWith (toJoinCondition tN ftN) cols fcs
+     | typ == Many ->
+        let ltN = fromMaybe "" (tableName <$> lt) in
+        zipWith (toJoinCondition tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toJoinCondition ftN ltN) fcs (fromMaybe [] lc2)
+     | typ == Root -> undefined
+  where
+    toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition
+    toJoinCondition tb ftb c fc =
+      JoinCondition (QualifiedIdentifier tSchema tb, Nothing, colName c)
+                    (QualifiedIdentifier tSchema ftb, Nothing, colName fc)
 
 addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest)
 addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
@@ -222,9 +256,11 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
     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)
-      | action == ActionRead || action == ActionInvoke = (iFilters apiRequest, iLogic apiRequest)
-      | otherwise = join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
+    (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)]
@@ -237,7 +273,7 @@ addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest
 addFilter = addProperty addFilterToNode
 
 addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest
-addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f
+addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f
 
 addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest
 addOrder = addProperty addOrderToNode
@@ -255,53 +291,35 @@ addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest
 addLogicTree = addProperty addLogicTreeToNode
 
 addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest
-addProperty f ([], a) n = f a n
-addProperty f (path, a) (Node rn forest) =
-  case targetNode of
+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:restForest)
+    Just tn -> Node rn (addProperty f (remainingPath, a) tn:delete tn forest)
   where
-    targetNodeName:remainingPath = path
-    (targetNode,restForest) = splitForest targetNodeName forest
-    splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode)
-    splitForest name forst =
-      case maybeNode of
-        Nothing -> (Nothing,forest)
-        Just node -> (Just node, delete node forest)
-      where
-        maybeNode :: Maybe ReadRequest
-        maybeNode = find fnd forst
-          where
-            fnd :: ReadRequest -> Bool
-            fnd (Node (_,(n,_,_,_)) _) = n == name
+    pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest
 
--- in a relation where one of the tables mathces "TableName"
--- replace the name to that table with pg_source
--- this "fake" relations is needed so that in a mutate query
--- we can look a the "returning *" part which is wrapped with a "with"
--- as just another table that has relations with other tables
-toSourceRelation :: TableName -> Relation -> Maybe Relation
-toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
-  | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}
-  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}
-  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}
-  | otherwise = Nothing
-
-mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest
-mutateRequest apiRequest fldNames = mapLeft apiRequestError $
+mutateRequest :: ApiRequest -> TableName -> [Text] -> [FieldName] -> Either Response MutateRequest
+mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $
   case action of
-    ActionCreate -> Right $ Insert rootTableName payload returnings
-    ActionUpdate -> Update rootTableName <$> pure payload <*> combinedLogic <*> pure returnings
-    ActionDelete -> Delete rootTableName <$> combinedLogic <*> pure returnings
-    _        -> Left UnsupportedVerb
+    ActionCreate -> Right $ Insert tName pkCols payload (iPreferResolution apiRequest) [] returnings
+    ActionUpdate -> Update tName payload <$> 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 tName pkCols payload (Just MergeDuplicates) <$> combinedLogic <*> pure returnings
+        else
+          Left InvalidFilters) =<< filters
+    ActionDelete -> Delete tName <$> combinedLogic <*> pure returnings
+    _            -> Left UnsupportedVerb
   where
     action = iAction apiRequest
     payload = fromJust $ iPayload apiRequest
-    rootTableName = -- TODO: Make it safe
-      let target = iTarget apiRequest in
-      case target of
-        (TargetIdent (QualifiedIdentifier _ t) ) -> t
-        _ -> undefined
     returnings = if iPreferRepresentation apiRequest == None then [] else fldNames
     filters = map snd <$> mapM pRequestFilter mutateFilters
     logic = map snd <$> mapM pRequestLogicTree logicFilters
@@ -315,7 +333,7 @@ fieldNames (Node (sel, _) forest) =
   map (fst . view _1) (select sel) ++ map colName fks
   where
     fks = concatMap (fromMaybe [] . f) forest
-    f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _, _)) _) = Just cols
+    f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _, _, _)) _) = Just cols
     f _ = Nothing
 
 -- Traditional filters(e.g. id=eq.1) are added as root nodes of the LogicTree

src/PostgREST/DbStructure.hs

@@ -3,10 +3,14 @@
 {-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeSynonymInstances  #-}
+{-# LANGUAGE NamedFieldPuns  #-}
 module PostgREST.DbStructure (
   getDbStructure
 , accessibleTables
+, accessibleProcs
 , schemaDescription
+, getPgVersion
+, fillSessionWithSettings
 ) where
 
 import qualified Hasql.Decoders                as HD
@@ -15,10 +19,11 @@ import qualified Hasql.Query                   as H
 
 import           Control.Applicative
 import qualified Data.HashMap.Strict           as M
-import           Data.List                     (elemIndex)
-import           Data.Maybe                    (fromJust)
+import qualified Data.List                     as L
+import           Data.Set                      as S (fromList)
 import           Data.Text                     (split, strip,
-                                                breakOn, dropAround)
+                                                breakOn, dropAround,
+                                                splitOn)
 import qualified Data.Text                     as T
 import qualified Hasql.Session                 as H
 import           PostgREST.Types
@@ -28,25 +33,29 @@ import           GHC.Exts                      (groupWith)
 import           Protolude
 import           Unsafe (unsafeHead)
 
-getDbStructure :: Schema -> H.Session DbStructure
-getDbStructure schema = do
-  tabs <- H.query () allTables
-  cols <- H.query () $ allColumns tabs
-  syns <- H.query () $ allSynonyms cols
-  rels <- H.query () $ allRelations tabs cols
-  keys <- H.query () $ allPrimaryKeys tabs
-  procs <- H.query schema accessibleProcs
+import           Data.Functor.Contravariant    (contramap)
+import           Contravariant.Extras          (contrazip2)
 
-  let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels
-      cols' = addForeignKeys rels' cols
-      keys' = synonymousPrimaryKeys syns keys
+getDbStructure :: Schema -> PgVersion -> H.Session DbStructure
+getDbStructure schema pgVer = do
+  tabs      <- H.query () allTables
+  cols      <- H.query schema $ allColumns tabs
+  syns      <- H.query () $ allSynonyms cols
+  childRels <- H.query () $ allChildRelations tabs cols
+  keys      <- H.query () $ allPrimaryKeys tabs
+  procs     <- H.query schema allProcs
+
+  let rels = addManyToManyRelations . addParentRelations $ addViewRelations syns childRels
+      cols' = addForeignKeys rels cols
+      keys' = addViewPrimaryKeys syns keys
 
   return DbStructure {
       dbTables = tabs
     , dbColumns = cols'
-    , dbRelations = rels'
+    , dbRelations = rels
     , dbPrimaryKeys = keys'
     , dbProcs = procs
+    , pgVersion = pgVer
     }
 
 decodeTables :: HD.Result [Table]
@@ -91,7 +100,7 @@ decodePks tables =
  where
   pkRow = (,,) <$> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text
 
-decodeSynonyms :: [Column] -> HD.Result [(Column,Column)]
+decodeSynonyms :: [Column] -> HD.Result [Synonym]
 decodeSynonyms cols =
   mapMaybe (synonymFromRow cols) <$> HD.rowsList synRow
  where
@@ -100,59 +109,66 @@ decodeSynonyms cols =
     <*> HD.value HD.text <*> HD.value HD.text
     <*> HD.value HD.text <*> HD.value HD.text
 
-accessibleProcs :: H.Query Schema (M.HashMap Text ProcDescription)
-accessibleProcs =
-  H.statement sql (HE.value HE.text)
-    (M.fromList . map addName <$>
-      HD.rowsList (
-        ProcDescription <$> HD.value HD.text
-                        <*> HD.nullableValue HD.text
-                        <*> (parseArgs <$> HD.value HD.text)
-                        <*> (parseRetType <$>
-                            HD.value HD.text <*>
-                            HD.value HD.text <*>
-                            HD.value HD.bool <*>
-                            HD.value HD.char)
-                        <*> (parseVolatility <$>
-                            HD.value HD.char)
-      )
-    ) True
- where
-  addName :: ProcDescription -> (Text, ProcDescription)
-  addName pd = (pdName pd, pd)
+decodeProcs :: HD.Result (M.HashMap Text [ProcDescription])
+decodeProcs =
+  -- Duplicate rows for a function means they're overloaded, order these by least args according to ProcDescription Ord instance
+  map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowsList tblRow
+  where
+    tblRow = ProcDescription
+              <$> HD.value HD.text
+              <*> HD.nullableValue HD.text
+              <*> (parseArgs <$> HD.value HD.text)
+              <*> (parseRetType
+                  <$> HD.value HD.text
+                  <*> HD.value HD.text
+                  <*> HD.value HD.bool
+                  <*> HD.value HD.char)
+              <*> (parseVolatility <$> HD.value HD.char)
 
-  parseArgs :: Text -> [PgArg]
-  parseArgs = mapMaybe (parseArg . strip) . split (==',')
+    addName :: ProcDescription -> (Text, ProcDescription)
+    addName pd = (pdName pd, pd)
 
-  parseArg :: Text -> Maybe PgArg
-  parseArg a =
-    let (body, def) = breakOn " DEFAULT " a
-        (name, typ) = breakOn " " body in
-    if T.null typ
-       then Nothing
-       else Just $
-         PgArg (dropAround (== '"') name) (strip typ) (T.null def)
+    parseArgs :: Text -> [PgArg]
+    parseArgs = mapMaybe parseArg . filter (not . isPrefixOf "OUT" . toS) . map strip . split (==',')
 
-  parseRetType :: Text -> Text -> Bool -> Char -> RetType
-  parseRetType schema name isSetOf typ
-    | 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
+    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)
 
-  parseVolatility :: Char -> ProcVolatility
-  parseVolatility 'i' = Immutable
-  parseVolatility 's' = Stable
-  parseVolatility 'v' = Volatile
-  parseVolatility _   = Volatile -- should not happen, but be pessimistic
+    parseRetType :: Text -> Text -> Bool -> Char -> RetType
+    parseRetType schema name isSetOf typ
+      | 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
 
-  sql = [q|
+    parseVolatility :: Char -> ProcVolatility
+    parseVolatility v | v == 'i' = Immutable
+                      | v == 's' = Stable
+                      | otherwise = Volatile -- only 'v' can happen here
+
+allProcs :: H.Query Schema (M.HashMap Text [ProcDescription])
+allProcs = H.statement (toS procsSqlQuery) (HE.value HE.text) decodeProcs True
+
+accessibleProcs :: H.Query Schema (M.HashMap Text [ProcDescription])
+accessibleProcs = H.statement (toS sql) (HE.value HE.text) decodeProcs True
+  where
+    sql = procsSqlQuery <> " AND has_function_privilege(p.oid, 'execute')"
+
+procsSqlQuery :: SqlQuery
+procsSqlQuery = [q|
   SELECT p.proname as "proc_name",
          d.description as "proc_description",
          pg_get_function_arguments(p.oid) as "args",
@@ -167,11 +183,12 @@ accessibleProcs =
     JOIN pg_namespace tn ON tn.oid = t.typnamespace
     LEFT JOIN pg_class comp ON comp.oid = t.typrelid
     LEFT JOIN pg_catalog.pg_description as d on d.objoid = p.oid
-  WHERE  pn.nspname = $1|]
+  WHERE  pn.nspname = $1
+|]
 
 schemaDescription :: H.Query Schema (Maybe Text)
 schemaDescription =
-    H.statement sql (HE.value HE.text) (HD.singleRow $ HD.nullableValue HD.text) True
+    H.statement sql (HE.value HE.text) (join <$> HD.maybeRow (HD.nullableValue HD.text)) True
   where
     sql = [q|
       select
@@ -202,7 +219,7 @@ accessibleTables =
       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')
+      c.relkind in ('v', 'r', 'm', 'f')
       and n.nspname = $1
       and (
         pg_has_role(c.relowner, 'USAGE'::text)
@@ -211,18 +228,6 @@ accessibleTables =
       )
     order by relname |]
 
-synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]]
-synonymousColumns allSyns cols = synCols'
-  where
-    syns = case headMay cols of
-            Just firstCol -> sort $ filter ((== colTable firstCol) . colTable . fst) allSyns
-            Nothing -> []
-    synCols  = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols
-    synCols' = (filter sameTable . filter matchLength) synCols
-    matchLength cs = length cols == length cs
-    sameTable (c:cs) = all (\cc -> colTable c == colTable cc) (c:cs)
-    sameTable [] = False
-
 addForeignKeys :: [Relation] -> [Column] -> [Column]
 addForeignKeys rels = map addFk
   where
@@ -231,35 +236,84 @@ addForeignKeys rels = map addFk
     lookupFn :: Column -> Relation -> Bool
     lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child
     relToFk col Relation{relColumns=cols, relFColumns=colsF} = do
-      pos <- elemIndex col cols
+      pos <- L.elemIndex col cols
       colF <- atMay colsF pos
       return $ ForeignKey colF
 
-addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation]
-addSynonymousRelations _ [] = []
-addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynonymousRelations syns rels
-  where
-    synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs})
-    synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs})
-    synRels cols mapFn = map (\cs -> mapFn (colTable $ unsafeHead cs) cs) $ synonymousColumns syns cols
+{-
+Adds Views Child Relations based on Synonyms found, the logic is as follows:
+
+Having a Relation{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relType=Child} represented by:
+
+t1.c1------t2.c2
+
+When only having a t1_view.c1 synonym, we need to add a View to Table Relation
+
+         t1.c1----t2.c2         t1.c1----------t2.c2
+                         ->            --------/
+                                      /
+      t1_view.c1             t1_view.c1
+
+
+When only having a t2_view.c2 synonym, we need to add a Table to View Relation
+
+         t1.c1----t2.c2               t1.c1----------t2.c2
+                               ->          \--------
+                                                    \
+                    t2_view.c2                      t2_view.c1
+
+When having t1_view.c1 and a t2_view.c2 synonyms, we need to add a View to View Relation in addition to the prior
+
+         t1.c1----t2.c2               t1.c1----------t2.c2
+                               ->          \--------/
+                                           /        \
+    t1_view.c1     t2_view.c2     t1_view.c1-------t2_view.c1
+
+The logic for composite pks is similar just need to make sure all the Relation columns have synonyms.
+-}
+addViewRelations :: [Synonym] -> [Relation] -> [Relation]
+addViewRelations allSyns = concatMap (\rel ->
+  rel : case rel of
+    Relation{relType=Child, relTable, relColumns, relFTable, relFColumns} ->
+
+      let colSynsGroupedByView :: [Column] -> [[Synonym]]
+          colSynsGroupedByView relCols = L.groupBy (\(_, viewCol1) (_, viewCol2) -> colTable viewCol1 == colTable viewCol2) $
+                                         filter (\(c, _) -> c `elem` relCols) allSyns
+          colsSyns = colSynsGroupedByView relColumns
+          fColsSyns = colSynsGroupedByView relFColumns
+          getView :: [Synonym] -> Table
+          getView = colTable . snd . unsafeHead
+          syns `allSynsOf` cols = S.fromList (fst <$> syns) == S.fromList cols in
+
+      -- View Table Relations
+      [Relation (getView syns) (snd <$> syns) relFTable relFColumns Child Nothing Nothing Nothing
+        | syns <- colsSyns, syns `allSynsOf` relColumns] ++
+
+      -- Table View Relations
+      [Relation relTable relColumns (getView fSyns) (snd <$> fSyns) Child Nothing Nothing Nothing
+        | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns] ++
+
+      -- View View Relations
+      [Relation (getView syns) (snd <$> syns) (getView fSyns) (snd <$> fSyns) Child Nothing Nothing Nothing
+        | syns <- colsSyns, fSyns <- fColsSyns, syns `allSynsOf` relColumns, fSyns `allSynsOf` relFColumns]
+
+    _ -> [])
 
 addParentRelations :: [Relation] -> [Relation]
-addParentRelations [] = []
-addParentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : addParentRelations rels
+addParentRelations = concatMap (\rel@(Relation t c ft fc _ _ _ _) -> [rel, Relation ft fc t c Parent Nothing Nothing Nothing])
 
 addManyToManyRelations :: [Relation] -> [Relation]
 addManyToManyRelations rels = rels ++ addMirrorRelation (mapMaybe link2Relation links)
   where
     links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels
     groupFn :: Relation -> Text
-    groupFn Relation{relTable=Table{tableSchema=s, tableName=t}} = s<>"_"<>t
+    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']
-    addMirrorRelation [] = []
-    addMirrorRelation (rel@(Relation t c ft fc _ lt lc1 lc2):rels') = Relation ft fc t c Many lt lc2 lc1 : rel : addMirrorRelation rels'
+    addMirrorRelation = concatMap (\rel@(Relation t c ft fc _ lt lc1 lc2) -> [rel, Relation ft fc t c Many lt lc2 lc1])
     link2Relation [
       Relation{relTable=lt, relColumns=lc1, relFTable=t,  relFColumns=c},
       Relation{             relColumns=lc2, relFTable=ft, relFColumns=fc}
@@ -268,25 +322,11 @@ addManyToManyRelations rels = rels ++ addMirrorRelation (mapMaybe link2Relation
       | otherwise = Nothing
     link2Relation _ = Nothing
 
-raiseRelations :: Schema -> [(Column,Column)] -> [Relation] -> [Relation]
-raiseRelations schema syns = map raiseRel
-  where
-    raiseRel rel
-      | tableSchema table == schema = rel
-      | isJust newCols = rel{relFTable=fromJust newTable,relFColumns=fromJust newCols}
-      | otherwise = rel
-      where
-        cols = relFColumns rel
-        table = relFTable rel
-        newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . unsafeHead) (synonymousColumns syns cols)
-        newTable = (colTable . unsafeHead) <$> newCols
-
-synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey]
-synonymousPrimaryKeys _ [] = []
-synonymousPrimaryKeys syns (key:keys) = key : newKeys ++ synonymousPrimaryKeys syns keys
-  where
-    keySyns = filter ((\c -> colTable c == pkTable key && colName c == pkName key) . fst) syns
-    newKeys = map ((\c -> PrimaryKey{pkTable=colTable c,pkName=colName c}) . snd) keySyns
+addViewPrimaryKeys :: [Synonym] -> [PrimaryKey] -> [PrimaryKey]
+addViewPrimaryKeys syns = concatMap (\pk ->
+  let viewPks = (\(_, viewCol) -> PrimaryKey{pkTable=colTable viewCol, pkName=colName viewCol}) <$>
+                filter (\(col, _) -> colTable col == pkTable pk && colName col == pkName pk) syns in
+  pk : viewPks)
 
 allTables :: H.Query () [Table]
 allTables =
@@ -306,14 +346,14 @@ allTables =
           AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable
     FROM pg_class c
     JOIN pg_namespace n ON n.oid = c.relnamespace
-    WHERE c.relkind IN ('v','r','m')
+    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.Query () [Column]
+allColumns :: [Table] -> H.Query Schema [Column]
 allColumns tabs =
-  H.statement sql HE.unit (decodeColumns tabs) True
+  H.statement sql (HE.value HE.text) (decodeColumns tabs) True
  where
   sql = [q|
     SELECT DISTINCT
@@ -331,9 +371,35 @@ allColumns tabs =
         array_to_string(enum_info.vals, ',') AS enum
     FROM (
         /*
-        -- CTE based on information_schema.columns to remove the owner filter
+        -- CTE based on pg_catalog to get only Primary and Foreign key columns outside api schema
         */
-        WITH columns AS (
+        WITH key_columns AS (
+             SELECT
+               r.oid AS r_oid,
+               c.oid AS c_oid,
+               n.nspname,
+               c.relname,
+               r.conname,
+               r.contype,
+               unnest(r.conkey) AS conkey
+             FROM
+               pg_catalog.pg_constraint r,
+               pg_catalog.pg_class c,
+               pg_catalog.pg_namespace n
+             WHERE
+               r.contype IN ('f', 'p')
+               AND c.relkind IN ('r', 'v', 'f', 'mv')
+               AND r.conrelid = c.oid
+               AND c.relnamespace = n.oid
+               AND n.nspname NOT IN ('pg_catalog', 'information_schema', $1)
+        ),
+        /*
+        -- CTE based on information_schema.columns
+        -- changed:
+        -- remove the owner filter
+        -- limit columns to the ones in the api schema or PK/FK columns
+        */
+        columns AS (
             SELECT current_database()::information_schema.sql_identifier AS table_catalog,
                 nc.nspname::information_schema.sql_identifier AS table_schema,
                 c.relname::information_schema.sql_identifier AS table_name,
@@ -411,6 +477,7 @@ allColumns tabs =
                     ELSE 'NO'::text
                 END::information_schema.yes_or_no AS is_updatable
             FROM pg_attribute a
+               LEFT JOIN key_columns kc ON kc.conkey = a.attnum AND kc.c_oid = a.attrelid
                LEFT JOIN pg_catalog.pg_description AS d ON d.objoid = a.attrelid and d.objsubid = a.attnum
                LEFT JOIN pg_attrdef ad ON a.attrelid = ad.adrelid AND a.attnum = ad.adnum
                JOIN (pg_class c
@@ -421,7 +488,12 @@ allColumns tabs =
                JOIN pg_namespace nbt ON bt.typnamespace = nbt.oid) ON t.typtype = 'd'::"char" AND t.typbasetype = bt.oid
                LEFT JOIN (pg_collation co
                JOIN pg_namespace nco ON co.collnamespace = nco.oid) ON a.attcollation = co.oid AND (nco.nspname <> 'pg_catalog'::name OR co.collname <> 'default'::name)
-            WHERE NOT pg_is_other_temp_schema(nc.oid) AND a.attnum > 0 AND NOT a.attisdropped AND (c.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"]))
+            WHERE
+                NOT pg_is_other_temp_schema(nc.oid)
+                AND a.attnum > 0
+                AND NOT a.attisdropped
+                AND (c.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"]))
+                AND (nc.nspname = $1 OR kc.r_oid IS NOT NULL) /*--filter only columns that are FK/PK or in the api schema */
               /*--AND (pg_has_role(c.relowner, 'USAGE'::text) OR has_column_privilege(c.oid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/
         )
         SELECT
@@ -466,8 +538,8 @@ columnFromRow tabs (s, t, n, desc, pos, nul, typ, u, l, p, d, e) = buildColumn <
     parseEnum :: Maybe Text -> [Text]
     parseEnum str = fromMaybe [] $ split (==',') <$> str
 
-allRelations :: [Table] -> [Column] -> H.Query () [Relation]
-allRelations tabs cols =
+allChildRelations :: [Table] -> [Column] -> H.Query () [Relation]
+allChildRelations tabs cols =
   H.statement sql HE.unit (decodeRelations tabs cols) True
  where
   sql = [q|
@@ -617,7 +689,7 @@ pkFromRow :: [Table] -> (Schema, Text, Text) -> Maybe PrimaryKey
 pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n
   where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
 
-allSynonyms :: [Column] -> H.Query () [(Column,Column)]
+allSynonyms :: [Column] -> H.Query () [Synonym]
 allSynonyms cols =
   H.statement sql HE.unit (decodeSynonyms cols) True
  where
@@ -692,9 +764,29 @@ allSynonyms cols =
     order by c.view_schema, c.view_name, c.table_name, c.view_column_name
     |]
 
-synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column)
+synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe Synonym
 synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
   where
     col1 = findCol s1 t1 c1
     col2 = findCol s2 t2 c2
     findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols
+
+getPgVersion :: H.Session PgVersion
+getPgVersion = H.query () $ H.statement sql HE.unit versionRow False
+  where
+    sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"
+    versionRow = HD.singleRow $ PgVersion <$> HD.value HD.int4 <*> HD.value HD.text
+
+fillSessionWithSettings :: [(Text, Text)] -> H.Session ()
+fillSessionWithSettings settings =
+    -- Send all of the config settings to the set_config function, using pgsql's `unnest` to transform arrays of values
+    H.query settings $ H.statement "SELECT set_config(k, v, false) FROM unnest($1, $2) AS f1(k, v)" encoder HD.unit False
+
+  where
+    -- Take a list of (key, value) pairs and encode each as an array to later bind to the query
+    -- see Insert Many section at https://hackage.haskell.org/package/hasql-1.1.1/docs/Hasql-Encoders.html
+    encoder = contramap L.unzip $ contrazip2 (vector HE.text) (vector HE.text)
+      where
+        vector value =
+          HE.value $ HE.array $ HE.arrayDimension foldl' $ HE.arrayValue value
+

src/PostgREST/Error.hs

@@ -10,6 +10,7 @@ module PostgREST.Error (
 , binaryFieldError
 , connectionLostError
 , encodeError
+, gucHeadersError
 ) where
 
 import           Protolude
@@ -22,6 +23,7 @@ import           Network.HTTP.Types.Header
 import qualified Network.HTTP.Types.Status as HT
 import           Network.Wai               (Response, responseLBS)
 import           PostgREST.Types
+import           Text.Read                 (readMaybe)
 
 apiRequestError :: ApiRequestError -> Response
 apiRequestError err =
@@ -37,6 +39,7 @@ apiRequestError err =
         NoRelationBetween _ _ -> HT.status400
         InvalidRange -> HT.status416
         UnknownRelation -> HT.status404
+        InvalidFilters -> HT.status405
 
 simpleError :: HT.Status -> [Header] -> Text -> Response
 simpleError status hdrs message =
@@ -78,6 +81,11 @@ binaryFieldError =
   simpleError HT.status406 [] (toS (toMime CTOctetStream) <>
   " requested but a single column was not selected")
 
+gucHeadersError :: Response
+gucHeadersError =
+ simpleError HT.status500 []
+ "response.headers guc must be a JSON array composed of objects with a single key and a string value"
+
 connectionLostError :: Response
 connectionLostError =
   simpleError HT.status503 [] "Database connection lost, retrying the connection."
@@ -100,6 +108,8 @@ instance JSON.ToJSON ApiRequestError where
     "message" .= ("Could not find foreign keys between these entities, No relation found between " <> parent <> " and " <> child :: Text)]
   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)]
 
 instance JSON.ToJSON P.UsageError where
   toJSON (P.ConnectionError e) = JSON.object [
@@ -109,11 +119,17 @@ instance JSON.ToJSON P.UsageError where
   toJSON (P.SessionError e) = JSON.toJSON e -- H.Error
 
 instance JSON.ToJSON H.Error where
-  toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [
-    "code" .= (toS c::Text),
-    "message" .= (toS m::Text),
-    "details" .= (fmap toS d::Maybe Text),
-    "hint" .= (fmap toS h::Maybe Text)]
+  toJSON (H.ResultError (H.ServerError c m d h)) = case toS c of
+    'P':'T':_ ->
+      JSON.object [
+        "details" .= (fmap toS d::Maybe Text),
+        "hint" .= (fmap toS h::Maybe Text)]
+    _ ->
+      JSON.object [
+        "code" .= (toS c::Text),
+        "message" .= (toS m::Text),
+        "details" .= (fmap toS d::Maybe Text),
+        "hint" .= (fmap toS h::Maybe Text)]
   toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [
     "message" .= (m::Text)]
   toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [
@@ -138,7 +154,7 @@ instance JSON.ToJSON H.Error where
 
 httpStatus :: Bool -> P.UsageError -> HT.Status
 httpStatus _ (P.ConnectionError _) = HT.status503
-httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
+httpStatus authed (P.SessionError (H.ResultError (H.ServerError c m _ _))) =
   case toS c of
     '0':'8':_ -> HT.status503 -- pg connection err
     '0':'9':_ -> HT.status500 -- triggered action exception
@@ -166,6 +182,7 @@ httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
     "42883"   -> HT.status404 -- undefined function
     "42P01"   -> HT.status404 -- undefined table
     "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
+    'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m)
     _         -> HT.status400
 httpStatus _ (P.SessionError (H.ResultError _)) = HT.status500
 httpStatus _ (P.SessionError (H.ClientError _)) = HT.status503

src/PostgREST/Middleware.hs

@@ -5,7 +5,7 @@
 module PostgREST.Middleware where
 
 import           Crypto.JWT
-import           Data.Aeson                    (Value (..))
+import qualified Data.Aeson                    as JSON
 import qualified Data.HashMap.Strict           as M
 import qualified Hasql.Transaction             as H
 
@@ -32,7 +32,7 @@ runWithClaims conf eClaims app req =
     JWTInvalid e -> return $ unauthed $ show e
     JWTMissingSecret -> return $ simpleError status500 [] "Server lacks JWT secret"
     JWTClaims claims -> do
-      H.sql $ toS.mconcat $ setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql
+      H.sql $ toS.mconcat $ setSchemaSql ++ setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql
       mapM_ H.sql customReqCheck
       app req
       where
@@ -41,9 +41,10 @@ runWithClaims conf eClaims app req =
         claimsSql = map (pgFmtEnvVar "request.jwt.claim.") [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]
         setRoleSql = maybeToList $
           (\r -> "set local role " <> r <> ";") . toS . pgFmtLit . unquoted <$> M.lookup "role" claimsWithRole
+        setSchemaSql = ["set schema " <> pgFmtLit (configSchema conf) <> ";"] :: [Text]
         -- role claim defaults to anon if not specified in jwt
         claimsWithRole = M.union claims (M.singleton "role" anon)
-        anon = String . toS $ configAnonRole conf
+        anon = JSON.String . toS $ configAnonRole conf
         customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
   where
     unauthed message = simpleError

src/PostgREST/OpenAPI.hs

@@ -22,7 +22,7 @@ import           Protolude hiding              ((&), Proxy, get, intercalate, dr
 import           Data.Swagger
 
 import           PostgREST.ApiRequest        (ContentType(..))
-import           PostgREST.Config            (prettyVersion)
+import           PostgREST.Config            (prettyVersion, docsVersion)
 import           PostgREST.Types             (Table(..), Column(..), PgArg(..), ForeignKey(..),
                                               PrimaryKey(..), Proxy(..), ProcDescription(..), toMime)
 
@@ -260,7 +260,7 @@ postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
       & description ?~ d)
   & externalDocs ?~ ((mempty :: ExternalDocs)
     & description ?~ "PostgREST Documentation"
-    & url .~ URL "https://postgrest.com/en/latest/api.html")
+    & url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))
   & host .~ h'
   & definitions .~ fromList (map (makeTableDef pks) ti)
   & parameters .~ fromList (makeParamDefs ti)

src/PostgREST/Parsers.hs

@@ -1,6 +1,6 @@
 module PostgREST.Parsers where
 
-import           Protolude                     hiding (try, intercalate, replace)
+import           Protolude                     hiding (try, intercalate, replace, option)
 import           Control.Monad                 ((>>))
 import           Data.Foldable                 (foldl1)
 import qualified Data.HashMap.Strict           as M
@@ -8,20 +8,21 @@ import           Data.Text                     (intercalate, replace, strip)
 import           Data.List                     (init, last)
 import           Data.Tree
 import           Data.Either.Combinators       (mapLeft)
-import           PostgREST.RangeQuery          (NonnegRange,allRange)
+import           PostgREST.RangeQuery          (NonnegRange)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
 import           Text.Parsec.Error
+import           Text.Read                     (read)
 
-pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest
-pRequestSelect rootName selStr =
-  mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
+pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
+pRequestSelect selStr =
+  mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
 
 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 (pOperation pVText pVTextL) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
+    oper = parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
     path = fst <$> treePath
     fld = snd <$> treePath
 
@@ -44,7 +45,7 @@ pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
     path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k
     embedPath = fst <$> path
     op = snd <$> path
-    -- Concat op and v to make pLogicTree argument regular, in the form of "op(.,.)"
+    -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
     logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v)
 
 ws :: Parser Text
@@ -53,21 +54,6 @@ ws = toS <$> many (oneOf " \t")
 lexeme :: Parser a -> Parser a
 lexeme p = ws *> p <* ws
 
-pReadRequest :: Text -> Parser ReadRequest
-pReadRequest rootNodeName = do
-  fieldTree <- pFieldForest
-  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing, Nothing)) []) fieldTree
-  where
-    readQuery = Select [] [rootNodeName] [] Nothing allRange
-    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
-    treeEntry (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) =
-      case fldForest of
-        [] -> Node (q {select=fld:select q}, i) rForest
-        _  -> Node (q, i) newForest
-          where
-            newForest =
-              foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias, relationDetail)) []) fldForest:rForest
-
 pTreePath :: Parser (EmbedPath, Field)
 pTreePath = do
   p <- pFieldName `sepBy1` pDelimiter
@@ -76,16 +62,14 @@ pTreePath = do
 
 pFieldForest :: Parser [Tree SelectItem]
 pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
-
-pFieldTree :: Parser (Tree SelectItem)
-pFieldTree =  try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest)
-          <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest)
-          <|> Node <$> pFieldSelect <*> pure []
+  where
+    pFieldTree :: Parser (Tree SelectItem)
+    pFieldTree =  try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|>
+                  Node <$> pFieldSelect <*> pure []
 
 pStar :: Parser Text
 pStar = toS <$> (string "*" *> pure ("*"::ByteString))
 
-
 pFieldName :: Parser Text
 pFieldName = do
   matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"
@@ -96,7 +80,6 @@ pFieldName = do
     dash :: Parser Char
     dash = isDash *> pure '-'
 
-
 pJsonPathStep :: Parser Text
 pJsonPathStep = toS <$> try (string "->" *> pFieldName)
 
@@ -131,26 +114,32 @@ pFieldSelect = lexeme $
     s <- pStar
     return ((s, Nothing), Nothing, Nothing, Nothing)
 
-pOperation :: Parser Operand -> Parser Operand -> Parser Operation
-pOperation parserVText parserVTextL = try ( string "not" *> pDelimiter *> (Operation True <$> pExpr)) <|> Operation False <$> pExpr
+pOpExpr :: Parser SingleVal -> Parser OpExpr
+pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation
   where
-    pExpr :: Parser (Operator, Operand)
-    pExpr =
-          ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys notInOps)) <*> parserVText)
-      <|> ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys inOps)) <*> parserVTextL)
+    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, ...)"
-    inOps = M.filterWithKey (const . flip elem ["in", "notin"]) operators
-    notInOps = M.difference operators inOps
 
-pVText :: Parser Operand
-pVText = VText . toS <$> many anyChar
+    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
 
-pVTextL :: Parser Operand
-pVTextL =     VTextL <$> try (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))
-          <|> VTextL <$> lexeme pVTextLElement `sepBy1` char ','
+    ops = M.filterWithKey (const . flip notElem ("in":ftsOps)) operators
+    ftsOps = M.keys ftsOperators
 
-pVTextLElement :: Parser Text
-pVTextLElement = try pQuotedValue <|> (toS <$> many (noneOf ",)"))
+pSingleVal :: Parser SingleVal
+pSingleVal = toS <$> many anyChar
+
+pListVal :: Parser ListVal
+pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')
+
+pListElement :: Parser Text
+pListElement = try pQuotedValue <|> (toS <$> many (noneOf ",)"))
 
 pQuotedValue :: Parser Text
 pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",)"))
@@ -159,30 +148,29 @@ pDelimiter :: Parser Char
 pDelimiter = char '.' <?> "delimiter (.)"
 
 pOrder :: Parser [OrderTerm]
-pOrder = lexeme pOrderTerm `sepBy` char ','
+pOrder = lexeme pOrderTerm `sepBy1` char ','
 
 pOrderTerm :: Parser OrderTerm
-pOrderTerm =
-  try ( do
-    c <- pField
-    d <- optionMaybe (try $ pDelimiter *> (
-               try(string "asc" *> pure OrderAsc)
-           <|> try(string "desc" *> pure OrderDesc)
-         ))
-    nls <- optionMaybe (pDelimiter *> (
-                 try(string "nullslast" *> pure OrderNullsLast)
-             <|> try(string "nullsfirst" *> pure OrderNullsFirst)
-           ))
-    return $ OrderTerm c d nls
-  )
-  <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing
+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 <*> pOperation pLogicVText pLogicVTextL
+    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal
     pNot :: Parser Bool
     pNot = try (string "not" *> pDelimiter *> pure True)
            <|> pure False
@@ -192,8 +180,8 @@ pLogicTree = Stmnt <$> try pLogicFilter
                <|> string "or" *> pure Or
                <?> "logic operator (and, or)"
 
-pLogicVText :: Parser Operand
-pLogicVText = VText <$> (try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)")))
+pLogicSingleVal :: Parser SingleVal
+pLogicSingleVal = try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)"))
   where
     pPgArray :: Parser Text
     pPgArray =  do
@@ -202,9 +190,6 @@ pLogicVText = VText <$> (try pQuotedValue <|> try pPgArray <|> (toS <$> many (no
       c <- string "}"
       toS <$> pure (a ++ b ++ c)
 
-pLogicVTextL :: Parser Operand
-pLogicVTextL = VTextL <$> (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))
-
 pLogicPath :: Parser (EmbedPath, Text)
 pLogicPath = do
   path <- pFieldName `sepBy1` pDelimiter
@@ -221,3 +206,25 @@ mapError = mapLeft translateError
         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 "_$@") <|> pQuoted) <?> "attribute name [a..z0..9_$@])"
+  where
+    pQuoted = char '"' *> many (noneOf "\"") <* char '"'
+
+pJSPIdx :: Parser Int
+pJSPIdx = char '[' *> (read <$> many1 digit) <* char ']' <?> "array index [0..n]"

src/PostgREST/QueryBuilder.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE DuplicateRecordFields    #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-|
 Module      : PostgREST.QueryBuilder
@@ -14,12 +16,10 @@ module PostgREST.QueryBuilder (
     callProc
   , createReadStatement
   , createWriteStatement
-  , getJoinFilters
   , pgFmtIdent
   , pgFmtLit
   , requestToQuery
   , requestToCountQuery
-  , sourceCTEName
   , unquoted
   , ResultsWithCount
   , pgFmtEnvVar
@@ -31,15 +31,15 @@ import qualified Hasql.Decoders          as HD
 
 import qualified Data.Aeson              as JSON
 
-import           PostgREST.RangeQuery    (NonnegRange, rangeLimit, rangeOffset, allRange)
-import           Data.Functor.Contravariant (contramap)
+import           PostgREST.Config        (pgVersion96)
+import           PostgREST.RangeQuery    (rangeLimit, rangeOffset, allRange)
 import qualified Data.HashMap.Strict     as HM
 import           Data.Maybe
+import qualified Data.Set                as S
 import           Data.Text               (intercalate, unwords, replace, isInfixOf, toLower)
 import qualified Data.Text as T          (map, takeWhile, null)
 import qualified Data.Text.Encoding as T
 import           Data.Tree               (Tree(..))
-import qualified Data.Vector as V
 import           PostgREST.Types
 import           Text.InterpolatedString.Perl6 (qc)
 import qualified Data.ByteString.Char8   as BS
@@ -77,14 +77,6 @@ decodeStandardMay :: HD.Result (Maybe ResultsWithCount)
 decodeStandardMay =
   HD.maybeRow standardRow
 
-{-| JSON and CSV payloads from the client are given to us as
-    PayloadJSON (objects who all have the same keys),
-    and we turn this into an old fasioned JSON array
--}
-encodeUniformObjs :: HE.Params PayloadJSON
-encodeUniformObjs =
-  contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json)
-
 createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName ->
                        H.Query () ResultsWithCount
 createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =
@@ -106,11 +98,12 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField
     | isJust binaryField = asBinaryF $ fromJust binaryField
     | otherwise = asJsonF
 
+
 createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
                         PreferRepresentation -> [Text] ->
-                        H.Query PayloadJSON (Maybe ResultsWithCount)
+                        H.Query ByteString (Maybe ResultsWithCount)
 createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys =
-  unicodeStatement sql encodeUniformObjs decodeStandardMay True
+  unicodeStatement sql (HE.value HE.unknown) decodeStandardMay True
 
  where
   sql = case rep of
@@ -130,7 +123,7 @@ createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys
       "'' AS total_result_set", -- when updateing it does not make sense
       "pg_catalog.count(_postgrest_t) AS page_total",
       if wantHdrs
-         then locationF pKeys
+         then "coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")"
          else noLocationF <> " AS header",
       if rep == Full
          then bodyF <> " AS body"
@@ -142,38 +135,55 @@ createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys
     | wantSingle = asJsonSingleF
     | otherwise = asJsonF
 
-type ProcResults = (Maybe Int64, Int64, ByteString)
-callProc :: QualifiedIdentifier -> JSON.Object -> Bool -> SqlQuery -> SqlQuery -> NonnegRange ->
-  Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> H.Query () (Maybe ProcResults)
-callProc qi params returnsScalar selectQuery countQuery _ countTotal isSingle paramsAsJson asCsv asBinary binaryField =
-  unicodeStatement sql HE.unit decodeProc True
+type ProcResults = (Maybe Int64, Int64, ByteString, ByteString)
+callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool ->
+            Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool -> PgVersion ->
+            H.Query ByteString (Maybe ProcResults)
+callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField isObject pgVer =
+  unicodeStatement sql (HE.value HE.unknown) decodeProc True
   where
     sql =
      if returnsScalar then [qc|
-       WITH {sourceCTEName} AS ({_callSql})
+       WITH {argsRecord},
+       {sourceCTEName} AS (
+         SELECT {fromQi qi}({args})
+       )
        SELECT
          {countResultF} AS total_result_set,
          1 AS page_total,
-         {scalarBodyF} as body
+         {scalarBodyF} AS body,
+         {responseHeaders} AS response_headers
        FROM ({selectQuery}) _postgrest_t;|]
      else [qc|
-       WITH {sourceCTEName} AS ({_callSql})
+       WITH {argsRecord},
+       {sourceCTEName} AS (
+         SELECT * FROM {fromQi qi}({args})
+       )
        SELECT
          {countResultF} AS total_result_set,
          pg_catalog.count(_postgrest_t) AS page_total,
-         {bodyF} as body
+         {bodyF} AS body,
+         {responseHeaders} AS response_headers
        FROM ({selectQuery}) _postgrest_t;|]
 
+    (argsRecord, args) | paramsAsSingleObject = ("_args_record AS (SELECT NULL)", "$1::json")
+                       | null pgArgs = (ignoredBody, "")
+                       | otherwise = (
+                           unwords [
+                           "_args_record AS (",
+                             "SELECT * FROM " <> (if isObject then "json_to_record" else "json_to_recordset") <> "($1)",
+                             "AS _(" <> intercalate ", " ((\a -> pgaName a <> " " <> pgaType a) <$> pgArgs) <> ")",
+                           ")"]
+                         , intercalate ", " ((\a -> pgaName a <> " := (SELECT " <> pgaName a <> " FROM _args_record)") <$> pgArgs))
     countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text
-    _args = if paramsAsJson
-                then insertableValueWithType "json" $ JSON.Object params
-                else intercalate "," $ map _assignment (HM.toList params)
     _procName = qiName qi
-    _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
-    _callSql = [qc|select * from {fromQi qi}({_args}) |] :: Text
+    responseHeaders =
+      if pgVer >= pgVersion96
+        then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
+        else "'[]'" :: Text
     decodeProc = HD.maybeRow procRow
-    procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
-                   <*> HD.value HD.bytea
+    procRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
+                    <*> HD.value HD.bytea <*> HD.value HD.bytea
     scalarBodyF
      | asBinary = asBinaryF _procName
      | otherwise = "(row_to_json(_postgrest_t)->" <> pgFmtLit _procName <> ")::character varying"
@@ -198,71 +208,64 @@ pgFmtLit x =
 
 requestToCountQuery :: Schema -> DbRequest -> SqlQuery
 requestToCountQuery _ (DbMutate _) = undefined
-requestToCountQuery schema (DbRead (Node (Select _ _ logicForest _ _, (mainTbl, _, _, _)) _)) =
+requestToCountQuery schema (DbRead (Node (Select{where_=logicForest}, (mainTbl, _, _, _, _)) _)) =
  unwords [
    "SELECT pg_catalog.count(*)",
    "FROM ", fromQi qi,
-    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) filteredLogic)) `emptyOnFalse` null filteredLogic
+    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest
    ]
  where
    qi = removeSourceCTESchema schema mainTbl
-   -- all foreing key filters are root nodes(see addFilterToLogicForest), only those are filtered
-   nonFKRoot :: LogicTree -> Bool
-   nonFKRoot (Stmnt (Filter _ Operation{expr=(_, VForeignKey _ _)})) = False
-   nonFKRoot (Stmnt _) = True
-   nonFKRoot Expr{} = True
-   filteredLogic = filter nonFKRoot logicForest
 
 requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery
-requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest ord range, (nodeName, maybeRelation, _, _)) forest)) =
-  query
+requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest joinConditions_ ordts range, (nodeName, maybeRelation, _, _, depth)) forest)) =
+  unwords [
+    "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
+    "FROM " <> intercalate ", " tables,
+    unwords joins,
+    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConds))
+      `emptyOnFalse` (null logicForest && null joinConds),
+    ("ORDER BY " <> intercalate ", " (map (pgFmtOrderTerm qi) ordts)) `emptyOnFalse` null ordts,
+    ("LIMIT " <> maybe "ALL" show (rangeLimit range) <> " OFFSET " <> show (rangeOffset range)) `emptyOnFalse` (isParent || range == allRange) ]
+
   where
     mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)
-    qi = removeSourceCTESchema schema mainTbl
-    toQi = removeSourceCTESchema schema
-    query = unwords [
-      "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
-      "FROM ", intercalate ", " (map (fromQi . toQi) tbls),
-      unwords joins,
-      ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,
-      orderF (fromMaybe [] ord),
-      if isParent then "" else limitF range
-      ]
-    orderF ts =
-        if null ts
-            then ""
-            else "ORDER BY " <> clause
-        where
-            clause = intercalate "," (map queryTerm ts)
-            queryTerm :: OrderTerm -> Text
-            queryTerm t = " "
-                <> toS (pgFmtField qi $ otTerm t) <> " "
-                <> maybe "" show (otDirection t) <> " "
-                <> maybe "" show (otNullOrder t) <> " "
+    isSelfJoin = maybe False (\r -> relType r /= Root && relTable r == relFTable r) maybeRelation
+    (qi, tables, joinConds) =
+      let depthAlias name dpth = if dpth /= 0  then name <> "_" <> show dpth else name in -- Root node doesn't get aliased
+      if isSelfJoin
+        then (
+          QualifiedIdentifier "" (depthAlias mainTbl depth),
+          (\t -> fromQi (removeSourceCTESchema schema t) <> " AS " <> pgFmtIdent (depthAlias t depth)) <$> tbls,
+          (\(JoinCondition (qi1, _, c1) (qi2, _, c2)) ->
+            JoinCondition (qi1, Just $ depthAlias (qiName qi1) depth, c1)
+                          (qi2, Just $ depthAlias (qiName qi2) (depth - 1), c2)) <$> joinConditions_)
+        else (
+          removeSourceCTESchema schema mainTbl,
+          fromQi . removeSourceCTESchema schema <$> tbls,
+          joinConditions_)
+
     (joins, selects) = foldr getQueryParts ([],[]) forest
 
     getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
-    getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}}, alias, _)) forst) (j,s) = (j,sel:s)
+    getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (j,sel:s)
       where
         sel = "COALESCE(("
-           <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
+           <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) "
            <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
            <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
            where subquery = requestToQuery schema False (DbRead (Node n forst))
-    getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias, _)) forst) (j,s) = (joi:j,sel:s)
+    getQueryParts (Node n@(_, (name, Just Relation{relType=Parent,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (joi:j,sel:s)
       where
-        node_name = fromMaybe name alias
-        local_table_name = table <> "_" <> node_name
-        replaceTableName localTableName (Filter a (Operation b (c, VForeignKey (QualifiedIdentifier "" _) d))) = Filter a (Operation b (c, VForeignKey (QualifiedIdentifier "" localTableName) d))
-        replaceTableName _ x = x
-        sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name
-        joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name  <>
-              " ON " <> intercalate " AND " ( map (pgFmtFilter qi . replaceTableName local_table_name) (getJoinFilters r) )
+        aliasOrName = fromMaybe name alias
+        localTableName = pgFmtIdent $ table <> "_" <> aliasOrName
+        sel = "row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName
+        joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> localTableName <> " ON TRUE "
           where subquery = requestToQuery schema True (DbRead (Node n forst))
-    getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias, _)) forst) (j,s) = (j,sel:s)
+    getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (j,sel:s)
       where
         sel = "COALESCE (("
-           <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
+           <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) "
            <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
            <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
            where subquery = requestToQuery schema False (DbRead (Node n forst))
@@ -270,47 +273,64 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest
     --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
     --posible relations are Child Parent Many
     getQueryParts _ _ = undefined
-requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) =
-  insInto <> vals <> ret
-  where qi = QualifiedIdentifier schema mainTbl
-        cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
-        colsString = intercalate ", " cols
-        insInto = unwords [ "INSERT INTO" , fromQi qi,
-            if T.null colsString then "" else "(" <> colsString <> ")"
-          ]
-        vals = unwords $
-          if T.null colsString
-            then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"]
-            else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"]
-        ret = if null returnings
-                  then ""
-                  else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)]
-requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) logicForest returnings)) =
-  case rows V.!? 0 of
-    Just obj ->
-      let assignments = map
-            (\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in
+requestToQuery schema _ (DbMutate (Insert mainTbl pkCols p@(PayloadJSON _ pType pKeys) onConflct logicForest returnings)) =
+  unwords [
+    ("WITH " <> ignoredBody) `emptyOnFalse` not payloadIsEmpty,
+    "INSERT INTO ", fromQi qi, if payloadIsEmpty then " " else "(" <> cols <> ")",
+    case (pType, payloadIsEmpty) of
+      (PJArray _, True) -> "SELECT null WHERE false"
+      (PJObject, True)  -> "DEFAULT VALUES"
+      _ -> unwords [
+        "SELECT " <> cols <> " FROM",
+        case pType of
+          PJObject  -> "json_populate_record"
+          PJArray _ -> "json_populate_recordset", "(null::", fromQi qi, ", $1) _",
+        -- Only used for PUT
+        ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier "" "_") <$> logicForest)) `emptyOnFalse` null logicForest],
+    maybe "" (\x -> (
+      "ON CONFLICT(" <> intercalate ", " pkCols <> ") " <> case x of
+      IgnoreDuplicates ->
+        "DO NOTHING"
+      MergeDuplicates  ->
+        "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList pKeys)
+    ) `emptyOnFalse` null pkCols) onConflct,
+    ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings]
+  where
+    qi = QualifiedIdentifier schema mainTbl
+    cols = intercalate ", " $ pgFmtIdent <$> S.toList pKeys
+    payloadIsEmpty = pjIsEmpty p
+requestToQuery schema _ (DbMutate (Update mainTbl p@(PayloadJSON _ pType keys) logicForest returnings)) =
+  if pjIsEmpty p
+    then "WITH " <> ignoredBody <> "SELECT ''"
+    else
       unwords [
-        "UPDATE ", fromQi qi,
-        " SET " <> intercalate "," assignments <> " ",
+        "UPDATE " <> fromQi qi <> " SET " <> cols,
+        "FROM (SELECT * FROM ",
+        case pType of
+           PJObject  -> " json_populate_record"
+           PJArray _ -> " json_populate_recordset", "(null::", fromQi qi, ", $1)) _ ",
         ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,
         ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
         ]
-    Nothing -> undefined
   where
     qi = QualifiedIdentifier schema mainTbl
+    cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList keys)
 requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) =
-  query
+  unwords [
+    "WITH " <> ignoredBody,
+    "DELETE FROM ", fromQi qi,
+    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,
+    ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
+    ]
   where
     qi = QualifiedIdentifier schema mainTbl
-    query = unwords [
-      "DELETE FROM ", fromQi qi,
-      ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,
-      ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
-      ]
 
-sourceCTEName :: SqlFragment
-sourceCTEName = "pg_source"
+-- Due to the use of the `unknown` encoder we need to cast '$1' when the value is not used in the main query
+-- otherwise the query will err with a `could not determine data type of parameter $1`.
+-- This happens because `unknown` relies on the context to determine the value type.
+-- The error also happens on raw libpq used with C.
+ignoredBody :: SqlFragment
+ignoredBody = "ignored_body AS (SELECT $1::text) "
 
 removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
 removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl
@@ -338,7 +358,7 @@ asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
     asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
 
 asJsonF :: SqlFragment
-asJsonF = "coalesce(array_to_json(array_agg(row_to_json(_postgrest_t))), '[]')::character varying"
+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 "
@@ -347,24 +367,12 @@ asBinaryF :: FieldName -> SqlFragment
 asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
 
 locationF :: [Text] -> SqlFragment
-locationF pKeys =
-    "(" <>
-    " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceCTEName <> " as ss  limit 1)" <>
-    " SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))" <>
-    " FROM s, json_each_text(s.r) AS json_data" <>
-    (
-      if null pKeys
-      then ""
-      else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')"
-    ) <> ")"
-
-limitF :: NonnegRange -> SqlFragment
-limitF r  = if r == allRange
-  then ""
-  else "LIMIT " <> limit <> " OFFSET " <> offset
-  where
-    limit  = maybe "ALL" show $ rangeLimit r
-    offset = show $ rangeOffset r
+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
@@ -372,35 +380,12 @@ fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
     n = qiName t
     s = qiSchema t
 
-getJoinFilters :: Relation -> [Filter]
-getJoinFilters (Relation t cols ft fcs typ lt lc1 lc2) =
-  case typ of
-    Child  -> zipWith (toFilter tN ftN) cols fcs
-    Parent -> zipWith (toFilter tN ftN) cols fcs
-    Many   -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2)
-    Root   -> undefined --error "undefined getJoinFilters"
-  where
-    s = if typ == Parent then "" else tableSchema t
-    tN = tableName t
-    ftN = tableName ft
-    ltN = fromMaybe "" (tableName <$> lt)
-    toFilter :: Text -> Text -> Column -> Column -> Filter
-    toFilter tb ftb c fc = Filter (colName c, Nothing) (Operation False ("=", VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})))
-
 unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Query a b
 unicodeStatement = H.statement . T.encodeUtf8
 
 emptyOnFalse :: Text -> Bool -> Text
 emptyOnFalse val cond = if cond then "" else val
 
-insertableValue :: JSON.Value -> SqlFragment
-insertableValue JSON.Null = "null"
-insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v
-
-insertableValueWithType :: Text -> JSON.Value -> SqlFragment
-insertableValueWithType t v =
-  pgFmtLit (unquoted v) <> "::" <> t
-
 pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
 pgFmtColumn table "*" = fromQi table <> ".*"
 pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
@@ -412,44 +397,54 @@ pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment
 pgFmtSelectItem table (f@(_, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs jp alias
 pgFmtSelectItem table (f@(_, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs 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 (Operation hasNot_ ex)) = notOp <> " " <> case ex of
-   (op, VText val) -> pgFmtFieldOp op <> " " <> case op of
-     "like"  -> unknownLiteral (T.map star val)
-     "ilike" -> unknownLiteral (T.map star val)
-     -- TODO: The '@@' was deprecated, remove in v0.5.0.0
-     "@@"    -> "to_tsquery(" <> unknownLiteral val <> ") "
-     "fts"   -> "to_tsquery(" <> unknownLiteral val <> ") "
-     "is"    -> whiteList val
-     "isnot" -> whiteList val
-     _       -> unknownLiteral val
-   (op, VTextL vals) -> pgFmtIn op vals -- in and notin
-   (op, VForeignKey fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName})) ->
-     pgFmtField fQi fld <> " " <> sqlOperator op <> " " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName
+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 ""
+   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"])
-   pgFmtIn :: Operator -> [Text] -> SqlFragment
-   pgFmtIn op vals =
-    -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"
-    let emptyValForIn o = (if "not" `isInfixOf` o then "NOT " else "") -- handle case of "notin" operator
-                          <> pgFmtField table fld <> " = any('{}') " in
-    case T.null <$> headMay vals of
-      Just isNull -> if isNull && length vals == 1
-                        then emptyValForIn op
-                        else pgFmtFieldOp op <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "
-      Nothing -> emptyValForIn op
+
+pgFmtJoinCondition :: JoinCondition -> SqlFragment
+pgFmtJoinCondition (JoinCondition (qi, al1, col1) (QualifiedIdentifier schema fTable, al2, col2)) =
+  pgFmtColumn (fromMaybe qi $ aliasToQi al1) col1 <> " = " <>
+  pgFmtColumn (fromMaybe (removeSourceCTESchema schema fTable) $ aliasToQi al2) col2
+  where
+    aliasToQi al = QualifiedIdentifier "" <$> al
 
 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 (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 :: Maybe JsonPath -> SqlFragment

src/PostgREST/Types.hs

@@ -2,11 +2,12 @@
 module PostgREST.Types where
 import           Protolude
 import qualified GHC.Show
-import           Data.Aeson
+import qualified Data.Aeson           as JSON
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.CaseInsensitive as CI
 import qualified Data.HashMap.Strict  as M
+import qualified Data.Set                  as S
 import           Data.Tree
-import qualified Data.Vector          as V
 import           PostgREST.RangeQuery (NonnegRange)
 import           Network.HTTP.Types.Header (hContentType, Header)
 
@@ -22,28 +23,44 @@ data ApiRequestError = ActionInappropriate
                      | UnknownRelation
                      | NoRelationBetween Text Text
                      | UnsupportedVerb
+                     | InvalidFilters
                      deriving (Show, Eq)
 
+data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq
+instance Show PreferResolution where
+  show MergeDuplicates  = "resolution=merge-duplicates"
+  show IgnoreDuplicates = "resolution=ignore-duplicates"
+
 data DbStructure = DbStructure {
   dbTables      :: [Table]
 , dbColumns     :: [Column]
 , dbRelations   :: [Relation]
 , dbPrimaryKeys :: [PrimaryKey]
-, dbProcs       :: M.HashMap Text ProcDescription
+-- ProcDescription is a list because a function can be overloaded
+, dbProcs       :: M.HashMap Text [ProcDescription]
+, 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)
+} deriving (Show, Eq, Ord)
 
-data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show)
+data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show, Ord)
 
-data RetType = Single PgType | SetOf PgType deriving (Eq, Show)
+data RetType = Single PgType | SetOf PgType deriving (Eq, Show, Ord)
 
 data ProcVolatility = Volatile | Stable | Immutable
-  deriving (Eq, Show)
+  deriving (Eq, Show, Ord)
 
 data ProcDescription = ProcDescription {
   pdName        :: Text
@@ -53,11 +70,17 @@ data ProcDescription = ProcDescription {
 , pdVolatility  :: ProcVolatility
 } deriving (Show, Eq)
 
+-- Order by least number of args in the case of overloaded functions
+instance Ord ProcDescription where
+  ProcDescription name1 des1 args1 rt1 vol1 `compare` ProcDescription name2 des2 args2 rt2 vol2
+    | name1 == name2 && length args1 < length args2  = LT
+    | name1 == name2 && length args1 > length args2  = GT
+    | otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2)
+
 type Schema = Text
 type TableName = Text
 type SqlQuery = Text
 type SqlFragment = Text
-type RequestBody = BL.ByteString
 
 data Table = Table {
   tableSchema      :: Schema
@@ -84,7 +107,9 @@ data Column =
     , colFK          :: Maybe ForeignKey
     } deriving (Show, Ord)
 
-type Synonym = (Column,Column)
+-- | A view column that refers to a table column
+type Synonym = (Column, ViewColumn)
+type ViewColumn = Column
 
 data PrimaryKey = PrimaryKey {
     pkTable :: Table
@@ -93,13 +118,13 @@ data PrimaryKey = PrimaryKey {
 
 data OrderDirection = OrderAsc | OrderDesc deriving (Eq)
 instance Show OrderDirection where
-  show OrderAsc  = "asc"
-  show OrderDesc = "desc"
+  show OrderAsc  = "ASC"
+  show OrderDesc = "DESC"
 
 data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq)
 instance Show OrderNulls where
-  show OrderNullsFirst = "nulls first"
-  show OrderNullsLast  = "nulls last"
+  show OrderNullsFirst = "NULLS FIRST"
+  show OrderNullsLast  = "NULLS LAST"
 
 data OrderTerm = OrderTerm {
   otTerm      :: Field
@@ -110,7 +135,7 @@ data OrderTerm = OrderTerm {
 data QualifiedIdentifier = QualifiedIdentifier {
   qiSchema :: Schema
 , qiName   :: TableName
-} deriving (Show, Eq)
+} deriving (Show, Eq, Ord)
 
 
 data RelationType = Child | Parent | Many | Root deriving (Show, Eq)
@@ -126,18 +151,29 @@ data Relation = Relation {
 , relFTable   :: Table
 , relFColumns :: [Column]
 , relType     :: RelationType
-, relLTable   :: Maybe Table
-, relLCols1   :: Maybe [Column]
-, relLCols2   :: Maybe [Column]
+-- The Link attrs are used when RelationType == Many
+, relLinkTable   :: Maybe Table
+, relLinkCols1   :: Maybe [Column]
+, relLinkCols2   :: Maybe [Column]
 } deriving (Show, Eq)
 
--- | An array of JSON objects that has been verified to have
--- the same keys in every object
-newtype PayloadJSON = PayloadJSON (V.Vector Object)
-  deriving (Show, Eq)
+-- | Cached attributes of a JSON payload
+data PayloadJSON = PayloadJSON {
+-- | This is the raw ByteString that comes from the request body.
+-- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding
+-- had high memory usage, see #1005 for more details
+  pjRaw     :: BL.ByteString
+, pjType    :: PJType
+-- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects
+, pjKeys    :: S.Set Text
+} deriving (Show, Eq)
 
-unPayloadJSON :: PayloadJSON -> V.Vector Object
-unPayloadJSON (PayloadJSON objs) = objs
+data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq)
+
+-- | e.g. whether it is []/{} or not
+pjIsEmpty :: PayloadJSON -> Bool
+pjIsEmpty (PayloadJSON _ PJObject keys) = S.size keys == 0
+pjIsEmpty (PayloadJSON _ (PJArray l) _) = l == 0
 
 data Proxy = Proxy {
   proxyScheme     :: Text
@@ -148,7 +184,7 @@ data Proxy = Proxy {
 
 type Operator = Text
 operators :: M.HashMap Operator SqlFragment
-operators = M.fromList [
+operators = M.union (M.fromList [
   ("eq", "="),
   ("gte", ">="),
   ("gt", ">"),
@@ -158,10 +194,7 @@ operators = M.fromList [
   ("like", "LIKE"),
   ("ilike", "ILIKE"),
   ("in", "IN"),
-  ("notin", "NOT IN"),
-  ("isnot", "IS NOT"),
   ("is", "IS"),
-  ("fts", "@@"),
   ("cs", "@>"),
   ("cd", "<@"),
   ("ov", "&&"),
@@ -169,13 +202,25 @@ operators = M.fromList [
   ("sr", ">>"),
   ("nxr", "&<"),
   ("nxl", "&>"),
-  ("adj", "-|-"),
-  -- TODO: these are deprecated and should be removed in v0.5.0.0
-  ("@@", "@@"),
-  ("@>", "@>"),
-  ("<@", "<@")]
-data Operation = Operation{ hasNot::Bool, expr::(Operator, Operand) } deriving (Eq, Show)
-data Operand = VText Text | VTextL [Text] | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
+  ("adj", "-|-")]) ftsOperators
+
+ftsOperators :: M.HashMap Operator SqlFragment
+ftsOperators = M.fromList [
+  ("fts", "@@ to_tsquery"),
+  ("plfts", "@@ plainto_tsquery"),
+  ("phfts", "@@ phraseto_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
@@ -199,6 +244,25 @@ 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 (Text, Text)
+
+instance JSON.FromJSON GucHeader where
+  parseJSON (JSON.Object o) = case headMay (M.toList o) of
+    Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (k, s)
+                            | otherwise     -> mzero
+    _ -> mzero
+  parseJSON _          = mzero
+
+toHeaders :: [GucHeader] -> [Header]
+toHeaders = map $ \(GucHeader (k, v)) -> (CI.mk $ toS k, toS v)
+
 {-|
   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.
@@ -207,14 +271,18 @@ type RelationDetail = Text
 type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe RelationDetail)
 -- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]
 type EmbedPath = [Text]
-data Filter = Filter { field::Field, operation::Operation } deriving (Show, Eq)
+data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq)
+data JoinCondition = JoinCondition (QualifiedIdentifier, Maybe Alias, FieldName)
+                                   (QualifiedIdentifier, Maybe Alias, FieldName) deriving (Show, Eq)
 
-data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
-data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }
+data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], joinConditions::[JoinCondition], order::[OrderTerm], range_::NonnegRange } deriving (Show, Eq)
+data MutateQuery = Insert { in_::TableName, insPkCols::[Text], qPayload::PayloadJSON, onConflict:: Maybe PreferResolution, where_::[LogicTree], returning::[FieldName] }
                  | Delete { in_::TableName, where_::[LogicTree], returning::[FieldName] }
                  | Update { in_::TableName, qPayload::PayloadJSON, where_::[LogicTree], returning::[FieldName] } deriving (Show, Eq)
-type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail))
+type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail, Depth))
 type ReadRequest = Tree ReadNode
+-- Depth of the ReadRequest tree
+type Depth = Integer
 type MutateRequest = MutateQuery
 data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
 
@@ -237,3 +305,16 @@ toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
 toMime CTOctetStream     = "application/octet-stream"
 toMime CTAny             = "*/*"
 toMime (CTOther ct)      = ct
+
+data PgVersion = PgVersion {
+  pgvNum  :: Int32
+, pgvName :: Text
+} deriving (Eq, Ord, Show)
+
+sourceCTEName :: SqlFragment
+sourceCTEName = "pg_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)

stack.yaml

@@ -1,13 +1,15 @@
-resolver: lts-9.0
+resolver: lts-9.6
 extra-deps:
   - configurator-ng-0.0.0.1
   - critbit-0.2.0.0
-  - hasql-pool-0.4.1
   - hjsonpointer-1.1.1
   - hjsonschema-1.5.0.1
-  - jose-0.5.0.3
   - Ranged-sets-0.3.0
   - protolude-0.2
+  - hasql-1.1
+  - hasql-pool-0.4.3
+  - hasql-transaction-0.5.2
+  - jose-0.7.0.0
 ghc-options:
   postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints
 nix:

test/Feature/AndOrParamsSpec.hs

@@ -27,13 +27,13 @@ spec =
 
       context "embedded levels" $ do
         it "can do logic on the second level" $
-          get "/entities?child_entities.or=(id.eq.1,name.eq.child entity 2)&select=id,child_entities{id}" `shouldRespondWith`
+          get "/entities?child_entities.or=(id.eq.1,name.eq.child entity 2)&select=id,child_entities(id)" `shouldRespondWith`
             [json|[
               {"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`
+          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": []} ]},
@@ -73,15 +73,15 @@ spec =
         it "can handle fts" $ do
           get "/entities?or=(text_search_vector.fts.bar,text_search_vector.fts.baz)&select=id" `shouldRespondWith`
             [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
-          -- TODO: remove in 0.5.0 as deprecated
-          get "/entities?or=(text_search_vector.@@.bar,text_search_vector.@@.baz)&select=id" `shouldRespondWith`
-            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
-        it "can handle cs and cd" $ do
+          get "/tsearch?or=(text_search_vector.plfts(german).Art%20Spass, text_search_vector.plfts(french).amusant%20impossible, 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 "can handle cs and cd" $
           get "/entities?or=(arr.cs.{1,2,3},arr.cd.{1})&select=id" `shouldRespondWith`
             [json|[{ "id": 1 },{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }
-          -- TODO: remove in 0.5.0 as deprecated
-          get "/entities?or=(arr.@>.{1,2,3},arr.<@.{1})&select=id" `shouldRespondWith`
-            [json|[{ "id": 1 },{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }
 
         it "can handle range operators" $ do
           get "/ranges?range=eq.[1,3]&select=id" `shouldRespondWith`
@@ -114,24 +114,15 @@ spec =
             [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
 
         context "operators with not" $ do
-          it "eq, cs, like can be negated" $ do
+          it "eq, cs, like can be negated" $
             get "/entities?and=(arr.not.cs.{1,2,3},and(id.not.eq.2,name.not.like.*3))&select=id" `shouldRespondWith`
               [json|[{ "id": 1}]|] { matchHeaders = [matchContentTypeJson] }
-            -- TODO: remove in 0.5.0 as deprecated
-            get "/entities?and=(arr.not.@>.{1,2,3},and(id.not.eq.2,name.not.like.*3))&select=id" `shouldRespondWith`
-              [json|[{ "id": 1}]|] { matchHeaders = [matchContentTypeJson] }
-          it "in, is, fts can be negated" $ do
+          it "in, is, fts can be negated" $
             get "/entities?and=(id.not.in.(1,3),and(name.not.is.null,text_search_vector.not.fts.foo))&select=id" `shouldRespondWith`
               [json|[{ "id": 2}]|] { matchHeaders = [matchContentTypeJson] }
-            -- TODO: remove in 0.5.0 as deprecated
-            get "/entities?and=(id.not.in.(1,3),and(name.not.is.null,text_search_vector.not.@@.foo))&select=id" `shouldRespondWith`
-              [json|[{ "id": 2}]|] { matchHeaders = [matchContentTypeJson] }
-          it "lt, gte, cd can be negated" $ do
+          it "lt, gte, cd can be negated" $
             get "/entities?and=(arr.not.cd.{1},or(id.not.lt.1,id.not.gte.3))&select=id" `shouldRespondWith`
               [json|[{"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }
-            -- TODO: remove in 0.5.0 as deprecated
-            get "/entities?and=(arr.not.<@.{1},or(id.not.lt.1,id.not.gte.3))&select=id" `shouldRespondWith`
-              [json|[{"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }
           it "gt, lte, ilike can be negated" $
             get "/entities?and=(name.not.ilike.*ITY2,or(id.not.gt.4,id.not.lte.1))&select=id" `shouldRespondWith`
               [json|[{"id": 1}, {"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }
@@ -176,7 +167,7 @@ spec =
 
     context "used with POST" $
       it "includes related data with filters" $
-        request methodPost "/child_entities?entities.or=(id.eq.2,id.eq.3)&select=id,entities{id}"
+        request methodPost "/child_entities?entities.or=(id.eq.2,id.eq.3)&select=id,entities(id)"
           [("Prefer", "return=representation")]
           [json|[{"id":4,"name":"entity 4","parent_id":1},
                  {"id":5,"name":"entity 5","parent_id":2},

test/Feature/AudienceJwtSecretSpec.hs

@@ -0,0 +1,47 @@
+module Feature.AudienceJwtSecretSpec where
+
+-- {{{ Imports
+import Test.Hspec
+import Test.Hspec.Wai
+import Network.HTTP.Types
+
+import SpecHelper
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+-- }}}
+
+spec :: SpecWith Application
+spec = describe "test handling of aud claims in JWT" $ do
+
+  -- this test will stop working 9999999999s after the UNIX EPOCH
+  it "succeeds with jwt token containing with an audience claim" $ do
+    {-  This is the decoded contents of authHeaderJWT
+
+        {
+          "exp": 9999999999,
+          "role": "postgrest_test_author",
+          "id": "jdoe",
+          "aud": "youraudience"
+        }
+
+    -}
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UiLCJhdWQiOiJ5b3VyYXVkaWVuY2UifQ.fJ4tLKSmolWGWehWN20qiU9dMO-WY0RI2VvacL7-ZGo"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200
+
+  it "succeeds with jwt token that does not contain an audience claim" $ do
+    {- This is the decoded contents of authHeaderJWT
+
+        {
+          "exp": 9999999999,
+          "role": "postgrest_test_author",
+          "id": "jdoe"
+        }
+    -}
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200
+
+  it "requests without JWT token should work" $
+    get "/has_count_column" `shouldRespondWith` 200 

test/Feature/AuthSpec.hs

@@ -1,6 +1,5 @@
 module Feature.AuthSpec where
 
--- {{{ Imports
 import Text.Heredoc
 import Test.Hspec
 import Test.Hspec.Wai
@@ -11,7 +10,6 @@ import SpecHelper
 import Network.Wai (Application)
 
 import Protolude hiding (get)
--- }}}
 
 spec :: SpecWith Application
 spec = describe "authorization" $ do
@@ -39,6 +37,17 @@ spec = describe "authorization" $ do
       , matchHeaders = []
       }
 
+  it "denies execution on functions that anonymous does not own" $
+    post "/rpc/privileged_hello" [json|{"name": "anonymous"}|] `shouldRespondWith` 401
+
+  it "allows execution on a function that postgrest_test_author owns" $
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" in
+    request methodPost "/rpc/privileged_hello" [auth] [json|{"name": "jdoe"}|]
+      `shouldRespondWith` [json|"Privileged hello to jdoe"|]
+      { matchStatus = 200
+      , matchHeaders = [matchContentTypeJson]
+      }
+
   it "returns jwt functions as jwt tokens" $
     request methodPost "/rpc/login" [single]
       [json| { "id": "jdoe", "pass": "1234" } |]

test/Feature/DeleteSpec.hs

@@ -36,7 +36,7 @@ spec =
         request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] ""
           `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|]
       it "can embed (parent) entities" $
-        request methodDelete "/tasks?id=eq.8&select=id,name,project{id}" [("Prefer", "return=representation")] ""
+        request methodDelete "/tasks?id=eq.8&select=id,name,project(id)" [("Prefer", "return=representation")] ""
           `shouldRespondWith` [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|]
           { matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "*/*"]

test/Feature/InsertSpec.hs

@@ -49,9 +49,15 @@ spec = do
           , matchHeaders = [matchContentTypeJson]
           }
 
+    context "non uniform json array" $ do
+      it "rejects json array that isn't exclusivily composed of objects" $
+        post "/articles" [json| [{"id": 100, "body": "xxxxx"}, 123, "xxxx", {"id": 111, "body": "xxxx"}] |] `shouldRespondWith` 400
+      it "rejects json array that has objects with different keys" $
+        post "/articles" [json| [{"id": 100, "body": "xxxxx"}, {"id": 111, "body": "xxxx", "owner": "me"}] |] `shouldRespondWith` 400
+
     context "requesting full representation" $ do
       it "includes related data after insert" $
-        request methodPost "/projects?select=id,name,clients{id,name}"
+        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"}}]|]
           { matchStatus  = 201
@@ -416,7 +422,7 @@ spec = do
         -- put value back for other tests
         void $ request methodPatch "/items?id=eq.99" [] [json| { "id":1 } |]
 
-      it "makes no updates and returns 204, when patching with an empty json object" $ do
+      it "makes no updates and returns 204, when patching with an empty json object/array" $ do
         request methodPatch "/items" [] [json| {} |]
           `shouldRespondWith` ""
           {
@@ -424,8 +430,16 @@ spec = do
             matchHeaders = ["Content-Range" <:> "*/*"]
           }
 
-        g <- get "/items"
-        liftIO $ simpleBody g `shouldBe` [json| [{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}] |]
+        request methodPatch "/items" [] [json| [] |]
+          `shouldRespondWith` ""
+          {
+            matchStatus  = 204,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+        get "/items" `shouldRespondWith`
+          [json|[{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}]|]
+          { matchHeaders = [matchContentTypeJson] }
 
       it "makes no updates and and returns 200, when patching with an empty json object and return=rep" $ do
         request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |]
@@ -434,10 +448,10 @@ spec = do
             matchStatus  = 200,
             matchHeaders = ["Content-Range" <:> "*/*"]
           }
-
-        g <- get "/items"
-        liftIO $ simpleBody g `shouldBe` [json| [{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}] |]
-
+        get "/items" `shouldRespondWith`
+          [json| [{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}] |]
+          { matchHeaders = [matchContentTypeJson] }
+  
     context "with unicode values" $
       it "succeeds and returns values intact" $ do
         void $ request methodPost "/no_pk" []

test/Feature/NonexistentSchemaSpec.hs

@@ -0,0 +1,15 @@
+module Feature.NonexistentSchemaSpec where
+
+import Network.Wai (Application)
+import Protolude hiding (get)
+import Test.Hspec
+import Test.Hspec.Wai
+
+spec :: SpecWith Application
+spec =
+  describe "Non existent api schema" $ do
+    it "succeeds when requesting root path" $
+      get "/" `shouldRespondWith` 200
+
+    it "gives 404 when requesting a nonexistent table in this nonexistent schema" $
+      get "/nonexistent_table" `shouldRespondWith` 404

test/Feature/PgVersion96Spec.hs

@@ -0,0 +1,81 @@
+module Feature.PgVersion96Spec where
+
+import Test.Hspec hiding (pendingWith)
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+
+import SpecHelper
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec =
+  describe "features supported on PostgreSQL 9.6" $ do
+    context "GUC headers" $ 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` 500
+        get "/rpc/bad_guc_headers_2" `shouldRespondWith` 500
+        get "/rpc/bad_guc_headers_3" `shouldRespondWith` 500
+        post "/rpc/bad_guc_headers_1" [json|{}|] `shouldRespondWith` 500
+
+      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 "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

@@ -5,7 +5,6 @@ import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus))
-import Text.Heredoc
 import SpecHelper
 import Network.Wai (Application)
 
@@ -30,15 +29,15 @@ spec =
         simpleStatus r `shouldBe` ok200
 
     it "limit works on all levels" $
-      get "/users?select=id,tasks{id}&order=id.asc&tasks.order=id.asc"
-        `shouldRespondWith` [str|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|]
+      get "/users?select=id,tasks(id)&order=id.asc&tasks.order=id.asc"
+        `shouldRespondWith` [json|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|]
         { matchStatus  = 200
         , matchHeaders = ["Content-Range" <:> "0-1/*"]
         }
 
     it "limit is not applied to parent embeds" $
-      get "/tasks?select=id,project{id}&id=gt.5"
-        `shouldRespondWith` [str|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|]
+      get "/tasks?select=id,project(id)&id=gt.5"
+        `shouldRespondWith` [json|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|]
         { matchStatus  = 200
         , matchHeaders = ["Content-Range" <:> "0-1/*"]
         }

test/Feature/RangeSpec.hs

@@ -9,7 +9,6 @@ import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
 import qualified Data.ByteString.Lazy         as BL
 
 import SpecHelper
-import Text.Heredoc
 import Network.Wai (Application)
 
 import Protolude hiding (get)
@@ -131,28 +130,28 @@ spec = do
       it "no parameters return everything" $
         get "/items?select=id&order=id.asc"
           `shouldRespondWith`
-          [str|[{"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}]|]
+          [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]
           { matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "0-14/*"]
           }
       it "top level limit with parameter" $
         get "/items?select=id&order=id.asc&limit=3"
-          `shouldRespondWith` [str|[{"id":1},{"id":2},{"id":3}]|]
+          `shouldRespondWith` [json|[{"id":1},{"id":2},{"id":3}]|]
           { matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "0-2/*"]
           }
       it "headers override get parameters" $
         request methodGet  "/items?select=id&order=id.asc&limit=3"
                      (rangeHdrs $ ByteRangeFromTo 0 1) ""
-          `shouldRespondWith` [str|[{"id":1},{"id":2}]|]
+          `shouldRespondWith` [json|[{"id":1},{"id":2}]|]
           { matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "0-1/*"]
           }
 
       it "limit works on all levels" $
-        get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=2&projects.tasks.order=id.asc&projects.tasks.limit=1"
+        get "/clients?select=id,projects(id,tasks(id))&order=id.asc&limit=1&projects.order=id.asc&projects.limit=2&projects.tasks.order=id.asc&projects.tasks.limit=1"
           `shouldRespondWith`
-          [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1}]},{"id":2,"tasks":[{"id":3}]}]}]|]
+          [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1}]},{"id":2,"tasks":[{"id":3}]}]}]|]
           { matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "0-0/*"]
           }
@@ -160,7 +159,7 @@ spec = do
 
       it "limit and offset works on first level" $
         get "/items?select=id&order=id.asc&limit=3&offset=2"
-          `shouldRespondWith` [str|[{"id":3},{"id":4},{"id":5}]|]
+          `shouldRespondWith` [json|[{"id":3},{"id":4},{"id":5}]|]
           { matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "2-4/*"]
           }

test/Feature/RpcSpec.hs

@@ -0,0 +1,363 @@
+module Feature.RpcSpec where
+
+import Test.Hspec hiding (pendingWith)
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+import Network.HTTP.Types
+import Network.Wai.Test (SResponse(simpleStatus, simpleBody))
+import qualified Data.ByteString.Lazy as BL (empty)
+
+import SpecHelper
+import Text.Heredoc
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec =
+  describe "remote procedure call" $ do
+    context "a proc that returns a set" $ do
+      it "returns paginated results" $ do
+        request methodPost "/rpc/getitemrange"
+                (rangeHdrs (ByteRangeFromTo 0 0))  [json| { "min": 2, "max": 4 } |]
+           `shouldRespondWith` [json| [{"id":3}] |]
+            { matchStatus = 200
+            , matchHeaders = ["Content-Range" <:> "0-0/*"]
+            }
+        request methodGet "/rpc/getitemrange?min=2&max=4"
+                (rangeHdrs (ByteRangeFromTo 0 0)) ""
+           `shouldRespondWith` [json| [{"id":3}] |]
+            { matchStatus = 200
+            , matchHeaders = ["Content-Range" <:> "0-0/*"]
+            }
+
+      it "includes total count if requested" $ do
+        request methodPost "/rpc/getitemrange"
+                (rangeHdrsWithCount (ByteRangeFromTo 0 0))
+                [json| { "min": 2, "max": 4 } |]
+           `shouldRespondWith` [json| [{"id":3}] |]
+            { matchStatus = 206 -- it now knows the response is partial
+            , matchHeaders = ["Content-Range" <:> "0-0/2"]
+            }
+        request methodGet "/rpc/getitemrange?min=2&max=4"
+                (rangeHdrsWithCount (ByteRangeFromTo 0 0)) ""
+           `shouldRespondWith` [json| [{"id":3}] |]
+            { matchStatus = 206
+            , matchHeaders = ["Content-Range" <:> "0-0/2"]
+            }
+
+      it "returns proper json" $ do
+        post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`
+          [json| [ {"id": 3}, {"id":4} ] |]
+          { matchHeaders = [matchContentTypeJson] }
+        get "/rpc/getitemrange?min=2&max=4" `shouldRespondWith`
+          [json| [ {"id": 3}, {"id":4} ] |]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns CSV" $ do
+        request methodPost "/rpc/getitemrange"
+                (acceptHdrs "text/csv")
+                [json| { "min": 2, "max": 4 } |]
+           `shouldRespondWith` "id\n3\n4"
+            { matchStatus = 200
+            , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
+            }
+        request methodGet "/rpc/getitemrange?min=2&max=4"
+                (acceptHdrs "text/csv") ""
+           `shouldRespondWith` "id\n3\n4"
+            { matchStatus = 200
+            , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
+            }
+
+    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
+
+    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}]|]
+        get "/rpc/getproject?id=1" `shouldRespondWith`
+          [str|[{"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`
+          [json|[{"id":2},{"id":3},{"id":4}]|]
+          { matchHeaders = [matchContentTypeJson] }
+        get "/rpc/getallprojects?id=gt.1&id=lt.5&select=id" `shouldRespondWith`
+          [json|[{"id":2},{"id":3},{"id":4}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "can limit proc results" $ do
+        post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id?limit=2&offset=1" [json| {} |]
+          `shouldRespondWith` [json|[{"id":3},{"id":4}]|]
+             { matchStatus = 200
+             , matchHeaders = ["Content-Range" <:> "1-2/*"] }
+        get "/rpc/getallprojects?id=gt.1&id=lt.5&select=id?limit=2&offset=1"
+          `shouldRespondWith` [json|[{"id":3},{"id":4}]|]
+             { matchStatus = 200
+             , matchHeaders = ["Content-Range" <:> "1-2/*"] }
+
+      it "select works on the first level" $ do
+        post "/rpc/getproject?select=id,name" [json| { "id": 1} |] `shouldRespondWith`
+          [str|[{"id":1,"name":"Windows 7"}]|]
+        get "/rpc/getproject?id=1&select=id,name" `shouldRespondWith`
+          [str|[{"id":1,"name":"Windows 7"}]|]
+
+    context "foreign entities embedding" $ do
+      it "can embed if related tables are in the exposed schema" $ do
+        post "/rpc/getproject?select=id,name,client(id),tasks(id)" [json| { "id": 1} |] `shouldRespondWith`
+          [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|]
+          { matchHeaders = [matchContentTypeJson] }
+        get "/rpc/getproject?id=1&select=id,name,client(id),tasks(id)" `shouldRespondWith`
+          [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "cannot embed if the related table is not in the exposed schema" $ do
+        post "/rpc/single_article?select=*,article_stars(*)" [json|{ "id": 1}|]
+          `shouldRespondWith` 400
+        get "/rpc/single_article?id=1&select=*,article_stars(*)"
+          `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] }
+        get "/rpc/single_article?id=2&select=id,articleStars(userId)"
+          `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+    context "a proc that returns an empty rowset" $
+      it "returns empty json array" $ do
+        post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith`
+          [json| [] |]
+          { matchHeaders = [matchContentTypeJson] }
+        get "/rpc/test_empty_rowset" `shouldRespondWith`
+          [json| [] |]
+          { matchHeaders = [matchContentTypeJson] }
+
+    context "proc return types" $ do
+      context "returns text" $ do
+        it "returns proper json" $
+          post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith`
+            [json|"Hello, world"|]
+            { matchHeaders = [matchContentTypeJson] }
+
+        it "can handle unicode" $
+          post "/rpc/sayhello" [json| { "name": "￥" } |] `shouldRespondWith`
+            [json|"Hello, ￥"|]
+            { matchHeaders = [matchContentTypeJson] }
+
+      it "returns array" $
+        post "/rpc/ret_array" [json|{}|] `shouldRespondWith`
+          [json|[1, 2, 3]|]
+          { 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] }
+
+      it "returns enum value" $
+        post "/rpc/ret_enum" [json|{ "val": "foo" }|] `shouldRespondWith`
+          [json|"foo"|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns domain value" $
+        post "/rpc/ret_domain" [json|{ "val": "8" }|] `shouldRespondWith`
+          [json|8|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns range" $
+        post "/rpc/ret_range" [json|{ "low": 10, "up": 20 }|] `shouldRespondWith`
+          [json|"[10,20)"|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns row of scalars" $
+        post "/rpc/ret_scalars" [json|{}|] `shouldRespondWith`
+          [json|[{"a":"scalars", "b":"foo", "c":1, "d":"[10,20)"}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns composite type in exposed schema" $
+        post "/rpc/ret_point_2d" [json|{}|] `shouldRespondWith`
+          [json|[{"x": 10, "y": 5}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "cannot return composite type in hidden schema" $
+        post "/rpc/ret_point_3d" [json|{}|] `shouldRespondWith` 401
+
+      it "returns single row from table" $
+        post "/rpc/single_article?select=id" [json|{"id": 2}|] `shouldRespondWith`
+          [json|[{"id": 2}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns null for void" $
+        post "/rpc/ret_void" [json|{}|] `shouldRespondWith`
+          [json|null|]
+          { matchHeaders = [matchContentTypeJson] }
+
+    context "improper input" $ do
+      it "rejects unknown content type even if payload is good" $ do
+        request methodPost "/rpc/sayhello"
+          (acceptHdrs "audio/mpeg3") [json| { "name": "world" } |]
+            `shouldRespondWith` 415
+        request methodGet "/rpc/sayhello?name=world"
+          (acceptHdrs "audio/mpeg3") ""
+            `shouldRespondWith` 415
+      it "rejects malformed json payload" $ do
+        p <- request methodPost "/rpc/sayhello"
+          (acceptHdrs "application/json") "sdfsdf"
+        liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
+          isErrorFormat (simpleBody p) `shouldBe` True
+      it "treats simple plpgsql raise as invalid input" $ do
+        p <- post "/rpc/problem" "{}"
+        liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "unsupported verbs" $ do
+      it "DELETE fails" $
+        request methodDelete "/rpc/sayhello" [] ""
+          `shouldRespondWith` 405
+      it "PATCH fails" $
+        request methodPatch "/rpc/sayhello" [] ""
+          `shouldRespondWith` 405
+      it "OPTIONS fails" $
+        -- TODO: should return info about the function
+        request methodOptions "/rpc/sayhello" [] ""
+          `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] }
+
+    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`
+          [json| "Return value of no parameters procedure." |]
+          { matchHeaders = [matchContentTypeJson] }
+      it "interprets empty string as a function with no args on a get request" $
+        get "/rpc/noparamsproc" `shouldRespondWith`
+          [json| "Return value of no parameters procedure." |]
+          { matchHeaders = [matchContentTypeJson] }
+
+    it "returns proper output when having the same return col name as the proc name" $ do
+      post "/rpc/test" [json|{}|] `shouldRespondWith`
+        [json|[{"test":"hello","value":1}]|] { matchHeaders = [matchContentTypeJson] }
+      get "/rpc/test" `shouldRespondWith`
+        [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 a scalar result when there is a single INOUT param" $
+        get "/rpc/single_inout_param?num=2" `shouldRespondWith`
+          [json|3|] { matchHeaders = [matchContentTypeJson] }
+
+      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 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 "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] }
+
+    it "can map a RAISE error code and message to a http status" $
+      get "/rpc/raise_pt402"
+        `shouldRespondWith` [json|{ "hint": "Upgrade your plan", "details": "Quota exceeded" }|]
+        { matchStatus  = 402
+        , matchHeaders = [matchContentTypeJson]
+        }
+
+    it "defaults to status 500 if RAISE code is PT not followed by a number" $
+      get "/rpc/raise_bad_pt" `shouldRespondWith` 500
+
+    context "expects a single json object" $ do
+      it "does not expand posted json into parameters" $
+        request methodPost "/rpc/singlejsonparam"
+          [("prefer","params=single-object")] [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] `shouldRespondWith`
+          [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "accepts parameters from an html form" $
+        request methodPost "/rpc/singlejsonparam"
+          [("Prefer","params=single-object"),("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`
+          [json| { "integer": "7", "double": "2.71828", "varchar" : "forms are fun"
+                 , "boolean":"false", "date":"1900-01-01", "money":"$3.99", "enum":"foo" } |]
+                 { matchHeaders = [matchContentTypeJson] }
+
+      it "works with GET" $
+        request methodGet "/rpc/singlejsonparam?p1=1&p2=text" [("Prefer","params=single-object")] ""
+          `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 "only for POST rpc" $
+      it "gives a parse filter error if GET style proc args are specified" $
+        post "/rpc/sayhello?name=John" [json|{}|] `shouldRespondWith` 400
+
+    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
+
+      it "should filter a proc that has arg name = filter name" $
+        get "/rpc/get_projects_below?id=5&id=gt.2&select=id" `shouldRespondWith`
+          [json|[{ "id": 3 }, { "id": 4 }]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "should work with filters that have the not operator" $ do
+        get "/rpc/get_projects_below?id=5&id=not.gt.2&select=id" `shouldRespondWith`
+          [json|[{ "id": 1 }, { "id": 2 }]|]
+          { matchHeaders = [matchContentTypeJson] }
+        get "/rpc/get_projects_below?id=5&id=not.in.(1,3)&select=id" `shouldRespondWith`
+          [json|[{ "id": 2 }, { "id": 4 }]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "should work with filters that use the plain with language fts operator" $ do
+        get "/rpc/get_tsearch?text_search_vector=fts(english).impossible" `shouldRespondWith`
+          [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|]
+          { matchHeaders = [matchContentTypeJson] }
+        get "/rpc/get_tsearch?text_search_vector=plfts.impossible" `shouldRespondWith`
+          [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|]
+          { matchHeaders = [matchContentTypeJson] }
+        get "/rpc/get_tsearch?text_search_vector=not.fts(english).fun%7Crat" `shouldRespondWith`
+          [json|[{"text_search_vector":"'amus':5 'fair':7 'impossibl':9 'peu':4"},{"text_search_vector":"'art':4 'spass':5 'unmog':7"}]|]
+          { matchHeaders = [matchContentTypeJson] }

test/Feature/SingularSpec.hs

@@ -37,9 +37,10 @@ spec =
           `shouldRespondWith` [str|{"id":5}|]
 
       it "can shape plurality singular object routes" $
-        request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [singular] ""
+        request methodGet "/projects_view?id=eq.1&select=id,name,clients(*),tasks(id,name)" [singular] ""
           `shouldRespondWith`
-            [str|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|]
+            [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"] }
 
     context "when updating rows" $ do
 

test/Feature/StructureSpec.hs

@@ -4,7 +4,9 @@ import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Network.HTTP.Types
 
+import PostgREST.Config (docsVersion)
 import Control.Lens ((^?))
+import Data.Aeson.Types (Value (..))
 import Data.Aeson.Lens
 import Data.Aeson.QQ
 
@@ -27,7 +29,14 @@ spec = do
               (acceptHdrs "application/openapi+json") ""
         `shouldRespondWith` 415
 
-    describe "table" $
+    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 "/"
@@ -76,7 +85,7 @@ spec = do
 
           deleteResponse `shouldBe` Just "No Content"
 
-    it "includes definitions to tables" $ do
+      it "includes definitions to tables" $ do
         r <- simpleBody <$> get "/"
 
         let def = r ^? key "definitions" . key "child_entities"
@@ -108,7 +117,53 @@ spec = do
               }
             |]
 
-    describe "RPC" $
+      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 "RPC" $ do
 
       it "includes body schema for arguments" $ do
         r <- simpleBody <$> get "/"
@@ -150,7 +205,7 @@ spec = do
                     "type": "string"
                   },
                   "enum": {
-                    "format": "test.enum_menagerie_type",
+                    "format": "enum_menagerie_type",
                     "type": "string"
                   },
                   "integer": {
@@ -162,6 +217,37 @@ spec = do
               }
             |]
 
+      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

test/Feature/UpsertSpec.hs

@@ -0,0 +1,200 @@
+module Feature.UpsertSpec where
+
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+import Network.HTTP.Types
+
+import SpecHelper
+import Network.Wai (Application)
+
+import Protolude hiding (get, put)
+import Text.Heredoc
+
+spec :: SpecWith Application
+spec =
+  describe "UPSERT" $ do
+    context "with POST" $ do
+      context "when Prefer: resolution=merge-duplicates is specified" $ do
+        it "INSERTs and UPDATEs rows on pk conflict" $
+          request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]
+            [json| [
+              { "name": "Javascript", "rank": 6 },
+              { "name": "Java", "rank": 2 },
+              { "name": "C", "rank": 1 }
+            ]|] `shouldRespondWith` [json| [
+              { "name": "Javascript", "rank": 6 },
+              { "name": "Java", "rank": 2 },
+              { "name": "C", "rank": 1 }
+            ]|]
+            { matchStatus = 201
+            , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson]
+            }
+
+        it "INSERTs and UPDATEs row on composite pk conflict" $
+          request methodPost "/employees" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]
+            [json| [
+              { "first_name": "Frances M.", "last_name": "Roe", "salary": "30000" },
+              { "first_name": "Peter S.", "last_name": "Yang", "salary": 42000 }
+            ]|] `shouldRespondWith` [json| [
+              { "first_name": "Frances M.", "last_name": "Roe", "salary": "$30,000.00", "company": "One-Up Realty", "occupation": "Author" },
+              { "first_name": "Peter S.", "last_name": "Yang", "salary": "$42,000.00", "company": null, "occupation": null }
+            ]|]
+            { matchStatus = 201
+            , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson]
+            }
+
+      context "when Prefer: resolution=ignore-duplicates is specified" $ do
+        it "INSERTs and ignores rows on pk conflict" $
+          request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]
+            [json|[
+              { "name": "PHP", "rank": 9 },
+              { "name": "Python", "rank": 10 }
+            ]|] `shouldRespondWith` [json|[
+              { "name": "PHP", "rank": 9 }
+            ]|]
+            { matchStatus = 201
+            , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson]
+            }
+
+        it "INSERTs and ignores rows on composite pk conflict" $
+          request methodPost "/employees" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]
+            [json|[
+              { "first_name": "Daniel B.", "last_name": "Lyon", "salary": "72000", "company": null, "occupation": null },
+              { "first_name": "Sara M.", "last_name": "Torpey", "salary": 60000, "company": "Burstein-Applebee", "occupation": "Soil scientist" }
+            ]|] `shouldRespondWith` [json|[
+              { "first_name": "Sara M.", "last_name": "Torpey", "salary": "$60,000.00", "company": "Burstein-Applebee", "occupation": "Soil scientist" }
+            ]|]
+            { matchStatus = 201
+            , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson]
+            }
+
+      it "succeeds if the table has only PK cols and no other cols" $ do
+        request methodPost "/only_pk" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]
+          [json|[ { "id": 1 }, { "id": 2 }, { "id": 3} ]|]
+          `shouldRespondWith`
+          [json|[ { "id": 3} ]|]
+          { matchStatus = 201 ,
+            matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates",
+            matchContentTypeJson] }
+
+        request methodPost "/only_pk" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]
+          [json|[ { "id": 1 }, { "id": 2 }, { "id": 4} ]|]
+          `shouldRespondWith`
+          [json|[ { "id": 1 }, { "id": 2 }, { "id": 4} ]|]
+          { matchStatus = 201 ,
+            matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates",
+            matchContentTypeJson] }
+
+      it "succeeds and ignores the Prefer: resolution header(no Preference-Applied present) if the table has no PK" $
+        request methodPost "/no_pk" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]
+          [json|[ { "a": "1", "b": "0" } ]|]
+          `shouldRespondWith`
+          [json|[ { "a": "1", "b": "0" } ]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] }
+
+      it "succeeds if not a single resource is created" $ do
+        request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]
+          [json|[ { "name": "Java", "rank": 1 } ]|] `shouldRespondWith`
+          [json|[]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] }
+        request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]
+          [json|[ { "name": "Java", "rank": 1 }, { "name": "C", "rank": 2 } ]|] `shouldRespondWith`
+          [json|[]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] }
+
+    context "with PUT" $ do
+      context "Restrictions" $ do
+        it "fails if Range is specified" $
+          request methodPut "/tiobe_pls?name=eq.Javascript" [("Range", "0-5")]
+            [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400
+
+        it "fails if limit is specified" $
+          put "/tiobe_pls?name=eq.Javascript&limit=1"
+            [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400
+
+        it "fails if offset is specified" $
+          put "/tiobe_pls?name=eq.Javascript&offset=1"
+            [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400
+
+        it "fails if the payload has more than one row" $
+          put "/tiobe_pls?name=eq.Go"
+            [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ]|] `shouldRespondWith` 400
+
+        it "fails if not all columns are specified" $ do
+          put "/tiobe_pls?name=eq.Go"
+            [str| [ { "name": "Go" } ]|] `shouldRespondWith` 400
+          put "/employees?first_name=eq.Susan&last_name=eq.Heidt"
+            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000" } ]|] `shouldRespondWith` 400
+
+        it "rejects every other filter than pk cols eq's" $ do
+          put "/tiobe_pls?rank=eq.19" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
+          put "/tiobe_pls?id=not.eq.Java" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
+          put "/tiobe_pls?id=in.(Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
+          put "/tiobe_pls?and=(id.eq.Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
+
+        it "fails if not all composite key cols are specified as eq filters" $ do
+          put "/employees?first_name=eq.Susan"
+            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]
+            `shouldRespondWith` 405
+          put "/employees?last_name=eq.Heidt"
+            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]
+            `shouldRespondWith` 405
+
+      it "fails if the uri primary key doesn't match the payload primary key" $ do
+        put "/tiobe_pls?name=eq.MATLAB"
+          [str| [ { "name": "Perl", "rank": 17 } ]|] `shouldRespondWith` 400
+        put "/employees?first_name=eq.Wendy&last_name=eq.Anderson"
+          [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] `shouldRespondWith` 400
+
+      it "fails if the table has no PK" $
+        put "/no_pk?a=eq.one&b=eq.two" [str| [ { "a": "one", "b": "two" } ]|] `shouldRespondWith` 405
+
+      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] }
+
+        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
+          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] }
+
+        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] }
+
+      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] }
+
+        it "succeeds on table with composite pk" $ do
+          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] }
+          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"
+            `shouldRespondWith`
+            [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$60,000.00", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|]
+            { matchHeaders = [matchContentTypeJson] }
+
+        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] }
+
+      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 } ]|]
+          `shouldRespondWith` [json|{ "name": "Ruby", "rank": 11 }|] { matchHeaders = [matchContentTypeSingular] }

test/Main.hs

@@ -5,14 +5,19 @@ import SpecHelper
 
 import qualified Hasql.Pool as P
 
-import PostgREST.DbStructure (getDbStructure)
 import PostgREST.App (postgrest)
+import PostgREST.Config (pgVersion95, pgVersion96, configSettings)
+import PostgREST.DbStructure (getDbStructure, getPgVersion, fillSessionWithSettings)
+import PostgREST.Types (DbStructure(..))
+import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction)
 import Data.Function (id)
 import Data.IORef
+import Data.Time.Clock (getCurrentTime)
 
 import qualified Feature.AuthSpec
 import qualified Feature.AsymmetricJwtSpec
 import qualified Feature.BinaryJwtSecretSpec
+import qualified Feature.AudienceJwtSecretSpec
 import qualified Feature.ConcurrentSpec
 import qualified Feature.CorsSpec
 import qualified Feature.DeleteSpec
@@ -26,6 +31,10 @@ import qualified Feature.SingularSpec
 import qualified Feature.UnicodeSpec
 import qualified Feature.ProxySpec
 import qualified Feature.AndOrParamsSpec
+import qualified Feature.RpcSpec
+import qualified Feature.NonexistentSchemaSpec
+import qualified Feature.PgVersion96Spec
+import qualified Feature.UpsertSpec
 
 import Protolude
 
@@ -36,17 +45,47 @@ main = do
 
   pool <- P.acquire (3, 10, toS testDbConn)
 
-  result <- P.use pool $ getDbStructure "test"
-  refDbStructure <- newIORef $ Just $ either (panic.show) id result
-  let withApp      = return $ postgrest (testCfg testDbConn)          refDbStructure pool $ pure ()
-      ltdApp       = return $ postgrest (testLtdRowsCfg testDbConn)   refDbStructure pool $ pure ()
-      unicodeApp   = return $ postgrest (testUnicodeCfg testDbConn)   refDbStructure pool $ pure ()
-      proxyApp     = return $ postgrest (testProxyCfg testDbConn)     refDbStructure pool $ pure ()
-      noJwtApp     = return $ postgrest (testCfgNoJWT testDbConn)     refDbStructure pool $ pure ()
-      binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool $ pure ()
-      asymJwkApp   = return $ postgrest (testCfgAsymJWK testDbConn)   refDbStructure pool $ pure ()
+  result <- P.use pool $ getDbStructure "test" =<< getPgVersion
+
+  dbStructure <- pure $ either (panic.show) id result
+
+  getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }
+
+  refDbStructure <- newIORef $ Just dbStructure
+
+  let withApp              = return $ postgrest (testCfg testDbConn)            refDbStructure pool getTime $ pure ()
+      ltdApp               = return $ postgrest (testLtdRowsCfg testDbConn)     refDbStructure pool getTime $ pure ()
+      unicodeApp           = return $ postgrest (testUnicodeCfg testDbConn)     refDbStructure pool getTime $ pure ()
+      proxyApp             = return $ postgrest (testProxyCfg testDbConn)       refDbStructure pool getTime $ pure ()
+      noJwtApp             = return $ postgrest (testCfgNoJWT testDbConn)       refDbStructure pool getTime $ pure ()
+      binaryJwtApp         = return $ postgrest (testCfgBinaryJWT testDbConn)   refDbStructure pool getTime $ pure ()
+      audJwtApp            = return $ postgrest (testCfgAudienceJWT testDbConn) refDbStructure pool getTime $ pure ()
+      asymJwkApp           = return $ postgrest (testCfgAsymJWK testDbConn)     refDbStructure pool getTime $ pure ()
+      nonexistentSchemaApp = return $ postgrest (testNonexistentSchemaCfg testDbConn)   refDbStructure pool getTime $ pure ()
+
+  let reset :: IO ()
+      reset = P.use pool (fillSessionWithSettings (configSettings $ testCfg testDbConn)) >> resetDb testDbConn
+
+      actualPgVersion = pgVersion dbStructure
+      extraSpecs =
+        [("Feature.UpsertSpec", Feature.UpsertSpec.spec) | actualPgVersion >= pgVersion95] ++
+        [("Feature.PgVersion96Spec", Feature.PgVersion96Spec.spec) | actualPgVersion >= pgVersion96]
+
+      specs = uncurry describe <$> [
+          ("Feature.AuthSpec"               , Feature.AuthSpec.spec)
+        , ("Feature.ConcurrentSpec"         , Feature.ConcurrentSpec.spec)
+        , ("Feature.CorsSpec"               , Feature.CorsSpec.spec)
+        , ("Feature.DeleteSpec"             , Feature.DeleteSpec.spec)
+        , ("Feature.InsertSpec"             , Feature.InsertSpec.spec)
+        , ("Feature.QuerySpec"              , Feature.QuerySpec.spec)
+        , ("Feature.RpcSpec"                , Feature.RpcSpec.spec)
+        , ("Feature.RangeSpec"              , Feature.RangeSpec.spec)
+        , ("Feature.SingularSpec"           , Feature.SingularSpec.spec)
+        , ("Feature.StructureSpec"          , Feature.StructureSpec.spec)
+        , ("Feature.AndOrParamsSpec"        , Feature.AndOrParamsSpec.spec)
+        , ("Feature.NonexistentSchemaSpec"  , Feature.NonexistentSchemaSpec.spec)
+        ] ++ extraSpecs
 
-  let reset = resetDb testDbConn
   hspec $ do
     mapM_ (beforeAll_ reset . before withApp) specs
 
@@ -70,20 +109,14 @@ main = do
     beforeAll_ reset . before binaryJwtApp $
       describe "Feature.BinaryJwtSecretSpec" Feature.BinaryJwtSecretSpec.spec
 
+    -- this test runs with a binary JWT secret and an audience claim
+    beforeAll_ reset . before audJwtApp $
+      describe "Feature.AudienceJwtSecretSpec" Feature.AudienceJwtSecretSpec.spec
+
     -- this test runs with asymmetric JWK
     beforeAll_ reset . before asymJwkApp $
       describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec
 
- where
-  specs = map (uncurry describe) [
-      ("Feature.AuthSpec"         , Feature.AuthSpec.spec)
-    , ("Feature.ConcurrentSpec"   , Feature.ConcurrentSpec.spec)
-    , ("Feature.CorsSpec"         , Feature.CorsSpec.spec)
-    , ("Feature.DeleteSpec"       , Feature.DeleteSpec.spec)
-    , ("Feature.InsertSpec"       , Feature.InsertSpec.spec)
-    , ("Feature.QuerySpec"        , Feature.QuerySpec.spec)
-    , ("Feature.RangeSpec"        , Feature.RangeSpec.spec)
-    , ("Feature.SingularSpec"     , Feature.SingularSpec.spec)
-    , ("Feature.StructureSpec"    , Feature.StructureSpec.spec)
-    , ("Feature.AndOrParamsSpec"  , Feature.AndOrParamsSpec.spec)
-    ]
+    -- this test runs with a nonexistent db-schema
+    beforeAll_ reset . before nonexistentSchemaApp $
+      describe "Feature.NonexistentSchemaSpec" Feature.NonexistentSchemaSpec.spec

test/SpecHelper.hs

@@ -17,6 +17,7 @@ import           System.Process (readProcess)
 import           Text.Heredoc
 
 import PostgREST.Config (AppConfig(..))
+import PostgREST.Types  (JSPathExp(..))
 
 import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
@@ -68,11 +69,16 @@ _baseCfg :: AppConfig
 _baseCfg =  -- Connection Settings
   AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000
             -- Jwt settings
-            (Just $ encodeUtf8 "reallyreallyreallyreallyverysafe") False
+            (Just $ encodeUtf8 "reallyreallyreallyreallyverysafe") False Nothing
             -- Connection Modifiers
             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"])
 
 testCfg :: Text -> AppConfig
 testCfg testDbConn = _baseCfg { configDatabase = testDbConn }
@@ -95,12 +101,22 @@ testCfgBinaryJWT testDbConn = (testCfg testDbConn) {
       "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU="
   }
 
+testCfgAudienceJWT :: Text -> AppConfig
+testCfgAudienceJWT testDbConn = (testCfg testDbConn) {
+    configJwtSecret = Just . B64.decodeLenient $
+      "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU=",
+    configJwtAudience = Just "youraudience"
+  }
+
 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"}|]
   }
 
+testNonexistentSchemaCfg :: Text -> AppConfig
+testNonexistentSchemaCfg testDbConn = (testCfg testDbConn) { configSchema = "nonexistent" }
+
 setupDb :: Text -> IO ()
 setupDb dbConn = do
   loadFixture dbConn "database"

test/fixtures/data.sql

@@ -248,7 +248,9 @@ INSERT INTO nullable_integer VALUES (NULL);
 TRUNCATE TABLE tsearch CASCADE;
 INSERT INTO tsearch VALUES (to_tsvector('It''s kind of fun to do the impossible'));
 INSERT INTO tsearch VALUES (to_tsvector('But also fun to do what is possible'));
-
+INSERT INTO tsearch VALUES (to_tsvector('Fat cats ate rats'));
+INSERT INTO tsearch VALUES (to_tsvector('french', 'C''est un peu amusant de faire l''impossible'));
+INSERT INTO tsearch VALUES (to_tsvector('german', 'Es ist eine Art Spaß, das Unmögliche zu machen')); 
 
 --
 -- Data for Name: users_projects; Type: TABLE DATA; Schema: test; Owner: -
@@ -321,6 +323,91 @@ INSERT INTO ranges VALUES (2, '[3,6]');
 INSERT INTO ranges VALUES (3, '[6,9]');
 INSERT INTO ranges VALUES (4, '[9,12]');
 
---
--- PostgreSQL database dump complete
---
+TRUNCATE TABLE being CASCADE;
+INSERT INTO being VALUES (1), (2), (3), (4);
+
+TRUNCATE TABLE descendant CASCADE;
+INSERT INTO descendant VALUES (1,1), (2,1), (3,1), (4,2);
+
+TRUNCATE TABLE part CASCADE;
+INSERT INTO part VALUES (1), (2), (3), (4);
+
+TRUNCATE TABLE being_part CASCADE;
+INSERT INTO being_part VALUES (1,1), (2,1), (3,2), (4,3);
+
+TRUNCATE TABLE employees CASCADE;
+INSERT INTO employees VALUES
+  ('Frances M.', 'Roe', '24000', 'One-Up Realty', 'Author'),
+  ('Daniel B.', 'Lyon', '36000', 'Dubrow''s Cafeteria', 'Packer'),
+  ('Edwin S.', 'Smith', '48000', 'Pro Garden Management', 'Marine biologist');
+
+TRUNCATE TABLE tiobe_pls CASCADE;
+INSERT INTO tiobe_pls VALUES ('Java', 1), ('C', 2), ('Python', 4);
+
+TRUNCATE TABLE only_pk CASCADE;
+INSERT INTO only_pk VALUES (1), (2);
+
+TRUNCATE TABLE family_tree CASCADE;
+INSERT INTO family_tree VALUES ('1', 'Parental Unit', NULL);
+INSERT INTO family_tree VALUES ('2', 'Kid One', '1');
+INSERT INTO family_tree VALUES ('3', 'Kid Two', '1');
+INSERT INTO family_tree VALUES ('4', 'Grandkid One', '2');
+INSERT INTO family_tree VALUES ('5', 'Grandkid Two', '3');
+
+TRUNCATE TABLE organizations CASCADE;
+INSERT INTO organizations VALUES (1, 'Referee Org', null, null);
+INSERT INTO organizations VALUES (2, 'Auditor Org', null, null);
+INSERT INTO organizations VALUES (3, 'Acme', 1, 2);
+INSERT INTO organizations VALUES (4, 'Umbrella', 1, 2);
+
+SET search_path = private, pg_catalog;
+
+TRUNCATE TABLE authors CASCADE;
+INSERT INTO authors VALUES (1, 'George Orwell');
+INSERT INTO authors VALUES (2, 'Anne Frank');
+INSERT INTO authors VALUES (3, 'Antoine de Saint-Exupéry');
+INSERT INTO authors VALUES (4, 'J.D. Salinger');
+INSERT INTO authors VALUES (5, 'Ray Bradbury');
+INSERT INTO authors VALUES (6, 'William Golding');
+INSERT INTO authors VALUES (7, 'Harper Lee');
+INSERT INTO authors VALUES (8, 'Kurt Vonnegut');
+INSERT INTO authors VALUES (9, 'Ken Kesey');
+
+TRUNCATE TABLE books CASCADE;
+INSERT INTO books VALUES (1, '1984', 1949, 1);
+INSERT INTO books VALUES (2, 'The Diary of a Young Girl', 1947, 2);
+INSERT INTO books VALUES (3, 'The Little Prince', 1947, 3);
+INSERT INTO books VALUES (4, 'The Catcher in the Rye', 1951, 4);
+INSERT INTO books VALUES (5, 'Farenheit 451', 1953, 5);
+INSERT INTO books VALUES (6, 'Lord of the Flies', 1954, 6);
+INSERT INTO books VALUES (7, 'To Kill a Mockingbird', 1960, 7);
+INSERT INTO books VALUES (8, 'Slaughterhouse-Five', 1969, 8);
+INSERT INTO books VALUES (9, 'One Flew Over the Cuckoo''s Nest', 1962, 9);
+
+SET search_path = test, pg_catalog;
+
+TRUNCATE TABLE person CASCADE;
+
+INSERT INTO person VALUES (1, 'John');
+INSERT INTO person VALUES (2, 'Jane');
+INSERT INTO person VALUES (3, 'Jake');
+INSERT INTO person VALUES (4, 'Julie');
+
+TRUNCATE TABLE message CASCADE;
+INSERT INTO message VALUES (1, 'Hello Jane', 1, 2);
+INSERT INTO message VALUES (2, 'Hi John', 2, 1);
+INSERT INTO message VALUES (3, 'How are you doing?', 1, 2);
+INSERT INTO message VALUES (4, 'Hey Julie', 3, 4);
+INSERT INTO message VALUES (5, 'What''s up Jake', 4, 3);
+
+TRUNCATE TABLE space CASCADE;
+INSERT INTO space VALUES (1, 'space 1');
+
+TRUNCATE TABLE zone CASCADE;
+INSERT INTO zone VALUES (1, 'zone 1', 2, 1);
+INSERT INTO zone VALUES (2, 'zone 2', 2, 1);
+INSERT INTO zone VALUES (3, 'store 3', 3, 1);
+INSERT INTO zone VALUES (4, 'store 4', 3, 1);
+
+-- for foreign table projects_dump
+copy (select id, name, client_id from projects) to '/tmp/projects_dump.csv' with csv;

test/fixtures/jwt.sql

@@ -4,7 +4,6 @@ set client_min_messages to warning;
 DROP SCHEMA IF EXISTS jwt CASCADE;
 CREATE SCHEMA jwt;
 
-
 CREATE OR REPLACE FUNCTION jwt.url_encode(data bytea) RETURNS text LANGUAGE sql AS $$
     SELECT translate(encode(data, 'base64'), E'+/=\n', '-_');
 $$;
@@ -31,7 +30,7 @@ WITH
       WHEN algorithm = 'HS384' THEN 'sha384'
       WHEN algorithm = 'HS512' THEN 'sha512'
       ELSE '' END)  -- hmac throws error
-SELECT jwt.url_encode(hmac(signables, secret, (select * FROM alg)));
+SELECT jwt.url_encode(public.hmac(signables, secret, (select * FROM alg)));
 $$;
 
 

test/fixtures/privileges.sql

@@ -57,6 +57,28 @@ GRANT ALL ON TABLE
     , child_entities
     , grandchild_entities
     , ranges
+    , being
+    , descendant
+    , being_part
+    , part
+    , leak
+    , perf_articles
+    , employees
+    , tiobe_pls
+    , only_pk
+    , family_tree
+    , organizations
+    , authors
+    , books
+    , forties_books
+    , fifties_books
+    , sixties_books
+    , person
+    , message
+    , person_detail
+    , space
+    , zone
+    , projects_dump
 TO postgrest_test_anonymous;
 
 GRANT INSERT ON TABLE insertonly TO postgrest_test_anonymous;
@@ -65,6 +87,7 @@ GRANT USAGE ON SEQUENCE
       auto_incrementing_pk_id_seq
     , items_id_seq
     , callcounter_count
+    , leak_id_seq
 TO postgrest_test_anonymous;
 
 -- Privileges for non anonymous users
@@ -74,3 +97,8 @@ GRANT ALL ON TABLE authors_only TO postgrest_test_author;
 GRANT SELECT (article_id, user_id) ON TABLE limited_article_stars TO postgrest_test_anonymous;
 GRANT INSERT (article_id, user_id) ON TABLE limited_article_stars TO postgrest_test_anonymous;
 GRANT UPDATE (article_id, user_id) ON TABLE limited_article_stars TO postgrest_test_anonymous;
+
+REVOKE EXECUTE ON FUNCTION privileged_hello(text) FROM PUBLIC; -- All functions are available to every role(PUBLIC) by default
+GRANT EXECUTE ON FUNCTION privileged_hello(text) TO postgrest_test_author;
+
+GRANT USAGE ON SCHEMA test TO postgrest_test_default_role;

test/fixtures/schema.sql

@@ -112,16 +112,19 @@ CREATE TABLE items (
 );
 
 
-SET search_path = public, pg_catalog;
-
---
--- Name: always_true(test.items); Type: FUNCTION; Schema: public; Owner: -
---
-
 CREATE FUNCTION always_true(test.items) RETURNS boolean
     LANGUAGE sql STABLE
     AS $$ SELECT true $$;
 
+CREATE FUNCTION anti_id(test.items) RETURNS bigint
+    LANGUAGE sql STABLE
+    AS $_$ SELECT $1.id * -1 $_$;
+
+SET search_path = public, pg_catalog;
+
+CREATE FUNCTION always_false(test.items) RETURNS boolean
+    LANGUAGE sql STABLE
+    AS $$ SELECT false $$;
 
 create table public_consumers (
     id                  serial             not null unique,
@@ -136,16 +139,6 @@ create table public_orders (
     primary key (id)
 );
 
---
--- Name: anti_id(test.items); Type: FUNCTION; Schema: public; Owner: -
---
-
-CREATE FUNCTION anti_id(test.items) RETURNS bigint
-    LANGUAGE sql STABLE
-    AS $_$ SELECT $1.id * -1 $_$;
-
-
-
 SET search_path = تست, pg_catalog;
 
 CREATE TABLE موارد (
@@ -638,6 +631,9 @@ CREATE TABLE no_pk (
     b character varying
 );
 
+CREATE TABLE only_pk (
+    id integer primary key
+);
 
 --
 -- Name: nullable_integer; Type: TABLE; Schema: test; Owner: -
@@ -1096,6 +1092,12 @@ CREATE FUNCTION getproject(id int) RETURNS SETOF projects
     SELECT * FROM test.projects WHERE id = $1;
 $_$;
 
+CREATE FUNCTION get_projects_below(id int) RETURNS SETOF projects
+    LANGUAGE sql
+    AS $_$
+    SELECT * FROM test.projects WHERE id < $1;
+$_$;
+
 CREATE FUNCTION getallprojects() RETURNS SETOF projects
     LANGUAGE sql
     AS $_$
@@ -1241,6 +1243,211 @@ create function test.test() returns table(test text, value int) as $$
   values ('hello', 1);
 $$ language sql;
 
---
--- PostgreSQL database dump complete
---
+create function test.privileged_hello(name text) returns text as $$
+  select 'Privileged hello to ' || $1;
+$$ language sql;
+
+create function test.get_tsearch() returns setof test.tsearch AS $$
+  SELECT * FROM test.tsearch;
+$$ language sql;
+
+create table test.being (
+  being int primary key not null
+);
+
+create table test.descendant (
+  descendant int primary key not null,
+  being int references test.being(being)
+);
+
+create table test.part (
+  part int primary key not null
+);
+
+create table test.being_part (
+  being int not null references test.being(being),
+  part int not null references test.part(part)
+);
+
+create function test.single_out_param(num int, OUT num_plus_one int) AS $$
+  select num + 1;
+$$ language sql;
+
+create function test.single_json_out_param(a int, b text, OUT my_json pg_catalog.json) AS $$
+  select json_build_object('a', a, 'b', b);
+$$ language sql;
+
+create function test.many_out_params(OUT my_json pg_catalog.json, OUT num int, OUT str text) AS $$
+  select '{"a": 1, "b": "two"}'::json, 3, 'four'::text;
+$$ language sql;
+
+create function test.single_inout_param(INOUT num int) AS $$
+  select num + 1;
+$$ language sql;
+
+create function test.many_inout_params(INOUT num int, INOUT str text, INOUT b bool DEFAULT true) AS $$
+  select num, str, b;
+$$ language sql;
+
+create or replace function test.raise_pt402() returns void as $$
+begin
+  raise sqlstate 'PT402' using message = 'Payment Required',
+                               detail = 'Quota exceeded',
+                               hint = 'Upgrade your plan';
+end;
+$$ language plpgsql;
+
+create or replace function test.raise_bad_pt() returns void as $$
+begin
+  raise sqlstate 'PT40A' using message = 'Wrong';
+end;
+$$ language plpgsql;
+
+create or replace function test.get_projects_and_guc_headers() returns setof test.projects as $$
+  set local "response.headers" = '[{"X-Test": "key1=val1; someValue; key2=val2"}, {"X-Test-2": "key1=val1"}]';
+  select * from test.projects;
+$$ language sql;
+
+create or replace function test.get_int_and_guc_headers(num int) returns integer as $$
+  set local "response.headers" = '[{"X-Test":"key1=val1; someValue; key2=val2"},{"X-Test-2":"key1=val1"}]';
+  select num;
+$$ language sql;
+
+create or replace function test.bad_guc_headers_1() returns void as $$
+  set local "response.headers" = '{"X-Test": "invalid structure for headers"}';
+$$ language sql;
+
+create or replace function test.bad_guc_headers_2() returns void as $$
+  set local "response.headers" = '["invalid", "structure", "for", "headers"]';
+$$ language sql;
+
+create or replace function test.bad_guc_headers_3() returns void as $$
+  set local "response.headers" = '{"X-Test": "invalid", "X-Test-2": "structure", "X-Test-3": "for headers"}';
+$$ language sql;
+
+create or replace function test.set_cookie_twice() returns void as $$
+  set local "response.headers" = '[{"Set-Cookie": "sessionid=38afes7a8; HttpOnly; Path=/"}, {"Set-Cookie": "id=a3fWa; Expires=Wed, 21 Oct 2015 07:28:00 GMT; Secure; HttpOnly"}]';
+$$ language sql;
+
+create or replace function test.three_defaults(a int default 1, b int default 2, c int default 3) returns int as $$
+select a + b + c
+$$ language sql;
+
+create or replace function test.overloaded() returns setof int as $$
+  values (1), (2), (3);
+$$ language sql;
+
+create or replace function test.overloaded(pg_catalog.json) returns table(x int, y text) as $$
+  select * from json_to_recordset($1) as r(x int, y text);
+$$ language sql;
+
+create or replace function test.overloaded(a int, b int) returns int as $$
+  select a + b
+$$ language sql;
+
+create or replace function test.overloaded(a text, b text, c text) returns text as $$
+  select a || b || c
+$$ language sql;
+
+create table test.leak(
+  id serial primary key,
+  blob bytea
+);
+
+create function test.leak(blob bytea) returns void as $$ begin end; $$ language plpgsql;
+
+create table test.perf_articles(
+  id integer not null,
+  body text not null
+);
+
+create table test.employees(
+  first_name text,
+  last_name text,
+  salary money,
+  company text,
+  occupation text,
+  primary key(first_name, last_name)
+);
+
+create table test.tiobe_pls(
+  name text primary key,
+  rank smallint
+);
+
+create table test.family_tree (
+  id text not null primary key,
+  name text not null,
+  parent text
+);
+alter table only test.family_tree add constraint pptr foreign key (parent) references test.family_tree(id);
+
+create table test.organizations (
+  id integer primary key,
+  name text,
+  referee integer,
+  auditor integer
+);
+alter table only test.organizations add constraint pptr1 foreign key (referee) references test.organizations(id);
+alter table only test.organizations add constraint pptr2 foreign key (auditor) references test.organizations(id);
+
+create table private.authors(
+  id integer primary key,
+  name text
+);
+
+create table private.books(
+  id integer primary key,
+  title text,
+  publication_year smallint,
+  author_id integer references private.authors(id)
+);
+
+create view test.authors as select id, name from private.authors;
+
+create view test.books as select id, title, publication_year, author_id from private.books;
+create view test.forties_books as select id, title, publication_year, author_id from private.books where publication_year >= 1940 and publication_year < 1950;
+create view test.fifties_books as select id, title, publication_year, author_id from private.books where publication_year >= 1950 and publication_year < 1960;
+create view test.sixties_books as select id, title, publication_year, author_id from private.books where publication_year >= 1960 and publication_year < 1970;
+
+create table person (
+  id integer primary key,
+  name character varying not null);
+
+create table message (
+  id integer primary key,
+  body text not null default '',
+  sender bigint not null references person(id),
+  recipient bigint not null references person(id));
+
+create view person_detail as
+  select p.id, p.name, s.count as sent, r.count as received
+  from person p
+  join lateral (select message.sender, count(message.id) as count from message group by message.sender) s on s.sender = p.id
+  join lateral (select message.recipient, count(message.id) as count from message group by message.recipient) r on r.recipient = p.id;
+
+create table space(
+  id integer primary key,
+  name text);
+
+create table zone(
+  id integer primary key,
+  name text,
+  zone_type_id integer,
+  space_id integer references space(id));
+
+-- foreign table tests
+create extension file_fdw;
+
+create server import_csv foreign data wrapper file_fdw;
+
+create foreign table projects_dump (
+  id integer,
+  name text,
+  client_id integer
+) server import_csv options ( filename '/tmp/projects_dump.csv', format 'csv');
+
+comment on foreign table projects_dump is
+$$A temporary projects dump
+
+Just a test for foreign tables$$;

test/io-tests.sh

@@ -40,9 +40,10 @@ pgrStopAll(){ pkill -f "$(stack path --local-install-root)/bin/postgrest"; }
 rootStatus(){
   curl -s -o /dev/null -w '%{http_code}' "http://localhost:$pgrPort/"
 }
+
 authorsStatus(){
   curl -s -o /dev/null -w '%{http_code}' \
-    -H "Authorization: Bearer $( cat "$1" )" \
+    -H "Authorization: Bearer $1" \
     "http://localhost:$pgrPort/authors_only"
 }
 
@@ -68,7 +69,7 @@ readSecretFromFile(){
   if pgrStarted
   then
     authorsJwt="./secrets/${1%.*}.jwt"
-    httpStatus="$( authorsStatus "$authorsJwt" )"
+    httpStatus="$( authorsStatus $(cat "$authorsJwt") )"
     if test "$httpStatus" -eq 200
     then
       ok "authentication with $2 secret read from a file"
@@ -81,6 +82,44 @@ readSecretFromFile(){
   pgrStop
 }
 
+reqWithRoleClaimKey(){
+  export ROLE_CLAIM_KEY=$1
+  pgrStart "./configs/role-claim-key.config"
+  while pgrStarted && test "$( rootStatus )" -ne 200
+  do
+    # wait for the server to start
+    sleep 0.1 \
+    || sleep 1 # fallback: subsecond sleep is not standard and may fail
+  done
+  authorsJwt=$(psql -qtAX postgrest_test -c "select jwt.sign('$2', 'reallyreallyreallyreallyverysafe');")
+  httpStatus="$( authorsStatus "$authorsJwt" )"
+  if test "$httpStatus" -eq $3
+  then
+    ok "request with \"$1\" role-claim-key for $2 jwt gave $3"
+  else
+    ko "request with \"$1\" role-claim-key for $2 jwt gave $httpStatus"
+  fi
+  pgrStop
+}
+
+invalidRoleClaimKey(){
+  export ROLE_CLAIM_KEY=$1
+  pgrStart "./configs/role-claim-key.config"
+  while pgrStarted && test "$( rootStatus )" -ne 200
+  do
+    # wait for the server to start
+    sleep 0.1 \
+    || sleep 1 # fallback: subsecond sleep is not standard and may fail
+  done
+  if pgrStarted
+  then
+    ko "invalid jspath \"$1\" accepted"
+  else
+    ok "invalid jspath \"$1\" rejected"
+  fi
+  pgrStop
+}
+
 # PRE: curl must be available
 test -n "$(command -v curl)" || bailOut 'curl is not available'
 
@@ -89,23 +128,35 @@ psql -l 1>/dev/null 2>/dev/null || bailOut 'postgres is not running'
 
 setUp
 
-totalTests=12
-echo "1..$totalTests"
+echo "Running IO tests.."
 
 readSecretFromFile word.noeol 'simple (no EOL)'
-skip readSecretFromFile word.txt 'simple'
+readSecretFromFile word.txt 'simple'
 readSecretFromFile ascii.noeol 'ASCII (no EOL)'
-skip readSecretFromFile ascii.txt 'ASCII'
+readSecretFromFile ascii.txt 'ASCII'
 readSecretFromFile utf8.noeol 'UTF-8 (no EOL)'
-skip readSecretFromFile utf8.txt 'UTF-8'
-skip readSecretFromFile binary.noeol 'binary'
-skip readSecretFromFile binary.eol 'binary (+EOL)'
+readSecretFromFile utf8.txt 'UTF-8'
+readSecretFromFile binary.noeol 'binary'
+readSecretFromFile binary.eol 'binary (+EOL)'
 
 readSecretFromFile word.b64 'Base64 (simple)'
 readSecretFromFile ascii.b64 'Base64 (ASCII)'
 readSecretFromFile utf8.b64 'Base64 (UTF-8)'
 readSecretFromFile binary.b64 'Base64 (binary)'
 
+reqWithRoleClaimKey '.postgrest.a_role' '{"postgrest":{"a_role":"postgrest_test_author"}}' 200
+reqWithRoleClaimKey '.customObject.manyRoles[1]' '{"customObject":{"manyRoles": ["other", "postgrest_test_author"]}}' 200
+reqWithRoleClaimKey '."https://www.example.com/roles"[0].value' '{"https://www.example.com/roles":[{"value":"postgrest_test_author"}]}' 200
+reqWithRoleClaimKey '.myDomain[3]' '{"myDomain":["other","postgrest_test_author"]}' 401
+reqWithRoleClaimKey '.myRole' '{"role":"postgrest_test_author"}' 401
+
+invalidRoleClaimKey 'role.other'
+invalidRoleClaimKey '.role##'
+invalidRoleClaimKey '.my_role;;domain'
+invalidRoleClaimKey '.#$%&$%/'
+invalidRoleClaimKey ''
+invalidRoleClaimKey 1234
+
 cleanUp
 
 exit $failedTests

test/io-tests/configs/role-claim-key.config

@@ -0,0 +1,8 @@
+db-uri = "postgres:///postgrest_test"
+db-schema = "test"
+db-anon-role = "postgrest_test_anonymous"
+db-pool = 1
+server-host = "*4"
+server-port = 49421
+role-claim-key = "$(ROLE_CLAIM_KEY)"
+jwt-secret = "reallyreallyreallyreallyverysafe"

test/memory-tests.sh

@@ -0,0 +1,117 @@
+#!/bin/bash
+currentTest=1
+failedTests=0
+result(){ echo "$1 $currentTest $2"; currentTest=$(( $currentTest + 1 )); }
+ok(){ result 'ok' "- $1"; }
+ko(){ result 'not ok' "- $1"; failedTests=$(( $failedTests + 1 )); }
+
+pgrPort=49421
+
+pgrStopAll(){ pkill -f "$(stack path --local-install-root)/bin/postgrest"; }
+
+pgrStart(){ stack exec -- postgrest test/memory-tests/config +RTS -p -h >/dev/null & pgrPID="$!"; }
+pgrStop(){ kill "$pgrPID" 2>/dev/null; }
+
+setUp(){ pgrStopAll; }
+cleanUp(){ pgrStopAll; }
+
+checkPgrStarted(){
+  while pgrStarted && test $(rootStatus) -ne 200
+  do
+    sleep 1
+  done
+}
+pgrStarted(){ kill -0 "$pgrPID" 2>/dev/null; }
+rootStatus(){
+  curl -s -o /dev/null -I -w '%{http_code}' "http://localhost:$pgrPort/"
+}
+
+jsonKeyTest(){
+  pgrStart
+  checkPgrStarted
+  factor=$(( 3*$(numfmt --from=si $1)/4 )) # 3/4 on $1 is need to maintain the specified size because of base64
+  payload="{\"blob\" : \"$(dd if=/dev/zero bs=$factor count=1 status=none | base64)\"}"
+  httpStatus=$(echo $payload | curl -s -H "Content-Type: application/json" --request $2 -d @- -w '%{http_code}' http://localhost:$pgrPort$3 | tr -d '"')
+  if test "$httpStatus" -ge 200 && test "$httpStatus" -lt 210
+  then
+    pgrStop
+    while [ ! -s postgrest.prof ]
+    do
+      sleep 1
+    done
+    BYTES_FMT=$(cat postgrest.prof | grep -o -P '(?<=alloc =).*(?=bytes)' | tr -d ' ')
+    BYTES=$(echo $BYTES_FMT | tr -d ',')
+    MAX_BYTES=$(numfmt --from=si $4)
+    if test $BYTES -le $MAX_BYTES
+    then
+      ok "$2 $3: with a json key of $1 the memory usage($BYTES_FMT bytes) is less than $4"
+    else
+      ko "$2 $3: with a json key of $1 the memory usage($BYTES_FMT bytes) is more than $4"
+    fi
+  else
+    pgrStop
+    ko "$2 $3: request failed with http $httpStatus"
+  fi
+}
+
+postJsonArrayTest(){
+  pgrStart
+  checkPgrStarted
+  arr=()
+  arr+=('[')
+  for i in $(seq 1 $(expr $1 - 1))
+  do
+    arr+=("{\"id\": $i, \"body\": \"xxxxxxx\"},")
+  done
+  arr+=("{\"id\": $1, \"body\": \"xxxxxxx\"}")
+  arr+=(']')
+  payload=$(echo ${arr[*]})
+  httpStatus=$(echo $payload | curl -s -H "Content-Type: application/json" -d @- -w '%{http_code}' http://localhost:$pgrPort$2 | tr -d '"')
+  if test "$httpStatus" -ge 200 && test "$httpStatus" -lt 210
+  then
+    pgrStop
+    while [ ! -s postgrest.prof ]
+    do
+      sleep 1
+    done
+    BYTES_FMT=$(cat postgrest.prof | grep -o -P '(?<=alloc =).*(?=bytes)' | tr -d ' ')
+    BYTES=$(echo $BYTES_FMT | tr -d ',')
+    MAX_BYTES=$(numfmt --from=si $3)
+    PAYLOAD_SIZE=$(echo $payload | wc -c | numfmt --to=si)
+    if test $BYTES -le $MAX_BYTES
+    then
+      ok "POST $2: with a json payload of $PAYLOAD_SIZE that has $1 array values the memory usage($BYTES_FMT bytes) is less than $3"
+    else
+      ko "POST $2: with a json payload of $PAYLOAD_SIZE that has $1 array values the memory usage($BYTES_FMT bytes) is more than $3"
+    fi
+  else
+    pgrStop
+    ko "POST $2: request failed with http $httpStatus"
+  fi
+}
+
+stack build --profile
+
+setUp
+
+echo "Running memory usage tests.."
+
+jsonKeyTest "1M" "POST" "/rpc/leak" "15M"
+jsonKeyTest "1M" "POST" "/leak" "15M"
+jsonKeyTest "1M" "PATCH" "/leak?id=eq.1" "15M"
+
+jsonKeyTest "10M" "POST" "/rpc/leak" "105M"
+jsonKeyTest "10M" "POST" "/leak" "105M"
+jsonKeyTest "10M" "PATCH" "/leak?id=eq.1" "105M"
+
+jsonKeyTest "100M" "POST" "/rpc/leak" "895M"
+jsonKeyTest "100M" "POST" "/leak" "895M"
+jsonKeyTest "100M" "PATCH" "/leak?id=eq.1" "895M"
+
+postJsonArrayTest "1000" "/perf_articles" "20M"
+postJsonArrayTest "10000" "/perf_articles" "120M"
+postJsonArrayTest "100000" "/perf_articles" "1.15G"
+
+cleanUp
+
+exit $failedTests

test/memory-tests/config

@@ -0,0 +1,8 @@
+db-uri = "postgres:///postgrest_test"
+db-schema = "test"
+db-anon-role = "postgrest_test_anonymous"
+db-pool = 1
+server-host = "*4"
+server-port = 49421
+
+jwt-secret = "reallyreallyreallyreallyverysafe"