bump version to 12.0.2

Closes https://github.com/PostgREST/postgrest/issues/3126

.cirrus.yml

@@ -1,9 +1,9 @@
 freebsd_instance:
-  image_family: freebsd-13-0
+  image_family: freebsd-13-1
 
 build_task:
   name: Build FreeBSD (Stack)
-  install_script: pkg install -y postgresql13-client hs-stack
+  install_script: pkg install -y postgresql13-client hs-stack git
 
   stack_cache:
     folders: /.stack

.github/PULL_REQUEST_TEMPLATE.md

@@ -3,4 +3,16 @@ When submitting a new feature or fix:
 
 - Add a new entry to the CHANGELOG - https://github.com/PostgREST/postgrest/blob/main/CHANGELOG.md#unreleased
 - If relevant, update the docs     - https://github.com/PostgREST/postgrest-docs
+- Use a prefix for the PR title or commits, e.g. "fix: description of the fix".
+  + `fix`, bug fixes
+  + `feat`, new features added
+  + `perf`, performance improvements
+  + `nix`, related to the Nix development environment
+  + `ci`, related to the Continuous Integration modules
+  + `test`, related to the testing modules
+  + `refactor`, refactoring code
+  + `deprecate`, deprecating a feature
+  + `chore`, maintenance (changelog, build process, etc.)
+  + Other prefixes may be used if necessary
+- If there's a breaking change, add `BREAKING CHANGE` and an explanation to your commit message
 -->

.github/actions/setup-nix/action.yaml

@@ -7,12 +7,23 @@ inputs:
     description: Token to pass to cachix
   tools:
     description: Tools to install with nix-env -iA <tools>
+  cache-id:
+    description: Cache id to use for cache-nix-action
+    default: "default"
 
 runs:
   using: composite
   steps:
-    - uses: cachix/install-nix-action@v16
-    - uses: cachix/cachix-action@v10
+    - uses: nixbuild/nix-quick-install-action@v26
+      with:
+        nix_version: '2.13.6'
+    - name: Restore and cache Nix store
+      uses: nix-community/cache-nix-action@v4.0.3
+      with:
+        key: cache-nix-${{ runner.os }}-id-${{ inputs.cache-id }}-${{ hashFiles('nix/**/*.nix', '.github/actions/setup-nix/*') }}
+        restore-keys: |
+          cache-nix-${{ runner.os }}-common-
+    - uses: cachix/cachix-action@v13
       with:
         name: postgrest
         authToken: ${{ inputs.authToken }}

.github/dependabot.yml

@@ -1,6 +1,11 @@
 version: 2
 updates:
-- package-ecosystem: github-actions
-  directory: /
-  schedule:
-    interval: weekly
+  - package-ecosystem: github-actions
+    directory: /
+    schedule:
+      interval: weekly
+
+  - package-ecosystem: github-actions
+    directory: /.github/actions/setup-nix
+    schedule:
+      interval: weekly

.github/get_cirrusci_freebsd

@@ -7,12 +7,13 @@ set -euo pipefail
 # https://docs.github.com/en/rest/reference/checks#list-check-suites-for-a-git-reference
 
 cirrus_artifact_name=bin
+gh_auth_header="Authorization: Bearer $GITHUB_TOKEN"
 gh_accept_header="Accept: application/vnd.github.v3+json"
 
 get_gh_check_runs_url() {
   gh_checks_list_url="https://api.github.com/repos/$GITHUB_REPOSITORY/commits/$GITHUB_COMMIT/check-suites"
   >&2 echo "Getting list of check-suites from $gh_checks_list_url ..."
-  curl --fail -H "$gh_accept_header"  "$gh_checks_list_url" \
+  curl --fail -H "$gh_auth_header" -H "$gh_accept_header"  "$gh_checks_list_url" \
     | jq -r '.check_suites[] | select(.app.slug == "cirrus-ci") | .check_runs_url'
 }
 
@@ -21,7 +22,7 @@ wait_for_cirrusci() {
   >&2 echo "Waiting to CirrusCI run to complete (two hours maximum)..."
   for _ in $(seq 1 120); do
     echo "Checking for CirrusCI task status at $gh_check_runs_url ..."
-    status=$(curl --fail "$gh_check_runs_url" | jq -r '.check_runs[] | .status')
+    status=$(curl --fail -H "$gh_auth_header" "$gh_check_runs_url" | jq -r '.check_runs[] | .status')
     if [ "$status" == "completed" ]; then
       break
     else
@@ -37,7 +38,7 @@ wait_for_cirrusci() {
 get_cirrus_taskid() {
   gh_check_runs_url="$(get_gh_check_runs_url)"
   >&2 echo "Getting the CirrusCI task id from $gh_check_runs_url ..."
-  curl --fail -H "$gh_accept_header" "$gh_check_runs_url" \
+  curl --fail -H "$gh_auth_header" -H "$gh_accept_header" "$gh_check_runs_url" \
     | jq -r '.check_runs[] | .external_id'
 }
 

.github/scripts/arm/build.sh

@@ -0,0 +1,68 @@
+#!/bin/bash
+
+# This script builds PostgREST in a remote ARM server
+
+[ -z "$1" ] && { echo "Missing 1st argument: PostgREST github commit SHA"; exit 1; }
+[ -z "$2" ] && { echo "Missing 2nd argument: Build environment directory name"; exit 1; }
+[ -z "$3" ] && { echo "Missing 3rd argument: GHC version"; exit 1; }
+
+PGRST_GITHUB_COMMIT="$1"
+SCRIPT_DIR="$2"
+
+DOCKER_BUILD_DIR="$SCRIPT_DIR/docker-env"
+# latest is a shortcut documented on https://www.haskell.org/ghcup/guide/#tags-and-shortcuts
+CABAL_VERSION="latest"
+GHC_VERSION="$3"
+
+install_packages() {
+  sudo apt-get update -y
+  sudo apt-get upgrade -y
+  sudo apt-get install -y git build-essential curl libffi-dev libffi7 libgmp-dev libgmp10 libncurses-dev libncurses5 libtinfo5 llvm libnuma-dev zlib1g-dev libpq-dev jq gcc
+  sudo apt-get clean
+}
+
+install_ghcup() {
+  export BOOTSTRAP_HASKELL_NONINTERACTIVE=1
+  export BOOTSTRAP_HASKELL_MINIMAL=1
+  curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
+  source ~/.ghcup/env
+}
+
+install_cabal() {
+  ghcup upgrade
+  ghcup install cabal $CABAL_VERSION
+  ghcup set cabal $CABAL_VERSION
+}
+
+install_ghc() {
+  ghcup upgrade
+  ghcup install ghc $GHC_VERSION
+  ghcup set ghc $GHC_VERSION
+}
+
+install_packages
+
+# Add ghcup to the PATH for this session
+[ -f ~/.ghcup/env ] && source ~/.ghcup/env
+
+ghcup --version || install_ghcup
+ghcup set cabal $CABAL_VERSION || install_cabal
+ghcup set ghc $GHC_VERSION || install_ghc
+
+cd ~/$SCRIPT_DIR
+
+# Clone the repository and build the project
+git clone https://github.com/PostgREST/postgrest.git
+cd postgrest
+git checkout $PGRST_GITHUB_COMMIT
+cabal v2-update && cabal v2-build
+
+# Copy the built binary to the Dockerfile directory
+PGRST_BIN=$(cabal exec which postgrest | tail -1)
+cp $PGRST_BIN ~/$DOCKER_BUILD_DIR
+
+# Move and compress the built binary
+mkdir -p ~/$SCRIPT_DIR/result
+mv $PGRST_BIN ~/$SCRIPT_DIR/result
+cd ~/$SCRIPT_DIR
+tar -cJf result.tar.xz result

.github/scripts/arm/docker-env/Dockerfile

@@ -0,0 +1,18 @@
+# PostgREST docker hub image
+
+FROM ubuntu:focal AS postgrest
+
+RUN apt-get update -y \
+    && apt install -y --no-install-recommends libpq-dev zlib1g-dev jq gcc libnuma-dev \
+    && apt-get clean \
+    && rm -rf /var/lib/apt/lists/*
+
+COPY postgrest /usr/bin/postgrest
+
+EXPOSE 3000
+
+USER 1000
+
+# Use the array form to avoid running the command using bash, which does not handle `SIGTERM` properly. 
+# See https://docs.docker.com/compose/faq/#why-do-my-services-take-10-seconds-to-recreate-or-stop 
+CMD ["postgrest"]

.github/scripts/arm/docker-publish.sh

@@ -0,0 +1,50 @@
+#!/bin/bash
+
+# This script publishes the Docker ARM images to Docker Hub.
+
+[ -z "$1" ] && { echo "Missing 1st argument: PostgREST github commit SHA"; exit 1; }
+[ -z "$2" ] && { echo "Missing 2nd argument: Docker repo"; exit 1; }
+[ -z "$3" ] && { echo "Missing 3rd argument: Docker username"; exit 1; }
+[ -z "$4" ] && { echo "Missing 4th argument: Docker password"; exit 1; }
+[ -z "$5" ] && { echo "Missing 5th argument: Build environment directory name"; exit 1; }
+[ -z "$6" ] && { echo "Missing 6th argument: PostgREST version"; exit 1; }
+
+PGRST_GITHUB_COMMIT="$1"
+DOCKER_REPO="$2"
+DOCKER_USER="$3"
+DOCKER_PASS="$4"
+SCRIPT_DIR="$5"
+PGRST_VERSION="v$6"
+IS_PRERELEASE="$7"
+
+DOCKER_BUILD_DIR="$SCRIPT_DIR/docker-env"
+
+clean_env()
+{
+    sudo docker logout
+}
+
+# Login to Docker
+sudo docker logout
+{ echo $DOCKER_PASS | sudo docker login -u $DOCKER_USER --password-stdin; } || { echo "Couldn't login to docker"; exit 1; }
+
+trap clean_env sigint sigterm exit
+
+# Move to the docker build environment
+cd ~/$DOCKER_BUILD_DIR
+
+# Push final images to Docker hub
+# NOTE: This command publishes a separate ARM image because the builds cannot
+#       be added to the manifest if they are not in the registry beforehand.
+#       This image must be manually deleted from Docker Hub at the end of the process.
+sudo docker buildx build --build-arg PGRST_GITHUB_COMMIT=$PGRST_GITHUB_COMMIT \
+                         -t $DOCKER_REPO/postgrest:$PGRST_VERSION-arm \
+                         --push .
+
+# Add the arm images to the manifest
+# NOTE: This assumes that there already is a `postgrest:<version>` image
+#       for the amd64 architecture pushed to Docker Hub
+sudo docker buildx imagetools create --append -t $DOCKER_REPO/postgrest:$PGRST_VERSION $DOCKER_REPO/postgrest:$PGRST_VERSION-arm
+[ -z $IS_PRERELEASE ] && sudo docker buildx imagetools create --append -t $DOCKER_REPO/postgrest:latest $DOCKER_REPO/postgrest:$PGRST_VERSION-arm
+
+sudo docker logout

.github/workflows/cachix.yaml

@@ -0,0 +1,78 @@
+name: Cachix
+
+# This workflow serves to
+#   - keep cachix up to date with the main branch
+#   - incrementally update cachix for large dependency
+#     updates, e.g. after running postgrest-nixpkgs-upgrade,
+#     which can cause the main CI workflow to time out
+
+on:
+  workflow_dispatch:
+  push:
+    branches:
+      - main
+      - rel-*
+    tags:
+      - v*
+
+jobs:
+  Seed-Cachix:
+    strategy:
+      fail-fast: false
+      matrix:
+        include:
+          - os: Linux
+            runs-on: ubuntu-latest
+          - os: MacOS
+            runs-on: macos-latest
+    name: Seed ${{ matrix.os }}
+    runs-on: ${{ matrix.runs-on }}
+    steps:
+      - uses: actions/checkout@v4
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
+
+      - name: Install cachix tooling
+        run: |
+          nix-env -f default.nix -iA devTools.pushCachix.bin
+          postgrest-push-cachix
+
+      - name: Seed dynamic postgrest build
+        run: |
+          nix-build -A postgrestPackage
+          postgrest-push-cachix
+
+      - name: Seed style tools
+        run: |
+          nix-build -A style
+          postgrest-push-cachix
+
+      - name: Seed test tools
+        run: |
+          nix-build -A tests
+          postgrest-push-cachix
+
+      - name: Seed static toolchain
+        if: matrix.os == 'Linux'
+        run: |
+          nix-build -A packagesStatic.haskellPackages.hello
+          postgrest-push-cachix
+
+      - name: Seed static postgresql build (for libpq)
+        if: matrix.os == 'Linux'
+        run: |
+          nix-build -A packagesStatic.pkgs.postgresql
+          postgrest-push-cachix
+
+      - name: Seed static postgrest build
+        if: matrix.os == 'Linux'
+        run: |
+          nix-build -A postgrestStatic
+          postgrest-push-cachix
+
+      - name: Build and push everything to Cachix
+        run: |
+          nix-build
+          postgrest-push-cachix

.github/workflows/ci.yaml

@@ -4,22 +4,46 @@ on:
   push:
     branches:
       - main
+      - rel-*
     tags:
       - v*
   pull_request:
     branches:
       - main
+      - rel-*
+concurrency:
+  group: ${{ github.workflow }}-${{ github.ref }}
+  
+  # Terminate all previous runs of the same workflow and branch/tag, except for main and release branches/tags
+  cancel-in-progress: "${{ !(github.ref == 'refs/heads/main' || startsWith(github.ref, 'refs/tags/v') || startsWith(github.ref, 'refs/heads/rel-')) }}"
 
 jobs:
+  Prepopulate-Nix-Cache-Linux:
+    name: Prepopulate Nix cache for Linux runners
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          cache-id: common
+      - name: Put all tools to store to be cached afterwards
+        run: |
+          # shellcheck disable=SC2046
+          nix-store -v --realize $( nix-instantiate default.nix )
+        shell: bash
+    
   Lint-Style:
     name: Lint & check code style
     runs-on: ubuntu-latest
+    needs: [Prepopulate-Nix-Cache-Linux]
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - name: Setup Nix Environment
         uses: ./.github/actions/setup-nix
         with:
           tools: style
+          cache-id: common
       - name: Run linter (check locally with `nix-shell --run postgrest-lint`)
         run: postgrest-lint
       - name: Run style check (auto-format with `nix-shell --run postgrest-style`)
@@ -29,45 +53,27 @@ jobs:
   Test-Nix:
     name: Test (Nix)
     runs-on: ubuntu-latest
+    needs: [Prepopulate-Nix-Cache-Linux]
     defaults:
       run:
         # Hack for enabling color output, see:
         # https://github.com/actions/runner/issues/241#issuecomment-842566950
         shell: script -qec "bash --noprofile --norc -eo pipefail {0}"
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - name: Setup Nix Environment
         uses: ./.github/actions/setup-nix
         with:
-          tools: tests withTools
+          tools: tests
+          cache-id: common
 
-      - name: Run coverage (IO tests and Spec tests against PostgreSQL 14)
+      - name: Run coverage (IO tests and Spec tests against PostgreSQL 15)
         run: postgrest-coverage
       - name: Upload coverage to codecov
-        uses: codecov/codecov-action@v2.1.0
+        uses: codecov/codecov-action@v3.1.4
         with:
           files: ./coverage/codecov.json
 
-      - name: Run the spec tests against PostgreSQL 13
-        if: always()
-        run: postgrest-with-postgresql-13 postgrest-test-spec
-      - name: Run the spec tests against PostgreSQL 12
-        if: always()
-        run: postgrest-with-postgresql-12 postgrest-test-spec
-      - name: Run the spec tests against PostgreSQL 11
-        if: always()
-        run: postgrest-with-postgresql-11 postgrest-test-spec
-      - name: Run the spec tests against PostgreSQL 10
-        if: always()
-        run: postgrest-with-postgresql-10 postgrest-test-spec
-      - name: Run the spec tests against PostgreSQL 9.6
-        if: always()
-        run: postgrest-with-postgresql-9.6 postgrest-test-spec
-
-      - name: Run query cost tests against all PostgreSQL versions
-        if: always()
-        run: postgrest-with-all postgrest-test-querycost
-
       - name: Run doctests
         if: always()
         run: nix-shell --run postgrest-test-doctests
@@ -77,33 +83,71 @@ jobs:
         run: postgrest-test-spec-idempotence
 
 
+  Test-Pg-Nix:
+    strategy:
+      fail-fast: false
+      matrix:
+        pgVersion: [9.6, 10, 11, 12, 13, 14, 15, 16]
+    name: Test PG ${{ matrix.pgVersion }} (Nix)
+    runs-on: ubuntu-latest
+    needs: [Prepopulate-Nix-Cache-Linux]
+    defaults:
+      run:
+        # Hack for enabling color output, see:
+        # https://github.com/actions/runner/issues/241#issuecomment-842566950
+        shell: script -qec "bash --noprofile --norc -eo pipefail {0}"
+    steps:
+      - uses: actions/checkout@v4
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          tools: tests withTools
+          # It seems like they are installing the same set of derivations, so we can assign them the same cache id. 
+          # This would decrease the amount of caches dowloaded on merge cache step and will prevent disk space issues.
+          cache-id: common 
+
+      - name: Run spec tests
+        if: always()
+        run: postgrest-with-postgresql-${{ matrix.pgVersion }} postgrest-test-spec
+
+      - name: Run IO tests
+        if: always()
+        run: postgrest-with-postgresql-${{ matrix.pgVersion }} -f test/io/fixtures.sql postgrest-test-io -vv
+
+
   Test-Memory-Nix:
     name: Test memory (Nix)
     runs-on: ubuntu-latest
+    needs: [Prepopulate-Nix-Cache-Linux]
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - name: Setup Nix Environment
         uses: ./.github/actions/setup-nix
         with:
           tools: memory
+          cache-id: common
       - name: Run memory tests
         run: postgrest-test-memory
 
 
-  Build-Nix:
+  Build-Static-Nix:
     name: Build Linux static (Nix)
     runs-on: ubuntu-latest
+    needs: [Prepopulate-Nix-Cache-Linux]
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - name: Setup Nix Environment
         uses: ./.github/actions/setup-nix
         with:
-          authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
+          tools: tests
+          cache-id: common
 
       - name: Build static executable
         run: nix-build -A postgrestStatic
+      - name: Check static executable
+        run: postgrest-check-static result/bin/postgrest
       - name: Save built executable as artifact
-        uses: actions/upload-artifact@v2.2.4
+        uses: actions/upload-artifact@v4
         with:
           name: postgrest-linux-static-x64
           path: result/bin/postgrest
@@ -112,18 +156,23 @@ jobs:
       - name: Build Docker image
         run: nix-build -A docker.image --out-link postgrest-docker.tar.gz
       - name: Save built Docker image as artifact
-        uses: actions/upload-artifact@v2.2.4
+        uses: actions/upload-artifact@v4
         with:
           name: postgrest-docker-x64
           path: postgrest-docker.tar.gz
           if-no-files-found: error
 
-      - name: Build and push everything to Cachix (main branch only)
-        if: ${{ github.ref == 'refs/heads/main' }}
+  Build-Macos-Nix:
+    name: Build MacOS (Nix)
+    runs-on: macos-latest
+    steps:
+      - uses: actions/checkout@v4
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+
+      - name: Build everything
         run: |
           nix-build
-          nix-env -f default.nix -iA devTools
-          postgrest-push-cachix
 
 
   Build-Stack:
@@ -131,22 +180,18 @@ jobs:
       fail-fast: false
       matrix:
         include:
-          - name: Linux & test
+          - name: Linux
             runs-on: ubuntu-latest
             cache: |
               ~/.stack
               .stack-work
-            test: true
-            pgdir: /usr/lib/postgresql
             artifact: postgrest-ubuntu-x64
 
-          - name: MacOS & test
+          - name: MacOS
             runs-on: macos-latest
             cache: |
               ~/.stack
               .stack-work
-            test: true
-            pgdir: /usr/local/Cellar/postgresql
             artifact: postgrest-macos-x64
 
           - name: Windows
@@ -155,34 +200,25 @@ jobs:
               ~\AppData\Roaming\stack
               ~\AppData\Local\Programs\stack
               .stack-work
-            deps: |
-              stack exec -- pacman -S mingw64/mingw-w64-x86_64-postgresql --noconfirm
-            # We'd need to make test/with_tmp_db run on Windows first
-            # test: true
+            deps: Add-Content $env:GITHUB_PATH $env:PGBIN
             artifact: postgrest-windows-x64
 
     name: Build ${{ matrix.name }} (Stack)
     runs-on: ${{ matrix.runs-on }}
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - name: Stack working files cache
-        uses: actions/cache@v2.1.7
+        uses: actions/cache@v3
         with:
           path: ${{ matrix.cache }}
-          key: ${{ runner.os }}-${{ hashFiles('stack.yaml.lock') }}
+          key: cache-stack-${{ runner.os }}-${{ hashFiles('stack.yaml.lock') }}
       - name: Install dependencies
         if: ${{ matrix.deps }}
         run: ${{ matrix.deps }}
       - name: Build with Stack
         run: stack build --local-bin-path result --copy-bins
-      - name: Run Spec tests with Stack
-        if: ${{ matrix.test }}
-        run: |
-          postgresql_bin="$(find ${{ matrix.pgdir }} -maxdepth 2 -type d -name bin | head -n 1)"
-          echo "Using PostgreSQL binaries at $postgresql_bin ..."
-          PATH="$postgresql_bin:$PATH" test/with_tmp_db stack test
       - name: Save built executable as artifact
-        uses: actions/upload-artifact@v2.2.4
+        uses: actions/upload-artifact@v4
         with:
           name: ${{ matrix.artifact }}
           path: |
@@ -190,24 +226,121 @@ jobs:
             result/postgrest.exe
           if-no-files-found: error
 
-
   Get-FreeBSD-CirrusCI:
     name: Get FreeBSD build from CirrusCI
     runs-on: ubuntu-latest
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - name: Get FreeBSD executable from CirrusCI
         env:
           # GITHUB_SHA does weird things for pull request, so we roll our own:
-          GITHUB_COMMIT: ${{github.event.pull_request.head.sha || github.sha}}
+          GITHUB_COMMIT: ${{ github.event.pull_request.head.sha || github.sha }}
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
         run: .github/get_cirrusci_freebsd
       - name: Save executable as artifact
-        uses: actions/upload-artifact@v2.2.4
+        uses: actions/upload-artifact@v4
         with:
           name: postgrest-freebsd-x64
           path: postgrest
           if-no-files-found: error
 
+  Build-Cabal:
+    strategy:
+      matrix:
+        ghc: ['9.0.2', '9.2.4']
+      fail-fast: false
+    name: Build Linux (Cabal, GHC ${{ matrix.ghc }})
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+      - name: Workaround runner image issue
+        # https://github.com/actions/runner-images/issues/7061
+        run: sudo chown -R "$USER" /usr/local/.ghcup
+      - name: ghcup
+        run: |
+          ghcup install ghc ${{ matrix.ghc }}
+          ghcup set ghc ${{ matrix.ghc }}
+      - name: Copy cabal.project & fix caching
+        run: |
+          mkdir ~/.cabal
+          cp cabal.project.non-nix cabal.project
+      - name: Cache
+        uses: actions/cache@v3
+        with:
+          path: |
+            ~/.cabal/packages
+            ~/.cabal/store
+            dist-newstyle
+          key: cache-cabal-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('**/*.cabal', '**/cabal.project') }}
+          restore-keys: |
+            cache-cabal-${{ runner.os }}-${{ matrix.ghc }}-
+      - name: Install dependencies
+        run: |
+          cabal update
+          cabal build --only-dependencies --enable-tests --enable-benchmarks
+      - name: Build
+        run: cabal build --enable-tests --enable-benchmarks all
+
+  Build-Cabal-Arm:
+    strategy:
+      matrix:
+        ghc: ['9.2.4']
+      fail-fast: false
+    name: Build aarch64 (Cabal, GHC ${{ matrix.ghc }})
+    if: ${{ github.ref == 'refs/heads/main' || startsWith(github.ref, 'refs/tags/v') || startsWith(github.ref, 'refs/heads/rel-') }}
+    runs-on: ubuntu-latest
+    outputs:
+      remotepath: ${{ steps.Remote-Dir.outputs.remotepath }}
+    env:
+      GITHUB_COMMIT: ${{ github.sha }}
+      GHC_VERSION: ${{ matrix.ghc }}
+    steps:
+      - uses: actions/checkout@v4
+      - id: Remote-Dir
+        name: Unique directory name for the remote build
+        run: echo "remotepath=postgrest-build-$(uuidgen)" >> "$GITHUB_OUTPUT"
+      - name: Copy script files to the remote server
+        uses: appleboy/scp-action@master
+        with:
+          host: ${{ secrets.SSH_ARM_HOST }}
+          username: ubuntu
+          key: ${{ secrets.SSH_ARM_PRIVATE_KEY }}
+          fingerprint: ${{ secrets.SSH_ARM_FINGERPRINT }}
+          source: ".github/scripts/arm/*"
+          target: ${{ steps.Remote-Dir.outputs.remotepath }}
+          strip_components: 3
+      - name: Build ARM
+        uses: appleboy/ssh-action@master
+        env:
+          REMOTE_DIR: ${{ steps.Remote-Dir.outputs.remotepath }}
+        with:
+          host: ${{ secrets.SSH_ARM_HOST }}
+          username: ubuntu
+          key: ${{ secrets.SSH_ARM_PRIVATE_KEY }}
+          fingerprint: ${{ secrets.SSH_ARM_FINGERPRINT }}
+          command_timeout: 120m
+          script_stop: true
+          envs: GITHUB_COMMIT,REMOTE_DIR,GHC_VERSION
+          script: bash ~/$REMOTE_DIR/build.sh "$GITHUB_COMMIT" "$REMOTE_DIR" "GHC_VERSION"
+      - name: Download binaries from remote server
+        uses: nicklasfrahm/scp-action@main
+        with:
+          direction: download
+          host: ${{ secrets.SSH_ARM_HOST }}
+          username: ubuntu
+          key: ${{ secrets.SSH_ARM_PRIVATE_KEY }}
+          fingerprint: ${{ secrets.SSH_ARM_FINGERPRINT }}
+          source: "${{ steps.Remote-Dir.outputs.remotepath }}/result.tar.xz"
+          target: "result.tar.xz"
+      - name: Extract downloaded binaries
+        run: tar -xvf result.tar.xz && rm result.tar.xz
+      - name: Save aarch64 executable as artifact
+        uses: actions/upload-artifact@v4
+        with:
+          name: postgrest-ubuntu-aarch64
+          path: result/postgrest
+          if-no-files-found: error
+
 
   Prepare-Release:
     name: Prepare release
@@ -216,15 +349,17 @@ jobs:
     needs:
       - Lint-Style
       - Test-Nix
+      - Test-Pg-Nix
       - Test-Memory-Nix
-      - Build-Nix
+      - Build-Static-Nix
       - Build-Stack
-      - Get-FreeBSD-CirrusCI
+      #- Get-FreeBSD-CirrusCI
+      - Build-Cabal-Arm
     outputs:
       version: ${{ steps.Identify-Version.outputs.version }}
       isprerelease: ${{ steps.Identify-Version.outputs.isprerelease }}
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - id: Identify-Version
         name: Identify the version to be released
         run: |
@@ -236,14 +371,14 @@ jobs:
             exit 1
           else
             echo "Version to be released is $cabal_version"
-            echo "::set-output name=version::$cabal_version"
+            echo "version=$cabal_version" >> "$GITHUB_OUTPUT"
           fi
 
           if [[ "$cabal_version" != *.*.*.* ]]; then
             echo "Version is for a full release (version does not have four components)"
           else
             echo "Version is for a pre-release (version has four components, e.g., 1.1.1.1)"
-            echo "::set-output name=isprerelease::1"
+            echo "isprerelease=1" >> "$GITHUB_OUTPUT"
           fi
       - name: Identify changes from CHANGELOG.md
         run: |
@@ -261,7 +396,7 @@ jobs:
           echo "Relevant extract from CHANGELOG.md:"
           cat CHANGES.md
       - name: Save CHANGES.md as artifact
-        uses: actions/upload-artifact@v2.2.4
+        uses: actions/upload-artifact@v4
         with:
           name: release-changes
           path: CHANGES.md
@@ -277,9 +412,9 @@ jobs:
     env:
       VERSION: ${{ needs.Prepare-Release.outputs.version }}
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - name: Download all artifacts
-        uses: actions/download-artifact@v2.0.10
+        uses: actions/download-artifact@v4
         with:
           path: artifacts
       - name: Create release bundle with archives for all builds
@@ -299,14 +434,18 @@ jobs:
           tar cJvf "release-bundle/postgrest-v$VERSION-macos-x64.tar.xz" \
             -C artifacts/postgrest-macos-x64 postgrest
 
-          tar cJvf "release-bundle/postgrest-v$VERSION-freebsd-x64.tar.xz" \
-            -C artifacts/postgrest-freebsd-x64 postgrest
+          # TODO: Fix timeouts for FreeBSD builds in Cirrus
+          #tar cJvf "release-bundle/postgrest-v$VERSION-freebsd-x64.tar.xz" \
+          #  -C artifacts/postgrest-freebsd-x64 postgrest
+
+          tar cJvf "release-bundle/postgrest-v$VERSION-ubuntu-aarch64.tar.xz" \
+            -C artifacts/postgrest-ubuntu-aarch64 postgrest
 
           zip "release-bundle/postgrest-v$VERSION-windows-x64.zip" \
             artifacts/postgrest-windows-x64/postgrest.exe
 
       - name: Save release bundle
-        uses: actions/upload-artifact@v2.2.4
+        uses: actions/upload-artifact@v4
         with:
           name: release-bundle
           path: release-bundle
@@ -329,25 +468,28 @@ jobs:
   Release-Docker:
     name: Release on Docker Hub
     runs-on: ubuntu-latest
-    needs: Prepare-Release
+    needs:
+      - Prepare-Release
     env:
+      GITHUB_COMMIT: ${{ github.sha }}
       DOCKER_REPO: postgrest
       DOCKER_USER: stevechavez
+      DOCKER_PASS: ${{ secrets.DOCKER_PASS }}
       VERSION: ${{ needs.Prepare-Release.outputs.version }}
       ISPRERELEASE: ${{ needs.Prepare-Release.outputs.isprerelease }}
     steps:
-      - uses: actions/checkout@v2.4.0
+      - uses: actions/checkout@v4
       - name: Setup Nix Environment
         uses: ./.github/actions/setup-nix
         with:
           tools: release
       - name: Download Docker image
-        uses: actions/download-artifact@v2.0.10
+        uses: actions/download-artifact@v4
         with:
           name: postgrest-docker-x64
       - name: Publish images on Docker Hub
         run: |
-          docker login -u "$DOCKER_USER" -p "${{ secrets.DOCKER_PASS }}"
+          docker login -u "$DOCKER_USER" -p "$DOCKER_PASS"
           docker load -i postgrest-docker.tar.gz
 
           docker tag postgrest:latest "$DOCKER_REPO/postgrest:v$VERSION"
@@ -361,13 +503,68 @@ jobs:
           else
             echo "Skipping pushing to 'latest' tag for v$VERSION pre-release..."
           fi
-      - name: Update descriptions on Docker Hub
+# TODO: Enable dockerhub description update again, once a solution for the permission problem is found:
+# https://github.com/docker/hub-feedback/issues/1927
+#      - name: Update descriptions on Docker Hub
+#        env:
+#          DOCKER_PASS: ${{ secrets.DOCKER_PASS }}
+#        run: |
+#          if [[ -z "$ISPRERELEASE" ]]; then
+#            echo "Updating description on Docker Hub..."
+#            postgrest-release-dockerhub-description
+#          else
+#            echo "Skipping updating description for pre-release..."
+#          fi
+
+  Release-Docker-Arm:
+    name: Release Arm Builds on Docker Hub
+    runs-on: ubuntu-latest
+    needs:
+      - Build-Cabal-Arm
+      - Prepare-Release
+      - Release-Docker
+    env:
+      GITHUB_COMMIT: ${{ github.sha }}
+      DOCKER_REPO: postgrest
+      DOCKER_USER: stevechavez
+      DOCKER_PASS: ${{ secrets.DOCKER_PASS }}
+      VERSION: ${{ needs.Prepare-Release.outputs.version }}
+      ISPRERELEASE: ${{ needs.Prepare-Release.outputs.isprerelease }}
+    steps:
+      - uses: actions/checkout@v4
+      - name: Publish images for ARM builds on Docker Hub
+        uses: appleboy/ssh-action@master
         env:
-          DOCKER_PASS: ${{ secrets.DOCKER_PASS }}
-        run: |
-          if [[ -z "$ISPRERELEASE" ]]; then
-            echo "Updating description on Docker Hub..."
-            postgrest-release-dockerhub-description
-          else
-            echo "Skipping updating description for pre-release..."
-          fi
+          REMOTE_DIR: ${{ needs.Build-Cabal-Arm.outputs.remotepath }}
+        with:
+          host: ${{ secrets.SSH_ARM_HOST }}
+          username: ubuntu
+          key: ${{ secrets.SSH_ARM_PRIVATE_KEY }}
+          fingerprint: ${{ secrets.SSH_ARM_FINGERPRINT }}
+          script_stop: true
+          envs: GITHUB_COMMIT,DOCKER_REPO,DOCKER_USER,DOCKER_PASS,REMOTE_DIR,VERSION,ISPRERELEASE
+          script: bash ~/$REMOTE_DIR/docker-publish.sh "$GITHUB_COMMIT" "$DOCKER_REPO" "$DOCKER_USER" "$DOCKER_PASS" "$REMOTE_DIR" "$VERSION" "$ISPRERELEASE"
+
+  Clean-Arm-Server:
+    name: Remove copied files from server
+    needs:
+      - Build-Cabal-Arm
+      - Release-Docker-Arm
+    if: success() ||
+      needs.Build-Cabal-Arm.result == 'failure' ||
+      needs.Build-Cabal-Arm.result == 'cancelled' ||
+      (needs.Build-Cabal-Arm.result == 'success' && !startsWith(github.ref, 'refs/tags/v'))
+    runs-on: ubuntu-latest
+    env:
+      REMOTE_DIR: ${{ needs.Build-Cabal-Arm.outputs.remotepath }}
+    steps:
+      - uses: actions/checkout@v4
+      - name: Remove uploaded files from server
+        uses: appleboy/ssh-action@master
+        with:
+          host: ${{ secrets.SSH_ARM_HOST }}
+          username: ubuntu
+          key: ${{ secrets.SSH_ARM_PRIVATE_KEY }}
+          fingerprint: ${{ secrets.SSH_ARM_FINGERPRINT }}
+          envs: REMOTE_DIR
+          script: rm -rf $REMOTE_DIR

.github/workflows/loadtest.yaml

@@ -0,0 +1,72 @@
+name: Loadtest
+
+on:
+  push:
+    branches:
+      - main
+    tags:
+      - v*
+  pull_request:
+    branches:
+      - main
+
+jobs:
+  Loadtest-PR-Nix:
+    name: Loadtest PR (Nix)
+    if: ${{ github.event_name == 'pull_request' }}
+    runs-on: ubuntu-latest
+    concurrency:
+      group: ${{ github.workflow }}-${{ github.ref }}
+      cancel-in-progress: true
+    steps:
+      - uses: actions/checkout@v4
+        with:
+          fetch-depth: 0
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          tools: loadtest
+          cache-id: test-loadtest
+      - uses: actions-ecosystem/action-get-latest-tag@v1
+        id: get-latest-tag
+        with:
+          semver_only: true          
+      - name: Run loadtest
+        run: |
+          postgrest-loadtest-against main ${{ steps.get-latest-tag.outputs.tag }}
+          postgrest-loadtest-report > loadtest/loadtest.md
+      - name: Upload report
+        uses: actions/upload-artifact@v4
+        with:
+          name: loadtest.md
+          path: loadtest/loadtest.md
+          if-no-files-found: error
+
+  Loadtest-Merge-Nix:
+    name: Loadtest Merge (Nix)
+    if: ${{ github.event_name == 'push' }}
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+        with:
+          fetch-depth: 0
+      - uses: actions-ecosystem/action-get-latest-tag@v1
+        id: get-latest-tag
+        with:
+          semver_only: true          
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          tools: loadtest
+          cache-id: test-loadtest
+      - name: Run loadtest
+        run: |
+          postgrest-loadtest-against ${{ steps.get-latest-tag.outputs.tag }}
+          postgrest-loadtest-report > loadtest/loadtest.md
+      - name: Upload report
+        uses: actions/upload-artifact@v4
+        with:
+          name: loadtest.md
+          path: loadtest/loadtest.md
+          if-no-files-found: error
+        

.github/workflows/report.yaml

@@ -15,14 +15,14 @@ jobs:
     if: ${{ github.event.workflow_run.conclusion == 'success' }}
     steps:
       - name: Download from Artifacts
-        uses: dawidd6/action-download-artifact@v2
+        uses: dawidd6/action-download-artifact@v3
         with:
           workflow: ${{ github.event.workflow.name }}
           run_id: ${{github.event.workflow_run.id }}
           name: loadtest.md
           path: artifacts
       - name: Upload to GitHub Checks
-        uses: LouisBrunner/checks-action@v1.2.0
+        uses: LouisBrunner/checks-action@v1.6.2
         with:
           token: ${{ secrets.GITHUB_TOKEN }}
           sha: ${{ github.event.workflow_run.head_sha }}

.gitignore

@@ -21,3 +21,5 @@ __pycache__
 *.tix
 coverage
 .hpc
+loadtest
+.history

ARCHITECTURE.md

@@ -0,0 +1,68 @@
+# Architecture
+
+This document describes the high-level architecture of PostgREST.
+
+## Bird's Eye View
+
+```haskell
+postgrest :: Request -> Either Error SQLStatement -> Response
+```
+
+On the highest level, PostgREST processes an HTTP request, if it's accepted it builds a SQL statement for it, executes it, and produces a response.
+
+## Code Map
+
+This section talks briefly about various important modules.
+
+The starting point of the program is `main/Main.hs`, which calls `src/PostgREST/CLI.hs` which then calls `src/PostgREST/App.hs`.
+
+`App.hs` is then in charge of composing the different modules.
+
+### ApiRequest.hs
+
+PostgREST operates over two types of resources: database relations(tables or views) and database functions; providing different representations(depending on the media type)
+for them.
+
+This module is in charge of representing the operation over an `ApiRequest` type. It parses the URL querystring following PostgREST syntax, the request headers, and the request body
+(if possible it avoids parsing the body and sends it directly to the db).
+
+A request might be rejected at this level if it's invalid, e.g. providing an unknown media type to PostgREST or using an unknown HTTP method.
+
+### Plan.hs
+
+Using the Schema Cache, this module enables more complex functionality(like resource embedding) by enriching the ApiRequest. It generates Plan types(`ReadPlan`, `MutatePlan`)
+that then will be used to generate a SQL statement.
+
+A request might be rejected at this level if it's invalid, e.g. by doing resource embedding on a nonexistent resource.
+
+An OPTIONS request doesn't require a plan to be generated.
+
+### Query.hs
+
+This module constructs single SQL statements that can be parametrized and prepared. Only at this stage a PostgreSQL connection from the pool is used.
+
+A query might fail(and be rollbacked) at this level if it doesn't comply to certain conditions, e.g. by not returning a single row when a ``Accept: application/vnd.pgrst.object`` header is specified.
+
+An OPTIONS request doesn't require a query to be executed.
+
+### Response.hs
+
+This module constructs the HTTP response body with the right headers.
+
+It builds the OpenAPI response using the schema cache.
+
+### Auth.hs
+
+This module provides functions to deal with JWT authorization.
+
+### SchemaCache.hs
+
+This queries the PostgreSQL system catalogs and caches the metadata into a SchemaCache type,
+
+### AppState.hs
+
+The state of the App which is kept across requests.
+
+This spawns threads which are used to execute concurrent jobs.
+
+Jobs include connection recover and a listener for the PostgreSQL LISTEN command.

BACKERS.md

@@ -4,40 +4,40 @@ PostgREST ongoing development is only possible thanks to our Sponsors and Backer
 
 ## Sponsors
 
-<table>
+<table align="center">
   <tbody>
     <tr>
       <td align="center" valign="middle">
         <a href="https://www.cybertec-postgresql.com/en/?utm_source=postgrest.org&utm_medium=referral&utm_campaign=postgrest" target="_blank">
-          <img width="222px" src="static/cybertec-new.png">
+          <img width="296px" src="static/cybertec-new.png">
         </a>
       </td>
-      <td align="center" valign="middle">
-        <a href="https://www.2ndquadrant.com/en/?utm_campaign=External%20Websites&utm_source=PostgREST&utm_medium=Logo" target="_blank">
-          <img width="296px" src="static/2ndquadrant.png">
-        </a>
-      </td>
-      <td align="center" valign="middle">
-        <a href="https://tryretool.com/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
-          <img width="296px" src="static/retool.png">
-        </a>
-      </td>
-    </tr>
-    <tr></tr>
-    <tr>
       <td align="center" valign="middle">
         <a href="https://gnuhost.eu/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
           <img width="296px" src="static/gnuhost.png">
         </a>
       </td>
       <td align="center" valign="middle">
-        <a href="https://supabase.io?utm_source=postgrest%20backers&utm_medium=open%20source%20partner&utm_campaign=postgrest%20backers%20github&utm_term=homepage" target="_blank">
-          <img width="296px" src="static/supabase.png">
+        <a href="https://neon.tech/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="static/neon.jpg">
+        </a>
+      </td>
+    </tr>
+    <tr></tr>
+    <tr>
+      <td align="center" valign="middle">
+        <a href="https://code.build/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="static/code-build.png">
         </a>
       </td>
       <td align="center" valign="middle">
-        <a href="https://oblivious.ai/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
-          <img width="296px" src="static/oblivious.jpg">
+        <a href="https://supabase.io?utm_source=postgrest%20backers&utm_medium=open%20source%20partner&utm_campaign=postgrest%20backers%20github&utm_term=homepage" target="_blank">
+          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/supabase.png">
+        </a>
+      </td>
+      <td align="center" valign="middle">
+        <a href="https://tembo.io/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="static/tembo.png">
         </a>
       </td>
     </tr>
@@ -46,12 +46,14 @@ PostgREST ongoing development is only possible thanks to our Sponsors and Backer
 
 ## Lead Backers
 
+- [Roboflow](https://github.com/roboflow)
 - Evans Fernandes
 - [Jan Sommer](https://github.com/nerfpops)
 - [Franz Gusenbauer](https://www.igutech.at/)
 
 ## Backers
 
+- Zac Miller
 - Tsingson Qin
 - Michel Pelletier
 - Jay Hannah
@@ -73,7 +75,22 @@ PostgREST ongoing development is only possible thanks to our Sponsors and Backer
     <tr>
       <td align="center" valign="middle">
         <a href="https://www.timescale.com?utm_campaign=postgrest&utm_source=sponsor&utm_medium=referral&utm_content=github" target="_blank">
-          <img width="222px" src="static/timescaledb.png">
+          <img width="222px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/timescaledb.png">
+        </a>
+      </td>
+      <td align="center" valign="middle">
+        <a href="https://tryretool.com/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img max-width="222px" height="88" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/retool.png">
+        </a>
+      </td>
+      <td align="center" valign="middle">
+        <a href="https://www.2ndquadrant.com/en/?utm_campaign=External%20Websites&utm_source=PostgREST&utm_medium=Logo" target="_blank">
+          <img width="222px" src="static/2ndquadrant.png">
+        </a>
+      </td>
+      <td align="center" valign="middle">
+        <a href="https://oblivious.ai/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="222px" src="static/oblivious.jpg">
         </a>
       </td>
     </tr>

CHANGELOG.md

@@ -5,10 +5,384 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ## Unreleased
 
-### Added
+## [12.0.2] - 2023-12-20
 
 ### Fixed
 
+  - #3124, Fix table's media type handlers not working for all schemas - @steve-chavez
+  - #3126, Fix empty row on media type handler function - @steve-chavez
+
+## [12.0.1] - 2023-12-12
+
+### Fixed
+
+ - #3054, Fix not allowing special characters in JSON keys - @laurenceisla
+ - #2344, Replace JSON parser error with a clearer generic message - @develop7
+ - #3100, Add missing in-database configuration option for `jwt-cache-max-lifetime` - @laurenceisla
+ - #3089, The any media type handler now sets `Content-Type: application/octet-stream` by default instead of `Content-Type: application/json` - @steve-chavez
+
+## [12.0.0] - 2023-12-01
+
+### Added
+
+ - #1614, Add `db-pool-automatic-recovery` configuration to disable connection retrying - @taimoorzaeem
+ - #2492, Allow full response control when raising exceptions - @taimoorzaeem, @laurenceisla
+ - #2771, #2983, #3062, #3055 Add `Server-Timing` response header - @taimoorzaeem, @develop7, @laurenceisla
+ - #2698, Add config `jwt-cache-max-lifetime` and implement JWT caching - @taimoorzaeem
+ - #2943, Add `handling=strict/lenient` for Prefer header - @taimoorzaeem
+ - #2441, Add config `server-cors-allowed-origins` to specify CORS origins - @taimoorzaeem
+ - #2825, SQL handlers for custom media types - @steve-chavez
+   + Solves #1548, #2699, #2763, #2170, #1462, #1102, #1374, #2901
+ - #2799, Add timezone in Prefer header - @taimoorzaeem
+ - #3001, Add `statement_timeout` set on functions - @taimoorzaeem
+ - #3045, Apply superuser settings on impersonated roles if they have PostgreSQL 15 `GRANT SET ON PARAMETER` privilege - @steve-chavez
+ - #915, Add support for aggregate functions - @timabdulla
+    + The aggregate functions SUM(), MAX(), MIN(), AVG(), and COUNT() are now supported.
+    + It's disabled by default, you can enable it with `db-aggregates-enabled`.
+ - #3057, Log all internal database errors to stderr - @laurenceisla
+
+### Fixed
+
+ - #3015, Fix unnecessary count() on RPC returning single - @steve-chavez
+ - #1070, Fix HTTP status responses for upserts - @taimoorzaeem
+   + `PUT` returns `201` instead of `200` when rows are inserted
+   + `POST` with `Prefer: resolution=merge-duplicates` returns `200` instead of `201` when no rows are inserted
+ - #3019, Transaction-Scoped Settings are now shown clearly in the Postgres logs - @laurenceisla
+   + Shows `set_config('pgrst.setting_name', $1)` instead of `setconfig($1, $2)`
+   + Does not apply to role settings and `app.settings.*`
+ - #2420, Fix bogus message when listening on port 0 - @develop7
+ - #3067, Fix Acquision Timeout errors logging to stderr when `log-level=crit` - @laurenceisla
+
+### Changed
+
+ - Removed [raw-media-types config](https://postgrest.org/en/v11.1/references/configuration.html#raw-media-types) - @steve-chavez
+ - Removed `application/octet-stream`, `text/plain`, `text/xml` [builtin support for scalar results](https://postgrest.org/en/v11.1/references/api/resource_representation.html#scalar-function-response-format) - @steve-chavez
+ - Removed default `application/openapi+json` media type for [db-root-spec](https://postgrest.org/en/v11.1/references/configuration.html#db-root-spec) - @steve-chavez
+ - Removed [db-use-legacy-gucs](https://postgrest.org/en/v11.2/references/configuration.html#db-use-legacy-gucs) - @laurenceisla
+
+## [11.2.2] - 2023-10-25
+
+### Fixed
+
+ - #2824, Fix regression by reverting fix that returned 206 when first position = length in a `Range` header - @laurenceisla, @strengthless
+
+## [11.2.1] - 2023-10-03
+
+### Fixed
+
+ - #2899, Fix `application/vnd.pgrst.array` not accepted as a valid mediatype - @taimoorzaeem
+ - #2524, Fix schema cache and configuration reloading with `NOTIFY` not working on Windows - @diogob, @laurenceisla
+ - #2915, Fix duplicate headers in response - @taimoorzaeem
+ - #2824, Fix range request with first position same as length return status 206 - @taimoorzaeem
+ - #2939, Fix wrong `Preference-Applied` with `Prefer: tx=commit` when transaction is rollbacked - @steve-chavez
+ - #2939, Fix `count=exact` not being included in `Preference-Applied` - @steve-chavez
+ - #2800, Fix not including to-one embed resources that had a `NULL` value in any of the selected fields when doing null filtering on them - @laurenceisla
+ - #2846, Fix error when requesting `Prefer: count=<type>` and doing null filtering on embedded resources - @laurenceisla
+ - #2959, Fix setting `default_transaction_isolation` unnecessarily - @steve-chavez
+ - #2929, Fix arrow filtering on RPC returning dynamic TABLE with composite type - @steve-chavez
+ - #2963, Fix RPCs not embedding correctly when using overloaded functions for computed relationships - @laurenceisla
+ - #2970, Fix regression that rejects URI connection strings with certain unescaped characters in the password - @laurenceisla, @steve-chavez
+
+## [11.2.0] - 2023-08-10
+
+### Added
+
+ - #2523, Data representations - @aljungberg
+   + Allows for flexible API output formatting and input parsing on a per-column type basis using regular SQL functions configured in the database
+   + Enables greater flexibility in the form and shape of your APIs, both for output and input, making PostgREST a more versatile general-purpose API server
+   + Examples include base64 encode/decode your binary data (like a `bytea` column containing an image), choose whether to present a timestamp column as seconds since the Unix epoch or as an ISO 8601 string, or represent fixed precision decimals as strings, not doubles, to preserve precision
+   + ...and accept the same in `POST/PUT/PATCH` by configuring the reverse transformation(s)
+   + Other use-cases include custom representation of enums, arrays, nested objects, CSS hex colour strings, gzip compressed fields, metric to imperial conversions, and much more
+   + Works when using the `select` parameter to select only a subset of columns, embedding through complex joins, renaming fields, with views and computed columns
+   + Works when filtering on a formatted column without extra indexes by parsing to the canonical representation
+   + Works for data `RETURNING` operations, such as requesting the full body in a POST/PUT/PATCH with `Prefer: return=representation`
+   + Works for batch updates and inserts
+   + Completely optional, define the functions in the database and they will be used automatically everywhere
+   + Data representations preserve the ability to write to the original column and require no extra storage or complex triggers (compared to using `GENERATED ALWAYS` columns)
+   + Note: data representations require Postgres 10 (Postgres 11 if using `IN` predicates); data representations are not implemented for RPC
+ - #2647, Allow to verify the PostgREST version in SQL: `select distinct application_name from pg_stat_activity`. - @laurenceisla
+ - #2856, Add the `--version` CLI option that prints the version information - @laurenceisla
+ - #1655, Improve `details` field of the singular error response - @taimoorzaeem
+ - #740, Add `Preference-Applied` in response for `Prefer: return=representation/headers-only/minimal` - @taimoorzaeem
+ - #1601, Add optional `nulls=stripped` parameter for mediatypes `application/vnd.pgrst.array+json` and `application/vnd.pgrst.object+json` - @taimoorzaeem
+
+### Fixed
+
+ - #2821, Fix OPTIONS not accepting all available media types - @steve-chavez
+ - #2834, Fix compilation on Ubuntu by being compatible with GHC 9.0.2 - @steve-chavez
+ - #2840, Fix `Prefer: missing=default` with DOMAIN default values - @steve-chavez
+ - #2849, Fix HEAD unnecessarily executing aggregates - @steve-chavez
+ - #2594, Fix unused index on jsonb/jsonb arrow filter and order (``/bets?data->>contractId=eq.1`` and ``/bets?order=data->>contractId``) - @steve-chavez
+ - #2861, Fix character and bit columns with fixed length not inserting/updating properly - @laurenceisla
+   + Fixes the error "value too long for type character(1)" when the char length of the column was bigger than one.
+ - #2862, Fix null filtering on embedded resource when using a column name equal to the relation name - @steve-chavez
+ - #1586, Fix function parameters of type character and bit not ignoring length - @laurenceisla
+   + Fixes the error "value too long for type character(1)" when the char length of the parameter was bigger than one.
+ - #2881, Fix error when a function returns `RECORD` or `SET OF RECORD` - @laurenceisla
+ - #2896, Fix applying superuser settings for impersonated role - @steve-chavez
+
+### Deprecated
+
+ - #2863, Deprecate resource embedding target disambiguation - @steve-chavez
+   + The `/table?select=*,other!fk(*)` must be used to disambiguate
+   + The server aids in choosing the `!fk` by sending a `hint` on the error whenever an ambiguous request happens.
+
+## [11.1.0] - 2023-06-07
+
+### Added
+
+ - #2786, Limit idle postgresql connection lifetime - @robx
+   + New option `db-pool-max-idletime` (default 30s).
+   + This is equivalent to the old option `db-pool-timeout` of PostgREST 10.0.0.
+   + A config alias for `db-pool-timeout` is included.
+ - #2703, Add pre-config function - @steve-chavez
+    + New config option `db-pre-config`(empty by default)
+    + Allows using the in-database configuration without SUPERUSER
+ - #2781, When `db-channel-enabled` is false, start automatic connection recovery on a new request when pool connections are closed with `pg_terminate_backend` - @steve-chavez
+    + Mitigates the lack of LISTEN/NOTIFY for schema cache reloading on read replicas.
+
+### Fixed
+
+ - #2791, Fix dropping schema cache reload notifications  - @steve-chavez
+ - #2801, Stop retrying connection when "no password supplied" - @steve-chavez
+
+## [11.0.1] - 2023-04-27
+
+### Fixed
+
+ - #2762, Fixes "permission denied for schema" error during schema cache load - @steve-chavez
+ - #2756, Fix bad error message on generated columns when using `Prefer: missing=default` - @steve-chavez
+ - #1139, Allow a 30 second skew for JWT validation - @steve-chavez
+   + It used to be 1 second, which was too strict
+
+## [11.0.0] - 2023-04-16
+
+### Added
+
+ - #1414, Add related orders - @steve-chavez
+   + On a many-to-one or one-to-one relationship, you can order a parent by a child column `/projects?select=*,clients(*)&order=clients(name).desc.nullsfirst`
+ - #1233, #1907, #2566, Allow spreading embedded resources - @steve-chavez
+   + On a many-to-one or one-to-one relationship, you can unnest a json object with `/projects?select=*,...clients(client_name:name)`
+   + Allows including the join table columns when resource embedding
+   + Allows disambiguating a recursive m2m embed
+   + Allows disambiguating an embed that has a many-to-many relationship using two foreign keys on a junction
+ - #2340, Allow embedding without selecting any column - @steve-chavez
+ - #2563, Allow `is.null` or `not.is.null` on an embedded resource - @steve-chavez
+   + Offers a more flexible replacement for `!inner`, e.g. `/projects?select=*,clients(*)&clients=not.is.null`
+   + Allows doing an anti join, e.g. `/projects?select=*,clients(*)&clients=is.null`
+   + Allows using or across related tables conditions
+ - #1100, Customizable OpenAPI title - @AnthonyFisi
+ - #2506, Add `server-trace-header` for tracing HTTP requests.  - @steve-chavez
+   + When the client sends the request header specified in the config it will be included in the response headers.
+ - #2694, Make `db-root-spec` stable. - @steve-chavez
+   + This can be used to override the OpenAPI spec with a custom database function
+ - #1567, On bulk inserts, missing values can get the column DEFAULT by using the `Prefer: missing=default` header - @steve-chavez
+ - #2501, Allow filtering by`IS DISTINCT FROM` using the `isdistinct` operator, e.g. `/people?alias=isdistinct.foo`
+ - #1569, Allow `any/all` modifiers on the `eq,like,ilike,gt,gte,lt,lte,match,imatch` operators, e.g. `/tbl?id=eq(any).{1,2,3}` - @steve-chavez
+   - This converts the input into an array type
+ - #2561, Configurable role settings - @steve-chavez
+   - Database roles that are members of the connection role get their settings applied, e.g. doing
+     `ALTER ROLE anon SET statement_timeout TO '5s'` will result in that `statement_timeout` getting applied for that role.
+   - Works when switching roles when a JWT is sent
+   - Settings can be reloaded with `NOTIFY pgrst, 'reload config'`.
+ - #2468, Configurable transaction isolation level with `default_transaction_isolation` - @steve-chavez
+   - Can be set per function `create function .. set default_transaction_isolation = 'repeatable read'`
+   - Or per role `alter role .. set default_transaction_isolation = 'serializable'`
+
+### Fixed
+
+ - #2651, Add the missing `get` path item for RPCs to the OpenAPI output - @laurenceisla
+ - #2648, Fix inaccurate error codes with new ones - @laurenceisla
+   + `PGRST204`: Column is not found
+   + `PGRST003`: Timed out when acquiring connection to db
+ - #1652, Fix function call with arguments not inlining - @steve-chavez
+ - #2705, Fix bug when using the `Range` header on `PATCH/DELETE` - @laurenceisla
+   + Fix the`"message": "syntax error at or near \"RETURNING\""` error
+   + Fix doing a limited update/delete when an `order` query parameter was present
+ - #2742, Fix db settings and pg version queries not getting prepared  - @steve-chavez
+ - #2618, Fix `PATCH` requests not recognizing embedded filters and using the top-level resource instead - @steve-chavez
+
+### Changed
+
+ - #2705, The `Range` header is now only considered on `GET` requests and is ignored for any other method - @laurenceisla
+   + Other methods should use the `limit/offset` query parameters for sub-ranges
+   + `PUT` requests no longer return an error when this header is present (using `limit/offset` still triggers the error)
+ - #2733, Remove bulk RPC call with the `Prefer: params=multiple-objects` header. A function with a JSON array or object parameter should be used instead.
+
+## [10.2.0] - 2023-04-12
+
+### Added
+
+ - #2663, Limit maximal postgresql connection lifetime - @robx
+   + New option `db-pool-max-lifetime` (default 30m)
+   + `db-pool-acquisition-timeout` is no longer optional and defaults to 10s
+   + Fixes postgresql resource leak with long-lived connections (#2638)
+
+### Fixed
+
+ - #2667, Fix `db-pool-acquisition-timeout` not logging to stderr when the timeout is reached - @steve-chavez
+
+## [10.1.2] - 2023-02-01
+
+### Fixed
+
+ - #2565, Fix bad M2M embedding on RPC - @steve-chavez
+ - #2575, Replace misleading error message when no function is found with a hint containing functions/parameters names suggestions - @laurenceisla
+ - #2582, Move explanation about "single parameters" from the `message` to the `details` in the error output - @laurenceisla
+ - #2569, Replace misleading error message when no relationship is found with a hint containing parent/child names suggestions - @laurenceisla
+ - #1405, Add the required OpenAPI items object when the parameter is an array - @laurenceisla
+ - #2592, Add upsert headers for POST requests to the OpenAPI output - @laurenceisla
+ - #2623, Fix FK pointing to VIEW instead of TABLE in OpenAPI output - @laurenceisla
+ - #2622, Consider any PostgreSQL authentication failure as fatal and exit immediately - @michivi
+ - #2620, Fix `NOTIFY pgrst` not reloading the db connections catalog cache - @steve-chavez
+
+## [10.1.1] - 2022-11-08
+
+### Fixed
+
+ - #2548, Fix regression when embedding views with partial references to multi column FKs - @wolfgangwalther
+ - #2558, Fix regression when requesting limit=0 and `db-max-row` is set - @laurenceisla
+ - #2542, Return a clear error without hitting the database when trying to update or insert an unknown column with `?columns` - @aljungberg
+
+## [10.1.0] - 2022-10-28
+
+### Added
+
+ - #2348, Add `db-pool-acquisition-timeout` configuration option, time in seconds to wait to acquire a connection. - @robx
+
+### Fixed
+
+ - #2261, #2349, #2467, Reduce allocations communication with PostgreSQL, particularly for request bodies. - @robx
+ - #2401, #2444, Fix SIGUSR1 to fully flush connections pool. - @robx
+ - #2428, Fix opening an empty transaction on failed resource embedding - @steve-chavez
+ - #2455, Fix embedding the same table multiple times - @steve-chavez
+ - #2518, Fix a regression when embedding views where base tables have a different column order for FK columns - @wolfgangwalther
+ - #2458, Fix a regression with the location header when inserting into views with PKs from multiple tables - @wolfgangwalther
+ - #2356, Fix a regression in openapi output with mode follow-privileges - @wolfgangwalther
+ - #2283, Fix infinite recursion when loading schema cache with self-referencing view - @wolfgangwalther
+ - #2343, Return status code 200 for PATCH requests which don't affect any rows - @wolfgangwalther
+ - #2481, Treat computed relationships not marked SETOF as M2O/O2O relationship - @wolfgangwalther
+ - #2534, Fix embedding a computed relationship with a normal relationship - @steve-chavez
+ - #2362, Fix error message when [] is used inside select - @wolfgangwalther
+ - #2475, Disallow !inner on computed columns - @wolfgangwalther
+ - #2285, Ignore leading and trailing spaces in column names when parsing the query string - @wolfgangwalther
+ - #2545, Fix UPSERT with PostgreSQL 15 - @wolfgangwalther
+ - #2459, Fix embedding views with multiple references to the same base column - @wolfgangwalther
+
+### Changed
+
+ - #2444, Removed `db-pool-timeout` option, because this was removed upstream in hasql-pool. - @robx
+ - #2343, PATCH requests that don't affect any rows no longer return 404 - @wolfgangwalther
+ - #2537, Stricter parsing of query string. Instead of silently ignoring, the parser now throws on invalid syntax like json paths for embeddings, hints for regular columns, empty casts or fts languages, etc. - @wolfgangwalther
+
+### Deprecated
+
+ - #1385, Deprecate bulk-calls when including the `Prefer: params=multiple-objects` in the request. A function with a JSON array or object parameter should be used instead for a better performance.
+
+## [10.0.0] - 2022-08-18
+
+### Added
+
+ - #1933, #2109, Add a minimal health check endpoint - @steve-chavez
+   + For enabling this, the `admin-server-port` config must be set explictly
+   + A `<host>:<admin_server_port>/live` endpoint is available for checking if postgrest is running on its port/socket. 200 OK = alive, 503 = dead.
+   + A `<host>:<admin_server_port>/ready` endpoint is available for checking a correct internal state(the database connection plus the schema cache). 200 OK = ready, 503 = not ready.
+ - #1988, Add the current user to the request log on stdout - @DavidLindbom, @wolfgangwalther
+ - #1823, Add the ability to run postgrest without any configuration. - @wolfgangwalther
+   + #1991, Add the ability to run without `db-uri` using libpq's PG environment variables to connect. - @wolfgangwalther
+   + #1769, Add the ability to run without `db-schemas`, defaulting to `db-schemas=public`. - @wolfgangwalther
+   + #1689, Add the ability to run without `db-anon-role` disabling anonymous access. - @wolfgangwalther
+ - #1543, Allow access to fields of composite types in select=, order= and filters through JSON operators -> and ->>. - @wolfgangwalther
+ - #2075, Allow access to array items in ?select=, ?order= and filters through JSON operators -> and ->>. - @wolfgangwalther
+ - #2156, #2211, Allow applying `limit/offset` to UPDATE/DELETE to only affect a subset of rows - @steve-chavez
+   + It requires an explicit `order` on a unique column(s)
+ - #1917, Add error codes with the `"PGRST"` prefix to the error response body to differentiate PostgREST errors from PostgreSQL errors - @laurenceisla
+ - #1917, Normalize the error response body by always having the `detail` and `hint` error fields with a `null` value if they are empty - @laurenceisla
+ - #2176, Errors raised with `SQLSTATE` now include the message and the code in the response body - @laurenceisla
+ - #2236, Support POSIX regular expression operators for row filtering - @enote-kane
+ - #2202, Allow returning XML from RPCs - @fjf2002
+ - #2268, Allow returning XML from single-column queries - @fjf2002
+ - #2300, RPC POST for function w/single unnamed XML param #2300 - @fjf2002
+ - #1564, Allow geojson output by specifying the `Accept: application/geo+json` media type - @steve-chavez
+   + Requires postgis >= 3.0
+   + Works for GET, RPC, POST/PATCH/DELETE with `Prefer: return=representation`.
+   + Resource embedding works and the embedded rows will go into the `properties` key
+   + In case of multiple geometries in the same table, you can choose which one will go into the `geometry` key with the usual `?select` query parameter.
+ - #1082, Add security definitions to the OpenAPI output - @laurenceisla
+ - #2378, Support http OPTIONS method on RPC and root path - @steve-chavez
+ - #2354, Allow getting the EXPLAIN plan of a request by using the `Accept: application/vnd.pgrst.plan` header - @steve-chavez
+   + Only allowed if the `db-plan-enabled` config is set to true
+   + Can generate the plan for different media types using the `for` parameter: `Accept: application/vnd.pgrst.plan; for="application/vnd.pgrst.object"`
+   + Different options for the plan can be used with the `options` parameter: `Accept: application/vnd.pgrst.plan; options=analyze|verbose|settings|buffers|wal`
+   + The plan can be obtained in text or json by using different media type suffixes: `Accept: application/vnd.pgrst.plan+text` and `Accept: application/vnd.pgrst.plan+json`.
+ - #2144, Support computed relationships which allow extending and overriding relationships for resource embedding - @steve-chavez, @wolfgangwalther
+ - #1984, Detect one-to-one relationships for resource embedding - @steve-chavez
+   + Detected when there's a foreign key with a unique constraint or when a foreign key is also a primary key
+
+### Fixed
+
+ - #2058, Return 204 No Content without Content-Type for PUT - @wolfgangwalther
+ - #2107, Clarify error for failed schema cache load. - @steve-chavez
+   + From `Database connection lost. Retrying the connection` to `Could not query the database for the schema cache. Retrying.`
+ - #1771, Fix silently ignoring filter on a non-existent embedded resource - @steve-chavez
+ - #2152, Remove functions, which are uncallable because of unnamend arguments from schema cache and OpenAPI output. - @wolfgangwalther
+ - #2145, Fix accessing json array fields with -> and ->> in ?select= and ?order=. - @wolfgangwalther
+ - #2155, Ignore `max-rows` on POST, PATCH, PUT and DELETE - @steve-chavez
+ - #2254, Fix inferring a foreign key column as a primary key column on views - @steve-chavez
+ - #2070, Restrict generated many-to-many relationships - @steve-chavez
+   + Only adds many-to-many relationships when: a table has FKs to two other tables and these FK columns are part of the table's PK columns.
+ - #2278, Allow casting to types with underscores and numbers(e.g. `select=oid_array::_int4`) - @steve-chavez
+ - #2277, #2238, #1643, Prevent views from breaking one-to-many/many-to-one embeds when using column or FK as target - @steve-chavez
+    + When using a column or FK as target for embedding(`/tbl?select=*,col-or-fk(*)`), only tables are now detected and views are not.
+    + You can still use a column or an inferred FK on a view to embed a table(`/view?select=*,col-or-fk(*)`)
+ - #2317, Increase the `db-pool-timeout` to 1 hour to prevent frequent high connection latency - @steve-chavez
+ - #2341, The search path now correctly identifies schemas with uppercase and special characters in their names (regression) - @laurenceisla
+ - #2364, "404 Not Found" on nested routes and "405 Method Not Allowed" errors no longer start an empty database transaction - @steve-chavez
+ - #2342, Fix inaccurate result count when an inner embed was selected after a normal embed in the query string - @laurenceisla
+ - #2376, OPTIONS requests no longer start an empty database transaction - @steve-chavez
+ - #2395, Allow using columns with dollar sign($) without double quoting in filters and `select` - @steve-chavez
+ - #2410, Fix loop crash error on startup in Postgres 15 beta 3. Log: "UNION types \"char\" and text cannot be matched". - @yevon
+ - #2397, Fix race conditions managing database connection helper - @robx
+ - #2269, Allow `limit=0` in the request query to return an empty array - @gautam1168, @laurenceisla
+ - #2401, Ensure database connections can't outlive SIGUSR1 - @robx
+
+### Changed
+
+ - #2001, Return 204 No Content without Content-Type for RPCs returning VOID - @wolfgangwalther
+   + Previously, those RPCs would return "null" as a body with Content-Type: application/json.
+ - #2156, `limit/offset` now limits the affected rows on UPDATE/DELETE  - @steve-chavez
+   + Previously, `limit/offset` only limited the returned rows but not the actual updated rows
+ - #2155, `max-rows` is no longer applied on POST/PATCH/PUT/DELETE returned rows - @steve-chavez
+   + This was misleading because the affected rows were not really affected by `max-rows`, only the returned rows were limited
+ - #2070, Restrict generated many-to-many relationships - @steve-chavez
+   + A primary key that contains the foreign key columns is now needed for generating many-to-many relationships.
+ - #2277, Views now are not detected when embedding using the column or FK as target (`/view?select=*,column(*)`) - @steve-chavez
+   + This embedding form was easily made ambiguous whenever a new view was added.
+   + You can use computed relationships to keep this embedding form working
+ - #2312, Using `Prefer: return=representation` no longer returns a `Location` header - @laurenceisla
+ - #1984, For the cases where one to one relationships are detected, json objects will be returned instead of json arrays of length 1
+   + If you wish to override this behavior, you can use computed relationships to return arrays again
+
+## [9.0.1] - 2022-06-03
+
+### Fixed
+
+- #2165, Fix json/jsonb columns should not have type in OpenAPI spec - @clrnd
+- #2020, Execute deferred constraint triggers when using `Prefer: tx=rollback` - @wolfgangwalther
+- #2077, Fix `is` not working with upper or mixed case values like `NULL, TrUe, FaLsE` - @steve-chavez
+- #2024, Fix schema cache loading when views with XMLTABLE and DEFAULT are present - @wolfgangwalther
+- #1724, Fix wrong CORS header Authentication -> Authorization - @wolfgangwalther
+- #2120, Fix reading database configuration properly when `=` is present in value - @wolfgangwalther
+- #2135, Remove trigger functions from schema cache and OpenAPI output, because they can't be called directly anyway. - @wolfgangwalther
+- #2101, Remove aggregates, procedures and window functions from the schema cache and OpenAPI output. - @wolfgangwalther
+- #2153, Fix --dump-schema running with a wrong PG version. - @wolfgangwalther
+- #2042, Keep working when EMFILE(Too many open files) is reached. - @steve-chavez
+- #2147, Ignore `Content-Type` headers for `GET` requests when calling RPCs. - @laurenceisla
+    + Previously, `GET` without parameters, but with `Content-Type: text/plain` or `Content-Type: application/octet-stream` would fail with `404 Not Found`, even if a function without arguments was available.
+- #2239, Fix misleading disambiguation error where the content of the `relationship` key looks like valid syntax - @laurenceisla
+- #2294, Disable parallel GC for better performance on higher core CPUs - @steve-chavez
+- #1076, Fix using CPU while idle - @steve-chavez
+
 ## [9.0.0] - 2021-11-25
 
 ### Added

README.md

@@ -2,9 +2,6 @@
 
 [![Donate](https://img.shields.io/badge/Donate-Patreon-orange.svg?colorB=F96854)](https://www.patreon.com/postgrest)
 [![Donate](https://img.shields.io/badge/Donate-PayPal-green.svg)](https://www.paypal.me/postgrest)
-<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.org)
 [![Docker Stars](https://img.shields.io/docker/pulls/postgrest/postgrest.svg)](https://hub.docker.com/r/postgrest/postgrest/)
@@ -18,40 +15,40 @@ API than you are likely to write from scratch.
 
 ## Sponsors
 
-<table>
+<table align="center">
   <tbody>
     <tr>
       <td align="center" valign="middle">
         <a href="https://www.cybertec-postgresql.com/en/?utm_source=postgrest.org&utm_medium=referral&utm_campaign=postgrest" target="_blank">
-          <img width="222px" src="static/cybertec-new.png">
+          <img width="296px" src="static/cybertec-new.png">
         </a>
       </td>
-      <td align="center" valign="middle">
-        <a href="https://www.2ndquadrant.com/en/?utm_campaign=External%20Websites&utm_source=PostgREST&utm_medium=Logo" target="_blank">
-          <img width="296px" src="static/2ndquadrant.png">
-        </a>
-      </td>
-      <td align="center" valign="middle">
-        <a href="https://tryretool.com/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
-          <img width="296px" src="static/retool.png">
-        </a>
-      </td>
-    </tr>
-    <tr></tr>
-    <tr>
       <td align="center" valign="middle">
         <a href="https://gnuhost.eu/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
           <img width="296px" src="static/gnuhost.png">
         </a>
       </td>
       <td align="center" valign="middle">
-        <a href="https://supabase.io?utm_source=postgrest%20backers&utm_medium=open%20source%20partner&utm_campaign=postgrest%20backers%20github&utm_term=homepage" target="_blank">
-          <img width="296px" src="static/supabase.png">
+        <a href="https://neon.tech/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="static/neon.jpg">
+        </a>
+      </td>
+    </tr>
+    <tr></tr>
+    <tr>
+      <td align="center" valign="middle">
+        <a href="https://code.build/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="static/code-build.png">
         </a>
       </td>
       <td align="center" valign="middle">
-        <a href="https://oblivious.ai/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
-          <img width="296px" src="static/oblivious.jpg">
+        <a href="https://supabase.io?utm_source=postgrest%20backers&utm_medium=open%20source%20partner&utm_campaign=postgrest%20backers%20github&utm_term=homepage" target="_blank">
+          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/supabase.png">
+        </a>
+      </td>
+      <td align="center" valign="middle">
+        <a href="https://tembo.io/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="static/tembo.png">
         </a>
       </td>
     </tr>

app.json

@@ -1,59 +0,0 @@
-{
-  "name": "PostgREST",
-  "description": "RESTful API for any PostgreSQL database.",
-  "logo": "https://avatars2.githubusercontent.com/u/15115011",
-  "repository": "https://github.com/PostgREST/postgrest",
-  "env": {
-    "BUILDPACK_URL": {
-      "description": "Heroku buildpack for deploying Haskell applications",
-      "value": "https://github.com/PostgREST/postgrest-heroku"
-    },
-    "POSTGREST_VER": {
-      "description": "Version of PostgREST to deploy",
-      "value": "8.0.0"
-    },
-    "DB_URI": {
-      "description": "Database connection string, e.g. postgres://user:pass@xxxxxxx.rds.amazonaws.com/mydb",
-      "required": true
-    },
-    "DB_SCHEMA": {
-      "description": "The database schema to expose to REST clients. Tables, views and stored procedures in this schema will get API endpoints",
-      "required": true,
-      "value": "public"
-    },
-    "DB_ANON_ROLE": {
-      "description": "The database role to use when executing commands on behalf of unauthenticated clients",
-      "required": true
-    },
-    "DB_POOL": {
-      "description": "Number of connections to keep open in PostgREST’s database pool",
-      "required": false,
-      "value": "10"
-    },
-    "SERVER_PROXY_URI": {
-      "description": "Overrides the base URL used within the OpenAPI self-documentation hosted at the API root path",
-      "required": false
-    },
-    "JWT_SECRET": {
-      "description": "The secret used to decode JWT tokens clients provide for authentication",
-      "required": false
-    },
-    "SECRET_IS_BASE64": {
-      "description": "When this is set to true, the value derived from jwt-secret will be treated as a base64 encoded secret",
-      "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
-    },
-    "PRE_REQUEST": {
-      "description": "A schema-qualified stored procedure name to call right after switching roles for a client request",
-      "required": false
-    }
-  }
-}

cabal.project.freeze

@@ -0,0 +1 @@
+index-state: hackage.haskell.org 2023-10-13T13:54:33Z

cabal.project.non-nix

@@ -0,0 +1,20 @@
+-- Settings to allow building with plain cabal. If this was
+-- named just cabal.project, it would interfere with the default
+-- nix build.
+
+packages: .
+
+-- Example of depending on a forked repository (the same dependency
+-- would be mentioned in nix/overlays/haskell-packages.nix and
+-- stack.yaml, and should refer to a main branch commit of the
+-- repository.
+--
+-- source-repository-package
+--  type: git
+--  location: https://github.com/PostgREST/hasql-pool.git
+--  tag: 4d462c4d47d762effefc7de6c85eaed55f144f1d
+
+source-repository-package
+  type: git
+  location: https://github.com/PostgREST/postgresql-libpq.git
+  tag: 890a0a16cf57dd401420fdc6c7d576fb696003bc

default.nix

@@ -1,9 +1,11 @@
+{ system ? builtins.currentSystem }:
+
 let
   name =
     "postgrest";
 
   compiler =
-    "ghc8107";
+    "ghc924";
 
   # PostgREST source files, filtered based on the rules in the .gitignore files
   # and file extensions. We want to include as litte as possible, as the files
@@ -34,24 +36,40 @@ let
       allOverlays.build-toolbox
       allOverlays.checked-shell-script
       allOverlays.gitignore
-      allOverlays.postgresql-default
+      allOverlays.postgis
+      (allOverlays.postgresql-default { inherit patches; })
       allOverlays.postgresql-legacy
       allOverlays.postgresql-future
       (allOverlays.haskell-packages { inherit compiler; })
+      allOverlays.slocat
     ];
 
   # Evaluated expression of the Nixpkgs repository.
   pkgs =
-    import nixpkgs { inherit overlays; };
+    import nixpkgs { inherit overlays system; };
 
   postgresqlVersions =
     [
-      { name = "postgresql-14"; postgresql = pkgs.postgresql_14; }
-      { name = "postgresql-13"; postgresql = pkgs.postgresql_13; }
-      { name = "postgresql-12"; postgresql = pkgs.postgresql_12; }
-      { name = "postgresql-11"; postgresql = pkgs.postgresql_11; }
-      { name = "postgresql-10"; postgresql = pkgs.postgresql_10; }
-      { name = "postgresql-9.6"; postgresql = pkgs.postgresql_9_6; }
+      {
+        name = "postgresql-16";
+        postgresql = pkgs.postgresql_16.withPackages (p: [
+          p.postgis
+          (p.pg_safeupdate.overrideAttrs (old: {
+            installPhase = ''
+              mkdir -p $out/bin
+              cp safeupdate.dylib safeupdate.so || true
+              install -D safeupdate.so -t $out/lib
+            '';
+          }))
+        ]);
+      }
+      { name = "postgresql-15"; postgresql = pkgs.postgresql_15.withPackages (p: [ p.postgis p.pg_safeupdate ]); }
+      { name = "postgresql-14"; postgresql = pkgs.postgresql_14.withPackages (p: [ p.postgis p.pg_safeupdate ]); }
+      { name = "postgresql-13"; postgresql = pkgs.postgresql_13.withPackages (p: [ p.postgis p.pg_safeupdate ]); }
+      { name = "postgresql-12"; postgresql = pkgs.postgresql_12.withPackages (p: [ p.postgis p.pg_safeupdate ]); }
+      { name = "postgresql-11"; postgresql = pkgs.postgresql_11.withPackages (p: [ p.postgis p.pg_safeupdate ]); }
+      { name = "postgresql-10"; postgresql = pkgs.postgresql_10.withPackages (p: [ p.postgis p.pg_safeupdate ]); }
+      { name = "postgresql-9.6"; postgresql = pkgs.postgresql_9_6.withPackages (p: [ p.postgis p.pg_safeupdate ]); }
     ];
 
   patches =
@@ -61,10 +79,16 @@ let
   postgrest =
     pkgs.haskell.packages."${compiler}".callCabal2nix name src { };
 
-  # Function that derives a fully static Haskell package based on
+  # Functionality that derives a fully static Haskell package based on
   # nh2/static-haskell-nix
   staticHaskellPackage =
-    import nix/static-haskell-package.nix { inherit nixpkgs compiler patches allOverlays; };
+    import nix/static-haskell-package.nix { inherit nixpkgs system compiler patches allOverlays; };
+
+  # Static executable.
+  postgrestStatic =
+    lib.justStaticExecutables (lib.dontCheck (staticHaskellPackage name src).package);
+
+  packagesStatic = (staticHaskellPackage name src).survey;
 
   # Options passed to cabal in dev tools and tests
   devCabalOptions =
@@ -90,10 +114,6 @@ rec {
   postgrestPackage =
     lib.dontCheck postgrest;
 
-  # Static executable.
-  postgrestStatic =
-    lib.justStaticExecutables (lib.dontCheck (staticHaskellPackage name src));
-
   # Profiled dynamic executable.
   postgrestProfiled =
     lib.enableExecutableProfiling (
@@ -115,13 +135,16 @@ rec {
   cabalTools =
     pkgs.callPackage nix/tools/cabalTools.nix { inherit devCabalOptions postgrest; };
 
+  withTools =
+    pkgs.callPackage nix/tools/withTools.nix { inherit cabalTools devCabalOptions postgresqlVersions postgrest; };
+
   # Development tools.
   devTools =
     pkgs.callPackage nix/tools/devTools.nix { inherit tests style devCabalOptions hsie withTools; };
 
-  # Docker images and loading script.
-  docker =
-    pkgs.callPackage nix/tools/docker { postgrest = postgrestStatic; };
+  # Load testing tools.
+  loadtest =
+    pkgs.callPackage nix/tools/loadtest.nix { inherit withTools; };
 
   # Script for running memory tests.
   memory =
@@ -145,8 +168,14 @@ rec {
       inherit postgrest devCabalOptions withTools;
       ghc = pkgs.haskell.compiler."${compiler}";
       inherit (pkgs.haskell.packages."${compiler}") hpc-codecov;
+      inherit (pkgs.haskell.packages."${compiler}") weeder;
     };
+} // pkgs.lib.optionalAttrs pkgs.stdenv.isLinux rec {
+  # Static executable.
+  inherit postgrestStatic;
+  inherit packagesStatic;
 
-  withTools =
-    pkgs.callPackage nix/tools/withTools.nix { inherit postgresqlVersions; };
+  # Docker images and loading script.
+  docker =
+    pkgs.callPackage nix/tools/docker { postgrest = postgrestStatic; };
 }

main/Main.hs

@@ -1,42 +1,16 @@
-{-# LANGUAGE CPP #-}
-
 module Main (main) where
 
-import qualified Data.Map.Strict as M
-
 import System.IO (BufferMode (..), hSetBuffering)
 
-import qualified PostgREST.App as App
 import qualified PostgREST.CLI as CLI
 
-import PostgREST.Config (readPGRSTEnvironment)
-
 import Protolude
 
-#ifndef mingw32_HOST_OS
-import qualified PostgREST.Unix as Unix
-#endif
-
 main :: IO ()
 main = do
   setBuffering
-  hasPGRSTEnv <- not . M.null <$> readPGRSTEnvironment
-  opts <- CLI.readCLIShowHelp hasPGRSTEnv
-  CLI.main installSignalHandlers runAppInSocket opts
-
-installSignalHandlers :: App.SignalHandlerInstaller
-#ifndef mingw32_HOST_OS
-installSignalHandlers = Unix.installSignalHandlers
-#else
-installSignalHandlers _ = pass
-#endif
-
-runAppInSocket :: Maybe App.SocketRunner
-#ifndef mingw32_HOST_OS
-runAppInSocket = Just Unix.runAppWithSocket
-#else
-runAppInSocket = Nothing
-#endif
+  opts <- CLI.readCLIShowHelp
+  CLI.main opts
 
 setBuffering :: IO ()
 setBuffering = do

nix/README.md

@@ -5,24 +5,14 @@ for developing, testing and building PostgREST.
 
 ## Getting started with Nix
 
-You'll need to [get Nix](https://nixos.org/download.html). The installer will
-create your Nix store in the `/nix/` directory, where all build artifacts and
-their dependencies will be stored. It will also link the Nix executables like
-`nix-env`, `nix-build` and `nix-shell` into your PATH. Nix will manage all
-other PostgREST dependencies from here on out. To clean up older build
-artifacts from the `/nix/store`, you can run `nix-collect-garbage`.
-
-If you are on a system that does not support nix, for example Windows, you can
-run the nix development environment in a docker container. Inside the `nix/`
-directory run `docker-compose run --rm nix` to start the docker container. This
-will set up the binary cache and launch `nix-shell` automatically.
+You'll need to [get Nix](https://nixos.org/download.html). Follow the recommended installation for your operating system from the official download website.
 
 ## Building PostgREST
 
 To build PostgREST from your local checkout of the repository, run:
 
 ```bash
-nix-build --attr postgrestPackage
+$ nix-build --attr postgrestPackage
 
 ```
 
@@ -32,6 +22,15 @@ build the `postgrestPackage` attribute from the Nix expression it finds in our
 `default.nix` (see below for details). Nix will take care of getting the right
 GHC version and all the build dependencies.
 
+You can also build a statically linked binary with:
+
+```bash
+$ nix-build --attr postgrestStatic
+
+$ ldd result/bin/postgrest
+$       not a dynamic executable
+```
+
 ## Binary cache
 
 We recommend that you use the PostgREST binary cache on
@@ -39,10 +38,10 @@ We recommend that you use the PostgREST binary cache on
 
 ```bash
 # Install cachix:
-nix-env -iA cachix -f https://cachix.org/api/v1/install
+$ nix-env -iA cachix -f https://cachix.org/api/v1/install
 
 # Set cachix up to use the PostgREST binary cache:
-cachix use postgrest
+$ cachix use postgrest
 
 ```
 
@@ -56,7 +55,7 @@ following command will put you into a new shell that has GHC and Cabal on the
 PATH:
 
 ```bash
-nix-shell
+$ nix-shell
 
 ```
 
@@ -92,7 +91,7 @@ Some additional modules like `memory`, `docker` and `release`
 have large dependencies that would need to be built before the shell becomes
 available, which could take an especially long time if the cachix binary cache
 is not used. You can activate those by passing a flag to `nix-shell` with
-`nix-shell --arg <module> true`. This will make the respective utilites available:
+`nix-shell --arg <module> true`. This will make the respective utilities available:
 
 ```bash
 $ nix-shell --arg memory true
@@ -114,7 +113,7 @@ postgrest-test-memory
 Note that `postgrest-test-memory` is now also available.
 
 To run one-off commands, you can also use `nix-shell --run <command>`, which
-will lauch the Nix shell, run that one command and exit. Note that the tab
+will launch the Nix shell, run that one command and exit. Note that the tab
 completion will not work with `nix-shell --run`, as Nix has yet to evaluate
 our Nix expressions to see which utilities are available.
 
@@ -146,16 +145,16 @@ Note: Once inside nix-shell, the utilities work from any directory inside
 the PostgREST repo. Paths are resolved relative to the repo root:
 
 ```bash
-$ cd src
+[nix-shell]$ cd src
 # Even though the current directory is ./src, the config path must still start
 # from the repo root:
-$ postgrest-run test/io-tests/configs/simple.conf
+[nix-shell]$ postgrest-run test/io/configs/simple.conf
 ```
 
 ## Testing
 
-In nix-shell, you'll find utility scripts that make it very easy to run the
-Haskell test suite, including setting up all required dependencies and
+In nix-shell, you'll find utility scripts that make it very easy to run our
+test suite, including setting up all required dependencies and
 temporary test databases:
 
 ```bash
@@ -177,12 +176,59 @@ run with `postgrest-test-io`. The test runner under the hood is
 
 ```bash
 # Filter the tests to run by name, including all that contain 'config':
-postgrest-test-io -k config
+[nix-shell]$ postgrest-test-io -k config
 
 # Run tests in parallel using xdist, specifying the number of processes:
-postgrest-test-io -n auto
-postgrest-test-io -n 8
+[nix-shell]$ postgrest-test-io -n auto
+[nix-shell]$ postgrest-test-io -n 8
+```
 
+The memory tests check that we don't surpass a memory threshold for big request bodies.
+
+```bash
+# Build the dependencies needed for the memory test
+$ nix-shell --arg memory true
+
+# Run the memory test
+[nix-shell]$ postgrest-test-memory
+```
+
+The loadtests ensure that performance doesn't drop on a change. Underlyingly they use
+[vegeta](https://github.com/tsenart/vegeta).
+
+```bash
+# Run the loadtests on the latest commit(HEAD)
+[nix-shell]$ postgrest-loadtest
+
+# You can loadtest comparing to a different branch
+[nix-shell]$ postgrest-loadtest-against master
+
+# You can simulate latency client/postgrest and postgrest/database
+[nix-shell]$ PGRST_DELAY=5ms PGDELAY=5ms postgrest-loadtest
+
+# You can build postgrest directly with cabal for faster iteration
+[nix-shell]$ PGRST_BUILD_CABAL=1 postgrest-loadtest
+
+# Produce a markdown report to be used on CI
+[nix-shell]$ postgrest-loadtest-report
+```
+
+doctests for some of our modules are also available:
+
+```bash
+[nix-shell]$ postgrest-test-doctest
+```
+
+## Code coverage
+
+Code coverage is available under the `postgrest-coverage` command. This will produce a `./coverage` directory that can be visualized on a browser.
+
+```bash
+# Will run all the tests and produce a coverage dir
+[nix-shell]$ postgrest-coverage
+...
+
+postgrest-coverage: To see the results, visit file://$(pwd)/coverage/check/hpc_index.html
 ```
 
 ## Linting and styling code
@@ -200,11 +246,11 @@ $ nix-shell --run postgrest-style
 ```
 
 There is also `postgrest-style-check` that exits with a non-zero exit code if
-the check resulted in any uncommited changes. It's mostly useful for CI.
+the check resulted in any uncommitted changes. It's mostly useful for CI.
 
 ## General development tools
 
-Tools like `postgrest-build`, `postgrest-run` etc. are simple wrappers around
+Tools like `postgrest-build`, `postgrest-run`, `postgrest-repl` etc. are simple wrappers around
 `cabal` and should do what you expect. `postgrest-check` runs most checks that will
 also run in CI, with the exception of the IO and Memory checks that need to be run
 separately.
@@ -218,6 +264,23 @@ run against the latest PostgreSQL version by default.
 file is changed. For example, `postgrest-watch postgrest-with-all postgrest-test-spec`
 will re-run the full spec test suite against all PostgreSQL versions on every change.
 
+## REPL
+
+You can use `postgrest-repl` to manually inspect the PostgREST modules.
+
+```bash
+$ postgrest-repl
+
+ghci> import PostgREST.<tab>
+PostgREST.Admin                        PostgREST.Config.Database              PostgREST.Plan.MutatePlan              PostgREST.Response.OpenAPI
+PostgREST.ApiRequest                   PostgREST.Config.JSPath                PostgREST.Plan.ReadPlan                PostgREST.SchemaCache
+...
+
+ghci> import PostgREST.MediaType
+ghci> decodeMediaType "application/json"
+MTApplicationJSON
+```
+
 ## Tour
 
 The following is not required for working on PostgREST with Nix, but it will
@@ -246,7 +309,7 @@ version.
 ### `shell.nix`
 
 [`shell.nix`](../shell.nix) defines an environment in which PostgREST can be
-built and developed. It extends the build enviroment from our `postgrest`
+built and developed. It extends the build environment from our `postgrest`
 attribute with useful utilities that will be put on the PATH in `nix-shell`.
 
 ### `nix/overlays`

nix/UPGRADE.md

@@ -74,7 +74,7 @@ required to avoid build timeouts in CI.
 
 You'll need to set the `CACHIX_SIGNING_KEY` before proceeding, e.g. by creating
 a file containing `export CACHIX_SIGNING_KEY=...` and sourcing that file, which
-avoids having the secret in you shell history.
+avoids having the secret in your shell history.
 
 To push all new artifacts to Cachix, run:
 

nix/hsie/Main.hs

@@ -24,21 +24,22 @@ import qualified Data.Text                               as T
 import qualified Data.Text.IO                            as T
 import qualified Dot
 import qualified GHC
+import qualified GHC.Paths
 import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
 import qualified Options.Applicative                     as O
 import qualified System.FilePath                         as FP
 
-import Bag                        (bagToList)
 import Data.Aeson.Encode.Pretty   (encodePretty)
 import Data.Function              ((&))
 import Data.List                  (intercalate)
 import Data.Maybe                 (catMaybes, mapMaybe)
 import Data.Text                  (Text)
+import GHC.Data.Bag               (bagToList)
 import GHC.Generics               (Generic)
 import GHC.Hs.Extension           (GhcPs)
-import Module                     (moduleNameString)
-import OccName                    (occNameString)
-import RdrName                    (rdrNameOcc)
+import GHC.Types.Name.Occurrence  (occNameString)
+import GHC.Types.Name.Reader      (rdrNameOcc)
+import GHC.Unit.Module.Name       (moduleNameString)
 import System.Directory.Recursive (getFilesRecursive)
 import System.Exit                (exitFailure)
 
@@ -197,11 +198,11 @@ sourceSymbols source = do
       return $ concatMap (importSymbols source filepath . GHC.unLoc) hsmodImports
 
 -- | Parse a Haskell module
-parseModule :: String -> IO (GHC.HsModule GhcPs)
+parseModule :: FilePath -> IO GHC.HsModule
 parseModule filepath = do
-  result <- ExactPrint.parseModule filepath
+  result <- ExactPrint.parseModule GHC.Paths.libdir filepath
   case result of
-    Right (_, hsmod) ->
+    Right hsmod ->
       return $ GHC.unLoc hsmod
     Left errs ->
       fail $ "Errors with " <> show filepath <> ":\n    "
@@ -212,7 +213,6 @@ parseModule filepath = do
 -- If the import is a wildcard, i.e. no symbols are selected for import, then
 -- only one item is returned.
 importSymbols :: FilePath -> FilePath -> GHC.ImportDecl GhcPs -> [ImportedSymbol]
-importSymbols _ _  (GHC.XImportDecl _) = mempty
 importSymbols source filepath GHC.ImportDecl{..} =
   case ideclHiding of
     Just (hiding, syms) ->

nix/hsie/default.nix

@@ -16,15 +16,20 @@ let
   ghc = ghcWithPackages modules;
   hsie =
     runCommand "haskellimports" { inherit name src; }
-      "${ghc}/bin/ghc -O -Werror -Wall -package ghc $src -o $out";
+      ''
+        cd $TMP
+        cp $src $TMP/Main.hs
+        ${ghc}/bin/ghc -O -Werror -Wall -package ghc Main.hs -o Main
+        cp Main $out
+      '';
   bin =
     runCommand name { inherit hsie name; }
       ''
         mkdir -p $out/bin
         ln -s $hsie $out/bin/$name
       '';
-  bashCompletion =
+  bash-completion =
     runCommand "${name}-bash-completion" { inherit bin name; }
       "$bin/bin/$name --bash-completion-script $bin/bin/$name > $out";
 in
-hsie // { inherit bashCompletion bin; }
+hsie // { inherit bash-completion bin; }

nix/nixpkgs-version.nix

@@ -1,6 +1,6 @@
 # Pinned version of Nixpkgs, generated with postgrest-nixpkgs-upgrade.
 {
-  date = "2021-11-02";
-  rev = "7053541084bf5ce2921ef307e5585d39d7ba8b3f";
-  tarballHash = "1flhh5d4zy43x6060hvzjb5hi5cmc51ivc0nwmija9n8d35kcc4x";
+  date = "2023-03-25";
+  rev = "dbf5322e93bcc6cfc52268367a8ad21c09d76fea";
+  tarballHash = "0lwk4v9dkvd28xpqch0b0jrac4xl9lwm6snrnzx8k5lby72kmkng";
 }

nix/overlays/build-toolbox/build-toolbox.nix

@@ -1,11 +1,11 @@
-# Creates an environment that exposes bashCompletion arguments from all checkedShellScripts
+# Creates an environment that exposes bash-completion arguments from all checkedShellScripts
 { buildEnv }:
 { name
 , tools
 , extra ? { }
 }:
 let
-  bashCompletion = builtins.map (tool: tool.bashCompletion) tools;
+  bash-completion = builtins.map (tool: tool.bash-completion) tools;
 
   env = buildEnv {
     inherit name;
@@ -13,4 +13,4 @@ let
   };
 
 in
-env // { inherit bashCompletion; } // extra
+env // { inherit bash-completion; } // extra

nix/overlays/checked-shell-script/checked-shell-script.nix

@@ -2,7 +2,7 @@
 # directly, or use the .bin attribute to get the script in a bin/ directory,
 # to be used in a path for example.
 { argbash
-, bash_5
+, bash
 , coreutils
 , git
 , lib
@@ -14,7 +14,7 @@
 { name
 , docs
 , args ? [ ]
-, addCommandCompletion ? false
+, positionalCompletion ? ""
 , inRootDir ? false
 , redirectTixFiles ? true
 , withEnv ? null
@@ -22,11 +22,10 @@
 , withTmpDir ? false
 }: text:
 let
+  # square brackets are a pain to escape - if even possible. just don't use them...
+  escape = builtins.replaceStrings [ "\n" ] [ " \\n" ];
+
   argsTemplate =
-    let
-      # square brackets are a pain to escape - if even possible. just don't use them...
-      escapedDocs = builtins.replaceStrings [ "\n" ] [ " \\n" ] docs;
-    in
     writeTextFile {
       inherit name;
       destination = "/${name}.m4"; # destination is needed to have the proper basename for completion
@@ -37,7 +36,7 @@ let
           # stripping the /nix/store/... path for nicer display
           BASH_ARGV0="$(basename "$0")"
 
-          # ARG_HELP([${name}], [${escapedDocs}])
+          # ARG_HELP([${name}], [${escape docs}])
           ${lib.strings.concatMapStrings (arg: "# " + arg) args}
           # ARG_POSITIONAL_DOUBLEDASH()
           # ARG_DEFAULTS_POS()
@@ -59,14 +58,14 @@ let
         sed '/_positionals_count + 1/a\\t\t\t\tset -- "''${@:1:1}" "--" "''${@:2}"' -i $out
       '';
 
-  bashCompletion =
+  bash-completion =
     runCommand "${name}-completion" { } (
       ''
         ${argbash}/bin/argbash --type completion --strip all ${argsTemplate}/${name}.m4 > $out
       ''
 
-      + lib.optionalString addCommandCompletion ''
-        sed 's/COMPREPLY.*compgen -o bashdefault .*$/_command/' -i $out
+      + lib.optionalString (positionalCompletion != "") ''
+        sed 's#COMPREPLY.*compgen -o bashdefault .*$#${escape positionalCompletion}#' -i $out
       ''
     );
 
@@ -78,7 +77,7 @@ let
 
       text =
         ''
-          #!${bash_5}/bin/bash
+          #!${bash}/bin/bash
           source ${argsParser}
           set -euo pipefail
         ''
@@ -139,4 +138,4 @@ let
   script =
     runCommand name { inherit bin name; } "ln -s $bin/bin/$name $out";
 in
-script // { inherit bin bashCompletion; }
+script // { inherit bin bash-completion; }

nix/overlays/default.nix

@@ -3,7 +3,9 @@
   checked-shell-script = import ./checked-shell-script;
   gitignore = import ./gitignore.nix;
   haskell-packages = import ./haskell-packages.nix;
+  postgis = import ./postgis.nix;
   postgresql-default = import ./postgresql-default.nix;
   postgresql-legacy = import ./postgresql-legacy.nix;
   postgresql-future = import ./postgresql-future.nix;
+  slocat = import ./slocat.nix;
 }

nix/overlays/gitignore.nix

@@ -12,8 +12,8 @@ self: super:
       gitignoreSrc = super.fetchFromGitHub {
         owner = "hercules-ci";
         repo = "gitignore";
-        rev = "211907489e9f198594c0eb0ca9256a1949c9d412";
-        sha256 = "06j7wpvj54khw0z10fjyi31kpafkr6hi1k0di13k1xp8kywvfyx8";
+        rev = "a20de23b925fd8264fd7fad6454652e142fd7f73";
+        sha256 = "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=";
       };
     in
     (super.callPackage gitignoreSrc { }).gitignoreSource;

nix/overlays/haskell-packages.nix

@@ -13,21 +13,49 @@ let
       #       {
       #         pkg = "protolude";
       #         ver = "0.3.0";
-      #         sha256 = "0iwh4wsjhb7pms88lw1afhdal9f86nrrkkvv65f9wxbd1b159n72";
+      #         sha256 = "<sha256>";
       #       }
       #       { };
       #
-      # To get the sha256:
-      #   nix-prefetch-url --unpack https://hackage.haskell.org/package/protolude-0.3.0/protolude-0.3.0.tar.gz
+      # To temporarily pin unreleased versions from GitHub:
+      #   <name> =
+      #     prev.callCabal2nixWithOptions "<name>" (super.fetchFromGitHub {
+      #       owner = "<owner>";
+      #       repo  = "<repo>";
+      #       rev = "<commit>";
+      #       sha256 = "<sha256>";
+      #    }) "--subpath=<subpath>" {};
+      #
+      # To fill in the sha256:
+      #   update-nix-fetchgit nix/overlays/haskell-packages.nix
 
-      hasql-dynamic-statements =
-        lib.dontCheck (lib.unmarkBroken prev.hasql-dynamic-statements);
+      postgresql-libpq = lib.dontCheck
+        (prev.callCabal2nix "postgresql-libpq"
+          (super.fetchFromGitHub {
+            owner = "PostgREST";
+            repo = "postgresql-libpq";
+            rev = "890a0a16cf57dd401420fdc6c7d576fb696003bc"; # master
+            sha256 = "1wmyhldk0k14y8whp1p4akrkqxf5snh8qsbm7fv5f7kz95nyffd0";
+          })
+          { });
 
-      hasql-implicits =
-        lib.dontCheck (lib.unmarkBroken prev.hasql-implicits);
+      hasql-notifications = lib.dontCheck
+        (prev.callHackageDirect
+          {
+            pkg = "hasql-notifications";
+            ver = "0.2.0.6";
+            sha256 = "sha256-7PyFlB2B70njudOjaX6tk1m77ol9vnF5fI0LF86kVAI=";
+          }
+          { });
 
-      ptr =
-        lib.dontCheck (lib.unmarkBroken prev.ptr);
+      hasql-pool = lib.dontCheck
+        (prev.callHackageDirect
+          {
+            pkg = "hasql-pool";
+            ver = "0.10";
+            sha256 = "sha256-kHzoqtNV9BFWnn1h560JRqMooQRwxokVKgDRBexamNI=";
+          }
+          { });
     } // extraOverrides final prev;
 in
 {

nix/overlays/postgis.nix

@@ -0,0 +1,27 @@
+final: prev:
+let
+  postgis_3_2_3 = rec {
+    version = "3.2.3";
+    src = final.fetchurl {
+      url = "https://download.osgeo.org/postgis/source/postgis-${version}.tar.gz";
+      sha256 = "sha256-G02LXHVuWrpZ77wYM7Iu/k1lYneO7KVvpJf+susTZow=";
+    };
+  };
+in
+{
+  postgresql_11 = prev.postgresql_11.override { this = final.postgresql_11; } // {
+    pkgs = prev.postgresql_11.pkgs // {
+      postgis = prev.postgresql_11.pkgs.postgis.overrideAttrs (_: postgis_3_2_3);
+    };
+  };
+  postgresql_10 = prev.postgresql_10.override { this = final.postgresql_11; } // {
+    pkgs = prev.postgresql_10.pkgs // {
+      postgis = prev.postgresql_10.pkgs.postgis.overrideAttrs (_: postgis_3_2_3);
+    };
+  };
+  postgresql_9_6 = prev.postgresql_9_6.override { this = final.postgresql_11; } // {
+    pkgs = prev.postgresql_9_6.pkgs // {
+      postgis = prev.postgresql_9_6.pkgs.postgis.overrideAttrs (_: postgis_3_2_3);
+    };
+  };
+}

nix/overlays/postgresql-default.nix

@@ -1,5 +1,8 @@
-self: super:
+{ patches }: self: super:
 # Overlay that sets the default version of PostgreSQL.
+with patches;
 {
-  postgresql = super.postgresql_14;
+  postgresql = super.postgresql_15.overrideAttrs ({ patches ? [ ], ... }: {
+    patches = patches ++ [ postgresql-atexit ];
+  });
 }

nix/overlays/postgresql-future.nix

@@ -4,16 +4,16 @@ self: super:
 {
   ## Example for including a postgresql version from a specific nixpks commit:
   ##
-  #  postgresql_14 =
-  #    let
-  #      rev = "76b1e16c6659ccef7187ca69b287525fea133244";
-  #      tarballHash = "1vsahpcx80k2bgslspb0sa6j4bmhdx77sw6la455drqcrqhdqj6a";
-  #
-  #      pinnedPkgs =
-  #        builtins.fetchTarball {
-  #          url = "https://github.com/nixos/nixpkgs/archive/${rev}.tar.gz";
-  #          sha256 = tarballHash;
-  #        };
-  #    in
-  #    (import pinnedPkgs { }).pkgs.postgresql_14;
+  postgresql_16 =
+    let
+      rev = "5148520bfab61f99fd25fb9ff7bfbb50dad3c9db";
+      tarballHash = "1dfjmz65h8z4lk845724vypzmf3dbgsdndjpj8ydlhx6c7rpcq3p";
+
+      pinnedPkgs =
+        builtins.fetchTarball {
+          url = "https://github.com/nixos/nixpkgs/archive/${rev}.tar.gz";
+          sha256 = tarballHash;
+        };
+    in
+    (import pinnedPkgs { }).pkgs.postgresql_16;
 }

nix/overlays/postgresql-legacy.nix

@@ -2,19 +2,33 @@ self: super:
 # Overlay that adds legacy versions of PostgreSQL that are supported by
 # PostgREST.
 {
-  # PostgreSQL 9.5 was removed from Nixpkgs with
-  # https://github.com/NixOS/nixpkgs/commit/72ab382fb6b729b0d654f2c03f5eb25b39f11fbb
+  # PostgreSQL 9.6 was removed from Nixpkgs with
+  # https://github.com/NixOS/nixpkgs/commit/757dd008b2f2926fc0f7688fa8189f930ea47521
   # We pin its parent commit to get the last version that was available.
-  # postgresql_9_5 =
-  #  let
-  #    rev = "55ac7d4580c9ab67848c98cb9519317a1cc399c8";
-  #    tarballHash = "02ffj9f8s1hwhmxj85nx04sv64qb6jm7w0122a1dz9n32fymgklj";
-  #
-  #    pinnedPkgs =
-  #      builtins.fetchTarball {
-  #        url = "https://github.com/nixos/nixpkgs/archive/${rev}.tar.gz";
-  #        sha256 = tarballHash;
-  #      };
-  #  in
-  #  (import pinnedPkgs { }).pkgs.postgresql_9_5;
+  postgresql_9_6 =
+    let
+      rev = "571cbf3d1db477058303cef8754fb85a14e90eb7";
+      tarballHash = "0q74wn418i1bn5sssacmw8ykpmqvzr0s93sj6pbs3rf6bf134fkz";
+      pinnedPkgs =
+        builtins.fetchTarball {
+          url = "https://github.com/nixos/nixpkgs/archive/${rev}.tar.gz";
+          sha256 = tarballHash;
+        };
+    in
+    (import pinnedPkgs { }).pkgs.postgresql_9_6;
+
+  # PostgreSQL 10 was removed from Nixpkgs with
+  # https://github.com/NixOS/nixpkgs/commit/aa1483114bb329fee7e1266100b8d8921ed4723f
+  # We pin its parent commit to get the last version that was available.
+  postgresql_10 =
+    let
+      rev = "79661ba7e2fb96ebefbb537458a5bbae9dc5bd1a";
+      tarballHash = "0rn796pfn4sg90ai9fdnwmr10a2s835p1arazzgz46h6s5cxvq97";
+      pinnedPkgs =
+        builtins.fetchTarball {
+          url = "https://github.com/nixos/nixpkgs/archive/${rev}.tar.gz";
+          sha256 = tarballHash;
+        };
+    in
+    (import pinnedPkgs { }).pkgs.postgresql_10;
 }

nix/overlays/slocat.nix

@@ -0,0 +1,13 @@
+final: prev:
+{
+  slocat = prev.buildGoModule {
+    name = "slocat";
+    src = prev.fetchFromGitHub {
+      owner = "robx";
+      repo = "slocat";
+      rev = "52e7512c6029fd00483e41ccce260a3b4b9b3b64";
+      sha256 = "sha256-qn6luuh5wqREu3s8RfuMCP5PKdS2WdwPrujRYTpfzQ8=";
+    };
+    vendorSha256 = "sha256-pQpattmS9VmO3ZIQUFn66az8GSmB4IvYhTTCFn6SUmo=";
+  };
+}

nix/patches/default.nix

@@ -18,7 +18,12 @@
         done
       '';
 
-  # See: https://github.com/NixOS/nixpkgs/pull/87879
-  nixpkgs-openssl-split-runtime-dependencies-of-static-builds =
-    ./nixpkgs-openssl-split-runtime-dependencies-of-static-builds.patch;
+  static-haskell-nix-ncurses =
+    ./static-haskell-nix-ncurses.patch;
+  static-haskell-nix-ghc-bignum =
+    ./static-haskell-nix-ghc-bignum.patch;
+  static-haskell-nix-openssl =
+    ./static-haskell-nix-openssl.patch;
+  postgresql-atexit =
+    ./postgresql-atexit.patch;
 }

nix/patches/nixpkgs-openssl-split-runtime-dependencies-of-static-builds.patch

@@ -1,76 +0,0 @@
-diff --git a/pkgs/development/libraries/openssl/default.nix b/pkgs/development/libraries/openssl/default.nix
-index d4be8cc2428..3979698711f 100644
---- a/pkgs/development/libraries/openssl/default.nix
-+++ b/pkgs/development/libraries/openssl/default.nix
-@@ -50,9 +50,21 @@ let
-       substituteInPlace crypto/async/arch/async_posix.h \
-         --replace '!defined(__ANDROID__) && !defined(__OpenBSD__)' \
-                   '!defined(__ANDROID__) && !defined(__OpenBSD__) && 0'
-+    '' + optionalString static
-+    # On static builds, the ENGINESDIR will be empty, but its path will be
-+    # compiled into the library. In order to minimize the runtime dependencies
-+    # of packages that statically link openssl, we move it into the OPENSSLDIR,
-+    # which will be separated into the 'etc' output.
-+    ''
-+      substituteInPlace Configurations/unix-Makefile.tmpl \
-+        --replace 'ENGINESDIR=$(libdir)/engines-{- $sover_dirname -}' \
-+                  'ENGINESDIR=$(OPENSSLDIR)/engines-{- $sover_dirname -}'
-     '';
- 
--    outputs = [ "bin" "dev" "out" "man" ] ++ optional withDocs "doc";
-+    outputs = [ "bin" "dev" "out" "man" ]
-+      ++ optional withDocs "doc"
-+      # Separate output for the runtime dependencies of the static build.
-+      ++ optional static "etc";
-     setOutputFlags = false;
-     separateDebugInfo =
-       !stdenv.hostPlatform.isDarwin &&
-@@ -101,7 +113,17 @@ let
-     configureFlags = [
-       "shared" # "shared" builds both shared and static libraries
-       "--libdir=lib"
--      "--openssldir=etc/ssl"
-+      (if !static then
-+         "--openssldir=etc/ssl"
-+       else
-+         # Separate the OPENSSLDIR into its own output, as its path will be
-+         # compiled into 'libcrypto.a'. This makes it a runtime dependency of
-+         # any package that statically links openssl, so we want to keep that
-+         # output minimal. We need to prepend '/.' to the path in order to make
-+         # it appear absolute before variable expansion, the 'prefix' would be
-+         # prepended to it otherwise.
-+         "--openssldir=/.$(etc)/etc/ssl"
-+      )
-     ] ++ lib.optionals withCryptodev [
-       "-DHAVE_CRYPTODEV"
-       "-DUSE_CRYPTODEV_DIGESTS"
-@@ -131,6 +153,9 @@ let
-       if [ -n "$(echo $out/lib/*.so $out/lib/*.dylib $out/lib/*.dll)" ]; then
-           rm "$out/lib/"*.a
-       fi
-+
-+      # 'etc' is a separate output on static builds only.
-+      etc=$out
-     '' + lib.optionalString (!stdenv.hostPlatform.isWindows)
-       # Fix bin/c_rehash's perl interpreter line
-       #
-@@ -152,14 +177,15 @@ let
-       mv $out/include $dev/
- 
-       # remove dependency on Perl at runtime
--      rm -r $out/etc/ssl/misc
-+      rm -r $etc/etc/ssl/misc
- 
--      rmdir $out/etc/ssl/{certs,private}
-+      rmdir $etc/etc/ssl/{certs,private}
-     '';
- 
-     postFixup = lib.optionalString (!stdenv.hostPlatform.isWindows) ''
--      # Check to make sure the main output doesn't depend on perl
--      if grep -r '${buildPackages.perl}' $out; then
-+      # Check to make sure the main output and the static runtime dependencies
-+      # don't depend on perl
-+      if grep -r '${buildPackages.perl}' $out $etc; then
-         echo "Found an erroneous dependency on perl ^^^" >&2
-         exit 1
-       fi

nix/patches/postgresql-atexit.patch

@@ -0,0 +1,11 @@
+--- a/src/interfaces/libpq/Makefile
++++ b/src/interfaces/libpq/Makefile
+@@ -118,7 +118,7 @@ backend_src = $(top_srcdir)/src/backend
+ libpq-refs-stamp: $(shlib)
+ ifneq ($(enable_coverage), yes)
+ ifeq (,$(filter aix solaris,$(PORTNAME)))
+-	@if nm -A -u $< 2>/dev/null | grep -v __cxa_atexit | grep exit; then \
++	@if nm -A -u $< 2>/dev/null | grep " exit"; then \
+ 		echo 'libpq must not be calling any function which invokes exit'; exit 1; \
+ 	fi
+ endif

nix/patches/static-haskell-nix-ghc-bignum.patch

@@ -0,0 +1,12 @@
+diff --git a/survey/default.nix b/survey/default.nix
+index 70afbbc..28cb0e9 100644
+--- a/survey/default.nix
++++ b/survey/default.nix
+@@ -81,6 +81,7 @@ let
+   # `.override` and the likes).
+   isProperHaskellPackage = val:
+     lib.isDerivation val && # must pass lib.isDerivation
++    val.pname != "ghc-bignum" &&
+     val ? env; # must have an .env key
+ 
+   # Function that tells us if a given Haskell package has an executable.

nix/patches/static-haskell-nix-ncurses.patch

@@ -0,0 +1,13 @@
+diff --git a/survey/default.nix b/survey/default.nix
+index 46d8066..a47f214 100644
+--- a/survey/default.nix
++++ b/survey/default.nix
+@@ -1519,7 +1519,7 @@ let
+                   [
+                     "--enable-executable-static" # requires `useFixedCabal`
+                     # `enableShared` seems to be required to avoid `recompile with -fPIC` errors on some packages.
+-                    "--extra-lib-dirs=${final.ncurses.override { enableStatic = true; enableShared = true; }}/lib"
++                    "--extra-lib-dirs=${final.ncurses.override { enableStatic = true; }}/lib"
+                   ]
+                   # TODO Figure out why this and the below libffi are necessary.
+                   #      `working` and `workingStackageExecutables` don't seem to need that,

nix/patches/static-haskell-nix-openssl.patch

@@ -0,0 +1,12 @@
+diff --git a/survey/default.nix b/survey/default.nix
+index cf1bd31..9d34753 100644
+--- a/survey/default.nix
++++ b/survey/default.nix
+@@ -736,6 +736,7 @@ let
+     openblas = previous.openblas.override { enableStatic = true; };
+ 
+     openssl = previous.openssl.override { static = true; };
++    openssl_1_1 = previous.openssl_1_1.override { static = true; };
+ 
+     libsass = previous.libsass.overrideAttrs (old: { dontDisableStatic = true; });
+ 

nix/static-haskell-package.nix

@@ -1,5 +1,5 @@
 # Derive a fully static Haskell package based on musl instead of glibc.
-{ nixpkgs, compiler, patches, allOverlays }:
+{ nixpkgs, system, compiler, patches, allOverlays }:
 
 name: src:
 let
@@ -17,14 +17,9 @@ let
     patches.applyPatches "patched-static-haskell-nix"
       static-haskell-nix
       [
-        # No patches currently required.
-      ];
-
-  patchedNixpkgs =
-    patches.applyPatches "patched-nixpkgs"
-      nixpkgs
-      [
-        patches.nixpkgs-openssl-split-runtime-dependencies-of-static-builds
+        patches.static-haskell-nix-ncurses
+        patches.static-haskell-nix-ghc-bignum
+        patches.static-haskell-nix-openssl
       ];
 
   extraOverrides =
@@ -40,7 +35,7 @@ let
   overlays =
     [
       allOverlays.postgresql-future
-      allOverlays.postgresql-default
+      (allOverlays.postgresql-default { inherit patches; })
       (allOverlays.haskell-packages { inherit compiler extraOverrides; })
       # Disable failing tests for postgresql on musl that should have no impact
       # on the libpq that we need (collate.icu.utf8 and foreign regression
@@ -50,13 +45,13 @@ let
       )
     ];
 
-  # Apply our overlay to the given pkgs.
+  # Apply our overlay to nixpkgs.
   normalPkgs =
-    import patchedNixpkgs { inherit overlays; };
+    import nixpkgs { inherit overlays system; };
 
   defaultCabalPackageVersionComingWithGhc =
     {
-      ghc8107 = "Cabal_3_2_1_0";
+      ghc924 = "Cabal_3_6_3_0";
     }."${compiler}";
 
   # The static-haskell-nix 'survey' derives a full static set of Haskell
@@ -64,4 +59,7 @@ let
   survey =
     import "${patched-static-haskell-nix}/survey" { inherit normalPkgs compiler defaultCabalPackageVersionComingWithGhc; };
 in
-survey.haskellPackages."${name}"
+{
+  inherit survey;
+  package = survey.haskellPackages."${name}";
+}

nix/tools/cabalTools.nix

@@ -28,6 +28,8 @@ let
       ''
         # clean old coverage data, too
         rm -rf .hpc coverage
+        # clean old hie files
+        find . -name "*.hie" -type f -delete
         exec ${cabal-install}/bin/cabal v2-clean
       '';
 
@@ -35,16 +37,38 @@ let
     checkedShellScript
       {
         name = "postgrest-run";
-        docs = "Run PostgREST after buidling it interactively with cabal-install";
-        args = [ "ARG_LEFTOVERS([PostgREST arguments])" ];
+        docs = "Run PostgREST after building it interactively with cabal-install";
+        args =
+          [
+            "ARG_USE_ENV([PGRST_DB_ANON_ROLE], [postgrest_test_anonymous], [PostgREST anonymous role])"
+            "ARG_USE_ENV([PGRST_DB_POOL], [1], [PostgREST pool size])"
+            "ARG_USE_ENV([PGRST_DB_POOL_ACQUISITION_TIMEOUT], [1], [PostgREST pool size])"
+            "ARG_LEFTOVERS([PostgREST arguments])"
+          ];
         inRootDir = true;
         withEnv = postgrest.env;
       }
       ''
+        export PGRST_DB_ANON_ROLE
+        export PGRST_DB_POOL
+        export PGRST_DB_POOL_ACQUISITION_TIMEOUT
+
         exec ${cabal-install}/bin/cabal v2-run ${devCabalOptions} --verbose=0 -- \
           postgrest "''${_arg_leftovers[@]}"
       '';
 
+  repl =
+    checkedShellScript
+      {
+        name = "postgrest-repl";
+        docs = "Interact with PostgREST modules using the cabal repl";
+        args = [ "ARG_LEFTOVERS([cabal v2-repl arguments])" ];
+        inRootDir = true;
+        withEnv = postgrest.env;
+      }
+      ''
+        exec ${cabal-install}/bin/cabal v2-repl "''${_arg_leftovers[@]}"
+      '';
 in
 buildToolbox
 {
@@ -53,5 +77,6 @@ buildToolbox
     build
     clean
     run
+    repl
   ];
 }

nix/tools/devTools.nix

@@ -4,7 +4,10 @@
 , checkedShellScript
 , devCabalOptions
 , entr
+, git
+, gnugrep
 , graphviz
+, haskellPackages
 , hsie
 , nix
 , silver-searcher
@@ -29,7 +32,7 @@ let
             "ARG_POSITIONAL_SINGLE([command], [Command to run])"
             "ARG_LEFTOVERS([command arguments])"
           ];
-        addCommandCompletion = true;
+        positionalCompletion = "_command";
         redirectTixFiles = false; # will be done by sub-command
         inRootDir = true;
       }
@@ -64,23 +67,172 @@ let
         name = "postgrest-check";
         docs =
           ''
-            Run most checks that will also run on CI.
+            Run most checks that will also run on CI, but only against the
+            latest PostgreSQL version.
 
-            This currently excludes the memory tests, as those are particularly
-            expensive.
+            This currently excludes the memory and spec-idempotence tests,
+            as those are particularly expensive.
           '';
         inRootDir = true;
       }
       ''
-        ${withTools}/bin/postgrest-with-all ${tests}/bin/postgrest-test-spec
-        ${withTools}/bin/postgrest-with-all ${tests}/bin/postgrest-test-querycost
+        ${tests}/bin/postgrest-test-spec
         ${tests}/bin/postgrest-test-doctests
-        ${tests}/bin/postgrest-test-spec-idempotence
         ${tests}/bin/postgrest-test-io
         ${style}/bin/postgrest-lint
         ${style}/bin/postgrest-style-check
       '';
 
+  gitHooks =
+    let
+      name = "postgrest-git-hooks";
+    in
+    checkedShellScript
+      {
+        inherit name;
+        docs =
+          ''
+            Enable or disable git pre-commit and pre-push hooks.
+
+            Basic is faster and will only run:
+              - pre-commit: postgrest-style
+              - pre-push: postgrest-lint
+
+            Full takes a lot more time and will run:
+              - pre-commit: postgrest-style && postgrest-lint
+              - pre-push: postgrest-check
+
+            Changes made by postgrest-style will be staged automatically.
+
+            Example usage:
+              postgrest-git-hooks disable
+              postgrest-git-hooks enable basic
+              postgrest-git-hooks enable full
+
+            The "run" operation and "--hook" argument are only used internally.
+          '';
+        args =
+          [
+            "ARG_POSITIONAL_SINGLE([operation], [Operation])"
+            "ARG_TYPE_GROUP_SET([OPERATION], [OPERATION], [operation], [disable,enable,run])"
+            "ARG_POSITIONAL_SINGLE([mode], [Mode], [basic])"
+            "ARG_TYPE_GROUP_SET([MODE], [MODE], [mode], [basic,full])"
+            "ARG_OPTIONAL_SINGLE([hook], , [Hook], [pre-commit])"
+            "ARG_TYPE_GROUP_SET([HOOK], [HOOK], [hook], [pre-commit,pre-push])"
+          ];
+        positionalCompletion =
+          ''
+            if test "$prev" == "${name}"; then
+              COMPREPLY=( $(compgen -W "enable disable" -- "$cur") )
+            elif test "$prev" == "enable" || test "$prev" == "disable"; then
+              COMPREPLY=( $(compgen -W "basic full" -- "$cur") )
+            fi
+          '';
+        inRootDir = true;
+      }
+      ''
+        if [ run != "$_arg_operation" ]; then
+          # Remove all hooks first and ignore failures because the file might be missing.
+          # This assumes that we're only adding lines that include "postgrest-git-hooks"
+          # to the hook file.
+          sed -i -e '/postgrest-git-hooks/d' .git/hooks/pre-{commit,push} 2> /dev/null || true
+
+          if [ disable != "$_arg_operation" ]; then
+            # The nix-shell && + nix-shell || pattern makes sure we can run the hook
+            # in a pure nix-shell, where nix-shell itself is not available, too.
+
+            # The $(nix-shell --run "command -v ...") pattern ensures we only need to enable
+            # the hooks once and still run the latest of our hook scripts, even when we
+            # update them in the repo.
+
+            echo 'command -v nix-shell > /dev/null || postgrest-git-hooks --hook=pre-commit run' "$_arg_mode" \
+              >> .git/hooks/pre-commit
+            # shellcheck disable=SC2016
+            echo 'command -v nix-shell > /dev/null && $(nix-shell --quiet -Q --run "command -v postgrest-git-hooks") --hook=pre-commit run' "$_arg_mode" \
+             >> .git/hooks/pre-commit
+            chmod +x .git/hooks/pre-commit
+
+            echo 'command -v nix-shell > /dev/null || postgrest-git-hooks --hook=pre-push run' "$_arg_mode" \
+              >> .git/hooks/pre-push
+            # shellcheck disable=SC2016
+            echo 'command -v nix-shell > /dev/null && $(nix-shell --quiet -Q --run "command -v postgrest-git-hooks") --hook=pre-push run' "$_arg_mode" \
+             >> .git/hooks/pre-push
+            chmod +x .git/hooks/pre-push
+          fi
+        else
+          # When run from a git hook, the GIT_ environment variables conflict with our withGit helper.
+          # The following unsets all GIT_ variables.
+          unset "''${!GIT_@}"
+
+          # shellcheck disable=SC2317
+          function restore () {
+            ref="$(git stash list --format=format:%gD --grep "$1" -n1)"
+            # this will avoid merge conflicts when applying the stash
+            ${git}/bin/git restore --source="$ref" .
+            # restore untracked files, too. could fail with no files
+            if [ "$(git show --numstat --format=oneline "$ref^3" | wc -l)" -gt 1 ]; then
+              ${git}/bin/git restore --overlay --source="$ref^3" .
+            fi
+            ${git}/bin/git stash drop "$ref"
+          }
+
+          case "$_arg_mode" in
+            basic)
+              case "$_arg_hook" in
+                pre-commit)
+                  # To be able to automatically add only changes from postgrest-style to the staging area,
+                  # we need to run postgrest-style twice. Otherwise we'd risk merge conflicts when popping
+                  # the stash afterwards.
+                  ${style}/bin/postgrest-style
+
+                  stash="postgrest-git-hooks-$RANDOM"
+                  ${git}/bin/git stash push --include-untracked --keep-index -m "$stash"
+                  if [ "$(git stash list --grep $stash)" ]; then
+                    # Only create the stash pop trap, if we actually created a stash.
+                    # Otherwise stash pop will cause havoc.
+                    trap 'restore "$stash"' EXIT
+                  fi
+
+                  ${style}/bin/postgrest-style
+                  ${git}/bin/git add .
+                  ;;
+                pre-push)
+                  # Create a clean working tree without any uncomitted changes.
+                  ${withTools.withGit} HEAD ${style}/bin/postgrest-lint
+                  ;;
+              esac
+              ;;
+            full)
+              case "$_arg_hook" in
+                pre-commit)
+                  # To be able to automatically add only changes from postgrest-style to the staging area,
+                  # we need to run postgrest-style twice. Otherwise we'd risk merge conflicts when popping
+                  # the stash afterwards.
+                  ${style}/bin/postgrest-style
+
+                  stash="postgrest-git-hooks-$RANDOM"
+                  ${git}/bin/git stash push --include-untracked --keep-index -m "$stash"
+                  if [ "$(git stash list --grep $stash)" ]; then
+                    # Only create the stash pop trap, if we actually created a stash.
+                    # Otherwise stash pop will cause havoc.
+                    trap 'restore "$stash"' EXIT
+                  fi
+
+                  ${style}/bin/postgrest-style
+                  ${git}/bin/git add .
+
+                  ${style}/bin/postgrest-lint
+                  ;;
+                pre-push)
+                  # Create a clean working tree without any uncomitted changes.
+                  ${withTools.withGit} HEAD ${check}
+                  ;;
+              esac
+              ;;
+          esac
+        fi
+      '';
+
   dumpMinimalImports =
     checkedShellScript
       {
@@ -146,9 +298,11 @@ buildToolbox
     watch
     pushCachix
     check
+    gitHooks
     dumpMinimalImports
     hsieMinimalImports
     hsieGraphModules
     hsieGraphSymbols
   ];
+  extra = { inherit pushCachix; };
 }

nix/tools/docker/README.md

@@ -93,3 +93,18 @@ Image efficiency score: 100 %
 
 Count   Total Space  Path
 ```
+
+# Deriving from the optimized image
+
+Since the docker image is minimal, it does not contain a shell or other utilities.
+To derive a non-minimal image, you can do the following:
+
+```Dockerfile
+# derive from any base image you want
+FROM alpine:latest
+
+# copy PostgREST over
+COPY --from=postgrest/postgrest /bin/postgrest /bin
+
+# add your other stuff
+```

nix/tools/docker/default.nix

@@ -8,7 +8,7 @@ let
     dockerTools.buildImage {
       name = "postgrest";
       tag = "latest";
-      contents = postgrest;
+      copyToRoot = postgrest;
 
       # Set the current time as the image creation date. This makes the build
       # non-reproducible, but that should not be an issue for us.

nix/tools/loadtest.nix

@@ -0,0 +1,184 @@
+{ buildToolbox
+, checkedShellScript
+, jq
+, python3Packages
+, vegeta
+, withTools
+, writers
+}:
+let
+  runner =
+    checkedShellScript
+      {
+        name = "postgrest-loadtest-runner";
+        docs = "Run vegeta. Assume PostgREST to be running.";
+        args = [
+          "ARG_LEFTOVERS([additional vegeta arguments])"
+          "ARG_USE_ENV([PGRST_SERVER_UNIX_SOCKET], [], [Unix socket to connect to running PostgREST instance])"
+        ];
+      }
+      ''
+        # ARG_USE_ENV only adds defaults or docs for environment variables
+        # We manually implement a required check here
+        # See also: https://github.com/matejak/argbash/issues/80
+        : "''${PGRST_SERVER_UNIX_SOCKET:?PGRST_SERVER_UNIX_SOCKET is required}"
+
+        ${vegeta}/bin/vegeta -cpus 1 attack \
+                                     -unix-socket "$PGRST_SERVER_UNIX_SOCKET" \
+                                     -max-workers 1 \
+                                     -workers 1 \
+                                     -rate 0 \
+                                     -duration 60s \
+                                     "''${_arg_leftovers[@]}"
+      '';
+
+  loadtest =
+    checkedShellScript
+      {
+        name = "postgrest-loadtest";
+        docs = "Run the vegeta loadtests with PostgREST.";
+        args = [
+          "ARG_OPTIONAL_SINGLE([output], [o], [Filename to dump json output to], [./loadtest/result.bin])"
+          "ARG_OPTIONAL_SINGLE([testdir], [t], [Directory to load tests and fixtures from], [./test/load])"
+          "ARG_LEFTOVERS([additional vegeta arguments])"
+        ];
+        inRootDir = true;
+      }
+      ''
+        # previously required settings to make this work with older branches
+        export PGRST_DB_ANON_ROLE="postgrest_test_anonymous"
+        export PGRST_DB_URI="postgresql://"
+        export PGRST_DB_SCHEMAS="test"
+
+        export PGRST_DB_CONFIG="false"
+        export PGRST_DB_POOL="1"
+        export PGRST_DB_TX_END="rollback-allow-override"
+        export PGRST_LOG_LEVEL="crit"
+
+        mkdir -p "$(dirname "$_arg_output")"
+        abs_output="$(realpath "$_arg_output")"
+
+        # shellcheck disable=SC2145
+        ${withTools.withPg} --fixtures "$_arg_testdir"/fixtures.sql \
+        ${withTools.withSlowPg} \
+        ${withTools.withPgrst} \
+        ${withTools.withSlowPgrst} \
+        sh -c "cd \"$_arg_testdir\" && ${runner} -targets targets.http -output \"$abs_output\" \"''${_arg_leftovers[@]}\""
+        ${vegeta}/bin/vegeta report -type=text "$_arg_output"
+      '';
+
+  loadtestAgainst =
+    let
+      name = "postgrest-loadtest-against";
+    in
+    checkedShellScript
+      {
+        inherit name;
+        docs =
+          ''
+            Run the vegeta loadtest against every target branch and HEAD:
+            - once on the every <target-#> branch
+            - once in the current worktree
+          '';
+        args = [
+          "ARG_POSITIONAL_INF([target], [Commit-ish reference to compare with], 1)"
+        ];
+        positionalCompletion =
+          ''
+            if test "$prev" == "${name}"; then
+              __gitcomp_nl "$(__git_refs)"
+            fi
+          '';
+        inRootDir = true;
+      }
+      ''
+        for tgt in "''${_arg_target[@]}"; do
+
+        cat << EOF
+
+        Running loadtest on "$tgt"...
+
+        EOF
+
+        # Runs the test files from the current working tree
+        # to make sure both tests are run with the same files.
+        # Save the results in the current working tree, too,
+        # otherwise they'd be lost in the temporary working tree
+        # created by withTools.withGit.
+        ${withTools.withGit} "$tgt" ${loadtest} --output "$PWD/loadtest/$tgt.bin" --testdir "$PWD/test/load"
+
+        cat << EOF
+
+        Done running on "$tgt".
+
+        EOF
+
+        done
+
+        cat << EOF
+
+        Running loadtest on HEAD...
+
+        EOF
+
+        ${loadtest} --output "$PWD/loadtest/head.bin" --testdir "$PWD/test/load"
+
+        cat << EOF
+
+        Done running on HEAD.
+
+        EOF
+      '';
+
+  reporter =
+    checkedShellScript
+      {
+        name = "postgrest-loadtest-reporter";
+        docs = "Create a named json report for a single result file.";
+        args = [
+          "ARG_POSITIONAL_SINGLE([file], [Filename of result to create report for])"
+          "ARG_LEFTOVERS([additional vegeta arguments])"
+        ];
+        inRootDir = true;
+      }
+      ''
+        ${vegeta}/bin/vegeta report -type=json "$_arg_file" \
+          | ${jq}/bin/jq --arg branch "$(basename "$_arg_file" .bin)" '. + {branch: $branch}'
+      '';
+
+  toMarkdown =
+    writers.writePython3 "postgrest-loadtest-to-markdown"
+      {
+        libraries = [ python3Packages.pandas python3Packages.tabulate ];
+      }
+      ''
+        import sys
+        import pandas as pd
+
+        pd.read_json(sys.stdin) \
+          .set_index('param') \
+          .drop(['branch', 'earliest', 'end', 'latest']) \
+          .convert_dtypes() \
+          .to_markdown(sys.stdout, floatfmt='.0f')
+      '';
+
+
+  report =
+    checkedShellScript
+      {
+        name = "postgrest-loadtest-report";
+        docs = "Create a report of all loadtest reports as markdown.";
+        inRootDir = true;
+      }
+      ''
+        find loadtest -type f -iname '*.bin' -exec ${reporter} {} \; \
+          | ${jq}/bin/jq '[leaf_paths as $path | {param: $path | join("."), (.branch): getpath($path)}]' \
+          | ${jq}/bin/jq --slurp 'flatten | group_by(.param) | map(add)' \
+          | ${toMarkdown}
+      '';
+
+in
+buildToolbox {
+  name = "postgrest-loadtest";
+  tools = [ loadtest loadtestAgainst report ];
+}

nix/tools/memory.nix

@@ -17,7 +17,7 @@ let
         withPath = [ postgrestProfiled curl ];
       }
       ''
-        ${withTools.latest} test/memory-tests.sh
+        ${withTools.withPg} test/memory/memory-tests.sh
       '';
 
 in

nix/tools/nixpkgsTools.nix

@@ -1,5 +1,6 @@
 { buildToolbox
 , checkedShellScript
+, coreutils
 , curl
 , jq
 , nix
@@ -33,7 +34,7 @@ let
         commitHash="$(${curl}/bin/curl "${refUrl}" -H "${githubV3Header}" | ${jq}/bin/jq -r .object.sha)"
         tarballUrl="${tarballUrlBase}$commitHash.tar.gz"
         tarballHash="$(${nix}/bin/nix-prefetch-url --unpack "$tarballUrl")"
-        currentDate="$(date --iso)"
+        currentDate="$(${coreutils}/bin/date --iso)"
 
         cat > nix/nixpkgs-version.nix << EOF
         # Pinned version of Nixpkgs, generated with ${name}.

nix/tools/release/default.nix

@@ -40,15 +40,98 @@ let
         )"
 
         repo_url="https://hub.docker.com/v2/repositories/$DOCKER_REPO/postgrest/"
-        echo "Patching both descriptions at $repo_url ..." 
+        echo "Patching both descriptions at $repo_url ..."
         ${curl}/bin/curl --fail -X PATCH "$repo_url" \
           -H "Authorization: JWT $token" \
           --data-urlencode description@${description} \
           --data-urlencode full_description@${fullDescription}
       '';
+
+  release =
+    checkedShellScript
+      {
+        name = "postgrest-release";
+        docs = "Patch postgrest.cabal, CHANGELOG.md, tag and push all in one go.";
+        args = [ "ARG_POSITIONAL_SINGLE([version], [Version to release], [pre])" ];
+        inRootDir = true;
+      }
+      ''
+        trap "echo You need to be on the main branch or a release branch to proceed. Exiting ..." ERR
+        [[ "$(git rev-parse --abbrev-ref HEAD)" =~ ^main$|^rel- ]]
+        trap "" ERR
+
+        trap "echo You have uncommitted changes in postgrest.cabal. Exiting ..." ERR
+        git diff --exit-code HEAD postgrest.cabal > /dev/null
+        trap "" ERR
+
+        current_version="$(grep -oP '^version:\s*\K.*' postgrest.cabal)"
+        # shellcheck disable=SC2034
+        IFS=. read -r major minor patch pre <<< "$current_version"
+        echo "Current version is $current_version"
+
+        today_date="$(date '+%Y%m%d')"
+        today_date_for_changelog="$(date '+%Y-%m-%d')"
+        bump_pre="$major.$minor.$patch.$today_date"
+        bump_pre_minor="$major.$((minor+1)).0.$today_date"
+        bump_patch="$major.$minor.$((patch+1))"
+        bump_minor="$major.$((minor+1)).0"
+        bump_major="$((major+1)).0.0"
+
+        PS3="Please select the new version: "
+        select new_version in "$bump_pre" "$bump_pre_minor" "$bump_patch" "$bump_minor" "$bump_major"; do
+          case "$REPLY" in
+            1|2|3|4|5)
+              echo "Selected $new_version"
+              break
+              ;;
+            *)
+            echo "Invalid option $REPLY"
+            ;;
+          esac
+        done
+
+        echo "Updating postgrest.cabal ..."
+        sed -i -E "s/^(version:\s+).*$/\1$new_version/" postgrest.cabal > /dev/null
+
+        echo "Committing ..."
+        git add postgrest.cabal > /dev/null
+
+        if [[ "$new_version" != "$bump_pre" && "$new_version" != "$bump_pre_minor" ]]; then
+          echo "Updating CHANGELOG.md ..."
+          sed -i -E "s/Unreleased/&\n\n## [$new_version] - $today_date_for_changelog/" CHANGELOG.md > /dev/null
+          git add CHANGELOG.md > /dev/null
+        fi
+
+        git commit -m "bump version to $new_version" > /dev/null
+
+        echo "Tagging ..."
+        git tag "v$new_version" > /dev/null
+
+        trap "echo Remote not found. Please push manually ..." ERR
+        remote="$(git remote -v | grep PostgREST/postgrest | grep push | cut -f1)"
+        trap "" ERR
+
+        push="git push --atomic $remote $(git rev-parse --abbrev-ref HEAD) v$new_version"
+
+        echo "To push both the branch and the new tag, the following will be run:"
+        echo
+        echo "$push"
+        echo
+
+        read -r -p 'Proceed? (y/N) ' REPLY
+        case "$REPLY" in
+          y|Y)
+            $push
+            ;;
+          *)
+            echo "Aborting ..."
+            ;;
+        esac
+      '';
+
 in
 buildToolbox
 {
   name = "postgrest-release";
-  tools = [ dockerHubDescription ];
+  tools = [ dockerHubDescription release ];
 }

nix/tools/release/docker-hub-full-description.md

@@ -12,30 +12,30 @@ write from scratch.
 
 ## Sponsors
 
-<table>
+<table align="center">
   <tbody>
     <tr>
       <td align="center" valign="middle">
         <a href="https://www.cybertec-postgresql.com/en/?utm_source=postgrest.org&utm_medium=referral&utm_campaign=postgrest" target="_blank">
-          <img width="222px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/cybertec-new.png">
+          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/cybertec-new.png">
         </a>
       </td>
       <td align="center" valign="middle">
-        <a href="https://www.2ndquadrant.com/en/?utm_campaign=External%20Websites&utm_source=PostgREST&utm_medium=Logo" target="_blank">
-          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/2ndquadrant.png">
+        <a href="https://gnuhost.eu/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/gnuhost.png">
         </a>
       </td>
       <td align="center" valign="middle">
-        <a href="https://tryretool.com/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
-          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/retool.png">
+        <a href="https://neon.tech/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/neon.jpg">
         </a>
       </td>
     </tr>
     <tr></tr>
     <tr>
       <td align="center" valign="middle">
-        <a href="https://gnuhost.eu/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
-          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/gnuhost.png">
+        <a href="https://code.build/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/code-build.png">
         </a>
       </td>
       <td align="center" valign="middle">
@@ -44,8 +44,8 @@ write from scratch.
         </a>
       </td>
       <td align="center" valign="middle">
-        <a href="https://oblivious.ai/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
-          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/oblivious.jpg">
+        <a href="https://tembo.io/?utm_source=sponsor&utm_campaign=postgrest" target="_blank">
+          <img width="296px" src="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/tembo.png">
         </a>
       </td>
     </tr>
@@ -55,16 +55,16 @@ write from scratch.
 # Usage
 
 To learn how to use this container, see the [PostgREST Docker
-documentation](https://postgrest.com/en/stable/install.html#docker).
+documentation](https://postgrest.org/en/stable/install.html#docker).
 
 You can configure the PostgREST image by setting
-[enviroment variables](https://postgrest.org/en/stable/configuration.html).
+[environment variables](https://postgrest.org/en/stable/configuration.html).
 
 # How this image is built
 
 The image is built from scratch using
 [Nix](https://nixos.org/nixpkgs/manual/#sec-pkgs-dockerTools) instead of a
-`Dockerfile`, which yields a higly secure and optimized image. This is also why
+`Dockerfile`, which yields a highly secure and optimized image. This is also why
 no commands are listed in the image history. See the [PostgREST
-respository](https://github.com/PostgREST/postgrest/tree/main/nix/docker) for
+respository](https://github.com/PostgREST/postgrest/tree/main/nix/tools/docker) for
 details on the build process and how to inspect the image.

nix/tools/style.nix

@@ -44,7 +44,9 @@ let
       ''
         ${style}
 
-        ${git}/bin/git diff-index --exit-code HEAD -- '*.hs' '*.lhs' '*.nix'
+        trap "echo postgrest-style-check failed. Run postgrest-style to fix issues automatically." ERR
+
+        ${git}/bin/git diff-index --exit-code HEAD -- '*.hs' '*.lhs' '*.nix' '*.py'
       '';
 
   lint =
@@ -67,8 +69,7 @@ let
         echo "Linting bash scripts..."
         ${shellcheck}/bin/shellcheck \
           .github/get_cirrusci_freebsd \
-          .github/release \
-          test/with_tmp_db
+          .github/release
 
         echo "Linting workflows..."
         ${actionlint}/bin/actionlint

nix/tools/tests.nix

@@ -3,14 +3,17 @@
 , checkedShellScript
 , devCabalOptions
 , ghc
-, glibcLocales
+, glibcLocales ? null
 , gnugrep
-, haskell
 , hpc-codecov
+, hostPlatform
 , jq
+, lib
 , postgrest
 , python3
 , runtimeShell
+, stdenv
+, weeder
 , withTools
 , yq
 }:
@@ -19,24 +22,14 @@ let
     checkedShellScript
       {
         name = "postgrest-test-spec";
-        docs = "Run the Haskell test suite";
+        docs = "Run the Haskell test suite. Use --match PATTERN for running individual specs";
+        args = [ "ARG_LEFTOVERS([hspec arguments])" ];
         inRootDir = true;
         withEnv = postgrest.env;
       }
       ''
-        ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec
-      '';
-
-  testQuerycost =
-    checkedShellScript
-      {
-        name = "postgrest-test-querycost";
-        docs = "Run the Haskell test suite for query costs";
-        inRootDir = true;
-        withEnv = postgrest.env;
-      }
-      ''
-        ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:querycost
+        ${withTools.withPg} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} \
+          test:spec -- "''${_arg_leftovers[@]}"
       '';
 
   testDoctests =
@@ -66,7 +59,7 @@ let
         withEnv = postgrest.env;
       }
       ''
-        ${withTools.latest} ${runtimeShell} -c " \
+        ${withTools.withPg} ${runtimeShell} -c " \
           ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec && \
           ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec"
       '';
@@ -75,7 +68,7 @@ let
     python3.withPackages (ps: [
       ps.pyjwt
       ps.pytest
-      ps.pytest_xdist
+      ps.pytest-xdist
       ps.pyyaml
       ps.requests
       ps.requests-unixsocket
@@ -85,28 +78,28 @@ let
     checkedShellScript
       {
         name = "postgrest-test-io";
-        docs = "Run the pytest-based IO tests.";
+        docs = "Run the pytest-based IO tests. Add -k to run tests that match a given expression.";
         args = [ "ARG_LEFTOVERS([pytest arguments])" ];
         inRootDir = true;
         withEnv = postgrest.env;
       }
       ''
         ${cabal-install}/bin/cabal v2-build ${devCabalOptions}
-        ${cabal-install}/bin/cabal v2-exec ${withTools.latest} \
-          ${ioTestPython}/bin/pytest -- -v test/io-tests "''${_arg_leftovers[@]}"
+        ${cabal-install}/bin/cabal v2-exec -- ${withTools.withPg} -f test/io/fixtures.sql \
+          ${ioTestPython}/bin/pytest -v test/io "''${_arg_leftovers[@]}"
       '';
 
   dumpSchema =
     checkedShellScript
       {
         name = "postgrest-dump-schema";
-        docs = "Dump the loaded schema's DbStructure as a yaml file.";
+        docs = "Dump the loaded schema's SchemaCache as a yaml file.";
         inRootDir = true;
         withEnv = postgrest.env;
         withPath = [ jq ];
       }
       ''
-        ${withTools.latest} \
+        ${withTools.withPg} \
             ${cabal-install}/bin/cabal v2-run ${devCabalOptions} --verbose=0 -- \
             postgrest --dump-schema \
             | ${yq}/bin/yq -y .
@@ -116,69 +109,76 @@ let
     checkedShellScript
       {
         name = "postgrest-coverage";
-        docs = "Run spec and io tests while collecting hpc coverage data.";
+        docs = "Run spec and io tests while collecting hpc coverage data. First runs weeder to detect dead code.";
         args = [ "ARG_LEFTOVERS([hpc report arguments])" ];
         inRootDir = true;
         redirectTixFiles = false;
         withEnv = postgrest.env;
         withTmpDir = true;
       }
-      ''
-        export LOCALE_ARCHIVE="${glibcLocales}/lib/locale/locale-archive"
+      (
+        # required for `hpc markup` in CI; glibcLocales is not available e.g. on Darwin
+        lib.optionalString (stdenv.isLinux && hostPlatform.libc == "glibc") ''
+          export LOCALE_ARCHIVE="${glibcLocales}/lib/locale/locale-archive"
+        '' +
 
-        # clean up previous coverage reports
-        mkdir -p coverage
-        rm -rf coverage/*
+        ''
+          # clean up previous coverage reports
+          mkdir -p coverage
+          rm -rf coverage/*
 
-        # build once before running all the tests
-        ${cabal-install}/bin/cabal v2-build ${devCabalOptions} exe:postgrest lib:postgrest test:spec test:querycost
+          # build once before running all the tests
+          ${cabal-install}/bin/cabal v2-build ${devCabalOptions} exe:postgrest lib:postgrest test:spec
 
-        # collect all tests
-        HPCTIXFILE="$tmpdir"/io.tix \
-          ${withTools.latest} ${cabal-install}/bin/cabal v2-exec ${devCabalOptions} \
-          ${ioTestPython}/bin/pytest -- -v test/io-tests
-          
-        HPCTIXFILE="$tmpdir"/spec.tix \
-          ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec
+          (
+            trap 'echo Found dead code: Check file list above.' ERR ;
+            ${weeder}/bin/weeder --config=./test/weeder.dhall
+          )
 
-        HPCTIXFILE="$tmpdir"/querycost.tix \
-          ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:querycost
+          # collect all tests
+          HPCTIXFILE="$tmpdir"/io.tix \
+            ${withTools.withPg} -f test/io/fixtures.sql ${cabal-install}/bin/cabal v2-exec ${devCabalOptions} -- \
+            ${ioTestPython}/bin/pytest -v test/io
 
-        # Note: No coverage for doctests, as doctests leverage GHCi and GHCi does not support hpc
+          HPCTIXFILE="$tmpdir"/spec.tix \
+            ${withTools.withPg} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec
 
-        # collect all the tix files
-        ${ghc}/bin/hpc sum  --union --exclude=Paths_postgrest --output="$tmpdir"/tests.tix \
-          "$tmpdir"/io*.tix "$tmpdir"/spec.tix "$tmpdir"/querycost.tix
+          # Note: No coverage for doctests, as doctests leverage GHCi and GHCi does not support hpc
 
-        # prepare the overlay
-        ${ghc}/bin/hpc overlay --output="$tmpdir"/overlay.tix test/coverage.overlay
-        ${ghc}/bin/hpc sum --union --output="$tmpdir"/tests-overlay.tix "$tmpdir"/tests.tix "$tmpdir"/overlay.tix
+          # collect all the tix files
+          ${ghc}/bin/hpc sum  --union --exclude=Paths_postgrest --output="$tmpdir"/tests.tix \
+            "$tmpdir"/io*.tix "$tmpdir"/spec.tix
 
-        # check nothing in the overlay is actually tested
-        ${ghc}/bin/hpc map --function=inv --output="$tmpdir"/inverted.tix "$tmpdir"/tests.tix
-        ${ghc}/bin/hpc combine --function=sub \
-          --output="$tmpdir"/check.tix "$tmpdir"/overlay.tix "$tmpdir"/inverted.tix
-        # returns zero exit code if any count="<non-zero>" lines are found, i.e.
-        # something is covered by both the overlay and the tests
-        if ${ghc}/bin/hpc report --xml "$tmpdir"/check.tix | ${gnugrep}/bin/grep -qP 'count="[^0]'
-        then
-          ${ghc}/bin/hpc markup --highlight-covered --destdir=coverage/overlay "$tmpdir"/overlay.tix || true
-          ${ghc}/bin/hpc markup --highlight-covered --destdir=coverage/check "$tmpdir"/check.tix || true
-          echo "ERROR: Something is covered by both the tests and the overlay:"
-          echo "file://$(pwd)/coverage/check/hpc_index.html"
-          exit 1
-        else
-          # copy the result .tix file to the coverage/ dir to make it available to postgrest-coverage-draft-overlay, too
-          cp "$tmpdir"/tests-overlay.tix coverage/postgrest.tix
-          # prepare codecov json report
-          ${hpc-codecov}/bin/hpc-codecov --mix=.hpc --out=coverage/codecov.json coverage/postgrest.tix
+          # prepare the overlay
+          ${ghc}/bin/hpc overlay --output="$tmpdir"/overlay.tix test/coverage.overlay
+          ${ghc}/bin/hpc sum --union --output="$tmpdir"/tests-overlay.tix "$tmpdir"/tests.tix "$tmpdir"/overlay.tix
 
-          # create html and stdout reports
-          ${ghc}/bin/hpc markup --destdir=coverage coverage/postgrest.tix
-          echo "file://$(pwd)/coverage/hpc_index.html"
-          ${ghc}/bin/hpc report coverage/postgrest.tix "''${_arg_leftovers[@]}"
-        fi
-      '';
+          # check nothing in the overlay is actually tested
+          ${ghc}/bin/hpc map --function=inv --output="$tmpdir"/inverted.tix "$tmpdir"/tests.tix
+          ${ghc}/bin/hpc combine --function=sub \
+            --output="$tmpdir"/check.tix "$tmpdir"/overlay.tix "$tmpdir"/inverted.tix
+          # returns zero exit code if any count="<non-zero>" lines are found, i.e.
+          # something is covered by both the overlay and the tests
+          if ${ghc}/bin/hpc report --xml "$tmpdir"/check.tix | ${gnugrep}/bin/grep -qP 'count="[^0]'
+          then
+            ${ghc}/bin/hpc markup --highlight-covered --destdir=coverage/overlay "$tmpdir"/overlay.tix || true
+            ${ghc}/bin/hpc markup --highlight-covered --destdir=coverage/check "$tmpdir"/check.tix || true
+            echo "ERROR: Something is covered by both the tests and the overlay:"
+            echo "postgrest-coverage: To see the results, visit file://$(pwd)/coverage/check/hpc_index.html"
+            exit 1
+          else
+            # copy the result .tix file to the coverage/ dir to make it available to postgrest-coverage-draft-overlay, too
+            cp "$tmpdir"/tests-overlay.tix coverage/postgrest.tix
+            # prepare codecov json report
+            ${hpc-codecov}/bin/hpc-codecov --mix=.hpc --out=coverage/codecov.json coverage/postgrest.tix
+
+            # create html and stdout reports
+            ${ghc}/bin/hpc markup --destdir=coverage coverage/postgrest.tix
+            echo "postgrest-coverage: To see the results, visit file://$(pwd)/coverage/hpc_index.html"
+            ${ghc}/bin/hpc report coverage/postgrest.tix "''${_arg_leftovers[@]}"
+          fi
+        ''
+      );
 
   coverageDraftOverlay =
     checkedShellScript
@@ -192,6 +192,26 @@ let
         sed -i 's|^module \(.*\):|module \1/|g' test/coverage.overlay
       '';
 
+  checkStatic =
+    checkedShellScript
+      {
+        name = "postgrest-check-static";
+        docs = "Verify that the argument is a static executable.";
+        args = [ "ARG_POSITIONAL_SINGLE([executable], [Executable])" ];
+        inRootDir = true;
+        withEnv = postgrest.env;
+      }
+      ''
+        exe="$_arg_executable"
+        ldd_output=$(ldd "$exe" 2>&1 || true)
+        if ! grep -q "not a dynamic executable" <<< "$ldd_output"; then
+          echo "not a static executable, ldd output:"
+          echo "$ldd_output"
+          exit 1
+        fi
+        "$exe" --help
+      '';
+
 in
 buildToolbox
 {
@@ -199,12 +219,12 @@ buildToolbox
   tools =
     [
       testSpec
-      testQuerycost
       testDoctests
       testSpecIdempotence
       testIO
       dumpSchema
       coverage
       coverageDraftOverlay
+      checkStatic
     ];
 }

nix/tools/withTools.nix

@@ -1,28 +1,40 @@
-{ bashCompletion
+{ bash-completion
 , buildToolbox
+, cabal-install
+, cabalTools
 , checkedShellScript
+, curl
+, devCabalOptions
+, git
 , lib
 , postgresqlVersions
-, writeTextFile
+, postgrest
+, slocat
+, writeText
 }:
 let
   withTmpDb =
     { name, postgresql }:
+    let
+      commandName = "postgrest-with-${name}";
+      superuserRole = "postgres";
+    in
     checkedShellScript
       {
-        name = "postgrest-with-${name}";
-        docs = "Run the given command in a temporary database with ${name}";
+        name = commandName;
+        docs = "Run the given command in a temporary database with ${name}. If you wish to mutate the database, login with the '${superuserRole}' role.";
         args =
           [
-            "ARG_OPTIONAL_SINGLE([fixtures], [f], [SQL file to load fixtures from], [test/fixtures/load.sql])"
+            "ARG_OPTIONAL_SINGLE([fixtures], [f], [SQL file to load fixtures from], [test/spec/fixtures/load.sql])"
             "ARG_POSITIONAL_SINGLE([command], [Command to run])"
             "ARG_LEFTOVERS([command arguments])"
             "ARG_USE_ENV([PGUSER], [postgrest_test_authenticator], [Authenticator PG role])"
             "ARG_USE_ENV([PGDATABASE], [postgres], [PG database name])"
             "ARG_USE_ENV([PGRST_DB_SCHEMAS], [test], [Schema to expose])"
-            "ARG_USE_ENV([PGRST_DB_ANON_ROLE], [postgrest_test_anonymous], [Anonymous PG role])"
+            "ARG_USE_ENV([PGTZ], [utc], [Timezone to use])"
+            "ARG_USE_ENV([PGOPTIONS], [-c search_path=public,test], [PG options to use])"
           ];
-        addCommandCompletion = true;
+        positionalCompletion = "_command";
         inRootDir = true;
         redirectTixFiles = false;
         withPath = [ postgresql ];
@@ -30,8 +42,8 @@ let
       }
       ''
         # avoid starting multiple layers of withTmpDb
-        if test -v PGRST_DB_URI; then
-          exec "$@"
+        if test -v PGHOST; then
+          exec "$_arg_command" "''${_arg_leftovers[@]}"
         fi
 
         setuplog="$tmpdir/setup.log"
@@ -48,21 +60,27 @@ let
         export PGHOST="$tmpdir/socket"
         export PGUSER
         export PGDATABASE
-        export PGRST_DB_URI="postgresql:///$PGDATABASE?host=$PGHOST&user=$PGUSER"
         export PGRST_DB_SCHEMAS
-        export PGRST_DB_ANON_ROLE
+        export PGTZ
+        export PGOPTIONS
+
+        HBA_FILE="$tmpdir/pg_hba.conf"
+        echo "local $PGDATABASE some_protected_user password" > "$HBA_FILE"
+        echo "local $PGDATABASE all trust" >> "$HBA_FILE"
 
         log "Initializing database cluster..."
         # We try to make the database cluster as independent as possible from the host
         # by specifying the timezone, locale and encoding.
-        PGTZ=UTC initdb --no-locale --encoding=UTF8 --nosync -U "$PGUSER" --auth=trust \
+        # initdb -U creates a superuser(man initdb)
+        TZ=$PGTZ initdb --no-locale --encoding=UTF8 --nosync -U "${superuserRole}" --auth=trust \
           >> "$setuplog"
 
         log "Starting the database cluster..."
         # Instead of listening on a local port, we will listen on a unix domain socket.
-        pg_ctl -l "$tmpdir/db.log" -w start -o "-F -c listen_addresses=\"\" -k $PGHOST" \
+        pg_ctl -l "$tmpdir/db.log" -w start -o "-F -c listen_addresses=\"\" -c hba_file=$HBA_FILE -k $PGHOST -c log_statement=\"all\" " \
           >> "$setuplog"
 
+        # shellcheck disable=SC2317
         stop () {
           log "Stopping the database cluster..."
           pg_ctl stop -m i >> "$setuplog"
@@ -70,35 +88,42 @@ let
         }
         trap stop EXIT
 
-        log "Loading fixtures..."
-        psql -v ON_ERROR_STOP=1 -f "$_arg_fixtures" >> "$setuplog"
+        log "Creating a minimally privileged $PGUSER connection role..."
+        createuser "$PGUSER" -U "${superuserRole}" --host="$tmpdir/socket" --no-createdb --no-inherit --no-superuser --no-createrole --no-replication --login
+
+        log "Loading fixtures under the ${superuserRole} role..."
+        psql -U "${superuserRole}" -v PGUSER="$PGUSER" -v ON_ERROR_STOP=1 -f "$_arg_fixtures" >> "$setuplog"
 
         log "Done. Running command..."
+
+        echo "${commandName}: You can connect with: psql 'postgres:///$PGDATABASE?host=$tmpdir/socket' -U ${superuserRole}"
+        echo "${commandName}: You can tail the logs with: tail -f $tmpdir/db.log"
+
         ("$_arg_command" "''${_arg_leftovers[@]}")
       '';
 
   # Helper script for running a command against all PostgreSQL versions.
-  withAll =
+  withPgAll =
     let
       runners =
         builtins.map
-          (pg:
+          (version:
             ''
               cat << EOF
 
-              Running against ${pg.name}...
+              Running against ${version.name}...
 
               EOF
 
-              trap 'echo "Failed on ${pg.name}"' exit
+              trap 'echo "Failed on ${version.name}"' exit
 
-              (${withTmpDb pg} "$_arg_command" "''${_arg_leftovers[@]}")
+              (${withTmpDb version} "$_arg_command" "''${_arg_leftovers[@]}")
 
               trap "" exit
 
               cat << EOF
 
-              Done running against ${pg.name}.
+              Done running against ${version.name}.
 
               EOF
             '')
@@ -113,21 +138,250 @@ let
             "ARG_POSITIONAL_SINGLE([command], [Command to run])"
             "ARG_LEFTOVERS([command arguments])"
           ];
-        addCommandCompletion = true;
+        positionalCompletion = "_command";
         inRootDir = true;
       }
       (lib.concatStringsSep "\n\n" runners);
 
   # Create a `postgrest-with-postgresql-` for each PostgreSQL version
-  withVersions = builtins.map withTmpDb postgresqlVersions;
+  withPgVersions = builtins.map withTmpDb postgresqlVersions;
+
+  withPg = builtins.head withPgVersions;
+
+  withSlowPg =
+    checkedShellScript
+      {
+        name = "postgrest-with-slow-pg";
+        docs = "Run the given command with simulated high latency postgresql";
+        args =
+          [
+            "ARG_POSITIONAL_SINGLE([command], [Command to run])"
+            "ARG_LEFTOVERS([command arguments])"
+            "ARG_USE_ENV([PGHOST], [], [PG host (socket name)])"
+            "ARG_USE_ENV([PGDELAY], [0ms], [extra PG latency (duration)])"
+          ];
+        positionalCompletion = "_command";
+        inRootDir = true;
+        redirectTixFiles = false;
+        withTmpDir = true;
+      }
+      ''
+        delay="''${PGDELAY:-0ms}"
+        echo "delaying data to/from postgres by $delay"
+
+        REALPGHOST="$PGHOST"
+        export PGHOST="$tmpdir/socket"
+        mkdir -p "$PGHOST"
+
+        ${slocat}/bin/slocat -delay "$delay" -src "$PGHOST/.s.PGSQL.5432" -dst "$REALPGHOST/.s.PGSQL.5432" &
+        SLOCAT_PID=$!
+        # shellcheck disable=SC2317
+        stop_slocat() {
+          kill "$SLOCAT_PID" || true
+          wait "$SLOCAT_PID" || true
+        }
+        trap stop_slocat EXIT
+        sleep 1 # should wait for socket file to appear instead
+
+        ("$_arg_command" "''${_arg_leftovers[@]}")
+      '';
+
+  withSlowPgrst =
+    checkedShellScript
+      {
+        name = "postgrest-with-slow-postgrest";
+        docs = "Run the given command with simulated high latency postgrest";
+        args =
+          [
+            "ARG_POSITIONAL_SINGLE([command], [Command to run])"
+            "ARG_LEFTOVERS([command arguments])"
+            "ARG_USE_ENV([PGRST_SERVER_UNIX_SOCKET], [], [PostgREST host (socket name)])"
+            "ARG_USE_ENV([PGRST_DELAY], [0ms], [extra PostgREST latency (duration)])"
+          ];
+        positionalCompletion = "_command";
+        inRootDir = true;
+        redirectTixFiles = false;
+        withTmpDir = true;
+      }
+      ''
+        delay="''${PGRST_DELAY:-0ms}"
+        echo "delaying data to/from PostgREST by $delay"
+
+        REAL_PGRST_SERVER_UNIX_SOCKET="$PGRST_SERVER_UNIX_SOCKET"
+        export PGRST_SERVER_UNIX_SOCKET="$tmpdir/postgrest.socket"
+
+        ${slocat}/bin/slocat -delay "$delay" -src "$PGRST_SERVER_UNIX_SOCKET" -dst "$REAL_PGRST_SERVER_UNIX_SOCKET" &
+        SLOCAT_PID=$!
+        # shellcheck disable=SC2317
+        stop_slocat() {
+          kill "$SLOCAT_PID" || true
+          wait "$SLOCAT_PID" || true
+        }
+        trap stop_slocat EXIT
+        sleep 1 # should wait for socket file to appear instead
+
+        ("$_arg_command" "''${_arg_leftovers[@]}")
+      '';
+
+  withGit =
+    let
+      name = "postgrest-with-git";
+    in
+    checkedShellScript
+      {
+        inherit name;
+        docs =
+          ''
+            Create a new worktree of the postgrest repo in a temporary directory and
+            check out <commit>, then run <command> with arguments inside the temporary folder.
+          '';
+        args =
+          [
+            "ARG_POSITIONAL_SINGLE([commit], [Commit-ish reference to run command with])"
+            "ARG_POSITIONAL_SINGLE([command], [Command to run])"
+            "ARG_LEFTOVERS([command arguments])"
+          ];
+        positionalCompletion =
+          ''
+            if test "$prev" == "${name}"; then
+              __gitcomp_nl "$(__git_refs)"
+            else
+              _command_offset 2
+            fi
+          '';
+        inRootDir = true;
+      }
+      ''
+        # not using withTmpDir here, because we don't want to keep the directory on error
+        tmpdir="$(mktemp -d)"
+        trap 'rm -rf "$tmpdir"' EXIT
+
+        ${git}/bin/git worktree add -f "$tmpdir" "$_arg_commit" > /dev/null
+
+        cd "$tmpdir"
+        ("$_arg_command" "''${_arg_leftovers[@]}")
+
+        ${git}/bin/git worktree remove -f "$tmpdir" > /dev/null
+      '';
+
+  legacyConfig =
+    writeText "legacy.conf"
+      ''
+        # Using this config file to support older postgrest versions for `postgrest-loadtest-against`
+        db-uri="$(PGRST_DB_URI)"
+        db-schema="$(PGRST_DB_SCHEMAS)"
+        db-anon-role="$(PGRST_DB_ANON_ROLE)"
+        db-pool="$(PGRST_DB_POOL)"
+        server-unix-socket="$(PGRST_SERVER_UNIX_SOCKET)"
+        log-level="$(PGRST_LOG_LEVEL)"
+      '';
+
+  waitForPgrstPid =
+    checkedShellScript
+      {
+        name = "postgrest-wait-for-pgrst-pid";
+        docs = "Wait for PostgREST to be running. Needs to be a separate command for timeout to work below.";
+        args = [
+          "ARG_USE_ENV([PGRST_SERVER_UNIX_SOCKET], [], [Unix socket to check for running PostgREST instance])"
+        ];
+      }
+      ''
+        # ARG_USE_ENV only adds defaults or docs for environment variables
+        # We manually implement a required check here
+        # See also: https://github.com/matejak/argbash/issues/80
+        : "''${PGRST_SERVER_UNIX_SOCKET:?PGRST_SERVER_UNIX_SOCKET is required}"
+
+        until [ -S "$PGRST_SERVER_UNIX_SOCKET" ]
+        do
+          sleep 0.1
+        done
+
+        # return pid of postgrest process
+        lsof -t -c '/^postgrest$/' "$PGRST_SERVER_UNIX_SOCKET"
+      '';
+
+  waitForPgrstReady =
+    checkedShellScript
+      {
+        name = "postgrest-wait-for-pgrst-ready";
+        docs = "Wait for PostgREST to be ready to serve requests. Needs to be a separate command for timeout to work below.";
+        args = [
+          "ARG_USE_ENV([PGRST_SERVER_UNIX_SOCKET], [], [Unix socket to check for running PostgREST instance])"
+        ];
+      }
+      ''
+        # ARG_USE_ENV only adds defaults or docs for environment variables
+        # We manually implement a required check here
+        # See also: https://github.com/matejak/argbash/issues/80
+        : "''${PGRST_SERVER_UNIX_SOCKET:?PGRST_SERVER_UNIX_SOCKET is required}"
+
+        function check_status () {
+          ${curl}/bin/curl -s -o /dev/null -w "%{http_code}" --unix-socket "$PGRST_SERVER_UNIX_SOCKET" http://localhost/
+        }
+
+        while [[ "$(check_status)" != "200" ]];
+           do sleep 0.1;
+        done
+      '';
+
+  withPgrst =
+    checkedShellScript
+      {
+        name = "postgrest-with-pgrst";
+        docs = "Build and run PostgREST and run <command> with PGRST_SERVER_UNIX_SOCKET set.";
+        args =
+          [
+            "ARG_POSITIONAL_SINGLE([command], [Command to run])"
+            "ARG_LEFTOVERS([command arguments])"
+          ];
+        positionalCompletion = "_command";
+        inRootDir = true;
+        withEnv = postgrest.env;
+        withTmpDir = true;
+      }
+      ''
+        export PGRST_SERVER_UNIX_SOCKET="$tmpdir"/postgrest.socket
+
+        rm -f result
+        if [ -z "''${PGRST_BUILD_CABAL:-}" ]; then
+          echo -n "Building postgrest (nix)... "
+          nix-build -A postgrestPackage > "$tmpdir"/build.log 2>&1 || {
+            echo "failed, output:"
+            cat "$tmpdir"/build.log
+            exit 1
+          }
+          PGRST_CMD=./result/bin/postgrest
+        else
+          echo -n "Building postgrest (cabal)... "
+          postgrest-build
+          PGRST_CMD=postgrest-run
+        fi
+        echo "done."
+
+        echo -n "Starting postgrest... "
+        $PGRST_CMD ${legacyConfig} > "$tmpdir"/run.log 2>&1 &
+        pid=$!
+        # shellcheck disable=SC2317
+        cleanup() {
+          kill "$pid" || true
+        }
+        trap cleanup EXIT
+
+        timeout -s TERM 5 ${waitForPgrstReady} || {
+          echo "timed out, output:"
+          cat "$tmpdir"/run.log
+          exit 1
+        }
+        echo "done."
+
+        ("$_arg_command" "''${_arg_leftovers[@]}")
+      '';
 
 in
 buildToolbox
 {
   name = "postgrest-with";
-  tools = [ withAll ] ++ withVersions;
-  extra = {
-    # make withTools.latest available for other nix files
-    latest = withTmpDb (builtins.head postgresqlVersions);
-  };
+  tools = [ withPgAll withGit withPgrst withSlowPg withSlowPgrst ] ++ withPgVersions;
+  # make withTools available for other nix files
+  extra = { inherit withGit withPg withPgAll withPgrst withSlowPg withSlowPgrst; };
 }

postgrest.cabal

@@ -1,8 +1,8 @@
 name:               postgrest
-version:            9.0.0
+version:            12.0.2
 synopsis:           REST API for any Postgres database
 description:        Reads the schema of a PostgreSQL database and creates RESTful routes
-                    for the tables and views, supporting all HTTP verbs that security
+                    for tables, views, and functions, supporting all HTTP methods that security
                     permits.
 license:            MIT
 license-file:       LICENSE
@@ -34,7 +34,8 @@ library
   default-extensions: OverloadedStrings
                       NoImplicitPrelude
   hs-source-dirs:     src
-  exposed-modules:    PostgREST.App
+  exposed-modules:    PostgREST.Admin
+                      PostgREST.App
                       PostgREST.AppState
                       PostgREST.Auth
                       PostgREST.CLI
@@ -43,77 +44,96 @@ library
                       PostgREST.Config.JSPath
                       PostgREST.Config.PgVersion
                       PostgREST.Config.Proxy
-                      PostgREST.ContentType
-                      PostgREST.DbStructure
-                      PostgREST.DbStructure.Identifiers
-                      PostgREST.DbStructure.Proc
-                      PostgREST.DbStructure.Relationship
-                      PostgREST.DbStructure.Table
+                      PostgREST.Cors
+                      PostgREST.SchemaCache
+                      PostgREST.SchemaCache.Identifiers
+                      PostgREST.SchemaCache.Routine
+                      PostgREST.SchemaCache.Relationship
+                      PostgREST.SchemaCache.Representations
+                      PostgREST.SchemaCache.Table
                       PostgREST.Error
-                      PostgREST.GucHeader
-                      PostgREST.Middleware
-                      PostgREST.OpenAPI
+                      PostgREST.Logger
+                      PostgREST.MediaType
+                      PostgREST.Query
                       PostgREST.Query.QueryBuilder
                       PostgREST.Query.SqlFragment
                       PostgREST.Query.Statements
+                      PostgREST.Plan
+                      PostgREST.Plan.CallPlan
+                      PostgREST.Plan.MutatePlan
+                      PostgREST.Plan.ReadPlan
+                      PostgREST.Plan.Types
                       PostgREST.RangeQuery
-                      PostgREST.Request.ApiRequest
-                      PostgREST.Request.DbRequestBuilder
-                      PostgREST.Request.Parsers
-                      PostgREST.Request.Preferences
-                      PostgREST.Request.Types
+                      PostgREST.Unix
+                      PostgREST.ApiRequest
+                      PostgREST.ApiRequest.Preferences
+                      PostgREST.ApiRequest.QueryParams
+                      PostgREST.ApiRequest.Types
+                      PostgREST.Response
+                      PostgREST.Response.OpenAPI
+                      PostgREST.Response.GucHeader
+                      PostgREST.Response.Performance
                       PostgREST.Version
-                      PostgREST.Workers
   other-modules:      Paths_postgrest
-  build-depends:      base                      >= 4.9 && < 4.16
-                    , HTTP                      >= 4000.3.7 && < 4000.4
+  build-depends:      base                      >= 4.9 && < 4.17
+                    , HTTP                      >= 4000.3.7 && < 4000.5
                     , Ranged-sets               >= 0.3 && < 0.5
-                    , aeson                     >= 1.4.7 && < 1.6
-                    , ansi-wl-pprint            >= 0.6.7 && < 0.7
+                    , aeson                     >= 2.0.3 && < 2.2
                     , auto-update               >= 0.1.4 && < 0.2
                     , base64-bytestring         >= 1 && < 1.3
-                    , bytestring                >= 0.10.8 && < 0.11
+                    , bytestring                >= 0.10.8 && < 0.12
+                    , cache                     >= 0.1.3 && < 0.2.0
                     , case-insensitive          >= 1.2 && < 1.3
                     , cassava                   >= 0.4.5 && < 0.6
+                    , clock                     >= 0.8.3 && < 0.9.0
                     , configurator-pg           >= 0.2 && < 0.3
                     , containers                >= 0.5.7 && < 0.7
-                    , contravariant             >= 1.4 && < 1.6
                     , contravariant-extras      >= 0.3.3 && < 0.4
                     , cookie                    >= 0.4.2 && < 0.5
+                    , directory                 >= 1.2.6 && < 1.4
                     , either                    >= 4.4.1 && < 5.1
-                    , fast-logger               >= 2.4.5
+                    , extra                     >= 1.7.0 && < 2.0
+                    , fuzzyset                  >= 0.2.3
                     , gitrev                    >= 1.2 && < 1.4
-                    , hasql                     >= 1.4 && < 1.5
-                    , hasql-dynamic-statements  == 0.3.1
-                    , hasql-notifications       >= 0.1 && < 0.3
-                    , hasql-pool                >= 0.5 && < 0.6
+                    , hasql                     >= 1.6.1.1 && < 1.7
+                    , hasql-dynamic-statements  >= 0.3.1 && < 0.4
+                    , hasql-notifications       >= 0.2.0.6 && < 0.3
+                    , hasql-pool                >= 0.10 && < 0.11
                     , hasql-transaction         >= 1.0.1 && < 1.1
                     , heredoc                   >= 0.2 && < 0.3
                     , http-types                >= 0.12.2 && < 0.13
                     , insert-ordered-containers >= 0.2.2 && < 0.3
                     , interpolatedstring-perl6  >= 1 && < 1.1
-                    , jose                      >= 0.8.1 && < 0.9
-                    , lens                      >= 4.14 && < 5.1
-                    , lens-aeson                >= 1.0.1 && < 1.2
+                    , jose                      >= 0.8.5.1 && < 0.11
+                    , lens                      >= 4.14 && < 5.3
+                    , lens-aeson                >= 1.0.1 && < 1.3
                     , mtl                       >= 2.2.2 && < 2.3
+                    , network                   >= 2.6 && < 3.2
                     , network-uri               >= 2.6.1 && < 2.8
-                    , optparse-applicative      >= 0.13 && < 0.17
+                    , optparse-applicative      >= 0.13 && < 0.18
                     , parsec                    >= 3.1.11 && < 3.2
-                    , protolude                 >= 0.3 && < 0.4
+                    , protolude                 >= 0.3.1 && < 0.4
                     , regex-tdfa                >= 1.2.2 && < 1.4
                     , retry                     >= 0.7.4 && < 0.10
                     , scientific                >= 0.3.4 && < 0.4
-                    , swagger2                  >= 2.4 && < 2.7
+                    , streaming-commons         >= 0.1.1 && < 0.3
+                    , swagger2                  >= 2.4 && < 2.9
                     , text                      >= 1.2.2 && < 1.3
-                    , time                      >= 1.6 && < 1.11
+                    , time                      >= 1.6 && < 1.12
+                    , timeit                    >= 2.0 && < 2.1
                     , unordered-containers      >= 0.2.8 && < 0.3
-                    , vector                    >= 0.11 && < 0.13
+                    , unix-compat               >= 0.5.4 && < 0.6
+                    , vault                     >= 0.3.1.5 && < 0.4
+                    , vector                    >= 0.11 && < 0.14
                     , wai                       >= 3.2.1 && < 3.3
                     , wai-cors                  >= 0.2.5 && < 0.3
-                    , wai-extra                 >= 3.0.19 && < 3.2
-                    , wai-logger                >= 2.3.2
-                    , wai-middleware-static     >= 0.8.1 && < 0.10
-                    , warp                      >= 3.2.12 && < 3.4
+                    , wai-extra                 >= 3.1.8 && < 3.2
+                    -- We already depend on wai-logger >= 2.3.7 indirectly via wai-extra,
+                    -- but we want to depend on 2.4.0 which fixes 'unknownSocket' log output
+                    -- for unix sockets; this is tested in test/io/test_io.py. See
+                    -- https://github.com/kazu-yamamoto/logger/commit/3a71ca70afdbb93d4ecf0083eeba1fbbbcab3fc3
+                    , wai-logger                >= 2.4.0
+                    , warp                      >= 3.3.19 && < 3.4
                       -- -fno-spec-constr may help keep compile time memory use in check,
                       --   see https://gitlab.haskell.org/ghc/ghc/issues/16017#note_219304
                       -- -optP-Wno-nonportable-include-path
@@ -123,7 +143,7 @@ library
                       -fno-spec-constr -optP-Wno-nonportable-include-path
 
   if flag(dev)
-    ghc-options: -O0
+    ghc-options: -O0 -fwrite-ide-info
     if flag(hpc)
       ghc-options: -fhpc -hpcdir .hpc
   else
@@ -132,10 +152,6 @@ library
   if !os(windows)
     build-depends:
       unix
-      , directory >= 1.2.6 && < 1.4
-      , network   >= 2.6 && < 3.2
-    exposed-modules:
-      PostgREST.Unix
 
 executable postgrest
   default-language:   Haskell2010
@@ -143,16 +159,18 @@ executable postgrest
                       NoImplicitPrelude
   hs-source-dirs:     main
   main-is:            Main.hs
-  build-depends:      base                >= 4.9 && < 4.16
+  build-depends:      base                >= 4.9 && < 4.17
                     , containers          >= 0.5.7 && < 0.7
                     , postgrest
-                    , protolude           >= 0.3 && < 0.4
-  ghc-options:        -threaded -rtsopts "-with-rtsopts=-N -I2"
+                    , protolude           >= 0.3.1 && < 0.4
+  ghc-options:        -threaded -rtsopts "-with-rtsopts=-N -I0 -qg"
                       -O2 -Werror -Wall -fwarn-identities
                       -fno-spec-constr -optP-Wno-nonportable-include-path
 
   if flag(dev)
-    ghc-options: -O0
+    ghc-options: -O0 -fwrite-ide-info
+                 -- https://github.com/PostgREST/postgrest/issues/387
+                 -with-rtsopts=-K1K
     if flag(hpc)
       ghc-options: -fhpc -hpcdir .hpc
   else
@@ -164,135 +182,103 @@ test-suite spec
   default-extensions: OverloadedStrings
                       QuasiQuotes
                       NoImplicitPrelude
-  hs-source-dirs:     test
+  hs-source-dirs:     test/spec
   main-is:            Main.hs
-  other-modules:      Feature.AndOrParamsSpec
-                      Feature.AsymmetricJwtSpec
-                      Feature.AudienceJwtSecretSpec
-                      Feature.AuthSpec
-                      Feature.BinaryJwtSecretSpec
+  other-modules:      Feature.Auth.AsymmetricJwtSpec
+                      Feature.Auth.AudienceJwtSecretSpec
+                      Feature.Auth.AuthSpec
+                      Feature.Auth.BinaryJwtSecretSpec
+                      Feature.Auth.NoAnonSpec
+                      Feature.Auth.NoJwtSpec
                       Feature.ConcurrentSpec
                       Feature.CorsSpec
-                      Feature.DeleteSpec
-                      Feature.DisabledOpenApiSpec
-                      Feature.EmbedDisambiguationSpec
-                      Feature.EmbedInnerJoinSpec
                       Feature.ExtraSearchPathSpec
-                      Feature.HtmlRawOutputSpec
-                      Feature.InsertSpec
-                      Feature.IgnorePrivOpenApiSpec
-                      Feature.JsonOperatorSpec
-                      Feature.LegacyGucsSpec
-                      Feature.MultipleSchemaSpec
-                      Feature.NoJwtSpec
-                      Feature.NonexistentSchemaSpec
-                      Feature.OpenApiSpec
+                      Feature.NoSuperuserSpec
+                      Feature.ObservabilitySpec
+                      Feature.OpenApi.DisabledOpenApiSpec
+                      Feature.OpenApi.IgnorePrivOpenApiSpec
+                      Feature.OpenApi.OpenApiSpec
+                      Feature.OpenApi.ProxySpec
+                      Feature.OpenApi.RootSpec
+                      Feature.OpenApi.SecurityOpenApiSpec
                       Feature.OptionsSpec
-                      Feature.ProxySpec
-                      Feature.QueryLimitedSpec
-                      Feature.QuerySpec
-                      Feature.RangeSpec
-                      Feature.RawOutputTypesSpec
+                      Feature.Query.AggregateFunctionsSpec
+                      Feature.Query.AndOrParamsSpec
+                      Feature.Query.ComputedRelsSpec
+                      Feature.Query.CustomMediaSpec
+                      Feature.Query.DeleteSpec
+                      Feature.Query.EmbedDisambiguationSpec
+                      Feature.Query.EmbedInnerJoinSpec
+                      Feature.Query.ErrorSpec
+                      Feature.Query.InsertSpec
+                      Feature.Query.JsonOperatorSpec
+                      Feature.Query.MultipleSchemaSpec
+                      Feature.Query.NullsStripSpec
+                      Feature.Query.PgSafeUpdateSpec
+                      Feature.Query.PlanSpec
+                      Feature.Query.PostGISSpec
+                      Feature.Query.PreferencesSpec
+                      Feature.Query.QueryLimitedSpec
+                      Feature.Query.QuerySpec
+                      Feature.Query.RangeSpec
+                      Feature.Query.RawOutputTypesSpec
+                      Feature.Query.RelatedQueriesSpec
+                      Feature.Query.RpcSpec
+                      Feature.Query.ServerTimingSpec
+                      Feature.Query.SingularSpec
+                      Feature.Query.SpreadQueriesSpec
+                      Feature.Query.UnicodeSpec
+                      Feature.Query.UpdateSpec
+                      Feature.Query.UpsertSpec
                       Feature.RollbackSpec
-                      Feature.RootSpec
                       Feature.RpcPreRequestGucsSpec
-                      Feature.RpcSpec
-                      Feature.SingularSpec
-                      Feature.UnicodeSpec
-                      Feature.UpdateSpec
-                      Feature.UpsertSpec
                       SpecHelper
-                      TestTypes
-  build-depends:      base              >= 4.9 && < 4.16
-                    , aeson             >= 1.4.7 && < 1.6
+  build-depends:      base              >= 4.9 && < 4.17
+                    , aeson             >= 2.0.3 && < 2.2
                     , aeson-qq          >= 0.8.1 && < 0.9
                     , async             >= 2.1.1 && < 2.3
                     , auto-update       >= 0.1.4 && < 0.2
                     , base64-bytestring >= 1 && < 1.3
-                    , bytestring        >= 0.10.8 && < 0.11
+                    , bytestring        >= 0.10.8 && < 0.12
                     , case-insensitive  >= 1.2 && < 1.3
-                    , cassava           >= 0.4.5 && < 0.6
                     , containers        >= 0.5.7 && < 0.7
-                    , contravariant     >= 1.4 && < 1.6
-                    , hasql             >= 1.4 && < 1.5
-                    , hasql-pool        >= 0.5 && < 0.6
+                    , hasql-pool        >= 0.10 && < 0.11
                     , hasql-transaction >= 1.0.1 && < 1.1
                     , heredoc           >= 0.2 && < 0.3
-                    , hspec             >= 2.3 && < 2.9
+                    , hspec             >= 2.3 && < 2.10
                     , hspec-wai         >= 0.10 && < 0.12
                     , hspec-wai-json    >= 0.10 && < 0.12
                     , http-types        >= 0.12.3 && < 0.13
-                    , lens              >= 4.14 && < 5.1
-                    , lens-aeson        >= 1.0.1 && < 1.2
+                    , lens              >= 4.14 && < 5.3
+                    , lens-aeson        >= 1.0.1 && < 1.3
                     , monad-control     >= 1.0.1 && < 1.1
                     , postgrest
                     , process           >= 1.4.2 && < 1.7
-                    , protolude         >= 0.3 && < 0.4
+                    , protolude         >= 0.3.1 && < 0.4
                     , regex-tdfa        >= 1.2.2 && < 1.4
+                    , scientific        >= 0.3.4 && < 0.4
                     , text              >= 1.2.2 && < 1.3
-                    , time              >= 1.6 && < 1.11
                     , transformers-base >= 0.4.4 && < 0.5
                     , wai               >= 3.2.1 && < 3.3
                     , wai-extra         >= 3.0.19 && < 3.2
-  ghc-options:        -O0 -Werror -Wall -fwarn-identities
+  ghc-options:        -threaded -O0 -Werror -Wall -fwarn-identities
                       -fno-spec-constr -optP-Wno-nonportable-include-path
                       -fno-warn-missing-signatures
-
-test-suite querycost
-  type:                exitcode-stdio-1.0
-  default-language:    Haskell2010
-  default-extensions:  OverloadedStrings
-                       QuasiQuotes
-                       NoImplicitPrelude
-  hs-source-dirs:      test
-  main-is:             QueryCost.hs
-  other-modules:       SpecHelper
-  build-depends:       base              >= 4.9 && < 4.16
-                     , aeson             >= 1.4.7 && < 1.6
-                     , aeson-qq          >= 0.8.1 && < 0.9
-                     , async             >= 2.1.1 && < 2.3
-                     , auto-update       >= 0.1.4 && < 0.2
-                     , base64-bytestring >= 1 && < 1.3
-                     , bytestring        >= 0.10.8 && < 0.11
-                     , case-insensitive  >= 1.2 && < 1.3
-                     , cassava           >= 0.4.5 && < 0.6
-                     , containers        >= 0.5.7 && < 0.7
-                     , contravariant     >= 1.4 && < 1.6
-                     , hasql             >= 1.4 && < 1.5
-                     , hasql-dynamic-statements  == 0.3.1
-                     , hasql-pool        >= 0.5 && < 0.6
-                     , hasql-transaction >= 1.0.1 && < 1.1
-                     , heredoc           >= 0.2 && < 0.3
-                     , hspec             >= 2.3 && < 2.9
-                     , hspec-wai         >= 0.10 && < 0.12
-                     , hspec-wai-json    >= 0.10 && < 0.12
-                     , http-types        >= 0.12.3 && < 0.13
-                     , lens              >= 4.14 && < 5.1
-                     , lens-aeson        >= 1.0.1 && < 1.2
-                     , monad-control     >= 1.0.1 && < 1.1
-                     , postgrest
-                     , process           >= 1.4.2 && < 1.7
-                     , protolude         >= 0.3 && < 0.4
-                     , regex-tdfa        >= 1.2.2 && < 1.4
-                     , text              >= 1.2.2 && < 1.3
-                     , time              >= 1.6 && < 1.11
-                     , transformers-base >= 0.4.4 && < 0.5
-                     , wai               >= 3.2.1 && < 3.3
-                     , wai-extra         >= 3.0.19 && < 3.2
-  ghc-options:         -O0 -Werror -Wall -fwarn-identities
-                       -fno-spec-constr -optP-Wno-nonportable-include-path
+                      -fwrite-ide-info
+                      -- https://github.com/PostgREST/postgrest/issues/387
+                      -with-rtsopts=-K33K
 
 test-suite doctests
-  type:                exitcode-stdio-1.0
-  default-language:    Haskell2010
-  default-extensions:  OverloadedStrings
-                       NoImplicitPrelude
-  hs-source-dirs:      test/doctests
-  main-is:             Main.hs
-  build-depends:       base              >= 4.9 && < 4.16
-                     , doctest           >= 0.8
-                     , postgrest
-                     , pretty-simple
-                     , protolude         >= 0.3 && < 0.4
-  ghc-options:         -threaded -O0 -Werror -Wall -fwarn-identities
-                       -fno-spec-constr -optP-Wno-nonportable-include-path
+  type:               exitcode-stdio-1.0
+  default-language:   Haskell2010
+  default-extensions: OverloadedStrings
+                      NoImplicitPrelude
+  hs-source-dirs:     test/doc
+  main-is:            Main.hs
+  build-depends:      base              >= 4.9 && < 4.17
+                    , doctest           >= 0.8
+                    , postgrest
+                    , pretty-simple
+                    , protolude         >= 0.3.1 && < 0.4
+  ghc-options:        -threaded -O0 -Werror -Wall -fwarn-identities
+                      -fno-spec-constr -optP-Wno-nonportable-include-path

shell.nix

@@ -11,7 +11,7 @@
 }:
 let
   postgrest =
-    import ./default.nix;
+    import ./default.nix { };
 
   inherit (postgrest) pkgs;
 
@@ -21,6 +21,7 @@ let
     [
       postgrest.cabalTools
       postgrest.devTools
+      postgrest.loadtest
       postgrest.nixpkgsTools
       postgrest.style
       postgrest.tests
@@ -37,20 +38,25 @@ lib.overrideDerivation postgrest.env (
       base.buildInputs ++ [
         pkgs.cabal-install
         pkgs.cabal2nix
+        pkgs.git
         pkgs.postgresql
+        pkgs.update-nix-fetchgit
         postgrest.hsie.bin
       ]
       ++ toolboxes;
 
     shellHook =
       ''
-        source ${pkgs.bashCompletion}/etc/profile.d/bash_completion.sh
-        source ${postgrest.hsie.bashCompletion}
+        export HISTFILE=.history
+
+        source ${pkgs.bash-completion}/etc/profile.d/bash_completion.sh
+        source ${pkgs.git}/share/git/contrib/completion/git-completion.bash
+        source ${postgrest.hsie.bash-completion}
 
       ''
       + builtins.concatStringsSep "\n" (
-        builtins.map (bashCompletion: "source ${bashCompletion}") (
-          builtins.concatLists (builtins.map (toolbox: toolbox.bashCompletion) toolboxes)
+        builtins.map (bash-completion: "source ${bash-completion}") (
+          builtins.concatLists (builtins.map (toolbox: toolbox.bash-completion) toolboxes)
         )
       );
   }

src/PostgREST/Admin.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module PostgREST.Admin
+  ( runAdmin
+  ) where
+
+import qualified Hasql.Session             as SQL
+import qualified Network.HTTP.Types.Status as HTTP
+import qualified Network.Wai               as Wai
+import qualified Network.Wai.Handler.Warp  as Warp
+
+import Control.Monad.Extra (whenJust)
+
+import Network.Socket
+import Network.Socket.ByteString
+
+import PostgREST.AppState (AppState)
+import PostgREST.Config   (AppConfig (..))
+
+import qualified PostgREST.AppState as AppState
+
+import Protolude
+import Protolude.Partial (fromJust)
+
+runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO ()
+runAdmin conf@AppConfig{configAdminServerPort} appState settings =
+  whenJust (AppState.getSocketAdmin appState) $ \adminSocket -> do
+    AppState.logWithZTime appState $ "Admin server listening on port " <> show (fromIntegral (fromJust configAdminServerPort) :: Integer)
+    void . forkIO $ Warp.runSettingsSocket settings adminSocket adminApp
+  where
+    adminApp = admin appState conf
+
+-- | PostgREST admin application
+admin :: AppState.AppState -> AppConfig -> Wai.Application
+admin appState appConfig req respond  = do
+  isMainAppReachable  <- isRight <$> reachMainApp (AppState.getSocketREST appState)
+  isSchemaCacheLoaded <- isJust <$> AppState.getSchemaCache appState
+  isConnectionUp      <-
+    if configDbChannelEnabled appConfig
+      then AppState.getIsListenerOn appState
+      else isRight <$> AppState.usePool appState appConfig (SQL.sql "SELECT 1")
+
+  case Wai.pathInfo req of
+    ["ready"] ->
+      respond $ Wai.responseLBS (if isMainAppReachable && isConnectionUp && isSchemaCacheLoaded then HTTP.status200 else HTTP.status503) [] mempty
+    ["live"] ->
+      respond $ Wai.responseLBS (if isMainAppReachable then HTTP.status200 else HTTP.status503) [] mempty
+    _ ->
+      respond $ Wai.responseLBS HTTP.status404 [] mempty
+
+-- Try to connect to the main app socket
+-- Note that it doesn't even send a valid HTTP request, we just want to check that the main app is accepting connections
+reachMainApp :: Socket -> IO (Either IOException ())
+reachMainApp appSock = do
+  sockAddr <- getSocketName appSock
+  sock <- socket (addrFamily sockAddr) Stream defaultProtocol
+  try $ do
+    connect sock sockAddr
+    withSocketsDo $ bracket (pure sock) close sendEmpty
+  where
+    sendEmpty sock = void $ send sock mempty
+    addrFamily (SockAddrInet _ _) = AF_INET
+    addrFamily (SockAddrInet6 {}) = AF_INET6
+    addrFamily (SockAddrUnix _)   = AF_UNIX

src/PostgREST/ApiRequest.hs

@@ -0,0 +1,340 @@
+{-|
+Module      : PostgREST.Request.ApiRequest
+Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
+-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE MultiWayIf      #-}
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module PostgREST.ApiRequest
+  ( ApiRequest(..)
+  , InvokeMethod(..)
+  , Mutation(..)
+  , MediaType(..)
+  , Action(..)
+  , Target(..)
+  , Payload(..)
+  , userApiRequest
+  ) where
+
+import qualified Data.Aeson            as JSON
+import qualified Data.Aeson.Key        as K
+import qualified Data.Aeson.KeyMap     as KM
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy  as LBS
+import qualified Data.CaseInsensitive  as CI
+import qualified Data.Csv              as CSV
+import qualified Data.HashMap.Strict   as HM
+import qualified Data.List.NonEmpty    as NonEmptyList
+import qualified Data.Map.Strict       as M
+import qualified Data.Set              as S
+import qualified Data.Text.Encoding    as T
+import qualified Data.Vector           as V
+
+import Data.Either.Combinators (mapBoth)
+
+import Control.Arrow             ((***))
+import Data.Aeson.Types          (emptyArray, emptyObject)
+import Data.List                 (lookup)
+import Data.Ranged.Ranges        (emptyRange, rangeIntersection,
+                                  rangeIsEmpty)
+import Network.HTTP.Types.Header (RequestHeaders, hCookie)
+import Network.HTTP.Types.URI    (parseSimpleQuery)
+import Network.Wai               (Request (..))
+import Network.Wai.Parse         (parseHttpAccept)
+import Web.Cookie                (parseCookies)
+
+import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
+import PostgREST.ApiRequest.Types        (ApiRequestError (..),
+                                          RangeError (..))
+import PostgREST.Config                  (AppConfig (..),
+                                          OpenAPIMode (..))
+import PostgREST.MediaType               (MediaType (..))
+import PostgREST.RangeQuery              (NonnegRange, allRange,
+                                          convertToLimitZeroRange,
+                                          hasLimitZero,
+                                          rangeRequested)
+import PostgREST.SchemaCache             (SchemaCache (..))
+import PostgREST.SchemaCache.Identifiers (FieldName,
+                                          QualifiedIdentifier (..),
+                                          Schema)
+
+import qualified PostgREST.ApiRequest.Preferences as Preferences
+import qualified PostgREST.ApiRequest.QueryParams as QueryParams
+import qualified PostgREST.MediaType              as MediaType
+
+import Protolude
+
+
+type RequestBody = LBS.ByteString
+
+data Payload
+  = ProcessedJSON -- ^ Cached attributes of a JSON payload
+      { payRaw  :: LBS.ByteString
+      -- ^ This is the raw ByteString that comes from the request body.  We
+      -- cache this instead of an Aeson Value because it was detected that for
+      -- large payloads the encoding had high memory usage, see
+      -- https://github.com/PostgREST/postgrest/pull/1005 for more details
+      , payKeys :: S.Set Text
+      -- ^ Keys of the object or if it's an array these keys are guaranteed to
+      -- be the same across all its objects
+      }
+  | ProcessedUrlEncoded { payArray  :: [(Text, Text)], payKeys :: S.Set Text }
+  | RawJSON { payRaw  :: LBS.ByteString }
+  | RawPay  { payRaw  :: LBS.ByteString }
+
+data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
+data Mutation = MutationCreate | MutationDelete | MutationSingleUpsert | MutationUpdate deriving Eq
+
+-- | Types of things a user wants to do to tables/views/procs
+data Action
+  = ActionMutate Mutation
+  | ActionRead {isHead :: Bool}
+  | ActionInvoke InvokeMethod
+  | ActionInfo
+  | ActionInspect {isHead :: Bool}
+  deriving Eq
+-- | The path info that will be mapped to a target (used to handle validations and errors before defining the Target)
+data PathInfo
+  = PathInfo
+      { pathName       :: Text
+      , pathIsProc     :: Bool
+      , pathIsDefSpec  :: Bool
+      , pathIsRootSpec :: Bool
+      }
+-- | The target db object of a user action
+data Target = TargetIdent QualifiedIdentifier
+            | TargetProc{tProc :: QualifiedIdentifier, tpIsRootSpec :: Bool}
+            | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/"
+
+{-|
+  Describes what the user wants to do. This data type is a
+  translation of the raw elements of an HTTP request into domain
+  specific language.  There is no guarantee that the intent is
+  sensible, it is up to a later stage of processing to determine
+  if it is an action we are able to perform.
+-}
+data ApiRequest = ApiRequest {
+    iAction              :: Action                           -- ^ Similar but not identical to HTTP method, e.g. Create/Invoke both POST
+  , iRange               :: HM.HashMap Text NonnegRange      -- ^ Requested range of rows within response
+  , iTopLevelRange       :: NonnegRange                      -- ^ Requested range of rows from the top level
+  , iTarget              :: Target                           -- ^ The target, be it calling a proc or accessing a table
+  , iPayload             :: Maybe Payload                    -- ^ Data sent by client and used for mutation actions
+  , iPreferences         :: Preferences.Preferences          -- ^ Prefer header values
+  , iQueryParams         :: QueryParams.QueryParams
+  , iColumns             :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and payload
+  , iHeaders             :: [(ByteString, ByteString)]       -- ^ HTTP request headers
+  , iCookies             :: [(ByteString, ByteString)]       -- ^ Request Cookies
+  , iPath                :: ByteString                       -- ^ Raw request path
+  , iMethod              :: ByteString                       -- ^ Raw request method
+  , iSchema              :: Schema                           -- ^ The request schema. Can vary depending on profile headers.
+  , iNegotiatedByProfile :: Bool                             -- ^ If schema was was chosen according to the profile spec https://www.w3.org/TR/dx-prof-conneg/
+  , iAcceptMediaType     :: [MediaType]                      -- ^ The resolved media types in the Accept, considering quality(q) factors
+  , iContentMediaType    :: MediaType                        -- ^ The media type in the Content-Type header
+  }
+
+-- | Examines HTTP request and translates it into user intent.
+userApiRequest :: AppConfig -> Request -> RequestBody -> SchemaCache -> Either ApiRequestError ApiRequest
+userApiRequest conf req reqBody sCache = do
+  pInfo@PathInfo{..} <- getPathInfo conf $ pathInfo req
+  act <- getAction pInfo method
+  qPrms <- first QueryParamError $ QueryParams.parse (pathIsProc && act `elem` [ActionInvoke InvGet, ActionInvoke InvHead]) $ rawQueryString req
+  (schema, negotiatedByProfile) <- getSchema conf hdrs method
+  (topLevelRange, ranges) <- getRanges method qPrms hdrs
+  (payload, columns) <- getPayload reqBody contentMediaType qPrms act pInfo
+  return $ ApiRequest {
+    iAction = act
+  , iTarget = if | pathIsProc    -> TargetProc (QualifiedIdentifier schema pathName) pathIsRootSpec
+                 | pathIsDefSpec -> TargetDefaultSpec schema
+                 | otherwise     -> TargetIdent $ QualifiedIdentifier schema pathName
+  , iRange = ranges
+  , iTopLevelRange = topLevelRange
+  , iPayload = payload
+  , iPreferences = Preferences.fromHeaders (configDbTxAllowOverride conf) (dbTimezones sCache) hdrs
+  , iQueryParams = qPrms
+  , iColumns = columns
+  , iHeaders = iHdrs
+  , iCookies = iCkies
+  , iPath = rawPathInfo req
+  , iMethod = method
+  , iSchema = schema
+  , iNegotiatedByProfile = negotiatedByProfile
+  , iAcceptMediaType = maybe [MTAny] (map MediaType.decodeMediaType . parseHttpAccept) $ lookupHeader "accept"
+  , iContentMediaType = contentMediaType
+  }
+  where
+    method = requestMethod req
+    hdrs = requestHeaders req
+    lookupHeader    = flip lookup hdrs
+    iHdrs = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]
+    iCkies = maybe [] parseCookies $ lookupHeader "Cookie"
+    contentMediaType = maybe MTApplicationJSON MediaType.decodeMediaType $ lookupHeader "content-type"
+
+getPathInfo :: AppConfig -> [Text] -> Either ApiRequestError PathInfo
+getPathInfo AppConfig{configOpenApiMode, configDbRootSpec} path =
+  case path of
+    []             -> case configDbRootSpec of
+                        Just (QualifiedIdentifier _ pathName)     -> Right $ PathInfo pathName True False True
+                        Nothing | configOpenApiMode == OADisabled -> Left NotFound
+                                | otherwise                       -> Right $ PathInfo mempty False True False
+    [table]        -> Right $ PathInfo table False False False
+    ["rpc", pName] -> Right $ PathInfo pName True False False
+    _              -> Left NotFound
+
+getAction :: PathInfo -> ByteString -> Either ApiRequestError Action
+getAction PathInfo{pathIsProc, pathIsDefSpec} method =
+  if pathIsProc && method `notElem` ["HEAD", "GET", "POST", "OPTIONS"]
+    then Left $ InvalidRpcMethod method
+    else case method of
+      -- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response
+      -- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4
+      "HEAD"     | pathIsDefSpec -> Right $ ActionInspect{isHead=True}
+                 | pathIsProc    -> Right $ ActionInvoke InvHead
+                 | otherwise     -> Right $ ActionRead{isHead=True}
+      "GET"      | pathIsDefSpec -> Right $ ActionInspect{isHead=False}
+                 | pathIsProc    -> Right $ ActionInvoke InvGet
+                 | otherwise     -> Right $ ActionRead{isHead=False}
+      "POST"     | pathIsProc    -> Right $ ActionInvoke InvPost
+                 | otherwise     -> Right $ ActionMutate MutationCreate
+      "PATCH"                    -> Right $ ActionMutate MutationUpdate
+      "PUT"                      -> Right $ ActionMutate MutationSingleUpsert
+      "DELETE"                   -> Right $ ActionMutate MutationDelete
+      "OPTIONS"                  -> Right ActionInfo
+      _                          -> Left $ UnsupportedMethod method
+
+getSchema :: AppConfig -> RequestHeaders -> ByteString -> Either ApiRequestError (Schema, Bool)
+getSchema AppConfig{configDbSchemas} hdrs method = do
+  case profile of
+    Just p | p `notElem` configDbSchemas -> Left $ UnacceptableSchema $ toList configDbSchemas
+           | otherwise                   -> Right (p, True)
+    Nothing -> Right (defaultSchema, length configDbSchemas /= 1) -- if we have many schemas, assume the default schema was negotiated
+  where
+    defaultSchema = NonEmptyList.head configDbSchemas
+    profile = case method of
+      -- POST/PATCH/PUT/DELETE don't use the same header as per the spec
+      "DELETE" -> contentProfile
+      "PATCH"  -> contentProfile
+      "POST"   -> contentProfile
+      "PUT"    -> contentProfile
+      _        -> acceptProfile
+    contentProfile = T.decodeUtf8 <$> lookupHeader "Content-Profile"
+    acceptProfile = T.decodeUtf8 <$> lookupHeader "Accept-Profile"
+    lookupHeader    = flip lookup hdrs
+
+getRanges :: ByteString -> QueryParams -> RequestHeaders -> Either ApiRequestError (NonnegRange, HM.HashMap Text NonnegRange)
+getRanges method QueryParams{qsOrder,qsRanges} hdrs
+  | isInvalidRange = Left $ InvalidRange (if rangeIsEmpty headerRange then LowerGTUpper else NegativeLimit)
+  | method `elem` ["PATCH", "DELETE"] && not (null qsRanges) && null qsOrder = Left LimitNoOrderError
+  | method == "PUT" && topLevelRange /= allRange = Left PutLimitNotAllowedError
+  | otherwise = Right (topLevelRange, ranges)
+  where
+    -- According to the RFC (https://www.rfc-editor.org/rfc/rfc9110.html#name-range),
+    -- the Range header must be ignored for all methods other than GET
+    headerRange = if method == "GET" then rangeRequested hdrs else allRange
+    limitRange = fromMaybe allRange (HM.lookup "limit" qsRanges)
+    headerAndLimitRange = rangeIntersection headerRange limitRange
+    -- Bypass all the ranges and send only the limit zero range (0 <= x <= -1) if
+    -- limit=0 is present in the query params (not allowed for the Range header)
+    ranges = HM.insert "limit" (convertToLimitZeroRange limitRange headerAndLimitRange) qsRanges
+    -- The only emptyRange allowed is the limit zero range
+    isInvalidRange = topLevelRange == emptyRange && not (hasLimitZero limitRange)
+    topLevelRange = fromMaybe allRange $ HM.lookup "limit" ranges -- if no limit is specified, get all the request rows
+
+getPayload :: RequestBody -> MediaType -> QueryParams.QueryParams -> Action -> PathInfo -> Either ApiRequestError (Maybe Payload, S.Set FieldName)
+getPayload reqBody contentMediaType QueryParams{qsColumns} action PathInfo{pathIsProc}= do
+  checkedPayload <- if shouldParsePayload then payload else Right Nothing
+  let cols = case (checkedPayload, columns) of
+        (Just ProcessedJSON{payKeys}, _)       -> payKeys
+        (Just ProcessedUrlEncoded{payKeys}, _) -> payKeys
+        (Just RawJSON{}, Just cls)             -> cls
+        _                                      -> S.empty
+  return (checkedPayload, cols)
+  where
+    payload :: Either ApiRequestError (Maybe Payload)
+    payload = mapBoth InvalidBody Just $ case (contentMediaType, pathIsProc) of
+      (MTApplicationJSON, _) ->
+        if isJust columns
+          then Right $ RawJSON reqBody
+          else note "All object keys must match" . payloadAttributes reqBody
+                 =<< if LBS.null reqBody && pathIsProc
+                       then Right emptyObject
+                       else first BS.pack $
+                          -- Drop parsing error message in favor of generic one (https://github.com/PostgREST/postgrest/issues/2344)
+                          maybe (Left "Empty or invalid json") Right $ JSON.decode reqBody
+      (MTTextCSV, _) -> do
+        json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody)
+        note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
+      (MTUrlEncoded, isProc) -> do
+        let params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
+        if isProc
+          then Right $ ProcessedUrlEncoded params (S.fromList $ fst <$> params)
+          else
+            let paramsMap = HM.fromList $ (identity *** JSON.String) <$> params in
+            Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap)
+      (MTTextPlain, True) -> Right $ RawPay reqBody
+      (MTTextXML, True) -> Right $ RawPay reqBody
+      (MTOctetStream, True) -> Right $ RawPay reqBody
+      (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
+
+    shouldParsePayload = case (action, contentMediaType) of
+      (ActionMutate MutationCreate, _)       -> True
+      (ActionInvoke InvPost, _)              -> True
+      (ActionMutate MutationSingleUpsert, _) -> True
+      (ActionMutate MutationUpdate, _)       -> True
+      _                                      -> False
+
+    columns = case action of
+      ActionMutate MutationCreate -> qsColumns
+      ActionMutate MutationUpdate -> qsColumns
+      ActionInvoke InvPost        -> qsColumns
+      _                           -> Nothing
+
+type CsvData = V.Vector (M.Map Text LBS.ByteString)
+
+{-|
+  Converts CSV like
+  a,b
+  1,hi
+  2,bye
+
+  into a JSON array like
+  [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
+
+  The reason for its odd signature is so that it can compose
+  directly with CSV.decodeByName
+-}
+csvToJson :: (CSV.Header, CsvData) -> JSON.Value
+csvToJson (_, vals) =
+  JSON.Array $ V.map rowToJsonObj vals
+ where
+  rowToJsonObj = JSON.Object . KM.fromMapText .
+    M.map (\str ->
+        if str == "NULL"
+          then JSON.Null
+          else JSON.String . T.decodeUtf8 $ LBS.toStrict str
+      )
+
+payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
+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 $ K.toText <$> KM.keys o
+              areKeysUniform = all (\case
+                JSON.Object x -> S.fromList (K.toText <$> KM.keys x) == canonicalKeys
+                _ -> False) arr in
+          if areKeysUniform
+            then Just $ ProcessedJSON raw canonicalKeys
+            else Nothing
+        Just _ -> Nothing
+        Nothing -> Just emptyPJArray
+
+    JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ K.toText <$> KM.keys o)
+
+    -- truncate everything else to an empty array.
+    _ -> Just emptyPJArray
+  where
+    emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty

src/PostgREST/ApiRequest/Preferences.hs

@@ -1,28 +1,35 @@
 -- |
--- Module: PostgREST.Request.Preferences
+-- Module: PostgREST.ApiRequest.Preferences
 -- Description: Track client preferences to be employed when processing requests
 --
 -- Track client prefences set in HTTP 'Prefer' headers according to RFC7240[1].
 --
 -- [1] https://datatracker.ietf.org/doc/html/rfc7240
 --
-module PostgREST.Request.Preferences
+{-# LANGUAGE NamedFieldPuns #-}
+module PostgREST.ApiRequest.Preferences
   ( Preferences(..)
   , PreferCount(..)
+  , PreferHandling(..)
+  , PreferMissing(..)
   , PreferParameters(..)
   , PreferRepresentation(..)
   , PreferResolution(..)
   , PreferTransaction(..)
+  , PreferTimezone(..)
   , fromHeaders
-  , ToAppliedHeader(..)
+  , shouldCount
+  , prefAppliedHeader
   ) where
 
 import qualified Data.ByteString.Char8     as BS
 import qualified Data.Map                  as Map
+import qualified Data.Set                  as S
 import qualified Network.HTTP.Types.Header as HTTP
 
-import Protolude
+import PostgREST.Config.Database (TimezoneNames)
 
+import Protolude
 
 -- $setup
 -- Setup for doctests
@@ -32,6 +39,9 @@ import Protolude
 -- >>> deriving instance Show PreferParameters
 -- >>> deriving instance Show PreferCount
 -- >>> deriving instance Show PreferTransaction
+-- >>> deriving instance Show PreferMissing
+-- >>> deriving instance Show PreferHandling
+-- >>> deriving instance Show PreferTimezone
 -- >>> deriving instance Show Preferences
 
 -- | Preferences recognized by the application.
@@ -42,77 +52,110 @@ data Preferences
     , preferParameters     :: Maybe PreferParameters
     , preferCount          :: Maybe PreferCount
     , preferTransaction    :: Maybe PreferTransaction
+    , preferMissing        :: Maybe PreferMissing
+    , preferHandling       :: Maybe PreferHandling
+    , preferTimezone       :: Maybe PreferTimezone
+    , invalidPrefs         :: [ByteString]
     }
 
 -- |
 -- Parse HTTP headers based on RFC7240[1] to identify preferences.
 --
--- One header with comma-separated values can be used to set multiple preferences:
+-- >>> let sc = S.fromList ["America/Los_Angeles"]
 --
--- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates, count=exact")]
+-- One header with comma-separated values can be used to set multiple preferences:
+-- >>> pPrint $ fromHeaders True sc [("Prefer", "resolution=ignore-duplicates, count=exact, timezone=America/Los_Angeles")]
 -- Preferences
 --     { preferResolution = Just IgnoreDuplicates
 --     , preferRepresentation = Nothing
 --     , preferParameters = Nothing
 --     , preferCount = Just ExactCount
 --     , preferTransaction = Nothing
+--     , preferMissing = Nothing
+--     , preferHandling = Nothing
+--     , preferTimezone = Just
+--         ( PreferTimezone "America/Los_Angeles" )
+--     , invalidPrefs = []
 --     }
 --
 -- Multiple headers can also be used:
 --
--- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates"), ("Prefer", "count=exact")]
+-- >>> pPrint $ fromHeaders True sc [("Prefer", "resolution=ignore-duplicates"), ("Prefer", "count=exact"), ("Prefer", "missing=null"), ("Prefer", "handling=lenient"), ("Prefer", "invalid")]
 -- Preferences
 --     { preferResolution = Just IgnoreDuplicates
 --     , preferRepresentation = Nothing
 --     , preferParameters = Nothing
 --     , preferCount = Just ExactCount
 --     , preferTransaction = Nothing
+--     , preferMissing = Just ApplyNulls
+--     , preferHandling = Just Lenient
+--     , preferTimezone = Nothing
+--     , invalidPrefs = [ "invalid" ]
 --     }
 --
 -- If a preference is set more than once, only the first is used:
 --
--- >>> preferTransaction $ fromHeaders [("Prefer", "tx=commit, tx=rollback")]
+-- >>> preferTransaction $ fromHeaders True sc [("Prefer", "tx=commit, tx=rollback")]
 -- Just Commit
 --
 -- This is also the case across multiple headers:
 --
 -- >>> :{
---   preferResolution . fromHeaders $
+--   preferResolution . fromHeaders True sc $
 --     [ ("Prefer", "resolution=ignore-duplicates")
 --     , ("Prefer", "resolution=merge-duplicates")
 --     ]
 -- :}
 -- Just IgnoreDuplicates
 --
--- Preferences not recognized by the application are ignored:
---
--- >>> preferResolution $ fromHeaders [("Prefer", "resolution=foo")]
--- Nothing
 --
 -- Preferences can be separated by arbitrary amounts of space, lower-case header is also recognized:
 --
--- >>> pPrint $ fromHeaders [("prefer", "count=exact,    tx=commit   ,return=minimal")]
+-- >>> pPrint $ fromHeaders True sc [("prefer", "count=exact,    tx=commit   ,return=representation , missing=default, handling=strict, anything")]
 -- Preferences
 --     { preferResolution = Nothing
---     , preferRepresentation = Just None
+--     , preferRepresentation = Just Full
 --     , preferParameters = Nothing
 --     , preferCount = Just ExactCount
 --     , preferTransaction = Just Commit
+--     , preferMissing = Just ApplyDefaults
+--     , preferHandling = Just Strict
+--     , preferTimezone = Nothing
+--     , invalidPrefs = [ "anything" ]
 --     }
 --
-fromHeaders :: [HTTP.Header] -> Preferences
-fromHeaders headers =
+fromHeaders :: Bool -> TimezoneNames -> [HTTP.Header] -> Preferences
+fromHeaders allowTxDbOverride acceptedTzNames headers =
   Preferences
-    { preferResolution = parsePrefs [MergeDuplicates, IgnoreDuplicates]
+    { preferResolution     = parsePrefs [MergeDuplicates, IgnoreDuplicates]
     , preferRepresentation = parsePrefs [Full, None, HeadersOnly]
-    , preferParameters = parsePrefs [SingleObject, MultipleObjects]
-    , preferCount = parsePrefs [ExactCount, PlannedCount, EstimatedCount]
-    , preferTransaction = parsePrefs [Commit, Rollback]
+    , preferParameters     = parsePrefs [SingleObject]
+    , preferCount          = parsePrefs [ExactCount, PlannedCount, EstimatedCount]
+    , preferTransaction    = if allowTxDbOverride then parsePrefs [Commit, Rollback] else Nothing
+    , preferMissing        = parsePrefs [ApplyDefaults, ApplyNulls]
+    , preferHandling       = parsePrefs [Strict, Lenient]
+    , preferTimezone       = if isTimezonePrefAccepted then PreferTimezone <$> timezonePref else Nothing
+    , invalidPrefs         = filter checkPrefs prefs
     }
   where
+    mapToHeadVal :: ToHeaderValue a => [a] -> [ByteString]
+    mapToHeadVal = map toHeaderValue
+    acceptedPrefs = mapToHeadVal [MergeDuplicates, IgnoreDuplicates] ++
+                    mapToHeadVal [Full, None, HeadersOnly] ++
+                    mapToHeadVal [SingleObject] ++
+                    mapToHeadVal [ExactCount, PlannedCount, EstimatedCount] ++
+                    mapToHeadVal [Commit, Rollback] ++
+                    mapToHeadVal [ApplyDefaults, ApplyNulls] ++
+                    mapToHeadVal [Strict, Lenient]
+
     prefHeaders = filter ((==) HTTP.hPrefer . fst) headers
     prefs = fmap BS.strip . concatMap (BS.split ',' . snd) $ prefHeaders
 
+    timezonePref = listToMaybe $ mapMaybe (BS.stripPrefix "timezone=") prefs
+    isTimezonePrefAccepted = (S.member <$> timezonePref <*> pure acceptedTzNames) == Just True
+
+    checkPrefs p = p `notElem` acceptedPrefs && not isTimezonePrefAccepted
+
     parsePrefs :: ToHeaderValue a => [a] -> Maybe a
     parsePrefs vals =
       head $ mapMaybe (flip Map.lookup $ prefMap vals) prefs
@@ -120,6 +163,24 @@ fromHeaders headers =
     prefMap :: ToHeaderValue a => [a] -> Map.Map ByteString a
     prefMap = Map.fromList . fmap (\pref -> (toHeaderValue pref, pref))
 
+prefAppliedHeader :: Preferences -> Maybe HTTP.Header
+prefAppliedHeader Preferences {preferResolution, preferRepresentation, preferParameters, preferCount, preferTransaction, preferMissing, preferHandling, preferTimezone } =
+  if null prefsVals
+    then Nothing
+    else Just (HTTP.hPreferenceApplied, combined)
+  where
+    combined = BS.intercalate ", " prefsVals
+    prefsVals = catMaybes [
+        toHeaderValue <$> preferResolution
+      , toHeaderValue <$> preferMissing
+      , toHeaderValue <$> preferRepresentation
+      , toHeaderValue <$> preferParameters
+      , toHeaderValue <$> preferCount
+      , toHeaderValue <$> preferTransaction
+      , toHeaderValue <$> preferHandling
+      , toHeaderValue <$> preferTimezone
+      ]
+
 -- |
 -- Convert a preference into the value that we look for in the 'Prefer' headers.
 --
@@ -129,33 +190,22 @@ fromHeaders headers =
 class ToHeaderValue a where
   toHeaderValue :: a -> ByteString
 
--- |
--- Header to indicate that a preference has been applied.
---
--- >>> toAppliedHeader MergeDuplicates
--- ("Preference-Applied","resolution=merge-duplicates")
---
-class ToHeaderValue a => ToAppliedHeader a where
-  toAppliedHeader :: a -> HTTP.Header
-  toAppliedHeader x = (HTTP.hPreferenceApplied, toHeaderValue x)
-
 -- | How to handle duplicate values.
 data PreferResolution
   = MergeDuplicates
   | IgnoreDuplicates
+  deriving Eq
 
 instance ToHeaderValue PreferResolution where
   toHeaderValue MergeDuplicates  = "resolution=merge-duplicates"
   toHeaderValue IgnoreDuplicates = "resolution=ignore-duplicates"
 
-instance ToAppliedHeader PreferResolution
-
 -- |
 -- How to return the mutated data.
 --
 -- From https://tools.ietf.org/html/rfc7240#section-4.2
 data PreferRepresentation
-  = Full        -- ^ Return the body plus the Location header(in case of POST).
+  = Full        -- ^ Return the body.
   | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
   | None        -- ^ Return nothing from the mutated data.
   deriving Eq
@@ -168,12 +218,10 @@ instance ToHeaderValue PreferRepresentation where
 -- | How to pass parameters to stored procedures.
 data PreferParameters
   = SingleObject    -- ^ Pass all parameters as a single json object to a stored procedure.
-  | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure.
   deriving Eq
 
 instance ToHeaderValue PreferParameters where
   toHeaderValue SingleObject    = "params=single-object"
-  toHeaderValue MultipleObjects = "params=multiple-objects"
 
 -- | How to determine the count of (expected) results
 data PreferCount
@@ -187,6 +235,10 @@ instance ToHeaderValue PreferCount where
   toHeaderValue PlannedCount   = "count=planned"
   toHeaderValue EstimatedCount = "count=estimated"
 
+shouldCount :: Maybe PreferCount -> Bool
+shouldCount prefCount =
+  prefCount == Just ExactCount || prefCount == Just EstimatedCount
+
 -- | Whether to commit or roll back transactions.
 data PreferTransaction
   = Commit   -- ^ Commit transaction - the default.
@@ -197,4 +249,32 @@ instance ToHeaderValue PreferTransaction where
   toHeaderValue Commit   = "tx=commit"
   toHeaderValue Rollback = "tx=rollback"
 
-instance ToAppliedHeader PreferTransaction
+-- |
+-- How to handle the insertion/update when the keys specified in ?columns are not present
+-- in the json body.
+data PreferMissing
+  = ApplyDefaults  -- ^ Use the default column value for missing values.
+  | ApplyNulls     -- ^ Use the null value for missing values.
+  deriving Eq
+
+instance ToHeaderValue PreferMissing where
+  toHeaderValue ApplyDefaults = "missing=default"
+  toHeaderValue ApplyNulls    = "missing=null"
+
+-- |
+-- Handling of unrecognised preferences
+data PreferHandling
+  = Strict  -- ^ Throw error on unrecognised preferences
+  | Lenient -- ^ Ignore unrecognised preferences
+  deriving Eq
+
+instance ToHeaderValue PreferHandling where
+  toHeaderValue Strict  = "handling=strict"
+  toHeaderValue Lenient = "handling=lenient"
+
+-- |
+-- Change timezone
+newtype PreferTimezone = PreferTimezone ByteString
+
+instance ToHeaderValue PreferTimezone where
+  toHeaderValue (PreferTimezone tz) = "timezone=" <> tz

src/PostgREST/ApiRequest/QueryParams.hs

@@ -0,0 +1,862 @@
+-- |
+-- Module      : PostgREST.ApiRequest.QueryParams
+-- Description : Parser for PostgREST Query parameters
+--
+-- This module is in charge of parsing all the querystring values in an url, e.g.
+-- the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.
+{-# LANGUAGE LambdaCase    #-}
+{-# LANGUAGE TupleSections #-}
+module PostgREST.ApiRequest.QueryParams
+  ( parse
+  , QueryParams(..)
+  , pRequestRange
+  ) where
+
+import qualified Data.ByteString.Char8         as BS
+import qualified Data.HashMap.Strict           as HM
+import qualified Data.List                     as L
+import qualified Data.Set                      as S
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as T
+import qualified Network.HTTP.Base             as HTTP
+import qualified Network.HTTP.Types.URI        as HTTP
+import qualified Text.ParserCombinators.Parsec as P
+
+import Control.Arrow                 ((***))
+import Data.Either.Combinators       (mapLeft)
+import Data.List                     (init, last)
+import Data.Ranged.Boundaries        (Boundary (..))
+import Data.Ranged.Ranges            (Range (..))
+import Data.Tree                     (Tree (..))
+import Text.Parsec.Error             (errorMessages,
+                                      showErrorMessages)
+import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,
+                                      anyChar, between, char, choice,
+                                      digit, eof, errorPos, letter,
+                                      lookAhead, many1, noneOf,
+                                      notFollowedBy, oneOf,
+                                      optionMaybe, sepBy, sepBy1,
+                                      string, try, (<?>))
+
+import PostgREST.RangeQuery              (NonnegRange, allRange,
+                                          rangeGeq, rangeLimit,
+                                          rangeOffset, restrictRange)
+import PostgREST.SchemaCache.Identifiers (FieldName)
+
+import PostgREST.ApiRequest.Types (AggregateFunction (..),
+                                   EmbedParam (..), EmbedPath, Field,
+                                   Filter (..), FtsOperator (..),
+                                   Hint, JoinType (..),
+                                   JsonOperand (..),
+                                   JsonOperation (..), JsonPath,
+                                   ListVal, LogicOperator (..),
+                                   LogicTree (..), OpExpr (..),
+                                   OpQuantifier (..), Operation (..),
+                                   OrderDirection (..),
+                                   OrderNulls (..), OrderTerm (..),
+                                   QPError (..), QuantOperator (..),
+                                   SelectItem (..),
+                                   SimpleOperator (..), SingleVal,
+                                   TrileanVal (..))
+
+import Protolude hiding (Sum, try)
+
+data QueryParams =
+  QueryParams
+    { qsCanonical      :: ByteString
+    -- ^ Canonical representation of the query params, sorted alphabetically
+    , qsParams         :: [(Text, Text)]
+    -- ^ Parameters for RPC calls
+    , qsRanges         :: HM.HashMap Text (Range Integer)
+    -- ^ Ranges derived from &limit and &offset params
+    , qsOrder          :: [(EmbedPath, [OrderTerm])]
+    -- ^ &order parameters for each level
+    , qsLogic          :: [(EmbedPath, LogicTree)]
+    -- ^ &and and &or parameters used for complex boolean logic
+    , qsColumns        :: Maybe (S.Set FieldName)
+    -- ^ &columns parameter and payload
+    , qsSelect         :: [Tree SelectItem]
+    -- ^ &select parameter used to shape the response
+    , qsFilters        :: [(EmbedPath, Filter)]
+    -- ^ Filters on the result from e.g. &id=e.10
+    , qsFiltersRoot    :: [Filter]
+    -- ^ Subset of the filters that apply on the root table. These are used on UPDATE/DELETE.
+    , qsFiltersNotRoot :: [(EmbedPath, Filter)]
+    -- ^ Subset of the filters that do not apply on the root table
+    , qsFilterFields   :: S.Set FieldName
+    -- ^ Set of fields that filters apply to
+    , qsOnConflict     :: Maybe [FieldName]
+    -- ^ &on_conflict parameter used to upsert on specific unique keys
+    }
+
+-- |
+-- Parse query parameters from a query string like "id=eq.1&select=name".
+--
+-- The canonical representation of the query string has parameters sorted alphabetically:
+--
+-- >>> qsCanonical <$> parse True "a=1&c=3&b=2&d"
+-- Right "a=1&b=2&c=3&d="
+--
+-- 'select' is a reserved parameter that selects the fields to be returned:
+--
+-- >>> qsSelect <$> parse False "select=name,location"
+-- Right [Node {rootLabel = SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectField {selField = ("location",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]
+--
+-- Filters are parameters whose value contains an operator, separated by a '.' from its value:
+--
+-- >>> qsFilters <$> parse False "a.b=eq.0"
+-- Right [(["a"],Filter {field = ("b",[]), opExpr = OpExpr False (OpQuant OpEqual Nothing "0")})]
+--
+-- If the operator specified in a filter does not exist, parsing the query string fails:
+--
+-- >>> qsFilters <$> parse False "a.b=noop.0"
+-- Left (QPError "\"failed to parse filter (noop.0)\" (line 1, column 1)" "unexpected \"o\" expecting \"not\" or operator (eq, gt, ...)")
+parse :: Bool -> ByteString -> Either QPError QueryParams
+parse isRpcGet qs = do
+  rOrd                      <- pRequestOrder `traverse` order
+  rLogic                    <- pRequestLogicTree `traverse` logic
+  rCols                     <- pRequestColumns columns
+  rSel                      <- pRequestSelect select
+  (rFlts, params)           <- L.partition hasOp <$> pRequestFilter isRpcGet `traverse` filters
+  (rFltsRoot, rFltsNotRoot) <- pure $ L.partition hasRootFilter rFlts
+  rOnConflict               <- pRequestOnConflict `traverse` onConflict
+
+  let rFltsFields           = S.fromList (fst <$> filters)
+      params'               = mapMaybe (\case {(_, Filter (fld, _) (NoOpExpr v)) -> Just (fld,v); _ -> Nothing}) params
+      rFltsRoot'            = snd <$> rFltsRoot
+
+  return $ QueryParams canonical params' ranges rOrd rLogic rCols rSel rFlts rFltsRoot' rFltsNotRoot rFltsFields rOnConflict
+  where
+    hasRootFilter, hasOp :: (EmbedPath, Filter) -> Bool
+    hasRootFilter ([], _) = True
+    hasRootFilter _       = False
+    hasOp (_, Filter (_, _) (NoOpExpr _)) = False
+    hasOp _                               = True
+
+    logic = filter (endingIn ["and", "or"] . fst) nonemptyParams
+    select = fromMaybe "*" $ lookupParam "select"
+    onConflict = lookupParam "on_conflict"
+    columns = lookupParam "columns"
+    order = filter (endingIn ["order"] . fst) nonemptyParams
+    limits = filter (endingIn ["limit"] . fst) nonemptyParams
+    -- Replace .offset ending with .limit to be able to match those params later in a map
+    offsets = first (replaceLast "limit") <$> filter (endingIn ["offset"] . fst) nonemptyParams
+    lookupParam :: Text -> Maybe Text
+    lookupParam needle = toS <$> join (L.lookup needle qParams)
+    nonemptyParams = mapMaybe (\(k, v) -> (k,) <$> v) qParams
+
+    qString = HTTP.parseQueryReplacePlus True qs
+
+    qParams = [(T.decodeUtf8 k, T.decodeUtf8 <$> v)|(k,v) <- qString]
+
+    canonical =
+      BS.pack $ HTTP.urlEncodeVars
+        . L.sortOn fst
+        . map (join (***) BS.unpack . second (fromMaybe mempty))
+        $ qString
+
+    endingIn:: [Text] -> Text -> Bool
+    endingIn xx key = lastWord `elem` xx
+      where lastWord = L.last $ T.split (== '.') key
+
+    filters = filter (isFilter . fst) nonemptyParams
+    isFilter k = not (endingIn reservedEmbeddable k) && notElem k reserved
+    reserved = ["select", "columns", "on_conflict"]
+    reservedEmbeddable = ["order", "limit", "offset", "and", "or"]
+
+    replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) <> [x]
+
+    ranges :: HM.HashMap Text (Range Integer)
+    ranges = HM.unionWith f limitParams offsetParams
+      where
+        f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)
+          where
+            l = fromMaybe 0 $ rangeLimit rl
+            o = rangeOffset ro
+
+        limitParams =
+          HM.fromList [(k, restrictRange (readMaybe v) allRange) | (k,v) <- limits]
+
+        offsetParams =
+          HM.fromList [(k, maybe allRange rangeGeq (readMaybe v)) | (k,v) <- offsets]
+
+simpleOperator :: Parser SimpleOperator
+simpleOperator =
+  try (string "neq" $> OpNotEqual) <|>
+  try (string "cs" $> OpContains) <|>
+  try (string "cd" $> OpContained) <|>
+  try (string "ov" $> OpOverlap) <|>
+  try (string "sl" $> OpStrictlyLeft) <|>
+  try (string "sr" $> OpStrictlyRight) <|>
+  try (string "nxr" $> OpNotExtendsRight) <|>
+  try (string "nxl" $> OpNotExtendsLeft) <|>
+  try (string "adj" $> OpAdjacent) <?>
+  "unknown single value operator"
+
+quantOperator :: Parser QuantOperator
+quantOperator =
+  try (string "eq" $> OpEqual) <|>
+  try (string "gte" $> OpGreaterThanEqual) <|>
+  try (string "gt" $> OpGreaterThan) <|>
+  try (string "lte" $> OpLessThanEqual) <|>
+  try (string "lt" $> OpLessThan) <|>
+  try (string "like" $> OpLike) <|>
+  try (string "ilike" $> OpILike) <|>
+  try (string "match" $> OpMatch) <|>
+  try (string "imatch" $> OpIMatch) <?>
+  "unknown single value operator"
+
+pRequestSelect :: Text -> Either QPError [Tree SelectItem]
+pRequestSelect selStr =
+  mapError $ P.parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
+
+pRequestOnConflict :: Text -> Either QPError [FieldName]
+pRequestOnConflict oncStr =
+  mapError $ P.parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr)
+
+-- |
+-- Parse `id=eq.1`(id, eq.1) into (EmbedPath, Filter)
+--
+-- >>> pRequestFilter False ("id", "eq.1")
+-- Right ([],Filter {field = ("id",[]), opExpr = OpExpr False (OpQuant OpEqual Nothing "1")})
+--
+-- >>> pRequestFilter False ("id", "val")
+-- Left (QPError "\"failed to parse filter (val)\" (line 1, column 1)" "unexpected \"v\" expecting \"not\" or operator (eq, gt, ...)")
+--
+-- >>> pRequestFilter True ("id", "val")
+-- Right ([],Filter {field = ("id",[]), opExpr = NoOpExpr "val"})
+pRequestFilter :: Bool -> (Text, Text) -> Either QPError (EmbedPath, Filter)
+pRequestFilter isRpcGet (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
+  where
+    treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
+    oper = P.parse parseFlt ("failed to parse filter (" ++ toS v ++ ")") $ toS v
+    parseFlt = if isRpcGet
+      then pOpExpr pSingleVal <|> pure (NoOpExpr v)
+      else pOpExpr pSingleVal
+    path = fst <$> treePath
+    fld = snd <$> treePath
+
+pRequestOrder :: (Text, Text) -> Either QPError (EmbedPath, [OrderTerm])
+pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
+  where
+    treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
+    path = fst <$> treePath
+    ord' = P.parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
+
+pRequestRange :: (Text, NonnegRange) -> Either QPError (EmbedPath, NonnegRange)
+pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
+  where
+    treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
+    path = fst <$> treePath
+
+pRequestLogicTree :: (Text, Text) -> Either QPError (EmbedPath, LogicTree)
+pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
+  where
+    path = P.parse pLogicPath ("failed to parse logic path (" ++ toS k ++ ")") $ toS k
+    embedPath = fst <$> path
+    logicTree = do
+      op <- snd <$> path
+      -- Concat op and v to make pLogicTree argument regular,
+      -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
+      P.parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v)
+
+pRequestColumns :: Maybe Text -> Either QPError (Maybe (S.Set FieldName))
+pRequestColumns colStr =
+  case colStr of
+    Just str ->
+      mapError $ Just . S.fromList <$> P.parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)
+    _ -> Right Nothing
+
+ws :: Parser Text
+ws = toS <$> many (oneOf " \t")
+
+lexeme :: Parser a -> Parser a
+lexeme p = ws *> p <* ws
+
+pTreePath :: Parser (EmbedPath, Field)
+pTreePath = do
+  p <- pFieldName `sepBy1` pDelimiter
+  jp <- P.option [] pJsonPath
+  return (init p, (last p, jp))
+
+-- |
+-- Parse select= into a Forest of SelectItems
+--
+-- >>> P.parse pFieldForest "" "id"
+-- Right [Node {rootLabel = SelectField {selField = ("id",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]
+--
+-- >>> P.parse pFieldForest "" "client(id)"
+-- Right [Node {rootLabel = SelectRelation {selRelation = "client", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("id",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]
+--
+-- >>> P.parse pFieldForest "" "*,client(*,nested(*))"
+-- Right [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectRelation {selRelation = "client", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectRelation {selRelation = "nested", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]}]
+--
+-- >>> P.parse pFieldForest "" "*,...client(*),other(*)"
+-- Right [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SpreadRelation {selRelation = "client", selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]},Node {rootLabel = SelectRelation {selRelation = "other", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]
+--
+-- >>> P.parse pFieldForest "" ""
+-- Right []
+--
+-- >>> P.parse pFieldForest "" "id,clients(name[])"
+-- Left (line 1, column 16):
+-- unexpected '['
+-- expecting letter, digit, "-", "->>", "->", "::", ".", ")", "," or end of input
+--
+-- >>> P.parse pFieldForest "" "data->>-78xy"
+-- Left (line 1, column 11):
+-- unexpected 'x'
+-- expecting digit, "->", "::", ".", "," or end of input
+pFieldForest :: Parser [Tree SelectItem]
+pFieldForest = pFieldTree `sepBy` lexeme (char ',')
+  where
+    pFieldTree =  Node <$> try pSpreadRelationSelect <*> between (char '(') (char ')') pFieldForest <|>
+                  Node <$> try pRelationSelect       <*> between (char '(') (char ')') pFieldForest <|>
+                  Node <$> pFieldSelect <*> pure []
+
+-- |
+-- Parse field names
+--
+-- >>> P.parse pFieldName "" "identifier"
+-- Right "identifier"
+--
+-- >>> P.parse pFieldName "" "identifier with spaces"
+-- Right "identifier with spaces"
+--
+-- >>> P.parse pFieldName "" "identifier-with-dashes"
+-- Right "identifier-with-dashes"
+--
+-- >>> P.parse pFieldName "" "123"
+-- Right "123"
+--
+-- >>> P.parse pFieldName "" "_"
+-- Right "_"
+--
+-- >>> P.parse pFieldName "" "$"
+-- Right "$"
+--
+-- >>> P.parse pFieldName "" ":"
+-- Left (line 1, column 1):
+-- unexpected ":"
+-- expecting field name (* or [a..z0..9_$])
+--
+-- >>> P.parse pFieldName "" "\":\""
+-- Right ":"
+--
+-- >>> P.parse pFieldName "" " no leading or trailing spaces "
+-- Right "no leading or trailing spaces"
+--
+-- >>> P.parse pFieldName "" "\" leading and trailing spaces \""
+-- Right " leading and trailing spaces "
+pFieldName :: Parser Text
+pFieldName =
+  pQuotedValue <|>
+  sepByDash pIdentifier <?>
+  "field name (* or [a..z0..9_$])"
+
+sepByDash :: Parser Text -> Parser Text
+sepByDash fieldIdent =
+  T.intercalate "-" . map toS <$> (fieldIdent `sepBy1` dash)
+  where
+    isDash :: GenParser Char st ()
+    isDash = try ( char '-' >> notFollowedBy (char '>') )
+    dash :: Parser Char
+    dash = isDash $> '-'
+
+-- |
+-- Parse json operators in select, order and filters
+--
+-- >>> P.parse pJsonPath "" "->text"
+-- Right [JArrow {jOp = JKey {jVal = "text"}}]
+--
+-- >>> P.parse pJsonPath "" "->!@#$%^&*_a"
+-- Right [JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]
+--
+-- >>> P.parse pJsonPath "" "->1"
+-- Right [JArrow {jOp = JIdx {jVal = "+1"}}]
+--
+-- >>> P.parse pJsonPath "" "->>text"
+-- Right [J2Arrow {jOp = JKey {jVal = "text"}}]
+--
+-- >>> P.parse pJsonPath "" "->>!@#$%^&*_a"
+-- Right [J2Arrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]
+--
+-- >>> P.parse pJsonPath "" "->>1"
+-- Right [J2Arrow {jOp = JIdx {jVal = "+1"}}]
+--
+-- >>> P.parse pJsonPath "" "->0,other"
+-- Right [JArrow {jOp = JIdx {jVal = "+0"}}]
+--
+-- >>> P.parse pJsonPath "" "->0.desc"
+-- Right [JArrow {jOp = JIdx {jVal = "+0"}}]
+--
+-- Fails on badly formed negatives
+--
+-- >>> P.parse pJsonPath "" "->>-78xy"
+-- Left (line 1, column 7):
+-- unexpected 'x'
+-- expecting digit, "->", "::", ".", "," or end of input
+--
+-- >>> P.parse pJsonPath "" "->>--34"
+-- Left (line 1, column 5):
+-- unexpected "-"
+-- expecting digit
+--
+-- >>> P.parse pJsonPath "" "->>-xy-4"
+-- Left (line 1, column 5):
+-- unexpected "x"
+-- expecting digit
+pJsonPath :: Parser JsonPath
+pJsonPath = many pJsonOperation
+  where
+    pJsonOperation :: Parser JsonOperation
+    pJsonOperation = pJsonArrow <*> pJsonOperand
+
+    pJsonArrow   =
+      try (string "->>" $> J2Arrow) <|>
+      try (string "->" $> JArrow)
+
+    pJsonOperand =
+      let pJKey = JKey . toS <$> pJsonKeyName
+          pJIdx = JIdx . toS <$> ((:) <$> P.option '+' (char '-') <*> many1 digit) <* pEnd
+          pEnd = try (void $ lookAhead (string "->")) <|>
+                 try (void $ lookAhead (string "::")) <|>
+                 try (void $ lookAhead (string ".")) <|>
+                 try (void $ lookAhead (string ",")) <|>
+                 try eof in
+      try pJIdx <|> try pJKey
+
+pJsonKeyName :: Parser Text
+pJsonKeyName =
+  pQuotedValue <|>
+  sepByDash pJsonKeyIdentifier <?>
+  "any non reserved character different from: .,>()"
+
+pJsonKeyIdentifier :: Parser Text
+pJsonKeyIdentifier = T.strip . toS <$> many1 (noneOf "(-:.,>)")
+
+pField :: Parser Field
+pField = lexeme $ (,) <$> pFieldName <*> P.option [] pJsonPath
+
+aliasSeparator :: Parser ()
+aliasSeparator = char ':' >> notFollowedBy (char ':')
+
+-- |
+-- Parse regular fields in select
+--
+-- >>> P.parse pRelationSelect "" "rel(*)"
+-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing})
+--
+-- >>> P.parse pRelationSelect "" "alias:rel(*)"
+-- Right (SelectRelation {selRelation = "rel", selAlias = Just "alias", selHint = Nothing, selJoinType = Nothing})
+--
+-- >>> P.parse pRelationSelect "" "rel!hint(*)"
+-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Just "hint", selJoinType = Nothing})
+--
+-- >>> P.parse pRelationSelect "" "rel!inner(*)"
+-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Nothing, selJoinType = Just JTInner})
+--
+-- >>> P.parse pRelationSelect "" "rel!hint!inner(*)"
+-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Just "hint", selJoinType = Just JTInner})
+--
+-- >>> P.parse pRelationSelect "" "alias:rel!inner!hint(*)"
+-- Right (SelectRelation {selRelation = "rel", selAlias = Just "alias", selHint = Just "hint", selJoinType = Just JTInner})
+--
+-- >>> P.parse pRelationSelect "" "rel->jsonpath(*)"
+-- Left (line 1, column 6):
+-- unexpected '>'
+--
+-- >>> P.parse pRelationSelect "" "rel->jsonpath!hint(*)"
+-- Left (line 1, column 6):
+-- unexpected '>'
+pRelationSelect :: Parser SelectItem
+pRelationSelect = lexeme $ do
+    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
+    name <- pFieldName
+    guard (name /= "count")
+    (hint, jType) <- pEmbedParams
+    try (void $ lookAhead (string "("))
+    return $ SelectRelation name alias hint jType
+
+
+-- |
+-- Parse regular fields in select
+--
+-- >>> P.parse pFieldSelect "" "name"
+-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
+--
+-- >>> P.parse pFieldSelect "" "name->jsonpath"
+-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "jsonpath"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
+--
+-- >>> P.parse pFieldSelect "" "name::cast"
+-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Nothing})
+--
+-- >>> P.parse pFieldSelect "" "alias:name"
+-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Just "alias"})
+--
+-- >>> P.parse pFieldSelect "" "alias:name->jsonpath::cast"
+-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "jsonpath"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Just "alias"})
+--
+-- >>> P.parse pFieldSelect "" "alias:name->!@#$%^&*_a::cast"
+-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Just "alias"})
+--
+-- >>> P.parse pFieldSelect "" "*"
+-- Right (SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
+--
+-- >>> P.parse pFieldSelect "" "name!hint"
+-- Left (line 1, column 5):
+-- unexpected '!'
+-- expecting letter, digit, "-", "->>", "->", "::", ".", ")", "," or end of input
+--
+-- >>> P.parse pFieldSelect "" "*!hint"
+-- Left (line 1, column 2):
+-- unexpected '!'
+-- expecting ")", "," or end of input
+--
+-- >>> P.parse pFieldSelect "" "name::"
+-- Left (line 1, column 7):
+-- unexpected end of input
+-- expecting letter or digit
+pFieldSelect :: Parser SelectItem
+pFieldSelect = lexeme $ try (do
+    s <- pStar
+    pEnd
+    return $ SelectField (s, []) Nothing Nothing Nothing Nothing)
+  <|> try (do
+    alias    <- optionMaybe ( try(pFieldName <* aliasSeparator) )
+    _        <- string "count()"
+    aggCast' <- optionMaybe (string "::" *> pIdentifier)
+    pEnd
+    return $ SelectField ("*", []) (Just Count) (toS <$> aggCast') Nothing alias)
+  <|> do
+    alias    <- optionMaybe ( try(pFieldName <* aliasSeparator) )
+    fld      <- pField
+    cast'    <- optionMaybe (string "::" *> pIdentifier)
+    agg      <- optionMaybe (try (char '.' *> pAggregation <* string "()"))
+    aggCast' <- optionMaybe (string "::" *> pIdentifier)
+    pEnd
+    return $ SelectField fld agg (toS <$> aggCast') (toS <$> cast') alias
+  where
+    pEnd = try (void $ lookAhead (string ")")) <|>
+           try (void $ lookAhead (string ",")) <|>
+           try eof
+    pStar = string "*" $> "*"
+    pAggregation = choice
+      [ string "sum"   $> Sum
+      , string "avg"   $> Avg
+      , string "count" $> Count
+      -- Using 'try' for "min" and "max" to allow backtracking.
+      -- This is necessary because both start with the same character 'm',
+      -- and without 'try', a partial match on "max" would prevent "min" from being tried.
+      , try (string "max") $> Max
+      , try (string "min") $> Min
+      ]
+
+
+-- |
+-- Parse spread relations in select
+--
+-- >>> P.parse pSpreadRelationSelect "" "...rel(*)"
+-- Right (SpreadRelation {selRelation = "rel", selHint = Nothing, selJoinType = Nothing})
+--
+-- >>> P.parse pSpreadRelationSelect "" "...rel!hint!inner(*)"
+-- Right (SpreadRelation {selRelation = "rel", selHint = Just "hint", selJoinType = Just JTInner})
+--
+-- >>> P.parse pSpreadRelationSelect "" "rel(*)"
+-- Left (line 1, column 1):
+-- unexpected "r"
+-- expecting "..."
+--
+-- >>> P.parse pSpreadRelationSelect "" "alias:...rel(*)"
+-- Left (line 1, column 1):
+-- unexpected "a"
+-- expecting "..."
+--
+-- >>> P.parse pSpreadRelationSelect "" "...rel->jsonpath(*)"
+-- Left (line 1, column 9):
+-- unexpected '>'
+pSpreadRelationSelect :: Parser SelectItem
+pSpreadRelationSelect = lexeme $ do
+    name <- string "..." >> pFieldName
+    (hint, jType) <- pEmbedParams
+    try (void $ lookAhead (string "("))
+    return $ SpreadRelation name hint jType
+
+pEmbedParams :: Parser (Maybe Hint, Maybe JoinType)
+pEmbedParams = do
+  prm1 <- optionMaybe pEmbedParam
+  prm2 <- optionMaybe pEmbedParam
+  return (embedParamHint prm1 <|> embedParamHint prm2, embedParamJoin prm1 <|> embedParamJoin prm2)
+  where
+    pEmbedParam :: Parser EmbedParam
+    pEmbedParam =
+      char '!' *> (
+        try (string "left"  $> EPJoinType JTLeft)  <|>
+        try (string "inner" $> EPJoinType JTInner) <|>
+        try (EPHint <$> pFieldName))
+    embedParamHint prm = case prm of
+      Just (EPHint hint) -> Just hint
+      _                  -> Nothing
+    embedParamJoin prm = case prm of
+      Just (EPJoinType jt) -> Just jt
+      _                    -> Nothing
+
+-- |
+-- Parse operator expression used in horizontal filtering
+--
+-- >>> P.parse (pOpExpr pSingleVal) "" "fts().value"
+-- Left (line 1, column 5):
+-- unexpected ")"
+-- expecting operator (eq, gt, ...)
+--
+-- >>> P.parse (pOpExpr pSingleVal) "" "eq(any).value"
+-- Right (OpExpr False (OpQuant OpEqual (Just QuantAny) "value"))
+--
+-- >>> P.parse (pOpExpr pSingleVal) "" "eq(all).value"
+-- Right (OpExpr False (OpQuant OpEqual (Just QuantAll) "value"))
+--
+-- >>> P.parse (pOpExpr pSingleVal) "" "not.eq(all).value"
+-- Right (OpExpr True (OpQuant OpEqual (Just QuantAll) "value"))
+--
+-- >>> P.parse (pOpExpr pSingleVal) "" "eq().value"
+-- Left (line 1, column 4):
+-- unexpected ")"
+-- expecting operator (eq, gt, ...)
+--
+-- >>> P.parse (pOpExpr pSingleVal) "" "is().value"
+-- Left (line 1, column 3):
+-- unexpected "("
+-- expecting operator (eq, gt, ...)
+--
+-- >>> P.parse (pOpExpr pSingleVal) "" "in().value"
+-- Left (line 1, column 3):
+-- unexpected "("
+-- expecting operator (eq, gt, ...)
+pOpExpr :: Parser SingleVal -> Parser OpExpr
+pOpExpr pSVal = do
+  boolExpr <- try (string "not" *> pDelimiter $> True) <|> pure False
+  OpExpr boolExpr <$> pOperation
+  where
+    pOperation :: Parser Operation
+    pOperation = pIn <|> pIs <|> pIsDist <|> try pFts <|> try pSimpleOp <|> try pQuantOp <?> "operator (eq, gt, ...)"
+
+    pIn = In <$> (try (string "in" *> pDelimiter) *> pListVal)
+    pIs = Is <$> (try (string "is" *> pDelimiter) *> pTriVal)
+
+    pIsDist = IsDistinctFrom <$> (try (string "isdistinct" *> pDelimiter) *> pSVal)
+
+    pSimpleOp = do
+      op <- simpleOperator
+      pDelimiter *> (Op op <$> pSVal)
+
+    pQuantOp = do
+      op <- quantOperator
+      quant <- optionMaybe $ try (between (char '(') (char ')') (try (string "any" $> QuantAny) <|> string "all" $> QuantAll))
+      pDelimiter *> (OpQuant op quant <$> pSVal)
+
+    pTriVal = try (ciString "null"    $> TriNull)
+          <|> try (ciString "unknown" $> TriUnknown)
+          <|> try (ciString "true"    $> TriTrue)
+          <|> try (ciString "false"   $> TriFalse)
+          <?> "null or trilean value (unknown, true, false)"
+
+    pFts = do
+      op <-  try (string "fts"   $> FilterFts)
+         <|> try (string "plfts" $> FilterFtsPlain)
+         <|> try (string "phfts" $> FilterFtsPhrase)
+         <|> try (string "wfts"  $> FilterFtsWebsearch)
+
+      lang <- optionMaybe $ try (between (char '(') (char ')') pIdentifier)
+      pDelimiter >> Fts op (toS <$> lang) <$> pSVal
+
+    -- case insensitive char and string
+    ciChar :: Char -> GenParser Char state Char
+    ciChar c = char c <|> char (toUpper c)
+    ciString :: [Char] -> GenParser Char state [Char]
+    ciString = traverse ciChar
+
+pSingleVal :: Parser SingleVal
+pSingleVal = toS <$> many anyChar
+
+pListVal :: Parser ListVal
+pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')
+
+pListElement :: Parser Text
+pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)"))
+
+pQuotedValue :: Parser Text
+pQuotedValue = toS <$> (char '"' *> many pCharsOrSlashed <* char '"')
+  where
+    pCharsOrSlashed = noneOf "\\\"" <|> (char '\\' *> anyChar)
+
+pDelimiter :: Parser Char
+pDelimiter = char '.' <?> "delimiter (.)"
+
+-- |
+-- Parses the elements in the order query parameter
+--
+-- >>> P.parse pOrder "" "name.desc.nullsfirst"
+-- Right [OrderTerm {otTerm = ("name",[]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
+--
+-- >>> P.parse pOrder "" "json_col->key.asc.nullslast"
+-- Right [OrderTerm {otTerm = ("json_col",[JArrow {jOp = JKey {jVal = "key"}}]), otDirection = Just OrderAsc, otNullOrder = Just OrderNullsLast}]
+--
+-- >>> P.parse pOrder "" "json_col->!@#$%^&*_a.asc.nullslast"
+-- Right [OrderTerm {otTerm = ("json_col",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), otDirection = Just OrderAsc, otNullOrder = Just OrderNullsLast}]
+--
+-- >>> P.parse pOrder "" "clients(json_col->key).desc.nullsfirst"
+-- Right [OrderRelationTerm {otRelation = "clients", otRelTerm = ("json_col",[JArrow {jOp = JKey {jVal = "key"}}]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
+--
+-- >>> P.parse pOrder "" "clients(json_col->!@#$%^&*_a).desc.nullsfirst"
+-- Right [OrderRelationTerm {otRelation = "clients", otRelTerm = ("json_col",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
+--
+-- >>> P.parse pOrder "" "clients(name,id)"
+-- Left (line 1, column 8):
+-- unexpected '('
+-- expecting letter, digit, "-", "->>", "->", delimiter (.), "," or end of input
+--
+-- >>> P.parse pOrder "" "name,clients(name),id"
+-- Right [OrderTerm {otTerm = ("name",[]), otDirection = Nothing, otNullOrder = Nothing},OrderRelationTerm {otRelation = "clients", otRelTerm = ("name",[]), otDirection = Nothing, otNullOrder = Nothing},OrderTerm {otTerm = ("id",[]), otDirection = Nothing, otNullOrder = Nothing}]
+--
+-- >>> P.parse pOrder "" "id.ac"
+-- Left (line 1, column 4):
+-- unexpected "c"
+-- expecting "asc", "desc", "nullsfirst" or "nullslast"
+--
+-- >>> P.parse pOrder "" "id.descc"
+-- Left (line 1, column 8):
+-- unexpected 'c'
+-- expecting delimiter (.), "," or end of input
+--
+-- >>> P.parse pOrder "" "id.nulsfist"
+-- Left (line 1, column 4):
+-- unexpected "n"
+-- expecting "asc", "desc", "nullsfirst" or "nullslast"
+--
+-- >>> P.parse pOrder "" "id.nullslasttt"
+-- Left (line 1, column 13):
+-- unexpected 't'
+-- expecting "," or end of input
+--
+-- >>> P.parse pOrder "" "id.smth34"
+-- Left (line 1, column 4):
+-- unexpected "s"
+-- expecting "asc", "desc", "nullsfirst" or "nullslast"
+--
+-- >>> P.parse pOrder "" "id.asc.nlsfst"
+-- Left (line 1, column 8):
+-- unexpected "l"
+-- expecting "nullsfirst" or "nullslast"
+--
+-- >>> P.parse pOrder "" "id.asc.nullslasttt"
+-- Left (line 1, column 17):
+-- unexpected 't'
+-- expecting "," or end of input
+--
+-- >>> P.parse pOrder "" "id.asc.smth34"
+-- Left (line 1, column 8):
+-- unexpected "s"
+-- expecting "nullsfirst" or "nullslast"
+pOrder :: Parser [OrderTerm]
+pOrder = lexeme (try pOrderRelationTerm <|> pOrderTerm) `sepBy1` char ','
+  where
+    pOrderTerm = do
+      fld <- pField
+      dir <- optionMaybe pOrdDir
+      nls <- optionMaybe pNulls <* pEnd <|>
+             pEnd $> Nothing
+      return $ OrderTerm fld dir nls
+
+    pOrderRelationTerm = do
+      nam <- pFieldName
+      fld <- between (char '(') (char ')') pField
+      dir <- optionMaybe pOrdDir
+      nls <- optionMaybe pNulls <* pEnd <|> pEnd $> Nothing
+      return $ OrderRelationTerm nam fld dir nls
+
+    pNulls :: Parser OrderNulls
+    pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>
+             try (pDelimiter *> string "nullslast"  $> OrderNullsLast)
+
+    pOrdDir :: Parser OrderDirection
+    pOrdDir = try (pDelimiter *> string "asc" $> OrderAsc) <|>
+              try (pDelimiter *> string "desc" $> OrderDesc)
+
+    pEnd = try (void $ lookAhead (char ',')) <|> try eof
+
+-- |
+-- Parses the elements inside or/and
+--
+-- >>> P.parse pLogicTree "" "or()"
+-- Left (line 1, column 4):
+-- unexpected ")"
+-- expecting field name (* or [a..z0..9_$]), negation operator (not) or logic operator (and, or)
+--
+-- >>> P.parse pLogicTree "" "or(id.in.1,2,id.eq.3)"
+-- Left (line 1, column 10):
+-- unexpected "1"
+-- expecting "("
+--
+-- >>> P.parse pLogicTree "" "or)("
+-- Left (line 1, column 3):
+-- unexpected ")"
+-- expecting "("
+--
+-- >>> P.parse pLogicTree "" "and(ord(id.eq.1,id.eq.1),id.eq.2)"
+-- Left (line 1, column 7):
+-- unexpected "d"
+-- expecting "("
+--
+-- >>> P.parse pLogicTree "" "or(id.eq.1,not.xor(id.eq.2,id.eq.3))"
+-- Left (line 1, column 16):
+-- unexpected "x"
+-- expecting logic operator (and, or)
+pLogicTree :: Parser LogicTree
+pLogicTree = Stmnt <$> try pLogicFilter
+             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')'))
+  where
+    pLogicFilter :: Parser Filter
+    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal
+    pNot :: Parser Bool
+    pNot = try (string "not" *> pDelimiter $> True)
+           <|> pure False
+           <?> "negation operator (not)"
+    pLogicOp :: Parser LogicOperator
+    pLogicOp = try (string "and" $> And)
+               <|> string "or" $> Or
+               <?> "logic operator (and, or)"
+
+pLogicSingleVal :: Parser SingleVal
+pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)"))
+  where
+    pPgArray :: Parser Text
+    pPgArray =  do
+      a <- string "{"
+      b <- many (noneOf "{}")
+      c <- string "}"
+      pure (toS $ a ++ b ++ c)
+
+pLogicPath :: Parser (EmbedPath, Text)
+pLogicPath = do
+  path <- pFieldName `sepBy1` pDelimiter
+  let op = last path
+      notOp = "not." <> op
+  return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)
+
+pColumns :: Parser [FieldName]
+pColumns = pFieldName `sepBy1` lexeme (char ',')
+
+pIdentifier :: Parser Text
+pIdentifier = T.strip . toS <$> many1 pIdentifierChar
+
+pIdentifierChar :: Parser Char
+pIdentifierChar = letter <|> digit <|> oneOf "_ $"
+
+mapError :: Either ParseError a -> Either QPError a
+mapError = mapLeft translateError
+  where
+    translateError e =
+      QPError message details
+      where
+        message = show $ errorPos e
+        details = T.strip $ T.replace "\n" " " $ toS
+           $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)

src/PostgREST/ApiRequest/Types.hs

@@ -0,0 +1,267 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module PostgREST.ApiRequest.Types
+  ( AggregateFunction(..)
+  , Alias
+  , Cast
+  , Depth
+  , EmbedParam(..)
+  , ApiRequestError(..)
+  , EmbedPath
+  , Field
+  , Filter(..)
+  , Hint
+  , JoinType(..)
+  , JsonOperand(..)
+  , JsonOperation(..)
+  , JsonPath
+  , ListVal
+  , LogicOperator(..)
+  , LogicTree(..)
+  , NodeName
+  , OpExpr(..)
+  , Operation (..)
+  , OpQuantifier(..)
+  , OrderDirection(..)
+  , OrderNulls(..)
+  , OrderTerm(..)
+  , QPError(..)
+  , RangeError(..)
+  , SingleVal
+  , TrileanVal(..)
+  , SimpleOperator(..)
+  , QuantOperator(..)
+  , FtsOperator(..)
+  , SelectItem(..)
+  ) where
+
+import PostgREST.MediaType                (MediaType (..))
+import PostgREST.SchemaCache.Identifiers  (FieldName,
+                                           QualifiedIdentifier)
+import PostgREST.SchemaCache.Relationship (Relationship,
+                                           RelationshipsMap)
+import PostgREST.SchemaCache.Routine      (Routine (..))
+
+import Protolude
+
+-- | The value in `/tbl?select=alias:field.aggregateFunction()::cast`
+data SelectItem
+  = SelectField
+    { selField             :: Field
+    , selAggregateFunction :: Maybe AggregateFunction
+    , selAggregateCast     :: Maybe Cast
+    , selCast              :: Maybe Cast
+    , selAlias             :: Maybe Alias
+    }
+-- | The value in `/tbl?select=alias:another_tbl(*)`
+  | SelectRelation
+    { selRelation :: FieldName
+    , selAlias    :: Maybe Alias
+    , selHint     :: Maybe Hint
+    , selJoinType :: Maybe JoinType
+    }
+-- | The value in `/tbl?select=...another_tbl(*)`
+  | SpreadRelation
+    { selRelation :: FieldName
+    , selHint     :: Maybe Hint
+    , selJoinType :: Maybe JoinType
+    }
+  deriving (Eq, Show)
+
+data ApiRequestError
+  = AggregatesNotAllowed
+  | AmbiguousRelBetween Text Text [Relationship]
+  | AmbiguousRpc [Routine]
+  | MediaTypeError [ByteString]
+  | InvalidBody ByteString
+  | InvalidFilters
+  | InvalidPreferences [ByteString]
+  | InvalidRange RangeError
+  | InvalidRpcMethod ByteString
+  | LimitNoOrderError
+  | NotFound
+  | NoRelBetween Text Text (Maybe Text) Text RelationshipsMap
+  | NoRpc Text Text [Text] Bool MediaType Bool [QualifiedIdentifier] [Routine]
+  | NotEmbedded Text
+  | PutLimitNotAllowedError
+  | QueryParamError QPError
+  | RelatedOrderNotToOne Text Text
+  | SpreadNotToOne Text Text
+  | UnacceptableFilter Text
+  | UnacceptableSchema [Text]
+  | UnsupportedMethod ByteString
+  | ColumnNotFound Text Text
+  | GucHeadersError
+  | GucStatusError
+  | OffLimitsChangesError Int64 Integer
+  | PutMatchingPkError
+  | SingularityError Integer
+  | PGRSTParseError
+  deriving Show
+
+data QPError = QPError Text Text
+  deriving Show
+data RangeError
+  = NegativeLimit
+  | LowerGTUpper
+  | OutOfBounds Text Text
+  deriving Show
+
+type NodeName = Text
+type Depth = Integer
+
+data OrderTerm
+  = OrderTerm
+    { otTerm      :: Field
+    , otDirection :: Maybe OrderDirection
+    , otNullOrder :: Maybe OrderNulls
+    }
+  | OrderRelationTerm
+    { otRelation  :: FieldName
+    , otRelTerm   :: Field
+    , otDirection :: Maybe OrderDirection
+    , otNullOrder :: Maybe OrderNulls
+    }
+  deriving (Eq, Show)
+
+data OrderDirection
+  = OrderAsc
+  | OrderDesc
+  deriving (Eq, Show)
+
+data OrderNulls
+  = OrderNullsFirst
+  | OrderNullsLast
+  deriving (Eq, Show)
+
+type Field = (FieldName, JsonPath)
+type Cast = Text
+type Alias = Text
+type Hint = Text
+
+data AggregateFunction = Sum | Avg | Max | Min | Count
+  deriving (Show, Eq)
+
+data EmbedParam
+  -- | Disambiguates an embedding operation when there's multiple relationships
+  -- between two tables. Can be the name of a foreign key constraint, column
+  -- name or the junction in an m2m relationship.
+  = EPHint Hint
+  | EPJoinType JoinType
+
+data JoinType
+  = JTInner
+  | JTLeft
+  deriving (Eq, Show)
+
+-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path
+-- ["clients", "projects"]
+type EmbedPath = [Text]
+
+-- | Json path operations as specified in
+-- https://www.postgresql.org/docs/current/static/functions-json.html
+type JsonPath = [JsonOperation]
+
+-- | Represents the single arrow `->` or double arrow `->>` operators
+data JsonOperation
+  = JArrow { jOp :: JsonOperand }
+  | J2Arrow { jOp :: JsonOperand }
+  deriving (Eq, Show, Ord)
+
+-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text
+-- because we reuse our escaping functons and let pg do the casting with
+-- '1'::int
+data JsonOperand
+  = JKey { jVal :: Text }
+  | JIdx { jVal :: Text }
+  deriving (Eq, Show, Ord)
+
+-- | Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
+--
+--            And
+--           /   \
+--  name.eq.N     Or
+--               /  \
+--         id.eq.1   id.eq.2
+data LogicTree
+  = Expr Bool LogicOperator [LogicTree]
+  | Stmnt Filter
+  deriving (Eq, Show)
+
+data LogicOperator
+  = And
+  | Or
+  deriving (Eq, Show)
+
+data Filter
+  = Filter
+  { field  :: Field
+  , opExpr :: OpExpr
+  }
+  deriving (Eq, Show)
+
+data OpExpr
+  = OpExpr Bool Operation
+  | NoOpExpr Text
+  deriving (Eq, Show)
+
+data OpQuantifier = QuantAny | QuantAll
+  deriving (Eq, Show)
+
+data Operation
+  = Op SimpleOperator SingleVal
+  | OpQuant QuantOperator (Maybe OpQuantifier) SingleVal
+  | In ListVal
+  | Is TrileanVal
+  | IsDistinctFrom SingleVal
+  | Fts FtsOperator (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]
+
+-- | Three-valued logic values
+data TrileanVal
+  = TriTrue
+  | TriFalse
+  | TriNull
+  | TriUnknown
+  deriving (Eq, Show)
+
+-- Operators that are quantifiable, i.e. they can be used with the any/all modifiers
+data QuantOperator
+  = OpEqual
+  | OpGreaterThanEqual
+  | OpGreaterThan
+  | OpLessThanEqual
+  | OpLessThan
+  | OpLike
+  | OpILike
+  | OpMatch
+  | OpIMatch
+  deriving (Eq, Show)
+
+data SimpleOperator
+  = OpNotEqual
+  | OpContains
+  | OpContained
+  | OpOverlap
+  | OpStrictlyLeft
+  | OpStrictlyRight
+  | OpNotExtendsRight
+  | OpNotExtendsLeft
+  | OpAdjacent
+  deriving (Eq, Show)
+
+--
+-- | Operators for full text search operators
+data FtsOperator
+  = FilterFts
+  | FilterFtsPlain
+  | FilterFtsPhrase
+  | FilterFtsWebsearch
+  deriving (Eq, Show)

src/PostgREST/App.hs

@@ -9,124 +9,83 @@ Some of its functionality includes:
 - Producing HTTP Headers according to RFCs.
 - Content Negotiation
 -}
+{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
 module PostgREST.App
-  ( SignalHandlerInstaller
-  , SocketRunner
-  , postgrest
+  ( postgrest
   , run
   ) where
 
+
 import Control.Monad.Except     (liftEither)
 import Data.Either.Combinators  (mapLeft)
-import Data.List                (union)
+import Data.Maybe               (fromJust)
 import Data.String              (IsString (..))
-import Data.Time.Clock          (UTCTime)
 import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
                                  setServerName)
-import System.Posix.Types       (FileMode)
 
-import qualified Data.ByteString.Char8           as BS
-import qualified Data.ByteString.Lazy            as LBS
-import qualified Data.HashMap.Strict             as M
-import qualified Data.Set                        as S
-import qualified Hasql.DynamicStatements.Snippet as SQL
-import qualified Hasql.Pool                      as SQL
-import qualified Hasql.Transaction               as SQL
-import qualified Hasql.Transaction.Sessions      as SQL
-import qualified Network.HTTP.Types.Header       as HTTP
-import qualified Network.HTTP.Types.Status       as HTTP
-import qualified Network.HTTP.Types.URI          as HTTP
-import qualified Network.Wai                     as Wai
-import qualified Network.Wai.Handler.Warp        as Warp
+import qualified Data.HashMap.Strict        as HM
+import qualified Data.Text.Encoding         as T
+import qualified Hasql.Transaction.Sessions as SQL
+import qualified Network.Wai                as Wai
+import qualified Network.Wai.Handler.Warp   as Warp
 
-import qualified PostgREST.AppState                 as AppState
-import qualified PostgREST.Auth                     as Auth
-import qualified PostgREST.DbStructure              as DbStructure
-import qualified PostgREST.Error                    as Error
-import qualified PostgREST.Middleware               as Middleware
-import qualified PostgREST.OpenAPI                  as OpenAPI
-import qualified PostgREST.Query.QueryBuilder       as QueryBuilder
-import qualified PostgREST.Query.Statements         as Statements
-import qualified PostgREST.RangeQuery               as RangeQuery
-import qualified PostgREST.Request.ApiRequest       as ApiRequest
-import qualified PostgREST.Request.DbRequestBuilder as ReqBuilder
+import qualified PostgREST.Admin            as Admin
+import qualified PostgREST.ApiRequest       as ApiRequest
+import qualified PostgREST.ApiRequest.Types as ApiRequestTypes
+import qualified PostgREST.AppState         as AppState
+import qualified PostgREST.Auth             as Auth
+import qualified PostgREST.Cors             as Cors
+import qualified PostgREST.Error            as Error
+import qualified PostgREST.Logger           as Logger
+import qualified PostgREST.Plan             as Plan
+import qualified PostgREST.Query            as Query
+import qualified PostgREST.Response         as Response
+import qualified PostgREST.Unix             as Unix (installSignalHandlers)
 
-import PostgREST.AppState                (AppState)
-import PostgREST.Config                  (AppConfig (..),
-                                          LogLevel (..),
-                                          OpenAPIMode (..))
-import PostgREST.Config.PgVersion        (PgVersion (..))
-import PostgREST.ContentType             (ContentType (..))
-import PostgREST.DbStructure             (DbStructure (..),
-                                          tablePKCols)
-import PostgREST.DbStructure.Identifiers (FieldName,
-                                          QualifiedIdentifier (..),
-                                          Schema)
-import PostgREST.DbStructure.Proc        (ProcDescription (..),
-                                          ProcVolatility (..))
-import PostgREST.DbStructure.Table       (Table (..))
-import PostgREST.Error                   (Error)
-import PostgREST.GucHeader               (GucHeader,
-                                          addHeadersIfNotIncluded,
-                                          unwrapGucHeader)
-import PostgREST.Request.ApiRequest      (Action (..),
-                                          ApiRequest (..),
-                                          InvokeMethod (..),
-                                          Target (..))
-import PostgREST.Request.Preferences     (PreferCount (..),
-                                          PreferParameters (..),
-                                          PreferRepresentation (..),
-                                          toAppliedHeader)
-import PostgREST.Request.Types           (ReadRequest, fstFieldNames)
-import PostgREST.Version                 (prettyVersion)
-import PostgREST.Workers                 (connectionWorker, listener)
+import PostgREST.ApiRequest           (Action (..), ApiRequest (..),
+                                       Mutation (..), Target (..))
+import PostgREST.AppState             (AppState)
+import PostgREST.Auth                 (AuthResult (..))
+import PostgREST.Config               (AppConfig (..))
+import PostgREST.Config.PgVersion     (PgVersion (..))
+import PostgREST.Error                (Error)
+import PostgREST.Query                (DbHandler)
+import PostgREST.Response.Performance (ServerTiming (..),
+                                       serverTimingHeader)
+import PostgREST.SchemaCache          (SchemaCache (..))
+import PostgREST.SchemaCache.Routine  (Routine (..))
+import PostgREST.Version              (docsVersion, prettyVersion)
 
-import qualified PostgREST.ContentType      as ContentType
-import qualified PostgREST.DbStructure.Proc as Proc
-
-import Protolude hiding (Handler)
-
-
-data RequestContext = RequestContext
-  { ctxConfig      :: AppConfig
-  , ctxDbStructure :: DbStructure
-  , ctxApiRequest  :: ApiRequest
-  , ctxPgVersion   :: PgVersion
-  }
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.List             as L
+import qualified Network.HTTP.Types    as HTTP
+import qualified Network.Socket        as NS
+import           Protolude             hiding (Handler)
+import           System.TimeIt         (timeItT)
 
 type Handler = ExceptT Error
 
-type DbHandler = Handler SQL.Transaction
-
-type SignalHandlerInstaller = AppState -> IO()
-
-type SocketRunner = Warp.Settings -> Wai.Application -> FileMode -> FilePath -> IO()
-
-
-run :: SignalHandlerInstaller -> Maybe SocketRunner -> AppState -> IO ()
-run installHandlers maybeRunWithSocket appState = do
+run :: AppState -> IO ()
+run appState = do
   conf@AppConfig{..} <- AppState.getConfig appState
-  connectionWorker appState -- Loads the initial DbStructure
-  installHandlers appState
+  AppState.connectionWorker appState -- Loads the initial SchemaCache
+  Unix.installSignalHandlers (AppState.getMainThreadId appState) (AppState.connectionWorker appState) (AppState.reReadConfig False appState)
   -- reload schema cache + config on NOTIFY
-  when configDbChannelEnabled $ listener appState
+  AppState.runListener conf appState
 
-  let app = postgrest configLogLevel appState (connectionWorker appState)
+  Admin.runAdmin conf appState $ serverSettings conf
 
-  case configServerUnixSocket of
-    Just socket ->
-      -- run the postgrest application with user defined socket. Only for UNIX systems
-      case maybeRunWithSocket of
-        Just runWithSocket -> do
-          AppState.logWithZTime appState $ "Listening on unix socket " <> show socket
-          runWithSocket (serverSettings conf) app configServerUnixSocketMode socket
-        Nothing ->
-          panic "Cannot run with socket on non-unix plattforms."
-    Nothing ->
-      do
-        AppState.logWithZTime appState $ "Listening on port " <> show configServerPort
-        Warp.runSettings (serverSettings conf) app
+  let app = postgrest conf appState (AppState.connectionWorker appState)
+
+  what <- case configServerUnixSocket of
+    Just path -> pure $ "unix socket " <> show path
+    Nothing   -> do
+      port <- NS.socketPort $ AppState.getSocketREST appState
+      pure $ "port " <> show port
+  AppState.logWithZTime appState $ "Listening on " <> what
+
+  Warp.runSettingsSocket (serverSettings conf) (AppState.getSocketREST appState) app
 
 serverSettings :: AppConfig -> Warp.Settings
 serverSettings AppConfig{..} =
@@ -136,476 +95,171 @@ serverSettings AppConfig{..} =
     & setServerName ("postgrest/" <> prettyVersion)
 
 -- | PostgREST application
-postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application
-postgrest logLev appState connWorker =
-  Middleware.pgrstMiddleware logLev $
-    \req respond -> do
-      time <- AppState.getTime appState
-      conf <- AppState.getConfig appState
-      maybeDbStructure <- AppState.getDbStructure appState
-      pgVer <- AppState.getPgVersion appState
-      jsonDbS <- AppState.getJsonDbS appState
+postgrest :: AppConfig -> AppState.AppState -> IO () -> Wai.Application
+postgrest conf appState connWorker =
+  traceHeaderMiddleware conf .
+  Cors.middleware (configServerCorsAllowedOrigins conf) .
+  Auth.middleware appState .
+  Logger.middleware (configLogLevel conf) $
+    -- fromJust can be used, because the auth middleware will **always** add
+    -- some AuthResult to the vault.
+    \req respond -> case fromJust $ Auth.getResult req of
+      Left err -> respond $ Error.errorResponseFor err
+      Right authResult -> do
+        appConf <- AppState.getConfig appState -- the config must be read again because it can reload
+        maybeSchemaCache <- AppState.getSchemaCache appState
+        pgVer <- AppState.getPgVersion appState
 
-      let
-        eitherResponse :: IO (Either Error Wai.Response)
-        eitherResponse =
-          runExceptT $ postgrestResponse conf maybeDbStructure jsonDbS pgVer (AppState.getPool appState) time req
+        let
+          eitherResponse :: IO (Either Error Wai.Response)
+          eitherResponse =
+            runExceptT $ postgrestResponse appState appConf maybeSchemaCache pgVer authResult req
 
-      response <- either Error.errorResponseFor identity <$> eitherResponse
-      -- Launch the connWorker when the connection is down.  The postgrest
-      -- function can respond successfully (with a stale schema cache) before
-      -- the connWorker is done.
-      let isPGAway = Wai.responseStatus response == HTTP.status503
-      when isPGAway connWorker
-      resp <- addRetryHint isPGAway appState response
-      respond resp
-
-addRetryHint :: Bool -> AppState -> Wai.Response -> IO Wai.Response
-addRetryHint shouldAdd appState response = do
-  delay <- AppState.getRetryNextIn appState
-  let h = ("Retry-After", BS.pack $ show delay)
-  return $ Wai.mapResponseHeaders (\hs -> if shouldAdd then h:hs else hs) response
+        response <- either Error.errorResponseFor identity <$> eitherResponse
+        -- Launch the connWorker when the connection is down.  The postgrest
+        -- function can respond successfully (with a stale schema cache) before
+        -- the connWorker is done.
+        when (isServiceUnavailable response) connWorker
+        resp <- do
+          delay <- AppState.getRetryNextIn appState
+          return $ addRetryHint delay response
+        respond resp
 
 postgrestResponse
-  :: AppConfig
-  -> Maybe DbStructure
-  -> ByteString
+  :: AppState.AppState
+  -> AppConfig
+  -> Maybe SchemaCache
   -> PgVersion
-  -> SQL.Pool
-  -> UTCTime
+  -> AuthResult
   -> Wai.Request
   -> Handler IO Wai.Response
-postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time req = do
+postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@AuthResult{..} req = do
+  sCache <-
+    case maybeSchemaCache of
+      Just sCache ->
+        return sCache
+      Nothing ->
+        throwError Error.NoSchemaCacheError
+
   body <- lift $ Wai.strictRequestBody req
 
-  dbStructure <-
-    case maybeDbStructure of
-      Just dbStructure ->
-        return dbStructure
-      Nothing ->
-        throwError Error.ConnectionLostError
+  (parseTime, apiRequest) <-
+    calcTiming configServerTimingEnabled $
+      liftEither . mapLeft Error.ApiRequestError $
+        ApiRequest.userApiRequest conf req body sCache
 
-  apiRequest@ApiRequest{..} <-
-    liftEither . mapLeft Error.ApiRequestError $
-      ApiRequest.userApiRequest conf dbStructure req body
+  let jwtTime = if configServerTimingEnabled then Auth.getJwtDur req else Nothing
+  handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache jwtTime parseTime
 
-  -- The JWT must be checked before touching the db
-  jwtClaims <- Auth.jwtClaims conf (toUtf8Lazy iJWT) time
-
-  let
-    handleReq apiReq =
-      handleRequest $ RequestContext conf dbStructure apiReq pgVer
-
-  runDbHandler pool (txMode apiRequest) jwtClaims (configDbPreparedStatements conf) .
-    Middleware.optionalRollback conf apiRequest $
-      Middleware.runPgLocals conf jwtClaims handleReq apiRequest jsonDbS pgVer
-
-runDbHandler :: SQL.Pool -> SQL.Mode -> Auth.JWTClaims -> Bool -> DbHandler a -> Handler IO a
-runDbHandler pool mode jwtClaims prepared handler = do
-  dbResp <-
-    let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
-    lift . SQL.use pool . transaction SQL.ReadCommitted mode $ runExceptT handler
+runDbHandler :: AppState.AppState -> AppConfig -> SQL.IsolationLevel -> SQL.Mode -> Bool -> Bool -> DbHandler b -> Handler IO b
+runDbHandler appState config isoLvl mode authenticated prepared handler = do
+  dbResp <- lift $ do
+    let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction
+    AppState.usePool appState config . transaction isoLvl mode $ runExceptT handler
 
   resp <-
     liftEither . mapLeft Error.PgErr $
-      mapLeft (Error.PgError $ Auth.containsRole jwtClaims) dbResp
+      mapLeft (Error.PgError authenticated) dbResp
 
   liftEither resp
 
-handleRequest :: RequestContext -> DbHandler Wai.Response
-handleRequest context@(RequestContext _ _ ApiRequest{..} _) =
+handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> Maybe Double -> Maybe Double -> Handler IO Wai.Response
+handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache jwtTime parseTime =
   case (iAction, iTarget) of
-    (ActionRead headersOnly, TargetIdent identifier) ->
-      handleRead headersOnly identifier context
-    (ActionCreate, TargetIdent identifier) ->
-      handleCreate identifier context
-    (ActionUpdate, TargetIdent identifier) ->
-      handleUpdate identifier context
-    (ActionSingleUpsert, TargetIdent identifier) ->
-      handleSingleUpsert identifier context
-    (ActionDelete, TargetIdent identifier) ->
-      handleDelete identifier context
-    (ActionInfo, TargetIdent identifier) ->
-      handleInfo identifier context
-    (ActionInvoke invMethod, TargetProc proc _) ->
-      handleInvoke invMethod proc context
-    (ActionInspect headersOnly, TargetDefaultSpec tSchema) ->
-      handleOpenApi headersOnly tSchema context
+    (ActionRead headersOnly, TargetIdent identifier) -> do
+      (planTime', wrPlan) <- withTiming $ liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq
+      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.wrTxMode wrPlan) $ Query.readQuery wrPlan conf apiReq
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.readResponse wrPlan headersOnly identifier apiReq resultSet
+      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
+
+    (ActionMutate MutationCreate, TargetIdent identifier) -> do
+      (planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationCreate apiReq identifier conf sCache
+      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.mrTxMode mrPlan) $ Query.createQuery mrPlan apiReq conf
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.createResponse identifier mrPlan apiReq resultSet
+      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
+
+    (ActionMutate MutationUpdate, TargetIdent identifier) -> do
+      (planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationUpdate apiReq identifier conf sCache
+      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.mrTxMode mrPlan) $ Query.updateQuery mrPlan apiReq conf
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.updateResponse mrPlan apiReq resultSet
+      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
+
+    (ActionMutate MutationSingleUpsert, TargetIdent identifier) -> do
+      (planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationSingleUpsert apiReq identifier conf sCache
+      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.mrTxMode mrPlan) $ Query.singleUpsertQuery mrPlan apiReq conf
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.singleUpsertResponse mrPlan apiReq resultSet
+      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
+
+    (ActionMutate MutationDelete, TargetIdent identifier) -> do
+      (planTime', mrPlan) <- withTiming $ liftEither $ Plan.mutateReadPlan MutationDelete apiReq identifier conf sCache
+      (txTime', resultSet) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.mrTxMode mrPlan) $ Query.deleteQuery mrPlan apiReq conf
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.deleteResponse mrPlan apiReq resultSet
+      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
+
+    (ActionInvoke invMethod, TargetProc identifier _) -> do
+      (planTime', cPlan) <- withTiming $ liftEither $ Plan.callReadPlan identifier conf sCache apiReq invMethod
+      (txTime', resultSet) <- withTiming $ runQuery (fromMaybe roleIsoLvl $ pdIsoLvl (Plan.crProc cPlan)) (pdTimeout $ Plan.crProc cPlan) (Plan.crTxMode cPlan) $ Query.invokeQuery (Plan.crProc cPlan) cPlan apiReq conf pgVer
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.invokeResponse cPlan invMethod (Plan.crProc cPlan) apiReq resultSet
+      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
+
+    (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> do
+      (planTime', iPlan) <- withTiming $ liftEither $ Plan.inspectPlan apiReq
+      (txTime', oaiResult) <- withTiming $ runQuery roleIsoLvl Nothing (Plan.ipTxmode iPlan) $ Query.openApiQuery sCache pgVer conf tSchema
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.openApiResponse (T.decodeUtf8 prettyVersion, docsVersion) headersOnly oaiResult conf sCache iSchema iNegotiatedByProfile
+      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' txTime' respTime') pgrst
+
+    (ActionInfo, TargetIdent identifier) -> do
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.infoIdentResponse identifier sCache
+      return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
+
+    (ActionInfo, TargetProc identifier _) -> do
+      (planTime', cPlan) <- withTiming $ liftEither $ Plan.callReadPlan identifier conf sCache apiReq ApiRequest.InvHead
+      (respTime', pgrst) <- withTiming $ liftEither $ Response.infoProcResponse (Plan.crProc cPlan)
+      return $ pgrstResponse (ServerTiming jwtTime parseTime planTime' Nothing respTime') pgrst
+
+    (ActionInfo, TargetDefaultSpec _) -> do
+      (respTime', pgrst) <- withTiming $ liftEither Response.infoRootResponse
+      return $ pgrstResponse (ServerTiming jwtTime parseTime Nothing Nothing respTime') pgrst
+
     _ ->
-      throwError Error.NotFound
-
-handleRead :: Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleRead headersOnly identifier context@RequestContext{..} = do
-  req <- readRequest identifier context
-  bField <- binaryField context req
-
-  let
-    ApiRequest{..} = ctxApiRequest
-    AppConfig{..} = ctxConfig
-    countQuery = QueryBuilder.readRequestToCountQuery req
-
-  (tableTotal, queryTotal, _ , body, gucHeaders, gucStatus) <-
-    lift . SQL.statement mempty $
-      Statements.createReadStatement
-        (QueryBuilder.readRequestToQuery req)
-        (if iPreferCount == Just EstimatedCount then
-           -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed
-           QueryBuilder.limitedQuery countQuery ((+ 1) <$> configDbMaxRows)
-         else
-           countQuery
-        )
-        (iAcceptContentType == CTSingularJSON)
-        (shouldCount iPreferCount)
-        (iAcceptContentType == CTTextCSV)
-        bField
-        configDbPreparedStatements
-
-  total <- readTotal ctxConfig ctxApiRequest tableTotal countQuery
-  response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders
-
-  let
-    (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange queryTotal total
-    headers =
-      [ contentRange
-      , ( "Content-Location"
-        , "/"
-            <> toUtf8 (qiName identifier)
-            <> if BS.null iCanonicalQS then mempty else "?" <> iCanonicalQS
-        )
-      ]
-      ++ contentTypeHeaders context
-
-  failNotSingular iAcceptContentType queryTotal . response status headers $
-    if headersOnly then mempty else LBS.fromStrict body
-
-readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64)
-readTotal AppConfig{..} ApiRequest{..} tableTotal countQuery =
-  case iPreferCount of
-    Just PlannedCount ->
-      explain
-    Just EstimatedCount ->
-      if tableTotal > (fromIntegral <$> configDbMaxRows) then
-        max tableTotal <$> explain
-      else
-        return tableTotal
-    _ ->
-      return tableTotal
+      -- This is unreachable as the ApiRequest.hs rejects it before
+      -- TODO Refactor the Action/Target types to remove this line
+      throwError $ Error.ApiRequestError ApiRequestTypes.NotFound
   where
-    explain =
-      lift . SQL.statement mempty . Statements.createExplainStatement countQuery $
-        configDbPreparedStatements
+    roleSettings = fromMaybe mempty (HM.lookup authRole $ configRoleSettings conf)
+    roleIsoLvl = HM.findWithDefault SQL.ReadCommitted authRole $ configRoleIsoLvl conf
+    runQuery isoLvl timeout mode query =
+      runDbHandler appState conf isoLvl mode authenticated prepared $ do
+        Query.setPgLocals conf authClaims authRole (HM.toList roleSettings) apiReq timeout
+        Query.runPreReq conf
+        query
 
-handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
-  let
-    ApiRequest{..} = ctxApiRequest
-    pkCols = tablePKCols ctxDbStructure qiSchema qiName
+    pgrstResponse :: ServerTiming -> Response.PgrstResponse -> Wai.Response
+    pgrstResponse timing (Response.PgrstResponse st hdrs bod) = Wai.responseLBS st (hdrs ++ ([serverTimingHeader timing | configServerTimingEnabled conf])) bod
 
-  WriteQueryResult{..} <- writeQuery identifier True pkCols context
+    withTiming = calcTiming $ configServerTimingEnabled conf
 
-  let
-    response = gucResponse resGucStatus resGucHeaders
-    headers =
-      catMaybes
-        [ if null resFields then
-            Nothing
-          else
-            Just
-              ( HTTP.hLocation
-              , "/"
-                  <> toUtf8 qiName
-                  <> HTTP.renderSimpleQuery True (splitKeyValue <$> resFields)
-              )
-        , Just . RangeQuery.contentRangeH 1 0 $
-            if shouldCount iPreferCount then Just resQueryTotal else Nothing
-        , if null pkCols && isNothing iOnConflict then
-            Nothing
-          else
-            toAppliedHeader <$> iPreferResolution
-        ]
+calcTiming :: Bool -> Handler IO a -> Handler IO (Maybe Double, a)
+calcTiming timingEnabled f = if timingEnabled
+    then do
+      (t, r) <- timeItT f
+      pure (Just t, r)
+    else do
+      r <- f
+      pure (Nothing, r)
 
-  failNotSingular iAcceptContentType resQueryTotal $
-    if iPreferRepresentation == Full then
-      response HTTP.status201 (headers ++ contentTypeHeaders context) (LBS.fromStrict resBody)
-    else
-      response HTTP.status201 headers mempty
+traceHeaderMiddleware :: AppConfig -> Wai.Middleware
+traceHeaderMiddleware AppConfig{configServerTraceHeader} app req respond =
+  case configServerTraceHeader of
+    Nothing -> app req respond
+    Just hdr ->
+      let hdrVal = L.lookup hdr $ Wai.requestHeaders req in
+      app req (respond . Wai.mapResponseHeaders ([(hdr, fromMaybe mempty hdrVal)] ++))
 
-handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do
-  WriteQueryResult{..} <- writeQuery identifier False mempty context
+addRetryHint :: Int -> Wai.Response -> Wai.Response
+addRetryHint delay response = do
+  let h = ("Retry-After", BS.pack $ show delay)
+  Wai.mapResponseHeaders (\hs -> if isServiceUnavailable response then h:hs else hs) response
 
-  let
-    response = gucResponse resGucStatus resGucHeaders
-    fullRepr = iPreferRepresentation == Full
-    updateIsNoOp = S.null iColumns
-    status
-      | resQueryTotal == 0 && not updateIsNoOp = HTTP.status404
-      | fullRepr = HTTP.status200
-      | otherwise = HTTP.status204
-    contentRangeHeader =
-      RangeQuery.contentRangeH 0 (resQueryTotal - 1) $
-        if shouldCount iPreferCount then Just resQueryTotal else Nothing
-
-  failNotSingular iAcceptContentType resQueryTotal $
-    if fullRepr then
-      response status (contentTypeHeaders context ++ [contentRangeHeader]) (LBS.fromStrict resBody)
-    else
-      response status [contentRangeHeader] mempty
-
-handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response
-handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do
-  when (iTopLevelRange /= RangeQuery.allRange) $
-    throwError Error.PutRangeNotAllowedError
-
-  WriteQueryResult{..} <- writeQuery identifier False mempty context
-
-  let response = gucResponse resGucStatus resGucHeaders
-
-  -- Makes sure the querystring pk matches the payload pk
-  -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted,
-  -- PUT /items?id=eq.14 { "id" : 2, .. } is rejected.
-  -- If this condition is not satisfied then nothing is inserted,
-  -- check the WHERE for INSERT in QueryBuilder.hs to see how it's done
-  when (resQueryTotal /= 1) $ do
-    lift SQL.condemn
-    throwError Error.PutMatchingPkError
-
-  return $
-    if iPreferRepresentation == Full then
-      response HTTP.status200 (contentTypeHeaders context) (LBS.fromStrict resBody)
-    else
-      response HTTP.status204 (contentTypeHeaders context) mempty
-
-handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
-handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do
-  WriteQueryResult{..} <- writeQuery identifier False mempty context
-
-  let
-    response = gucResponse resGucStatus resGucHeaders
-    contentRangeHeader =
-      RangeQuery.contentRangeH 1 0 $
-        if shouldCount iPreferCount then Just resQueryTotal else Nothing
-
-  failNotSingular iAcceptContentType resQueryTotal $
-    if iPreferRepresentation == Full then
-      response HTTP.status200
-        (contentTypeHeaders context ++ [contentRangeHeader])
-        (LBS.fromStrict resBody)
-    else
-      response HTTP.status204 [contentRangeHeader] mempty
-
-handleInfo :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m Wai.Response
-handleInfo identifier RequestContext{..} =
-  case find tableMatches $ dbTables ctxDbStructure of
-    Just table ->
-      return $ Wai.responseLBS HTTP.status200 [allOrigins, allowH table] mempty
-    Nothing ->
-      throwError Error.NotFound
-  where
-    allOrigins = ("Access-Control-Allow-Origin", "*")
-    allowH table =
-      ( HTTP.hAllow
-      , BS.intercalate "," $
-          ["OPTIONS,GET,HEAD"]
-          ++ ["POST" | tableInsertable table]
-          ++ ["PUT" | tableInsertable table && tableUpdatable table && hasPK]
-          ++ ["PATCH" | tableUpdatable table]
-          ++ ["DELETE" | tableDeletable table]
-      )
-    tableMatches table =
-      tableName table == qiName identifier
-      && tableSchema table == qiSchema identifier
-    hasPK =
-      not $ null $ tablePKCols ctxDbStructure (qiSchema identifier) (qiName identifier)
-
-handleInvoke :: InvokeMethod -> ProcDescription -> RequestContext -> DbHandler Wai.Response
-handleInvoke invMethod proc context@RequestContext{..} = do
-  let
-    ApiRequest{..} = ctxApiRequest
-
-    identifier =
-      QualifiedIdentifier
-        (pdSchema proc)
-        (fromMaybe (pdName proc) $ Proc.procTableName proc)
-
-  req <- readRequest identifier context
-  bField <- binaryField context req
-
-  let callReq = ReqBuilder.callRequest proc ctxApiRequest req
-
-  (tableTotal, queryTotal, body, gucHeaders, gucStatus) <-
-    lift . SQL.statement mempty $
-      Statements.callProcStatement
-        (Proc.procReturnsScalar proc)
-        (Proc.procReturnsSingle proc)
-        (QueryBuilder.requestToCallProcQuery callReq)
-        (QueryBuilder.readRequestToQuery req)
-        (QueryBuilder.readRequestToCountQuery req)
-        (shouldCount iPreferCount)
-        (iAcceptContentType == CTSingularJSON)
-        (iAcceptContentType == CTTextCSV)
-        (iPreferParameters == Just MultipleObjects)
-        bField
-        (configDbPreparedStatements ctxConfig)
-
-  response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders
-
-  let
-    (status, contentRange) =
-      RangeQuery.rangeStatusHeader iTopLevelRange queryTotal tableTotal
-
-  failNotSingular iAcceptContentType queryTotal $
-    response status
-      (contentTypeHeaders context ++ [contentRange])
-      (if invMethod == InvHead then mempty else LBS.fromStrict body)
-
-handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response
-handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest ctxPgVersion) = do
-  body <-
-    lift $ case configOpenApiMode of
-      OAFollowPriv ->
-        OpenAPI.encode conf dbStructure
-           <$> SQL.statement tSchema (DbStructure.accessibleTables ctxPgVersion configDbPreparedStatements)
-           <*> SQL.statement tSchema (DbStructure.accessibleProcs configDbPreparedStatements)
-           <*> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements)
-      OAIgnorePriv ->
-        OpenAPI.encode conf dbStructure
-              (filter (\x -> tableSchema x == tSchema) $ DbStructure.dbTables dbStructure)
-              (M.filterWithKey (\(QualifiedIdentifier sch _) _ ->  sch == tSchema) $ DbStructure.dbProcs dbStructure)
-          <$> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements)
-      OADisabled ->
-        pure mempty
-
-  return $
-    Wai.responseLBS HTTP.status200
-      (ContentType.toHeader CTOpenAPI : maybeToList (profileHeader apiRequest))
-      (if headersOnly then mempty else body)
-
-txMode :: ApiRequest -> SQL.Mode
-txMode ApiRequest{..} =
-  case (iAction, iTarget) of
-    (ActionRead _, _) ->
-      SQL.Read
-    (ActionInfo, _) ->
-      SQL.Read
-    (ActionInspect _, _) ->
-      SQL.Read
-    (ActionInvoke InvGet, _) ->
-      SQL.Read
-    (ActionInvoke InvHead, _) ->
-      SQL.Read
-    (ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Stable} _) ->
-      SQL.Read
-    (ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Immutable} _) ->
-      SQL.Read
-    _ ->
-      SQL.Write
-
--- | Result from executing a write query on the database
-data WriteQueryResult = WriteQueryResult
-  { resQueryTotal :: Int64
-  , resFields     :: [ByteString]
-  , resBody       :: ByteString
-  , resGucStatus  :: Maybe HTTP.Status
-  , resGucHeaders :: [GucHeader]
-  }
-
-writeQuery :: QualifiedIdentifier -> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult
-writeQuery identifier@QualifiedIdentifier{..} isInsert pkCols context@RequestContext{..} = do
-  readReq <- readRequest identifier context
-
-  mutateReq <-
-    liftEither $
-      ReqBuilder.mutateRequest qiSchema qiName ctxApiRequest
-        (tablePKCols ctxDbStructure qiSchema qiName)
-        readReq
-
-  (_, queryTotal, fields, body, gucHeaders, gucStatus) <-
-    lift . SQL.statement mempty $
-      Statements.createWriteStatement
-        (QueryBuilder.readRequestToQuery readReq)
-        (QueryBuilder.mutateRequestToQuery mutateReq)
-        (iAcceptContentType ctxApiRequest == CTSingularJSON)
-        isInsert
-        (iAcceptContentType ctxApiRequest == CTTextCSV)
-        (iPreferRepresentation ctxApiRequest)
-        pkCols
-        (configDbPreparedStatements ctxConfig)
-
-  liftEither $ WriteQueryResult queryTotal fields body <$> gucStatus <*> gucHeaders
-
--- | Response with headers and status overridden from GUCs.
-gucResponse
-  :: Maybe HTTP.Status
-  -> [GucHeader]
-  -> HTTP.Status
-  -> [HTTP.Header]
-  -> LBS.ByteString
-  -> Wai.Response
-gucResponse gucStatus gucHeaders status headers =
-  Wai.responseLBS (fromMaybe status gucStatus) $
-    addHeadersIfNotIncluded headers (map unwrapGucHeader gucHeaders)
-
--- |
--- Fail a response if a single JSON object was requested and not exactly one
--- was found.
-failNotSingular :: ContentType -> Int64 -> Wai.Response -> DbHandler Wai.Response
-failNotSingular contentType queryTotal response =
-  if contentType == CTSingularJSON && queryTotal /= 1 then
-    do
-      lift SQL.condemn
-      throwError $ Error.singularityError queryTotal
-  else
-    return response
-
-shouldCount :: Maybe PreferCount -> Bool
-shouldCount preferCount =
-  preferCount == Just ExactCount || preferCount == Just EstimatedCount
-
-returnsScalar :: ApiRequest.Target -> Bool
-returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc
-returnsScalar _                   = False
-
-readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest
-readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest _) =
-  liftEither $
-    ReqBuilder.readRequest qiSchema qiName configDbMaxRows
-      (dbRelationships dbStructure)
-      apiRequest
-
-contentTypeHeaders :: RequestContext -> [HTTP.Header]
-contentTypeHeaders RequestContext{..} =
-  ContentType.toHeader (iAcceptContentType ctxApiRequest) : maybeToList (profileHeader ctxApiRequest)
-
--- | If raw(binary) output is requested, check that ContentType is one of the
--- admitted rawContentTypes and that`?select=...` contains only one field other
--- than `*`
-binaryField :: Monad m => RequestContext -> ReadRequest -> Handler m (Maybe FieldName)
-binaryField RequestContext{..} readReq
-  | returnsScalar (iTarget ctxApiRequest) && iAcceptContentType ctxApiRequest `elem` rawContentTypes ctxConfig =
-      return $ Just "pgrst_scalar"
-  | iAcceptContentType ctxApiRequest `elem` rawContentTypes ctxConfig =
-      let
-        fldNames = fstFieldNames readReq
-        fieldName = headMay fldNames
-      in
-      if length fldNames == 1 && fieldName /= Just "*" then
-        return fieldName
-      else
-        throwError $ Error.BinaryFieldError (iAcceptContentType ctxApiRequest)
-  | otherwise =
-      return Nothing
-
-rawContentTypes :: AppConfig -> [ContentType]
-rawContentTypes AppConfig{..} =
-  (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
-
-profileHeader :: ApiRequest -> Maybe HTTP.Header
-profileHeader ApiRequest{..} =
-  (,) "Content-Profile" <$> (toUtf8 <$> iProfile)
-
-splitKeyValue :: ByteString -> (ByteString, ByteString)
-splitKeyValue kv =
-  (k, BS.tail v)
-  where
-    (k, v) = BS.break (== '=') kv
+isServiceUnavailable :: Wai.Response -> Bool
+isServiceUnavailable response = Wai.responseStatus response == HTTP.status503

src/PostgREST/AppState.hs

@@ -1,98 +1,233 @@
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
 
 module PostgREST.AppState
   ( AppState
+  , AuthResult(..)
+  , destroy
   , getConfig
-  , getDbStructure
-  , getIsWorkerOn
-  , getJsonDbS
+  , getSchemaCache
+  , getIsListenerOn
   , getMainThreadId
   , getPgVersion
-  , getPool
-  , getTime
   , getRetryNextIn
+  , getTime
+  , getJwtCache
+  , getSocketREST
+  , getSocketAdmin
   , init
+  , initSockets
   , initWithPool
   , logWithZTime
-  , putConfig
-  , putDbStructure
-  , putIsWorkerOn
-  , putJsonDbS
+  , putSchemaCache
   , putPgVersion
-  , putRetryNextIn
-  , releasePool
-  , signalListener
-  , waitListener
+  , usePool
+  , loadSchemaCache
+  , reReadConfig
+  , connectionWorker
+  , runListener
   ) where
 
-import qualified Hasql.Pool as SQL
+import qualified Data.Aeson                 as JSON
+import qualified Data.Aeson.KeyMap          as KM
+import qualified Data.ByteString.Char8      as BS
+import qualified Data.ByteString.Lazy       as LBS
+import qualified Data.Cache                 as C
+import           Data.Either.Combinators    (whenLeft)
+import qualified Data.Text                  as T (unpack)
+import qualified Data.Text.Encoding         as T
+import           Hasql.Connection           (acquire)
+import qualified Hasql.Notifications        as SQL
+import qualified Hasql.Pool                 as SQL
+import qualified Hasql.Session              as SQL
+import qualified Hasql.Transaction.Sessions as SQL
+import qualified Network.HTTP.Types.Status  as HTTP
+import qualified Network.Socket             as NS
+import qualified PostgREST.Error            as Error
+import           PostgREST.Version          (prettyVersion)
 
 import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
                            updateAction)
+import Control.Debounce
+import Control.Retry      (RetryStatus, capDelay, exponentialBackoff,
+                           retrying, rsPreviousDelay)
 import Data.IORef         (IORef, atomicWriteIORef, newIORef,
                            readIORef)
 import Data.Time          (ZonedTime, defaultTimeLocale, formatTime,
                            getZonedTime)
 import Data.Time.Clock    (UTCTime, getCurrentTime)
 
-import PostgREST.Config           (AppConfig (..))
-import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion)
-import PostgREST.DbStructure      (DbStructure)
+import PostgREST.Config                  (AppConfig (..),
+                                          LogLevel (..),
+                                          addFallbackAppName,
+                                          readAppConfig)
+import PostgREST.Config.Database         (queryDbSettings,
+                                          queryPgVersion,
+                                          queryRoleSettings)
+import PostgREST.Config.PgVersion        (PgVersion (..),
+                                          minimumPgVersion)
+import PostgREST.SchemaCache             (SchemaCache,
+                                          querySchemaCache)
+import PostgREST.SchemaCache.Identifiers (dumpQi)
+import PostgREST.Unix                    (createAndBindDomainSocket)
 
+import Data.Streaming.Network (bindPortTCP, bindRandomPortTCP)
+import Data.String            (IsString (..))
 import Protolude
 
+data AuthResult = AuthResult
+  { authClaims :: KM.KeyMap JSON.Value
+  , authRole   :: BS.ByteString
+  }
 
 data AppState = AppState
-  { statePool         :: SQL.Pool -- | Connection pool, either a 'Connection' or a 'ConnectionError'
-  , statePgVersion    :: IORef PgVersion
+  -- | Database connection pool
+  { statePool                     :: SQL.Pool
+  -- | Database server version, will be updated by the connectionWorker
+  , statePgVersion                :: IORef PgVersion
   -- | No schema cache at the start. Will be filled in by the connectionWorker
-  , stateDbStructure  :: IORef (Maybe DbStructure)
-  -- | Cached DbStructure in json
-  , stateJsonDbS      :: IORef ByteString
-  -- | Helper ref to make sure just one connectionWorker can run at a time
-  , stateIsWorkerOn   :: IORef Bool
+  , stateSchemaCache              :: IORef (Maybe SchemaCache)
+  -- | starts the connection worker with a debounce
+  , debouncedConnectionWorker     :: IO ()
   -- | Binary semaphore used to sync the listener(NOTIFY reload) with the connectionWorker.
-  , stateListener     :: MVar ()
+  , stateListener                 :: MVar ()
+  -- | State of the LISTEN channel, used for the admin server checks
+  , stateIsListenerOn             :: IORef Bool
   -- | Config that can change at runtime
-  , stateConf         :: IORef AppConfig
+  , stateConf                     :: IORef AppConfig
   -- | Time used for verifying JWT expiration
-  , stateGetTime      :: IO UTCTime
+  , stateGetTime                  :: IO UTCTime
   -- | Time with time zone used for worker logs
-  , stateGetZTime     :: IO ZonedTime
+  , stateGetZTime                 :: IO ZonedTime
   -- | Used for killing the main thread in case a subthread fails
-  , stateMainThreadId :: ThreadId
+  , stateMainThreadId             :: ThreadId
   -- | Keeps track of when the next retry for connecting to database is scheduled
-  , stateRetryNextIn  :: IORef Int
+  , stateRetryNextIn              :: IORef Int
+  -- | Logs a pool error with a debounce
+  , debounceLogAcquisitionTimeout :: IO ()
+  -- | JWT Cache
+  , jwtCache                      :: C.Cache ByteString AuthResult
+  -- | Network socket for REST API
+  , stateSocketREST               :: NS.Socket
+  -- | Network socket for the admin UI
+  , stateSocketAdmin              :: Maybe NS.Socket
   }
 
+type AppSockets = (NS.Socket, Maybe NS.Socket)
+
 init :: AppConfig -> IO AppState
 init conf = do
-  newPool <- initPool conf
-  initWithPool newPool conf
+  pool <- initPool conf
+  (sock, adminSock) <- initSockets conf
+  state' <- initWithPool (sock, adminSock) pool conf
+  pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock }
 
-initWithPool :: SQL.Pool -> AppConfig -> IO AppState
-initWithPool newPool conf =
-  AppState newPool
+initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> IO AppState
+initWithPool (sock, adminSock) pool conf = do
+  appState <- AppState pool
     <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
     <*> newIORef Nothing
-    <*> newIORef mempty
-    <*> newIORef False
+    <*> pure (pure ())
     <*> newEmptyMVar
+    <*> newIORef False
     <*> newIORef conf
     <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }
     <*> mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime }
     <*> myThreadId
     <*> newIORef 0
+    <*> pure (pure ())
+    <*> C.newCache Nothing
+    <*> pure sock
+    <*> pure adminSock
+
+
+  debLogTimeout <-
+    let oneSecond = 1000000 in
+    mkDebounce defaultDebounceSettings
+       { debounceAction = logPgrstError appState SQL.AcquisitionTimeoutUsageError
+       , debounceFreq = 5*oneSecond
+       , debounceEdge = leadingEdge -- logs at the start and the end
+       }
+
+  debWorker <-
+    let decisecond = 100000 in
+    mkDebounce defaultDebounceSettings
+       { debounceAction = internalConnectionWorker appState
+       , debounceFreq = decisecond
+       , debounceEdge = leadingEdge -- runs the worker at the start and the end
+       }
+
+  return appState { debounceLogAcquisitionTimeout = debLogTimeout, debouncedConnectionWorker = debWorker }
+
+destroy :: AppState -> IO ()
+destroy = destroyPool
+
+initSockets :: AppConfig -> IO AppSockets
+initSockets AppConfig{..} = do
+  let
+    cfg'usp = configServerUnixSocket
+    cfg'uspm = configServerUnixSocketMode
+    cfg'host = configServerHost
+    cfg'port = configServerPort
+    cfg'adminport = configAdminServerPort
+
+  sock <- case cfg'usp of
+    -- I'm not using `streaming-commons`' bindPath function here because it's not defined for Windows,
+    -- but we need to have runtime error if we try to use it in Windows, not compile time error
+    Just path -> createAndBindDomainSocket path cfg'uspm
+    Nothing -> do
+      (_, sock) <-
+        if cfg'port /= 0
+          then do
+            sock <- bindPortTCP cfg'port (fromString $ T.unpack cfg'host)
+            pure (cfg'port, sock)
+          else do
+            -- explicitly bind to a random port, returning bound port number
+            (num, sock) <- bindRandomPortTCP (fromString $ T.unpack cfg'host)
+            pure (num, sock)
+      pure sock
+
+  adminSock <- case cfg'adminport of
+    Just adminPort -> do
+      adminSock <- bindPortTCP adminPort (fromString $ T.unpack cfg'host)
+      pure $ Just adminSock
+    Nothing -> pure Nothing
+
+  pure (sock, adminSock)
 
 initPool :: AppConfig -> IO SQL.Pool
 initPool AppConfig{..} =
-  SQL.acquire (configDbPoolSize, configDbPoolTimeout, toUtf8 configDbUri)
+  SQL.acquire
+    configDbPoolSize
+    (fromIntegral configDbPoolAcquisitionTimeout)
+    (fromIntegral configDbPoolMaxLifetime)
+    (fromIntegral configDbPoolMaxIdletime)
+    (toUtf8 $ addFallbackAppName prettyVersion configDbUri)
 
-getPool :: AppState -> SQL.Pool
-getPool = statePool
+-- | Run an action with a database connection.
+usePool :: AppState -> AppConfig -> SQL.Session a -> IO (Either SQL.UsageError a)
+usePool appState@AppState{..} AppConfig{configLogLevel} x = do
+  res <- SQL.use statePool x
 
-releasePool :: AppState -> IO ()
-releasePool AppState{..} = SQL.release statePool >> throwTo stateMainThreadId UserInterrupt
+  when (configLogLevel > LogCrit) $ do
+    whenLeft res (\case
+      SQL.AcquisitionTimeoutUsageError -> debounceLogAcquisitionTimeout -- this can happen rapidly for many requests, so we debounce
+      error
+        -- TODO We're using the 500 HTTP status for getting all internal db errors but there's no response here. We need a new intermediate type to not rely on the HTTP status.
+        | Error.status (Error.PgError False error) >= HTTP.status500 -> logPgrstError appState error
+        | otherwise -> pure ())
+
+  return res
+
+-- | Flush the connection pool so that any future use of the pool will
+-- use connections freshly established after this call.
+flushPool :: AppState -> IO ()
+flushPool AppState{..} = SQL.release statePool
+
+-- | Destroy the pool on shutdown.
+destroyPool :: AppState -> IO ()
+destroyPool AppState{..} = SQL.release statePool
 
 getPgVersion :: AppState -> IO PgVersion
 getPgVersion = readIORef . statePgVersion
@@ -100,24 +235,14 @@ getPgVersion = readIORef . statePgVersion
 putPgVersion :: AppState -> PgVersion -> IO ()
 putPgVersion = atomicWriteIORef . statePgVersion
 
-getDbStructure :: AppState -> IO (Maybe DbStructure)
-getDbStructure = readIORef . stateDbStructure
+getSchemaCache :: AppState -> IO (Maybe SchemaCache)
+getSchemaCache = readIORef . stateSchemaCache
 
-putDbStructure :: AppState -> DbStructure -> IO ()
-putDbStructure appState structure =
-  atomicWriteIORef (stateDbStructure appState) $ Just structure
+putSchemaCache :: AppState -> Maybe SchemaCache -> IO ()
+putSchemaCache appState = atomicWriteIORef (stateSchemaCache appState)
 
-getJsonDbS :: AppState -> IO ByteString
-getJsonDbS = readIORef . stateJsonDbS
-
-putJsonDbS :: AppState -> ByteString -> IO ()
-putJsonDbS appState = atomicWriteIORef (stateJsonDbS appState)
-
-getIsWorkerOn :: AppState -> IO Bool
-getIsWorkerOn = readIORef . stateIsWorkerOn
-
-putIsWorkerOn :: AppState -> Bool -> IO ()
-putIsWorkerOn = atomicWriteIORef . stateIsWorkerOn
+connectionWorker :: AppState -> IO ()
+connectionWorker = debouncedConnectionWorker
 
 getRetryNextIn :: AppState -> IO Int
 getRetryNextIn = readIORef . stateRetryNextIn
@@ -134,12 +259,24 @@ putConfig = atomicWriteIORef . stateConf
 getTime :: AppState -> IO UTCTime
 getTime = stateGetTime
 
+getJwtCache :: AppState -> C.Cache ByteString AuthResult
+getJwtCache = jwtCache
+
+getSocketREST :: AppState -> NS.Socket
+getSocketREST = stateSocketREST
+
+getSocketAdmin :: AppState -> Maybe NS.Socket
+getSocketAdmin = stateSocketAdmin
+
 -- | Log to stderr with local time
 logWithZTime :: AppState -> Text -> IO ()
 logWithZTime appState txt = do
   zTime <- stateGetZTime appState
   hPutStrLn stderr $ toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <> txt
 
+logPgrstError :: AppState -> SQL.UsageError -> IO ()
+logPgrstError appState e = logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ Error.errorPayload $ Error.PgError False e
+
 getMainThreadId :: AppState -> ThreadId
 getMainThreadId = stateMainThreadId
 
@@ -153,3 +290,274 @@ waitListener = takeMVar . stateListener
 -- the connectionWorker is the only mvar producer.
 signalListener :: AppState -> IO ()
 signalListener appState = void $ tryPutMVar (stateListener appState) ()
+
+getIsListenerOn :: AppState -> IO Bool
+getIsListenerOn = readIORef . stateIsListenerOn
+
+putIsListenerOn :: AppState -> Bool -> IO ()
+putIsListenerOn = atomicWriteIORef . stateIsListenerOn
+
+-- | Schema cache status
+data SCacheStatus
+  = SCLoaded
+  | SCOnRetry
+  | SCFatalFail
+
+-- | Load the SchemaCache by using a connection from the pool.
+loadSchemaCache :: AppState -> IO SCacheStatus
+loadSchemaCache appState = do
+  conf@AppConfig{..} <- getConfig appState
+  result <-
+    let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
+    usePool appState conf . transaction SQL.ReadCommitted SQL.Read $
+      querySchemaCache conf
+  case result of
+    Left e -> do
+      case checkIsFatal e of
+        Just hint -> do
+          logWithZTime appState "A fatal error ocurred when loading the schema cache"
+          logPgrstError appState e
+          logWithZTime appState hint
+          return SCFatalFail
+        Nothing -> do
+          putSchemaCache appState Nothing
+          logWithZTime appState "An error ocurred when loading the schema cache"
+          logPgrstError appState e
+          return SCOnRetry
+
+    Right sCache -> do
+      putSchemaCache appState (Just sCache)
+      logWithZTime appState "Schema cache loaded"
+      return SCLoaded
+
+-- | Current database connection status data ConnectionStatus
+data ConnectionStatus
+  = NotConnected
+  | Connected PgVersion
+  | FatalConnectionError Text
+  deriving (Eq)
+
+-- | The purpose of this worker is to obtain a healthy connection to pg and an
+-- up-to-date schema cache(SchemaCache).  This method is meant to be called
+-- multiple times by the same thread, but does nothing if the previous
+-- invocation has not terminated. In all cases this method does not halt the
+-- calling thread, the work is performed in a separate thread.
+--
+-- Background thread that does the following :
+--  1. Tries to connect to pg server and will keep trying until success.
+--  2. Checks if the pg version is supported and if it's not it kills the main
+--     program.
+--  3. Obtains the sCache. If this fails, it goes back to 1.
+internalConnectionWorker :: AppState -> IO ()
+internalConnectionWorker appState = work
+  where
+    work = do
+      config@AppConfig{..} <- getConfig appState
+      logWithZTime appState $ "Starting PostgREST " <> T.decodeUtf8 prettyVersion <> "..."
+      logWithZTime appState "Attempting to connect to the database..."
+      connected <- establishConnection appState config
+      case connected of
+        FatalConnectionError reason ->
+          -- Fatal error when connecting
+          logWithZTime appState reason >> killThread (getMainThreadId appState)
+        NotConnected ->
+          -- Unreachable because establishConnection will keep trying to connect, unless disable-recovery is turned on
+          unless configDbPoolAutomaticRecovery
+              $ logWithZTime appState "Automatic recovery disabled, exiting." >> killThread (getMainThreadId appState)
+        Connected actualPgVersion -> do
+          -- Procede with initialization
+          putPgVersion appState actualPgVersion
+          when configDbChannelEnabled $
+            signalListener appState
+          logWithZTime appState "Connection successful"
+          -- this could be fail because the connection drops, but the loadSchemaCache will pick the error and retry again
+          -- We cannot retry after it fails immediately, because db-pre-config could have user errors. We just log the error and continue.
+          when configDbConfig $ reReadConfig False appState
+          scStatus <- loadSchemaCache appState
+          case scStatus of
+            SCLoaded ->
+              -- do nothing and proceed if the load was successful
+              return ()
+            SCOnRetry ->
+              -- retry reloading the schema cache
+              work
+            SCFatalFail ->
+              -- die if our schema cache query has an error
+              killThread $ getMainThreadId appState
+
+-- | Repeatedly flush the pool, and check if a connection from the
+-- pool allows access to the PostgreSQL database.
+--
+-- Releasing the pool is key for rapid recovery. Otherwise, the pool
+-- timeout would have to be reached for new healthy connections to be acquired.
+-- Which might not happen if the server is busy with requests. No idle
+-- connection, no pool timeout.
+--
+-- The connection tries are capped, but if the connection times out no error is
+-- thrown, just 'False' is returned.
+establishConnection :: AppState -> AppConfig -> IO ConnectionStatus
+establishConnection appState config =
+  retrying retrySettings shouldRetry $
+    const $ flushPool appState >> getConnectionStatus
+  where
+    retrySettings = capDelay delayMicroseconds $ exponentialBackoff backoffMicroseconds
+    delayMicroseconds = 32000000 -- 32 seconds
+    backoffMicroseconds = 1000000 -- 1 second
+
+    getConnectionStatus :: IO ConnectionStatus
+    getConnectionStatus = do
+      pgVersion <- usePool appState config $ queryPgVersion False -- No need to prepare the query here, as the connection might not be established
+      case pgVersion of
+        Left e -> do
+          logPgrstError appState e
+          case checkIsFatal e of
+            Just reason ->
+              return $ FatalConnectionError reason
+            Nothing ->
+              return NotConnected
+        Right version ->
+          if version < minimumPgVersion then
+            return . FatalConnectionError $
+              "Cannot run in this PostgreSQL version, PostgREST needs at least "
+              <> pgvName minimumPgVersion
+          else
+            return . Connected  $ version
+
+    shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool
+    shouldRetry rs isConnSucc = do
+      AppConfig{..} <- getConfig appState
+      let
+        delay = fromMaybe 0 (rsPreviousDelay rs) `div` backoffMicroseconds
+        itShould = NotConnected == isConnSucc && configDbPoolAutomaticRecovery
+      when itShould . logWithZTime appState $
+        "Attempting to reconnect to the database in "
+        <> (show delay::Text)
+        <> " seconds..."
+      when itShould $ putRetryNextIn appState delay
+      return itShould
+
+-- | Re-reads the config plus config options from the db
+reReadConfig :: Bool -> AppState -> IO ()
+reReadConfig startingUp appState = do
+  config@AppConfig{..} <- getConfig appState
+  pgVer <- getPgVersion appState
+  dbSettings <-
+    if configDbConfig then do
+      qDbSettings <- usePool appState config $ queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements
+      case qDbSettings of
+        Left e -> do
+          logWithZTime appState
+            "An error ocurred when trying to query database settings for the config parameters"
+          case checkIsFatal e of
+            Just hint -> do
+              logPgrstError appState e
+              logWithZTime appState hint
+              killThread (getMainThreadId appState)
+            Nothing -> do
+              logPgrstError appState e
+          pure mempty
+        Right x -> pure x
+    else
+      pure mempty
+  (roleSettings, roleIsolationLvl) <-
+    if configDbConfig then do
+      rSettings <- usePool appState config $ queryRoleSettings pgVer configDbPreparedStatements
+      case rSettings of
+        Left e -> do
+          logWithZTime appState "An error ocurred when trying to query the role settings"
+          logPgrstError appState e
+          pure (mempty, mempty)
+        Right x -> pure x
+    else
+      pure mempty
+  readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings roleIsolationLvl >>= \case
+    Left err   ->
+      if startingUp then
+        panic err -- die on invalid config if the program is starting up
+      else
+        logWithZTime appState $ "Failed reloading config: " <> err
+    Right newConf -> do
+      putConfig appState newConf
+      if startingUp then
+        pass
+      else
+        logWithZTime appState "Config reloaded"
+
+
+runListener :: AppConfig -> AppState -> IO ()
+runListener AppConfig{configDbChannelEnabled} appState =
+  when configDbChannelEnabled $ listener appState
+
+-- | Starts a dedicated pg connection to LISTEN for notifications.  When a
+-- NOTIFY <db-channel> - with an empty payload - is done, it refills the schema
+-- cache.  It uses the connectionWorker in case the LISTEN connection dies.
+listener :: AppState -> IO ()
+listener appState = do
+  AppConfig{..} <- getConfig appState
+  let dbChannel = toS configDbChannel
+
+  -- The listener has to wait for a signal from the connectionWorker.
+  -- This is because when the connection to the db is lost, the listener also
+  -- tries to recover the connection, but not with the same pace as the connectionWorker.
+  -- Not waiting makes stderr quickly fill with connection retries messages from the listener.
+  waitListener appState
+
+  -- forkFinally allows to detect if the thread dies
+  void . flip forkFinally (handleFinally dbChannel configDbPoolAutomaticRecovery) $ do
+    dbOrError <- acquire $ toUtf8 (addFallbackAppName prettyVersion configDbUri)
+    case dbOrError of
+      Right db -> do
+        logWithZTime appState $ "Listening for notifications on the " <> dbChannel <> " channel"
+        putIsListenerOn appState True
+        SQL.listen db $ SQL.toPgIdentifier dbChannel
+        SQL.waitForNotifications handleNotification db
+      _ ->
+        die $ "Could not listen for notifications on the " <> dbChannel <> " channel"
+  where
+    handleFinally _ False _ =
+      logWithZTime appState "Automatic recovery disabled, exiting." >> killThread (getMainThreadId appState)
+    handleFinally dbChannel True _ = do
+      -- if the thread dies, we try to recover
+      logWithZTime appState $ "Retrying listening for notifications on the " <> dbChannel <> " channel.."
+      putIsListenerOn appState False
+      -- assume the pool connection was also lost, call the connection worker
+      connectionWorker appState
+      -- retry the listener
+      listener appState
+
+    handleNotification _ msg
+      | BS.null msg            = cacheReloader
+      | msg == "reload schema" = cacheReloader
+      | msg == "reload config" = reReadConfig False appState
+      | otherwise              = pure () -- Do nothing if anything else than an empty message is sent
+
+    cacheReloader =
+      -- reloads the schema cache + restarts pool connections
+      -- it's necessary to restart the pg connections because they cache the pg catalog(see #2620)
+      connectionWorker appState
+
+checkIsFatal :: SQL.UsageError -> Maybe Text
+checkIsFatal (SQL.ConnectionUsageError e)
+  | isAuthFailureMessage = Just $ toS failureMessage
+  | otherwise = Nothing
+  where isAuthFailureMessage =
+          ("FATAL:  password authentication failed" `isInfixOf` failureMessage) ||
+          ("no password supplied" `isInfixOf` failureMessage)
+        failureMessage = BS.unpack $ fromMaybe mempty e
+checkIsFatal(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError serverError)))
+  = case serverError of
+      -- Check for a syntax error (42601 is the pg code). This would mean the error is on our part somehow, so we treat it as fatal.
+      SQL.ServerError "42601" _ _ _ _
+        -> Just "Hint: This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues"
+      -- Check for a "prepared statement <name> already exists" error (Code 42P05: duplicate_prepared_statement).
+      -- This would mean that a connection pooler in transaction mode is being used
+      -- while prepared statements are enabled in the PostgREST configuration,
+      -- both of which are incompatible with each other.
+      SQL.ServerError "42P05" _ _ _ _
+        -> Just "Hint: If you are using connection poolers in transaction mode, try setting db-prepared-statements to false."
+      -- Check for a "transaction blocks not allowed in statement pooling mode" error (Code 08P01: protocol_violation).
+      -- This would mean that a connection pooler in statement mode is being used which is not supported in PostgREST.
+      SQL.ServerError "08P01" "transaction blocks not allowed in statement pooling mode" _ _ _
+        -> Just "Hint: Connection poolers in statement mode are not supported."
+      _ -> Nothing
+checkIsFatal _ = Nothing

src/PostgREST/Auth.hs

@@ -12,43 +12,60 @@ very simple authentication system inside the PostgreSQL database.
 -}
 {-# LANGUAGE RecordWildCards #-}
 module PostgREST.Auth
-  ( containsRole
-  , jwtClaims
-  , JWTClaims
+  ( AuthResult (..)
+  , getResult
+  , getJwtDur
+  , getRole
+  , middleware
   ) where
 
-import qualified Crypto.JWT          as JWT
-import qualified Data.Aeson          as JSON
-import qualified Data.HashMap.Strict as M
-import qualified Data.Vector         as V
+import qualified Crypto.JWT                      as JWT
+import qualified Data.Aeson                      as JSON
+import qualified Data.Aeson.Key                  as K
+import qualified Data.Aeson.KeyMap               as KM
+import qualified Data.Aeson.Types                as JSON
+import qualified Data.ByteString                 as BS
+import qualified Data.ByteString.Lazy.Char8      as LBS
+import qualified Data.Cache                      as C
+import qualified Data.Scientific                 as Sci
+import qualified Data.Vault.Lazy                 as Vault
+import qualified Data.Vector                     as V
+import qualified Network.HTTP.Types.Header       as HTTP
+import qualified Network.Wai                     as Wai
+import qualified Network.Wai.Middleware.HttpAuth as Wai
 
 import Control.Lens            (set)
 import Control.Monad.Except    (liftEither)
 import Data.Either.Combinators (mapLeft)
-import Data.Time.Clock         (UTCTime)
+import Data.List               (lookup)
+import Data.Time.Clock         (UTCTime, nominalDiffTimeToSeconds)
+import Data.Time.Clock.POSIX   (utcTimeToPOSIXSeconds)
+import System.Clock            (TimeSpec (..))
+import System.IO.Unsafe        (unsafePerformIO)
+import System.TimeIt           (timeItT)
 
-import PostgREST.Config (AppConfig (..), JSPath, JSPathExp (..))
-import PostgREST.Error  (Error (..))
+import PostgREST.AppState (AppState, AuthResult (..), getConfig,
+                           getJwtCache, getTime)
+import PostgREST.Config   (AppConfig (..), JSPath, JSPathExp (..))
+import PostgREST.Error    (Error (..))
 
 import Protolude
 
 
-type JWTClaims = M.HashMap Text JSON.Value
-
 -- | Receives the JWT secret and audience (from config) and a JWT and returns a
--- map of JWT claims.
-jwtClaims :: Monad m =>
-  AppConfig -> LByteString -> UTCTime -> ExceptT Error m JWTClaims
-jwtClaims _ "" _ = return M.empty
-jwtClaims AppConfig{..} payload time = do
+-- JSON object of JWT claims.
+parseToken :: Monad m =>
+  AppConfig -> LByteString -> UTCTime -> ExceptT Error m JSON.Value
+parseToken _ "" _ = return JSON.emptyObject
+parseToken AppConfig{..} token time = do
   secret <- liftEither . maybeToRight JwtTokenMissing $ configJWKS
   eitherClaims <-
     lift . runExceptT $
-      JWT.verifyClaimsAt validation secret time =<< JWT.decodeCompact payload
-  liftEither . mapLeft jwtClaimsError $ claimsMap configJwtRoleClaimKey <$> eitherClaims
+      JWT.verifyClaimsAt validation secret time =<< JWT.decodeCompact token
+  liftEither . mapLeft jwtClaimsError $ JSON.toJSON <$> eitherClaims
   where
     validation =
-      JWT.defaultJWTValidationSettings audienceCheck & set JWT.allowedSkew 1
+      JWT.defaultJWTValidationSettings audienceCheck & set JWT.allowedSkew 30
 
     audienceCheck :: JWT.StringOrURI -> Bool
     audienceCheck = maybe (const True) (==) configJwtAudience
@@ -57,26 +74,95 @@ jwtClaims AppConfig{..} payload time = do
     jwtClaimsError JWT.JWTExpired = JwtTokenInvalid "JWT expired"
     jwtClaimsError e              = JwtTokenInvalid $ show e
 
--- | Turn JWT ClaimSet into something easier to work with.
---
--- Also, here the jspath is applied to put the "role" in the map.
-claimsMap :: JSPath -> JWT.ClaimsSet -> JWTClaims
-claimsMap jspath claims =
-  case JSON.toJSON claims of
-    val@(JSON.Object o) ->
-      M.delete "role" o `M.union` role val
-    _ ->
-      M.empty
+parseClaims :: Monad m =>
+  AppConfig -> JSON.Value -> ExceptT Error m AuthResult
+parseClaims AppConfig{..} jclaims@(JSON.Object mclaims) = do
+  -- role defaults to anon if not specified in jwt
+  role <- liftEither . maybeToRight JwtTokenRequired $
+    unquoted <$> walkJSPath (Just jclaims) configJwtRoleClaimKey <|> configDbAnonRole
+  return AuthResult
+           { authClaims = mclaims & KM.insert "role" (JSON.toJSON $ decodeUtf8 role)
+           , authRole = role
+           }
   where
-    role value =
-      maybe M.empty (M.singleton "role") $ walkJSPath (Just value) jspath
-
     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.Object o)) (JSPKey key:rest) = walkJSPath (KM.lookup (K.fromText 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 :: JWTClaims -> Bool
-containsRole = M.member "role"
+    unquoted :: JSON.Value -> BS.ByteString
+    unquoted (JSON.String t) = encodeUtf8 t
+    unquoted v               = LBS.toStrict $ JSON.encode v
+-- impossible case - just added to please -Wincomplete-patterns
+parseClaims _ _ = return AuthResult { authClaims = KM.empty, authRole = mempty }
+
+-- | Validate authorization header.
+--   Parse and store JWT claims for future use in the request.
+middleware :: AppState -> Wai.Middleware
+middleware appState app req respond = do
+  conf <- getConfig appState
+  time <- getTime appState
+
+  let token  = fromMaybe "" $ Wai.extractBearerAuth =<< lookup HTTP.hAuthorization (Wai.requestHeaders req)
+      parseJwt = runExceptT $ parseToken conf (LBS.fromStrict token) time >>= parseClaims conf
+
+-- If DbPlanEnabled       -> calculate JWT validation time
+-- If JwtCacheMaxLifetime -> cache JWT validation result
+  req' <- case (configServerTimingEnabled conf, configJwtCacheMaxLifetime conf) of
+    (True, 0)            -> do
+          (dur, authResult) <- timeItT parseJwt
+          return $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult & Vault.insert jwtDurKey dur }
+
+    (True, maxLifetime)  -> do
+          (dur, authResult) <- timeItT $ getJWTFromCache appState token maxLifetime parseJwt time
+          return $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult & Vault.insert jwtDurKey dur }
+
+    (False, 0)           -> do
+          authResult <- parseJwt
+          return $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult }
+
+    (False, maxLifetime) -> do
+          authResult <- getJWTFromCache appState token maxLifetime parseJwt time
+          return $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult }
+
+  app req' respond
+
+-- | Used to retrieve and insert JWT to JWT Cache
+getJWTFromCache :: AppState -> ByteString -> Int -> IO (Either Error AuthResult) -> UTCTime -> IO (Either Error AuthResult)
+getJWTFromCache appState token maxLifetime parseJwt utc = do
+  checkCache <- C.lookup (getJwtCache appState) token
+  authResult <- maybe parseJwt (pure . Right) checkCache
+
+  case (authResult,checkCache) of
+    (Right res, Nothing) -> C.insert' (getJwtCache appState) (getTimeSpec res maxLifetime utc) token res
+    _                    -> pure ()
+
+  return authResult
+
+-- Used to extract JWT exp claim and add to JWT Cache
+getTimeSpec :: AuthResult -> Int -> UTCTime -> Maybe TimeSpec
+getTimeSpec res maxLifetime utc = do
+  let expireJSON = KM.lookup "exp" (authClaims res)
+      utcToSecs = floor . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds
+      sciToInt = fromMaybe 0 . Sci.toBoundedInteger
+  case expireJSON of
+    Just (JSON.Number seconds) -> Just $ TimeSpec (sciToInt seconds - utcToSecs utc) 0
+    _                          -> Just $ TimeSpec (fromIntegral maxLifetime :: Int64) 0
+
+authResultKey :: Vault.Key (Either Error AuthResult)
+authResultKey = unsafePerformIO Vault.newKey
+{-# NOINLINE authResultKey #-}
+
+getResult :: Wai.Request -> Maybe (Either Error AuthResult)
+getResult = Vault.lookup authResultKey . Wai.vault
+
+jwtDurKey :: Vault.Key Double
+jwtDurKey = unsafePerformIO Vault.newKey
+{-# NOINLINE jwtDurKey #-}
+
+getJwtDur :: Wai.Request -> Maybe Double
+getJwtDur =  Vault.lookup jwtDurKey . Wai.vault
+
+getRole :: Wai.Request -> Maybe BS.ByteString
+getRole req = authRole <$> (rightToMaybe =<< getResult req)

src/PostgREST/CLI.hs

@@ -11,7 +11,6 @@ module PostgREST.CLI
 import qualified Data.Aeson                 as JSON
 import qualified Data.ByteString.Char8      as BS
 import qualified Data.ByteString.Lazy       as LBS
-import qualified Hasql.Pool                 as SQL
 import qualified Hasql.Transaction.Sessions as SQL
 import qualified Options.Applicative        as O
 
@@ -20,9 +19,8 @@ import Text.Heredoc (str)
 
 import PostgREST.AppState    (AppState)
 import PostgREST.Config      (AppConfig (..))
-import PostgREST.DbStructure (queryDbStructure)
+import PostgREST.SchemaCache (querySchemaCache)
 import PostgREST.Version     (prettyVersion)
-import PostgREST.Workers     (reReadConfig)
 
 import qualified PostgREST.App      as App
 import qualified PostgREST.AppState as AppState
@@ -31,44 +29,38 @@ import qualified PostgREST.Config   as Config
 import Protolude hiding (hPutStrLn)
 
 
-main :: App.SignalHandlerInstaller -> Maybe App.SocketRunner -> CLI -> IO ()
-main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do
+main :: CLI -> IO ()
+main CLI{cliCommand, cliPath} = do
   conf@AppConfig{..} <-
-    either panic identity <$> Config.readAppConfig mempty cliPath Nothing
-  appState <- AppState.init conf
+    either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty
 
-  -- Override the config with config options from the db
-  -- TODO: the same operation is repeated on connectionWorker, ideally this
-  -- would be done only once, but dump CmdDumpConfig needs it for tests.
-  when configDbConfig $ reReadConfig True appState
+  -- Per https://github.com/PostgREST/postgrest/issues/268, we want to
+  -- explicitly close the connections to PostgreSQL on shutdown.
+  -- 'AppState.destroy' takes care of that.
+  bracket
+    (AppState.init conf)
+    AppState.destroy
+    (\appState -> case cliCommand of
+      CmdDumpConfig -> do
+        when configDbConfig $ AppState.reReadConfig True appState
+        putStr . Config.toText =<< AppState.getConfig appState
+      CmdDumpSchema -> putStrLn =<< dumpSchema appState
+      CmdRun -> App.run appState)
 
-  exec cliCommand appState
-  where
-    exec :: Command -> AppState -> IO ()
-    exec CmdDumpConfig appState = putStr . Config.toText =<< AppState.getConfig appState
-    exec CmdDumpSchema appState = putStrLn =<< dumpSchema appState
-    exec CmdRun appState = App.run installSignalHandlers runAppWithSocket appState
-
--- | Dump DbStructure schema to JSON
+-- | Dump SchemaCache schema to JSON
 dumpSchema :: AppState -> IO LBS.ByteString
 dumpSchema appState = do
-  AppConfig{..} <- AppState.getConfig appState
-  actualPgVersion <- AppState.getPgVersion appState
+  conf@AppConfig{..} <- AppState.getConfig appState
   result <-
     let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
-    SQL.use (AppState.getPool appState) $
+    AppState.usePool appState conf $
       transaction SQL.ReadCommitted SQL.Read $
-        queryDbStructure
-          (toList configDbSchemas)
-          configDbExtraSearchPath
-          actualPgVersion
-          configDbPreparedStatements
-  SQL.release $ AppState.getPool appState
+        querySchemaCache conf
   case result of
     Left e -> do
       hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e
       exitFailure
-    Right dbStructure -> return $ JSON.encode dbStructure
+    Right sCache -> return $ JSON.encode sCache
 
 -- | Command line interface options
 data CLI = CLI
@@ -82,13 +74,13 @@ data Command
   | CmdDumpSchema
 
 -- | Read command line interface options. Also prints help.
-readCLIShowHelp :: Bool -> IO CLI
-readCLIShowHelp hasEnvironment =
+readCLIShowHelp :: IO CLI
+readCLIShowHelp =
   O.customExecParser prefs opts
   where
     prefs = O.prefs $ O.showHelpOnError <> O.showHelpOnEmpty
-    opts = O.info parser $ O.fullDesc <> progDesc <> footer
-    parser = O.helper <*> exampleParser <*> cliParser
+    opts = O.info parser $ O.fullDesc <> progDesc
+    parser = O.helper <*> versionFlag <*> exampleParser <*> cliParser
 
     progDesc =
       O.progDesc $
@@ -96,10 +88,11 @@ readCLIShowHelp hasEnvironment =
         <> BS.unpack prettyVersion
         <> " / create a REST API to an existing Postgres database"
 
-    footer =
-      O.footer $
-        "To run PostgREST, please pass the FILENAME argument"
-        <> " or set PGRST_ environment variables."
+    versionFlag =
+      O.infoOption ("PostgREST " <> BS.unpack prettyVersion) $
+        O.long "version"
+        <> O.short 'v'
+        <> O.help "Show the version information"
 
     exampleParser =
       O.infoOption exampleConfigFile $
@@ -111,12 +104,12 @@ readCLIShowHelp hasEnvironment =
     cliParser =
       CLI
         <$> (dumpConfigFlag <|> dumpSchemaFlag)
-        <*> optionalIf hasEnvironment configFileOption
+        <*> O.optional configFileOption
 
     configFileOption =
       O.strArgument $
         O.metavar "FILENAME"
-        <> O.help "Path to configuration file (optional with PGRST_ environment variables)"
+        <> O.help "Path to configuration file"
 
     dumpConfigFlag =
       O.flag CmdRun CmdDumpConfig $
@@ -128,36 +121,13 @@ readCLIShowHelp hasEnvironment =
         O.long "dump-schema"
         <> O.help "Dump loaded schema as JSON and exit (for debugging, output structure is unstable)"
 
-    optionalIf :: Alternative f => Bool -> f a -> f (Maybe a)
-    optionalIf True  = O.optional
-    optionalIf False = fmap Just
-
 exampleConfigFile :: [Char]
 exampleConfigFile =
-  [str|### REQUIRED:
-      |db-uri = "postgres://user:pass@localhost:5432/dbname"
-      |db-schema = "public"
-      |db-anon-role = "postgres"
+  [str|## Admin server used for checks. It's disabled by default unless a port is specified.
+      |# admin-server-port = 3001
       |
-      |### OPTIONAL:
-      |## number of open connections in the pool
-      |db-pool = 10
-      |
-      |## Time to live, in seconds, for an idle database pool connection.
-      |db-pool-timeout = 10
-      |
-      |## extra schemas to add to the search_path of every request
-      |db-extra-search-path = "public"
-      |
-      |## limit rows in response
-      |# db-max-rows = 1000
-      |
-      |## stored proc to exec immediately after auth
-      |# db-pre-request = "stored_proc_name"
-      |
-      |## stored proc that overrides the root "/" spec
-      |## it must be inside the db-schema
-      |# db-root-spec = "stored_proc_name"
+      |## The database role to use when no client authentication is provided
+      |# db-anon-role = "anon"
       |
       |## Notification channel for reloading the schema cache
       |db-channel = "pgrst"
@@ -168,56 +138,96 @@ exampleConfigFile =
       |## Enable in-database configuration
       |db-config = true
       |
-      |## Determine if GUC request settings for headers, cookies and jwt claims use the legacy names (string with dashes, invalid starting from PostgreSQL v14) with text values instead of the new names (string without dashes, valid on all PostgreSQL versions) with json values.
-      |## For PostgreSQL v14 and up, this setting will be ignored.
-      |db-use-legacy-gucs = true
+      |## Function for in-database configuration
+      |## db-pre-config = "postgrest.pre_config"
       |
-      |## how to terminate database transactions
-      |## possible values are:
+      |## Extra schemas to add to the search_path of every request
+      |db-extra-search-path = "public"
+      |
+      |## Limit rows in response
+      |# db-max-rows = 1000
+      |
+      |## Allow getting the EXPLAIN plan through the `Accept: application/vnd.pgrst.plan` header
+      |# db-plan-enabled = false
+      |
+      |## Number of open connections in the pool
+      |db-pool = 10
+      |
+      |## Time in seconds to wait to acquire a slot from the connection pool
+      |# db-pool-acquisition-timeout = 10
+      |
+      |## Time in seconds after which to recycle pool connections
+      |# db-pool-max-lifetime = 1800
+      |
+      |## Time in seconds after which to recycle unused pool connections
+      |# db-pool-max-idletime = 30
+      |
+      |## Allow automatic database connection retrying
+      |# db-pool-automatic-recovery = true
+      |
+      |## Stored proc to exec immediately after auth
+      |# db-pre-request = "stored_proc_name"
+      |
+      |## Enable or disable prepared statements. disabling is only necessary when behind a connection pooler.
+      |## When disabled, statements will be parametrized but won't be prepared.
+      |db-prepared-statements = true
+      |
+      |## The name of which database schema to expose to REST clients
+      |db-schemas = "public"
+      |
+      |## How to terminate database transactions
+      |## Possible values are:
       |## commit (default)
-      |##   transaction is always committed, this can not be overriden
+      |##   Transaction is always committed, this can not be overriden
       |## commit-allow-override
-      |##   transaction is committed, but can be overriden with Prefer tx=rollback header
+      |##   Transaction is committed, but can be overriden with Prefer tx=rollback header
       |## rollback
-      |##   transaction is always rolled back, this can not be overriden
+      |##   Transaction is always rolled back, this can not be overriden
       |## rollback-allow-override
-      |##   transaction is rolled back, but can be overriden with Prefer tx=commit header
+      |##   Transaction is rolled back, but can be overriden with Prefer tx=commit header
       |db-tx-end = "commit"
       |
-      |## enable or disable prepared statements. disabling is only necessary when behind a connection pooler.
-      |## when disabled, statements will be parametrized but won't be prepared.
-      |db-prepared-statements = true
+      |## The standard connection URI format, documented at
+      |## https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING
+      |db-uri = "postgresql://"
+      |
+      |# jwt-aud = "your_audience_claim"
+      |
+      |## Jspath to the role claim key
+      |jwt-role-claim-key = ".role"
+      |
+      |## Choose a secret, JSON Web Key (or set) to enable JWT auth
+      |## (use "@filename" to load from separate file)
+      |# jwt-secret = "secret_with_at_least_32_characters"
+      |jwt-secret-is-base64 = false
+      |
+      |## Enables and set JWT Cache max lifetime, disables caching with 0
+      |# jwt-cache-max-lifetime = 0
+      |
+      |## Logging level, the admitted values are: crit, error, warn and info.
+      |log-level = "error"
+      |
+      |## Determine if the OpenAPI output should follow or ignore role privileges or be disabled entirely.
+      |## Admitted values: follow-privileges, ignore-privileges, disabled
+      |openapi-mode = "follow-privileges"
+      |
+      |## Base url for the OpenAPI output
+      |openapi-server-proxy-uri = ""
+      |
+      |## Configurable CORS origins
+      |# server-cors-allowed-origins = ""
       |
       |server-host = "!4"
       |server-port = 3000
       |
-      |## unix socket location
+      |## Allow getting the request-response timing information through the `Server-Timing` header
+      |server-timing-enabled = false
+      |
+      |## Unix socket location
       |## if specified it takes precedence over server-port
       |# server-unix-socket = "/tmp/pgrst.sock"
       |
-      |## unix socket file mode
-      |## when none is provided, 660 is applied by default
+      |## Unix socket file mode
+      |## When none is provided, 660 is applied by default
       |# server-unix-socket-mode = "660"
-      |
-      |## determine if the OpenAPI output should follow or ignore role privileges or be disabled entirely
-      |## admitted values: follow-privileges, ignore-privileges, disabled
-      |openapi-mode = "follow-privileges"
-      |
-      |## base url for the OpenAPI output
-      |openapi-server-proxy-uri = ""
-      |
-      |## choose a secret, JSON Web Key (or set) to enable JWT auth
-      |## (use "@filename" to load from separate file)
-      |# jwt-secret = "secret_with_at_least_32_characters"
-      |# jwt-aud = "your_audience_claim"
-      |jwt-secret-is-base64 = false
-      |
-      |## jspath to the role claim key
-      |jwt-role-claim-key = ".role"
-      |
-      |## content types to produce raw output
-      |# raw-media-types="image/png, image/jpg"
-      |
-      |## logging level, the admitted values are: crit, error, warn and info.
-      |log-level = "error"
       |]

src/PostgREST/Config.hs

@@ -24,6 +24,7 @@ module PostgREST.Config
   , readPGRSTEnvironment
   , toURI
   , parseSecret
+  , addFallbackAppName
   ) where
 
 import qualified Crypto.JOSE.Types      as JOSE
@@ -32,6 +33,7 @@ import qualified Data.Aeson             as JSON
 import qualified Data.ByteString        as BS
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Lazy   as LBS
+import qualified Data.CaseInsensitive   as CI
 import qualified Data.Configurator      as C
 import qualified Data.Map.Strict        as M
 import qualified Data.Text              as T
@@ -46,56 +48,74 @@ import Data.List               (lookup)
 import Data.List.NonEmpty      (fromList, toList)
 import Data.Maybe              (fromJust)
 import Data.Scientific         (floatingOrInteger)
-import Data.Time.Clock         (NominalDiffTime)
+import Network.URI             (escapeURIString,
+                                isUnescapedInURIComponent, parseURI,
+                                uriQuery)
 import Numeric                 (readOct, showOct)
 import System.Environment      (getEnvironment)
 import System.Posix.Types      (FileMode)
 
+import PostgREST.Config.Database         (RoleIsolationLvl,
+                                          RoleSettings)
 import PostgREST.Config.JSPath           (JSPath, JSPathExp (..),
                                           dumpJSPath, pRoleClaimKey)
 import PostgREST.Config.Proxy            (Proxy (..),
                                           isMalformedProxyUri, toURI)
-import PostgREST.DbStructure.Identifiers (QualifiedIdentifier, dumpQi,
+import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier, dumpQi,
                                           toQi)
 
 import Protolude hiding (Proxy, toList)
 
 
 data AppConfig = AppConfig
-  { configAppSettings           :: [(Text, Text)]
-  , configDbAnonRole            :: Text
-  , configDbChannel             :: Text
-  , configDbChannelEnabled      :: Bool
-  , configDbExtraSearchPath     :: [Text]
-  , configDbMaxRows             :: Maybe Integer
-  , configDbPoolSize            :: Int
-  , configDbPoolTimeout         :: NominalDiffTime
-  , configDbPreRequest          :: Maybe QualifiedIdentifier
-  , configDbPreparedStatements  :: Bool
-  , configDbRootSpec            :: Maybe QualifiedIdentifier
-  , configDbSchemas             :: NonEmpty Text
-  , configDbConfig              :: Bool
-  , configDbTxAllowOverride     :: Bool
-  , configDbTxRollbackAll       :: Bool
-  , configDbUri                 :: Text
-  , configDbUseLegacyGucs       :: Bool
-  , configFilePath              :: Maybe FilePath
-  , configJWKS                  :: Maybe JWKSet
-  , configJwtAudience           :: Maybe StringOrURI
-  , configJwtRoleClaimKey       :: JSPath
-  , configJwtSecret             :: Maybe BS.ByteString
-  , configJwtSecretIsBase64     :: Bool
-  , configLogLevel              :: LogLevel
-  , configOpenApiMode           :: OpenAPIMode
-  , configOpenApiServerProxyUri :: Maybe Text
-  , configRawMediaTypes         :: [BS.ByteString]
-  , configServerHost            :: Text
-  , configServerPort            :: Int
-  , configServerUnixSocket      :: Maybe FilePath
-  , configServerUnixSocketMode  :: FileMode
+  { configAppSettings              :: [(Text, Text)]
+  , configDbAggregates             :: Bool
+  , configDbAnonRole               :: Maybe BS.ByteString
+  , configDbChannel                :: Text
+  , configDbChannelEnabled         :: Bool
+  , configDbExtraSearchPath        :: [Text]
+  , configDbMaxRows                :: Maybe Integer
+  , configDbPlanEnabled            :: Bool
+  , configDbPoolSize               :: Int
+  , configDbPoolAcquisitionTimeout :: Int
+  , configDbPoolMaxLifetime        :: Int
+  , configDbPoolMaxIdletime        :: Int
+  , configDbPoolAutomaticRecovery  :: Bool
+  , configDbPreRequest             :: Maybe QualifiedIdentifier
+  , configDbPreparedStatements     :: Bool
+  , configDbRootSpec               :: Maybe QualifiedIdentifier
+  , configDbSchemas                :: NonEmpty Text
+  , configDbConfig                 :: Bool
+  , configDbPreConfig              :: Maybe QualifiedIdentifier
+  , configDbTxAllowOverride        :: Bool
+  , configDbTxRollbackAll          :: Bool
+  , configDbUri                    :: Text
+  , configFilePath                 :: Maybe FilePath
+  , configJWKS                     :: Maybe JWKSet
+  , configJwtAudience              :: Maybe StringOrURI
+  , configJwtRoleClaimKey          :: JSPath
+  , configJwtSecret                :: Maybe BS.ByteString
+  , configJwtSecretIsBase64        :: Bool
+  , configJwtCacheMaxLifetime      :: Int
+  , configLogLevel                 :: LogLevel
+  , configOpenApiMode              :: OpenAPIMode
+  , configOpenApiSecurityActive    :: Bool
+  , configOpenApiServerProxyUri    :: Maybe Text
+  , configServerCorsAllowedOrigins :: Maybe [Text]
+  , configServerHost               :: Text
+  , configServerPort               :: Int
+  , configServerTraceHeader        :: Maybe (CI.CI BS.ByteString)
+  , configServerTimingEnabled      :: Bool
+  , configServerUnixSocket         :: Maybe FilePath
+  , configServerUnixSocketMode     :: FileMode
+  , configAdminServerPort          :: Maybe Int
+  , configRoleSettings             :: RoleSettings
+  , configRoleIsoLvl               :: RoleIsolationLvl
+  , configInternalSCSleep          :: Maybe Int32
   }
 
 data LogLevel = LogCrit | LogError | LogWarn | LogInfo
+  deriving (Eq, Ord)
 
 dumpLogLevel :: LogLevel -> Text
 dumpLogLevel = \case
@@ -120,33 +140,43 @@ toText conf =
   where
     -- apply conf to all pgrst settings
     pgrstSettings = (\(k, v) -> (k, v conf)) <$>
-      [("db-anon-role",              q . configDbAnonRole)
+      [("db-aggregates-enabled",         T.toLower . show . configDbAggregates)
+      ,("db-anon-role",              q . T.decodeUtf8 . fromMaybe "" . configDbAnonRole)
       ,("db-channel",                q . configDbChannel)
       ,("db-channel-enabled",            T.toLower . show . configDbChannelEnabled)
       ,("db-extra-search-path",      q . T.intercalate "," . configDbExtraSearchPath)
       ,("db-max-rows",                   maybe "\"\"" show . configDbMaxRows)
+      ,("db-plan-enabled",               T.toLower . show . configDbPlanEnabled)
       ,("db-pool",                       show . configDbPoolSize)
-      ,("db-pool-timeout",               show . floor . configDbPoolTimeout)
+      ,("db-pool-acquisition-timeout",   show . configDbPoolAcquisitionTimeout)
+      ,("db-pool-max-lifetime",          show . configDbPoolMaxLifetime)
+      ,("db-pool-max-idletime",          show . configDbPoolMaxIdletime)
+      ,("db-pool-automatic-recovery",    T.toLower . show . configDbPoolAutomaticRecovery)
       ,("db-pre-request",            q . maybe mempty dumpQi . configDbPreRequest)
       ,("db-prepared-statements",        T.toLower . show . configDbPreparedStatements)
       ,("db-root-spec",              q . maybe mempty dumpQi . configDbRootSpec)
       ,("db-schemas",                q . T.intercalate "," . toList . configDbSchemas)
-      ,("db-config",                 q . T.toLower . show . configDbConfig)
+      ,("db-config",                     T.toLower . show . configDbConfig)
+      ,("db-pre-config",             q . maybe mempty dumpQi . configDbPreConfig)
       ,("db-tx-end",                 q . showTxEnd)
       ,("db-uri",                    q . configDbUri)
-      ,("db-use-legacy-gucs",            T.toLower . show . configDbUseLegacyGucs)
       ,("jwt-aud",                       T.decodeUtf8 . LBS.toStrict . JSON.encode . maybe "" toJSON . configJwtAudience)
       ,("jwt-role-claim-key",        q . T.intercalate mempty . fmap dumpJSPath . configJwtRoleClaimKey)
       ,("jwt-secret",                q . T.decodeUtf8 . showJwtSecret)
       ,("jwt-secret-is-base64",          T.toLower . show . configJwtSecretIsBase64)
+      ,("jwt-cache-max-lifetime",                   show . configJwtCacheMaxLifetime)
       ,("log-level",                 q . dumpLogLevel . configLogLevel)
       ,("openapi-mode",              q . dumpOpenApiMode . configOpenApiMode)
+      ,("openapi-security-active",       T.toLower . show . configOpenApiSecurityActive)
       ,("openapi-server-proxy-uri",  q . fromMaybe mempty . configOpenApiServerProxyUri)
-      ,("raw-media-types",           q . T.decodeUtf8 . BS.intercalate "," . configRawMediaTypes)
+      ,("server-cors-allowed-origins",      q . maybe "" (T.intercalate ",") . configServerCorsAllowedOrigins)
       ,("server-host",               q . configServerHost)
       ,("server-port",                   show . configServerPort)
+      ,("server-trace-header",       q . T.decodeUtf8 . maybe mempty CI.original . configServerTraceHeader)
+      ,("server-timing-enabled",         T.toLower . show . configServerTimingEnabled)
       ,("server-unix-socket",        q . maybe mempty T.pack . configServerUnixSocket)
       ,("server-unix-socket-mode",   q . T.pack . showSocketMode)
+      ,("admin-server-port",             maybe "\"\"" show . configAdminServerPort)
       ]
 
     -- quote all app.settings
@@ -173,20 +203,20 @@ class JustIfMaybe a b where
   justIfMaybe :: a -> b
 
 instance JustIfMaybe a a where
-  justIfMaybe a = a
+  justIfMaybe = identity
 
 instance JustIfMaybe a (Maybe a) where
-  justIfMaybe a = Just a
+  justIfMaybe = Just
 
 -- | Reads and parses the config and overrides its parameters from env vars,
 -- files or db settings.
-readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> IO (Either Text AppConfig)
-readAppConfig dbSettings optPath prevDbUri = do
+readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> IO (Either Text AppConfig)
+readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl = do
   env <- readPGRSTEnvironment
   -- if no filename provided, start with an empty map to read config from environment
   conf <- maybe (return $ Right M.empty) loadConfig optPath
 
-  case C.runParser (parser optPath env dbSettings) =<< mapLeft show conf of
+  case C.runParser (parser optPath env dbSettings roleSettings roleIsolationLvl) =<< mapLeft show conf of
     Left err ->
       return . Left $ "Error in config " <> err
     Right parsedConfig ->
@@ -201,31 +231,36 @@ readAppConfig dbSettings optPath prevDbUri = do
       decodeJWKS <$>
         (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig)
 
-parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> C.Parser C.Config AppConfig
-parser optPath env dbSettings =
+parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> C.Parser C.Config AppConfig
+parser optPath env dbSettings roleSettings roleIsolationLvl =
   AppConfig
     <$> parseAppSettings "app.settings"
-    <*> reqString "db-anon-role"
+    <*> (fromMaybe False <$> optBool "db-aggregates-enabled")
+    <*> (fmap encodeUtf8 <$> optString "db-anon-role")
     <*> (fromMaybe "pgrst" <$> optString "db-channel")
     <*> (fromMaybe True <$> optBool "db-channel-enabled")
     <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path")
     <*> optWithAlias (optInt "db-max-rows")
                      (optInt "max-rows")
+    <*> (fromMaybe False <$> optBool "db-plan-enabled")
     <*> (fromMaybe 10 <$> optInt "db-pool")
-    <*> (fromIntegral . fromMaybe 10 <$> optInt "db-pool-timeout")
+    <*> (fromMaybe 10 <$> optInt "db-pool-acquisition-timeout")
+    <*> (fromMaybe 1800 <$> optInt "db-pool-max-lifetime")
+    <*> (fromMaybe 30 <$> optWithAlias (optInt "db-pool-timeout")
+                                       (optInt "db-pool-max-idletime"))
+    <*> (fromMaybe True <$> optBool "db-pool-automatic-recovery")
     <*> (fmap toQi <$> optWithAlias (optString "db-pre-request")
                                     (optString "pre-request"))
     <*> (fromMaybe True <$> optBool "db-prepared-statements")
     <*> (fmap toQi <$> optWithAlias (optString "db-root-spec")
                                     (optString "root-spec"))
-    <*> (fromList . splitOnCommas <$> reqWithAlias (optValue "db-schemas")
-                                                   (optValue "db-schema")
-                                                   "missing key: either db-schemas or db-schema must be set")
+    <*> (fromList . maybe ["public"] splitOnCommas <$> optWithAlias (optValue "db-schemas")
+                                                                    (optValue "db-schema"))
     <*> (fromMaybe True <$> optBool "db-config")
+    <*> (fmap toQi <$> optString "db-pre-config")
     <*> parseTxEnd "db-tx-end" snd
     <*> parseTxEnd "db-tx-end" fst
-    <*> reqString "db-uri"
-    <*> (fromMaybe True <$> optBool "db-use-legacy-gucs")
+    <*> (fromMaybe "postgresql://" <$> optString "db-uri")
     <*> pure optPath
     <*> pure Nothing
     <*> parseJwtAudience "jwt-aud"
@@ -234,14 +269,22 @@ parser optPath env dbSettings =
     <*> (fromMaybe False <$> optWithAlias
           (optBool "jwt-secret-is-base64")
           (optBool "secret-is-base64"))
+    <*> (fromMaybe 0 <$> optInt "jwt-cache-max-lifetime")
     <*> parseLogLevel "log-level"
     <*> parseOpenAPIMode "openapi-mode"
+    <*> (fromMaybe False <$> optBool "openapi-security-active")
     <*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri"
-    <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")
+    <*> parseCORSAllowedOrigins "server-cors-allowed-origins"
     <*> (fromMaybe "!4" <$> optString "server-host")
     <*> (fromMaybe 3000 <$> optInt "server-port")
+    <*> (fmap (CI.mk . encodeUtf8) <$> optString "server-trace-header")
+    <*> (fromMaybe False <$> optBool "server-timing-enabled")
     <*> (fmap T.unpack <$> optString "server-unix-socket")
     <*> parseSocketFileMode "server-unix-socket-mode"
+    <*> optInt "admin-server-port"
+    <*> pure roleSettings
+    <*> pure roleIsolationLvl
+    <*> optInt "internal-schema-cache-sleep"
   where
     parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
     parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value
@@ -314,14 +357,10 @@ parser optPath env dbSettings =
         Nothing  -> pure [JSPKey "role"]
         Just rck -> either (fail . show) pure $ pRoleClaimKey rck
 
-    reqWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> [Char] -> C.Parser C.Config a
-    reqWithAlias orig alias err =
-      orig >>= \case
-        Just v  -> pure v
-        Nothing ->
-          alias >>= \case
-            Just v  -> pure v
-            Nothing -> fail err
+    parseCORSAllowedOrigins k =
+      optString k >>= \case
+        Nothing   -> pure Nothing
+        Just orig -> pure $ Just (T.strip <$> T.splitOn "," orig)
 
     optWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a)
     optWithAlias orig alias =
@@ -329,9 +368,6 @@ parser optPath env dbSettings =
         Just v  -> pure $ Just v
         Nothing -> alias
 
-    reqString :: C.Key -> C.Parser C.Config Text
-    reqString k = overrideFromDbOrEnvironment C.required k coerceText
-
     optString :: C.Key -> C.Parser C.Config (Maybe Text)
     optString k = mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText
 
@@ -348,20 +384,14 @@ parser optPath env dbSettings =
                                (C.Key -> C.Parser C.Value a -> C.Parser C.Config b) ->
                                C.Key -> (C.Value -> a) -> C.Parser C.Config b
     overrideFromDbOrEnvironment necessity key coercion =
-      case reloadableDbSetting <|> M.lookup envVarName env of
+      case dbConf <|> M.lookup envVarName env of
         Just dbOrEnvVal -> pure $ justIfMaybe $ coercion $ C.String dbOrEnvVal
-        Nothing  -> necessity key (coercion <$> C.value)
+        Nothing         -> necessity key (coercion <$> C.value)
       where
         dashToUnderscore '-' = '_'
         dashToUnderscore c   = c
         envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key)
-        reloadableDbSetting =
-          let dbSettingName = T.pack $ dashToUnderscore <$> toS key in
-          if dbSettingName `notElem` [
-            "server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "log_level",
-            "db_anon_role", "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_timeout", "db_config"]
-          then lookup dbSettingName dbSettings
-          else Nothing
+        dbConf = lookup (T.pack $ dashToUnderscore <$> toS key) dbSettings
 
     coerceText :: C.Value -> Text
     coerceText (C.String s) = s
@@ -369,17 +399,17 @@ parser optPath env dbSettings =
 
     coerceInt :: (Read i, Integral i) => C.Value -> Maybe i
     coerceInt (C.Number x) = rightToMaybe $ floatingOrInteger x
-    coerceInt (C.String x) = readMaybe $ toS x
+    coerceInt (C.String x) = readMaybe x
     coerceInt _            = Nothing
 
     coerceBool :: C.Value -> Maybe Bool
     coerceBool (C.Bool b)   = Just b
     coerceBool (C.String s) =
       -- parse all kinds of text: True, true, TRUE, "true", ...
-      case readMaybe . toS $ T.toTitle $ T.filter isAlpha $ toS s of
+      case readMaybe $ T.toTitle $ T.filter isAlpha $ toS s of
         Just b  -> Just b
         -- numeric instead?
-        Nothing -> (> 0) <$> (readMaybe $ toS s :: Maybe Integer)
+        Nothing -> (> 0) <$> (readMaybe s :: Maybe Integer)
     coerceBool _            = Nothing
 
     splitOnCommas :: C.Value -> [Text]
@@ -448,3 +478,41 @@ type Environment = M.Map [Char] Text
 readPGRSTEnvironment :: IO Environment
 readPGRSTEnvironment =
   M.map T.pack . M.fromList . filter (isPrefixOf "PGRST_" . fst) <$> getEnvironment
+
+-- | Adds a `fallback_application_name` value to the connection string. This allows querying the PostgREST version on pg_stat_activity.
+--
+-- >>> let ver = "11.1.0 (5a04ec7)"::ByteString
+-- >>> let strangeVer = "11'1&0@#$%,.:\"[]{}?+^()=asdfqwer"::ByteString
+--
+-- >>> addFallbackAppName ver "postgres://user:pass@host:5432/postgres"
+-- "postgres://user:pass@host:5432/postgres?fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
+--
+-- >>> addFallbackAppName ver "postgres://user:pass@host:5432/postgres?"
+-- "postgres://user:pass@host:5432/postgres?fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
+--
+-- >>> addFallbackAppName ver "postgres:///postgres?host=server&port=5432"
+-- "postgres:///postgres?host=server&port=5432&fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
+--
+-- >>> addFallbackAppName ver "postgresql://"
+-- "postgresql://?fallback_application_name=PostgREST%2011.1.0%20%285a04ec7%29"
+--
+-- >>> addFallbackAppName strangeVer "postgres:///postgres?host=server&port=5432"
+-- "postgres:///postgres?host=server&port=5432&fallback_application_name=PostgREST%2011%271%260%40%23%24%25%2C.%3A%22%5B%5D%7B%7D%3F%2B%5E%28%29%3Dasdfqwer"
+--
+-- >>> addFallbackAppName ver "postgres://user:invalid_chars[]#@host:5432/postgres"
+-- "postgres://user:invalid_chars[]#@host:5432/postgres"
+--
+-- >>> addFallbackAppName ver "invalid_uri1=val1 invalid_uri2=val2"
+-- "invalid_uri1=val1 invalid_uri2=val2"
+addFallbackAppName :: ByteString -> Text -> Text
+addFallbackAppName version dbUri = dbUri <>
+  case uriQuery <$> parseURI (toS dbUri) of
+    -- Does not add the application name to key=val connection strings or invalid URIs
+    Nothing  -> mempty
+    Just ""  -> "?" <> uriFmt
+    Just "?" -> uriFmt
+    _        -> "&" <> uriFmt
+  where
+    uriFmt = pKeyWord <> toS (escapeURIString isUnescapedInURIComponent $ toS pgrstVer)
+    pKeyWord = "fallback_application_name="
+    pgrstVer = "PostgREST " <> T.decodeUtf8 version

src/PostgREST/Config/Database.hs

@@ -1,56 +1,203 @@
 {-# LANGUAGE QuasiQuotes #-}
 
 module PostgREST.Config.Database
-  ( queryDbSettings
+  ( pgVersionStatement
+  , queryDbSettings
   , queryPgVersion
+  , queryRoleSettings
+  , RoleSettings
+  , RoleIsolationLvl
+  , TimezoneNames
+  , toIsolationLevel
   ) where
 
-import PostgREST.Config.PgVersion (PgVersion (..))
+import Control.Arrow ((***))
+
+import PostgREST.Config.PgVersion (PgVersion (..), pgVersion150)
+
+import qualified Data.HashMap.Strict as HM
 
 import qualified Hasql.Decoders             as HD
 import qualified Hasql.Encoders             as HE
-import qualified Hasql.Pool                 as SQL
 import           Hasql.Session              (Session, statement)
 import qualified Hasql.Statement            as SQL
 import qualified Hasql.Transaction          as SQL
 import qualified Hasql.Transaction.Sessions as SQL
 
-import Text.InterpolatedString.Perl6 (q)
+import Text.InterpolatedString.Perl6 (q, qc)
 
 import Protolude
 
-queryPgVersion :: Session PgVersion
-queryPgVersion = statement mempty $ SQL.Statement sql HE.noParams versionRow False
+type RoleSettings     = (HM.HashMap ByteString (HM.HashMap ByteString ByteString))
+type RoleIsolationLvl = HM.HashMap ByteString SQL.IsolationLevel
+type TimezoneNames    = Set ByteString -- cache timezone names for prefer timezone=
+
+toIsolationLevel :: (Eq a, IsString a) => a -> SQL.IsolationLevel
+toIsolationLevel a = case a of
+  "repeatable read" -> SQL.RepeatableRead
+  "serializable"    -> SQL.Serializable
+  _                 -> SQL.ReadCommitted
+
+prefix :: Text
+prefix = "pgrst."
+
+-- | In-db settings names
+dbSettingsNames :: [Text]
+dbSettingsNames =
+  (prefix <>) <$>
+  ["db_aggregates_enabled"
+  ,"db_anon_role"
+  ,"db_pre_config"
+  ,"db_extra_search_path"
+  ,"db_max_rows"
+  ,"db_plan_enabled"
+  ,"db_pre_request"
+  ,"db_prepared_statements"
+  ,"db_root_spec"
+  ,"db_schemas"
+  ,"db_tx_end"
+  ,"jwt_aud"
+  ,"jwt_role_claim_key"
+  ,"jwt_secret"
+  ,"jwt_secret_is_base64"
+  ,"jwt_cache_max_lifetime"
+  ,"openapi_mode"
+  ,"openapi_security_active"
+  ,"openapi_server_proxy_uri"
+  ,"raw_media_types"
+  ,"server_trace_header"
+  ,"server_timing_enabled"
+  ]
+
+queryPgVersion :: Bool -> Session PgVersion
+queryPgVersion prepared = statement mempty $ pgVersionStatement prepared
+
+pgVersionStatement :: Bool -> SQL.Statement () PgVersion
+pgVersionStatement = SQL.Statement sql HE.noParams versionRow
   where
     sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"
     versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text
 
-queryDbSettings :: SQL.Pool -> Bool -> IO (Either SQL.UsageError [(Text, Text)])
-queryDbSettings pool prepared =
+-- | Query the in-database configuration. The settings have the following priorities:
+--
+-- 1. Role + with database-specific settings:
+--    ALTER ROLE authenticator IN DATABASE postgres SET <prefix>jwt_aud = 'val';
+-- 2. Role + with settings:
+--    ALTER ROLE authenticator SET <prefix>jwt_aud = 'overridden';
+-- 3. pre-config function:
+--    CREATE FUNCTION pre_config() .. PERFORM set_config(<prefix>jwt_aud, 'pre_config_aud'..)
+--
+-- The example above will result in <prefix>jwt_aud = 'val'
+-- A setting on the database only will have no effect: ALTER DATABASE postgres SET <prefix>jwt_aud = 'xx'
+queryDbSettings :: Maybe Text -> Bool -> Session [(Text, Text)]
+queryDbSettings preConfFunc prepared =
   let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
-  SQL.use pool . transaction SQL.ReadCommitted SQL.Read $
-    SQL.statement mempty dbSettingsStatement
+  transaction SQL.ReadCommitted SQL.Read $ SQL.statement dbSettingsNames $ SQL.Statement sql (arrayParam HE.text) decodeSettings prepared
+  where
+    sql = [qc|
+      WITH
+      role_setting AS (
+        SELECT setdatabase as database,
+               unnest(setconfig) as setting
+        FROM pg_catalog.pg_db_role_setting
+        WHERE setrole = CURRENT_USER::regrole::oid
+          AND setdatabase IN (0, (SELECT oid FROM pg_catalog.pg_database WHERE datname = CURRENT_CATALOG))
+      ),
+      kv_settings AS (
+        SELECT database,
+               substr(setting, 1, strpos(setting, '=') - 1) as k,
+               substr(setting, strpos(setting, '=') + 1) as v
+        FROM role_setting
+        {preConfigF}
+      )
+      SELECT DISTINCT ON (key)
+             replace(k, '{prefix}', '') AS key,
+             v AS value
+      FROM kv_settings
+      WHERE k = ANY($1) AND v IS NOT NULL
+      ORDER BY key, database DESC NULLS LAST;
+    |]
+    preConfigF = case preConfFunc of
+      Nothing   -> mempty
+      Just func -> [qc|
+          UNION
+          SELECT
+            null as database,
+            x as k,
+            current_setting(x, true) as v
+          FROM unnest($1) x
+          JOIN {func}() _ ON TRUE
+      |]::Text
+    decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
 
--- | Get db settings from the connection role. Global settings will be overridden by database specific settings.
-dbSettingsStatement :: SQL.Statement () [(Text, Text)]
-dbSettingsStatement = SQL.Statement sql HE.noParams decodeSettings False
+queryRoleSettings :: PgVersion -> Bool -> Session (RoleSettings, RoleIsolationLvl)
+queryRoleSettings pgVer prepared =
+  let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
+  transaction SQL.ReadCommitted SQL.Read $ SQL.statement mempty $ SQL.Statement sql HE.noParams (processRows <$> rows) prepared
   where
     sql = [q|
       with
       role_setting as (
-        select setdatabase, unnest(setconfig) as setting from pg_catalog.pg_db_role_setting
-        where setrole = current_user::regrole::oid
-          and setdatabase in (0, (select oid from pg_catalog.pg_database where datname = current_catalog))
+        select r.rolname, unnest(r.rolconfig) as setting
+        from pg_auth_members m
+        join pg_roles r on r.oid = m.roleid
+        where member = current_user::regrole::oid
       ),
-      kv_settings as (
-        select setdatabase, split_part(setting, '=', 1) as k, split_part(setting, '=', 2) as value from role_setting
-        where setting like 'pgrst.%'
+      kv_settings AS (
+        SELECT
+          rolname,
+          substr(setting, 1, strpos(setting, '=') - 1) as key,
+          lower(substr(setting, strpos(setting, '=') + 1)) as value
+        FROM role_setting
+      ),
+      iso_setting AS (
+        SELECT rolname, value
+        FROM kv_settings
+        WHERE key = 'default_transaction_isolation'
       )
-      select distinct on (key) replace(k, 'pgrst.', '') as key, value
-      from kv_settings
-      order by key, setdatabase desc;
+      select
+        kv.rolname,
+        i.value as iso_lvl,
+        coalesce(array_agg(row(kv.key, kv.value)) filter (where key <> 'default_transaction_isolation'), '{}') as role_settings
+      from kv_settings kv
+      join pg_settings ps on ps.name = kv.key |] <>
+      (if pgVer >= pgVersion150
+        then "and (ps.context = 'user' or has_parameter_privilege(current_user::regrole::oid, ps.name, 'set')) "
+        else "and ps.context = 'user' ") <> [q|
+      left join iso_setting i on i.rolname = kv.rolname
+      group by kv.rolname, i.value;
     |]
-    decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
+
+    processRows :: [(Text, Maybe Text, [(Text, Text)])] -> (RoleSettings, RoleIsolationLvl)
+    processRows rs =
+      let
+        rowsWRoleSettings = [ (x, z) | (x, _, z) <- rs ]
+        rowsWIsolation    = [ (x, y) | (x, Just y, _) <- rs ]
+      in
+      ( HM.fromList $ bimap encodeUtf8 (HM.fromList . ((encodeUtf8 *** encodeUtf8) <$>)) <$> rowsWRoleSettings
+      , HM.fromList $ (encodeUtf8 *** toIsolationLevel) <$> rowsWIsolation
+      )
+
+    rows :: HD.Result [(Text, Maybe Text, [(Text, Text)])]
+    rows = HD.rowList $ (,,) <$> column HD.text <*> nullableColumn HD.text <*> compositeArrayColumn ((,) <$> compositeField HD.text <*> compositeField HD.text)
 
 column :: HD.Value a -> HD.Row a
 column = HD.column . HD.nonNullable
+
+nullableColumn :: HD.Value a -> HD.Row (Maybe a)
+nullableColumn = HD.column . HD.nullable
+
+compositeField :: HD.Value a -> HD.Composite a
+compositeField = HD.field . HD.nonNullable
+
+compositeArrayColumn :: HD.Composite a -> HD.Row [a]
+compositeArrayColumn = arrayColumn . HD.composite
+
+arrayColumn :: HD.Value a -> HD.Row [a]
+arrayColumn = column . HD.listArray . HD.nonNullable
+
+param :: HE.Value a -> HE.Params a
+param = HE.param . HE.nonNullable
+
+arrayParam :: HE.Value a -> HE.Params [a]
+arrayParam = param . HE.foldableArray . HE.nonNullable

src/PostgREST/Config/PgVersion.hs

@@ -9,9 +9,11 @@ module PostgREST.Config.PgVersion
   , pgVersion110
   , pgVersion112
   , pgVersion114
+  , pgVersion120
   , pgVersion121
   , pgVersion130
   , pgVersion140
+  , pgVersion150
   ) where
 
 import qualified Data.Aeson as JSON
@@ -50,6 +52,9 @@ pgVersion112 = PgVersion 110002 "11.2"
 pgVersion114 :: PgVersion
 pgVersion114 = PgVersion 110004 "11.4"
 
+pgVersion120 :: PgVersion
+pgVersion120 = PgVersion 120000 "12.0"
+
 pgVersion121 :: PgVersion
 pgVersion121 = PgVersion 120001 "12.1"
 
@@ -58,3 +63,6 @@ pgVersion130 = PgVersion 130000 "13.0"
 
 pgVersion140 :: PgVersion
 pgVersion140 = PgVersion 140000 "14.0"
+
+pgVersion150 :: PgVersion
+pgVersion150 = PgVersion 150000 "15.0"

src/PostgREST/ContentType.hs

@@ -1,64 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-
-module PostgREST.ContentType
-  ( ContentType(..)
-  , toHeader
-  , toMime
-  , decodeContentType
-  ) where
-
-import qualified Data.ByteString          as BS
-import qualified Data.ByteString.Internal as BS (c2w)
-
-import Network.HTTP.Types.Header (Header, hContentType)
-
-import Protolude
-
--- | Enumeration of currently supported response content types
-data ContentType
-  = CTApplicationJSON
-  | CTSingularJSON
-  | CTTextCSV
-  | CTTextPlain
-  | CTOpenAPI
-  | CTUrlEncoded
-  | CTOctetStream
-  | CTAny
-  | CTOther ByteString
-  deriving (Eq)
-
--- | Convert from ContentType to a full HTTP Header
-toHeader :: ContentType -> Header
-toHeader ct = (hContentType, toMime ct <> charset)
-  where
-    charset = case ct of
-      CTOctetStream -> mempty
-      CTOther _     -> mempty
-      _             -> "; charset=utf-8"
-
--- | Convert from ContentType to a ByteString representing the mime type
-toMime :: ContentType -> ByteString
-toMime CTApplicationJSON = "application/json"
-toMime CTTextCSV         = "text/csv"
-toMime CTTextPlain       = "text/plain"
-toMime CTOpenAPI         = "application/openapi+json"
-toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
-toMime CTUrlEncoded      = "application/x-www-form-urlencoded"
-toMime CTOctetStream     = "application/octet-stream"
-toMime CTAny             = "*/*"
-toMime (CTOther ct)      = ct
-
--- | Convert from ByteString to ContentType. Warning: discards MIME parameters
-decodeContentType :: BS.ByteString -> ContentType
-decodeContentType ct =
-  case BS.takeWhile (/= BS.c2w ';') ct of
-    "application/json"                  -> CTApplicationJSON
-    "text/csv"                          -> CTTextCSV
-    "text/plain"                        -> CTTextPlain
-    "application/openapi+json"          -> CTOpenAPI
-    "application/vnd.pgrst.object+json" -> CTSingularJSON
-    "application/vnd.pgrst.object"      -> CTSingularJSON
-    "application/x-www-form-urlencoded" -> CTUrlEncoded
-    "application/octet-stream"          -> CTOctetStream
-    "*/*"                               -> CTAny
-    ct'                                 -> CTOther ct'

src/PostgREST/Cors.hs

@@ -0,0 +1,46 @@
+{-|
+Module      : PostgREST.Cors
+Description : Wai Middleware to set cors policy.
+-}
+
+{-# LANGUAGE TupleSections #-}
+
+module PostgREST.Cors (middleware) where
+
+import qualified Data.ByteString.Char8       as BS
+import qualified Data.CaseInsensitive        as CI
+import qualified Data.Text.Encoding          as T
+import qualified Network.Wai                 as Wai
+import qualified Network.Wai.Middleware.Cors as Wai
+
+import Data.List (lookup)
+
+import Protolude
+
+middleware :: Maybe [Text] -> Wai.Middleware
+middleware corsAllowedOrigins = Wai.cors $ corsPolicy corsAllowedOrigins
+
+-- | CORS policy to be used in by Wai Cors middleware
+corsPolicy :: Maybe [Text] -> Wai.Request -> Maybe Wai.CorsResourcePolicy
+corsPolicy corsAllowedOrigins req = case lookup "origin" headers of
+  Just _ ->
+    Just Wai.CorsResourcePolicy
+    { Wai.corsOrigins = (, True) . map T.encodeUtf8 <$> corsAllowedOrigins
+    , Wai.corsMethods = ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"]
+    , Wai.corsRequestHeaders = "Authorization" : accHeaders
+    , Wai.corsExposedHeaders = Just
+      [ "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
+      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"]
+    , Wai.corsMaxAge = Just $ 60*60*24
+    , Wai.corsVaryOrigin = False
+    , Wai.corsRequireOrigin = False
+    , Wai.corsIgnoreFailures = True
+    }
+  Nothing -> Nothing
+  where
+    headers = Wai.requestHeaders req
+    accHeaders = case lookup "access-control-request-headers" headers of
+      Just hdrs -> map (CI.mk . BS.strip) $ BS.split ',' hdrs
+       -- Impossible case, Middleware.Cors will not evaluate this when
+       -- the Access-Control-Request-Headers header is not set.
+      Nothing   -> []

src/PostgREST/DbStructure.hs

@@ -1,924 +0,0 @@
-{-|
-Module      : PostgREST.DbStructure
-Description : PostgREST schema cache
-
-This module contains queries that target PostgreSQL system catalogs, these are used to build the schema cache(DbStructure).
-
-The schema cache is necessary for resource embedding, foreign keys are used for inferring the relationships between tables.
-
-These queries are executed once at startup or when PostgREST is reloaded.
--}
-{-# LANGUAGE DeriveAnyClass        #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns        #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeSynonymInstances  #-}
-
-module PostgREST.DbStructure
-  ( DbStructure(..)
-  , queryDbStructure
-  , accessibleTables
-  , accessibleProcs
-  , schemaDescription
-  , tableCols
-  , tablePKCols
-  ) where
-
-import qualified Data.Aeson          as JSON
-import qualified Data.HashMap.Strict as M
-import qualified Data.List           as L
-import qualified Hasql.Decoders      as HD
-import qualified Hasql.Encoders      as HE
-import qualified Hasql.Statement     as SQL
-import qualified Hasql.Transaction   as SQL
-
-import Contravariant.Extras          (contrazip2)
-import Data.Set                      as S (fromList)
-import Data.Text                     (split)
-import Text.InterpolatedString.Perl6 (q)
-
-import PostgREST.Config.PgVersion         (PgVersion, pgVersion100)
-import PostgREST.DbStructure.Identifiers  (QualifiedIdentifier (..),
-                                           Schema, TableName)
-import PostgREST.DbStructure.Proc         (PgType (..),
-                                           ProcDescription (..),
-                                           ProcParam (..),
-                                           ProcVolatility (..),
-                                           ProcsMap, RetType (..))
-import PostgREST.DbStructure.Relationship (Cardinality (..),
-                                           Junction (..),
-                                           PrimaryKey (..),
-                                           Relationship (..))
-import PostgREST.DbStructure.Table        (Column (..), Table (..))
-
-import Protolude
-import Protolude.Unsafe (unsafeHead)
-
-
-data DbStructure = DbStructure
-  { dbTables        :: [Table]
-  , dbColumns       :: [Column]
-  , dbRelationships :: [Relationship]
-  , dbPrimaryKeys   :: [PrimaryKey]
-  , dbProcs         :: ProcsMap
-  }
-  deriving (Generic, JSON.ToJSON)
-
--- TODO Table could hold references to all its Columns
-tableCols :: DbStructure -> Schema -> TableName -> [Column]
-tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs
-
--- TODO Table could hold references to all its PrimaryKeys
-tablePKCols :: DbStructure -> Schema -> TableName -> [Text]
-tablePKCols dbs tSchema tName =  pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)
-
--- | The source table column a view column refers to
-type SourceColumn = (Column, ViewColumn)
-type ViewColumn = Column
-
--- | A SQL query that can be executed independently
-type SqlQuery = ByteString
-
-queryDbStructure :: [Schema] -> [Schema] -> PgVersion -> Bool -> SQL.Transaction DbStructure
-queryDbStructure schemas extraSearchPath pgVer prepared = do
-  SQL.sql "set local schema ''" -- This voids the search path. The following queries need this for getting the fully qualified name(schema.name) of every db object
-  tabs    <- SQL.statement mempty $ allTables pgVer prepared
-  cols    <- SQL.statement schemas $ allColumns tabs prepared
-  srcCols <- SQL.statement (schemas, extraSearchPath) $ pfkSourceColumns cols prepared
-  m2oRels <- SQL.statement mempty $ allM2ORels tabs cols prepared
-  keys    <- SQL.statement mempty $ allPrimaryKeys tabs prepared
-  procs   <- SQL.statement schemas $ allProcs prepared
-
-  let rels = addO2MRels . addM2MRels $ addViewM2ORels srcCols m2oRels
-      keys' = addViewPrimaryKeys srcCols keys
-
-  return $ removeInternal schemas $ DbStructure {
-      dbTables = tabs
-    , dbColumns = cols
-    , dbRelationships = rels
-    , dbPrimaryKeys = keys'
-    , dbProcs = procs
-    }
-
--- | Remove db objects that belong to an internal schema(not exposed through the API) from the DbStructure.
-removeInternal :: [Schema] -> DbStructure -> DbStructure
-removeInternal schemas dbStruct =
-  DbStructure {
-      dbTables        = filter (\x -> tableSchema x `elem` schemas) $ dbTables dbStruct
-    , dbColumns       = filter (\x -> tableSchema (colTable x) `elem` schemas) (dbColumns dbStruct)
-    , dbRelationships = filter (\x -> tableSchema (relTable x) `elem` schemas &&
-                                      tableSchema (relForeignTable x) `elem` schemas &&
-                                      not (hasInternalJunction x)) $ dbRelationships dbStruct
-    , dbPrimaryKeys   = filter (\x -> tableSchema (pkTable x) `elem` schemas) $ dbPrimaryKeys dbStruct
-    , dbProcs         = dbProcs dbStruct -- procs are only obtained from the exposed schemas, no need to filter them.
-    }
-  where
-    hasInternalJunction rel = case relCardinality rel of
-      M2M Junction{junTable} -> tableSchema junTable `notElem` schemas
-      _                      -> False
-
-decodeTables :: HD.Result [Table]
-decodeTables =
-  HD.rowList tblRow
- where
-  tblRow = Table <$> column HD.text
-                 <*> column HD.text
-                 <*> nullableColumn HD.text
-                 <*> column HD.bool
-                 <*> column HD.bool
-                 <*> column HD.bool
-
-decodeColumns :: [Table] -> HD.Result [Column]
-decodeColumns tables =
-  mapMaybe (columnFromRow tables) <$> HD.rowList colRow
- where
-  colRow =
-    (,,,,,,,,)
-      <$> column HD.text
-      <*> column HD.text
-      <*> column HD.text
-      <*> nullableColumn HD.text
-      <*> column HD.bool
-      <*> column HD.text
-      <*> nullableColumn HD.int4
-      <*> nullableColumn HD.text
-      <*> nullableColumn HD.text
-
-decodeRels :: [Table] -> [Column] -> HD.Result [Relationship]
-decodeRels tables cols =
-  mapMaybe (relFromRow tables cols) <$> HD.rowList relRow
- where
-  relRow = (,,,,,,)
-    <$> column HD.text
-    <*> column HD.text
-    <*> column HD.text
-    <*> arrayColumn HD.text
-    <*> column HD.text
-    <*> column HD.text
-    <*> arrayColumn HD.text
-
-decodePks :: [Table] -> HD.Result [PrimaryKey]
-decodePks tables =
-  mapMaybe (pkFromRow tables) <$> HD.rowList pkRow
- where
-  pkRow = (,,) <$> column HD.text <*> column HD.text <*> column HD.text
-
-decodeSourceColumns :: [Column] -> HD.Result [SourceColumn]
-decodeSourceColumns cols =
-  mapMaybe (sourceColumnFromRow cols) <$> HD.rowList srcColRow
- where
-  srcColRow = (,,,,,)
-    <$> column HD.text <*> column HD.text
-    <*> column HD.text <*> column HD.text
-    <*> column HD.text <*> column HD.text
-
-sourceColumnFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe SourceColumn
-sourceColumnFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
-  where
-    col1 = findCol s1 t1 c1
-    col2 = findCol s2 t2 c2
-    findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols
-
-decodeProcs :: HD.Result ProcsMap
-decodeProcs =
-  -- Duplicate rows for a function means they're overloaded, order these by least args according to ProcDescription Ord instance
-  map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addKey) <$> HD.rowList procRow
-  where
-    procRow = ProcDescription
-              <$> column HD.text
-              <*> column HD.text
-              <*> nullableColumn HD.text
-              <*> compositeArrayColumn
-                  (ProcParam
-                  <$> compositeField HD.text
-                  <*> compositeField HD.text
-                  <*> compositeField HD.bool
-                  <*> compositeField HD.bool)
-              <*> (parseRetType
-                  <$> column HD.text
-                  <*> column HD.text
-                  <*> column HD.bool
-                  <*> column HD.bool)
-              <*> (parseVolatility <$> column HD.char)
-              <*> column HD.bool
-
-    addKey :: ProcDescription -> (QualifiedIdentifier, ProcDescription)
-    addKey pd = (QualifiedIdentifier (pdSchema pd) (pdName pd), pd)
-
-    parseRetType :: Text -> Text -> Bool -> Bool -> RetType
-    parseRetType schema name isSetOf isComposite
-      | isSetOf   = SetOf pgType
-      | otherwise = Single pgType
-      where
-        qi = QualifiedIdentifier schema name
-        pgType
-          | isComposite = Composite qi
-          | otherwise   = Scalar
-
-    parseVolatility :: Char -> ProcVolatility
-    parseVolatility v | v == 'i' = Immutable
-                      | v == 's' = Stable
-                      | otherwise = Volatile -- only 'v' can happen here
-
-allProcs :: Bool -> SQL.Statement [Schema] ProcsMap
-allProcs = SQL.Statement sql (arrayParam HE.text) decodeProcs
-  where
-    sql = procsSqlQuery <> " WHERE pn.nspname = ANY($1)"
-
-accessibleProcs :: Bool -> SQL.Statement Schema ProcsMap
-accessibleProcs = SQL.Statement sql (param HE.text) decodeProcs
-  where
-    sql = procsSqlQuery <> " WHERE pn.nspname = $1 AND has_function_privilege(p.oid, 'execute')"
-
-procsSqlQuery :: SqlQuery
-procsSqlQuery = [q|
- -- Recursively get the base types of domains
-  WITH
-  base_types AS (
-    WITH RECURSIVE
-    recurse AS (
-      SELECT
-        oid,
-        typbasetype,
-        COALESCE(NULLIF(typbasetype, 0), oid) AS base
-      FROM pg_type
-      UNION
-      SELECT
-        t.oid,
-        b.typbasetype,
-        COALESCE(NULLIF(b.typbasetype, 0), b.oid) AS base
-      FROM recurse t
-      JOIN pg_type b ON t.typbasetype = b.oid
-    )
-    SELECT
-      oid,
-      base
-    FROM recurse
-    WHERE typbasetype = 0
-  ),
-  arguments AS (
-    SELECT
-      oid,
-      array_agg((
-        COALESCE(name, ''), -- name
-        type::regtype::text, -- type
-        idx <= (pronargs - pronargdefaults), -- is_required
-        COALESCE(mode = 'v', FALSE) -- is_variadic
-      ) ORDER BY idx) AS args
-    FROM pg_proc,
-         unnest(proargnames, proargtypes, proargmodes)
-           WITH ORDINALITY AS _ (name, type, mode, idx)
-    WHERE type IS NOT NULL -- only input arguments
-    GROUP BY oid
-  )
-  SELECT
-    pn.nspname AS proc_schema,
-    p.proname AS proc_name,
-    d.description AS proc_description,
-    COALESCE(a.args, '{}') AS args,
-    tn.nspname AS schema,
-    COALESCE(comp.relname, t.typname) AS name,
-    p.proretset AS rettype_is_setof,
-    (t.typtype = 'c'
-     -- if any TABLE, INOUT or OUT arguments present, treat as composite
-     or COALESCE(proargmodes::text[] && '{t,b,o}', false)
-    ) AS rettype_is_composite,
-    p.provolatile,
-    p.provariadic > 0 as hasvariadic
-  FROM pg_proc p
-  LEFT JOIN arguments a ON a.oid = p.oid
-  JOIN pg_namespace pn ON pn.oid = p.pronamespace
-  JOIN base_types bt ON bt.oid = p.prorettype
-  JOIN pg_type t ON t.oid = bt.base
-  JOIN pg_namespace tn ON tn.oid = t.typnamespace
-  LEFT JOIN pg_class comp ON comp.oid = t.typrelid
-  LEFT JOIN pg_catalog.pg_description as d ON d.objoid = p.oid
-|]
-
-schemaDescription :: Bool -> SQL.Statement Schema (Maybe Text)
-schemaDescription =
-    SQL.Statement sql (param HE.text) (join <$> HD.rowMaybe (nullableColumn HD.text))
-  where
-    sql = [q|
-      select
-        description
-      from
-        pg_catalog.pg_namespace n
-        left join pg_catalog.pg_description d on d.objoid = n.oid
-      where
-        n.nspname = $1 |]
-
-accessibleTables :: PgVersion -> Bool -> SQL.Statement Schema [Table]
-accessibleTables pgVer =
-  SQL.Statement sql (param HE.text) decodeTables
- where
-  sql = [q|
-    select
-      n.nspname as table_schema,
-      relname as table_name,
-      d.description as table_description,
-      (
-        c.relkind IN ('r','p')
-        OR (
-          c.relkind IN ('v','f')
-          -- CMD_INSERT - see allTables query below for explanation
-          AND (pg_relation_is_updatable(c.oid::regclass, TRUE) & 8) = 8
-        )
-      ) AS insertable,
-      (
-        c.relkind IN ('r','p')
-        OR (
-          c.relkind IN ('v','f')
-          -- CMD_UPDATE
-          AND (pg_relation_is_updatable(c.oid::regclass, TRUE) & 4) = 4
-        )
-      ) as updatable,
-      (
-        c.relkind IN ('r','p')
-        OR (
-          c.relkind IN ('v','f')
-          -- CMD_DELETE
-          AND (pg_relation_is_updatable(c.oid::regclass, TRUE) & 16) = 16
-        )
-      ) as deletable
-    from
-      pg_class c
-      join pg_namespace n on n.oid = c.relnamespace
-      left join pg_catalog.pg_description as d on d.objoid = c.oid and d.objsubid = 0
-    where
-      c.relkind in ('v','r','m','f','p')
-      and n.nspname = $1 |]
-      <> relIsNotPartition pgVer <> [q|
-      and (
-        pg_has_role(c.relowner, 'USAGE')
-        or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER')
-        or has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES')
-      )
-    order by relname |]
-
-{-
-Adds Views M2O Relationships based on SourceColumns found, the logic is as follows:
-
-Having a Relationship{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relCardinality=M2O} represented by:
-
-t1.c1------t2.c2
-
-When only having a t1_view.c1 source column, we need to add a View-Table M2O Relationship
-
-         t1.c1----t2.c2         t1.c1----------t2.c2
-                         ->            ________/
-                                      /
-      t1_view.c1             t1_view.c1
-
-
-When only having a t2_view.c2 source column, we need to add a Table-View M2O Relationship
-
-         t1.c1----t2.c2               t1.c1----------t2.c2
-                               ->          \________
-                                                    \
-                    t2_view.c2                      t2_view.c1
-
-When having t1_view.c1 and a t2_view.c2 source columns, we need to add a View-View M2O Relationship in addition to the prior
-
-         t1.c1----t2.c2               t1.c1----------t2.c2
-                               ->          \________/
-                                           /        \
-    t1_view.c1     t2_view.c2     t1_view.c1-------t2_view.c1
-
-The logic for composite pks is similar just need to make sure all the Relationship columns have source columns.
--}
-addViewM2ORels :: [SourceColumn] -> [Relationship] -> [Relationship]
-addViewM2ORels allSrcCols = concatMap (\rel@Relationship{..} -> rel :
-  let
-    srcColsGroupedByView :: [Column] -> [[SourceColumn]]
-    srcColsGroupedByView relCols = L.groupBy (\(_, viewCol1) (_, viewCol2) -> colTable viewCol1 == colTable viewCol2) $
-                   filter (\(c, _) -> c `elem` relCols) allSrcCols
-    relSrcCols = srcColsGroupedByView relColumns
-    relFSrcCols = srcColsGroupedByView relForeignColumns
-    getView :: [SourceColumn] -> Table
-    getView = colTable . snd . unsafeHead
-    srcCols `allSrcColsOf` cols = S.fromList (fst <$> srcCols) == S.fromList cols
-    -- Relationship is dependent on the order of relColumns and relFColumns to get the join conditions right in the generated query.
-    -- So we need to change the order of the SourceColumns to match the relColumns
-    -- TODO: This could be avoided if the Relationship type is improved with a structure that maintains the association of relColumns and relFColumns
-    srcCols `sortAccordingTo` cols = sortOn (\(k, _) -> L.lookup k $ zip cols [0::Int ..]) srcCols
-
-    viewTableM2O =
-      [ Relationship
-          (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)
-          relForeignTable relForeignColumns relCardinality
-      | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns ]
-
-    tableViewM2O =
-      [ Relationship
-          relTable relColumns
-          (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relForeignColumns)
-          relCardinality
-      | fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relForeignColumns ]
-
-    viewViewM2O =
-      [ Relationship
-          (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns)
-          (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relForeignColumns)
-          relCardinality
-      | srcCols  <- relSrcCols, srcCols `allSrcColsOf` relColumns
-      , fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relForeignColumns ]
-
-  in viewTableM2O ++ tableViewM2O ++ viewViewM2O)
-
-addO2MRels :: [Relationship] -> [Relationship]
-addO2MRels rels = rels ++ [ Relationship ft fc t c (O2M cons)
-                          | Relationship t c ft fc (M2O cons) <- rels ]
-
-addM2MRels :: [Relationship] -> [Relationship]
-addM2MRels rels = rels ++ [ Relationship t c ft fc (M2M $ Junction jt1 cons1 jc1 cons2 jc2)
-                          | Relationship jt1 jc1 t c (M2O cons1) <- rels
-                          , Relationship jt2 jc2 ft fc (M2O cons2) <- rels
-                          , jt1 == jt2
-                          , cons1 /= cons2]
-
-addViewPrimaryKeys :: [SourceColumn] -> [PrimaryKey] -> [PrimaryKey]
-addViewPrimaryKeys srcCols = concatMap (\pk ->
-  let viewPks = (\(_, viewCol) -> PrimaryKey{pkTable=colTable viewCol, pkName=colName viewCol}) <$>
-                filter (\(col, _) -> colTable col == pkTable pk && colName col == pkName pk) srcCols in
-  pk : viewPks)
-
-allTables :: PgVersion -> Bool -> SQL.Statement () [Table]
-allTables pgVer =
-  SQL.Statement sql HE.noParams decodeTables
- where
-  sql = [q|
-    SELECT
-      n.nspname AS table_schema,
-      c.relname AS table_name,
-      d.description AS table_description,
-      (
-        c.relkind IN ('r','p')
-        OR (
-          c.relkind in ('v','f')
-          -- The function `pg_relation_is_updateable` returns a bitmask where 8
-          -- corresponds to `1 << CMD_INSERT` in the PostgreSQL source code, i.e.
-          -- it's possible to insert into the relation.
-          AND (pg_relation_is_updatable(c.oid::regclass, TRUE) & 8) = 8
-        )
-      ) AS insertable,
-      (
-        c.relkind IN ('r','p')
-        OR (
-          c.relkind in ('v','f')
-          -- CMD_UPDATE
-          AND (pg_relation_is_updatable(c.oid::regclass, TRUE) & 4) = 4
-        )
-      ) AS updatable,
-      (
-        c.relkind IN ('r','p')
-        OR (
-          c.relkind in ('v','f')
-          -- CMD_DELETE
-          AND (pg_relation_is_updatable(c.oid::regclass, TRUE) & 16) = 16
-        )
-      ) AS deletable
-    FROM pg_class c
-    JOIN pg_namespace n ON n.oid = c.relnamespace
-    LEFT JOIN pg_catalog.pg_description as d on d.objoid = c.oid and d.objsubid = 0
-    WHERE c.relkind IN ('v','r','m','f','p')
-      AND n.nspname NOT IN ('pg_catalog', 'information_schema') |]
-      <> relIsNotPartition pgVer <> [q|
-    ORDER BY table_schema, table_name |]
-
-relIsNotPartition :: PgVersion -> SqlQuery
-relIsNotPartition pgVer = if pgVer >= pgVersion100 then " AND not c.relispartition " else mempty
-
-allColumns :: [Table] -> Bool -> SQL.Statement [Schema] [Column]
-allColumns tabs =
- SQL.Statement sql (arrayParam HE.text) (decodeColumns tabs)
- where
-  sql = [q|
-    SELECT DISTINCT
-        info.table_schema AS schema,
-        info.table_name AS table_name,
-        info.column_name AS name,
-        info.description AS description,
-        info.is_nullable::boolean AS nullable,
-        info.data_type AS col_type,
-        info.character_maximum_length AS max_len,
-        info.column_default AS default_value,
-        array_to_string(enum_info.vals, ',') AS enum,
-        info.position
-    FROM (
-        -- CTE based on pg_catalog to get PRIMARY/FOREIGN key and UNIQUE columns outside api schema
-        WITH key_columns AS (
-             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', 'u')
-               AND c.relkind IN ('r', 'v', 'f', 'm', 'p')
-               AND r.conrelid = c.oid
-               AND c.relnamespace = n.oid
-               AND n.nspname <> ANY (ARRAY['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
-                nc.nspname::name AS table_schema,
-                c.relname::name AS table_name,
-                a.attname::name AS column_name,
-                d.description AS description,
-                pg_get_expr(ad.adbin, ad.adrelid)::text AS column_default,
-                not (a.attnotnull OR t.typtype = 'd' AND t.typnotnull) AS is_nullable,
-                    CASE
-                        WHEN t.typtype = 'd' THEN
-                        CASE
-                            WHEN bt.typelem <> 0::oid AND bt.typlen = (-1) THEN 'ARRAY'::text
-                            WHEN nbt.nspname = 'pg_catalog'::name THEN format_type(t.typbasetype, NULL::integer)
-                            ELSE format_type(a.atttypid, a.atttypmod)
-                        END
-                        ELSE
-                        CASE
-                            WHEN t.typelem <> 0::oid AND t.typlen = (-1) THEN 'ARRAY'::text
-                            WHEN nt.nspname = 'pg_catalog'::name THEN format_type(a.atttypid, NULL::integer)
-                            ELSE format_type(a.atttypid, a.atttypmod)
-                        END
-                    END::text AS data_type,
-                information_schema._pg_char_max_length(
-                    information_schema._pg_truetypid(a.*, t.*),
-                    information_schema._pg_truetypmod(a.*, t.*)
-                )::integer AS character_maximum_length,
-                COALESCE(bt.typname, t.typname)::name AS udt_name,
-                a.attnum::integer AS position
-            FROM pg_attribute a
-                LEFT JOIN key_columns kc
-                    ON kc.conkey = a.attnum AND kc.c_oid = a.attrelid
-                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 JOIN pg_namespace nc ON c.relnamespace = nc.oid)
-                    ON a.attrelid = c.oid
-                JOIN (pg_type t JOIN pg_namespace nt ON t.typnamespace = nt.oid)
-                    ON a.atttypid = t.oid
-                LEFT JOIN (pg_type bt JOIN pg_namespace nbt ON bt.typnamespace = nbt.oid)
-                    ON t.typtype = 'd' 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 in ('r', 'v', 'f', 'm', 'p')
-                -- Filter only columns that are FK/PK or in the api schema:
-                AND (nc.nspname = ANY ($1) OR kc.r_oid IS NOT NULL)
-        )
-        SELECT
-            table_schema,
-            table_name,
-            column_name,
-            description,
-            is_nullable,
-            data_type,
-            character_maximum_length,
-            column_default,
-            udt_name,
-            position
-        FROM columns
-        WHERE table_schema NOT IN ('pg_catalog', 'information_schema')
-    ) AS info
-    LEFT OUTER JOIN (
-        SELECT
-            n.nspname AS s,
-            t.typname AS n,
-            array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals
-        FROM pg_type t
-        JOIN pg_enum e ON t.oid = e.enumtypid
-        JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace
-        GROUP BY s,n
-    ) AS enum_info ON (info.udt_name = enum_info.n)
-    ORDER BY schema, position |]
-
-columnFromRow :: [Table] ->
-                 (Text,        Text,        Text,
-                  Maybe Text,  Bool,        Text,
-                  Maybe Int32, Maybe Text,  Maybe Text)
-                 -> Maybe Column
-columnFromRow tabs (s, t, n, desc, nul, typ, l, d, e) = buildColumn <$> table
-  where
-    buildColumn tbl = Column tbl n desc nul typ l d (parseEnum e)
-    table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
-    parseEnum :: Maybe Text -> [Text]
-    parseEnum = maybe [] (split (==','))
-
-allM2ORels :: [Table] -> [Column] -> Bool -> SQL.Statement () [Relationship]
-allM2ORels tabs cols =
-  SQL.Statement sql HE.noParams (decodeRels tabs cols)
- where
-  sql = [q|
-    SELECT ns1.nspname AS table_schema,
-           tab.relname AS table_name,
-           conname     AS constraint_name,
-           column_info.cols AS columns,
-           ns2.nspname AS foreign_table_schema,
-           other.relname AS foreign_table_name,
-           column_info.refs AS foreign_columns
-    FROM pg_constraint,
-    LATERAL (
-      SELECT array_agg(cols.attname) AS cols,
-                    array_agg(cols.attnum)  AS nums,
-                    array_agg(refs.attname) AS refs
-      FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,
-      LATERAL (SELECT * FROM pg_attribute WHERE attrelid = conrelid AND attnum = col) AS cols,
-      LATERAL (SELECT * FROM pg_attribute WHERE attrelid = confrelid AND attnum = ref) AS refs) AS column_info,
-    LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = connamespace) AS ns1,
-    LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
-    LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other,
-    LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2
-    WHERE confrelid != 0
-    ORDER BY (conrelid, column_info.nums) |]
-
-relFromRow :: [Table] -> [Column] -> (Text, Text, Text, [Text], Text, Text, [Text]) -> Maybe Relationship
-relFromRow allTabs allCols (rs, rt, cn, rcs, frs, frt, frcs) =
-  Relationship <$> table <*> cols <*> tableF <*> colsF <*> pure (M2O cn)
-  where
-    findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs
-    findCol s t c = find (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col == c) allCols
-    table  = findTable rs rt
-    tableF = findTable frs frt
-    cols  = mapM (findCol rs rt) rcs
-    colsF = mapM (findCol frs frt) frcs
-
-allPrimaryKeys :: [Table] -> Bool -> SQL.Statement () [PrimaryKey]
-allPrimaryKeys tabs =
-  SQL.Statement sql HE.noParams (decodePks tabs)
- where
-  sql = [q|
-    -- CTE to replace information_schema.table_constraints to remove owner limit
-    WITH tc AS (
-        SELECT
-            c.conname::name AS constraint_name,
-            nr.nspname::name AS table_schema,
-            r.relname::name AS table_name
-        FROM pg_namespace nc,
-            pg_namespace nr,
-            pg_constraint c,
-            pg_class r
-        WHERE
-            nc.oid = c.connamespace
-            AND nr.oid = r.relnamespace
-            AND c.conrelid = r.oid
-            AND r.relkind IN ('r', 'p')
-            AND NOT pg_is_other_temp_schema(nr.oid)
-            AND c.contype = 'p'
-    ),
-    -- CTE to replace information_schema.key_column_usage to remove owner limit
-    kc AS (
-        SELECT
-            ss.conname::name AS constraint_name,
-            ss.nr_nspname::name AS table_schema,
-            ss.relname::name AS table_name,
-            a.attname::name AS column_name,
-            (ss.x).n::integer AS ordinal_position,
-            CASE
-                WHEN ss.contype = 'f' THEN information_schema._pg_index_position(ss.conindid, ss.confkey[(ss.x).n])
-                ELSE NULL::integer
-            END::integer AS position_in_unique_constraint
-        FROM pg_attribute a,
-            ( SELECT r.oid AS roid,
-                r.relname,
-                r.relowner,
-                nc.nspname AS nc_nspname,
-                nr.nspname AS nr_nspname,
-                c.oid AS coid,
-                c.conname,
-                c.contype,
-                c.conindid,
-                c.confkey,
-                information_schema._pg_expandarray(c.conkey) AS x
-               FROM pg_namespace nr,
-                pg_class r,
-                pg_namespace nc,
-                pg_constraint c
-              WHERE
-                nr.oid = r.relnamespace
-                AND r.oid = c.conrelid
-                AND nc.oid = c.connamespace
-                AND c.contype in ('p', 'u', 'f')
-                AND r.relkind IN ('r', 'p')
-                AND NOT pg_is_other_temp_schema(nr.oid)
-            ) ss
-        WHERE
-          ss.roid = a.attrelid
-          AND a.attnum = (ss.x).x
-          AND NOT a.attisdropped
-    )
-    SELECT
-        kc.table_schema,
-        kc.table_name,
-        kc.column_name
-    FROM
-        tc, kc
-    WHERE
-        kc.table_name = tc.table_name AND
-        kc.table_schema = tc.table_schema AND
-        kc.constraint_name = tc.constraint_name AND
-        kc.table_schema NOT IN ('pg_catalog', 'information_schema') |]
-
-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
-
--- returns all the primary and foreign key columns which are referenced in views
-pfkSourceColumns :: [Column] -> Bool -> SQL.Statement ([Schema], [Schema]) [SourceColumn]
-pfkSourceColumns cols =
-  SQL.Statement sql (contrazip2 (arrayParam HE.text) (arrayParam HE.text)) (decodeSourceColumns cols)
-  -- query explanation at:
-  --  * rationale: https://gist.github.com/wolfgangwalther/5425d64e7b0d20aad71f6f68474d9f19
-  --  * json transformation: https://gist.github.com/wolfgangwalther/3a8939da680c24ad767e93ad2c183089
-  where
-    sql = [q|
-      with recursive
-      pks_fks as (
-        -- pk + fk referencing col
-        select
-          conrelid as resorigtbl,
-          unnest(conkey) as resorigcol
-        from pg_constraint
-        where contype IN ('p', 'f')
-        union
-        -- fk referenced col
-        select
-          confrelid,
-          unnest(confkey)
-        from pg_constraint
-        where contype='f'
-      ),
-      views as (
-        select
-          c.oid       as view_id,
-          n.nspname   as view_schema,
-          c.relname   as view_name,
-          r.ev_action as view_definition
-        from pg_class c
-        join pg_namespace n on n.oid = c.relnamespace
-        join pg_rewrite r on r.ev_class = c.oid
-        where c.relkind in ('v', 'm') and n.nspname = ANY($1 || $2)
-      ),
-      transform_json as (
-        select
-          view_id, view_schema, view_name,
-          -- the following formatting is without indentation on purpose
-          -- to allow simple diffs, with less whitespace noise
-          replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            regexp_replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-            replace(
-              view_definition::text,
-            -- This conversion to json is heavily optimized for performance.
-            -- The general idea is to use as few regexp_replace() calls as possible.
-            -- Simple replace() is a lot faster, so we jump through some hoops
-            -- to be able to use regexp_replace() only once.
-            -- This has been tested against a huge schema with 250+ different views.
-            -- The unit tests do NOT reflect all possible inputs. Be careful when changing this!
-            -- -----------------------------------------------
-            -- pattern           | replacement         | flags
-            -- -----------------------------------------------
-            -- `,` is not part of the pg_node_tree format, but used in the regex.
-            -- This removes all `,` that might be part of column names.
-               ','               , ''
-            -- The same applies for `{` and `}`, although those are used a lot in pg_node_tree.
-            -- We remove the escaped ones, which might be part of column names again.
-            ), E'\\{'            , ''
-            ), E'\\}'            , ''
-            -- The fields we need are formatted as json manually to protect them from the regex.
-            ), ' :targetList '   , ',"targetList":'
-            ), ' :resno '        , ',"resno":'
-            ), ' :resorigtbl '   , ',"resorigtbl":'
-            ), ' :resorigcol '   , ',"resorigcol":'
-            -- Make the regex also match the node type, e.g. `{QUERY ...`, to remove it in one pass.
-            ), '{'               , '{ :'
-            -- Protect node lists, which start with `({` or `((` from the greedy regex.
-            -- The extra `{` is removed again later.
-            ), '(('              , '{(('
-            ), '({'              , '{({'
-            -- This regex removes all unused fields to avoid the need to format all of them correctly.
-            -- This leads to a smaller json result as well.
-            -- Removal stops at `,` for used fields (see above) and `}` for the end of the current node.
-            -- Nesting can't be parsed correctly with a regex, so we stop at `{` as well and
-            -- add an empty key for the followig node.
-            ), ' :[^}{,]+'       , ',"":'              , 'g'
-            -- For performance, the regex also added those empty keys when hitting a `,` or `}`.
-            -- Those are removed next.
-            ), ',"":}'           , '}'
-            ), ',"":,'           , ','
-            -- This reverses the "node list protection" from above.
-            ), '{('              , '('
-            -- Every key above has been added with a `,` so far. The first key in an object doesn't need it.
-            ), '{,'              , '{'
-            -- pg_node_tree has `()` around lists, but JSON uses `[]`
-            ), '('               , '['
-            ), ')'               , ']'
-            -- pg_node_tree has ` ` between list items, but JSON uses `,`
-            ), ' '             , ','
-            -- `<>` in pg_node_tree is the same as `null` in JSON, but due to very poor performance of json_typeof
-            -- we need to make this an empty array here to prevent json_array_elements from throwing an error
-            -- when the targetList is null.
-            ), '<>'              , '[]'
-          )::json as view_definition
-        from views
-      ),
-      target_entries as(
-        select
-          view_id, view_schema, view_name,
-          json_array_elements(view_definition->0->'targetList') as entry
-        from transform_json
-      ),
-      results as(
-        select
-          view_id, view_schema, view_name,
-          (entry->>'resno')::int as view_column,
-          (entry->>'resorigtbl')::oid as resorigtbl,
-          (entry->>'resorigcol')::int as resorigcol
-        from target_entries
-      ),
-      recursion as(
-        select r.*
-        from results r
-        where view_schema = ANY ($1)
-        union all
-        select
-          view.view_id,
-          view.view_schema,
-          view.view_name,
-          view.view_column,
-          tab.resorigtbl,
-          tab.resorigcol
-        from recursion view
-        join results tab on view.resorigtbl=tab.view_id and view.resorigcol=tab.view_column
-      )
-      select
-        sch.nspname as table_schema,
-        tbl.relname as table_name,
-        col.attname as table_column_name,
-        rec.view_schema,
-        rec.view_name,
-        vcol.attname as view_column_name
-      from recursion rec
-      join pg_class tbl on tbl.oid = rec.resorigtbl
-      join pg_attribute col on col.attrelid = tbl.oid and col.attnum = rec.resorigcol
-      join pg_attribute vcol on vcol.attrelid = rec.view_id and vcol.attnum = rec.view_column
-      join pg_namespace sch on sch.oid = tbl.relnamespace
-      join pks_fks using (resorigtbl, resorigcol)
-      order by view_schema, view_name, view_column_name; |]
-
-param :: HE.Value a -> HE.Params a
-param = HE.param . HE.nonNullable
-
-arrayParam :: HE.Value a -> HE.Params [a]
-arrayParam = param . HE.foldableArray . HE.nonNullable
-
-compositeArrayColumn :: HD.Composite a -> HD.Row [a]
-compositeArrayColumn = arrayColumn . HD.composite
-
-compositeField :: HD.Value a -> HD.Composite a
-compositeField = HD.field . HD.nonNullable
-
-column :: HD.Value a -> HD.Row a
-column = HD.column . HD.nonNullable
-
-nullableColumn :: HD.Value a -> HD.Row (Maybe a)
-nullableColumn = HD.column . HD.nullable
-
-arrayColumn :: HD.Value a -> HD.Row [a]
-arrayColumn = column . HD.listArray . HD.nonNullable

src/PostgREST/DbStructure/Proc.hs

@@ -1,85 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric  #-}
-
-module PostgREST.DbStructure.Proc
-  ( PgType(..)
-  , ProcDescription(..)
-  , ProcParam(..)
-  , ProcVolatility(..)
-  , ProcsMap
-  , RetType(..)
-  , procReturnsScalar
-  , procReturnsSingle
-  , procTableName
-  ) where
-
-import qualified Data.Aeson          as JSON
-import qualified Data.HashMap.Strict as M
-
-import PostgREST.DbStructure.Identifiers (QualifiedIdentifier (..),
-                                          Schema, TableName)
-
-import Protolude
-
-data PgType
-  = Scalar
-  | Composite QualifiedIdentifier
-  deriving (Eq, Ord, Generic, JSON.ToJSON)
-
-data RetType
-  = Single PgType
-  | SetOf PgType
-  deriving (Eq, Ord, Generic, JSON.ToJSON)
-
-data ProcVolatility
-  = Volatile
-  | Stable
-  | Immutable
-  deriving (Eq, Ord, Generic, JSON.ToJSON)
-
-data ProcDescription = ProcDescription
-  { pdSchema      :: Schema
-  , pdName        :: Text
-  , pdDescription :: Maybe Text
-  , pdParams      :: [ProcParam]
-  , pdReturnType  :: RetType
-  , pdVolatility  :: ProcVolatility
-  , pdHasVariadic :: Bool
-  }
-  deriving (Eq, Generic, JSON.ToJSON)
-
-data ProcParam = ProcParam
-  { ppName :: Text
-  , ppType :: Text
-  , ppReq  :: Bool
-  , ppVar  :: Bool
-  }
-  deriving (Eq, Ord, Generic, JSON.ToJSON)
-
--- Order by least number of params in the case of overloaded functions
-instance Ord ProcDescription where
-  ProcDescription schema1 name1 des1 prms1 rt1 vol1 hasVar1 `compare` ProcDescription schema2 name2 des2 prms2 rt2 vol2 hasVar2
-    | schema1 == schema2 && name1 == name2 && length prms1 < length prms2  = LT
-    | schema2 == schema2 && name1 == name2 && length prms1 > length prms2  = GT
-    | otherwise = (schema1, name1, des1, prms1, rt1, vol1, hasVar1) `compare` (schema2, name2, des2, prms2, rt2, vol2, hasVar2)
-
--- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription).
--- | It uses a HashMap for a faster lookup.
-type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
-
-procReturnsScalar :: ProcDescription -> Bool
-procReturnsScalar proc = case proc of
-  ProcDescription{pdReturnType = (Single Scalar)} -> True
-  ProcDescription{pdReturnType = (SetOf Scalar)}  -> True
-  _                                               -> False
-
-procReturnsSingle :: ProcDescription -> Bool
-procReturnsSingle proc = case proc of
-  ProcDescription{pdReturnType = (Single _)} -> True
-  _                                          -> False
-
-procTableName :: ProcDescription -> Maybe TableName
-procTableName proc = case pdReturnType proc of
-  SetOf  (Composite qi) -> Just $ qiName qi
-  Single (Composite qi) -> Just $ qiName qi
-  _                     -> Nothing

src/PostgREST/DbStructure/Relationship.hs

@@ -1,62 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric  #-}
-
-module PostgREST.DbStructure.Relationship
-  ( Cardinality(..)
-  , PrimaryKey(..)
-  , Relationship(..)
-  , Junction(..)
-  , isSelfReference
-  ) where
-
-import qualified Data.Aeson as JSON
-
-import PostgREST.DbStructure.Table (Column (..), Table (..))
-
-import Protolude
-
-
--- | Relationship between two tables.
---
--- The order of the relColumns and relForeignColumns should be maintained to get the
--- join conditions right.
---
--- TODO merge relColumns and relForeignColumns to a tuple or Data.Bimap
-data Relationship = Relationship
-  { relTable          :: Table
-  , relColumns        :: [Column]
-  , relForeignTable   :: Table
-  , relForeignColumns :: [Column]
-  , relCardinality    :: Cardinality
-  }
-  deriving (Eq, Generic, JSON.ToJSON)
-
--- | The relationship cardinality
--- | https://en.wikipedia.org/wiki/Cardinality_(data_modeling)
--- TODO: missing one-to-one
-data Cardinality
-  = O2M FKConstraint -- ^ one-to-many cardinality
-  | M2O FKConstraint -- ^ many-to-one cardinality
-  | M2M Junction     -- ^ many-to-many cardinality
-  deriving (Eq, Generic, JSON.ToJSON)
-
-type FKConstraint = Text
-
--- | Junction table on an M2M relationship
-data Junction = Junction
-  { junTable       :: Table
-  , junConstraint1 :: FKConstraint
-  , junColumns1    :: [Column]
-  , junConstraint2 :: FKConstraint
-  , junColumns2    :: [Column]
-  }
-  deriving (Eq, Generic, JSON.ToJSON)
-
-isSelfReference :: Relationship -> Bool
-isSelfReference r = relTable r == relForeignTable r
-
-data PrimaryKey = PrimaryKey
-  { pkTable :: Table
-  , pkName  :: Text
-  }
-  deriving (Generic, JSON.ToJSON)

src/PostgREST/DbStructure/Table.hs

@@ -1,55 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric  #-}
-
-module PostgREST.DbStructure.Table
-  ( Column(..)
-  , Table(..)
-  , tableQi
-  ) where
-
-import qualified Data.Aeson as JSON
-
-import PostgREST.DbStructure.Identifiers (FieldName,
-                                          QualifiedIdentifier (..),
-                                          Schema, TableName)
-
-import Protolude
-
-
-data Table = Table
-  { tableSchema      :: Schema
-  , tableName        :: TableName
-  , tableDescription :: Maybe Text
-    -- The following fields identify what can be done on the table/view, they're not related to the privileges granted to it
-  , tableInsertable  :: Bool
-  , tableUpdatable   :: Bool
-  , tableDeletable   :: Bool
-  }
-  deriving (Show, Ord, Generic, JSON.ToJSON)
-
-instance Eq Table where
-  Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
-
-tableQi :: Table -> QualifiedIdentifier
-tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n
-
-data Column = Column
-  { colTable       :: Table
-  , colName        :: FieldName
-  , colDescription :: Maybe Text
-  , colNullable    :: Bool
-  , colType        :: Text
-  , colMaxLen      :: Maybe Int32
-  , colDefault     :: Maybe Text
-  , colEnum        :: [Text]
-  }
-  deriving (Ord, Generic, JSON.ToJSON)
-
-instance Eq Column where
-  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
-
-data PrimaryKey = PrimaryKey
-  { pkTable :: Table
-  , pkName  :: Text
-  }
-  deriving (Generic, JSON.ToJSON)

src/PostgREST/Error.hs

@@ -11,12 +11,15 @@ module PostgREST.Error
   , PgError(..)
   , Error(..)
   , errorPayload
-  , checkIsFatal
-  , singularityError
+  , status
   ) where
 
 import qualified Data.Aeson                as JSON
 import qualified Data.ByteString.Char8     as BS
+import qualified Data.CaseInsensitive      as CI
+import qualified Data.FuzzySet             as Fuzzy
+import qualified Data.HashMap.Strict       as HM
+import qualified Data.Map.Internal         as M
 import qualified Data.Text                 as T
 import qualified Data.Text.Encoding        as T
 import qualified Data.Text.Encoding.Error  as T
@@ -24,21 +27,25 @@ import qualified Hasql.Pool                as SQL
 import qualified Hasql.Session             as SQL
 import qualified Network.HTTP.Types.Status as HTTP
 
-import Data.Aeson  ((.=))
+import Data.Aeson  ((.:), (.:?), (.=))
 import Network.Wai (Response, responseLBS)
 
 import Network.HTTP.Types.Header (Header)
 
-import           PostgREST.ContentType (ContentType (..))
-import qualified PostgREST.ContentType as ContentType
+import           PostgREST.ApiRequest.Types (ApiRequestError (..),
+                                             QPError (..),
+                                             RangeError (..))
+import           PostgREST.MediaType        (MediaType (..))
+import qualified PostgREST.MediaType        as MediaType
 
-import PostgREST.DbStructure.Proc         (ProcDescription (..),
-                                           ProcParam (..))
-import PostgREST.DbStructure.Relationship (Cardinality (..),
+import PostgREST.SchemaCache.Identifiers  (QualifiedIdentifier (..),
+                                           Schema)
+import PostgREST.SchemaCache.Relationship (Cardinality (..),
                                            Junction (..),
-                                           Relationship (..))
-import PostgREST.DbStructure.Table        (Column (..), Table (..))
-
+                                           Relationship (..),
+                                           RelationshipsMap)
+import PostgREST.SchemaCache.Routine      (Routine (..),
+                                           RoutineParam (..))
 import Protolude
 
 
@@ -50,110 +57,329 @@ class (JSON.ToJSON a) => PgrstError a where
   errorPayload = JSON.encode
 
   errorResponseFor :: a -> Response
-  errorResponseFor err = responseLBS (status err) (headers err) $ errorPayload err
-
-
-
-data ApiRequestError
-  = ActionInappropriate
-  | InvalidRange
-  | InvalidBody ByteString
-  | ParseRequestError Text Text
-  | NoRelBetween Text Text
-  | AmbiguousRelBetween Text Text [Relationship]
-  | AmbiguousRpc [ProcDescription]
-  | NoRpc Text Text [Text] Bool ContentType Bool
-  | InvalidFilters
-  | UnacceptableSchema [Text]
-  | ContentTypeError [ByteString]
-  | UnsupportedVerb                -- Unreachable?
+  errorResponseFor err =
+    let baseHeader = MediaType.toContentType MTApplicationJSON in
+    responseLBS (status err) (baseHeader : headers err) $ errorPayload err
 
 instance PgrstError ApiRequestError where
-  status InvalidRange            = HTTP.status416
-  status InvalidFilters          = HTTP.status405
-  status (InvalidBody _)         = HTTP.status400
-  status UnsupportedVerb         = HTTP.status405
-  status ActionInappropriate     = HTTP.status405
-  status (ParseRequestError _ _) = HTTP.status400
-  status (NoRelBetween _ _)      = HTTP.status400
+  status AggregatesNotAllowed{}  = HTTP.status400
   status AmbiguousRelBetween{}   = HTTP.status300
-  status (AmbiguousRpc _)        = HTTP.status300
-  status NoRpc{}                 = HTTP.status404
-  status (UnacceptableSchema _)  = HTTP.status406
-  status (ContentTypeError _)    = HTTP.status415
+  status AmbiguousRpc{}          = HTTP.status300
+  status MediaTypeError{}        = HTTP.status415
+  status InvalidBody{}           = HTTP.status400
+  status InvalidFilters          = HTTP.status405
+  status InvalidPreferences{}    = HTTP.status400
+  status InvalidRpcMethod{}      = HTTP.status405
+  status InvalidRange{}          = HTTP.status416
+  status NotFound                = HTTP.status404
 
-  headers _ = [ContentType.toHeader CTApplicationJSON]
+  status NoRelBetween{}          = HTTP.status400
+  status NoRpc{}                 = HTTP.status404
+  status NotEmbedded{}           = HTTP.status400
+  status PutLimitNotAllowedError = HTTP.status400
+  status QueryParamError{}       = HTTP.status400
+  status RelatedOrderNotToOne{}  = HTTP.status400
+  status SpreadNotToOne{}        = HTTP.status400
+  status UnacceptableFilter{}    = HTTP.status400
+  status UnacceptableSchema{}    = HTTP.status406
+  status UnsupportedMethod{}     = HTTP.status405
+  status LimitNoOrderError       = HTTP.status400
+  status ColumnNotFound{}        = HTTP.status400
+  status GucHeadersError         = HTTP.status500
+  status GucStatusError          = HTTP.status500
+  status OffLimitsChangesError{} = HTTP.status400
+  status PutMatchingPkError      = HTTP.status400
+  status SingularityError{}      = HTTP.status406
+  status PGRSTParseError         = HTTP.status500
+
+  headers SingularityError{}     = [MediaType.toContentType $ MTVndSingularJSON False]
+  headers _ = mempty
+
+toJsonPgrstError :: ErrorCode -> Text -> Maybe JSON.Value -> Maybe JSON.Value -> JSON.Value
+toJsonPgrstError code msg details hint = JSON.object [
+    "code"     .= code
+  , "message"  .= msg
+  , "details"  .= details
+  , "hint"     .= hint
+  ]
 
 instance JSON.ToJSON ApiRequestError where
-  toJSON (ParseRequestError message details) = JSON.object [
-    "message" .= message, "details" .= details]
-  toJSON ActionInappropriate = JSON.object [
-    "message" .= ("Bad Request" :: Text)]
-  toJSON (InvalidBody errorMessage) = JSON.object [
-    "message" .= T.decodeUtf8 errorMessage]
-  toJSON InvalidRange = JSON.object [
-    "message" .= ("HTTP Range error" :: Text)]
-  toJSON (NoRelBetween parent child) = JSON.object [
-    "hint"    .= ("If a new foreign key between these entities was created in the database, try reloading the schema cache." :: Text),
-    "message" .= ("Could not find a relationship between " <> parent <> " and " <> child <> " in the schema cache" :: Text)]
-  toJSON (AmbiguousRelBetween parent child rels) = JSON.object [
-    "hint"    .= ("Try changing '" <> child <> "' to one of the following: " <> relHint rels <> ". Find the desired relationship in the 'details' key." :: Text),
-    "message" .= ("Could not embed because more than one relationship was found for '" <> parent <> "' and '" <> child <> "'" :: Text),
-    "details" .= (compressedRel <$> rels) ]
-  toJSON (AmbiguousRpc procs)  = JSON.object [
-    "hint"    .= ("Try renaming the parameters or the function itself in the database so function overloading can be resolved" :: Text),
-    "message" .= ("Could not choose the best candidate function between: " <> T.intercalate ", " [pdSchema p <> "." <> pdName p <> "(" <> T.intercalate ", " [ppName a <> " => " <> ppType a | a <- pdParams p] <> ")" | p <- procs])]
-  toJSON (NoRpc schema procName argumentKeys hasPreferSingleObject contentType isInvPost)  =
-    let prms = "(" <> T.intercalate ", " argumentKeys <> ")" in JSON.object [
-    "hint"    .= ("If a new function was created in the database with this name and parameters, try reloading the schema cache." :: Text),
-    "message" .= ("Could not find the " <> schema <> "." <> procName <>
+  toJSON (QueryParamError (QPError message details)) = toJsonPgrstError
+    ApiRequestErrorCode00 message (Just (JSON.String details)) Nothing
+
+  toJSON (InvalidRpcMethod method) = toJsonPgrstError
+    ApiRequestErrorCode01 ("Cannot use the " <> T.decodeUtf8 method <> " method on RPC") Nothing Nothing
+
+  toJSON (InvalidBody errorMessage) = toJsonPgrstError
+    ApiRequestErrorCode02 (T.decodeUtf8 errorMessage) Nothing Nothing
+
+  toJSON (InvalidRange rangeError) = toJsonPgrstError
+    ApiRequestErrorCode03
+    "Requested range not satisfiable"
+    (Just $ case rangeError of
+       NegativeLimit           -> "Limit should be greater than or equal to zero."
+       LowerGTUpper            -> "The lower boundary must be lower than or equal to the upper boundary in the Range header."
+       OutOfBounds lower total -> JSON.String $ "An offset of " <> lower <> " was requested, but there are only " <> total <> " rows.")
+    Nothing
+
+  toJSON InvalidFilters = toJsonPgrstError
+    ApiRequestErrorCode05 "Filters must include all and only primary key columns with 'eq' operators" Nothing Nothing
+
+  toJSON (UnacceptableSchema schemas) = toJsonPgrstError
+    ApiRequestErrorCode06 ("The schema must be one of the following: " <> T.intercalate ", " schemas) Nothing Nothing
+
+  toJSON (MediaTypeError cts) = toJsonPgrstError
+    ApiRequestErrorCode07 ("None of these media types are available: " <> T.intercalate ", " (map T.decodeUtf8 cts)) Nothing Nothing
+
+  toJSON NotFound = JSON.object []
+
+  toJSON (NotEmbedded resource) = toJsonPgrstError
+    ApiRequestErrorCode08
+    ("'" <> resource <> "' is not an embedded resource in this request")
+    Nothing
+    (Just $ JSON.String $ "Verify that '" <> resource <> "' is included in the 'select' query parameter.")
+
+  toJSON LimitNoOrderError = toJsonPgrstError
+    ApiRequestErrorCode09 "A 'limit' was applied without an explicit 'order'" Nothing (Just "Apply an 'order' using unique column(s)")
+
+  toJSON (OffLimitsChangesError n maxs) = toJsonPgrstError
+    ApiRequestErrorCode10
+    "The maximum number of rows allowed to change was surpassed"
+    (Just $ JSON.String $ T.unwords ["Results contain", show n, "rows changed but the maximum number allowed is", show maxs])
+    Nothing
+
+  toJSON GucHeadersError = toJsonPgrstError
+    ApiRequestErrorCode11 "response.headers guc must be a JSON array composed of objects with a single key and a string value" Nothing Nothing
+
+  toJSON GucStatusError = toJsonPgrstError
+    ApiRequestErrorCode12 "response.status guc must be a valid status code" Nothing Nothing
+
+  toJSON PutLimitNotAllowedError = toJsonPgrstError
+    ApiRequestErrorCode14 "limit/offset querystring parameters are not allowed for PUT" Nothing Nothing
+
+  toJSON PutMatchingPkError = toJsonPgrstError
+    ApiRequestErrorCode15 "Payload values do not match URL in primary key column(s)" Nothing Nothing
+
+  toJSON (SingularityError n) = toJsonPgrstError
+    ApiRequestErrorCode16
+    "JSON object requested, multiple (or no) rows returned"
+    (Just $ JSON.String $ T.unwords ["The result contains", show n, "rows"])
+    Nothing
+
+  toJSON (UnsupportedMethod method) = toJsonPgrstError
+    ApiRequestErrorCode17 ("Unsupported HTTP method: " <> T.decodeUtf8 method) Nothing Nothing
+
+  toJSON (RelatedOrderNotToOne origin target) = toJsonPgrstError
+    ApiRequestErrorCode18
+    ("A related order on '" <> target <> "' is not possible")
+    (Just $ JSON.String $ "'" <> origin <> "' and '" <> target <> "' do not form a many-to-one or one-to-one relationship")
+    Nothing
+
+  toJSON (SpreadNotToOne origin target) = toJsonPgrstError
+    ApiRequestErrorCode19
+    ("A spread operation on '" <> target <> "' is not possible")
+    (Just $ JSON.String $ "'" <> origin <> "' and '" <> target <> "' do not form a many-to-one or one-to-one relationship")
+    Nothing
+
+  toJSON (UnacceptableFilter target) = toJsonPgrstError
+    ApiRequestErrorCode20
+    ("Bad operator on the '" <> target <> "' embedded resource")
+    (Just "Only is null or not is null filters are allowed on embedded resources")
+    Nothing
+
+  toJSON PGRSTParseError = toJsonPgrstError
+    ApiRequestErrorCode21 "The message and detail field of RAISE 'PGRST' error expects JSON" Nothing Nothing
+
+  toJSON (InvalidPreferences prefs) = toJsonPgrstError
+    ApiRequestErrorCode22
+    "Invalid preferences given with handling=strict"
+    (Just $ JSON.String $ T.decodeUtf8 ("Invalid preferences: " <> BS.intercalate ", " prefs))
+    Nothing
+
+  toJSON AggregatesNotAllowed = toJsonPgrstError
+    ApiRequestErrorCode23 "Use of aggregate functions is not allowed" Nothing Nothing
+
+  toJSON (NoRelBetween parent child embedHint schema allRels) = toJsonPgrstError
+    SchemaCacheErrorCode00
+    ("Could not find a relationship between '" <> parent <> "' and '" <> child <> "' in the schema cache")
+    (Just $ JSON.String $ "Searched for a foreign key relationship between '" <> parent <> "' and '" <> child <> maybe mempty ("' using the hint '" <>) embedHint <> "' in the schema '" <> schema <> "', but no matches were found.")
+    (JSON.String <$> noRelBetweenHint parent child schema allRels)
+
+  toJSON (AmbiguousRelBetween parent child rels) = toJsonPgrstError
+    SchemaCacheErrorCode01
+    ("Could not embed because more than one relationship was found for '" <> parent <> "' and '" <> child <> "'")
+    (Just $ JSON.toJSONList (compressedRel <$> rels))
+    (Just $ JSON.String $ "Try changing '" <> child <> "' to one of the following: " <> relHint rels <> ". Find the desired relationship in the 'details' key.")
+
+  toJSON (NoRpc schema procName argumentKeys hasPreferSingleObject contentType isInvPost allProcs overloadedProcs)  =
+    let func = schema <> "." <> procName
+        prms = T.intercalate ", " argumentKeys
+        prmsMsg = "(" <> prms <> ")"
+        prmsDet = " with parameter" <> (if length argumentKeys > 1 then "s " else " ") <> prms
+        fmtPrms p = if null argumentKeys then " without parameters" else p
+        onlySingleParams = hasPreferSingleObject || (isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream])
+    in toJsonPgrstError
+    SchemaCacheErrorCode02
+    ("Could not find the function " <> func <> (if onlySingleParams then "" else fmtPrms prmsMsg) <> " in the schema cache")
+    (Just $ JSON.String $ "Searched for the function " <> func <>
       (case (hasPreferSingleObject, isInvPost, contentType) of
-        (True, _, _)                 -> " function with a single json or jsonb parameter"
-        (_, True, CTTextPlain)       -> " function with a single unnamed text parameter"
-        (_, True, CTOctetStream)     -> " function with a single unnamed bytea parameter"
-        (_, True, CTApplicationJSON) -> prms <> " function or the " <> schema <> "." <> procName <>" function with a single unnamed json or jsonb parameter"
-        _                            -> prms <> " function") <>
-      " in the schema cache")]
-  toJSON UnsupportedVerb = JSON.object [
-    "message" .= ("Unsupported HTTP verb" :: Text)]
-  toJSON InvalidFilters = JSON.object [
-    "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)]
-  toJSON (UnacceptableSchema schemas) = JSON.object [
-    "message" .= ("The schema must be one of the following: " <> T.intercalate ", " schemas)]
-  toJSON (ContentTypeError cts)    = JSON.object [
-    "message" .= ("None of these Content-Types are available: " <> T.intercalate ", " (map T.decodeUtf8 cts))]
+        (True, _, _)                 -> " with a single json/jsonb parameter"
+        (_, True, MTTextPlain)       -> " with a single unnamed text parameter"
+        (_, True, MTTextXML)         -> " with a single unnamed xml parameter"
+        (_, True, MTOctetStream)     -> " with a single unnamed bytea parameter"
+        (_, True, MTApplicationJSON) -> fmtPrms prmsDet <> " or with a single unnamed json/jsonb parameter"
+        _                            -> fmtPrms prmsDet) <>
+      ", but no matches were found in the schema cache.")
+    -- The hint will be null in the case of single unnamed parameter functions
+    (if onlySingleParams
+      then Nothing
+      else JSON.String <$> noRpcHint schema procName argumentKeys allProcs overloadedProcs)
+
+  toJSON (AmbiguousRpc procs)  = toJsonPgrstError
+    SchemaCacheErrorCode03
+    ("Could not choose the best candidate function between: " <> T.intercalate ", " [pdSchema p <> "." <> pdName p <> "(" <> T.intercalate ", " [ppName a <> " => " <> ppType a | a <- pdParams p] <> ")" | p <- procs])
+    Nothing
+    (Just "Try renaming the parameters or the function itself in the database so function overloading can be resolved")
+
+  toJSON (ColumnNotFound relName colName) = toJsonPgrstError
+    SchemaCacheErrorCode04 ("Column '" <> colName <> "' of relation '" <> relName <> "' does not exist") Nothing Nothing
+
+-- |
+-- If no relationship is found then:
+--
+-- Looks for parent suggestions if parent not found
+-- Looks for child suggestions if parent is found but child is not
+-- Gives no suggestions if both are found (it means that there is a problem with the embed hint)
+--
+-- >>> :set -Wno-missing-fields
+-- >>> let qi t = QualifiedIdentifier "api" t
+-- >>> let rel ft = Relationship{relForeignTable = qi ft}
+-- >>> let rels = HM.fromList [((qi "films", "api"), [rel "directors", rel "roles", rel "actors"])]
+--
+-- >>> noRelBetweenHint "film" "directors" "api" rels
+-- Just "Perhaps you meant 'films' instead of 'film'."
+--
+-- >>> noRelBetweenHint "films" "role" "api" rels
+-- Just "Perhaps you meant 'roles' instead of 'role'."
+--
+-- >>> noRelBetweenHint "films" "role" "api" rels
+-- Just "Perhaps you meant 'roles' instead of 'role'."
+--
+-- >>> noRelBetweenHint "films" "actors" "api" rels
+-- Nothing
+--
+-- >>> noRelBetweenHint "noclosealternative" "roles" "api" rels
+-- Nothing
+--
+-- >>> noRelBetweenHint "films" "noclosealternative" "api" rels
+-- Nothing
+--
+-- >>> noRelBetweenHint "films" "noclosealternative" "noclosealternative" rels
+-- Nothing
+--
+noRelBetweenHint :: Text -> Text -> Schema -> RelationshipsMap -> Maybe Text
+noRelBetweenHint parent child schema allRels = ("Perhaps you meant '" <>) <$>
+  if isJust findParent
+    then (<> "' instead of '" <> child <> "'.") <$> suggestChild
+    else (<> "' instead of '" <> parent <> "'.") <$> suggestParent
+  where
+    findParent = HM.lookup (QualifiedIdentifier schema parent, schema) allRels
+    fuzzySetOfParents  = Fuzzy.fromList [qiName (fst p) | p <- HM.keys allRels, snd p == schema]
+    fuzzySetOfChildren = Fuzzy.fromList [qiName (relForeignTable c) | c <- fromMaybe [] findParent]
+    suggestParent = Fuzzy.getOne fuzzySetOfParents parent
+    -- Do not give suggestion if the child is found in the relations (weight = 1.0)
+    suggestChild  = headMay [snd k | k <- Fuzzy.get fuzzySetOfChildren child, fst k < 1.0]
+
+-- |
+-- If no function is found with the given name, it does a fuzzy search to all the functions
+-- in the same schema and shows the best match as hint.
+--
+-- >>> :set -Wno-missing-fields
+-- >>> let procs = [(QualifiedIdentifier "api" "test"), (QualifiedIdentifier "api" "another"), (QualifiedIdentifier "private" "other")]
+--
+-- >>> noRpcHint "api" "testt" ["val", "param", "name"] procs []
+-- Just "Perhaps you meant to call the function api.test"
+--
+-- >>> noRpcHint "api" "other" [] procs []
+-- Just "Perhaps you meant to call the function api.another"
+--
+-- >>> noRpcHint "api" "noclosealternative" [] procs []
+-- Nothing
+--
+-- If a function is found with the given name, but no params match, then it does a fuzzy search
+-- to all the overloaded functions' params using the form "param1, param2, param3, ..."
+-- and shows the best match as hint.
+--
+-- >>> let procsDesc = [Function {pdParams = [RoutineParam {ppName="val"}, RoutineParam {ppName="param"}, RoutineParam {ppName="name"}]}, Function {pdParams = [RoutineParam {ppName="id"}, RoutineParam {ppName="attr"}]}]
+--
+-- >>> noRpcHint "api" "test" ["vall", "pqaram", "nam"] procs procsDesc
+-- Just "Perhaps you meant to call the function api.test(name, param, val)"
+--
+-- >>> noRpcHint "api" "test" ["val", "param"] procs procsDesc
+-- Just "Perhaps you meant to call the function api.test(name, param, val)"
+--
+-- >>> noRpcHint "api" "test" ["id", "attrs"] procs procsDesc
+-- Just "Perhaps you meant to call the function api.test(attr, id)"
+--
+-- >>> noRpcHint "api" "test" ["id"] procs procsDesc
+-- Just "Perhaps you meant to call the function api.test(attr, id)"
+--
+-- >>> noRpcHint "api" "test" ["noclosealternative"] procs procsDesc
+-- Nothing
+--
+noRpcHint :: Text -> Text -> [Text] -> [QualifiedIdentifier] -> [Routine] -> Maybe Text
+noRpcHint schema procName params allProcs overloadedProcs =
+  fmap (("Perhaps you meant to call the function " <> schema <> ".") <>) possibleProcs
+  where
+    fuzzySetOfProcs  = Fuzzy.fromList [qiName k | k <- allProcs, qiSchema k == schema]
+    fuzzySetOfParams = Fuzzy.fromList $ listToText <$> [[ppName prm | prm <- pdParams ov] | ov <- overloadedProcs]
+    -- Cannot do a fuzzy search like: Fuzzy.getOne [[Text]] [Text], where [[Text]] is the list of params for each
+    -- overloaded function and [Text] the given params. This converts those lists to text to make fuzzy search possible.
+    -- E.g. ["val", "param", "name"] into "(name, param, val)"
+    listToText       = ("(" <>) . (<> ")") . T.intercalate ", " . sort
+    possibleProcs
+      | null overloadedProcs = Fuzzy.getOne fuzzySetOfProcs procName
+      | otherwise            = (procName <>) <$> Fuzzy.getOne fuzzySetOfParams (listToText params)
 
 compressedRel :: Relationship -> JSON.Value
+-- An ambiguousness error cannot happen for computed relationships TODO refactor so this mempty is not needed
+compressedRel ComputedRelationship{} = JSON.object mempty
 compressedRel Relationship{..} =
   let
-    fmtTbl Table{..} = tableSchema <> "." <> tableName
-    fmtEls els = "[" <> T.intercalate ", " els <> "]"
+    fmtEls els = "(" <> T.intercalate ", " els <> ")"
   in
   JSON.object $
-    ("embedding" .= (tableName relTable <> " with " <> tableName relForeignTable :: Text))
+    ("embedding" .= (qiName relTable <> " with " <> qiName relForeignTable :: Text))
     : case relCardinality of
         M2M Junction{..} -> [
             "cardinality" .= ("many-to-many" :: Text)
-          , "relationship" .= (fmtTbl junTable <> fmtEls [junConstraint1] <> fmtEls [junConstraint2])
+          , "relationship" .= (qiName junTable <> " using " <> junConstraint1 <> fmtEls (snd <$> junColsSource) <> " and " <> junConstraint2 <> fmtEls (snd <$> junColsTarget))
           ]
-        M2O cons -> [
+        M2O cons relColumns -> [
             "cardinality" .= ("many-to-one" :: Text)
-          , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns))
+          , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns))
           ]
-        O2M cons -> [
+        O2O cons relColumns -> [
+            "cardinality" .= ("one-to-one" :: Text)
+          , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns))
+          ]
+        O2M cons relColumns -> [
             "cardinality" .= ("one-to-many" :: Text)
-          , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns))
+          , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns))
           ]
 
 relHint :: [Relationship] -> Text
 relHint rels = T.intercalate ", " (hintList <$> rels)
   where
     hintList Relationship{..} =
-      let buildHint rel = "'" <> tableName relForeignTable <> "!" <> rel <> "'" in
+      let buildHint rel = "'" <> qiName relForeignTable <> "!" <> rel <> "'" in
       case relCardinality of
-        M2M Junction{..} -> buildHint (tableName junTable)
-        M2O cons         -> buildHint cons
-        O2M cons         -> buildHint cons
+        M2M Junction{..} -> buildHint (qiName junTable)
+        M2O cons _       -> buildHint cons
+        O2O cons _       -> buildHint cons
+        O2M cons _       -> buildHint cons
+    -- An ambiguousness error cannot happen for computed relationships TODO refactor so this mempty is not needed
+    hintList ComputedRelationship{} = mempty
 
 data PgError = PgError Authenticated SQL.UsageError
 type Authenticated = Bool
@@ -161,63 +387,68 @@ type Authenticated = Bool
 instance PgrstError PgError where
   status (PgError authed usageError) = pgErrorStatus authed usageError
 
+  headers (PgError _ (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError (SQL.ServerError "PGRST" m d _ _p))))) =
+    case (parseMessage m, parseDetails d) of
+      (Just _, Just r) -> headers PGRSTParseError ++ map intoHeader (M.toList $ getHeaders r)
+      _                -> headers PGRSTParseError
+    where
+      intoHeader (k,v) = (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v)
+
   headers err =
     if status err == HTTP.status401
-       then [ContentType.toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
-       else [ContentType.toHeader CTApplicationJSON]
+       then [("WWW-Authenticate", "Bearer") :: Header]
+       else mempty
 
 instance JSON.ToJSON PgError where
   toJSON (PgError _ usageError) = JSON.toJSON usageError
 
 instance JSON.ToJSON SQL.UsageError where
-  toJSON (SQL.ConnectionError e) = JSON.object [
-    "code"    .= ("" :: Text),
-    "message" .= ("Database connection error. Retrying the connection." :: Text),
-    "details" .= (T.decodeUtf8With T.lenientDecode $ fromMaybe "" e :: Text)]
-  toJSON (SQL.SessionError e) = JSON.toJSON e -- SQL.Error
+  toJSON (SQL.ConnectionUsageError e) = toJsonPgrstError
+    ConnectionErrorCode00
+    "Database connection error. Retrying the connection."
+    (Just $ JSON.String $ T.decodeUtf8With T.lenientDecode $ fromMaybe "" e)
+    Nothing
+
+  toJSON (SQL.SessionUsageError e) = JSON.toJSON e -- SQL.Error
+
+  toJSON SQL.AcquisitionTimeoutUsageError = toJsonPgrstError
+    ConnectionErrorCode03 "Timed out acquiring connection from connection pool." Nothing Nothing
 
 instance JSON.ToJSON SQL.QueryError where
   toJSON (SQL.QueryError _ _ e) = JSON.toJSON e
 
 instance JSON.ToJSON SQL.CommandError where
-  toJSON (SQL.ResultError (SQL.ServerError c m d h)) = case BS.unpack c of
-    'P':'T':_ -> JSON.object [
-        "details" .= fmap T.decodeUtf8 d,
-        "hint"    .= fmap T.decodeUtf8 h]
+  -- Special error raised with code PGRST, to allow full response control
+  toJSON (SQL.ResultError (SQL.ServerError "PGRST" m d _ _p)) =
+    case (parseMessage m, parseDetails d) of
+      (Just r, Just _) -> JSON.object [
+        "code"     .= getCode r,
+        "message"  .= getMessage r,
+        "details"  .= checkMaybe (getDetails r),
+        "hint"     .= checkMaybe (getHint r)]
+      _ -> JSON.toJSON PGRSTParseError
+    where
+      checkMaybe = maybe JSON.Null JSON.String
 
-    _         -> JSON.object [
-        "code"    .= (T.decodeUtf8 c      :: Text),
-        "message" .= (T.decodeUtf8 m      :: Text),
-        "details" .= (fmap T.decodeUtf8 d :: Maybe Text),
-        "hint"    .= (fmap T.decodeUtf8 h :: Maybe Text)]
+  toJSON (SQL.ResultError (SQL.ServerError c m d h _p)) = JSON.object [
+    "code"     .= (T.decodeUtf8 c      :: Text),
+    "message"  .= (T.decodeUtf8 m      :: Text),
+    "details"  .= (fmap T.decodeUtf8 d :: Maybe Text),
+    "hint"     .= (fmap T.decodeUtf8 h :: Maybe Text)]
 
-  toJSON (SQL.ResultError (SQL.UnexpectedResult m)) = JSON.object [
-    "message" .= (m :: Text)]
-  toJSON (SQL.ResultError (SQL.RowError i SQL.EndOfInput)) = JSON.object [
-    "message" .= ("Row error: end of input" :: Text),
-    "details" .= ("Attempt to parse more columns than there are in the result" :: Text),
-    "hint"    .= (("Row number " <> show i) :: Text)]
-  toJSON (SQL.ResultError (SQL.RowError i SQL.UnexpectedNull)) = JSON.object [
-    "message" .= ("Row error: unexpected null" :: Text),
-    "details" .= ("Attempt to parse a NULL as some value." :: Text),
-    "hint"    .= (("Row number " <> show i) :: Text)]
-  toJSON (SQL.ResultError (SQL.RowError i (SQL.ValueError d))) = JSON.object [
-    "message" .= ("Row error: Wrong value parser used" :: Text),
-    "details" .= d,
-    "hint"    .= (("Row number " <> show i) :: Text)]
-  toJSON (SQL.ResultError (SQL.UnexpectedAmountOfRows i)) = JSON.object [
-    "message" .= ("Unexpected amount of rows" :: Text),
-    "details" .= i]
-  toJSON (SQL.ClientError d) = JSON.object [
-    "message" .= ("Database client error. Retrying the connection." :: Text),
-    "details" .= (fmap T.decodeUtf8 d :: Maybe Text)]
+  toJSON (SQL.ResultError resultError) = toJsonPgrstError
+    InternalErrorCode00 (show resultError) Nothing Nothing
+
+  toJSON (SQL.ClientError d) = toJsonPgrstError
+    ConnectionErrorCode01 "Database client error. Retrying the connection." (JSON.String <$> fmap T.decodeUtf8 d) Nothing
 
 pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status
-pgErrorStatus _      (SQL.ConnectionError _)                                      = HTTP.status503
-pgErrorStatus _      (SQL.SessionError (SQL.QueryError _ _ (SQL.ClientError _)))      = HTTP.status503
-pgErrorStatus authed (SQL.SessionError (SQL.QueryError _ _ (SQL.ResultError rError))) =
+pgErrorStatus _      (SQL.ConnectionUsageError _) = HTTP.status503
+pgErrorStatus _      SQL.AcquisitionTimeoutUsageError = HTTP.status504
+pgErrorStatus _      (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _)))      = HTTP.status503
+pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError rError))) =
   case rError of
-    (SQL.ServerError c m _ _) ->
+    (SQL.ServerError c m d _ _) ->
       case BS.unpack c of
         '0':'8':_ -> HTTP.status503 -- pg connection err
         '0':'9':_ -> HTTP.status500 -- triggered action exception
@@ -236,6 +467,7 @@ pgErrorStatus authed (SQL.SessionError (SQL.QueryError _ _ (SQL.ResultError rErr
         '5':'3':_ -> HTTP.status503 -- insufficient resources
         '5':'4':_ -> HTTP.status413 -- too complex
         '5':'5':_ -> HTTP.status500 -- obj not on prereq state
+        '5':'7':'P':'0':'1':_ -> HTTP.status503 -- terminating connection due to administrator command
         '5':'7':_ -> HTTP.status500 -- operator intervention
         '5':'8':_ -> HTTP.status500 -- system error
         'F':'0':_ -> HTTP.status500 -- conf file error
@@ -243,97 +475,56 @@ pgErrorStatus authed (SQL.SessionError (SQL.QueryError _ _ (SQL.ResultError rErr
         "P0001"   -> HTTP.status400 -- default code for "raise"
         'P':'0':_ -> HTTP.status500 -- PL/pgSQL Error
         'X':'X':_ -> HTTP.status500 -- internal Error
-        "42883"   -> HTTP.status404 -- undefined function
+        "42883"-> if BS.isPrefixOf "function xmlagg(" m
+          then HTTP.status406
+          else HTTP.status404 -- undefined function
         "42P01"   -> HTTP.status404 -- undefined table
         "42501"   -> if authed then HTTP.status403 else HTTP.status401 -- insufficient privilege
         'P':'T':n -> fromMaybe HTTP.status500 (HTTP.mkStatus <$> readMaybe n <*> pure m)
+        "PGRST"   ->
+          case (parseMessage m, parseDetails d) of
+            (Just _, Just r) -> maybe (toEnum $ getStatus r) (HTTP.mkStatus (getStatus r) . T.encodeUtf8) (getStatusText r)
+            _                -> status PGRSTParseError
         _         -> HTTP.status400
 
     _                       -> HTTP.status500
 
-checkIsFatal :: PgError -> Maybe Text
-checkIsFatal (PgError _ (SQL.ConnectionError e))
-  | isAuthFailureMessage = Just $ toS failureMessage
-  | otherwise = Nothing
-  where isAuthFailureMessage = "FATAL:  password authentication failed" `isPrefixOf` failureMessage
-        failureMessage = BS.unpack $ fromMaybe mempty e
-checkIsFatal (PgError _ (SQL.SessionError (SQL.QueryError _ _ (SQL.ResultError serverError))))
-  = case serverError of
-      -- Check for a syntax error (42601 is the pg code). This would mean the error is on our part somehow, so we treat it as fatal.
-      SQL.ServerError "42601" _ _ _
-        -> Just "Hint: This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues"
-      -- Check for a "prepared statement <name> already exists" error (Code 42P05: duplicate_prepared_statement).
-      -- This would mean that a connection pooler in transaction mode is being used
-      -- while prepared statements are enabled in the PostgREST configuration,
-      -- both of which are incompatible with each other.
-      SQL.ServerError "42P05" _ _ _
-        -> Just "Hint: If you are using connection poolers in transaction mode, try setting db-prepared-statements to false."
-      -- Check for a "transaction blocks not allowed in statement pooling mode" error (Code 08P01: protocol_violation).
-      -- This would mean that a connection pooler in statement mode is being used which is not supported in PostgREST.
-      SQL.ServerError "08P01" "transaction blocks not allowed in statement pooling mode" _ _
-        -> Just "Hint: Connection poolers in statement mode are not supported."
-      _ -> Nothing
-checkIsFatal _ = Nothing
-
 
 data Error
-  = GucHeadersError
-  | GucStatusError
-  | BinaryFieldError ContentType
-  | ConnectionLostError
-  | PutMatchingPkError
-  | PutRangeNotAllowedError
-  | JwtTokenMissing
+  = ApiRequestError ApiRequestError
   | JwtTokenInvalid Text
-  | SingularityError Integer
-  | NotFound
-  | ApiRequestError ApiRequestError
+  | JwtTokenMissing
+  | JwtTokenRequired
+  | NoSchemaCacheError
   | PgErr PgError
 
 instance PgrstError Error where
-  status GucHeadersError         = HTTP.status500
-  status GucStatusError          = HTTP.status500
-  status (BinaryFieldError _)    = HTTP.status406
-  status ConnectionLostError     = HTTP.status503
-  status PutMatchingPkError      = HTTP.status400
-  status PutRangeNotAllowedError = HTTP.status400
-  status JwtTokenMissing         = HTTP.status500
-  status (JwtTokenInvalid _)     = HTTP.unauthorized401
-  status (SingularityError _)    = HTTP.status406
-  status NotFound                = HTTP.status404
-  status (PgErr err)             = status err
-  status (ApiRequestError err)   = status err
+  status (ApiRequestError err) = status err
+  status JwtTokenInvalid{}     = HTTP.unauthorized401
+  status JwtTokenMissing       = HTTP.status500
+  status JwtTokenRequired      = HTTP.unauthorized401
+  status NoSchemaCacheError    = HTTP.status503
+  status (PgErr err)           = status err
 
-  headers (SingularityError _)     = [ContentType.toHeader CTSingularJSON]
-  headers (JwtTokenInvalid m)      = [ContentType.toHeader CTApplicationJSON, invalidTokenHeader m]
-  headers (PgErr err)              = headers err
-  headers (ApiRequestError err)    = headers err
-  headers _                        = [ContentType.toHeader CTApplicationJSON]
+  headers (ApiRequestError err) = headers err
+  headers (JwtTokenInvalid m)   = [invalidTokenHeader m]
+  headers JwtTokenRequired      = [requiredTokenHeader]
+  headers (PgErr err)           = headers err
+  headers _                     = mempty
 
 instance JSON.ToJSON Error where
-  toJSON GucHeadersError           = JSON.object [
-    "message" .= ("response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)]
-  toJSON GucStatusError           = JSON.object [
-    "message" .= ("response.status guc must be a valid status code" :: Text)]
-  toJSON (BinaryFieldError ct)          = JSON.object [
-    "message" .= ((T.decodeUtf8 (ContentType.toMime ct) <> " requested but more than one column was selected") :: Text)]
-  toJSON ConnectionLostError       = JSON.object [
-    "message" .= ("Database connection lost. Retrying the connection." :: Text)]
+  toJSON NoSchemaCacheError = toJsonPgrstError
+      ConnectionErrorCode02 "Could not query the database for the schema cache. Retrying." Nothing Nothing
 
-  toJSON PutRangeNotAllowedError   = JSON.object [
-    "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)]
-  toJSON PutMatchingPkError        = JSON.object [
-    "message" .= ("Payload values do not match URL in primary key column(s)" :: Text)]
+  toJSON JwtTokenMissing = toJsonPgrstError
+      JWTErrorCode00 "Server lacks JWT secret" Nothing Nothing
 
-  toJSON (SingularityError n)      = JSON.object [
-    "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
-    "details" .= T.unwords ["Results contain", show n, "rows,", T.decodeUtf8 (ContentType.toMime CTSingularJSON), "requires 1 row"]]
+  toJSON (JwtTokenInvalid message) = toJsonPgrstError
+      JWTErrorCode01 message Nothing Nothing
+
+  toJSON JwtTokenRequired = toJsonPgrstError
+      JWTErrorCode02 "Anonymous access is disabled" Nothing Nothing
 
-  toJSON JwtTokenMissing           = JSON.object [
-    "message" .= ("Server lacks JWT secret" :: Text)]
-  toJSON (JwtTokenInvalid message) = JSON.object [
-    "message" .= (message :: Text)]
-  toJSON NotFound = JSON.object []
   toJSON (PgErr err) = JSON.toJSON err
   toJSON (ApiRequestError err) = JSON.toJSON err
 
@@ -341,5 +532,136 @@ invalidTokenHeader :: Text -> Header
 invalidTokenHeader m =
   ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m))
 
-singularityError :: (Integral a) => a -> Error
-singularityError = SingularityError . toInteger
+requiredTokenHeader :: Header
+requiredTokenHeader = ("WWW-Authenticate", "Bearer")
+
+-- For parsing byteString to JSON Object, used for allowing full response control
+data PgRaiseErrMessage = PgRaiseErrMessage {
+  getCode    :: Text,
+  getMessage :: Text,
+  getDetails :: Maybe Text,
+  getHint    :: Maybe Text
+}
+
+data PgRaiseErrDetails = PgRaiseErrDetails {
+  getStatus     :: Int,
+  getStatusText :: Maybe Text,
+  getHeaders    :: Map Text Text
+}
+
+instance JSON.FromJSON PgRaiseErrMessage where
+  parseJSON (JSON.Object m) =
+    PgRaiseErrMessage
+      <$> m .: "code"
+      <*> m .: "message"
+      <*> m .:? "details"
+      <*> m .:? "hint"
+
+  parseJSON _ = mzero
+
+instance JSON.FromJSON PgRaiseErrDetails where
+  parseJSON (JSON.Object d) =
+    PgRaiseErrDetails
+      <$> d .: "status"
+      <*> d .:? "status_text"
+      <*> d .: "headers"
+
+  parseJSON _ = mzero
+
+parseMessage :: ByteString -> Maybe PgRaiseErrMessage
+parseMessage = JSON.decodeStrict
+
+parseDetails :: Maybe ByteString -> Maybe PgRaiseErrDetails
+parseDetails d = JSON.decodeStrict =<< d
+
+-- Error codes are grouped by common modules or characteristics
+data ErrorCode
+  -- PostgreSQL connection errors
+  = ConnectionErrorCode00
+  | ConnectionErrorCode01
+  | ConnectionErrorCode02
+  | ConnectionErrorCode03
+  -- API Request errors
+  | ApiRequestErrorCode00
+  | ApiRequestErrorCode01
+  | ApiRequestErrorCode02
+  | ApiRequestErrorCode03
+  -- | ApiRequestErrorCode04 -- no longer used (used to be mapped to ParseRequestError)
+  | ApiRequestErrorCode05
+  | ApiRequestErrorCode06
+  | ApiRequestErrorCode07
+  | ApiRequestErrorCode08
+  | ApiRequestErrorCode09
+  | ApiRequestErrorCode10
+  | ApiRequestErrorCode11
+  -- | ApiRequestErrorCode13 -- no longer used (used to be mapped to BinaryFieldError)
+  | ApiRequestErrorCode12
+  | ApiRequestErrorCode14
+  | ApiRequestErrorCode15
+  | ApiRequestErrorCode16
+  | ApiRequestErrorCode17
+  | ApiRequestErrorCode18
+  | ApiRequestErrorCode19
+  | ApiRequestErrorCode20
+  | ApiRequestErrorCode21
+  | ApiRequestErrorCode22
+  | ApiRequestErrorCode23
+  -- Schema Cache errors
+  | SchemaCacheErrorCode00
+  | SchemaCacheErrorCode01
+  | SchemaCacheErrorCode02
+  | SchemaCacheErrorCode03
+  | SchemaCacheErrorCode04
+  -- JWT authentication errors
+  | JWTErrorCode00
+  | JWTErrorCode01
+  | JWTErrorCode02
+  -- Internal errors related to the Hasql library
+  | InternalErrorCode00
+
+instance JSON.ToJSON ErrorCode where
+  toJSON e = JSON.toJSON (buildErrorCode e)
+
+-- New group of errors will be added at the end of all the groups and will have the next prefix in the sequence
+-- New errors are added at the end of the group they belong to and will have the next code in the sequence
+buildErrorCode :: ErrorCode -> Text
+buildErrorCode code = "PGRST" <> case code of
+  ConnectionErrorCode00  -> "000"
+  ConnectionErrorCode01  -> "001"
+  ConnectionErrorCode02  -> "002"
+  ConnectionErrorCode03  -> "003"
+
+  ApiRequestErrorCode00  -> "100"
+  ApiRequestErrorCode01  -> "101"
+  ApiRequestErrorCode02  -> "102"
+  ApiRequestErrorCode03  -> "103"
+  ApiRequestErrorCode05  -> "105"
+  ApiRequestErrorCode06  -> "106"
+  ApiRequestErrorCode07  -> "107"
+  ApiRequestErrorCode08  -> "108"
+  ApiRequestErrorCode09  -> "109"
+  ApiRequestErrorCode10  -> "110"
+  ApiRequestErrorCode11  -> "111"
+  ApiRequestErrorCode12  -> "112"
+  ApiRequestErrorCode14  -> "114"
+  ApiRequestErrorCode15  -> "115"
+  ApiRequestErrorCode16  -> "116"
+  ApiRequestErrorCode17  -> "117"
+  ApiRequestErrorCode18  -> "118"
+  ApiRequestErrorCode19  -> "119"
+  ApiRequestErrorCode20  -> "120"
+  ApiRequestErrorCode21  -> "121"
+  ApiRequestErrorCode22  -> "122"
+  ApiRequestErrorCode23  -> "123"
+
+  SchemaCacheErrorCode00 -> "200"
+  SchemaCacheErrorCode01 -> "201"
+  SchemaCacheErrorCode02 -> "202"
+  SchemaCacheErrorCode03 -> "203"
+  SchemaCacheErrorCode04 -> "204"
+
+  JWTErrorCode00         -> "300"
+  JWTErrorCode01         -> "301"
+  JWTErrorCode02         -> "302"
+
+  InternalErrorCode00    -> "X00"

src/PostgREST/Logger.hs

@@ -0,0 +1,30 @@
+{-|
+Module      : PostgREST.Logger
+Description : Wai Middleware to log requests to stdout.
+-}
+module PostgREST.Logger (middleware) where
+
+import qualified Network.Wai                          as Wai
+import qualified Network.Wai.Middleware.RequestLogger as Wai
+
+import Network.HTTP.Types.Status (status400, status500)
+import System.IO.Unsafe          (unsafePerformIO)
+
+import qualified PostgREST.Auth   as Auth
+import           PostgREST.Config (LogLevel (..))
+
+import Protolude
+
+middleware :: LogLevel -> Wai.Middleware
+middleware logLevel = case logLevel of
+  LogInfo  -> requestLogger (const True)
+  LogWarn  -> requestLogger (>= status400)
+  LogError -> requestLogger (>= status500)
+  LogCrit  -> requestLogger (const False)
+  where
+    requestLogger filterStatus = unsafePerformIO $ Wai.mkRequestLogger Wai.defaultRequestLoggerSettings
+      { Wai.outputFormat = Wai.ApacheWithSettings $
+          Wai.defaultApacheSettings
+            & Wai.setApacheRequestFilter (\_ res -> filterStatus $ Wai.responseStatus res)
+            & Wai.setApacheUserGetter Auth.getRole
+      }

src/PostgREST/MediaType.hs

@@ -0,0 +1,159 @@
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module PostgREST.MediaType
+  ( MediaType(..)
+  , MTVndPlanOption (..)
+  , MTVndPlanFormat (..)
+  , toContentType
+  , toMime
+  , decodeMediaType
+  ) where
+
+import qualified Data.ByteString          as BS
+import qualified Data.ByteString.Internal as BS (c2w)
+
+import Network.HTTP.Types.Header (Header, hContentType)
+
+import Protolude
+
+-- | Enumeration of currently supported media types
+data MediaType
+  = MTApplicationJSON
+  | MTGeoJSON
+  | MTTextCSV
+  | MTTextPlain
+  | MTTextXML
+  | MTOpenAPI
+  | MTUrlEncoded
+  | MTOctetStream
+  | MTAny
+  | MTOther ByteString
+  -- vendored media types
+  | MTVndArrayJSONStrip
+  | MTVndSingularJSON Bool
+  -- TODO MTVndPlan should only have its options as [Text]. Its ResultAggregate should have the typed attributes.
+  | MTVndPlan MediaType MTVndPlanFormat [MTVndPlanOption]
+  deriving (Eq, Show, Generic)
+instance Hashable MediaType
+
+data MTVndPlanOption
+  = PlanAnalyze | PlanVerbose | PlanSettings | PlanBuffers | PlanWAL
+  deriving (Eq, Show, Generic)
+instance Hashable MTVndPlanOption
+
+data MTVndPlanFormat
+  = PlanJSON | PlanText
+  deriving (Eq, Show, Generic)
+instance Hashable MTVndPlanFormat
+
+-- | Convert MediaType to a Content-Type HTTP Header
+toContentType :: MediaType -> Header
+toContentType ct = (hContentType, toMime ct <> charset)
+  where
+    charset = case ct of
+      MTOctetStream -> mempty
+      MTOther _     -> mempty
+      _             -> "; charset=utf-8"
+
+-- | Convert from MediaType to a ByteString representing the mime type
+toMime :: MediaType -> ByteString
+toMime MTApplicationJSON      = "application/json"
+toMime MTVndArrayJSONStrip    = "application/vnd.pgrst.array+json;nulls=stripped"
+toMime MTGeoJSON              = "application/geo+json"
+toMime MTTextCSV              = "text/csv"
+toMime MTTextPlain            = "text/plain"
+toMime MTTextXML              = "text/xml"
+toMime MTOpenAPI              = "application/openapi+json"
+toMime (MTVndSingularJSON True)  = "application/vnd.pgrst.object+json;nulls=stripped"
+toMime (MTVndSingularJSON False) = "application/vnd.pgrst.object+json"
+toMime MTUrlEncoded           = "application/x-www-form-urlencoded"
+toMime MTOctetStream          = "application/octet-stream"
+toMime MTAny                  = "*/*"
+toMime (MTOther ct)           = ct
+toMime (MTVndPlan mt fmt opts)   =
+  "application/vnd.pgrst.plan+" <> toMimePlanFormat fmt <>
+  ("; for=\"" <> toMime mt <> "\"") <>
+  (if null opts then mempty else "; options=" <> BS.intercalate "|" (toMimePlanOption <$> opts))
+
+toMimePlanOption :: MTVndPlanOption -> ByteString
+toMimePlanOption PlanAnalyze  = "analyze"
+toMimePlanOption PlanVerbose  = "verbose"
+toMimePlanOption PlanSettings = "settings"
+toMimePlanOption PlanBuffers  = "buffers"
+toMimePlanOption PlanWAL      = "wal"
+
+toMimePlanFormat :: MTVndPlanFormat -> ByteString
+toMimePlanFormat PlanJSON = "json"
+toMimePlanFormat PlanText = "text"
+
+-- | Convert from ByteString to MediaType.
+--
+-- >>> decodeMediaType "application/json"
+-- MTApplicationJSON
+--
+-- >>> decodeMediaType "application/vnd.pgrst.plan;"
+-- MTVndPlan MTApplicationJSON PlanText []
+--
+-- >>> decodeMediaType "application/vnd.pgrst.plan;for=\"application/json\""
+-- MTVndPlan MTApplicationJSON PlanText []
+--
+-- >>> decodeMediaType "application/vnd.pgrst.plan+json;for=\"text/csv\""
+-- MTVndPlan MTTextCSV PlanJSON []
+--
+-- >>> decodeMediaType "application/vnd.pgrst.array+json;nulls=stripped"
+-- MTVndArrayJSONStrip
+--
+-- >>> decodeMediaType "application/vnd.pgrst.array+json"
+-- MTApplicationJSON
+--
+-- >>> decodeMediaType "application/vnd.pgrst.object+json;nulls=stripped"
+-- MTVndSingularJSON True
+--
+-- >>> decodeMediaType "application/vnd.pgrst.object+json"
+-- MTVndSingularJSON False
+
+decodeMediaType :: BS.ByteString -> MediaType
+decodeMediaType mt =
+  case BS.split (BS.c2w ';') mt of
+    "application/json":_                     -> MTApplicationJSON
+    "application/geo+json":_                 -> MTGeoJSON
+    "text/csv":_                             -> MTTextCSV
+    "text/plain":_                           -> MTTextPlain
+    "text/xml":_                             -> MTTextXML
+    "application/openapi+json":_             -> MTOpenAPI
+    "application/x-www-form-urlencoded":_    -> MTUrlEncoded
+    "application/octet-stream":_             -> MTOctetStream
+    "application/vnd.pgrst.plan":rest        -> getPlan PlanText rest
+    "application/vnd.pgrst.plan+text":rest   -> getPlan PlanText rest
+    "application/vnd.pgrst.plan+json":rest   -> getPlan PlanJSON rest
+    "application/vnd.pgrst.object+json":rest -> checkSingularNullStrip rest
+    "application/vnd.pgrst.object":rest      -> checkSingularNullStrip rest
+    "application/vnd.pgrst.array+json":rest  -> checkArrayNullStrip rest
+    "application/vnd.pgrst.array":rest       -> checkArrayNullStrip rest
+    "*/*":_                                  -> MTAny
+    other:_                                  -> MTOther other
+    _                                        -> MTAny
+  where
+    checkArrayNullStrip ["nulls=stripped"] = MTVndArrayJSONStrip
+    checkArrayNullStrip  _                 = MTApplicationJSON
+
+    checkSingularNullStrip ["nulls=stripped"] = MTVndSingularJSON True
+    checkSingularNullStrip  _                 = MTVndSingularJSON False
+
+    getPlan fmt rest =
+      let
+        opts         = BS.split (BS.c2w '|') $ fromMaybe mempty (BS.stripPrefix "options=" =<< find (BS.isPrefixOf "options=") rest)
+        inOpts str   = str `elem` opts
+        dropAround p = BS.dropWhile p . BS.dropWhileEnd p
+        mtFor        = fromMaybe MTApplicationJSON $ do
+          foundFor    <- find (BS.isPrefixOf "for=") rest
+          strippedFor <- BS.stripPrefix "for=" foundFor
+          pure . decodeMediaType $ dropAround (== BS.c2w '"') strippedFor
+      in
+      MTVndPlan mtFor fmt $
+        [PlanAnalyze  | inOpts "analyze" ] ++
+        [PlanVerbose  | inOpts "verbose" ] ++
+        [PlanSettings | inOpts "settings"] ++
+        [PlanBuffers  | inOpts "buffers" ] ++
+        [PlanWAL      | inOpts "wal"     ]

src/PostgREST/Middleware.hs

@@ -1,204 +0,0 @@
-{-|
-Module      : PostgREST.Middleware
-Description : Sets CORS policy. Also the PostgreSQL GUCs, role, search_path and pre-request function.
--}
-{-# LANGUAGE RecordWildCards #-}
-module PostgREST.Middleware
-  ( runPgLocals
-  , pgrstFormat
-  , pgrstMiddleware
-  , defaultCorsPolicy
-  , corsPolicy
-  , optionalRollback
-  ) where
-
-import qualified Data.Aeson                           as JSON
-import qualified Data.ByteString.Char8                as BS
-import qualified Data.ByteString.Lazy.Char8           as LBS
-import qualified Data.CaseInsensitive                 as CI
-import qualified Data.HashMap.Strict                  as M
-import qualified Data.Text                            as T
-import qualified Data.Text.Encoding                   as T
-import qualified Hasql.Decoders                       as HD
-import qualified Hasql.DynamicStatements.Snippet      as SQL hiding
-                                                             (sql)
-import qualified Hasql.DynamicStatements.Statement    as SQL
-import qualified Hasql.Transaction                    as SQL
-import qualified Network.Wai                          as Wai
-import qualified Network.Wai.Logger                   as Wai
-import qualified Network.Wai.Middleware.Cors          as Wai
-import qualified Network.Wai.Middleware.Gzip          as Wai
-import qualified Network.Wai.Middleware.RequestLogger as Wai
-import qualified Network.Wai.Middleware.Static        as Wai
-
-import Control.Arrow ((***))
-
-import Data.Function             (id)
-import Data.List                 (lookup)
-import Data.Scientific           (FPFormat (..), formatScientific,
-                                  isInteger)
-import Network.HTTP.Types.Status (Status, status400, status500,
-                                  statusCode)
-import System.IO.Unsafe          (unsafePerformIO)
-import System.Log.FastLogger     (toLogStr)
-
-import PostgREST.Config             (AppConfig (..), LogLevel (..))
-import PostgREST.Config.PgVersion   (PgVersion (..), pgVersion140)
-import PostgREST.Error              (Error, errorResponseFor)
-import PostgREST.GucHeader          (addHeadersIfNotIncluded)
-import PostgREST.Query.SqlFragment  (fromQi, intercalateSnippet,
-                                     unknownEncoder)
-import PostgREST.Request.ApiRequest (ApiRequest (..), Target (..))
-
-import PostgREST.Request.Preferences
-
-import Protolude
-
--- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function
-runPgLocals :: AppConfig   -> M.HashMap Text JSON.Value ->
-               (ApiRequest -> ExceptT Error SQL.Transaction Wai.Response) ->
-               ApiRequest  -> ByteString -> PgVersion -> ExceptT Error SQL.Transaction Wai.Response
-runPgLocals conf claims app req jsonDbS actualPgVersion = do
-  lift $ SQL.statement mempty $ SQL.dynamicallyParameterized
-    ("select " <> intercalateSnippet ", " (searchPathSql : roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql ++ specSql))
-    HD.noResult (configDbPreparedStatements conf)
-  lift $ traverse_ SQL.sql preReqSql
-  app req
-  where
-    methodSql = setConfigLocal mempty ("request.method", iMethod req)
-    pathSql = setConfigLocal mempty ("request.path", iPath req)
-    headersSql = if usesLegacyGucs
-                   then setConfigLocal "request.header." <$> iHeaders req
-                   else setConfigLocalJson "request.headers" (iHeaders req)
-    cookiesSql = if usesLegacyGucs
-                   then setConfigLocal "request.cookie." <$> iCookies req
-                   else setConfigLocalJson "request.cookies" (iCookies req)
-    claimsWithRole =
-      let anon = JSON.String . toS $ configDbAnonRole conf in -- role claim defaults to anon if not specified in jwt
-      M.union claims (M.singleton "role" anon)
-    claimsSql = if usesLegacyGucs
-                  then setConfigLocal "request.jwt.claim." <$> [(toUtf8 c, toUtf8 $ unquoted v) | (c,v) <- M.toList claimsWithRole]
-                  else [setConfigLocal mempty ("request.jwt.claims", LBS.toStrict $ JSON.encode claimsWithRole)]
-    roleSql = maybeToList $ (\x -> setConfigLocal mempty ("role", toUtf8 $ unquoted x)) <$> M.lookup "role" claimsWithRole
-    appSettingsSql = setConfigLocal mempty <$> (join bimap toUtf8 <$> configAppSettings conf)
-    searchPathSql =
-      let schemas = T.intercalate ", " (iSchema req : configDbExtraSearchPath conf) in
-      setConfigLocal mempty ("search_path", toUtf8 schemas)
-    preReqSql = (\f -> "select " <> fromQi f <> "();") <$> configDbPreRequest conf
-    specSql = case iTarget req of
-      TargetProc{tpIsRootSpec=True} -> [setConfigLocal mempty ("request.spec", jsonDbS)]
-      _                             -> mempty
-    usesLegacyGucs = configDbUseLegacyGucs conf && actualPgVersion < pgVersion140
-
--- | Log in apache format. Only requests that have a status greater than minStatus are logged.
--- | There's no way to filter logs in the apache format on wai-extra: https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html#t:OutputFormat.
--- | So here we copy wai-logger apacheLogStr function: https://github.com/kazu-yamamoto/logger/blob/a4f51b909a099c51af7a3f75cf16e19a06f9e257/wai-logger/Network/Wai/Logger/Apache.hs#L45
--- | TODO: Add the ability to filter apache logs on wai-extra and remove this function.
-pgrstFormat :: Status -> Wai.OutputFormatter
-pgrstFormat minStatus date req status responseSize =
-  if status < minStatus
-    then mempty
-  else toLogStr (getSourceFromSocket req)
-    <> " - - ["
-    <> toLogStr date
-    <> "] \""
-    <> toLogStr (Wai.requestMethod req)
-    <> " "
-    <> toLogStr (Wai.rawPathInfo req <> Wai.rawQueryString req)
-    <> " "
-    <> toLogStr (show (Wai.httpVersion req)::Text)
-    <> "\" "
-    <> toLogStr (show (statusCode status)::Text)
-    <> " "
-    <> toLogStr (maybe "-" show responseSize::Text)
-    <> " \""
-    <> toLogStr (fromMaybe mempty $ Wai.requestHeaderReferer req)
-    <> "\" \""
-    <> toLogStr (fromMaybe mempty $ Wai.requestHeaderUserAgent req)
-    <> "\"\n"
-  where
-    getSourceFromSocket = BS.pack . Wai.showSockAddr . Wai.remoteHost
-
-pgrstMiddleware :: LogLevel -> Wai.Application -> Wai.Application
-pgrstMiddleware logLevel =
-    logger
-  . Wai.cors corsPolicy
-  . Wai.staticPolicy (Wai.only [("favicon.ico", "static/favicon.ico")])
-  where
-    logger = case logLevel of
-      LogCrit  -> id
-      LogError -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status500}
-      LogWarn  -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400}
-      LogInfo  -> Wai.logStdout
-
-defaultCorsPolicy :: Wai.CorsResourcePolicy
-defaultCorsPolicy =  Wai.CorsResourcePolicy Nothing
-  ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing
-  (Just $ 60*60*24) False False True
-
--- | CORS policy to be used in by Wai Cors middleware
-corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy
-corsPolicy req = case lookup "origin" headers of
-  Just origin -> Just defaultCorsPolicy {
-      Wai.corsOrigins = Just ([origin], True)
-    , Wai.corsRequestHeaders = "Authentication" : accHeaders
-    , Wai.corsExposedHeaders = Just [
-        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
-      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
-      ]
-    }
-  Nothing -> Nothing
-  where
-    headers = Wai.requestHeaders req
-    accHeaders = case lookup "access-control-request-headers" headers of
-      Just hdrs -> map (CI.mk . BS.strip) $ BS.split ',' hdrs
-      Nothing   -> []
-
-unquoted :: JSON.Value -> Text
-unquoted (JSON.String t) = t
-unquoted (JSON.Number n) =
-  toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
-unquoted (JSON.Bool b) = show b
-unquoted v = T.decodeUtf8 . LBS.toStrict $ JSON.encode v
-
--- | Set a transaction to eventually roll back if requested and set respective
--- headers on the response.
-optionalRollback
-  :: AppConfig
-  -> ApiRequest
-  -> ExceptT Error SQL.Transaction Wai.Response
-  -> ExceptT Error SQL.Transaction Wai.Response
-optionalRollback AppConfig{..} ApiRequest{..} transaction = do
-  resp <- catchError transaction $ return . errorResponseFor
-  when (shouldRollback || (configDbTxRollbackAll && not shouldCommit))
-    (lift SQL.condemn)
-  return $ Wai.mapResponseHeaders preferenceApplied resp
-  where
-    shouldCommit =
-      configDbTxAllowOverride && iPreferTransaction == Just Commit
-    shouldRollback =
-      configDbTxAllowOverride && iPreferTransaction == Just Rollback
-    preferenceApplied
-      | shouldCommit =
-          addHeadersIfNotIncluded
-            [toAppliedHeader Commit]
-      | shouldRollback =
-          addHeadersIfNotIncluded
-            [toAppliedHeader Rollback]
-      | otherwise =
-          identity
-
--- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
-setConfigLocal :: ByteString -> (ByteString, ByteString) -> SQL.Snippet
-setConfigLocal prefix (k, v) =
-  "set_config(" <> unknownEncoder (prefix <> k) <> ", " <> unknownEncoder v <> ", true)"
-
--- | Starting from PostgreSQL v14, some characters are not allowed for config names (mostly affecting headers with "-").
--- | A JSON format string is used to avoid this problem. See https://github.com/PostgREST/postgrest/issues/1857
-setConfigLocalJson :: ByteString -> [(ByteString, ByteString)] -> [SQL.Snippet]
-setConfigLocalJson prefix keyVals = [setConfigLocal mempty (prefix, gucJsonVal keyVals)]
-  where
-    gucJsonVal :: [(ByteString, ByteString)] -> ByteString
-    gucJsonVal = LBS.toStrict . JSON.encode . M.fromList . arrayByteStringToText
-    arrayByteStringToText :: [(ByteString, ByteString)] -> [(Text,Text)]
-    arrayByteStringToText keyVal = (T.decodeUtf8 *** T.decodeUtf8) <$> keyVal

src/PostgREST/Plan/CallPlan.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module PostgREST.Plan.CallPlan
+  ( CallPlan(..)
+  , CallParams(..)
+  , jsonRpcParams
+  )
+where
+
+import qualified Data.Aeson                        as JSON
+import qualified Data.ByteString.Lazy              as LBS
+import qualified Data.HashMap.Strict               as HM
+import           PostgREST.SchemaCache.Identifiers (FieldName,
+                                                    QualifiedIdentifier)
+import           PostgREST.SchemaCache.Routine     (Routine (..),
+                                                    RoutineParam (..))
+
+import Protolude
+
+data CallPlan = FunctionCall
+  { funCQi                :: QualifiedIdentifier
+  , funCParams            :: CallParams
+  , funCArgs              :: Maybe LBS.ByteString
+  , funCScalar            :: Bool
+  , funCSetOfScalar       :: Bool
+  , funCRetCompositeAlias :: Bool
+  , funCReturning         :: [FieldName]
+  }
+
+data CallParams
+  = KeyParams [RoutineParam] -- ^ Call with key params: func(a := val1, b:= val2)
+  | OnePosParam RoutineParam -- ^ Call with positional params(only one supported): func(val)
+
+-- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"}
+jsonRpcParams :: Routine -> [(Text, Text)] -> LBS.ByteString
+jsonRpcParams proc prms =
+  if not $ pdHasVariadic proc then -- if proc has no variadic param, save steps and directly convert to json
+    JSON.encode $ HM.fromList $ second JSON.toJSON <$> prms
+  else
+    let paramsMap = HM.fromListWith mergeParams $ toRpcParamValue proc <$> prms in
+    JSON.encode paramsMap
+  where
+    mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue
+    mergeParams (Variadic a) (Variadic b) = Variadic $ b ++ a
+    mergeParams v _                       = v -- repeated params for non-variadic parameters are not merged
+
+toRpcParamValue :: Routine -> (Text, Text) -> (Text, RpcParamValue)
+toRpcParamValue proc (k, v) | prmIsVariadic k = (k, Variadic [v])
+                            | otherwise       = (k, Fixed v)
+  where
+    prmIsVariadic prm = isJust $ find (\RoutineParam{ppName, ppVar} -> ppName == prm && ppVar) $ pdParams proc
+
+-- | RPC query param value `/rpc/func?v=<value>`, used for VARIADIC functions on form-urlencoded POST and GETs
+-- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3.
+data RpcParamValue = Fixed Text | Variadic [Text]
+instance JSON.ToJSON RpcParamValue where
+  toJSON (Fixed    v) = JSON.toJSON v
+  toJSON (Variadic v) = JSON.toJSON v

src/PostgREST/Plan/MutatePlan.hs

@@ -0,0 +1,46 @@
+module PostgREST.Plan.MutatePlan
+  ( MutatePlan(..)
+  )
+where
+
+import qualified Data.ByteString.Lazy as LBS
+
+import PostgREST.ApiRequest.Preferences  (PreferResolution)
+import PostgREST.Plan.Types              (CoercibleField,
+                                          CoercibleLogicTree,
+                                          CoercibleOrderTerm)
+import PostgREST.RangeQuery              (NonnegRange)
+import PostgREST.SchemaCache.Identifiers (FieldName,
+                                          QualifiedIdentifier)
+
+
+import Protolude
+
+data MutatePlan
+  = Insert
+      { in_        :: QualifiedIdentifier
+      , insCols    :: [CoercibleField]
+      , insBody    :: Maybe LBS.ByteString
+      , onConflict :: Maybe (PreferResolution, [FieldName])
+      , where_     :: [CoercibleLogicTree]
+      , returning  :: [FieldName]
+      , insPkCols  :: [FieldName]
+      , applyDefs  :: Bool
+      }
+  | Update
+      { in_       :: QualifiedIdentifier
+      , updCols   :: [CoercibleField]
+      , updBody   :: Maybe LBS.ByteString
+      , where_    :: [CoercibleLogicTree]
+      , mutRange  :: NonnegRange
+      , mutOrder  :: [CoercibleOrderTerm]
+      , returning :: [FieldName]
+      , applyDefs :: Bool
+      }
+  | Delete
+      { in_       :: QualifiedIdentifier
+      , where_    :: [CoercibleLogicTree]
+      , mutRange  :: NonnegRange
+      , mutOrder  :: [CoercibleOrderTerm]
+      , returning :: [FieldName]
+      }

src/PostgREST/Plan/ReadPlan.hs

@@ -0,0 +1,50 @@
+module PostgREST.Plan.ReadPlan
+  ( ReadPlanTree
+  , ReadPlan(..)
+  , JoinCondition(..)
+  ) where
+
+import Data.Tree (Tree (..))
+
+import PostgREST.ApiRequest.Types         (Alias, Depth, Hint,
+                                           JoinType, NodeName)
+import PostgREST.Plan.Types               (CoercibleLogicTree,
+                                           CoercibleOrderTerm,
+                                           CoercibleSelectField (..),
+                                           RelSelectField (..))
+import PostgREST.RangeQuery               (NonnegRange)
+import PostgREST.SchemaCache.Identifiers  (FieldName,
+                                           QualifiedIdentifier)
+import PostgREST.SchemaCache.Relationship (Relationship)
+
+
+import Protolude
+
+type ReadPlanTree = Tree ReadPlan
+
+data JoinCondition =
+  JoinCondition
+    (QualifiedIdentifier, FieldName)
+    (QualifiedIdentifier, FieldName)
+  deriving (Eq, Show)
+
+data ReadPlan = ReadPlan
+  { select       :: [CoercibleSelectField]
+  , from         :: QualifiedIdentifier
+  , fromAlias    :: Maybe Alias
+  , where_       :: [CoercibleLogicTree]
+  , order        :: [CoercibleOrderTerm]
+  , range_       :: NonnegRange
+  , relName      :: NodeName
+  , relToParent  :: Maybe Relationship
+  , relJoinConds :: [JoinCondition]
+  , relAlias     :: Maybe Alias
+  , relAggAlias  :: Alias
+  , relHint      :: Maybe Hint
+  , relJoinType  :: Maybe JoinType
+  , relIsSpread  :: Bool
+  , relSelect    :: [RelSelectField]
+  , depth        :: Depth
+  -- ^ used for aliasing
+  }
+  deriving (Eq, Show)

src/PostgREST/Plan/Types.hs

@@ -0,0 +1,106 @@
+module PostgREST.Plan.Types
+  ( CoercibleField(..)
+  , CoercibleSelectField(..)
+  , unknownField
+  , CoercibleLogicTree(..)
+  , CoercibleFilter(..)
+  , TransformerProc
+  , CoercibleOrderTerm(..)
+  , RelSelectField(..)
+  , RelJsonEmbedMode(..)
+  , SpreadSelectField(..)
+  ) where
+
+import PostgREST.ApiRequest.Types (AggregateFunction, Alias, Cast,
+                                   Field, JsonPath, LogicOperator,
+                                   OpExpr, OrderDirection, OrderNulls)
+
+import PostgREST.SchemaCache.Identifiers (FieldName)
+
+import Protolude
+
+type TransformerProc = Text
+
+-- | A CoercibleField pairs the name of a query element with any type coercion information we need for some specific use case.
+-- |
+-- | As suggested by the name, it's often a reference to a field in a table but really it can be any nameable element (function parameter, calculation with an alias, etc) with a knowable type.
+-- |
+-- | In the simplest case, it allows us to parse JSON payloads with `json_to_recordset`, for which we need to know both the name and the type of each thing we'd like to extract. At a higher level, CoercibleField generalises to reflect that any value we work with in a query may need type specific handling.
+-- |
+-- | CoercibleField is the foundation for the Data Representations feature. This feature allow user-definable mappings between database types so that the same data can be presented or interpreted in various ways as needed. Sometimes the way Postgres coerces data implicitly isn't right for the job. Different mappings might be appropriate for different situations: parsing a filter from a query string requires one function (text -> field type) while parsing a payload from JSON takes another (json -> field type). And the reverse, outputting a field as JSON, requires yet a third (field type -> json). CoercibleField is that "job specific" reference to an element paired with the type we desire for that particular purpose and the function we'll use to get there, if any.
+-- |
+-- | In the planning phase, we "resolve" generic named elements into these specialised CoercibleFields. Again this is context specific: two different CoercibleFields both representing the exact same table column in the database, even in the same query, might have two different target types and mapping functions. For example, one might represent a column in a filter, and another the very same column in an output role to be sent in the response body.
+-- |
+-- | The type value is allowed to be the empty string. The analog here is soft type checking in programming languages: sometimes we don't need a variable to have a specified type and things will work anyhow. So the empty type variant is valid when we don't know and *don't need to know* about the specific type in some context. Note that this variation should not be used if it guarantees failure: in that case you should instead raise an error at the planning stage and bail out. For example, we can't parse JSON with `json_to_recordset` without knowing the types of each recipient field, and so error out. Using the empty string for the type would be incorrect and futile. On the other hand we use the empty type for RPC calls since type resolution isn't implemented for RPC, but it's fine because the query still works with Postgres' implicit coercion. In the future, hopefully we will support data representations across the board and then the empty type may be permanently retired.
+data CoercibleField = CoercibleField
+  { cfName      :: FieldName
+  , cfJsonPath  :: JsonPath
+  , cfToJson    :: Bool
+  , cfIRType    :: Text                  -- ^ The native Postgres type of the field, the intermediate (IR) type before mapping.
+  , cfTransform :: Maybe TransformerProc -- ^ The optional mapping from irType -> targetType.
+  , cfDefault   :: Maybe Text
+  } deriving (Eq, Show)
+
+unknownField :: FieldName -> JsonPath -> CoercibleField
+unknownField name path = CoercibleField name path False "" Nothing Nothing
+
+-- | Like an API request LogicTree, but with coercible field information.
+data CoercibleLogicTree
+  = CoercibleExpr Bool LogicOperator [CoercibleLogicTree]
+  | CoercibleStmnt CoercibleFilter
+  deriving (Eq, Show)
+
+data CoercibleFilter = CoercibleFilter
+  { field  :: CoercibleField
+  , opExpr :: OpExpr
+  }
+  | CoercibleFilterNullEmbed Bool FieldName
+  deriving (Eq, Show)
+
+data CoercibleOrderTerm
+  = CoercibleOrderTerm
+    { coField     :: CoercibleField
+    , coDirection :: Maybe OrderDirection
+    , coNullOrder :: Maybe OrderNulls
+    }
+  | CoercibleOrderRelationTerm
+    { coRelation  :: FieldName
+    , coRelTerm   :: Field
+    , coDirection :: Maybe OrderDirection
+    , coNullOrder :: Maybe OrderNulls
+    }
+  deriving (Eq, Show)
+
+data CoercibleSelectField = CoercibleSelectField
+  { csField       :: CoercibleField
+  , csAggFunction :: Maybe AggregateFunction
+  , csAggCast     :: Maybe Cast
+  , csCast        :: Maybe Cast
+  , csAlias       :: Maybe Alias
+  }
+  deriving (Eq, Show)
+
+data RelJsonEmbedMode = JsonObject | JsonArray
+  deriving (Show, Eq)
+
+data RelSelectField
+  = JsonEmbed
+      { rsSelName    :: FieldName
+      , rsAggAlias   :: Alias
+      , rsEmbedMode  :: RelJsonEmbedMode
+      , rsEmptyEmbed :: Bool
+      }
+  | Spread
+      { rsSpreadSel :: [SpreadSelectField]
+      , rsAggAlias  :: Alias
+      }
+  deriving (Eq, Show)
+
+data SpreadSelectField =
+  SpreadSelectField
+  { ssSelName        :: FieldName
+  , ssSelAggFunction :: Maybe AggregateFunction
+  , ssSelAggCast     :: Maybe Cast
+  , ssSelAlias       :: Maybe Alias
+  }
+  deriving (Eq, Show)

src/PostgREST/Query.hs

@@ -0,0 +1,267 @@
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.Query
+  ( createQuery
+  , deleteQuery
+  , invokeQuery
+  , openApiQuery
+  , readQuery
+  , singleUpsertQuery
+  , updateQuery
+  , setPgLocals
+  , runPreReq
+  , DbHandler
+  ) where
+
+import qualified Data.Aeson                        as JSON
+import qualified Data.Aeson.KeyMap                 as KM
+import qualified Data.ByteString                   as BS
+import qualified Data.ByteString.Lazy.Char8        as LBS
+import qualified Data.HashMap.Strict               as HM
+import qualified Data.Set                          as S
+import qualified Hasql.Decoders                    as HD
+import qualified Hasql.DynamicStatements.Snippet   as SQL (Snippet)
+import qualified Hasql.DynamicStatements.Statement as SQL
+import qualified Hasql.Transaction                 as SQL
+
+import qualified PostgREST.ApiRequest.Types   as ApiRequestTypes
+import qualified PostgREST.Error              as Error
+import qualified PostgREST.Query.QueryBuilder as QueryBuilder
+import qualified PostgREST.Query.Statements   as Statements
+import qualified PostgREST.RangeQuery         as RangeQuery
+import qualified PostgREST.SchemaCache        as SchemaCache
+
+import PostgREST.ApiRequest              (ApiRequest (..))
+import PostgREST.ApiRequest.Preferences  (PreferCount (..),
+                                          PreferTimezone (..),
+                                          PreferTransaction (..),
+                                          Preferences (..),
+                                          shouldCount)
+import PostgREST.Config                  (AppConfig (..),
+                                          OpenAPIMode (..))
+import PostgREST.Config.PgVersion        (PgVersion (..))
+import PostgREST.Error                   (Error)
+import PostgREST.MediaType               (MediaType (..))
+import PostgREST.Plan                    (CallReadPlan (..),
+                                          MutateReadPlan (..),
+                                          WrappedReadPlan (..))
+import PostgREST.Plan.MutatePlan         (MutatePlan (..))
+import PostgREST.Query.SqlFragment       (escapeIdentList, fromQi,
+                                          intercalateSnippet,
+                                          setConfigWithConstantName,
+                                          setConfigWithConstantNameJSON,
+                                          setConfigWithDynamicName)
+import PostgREST.Query.Statements        (ResultSet (..))
+import PostgREST.SchemaCache             (SchemaCache (..))
+import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
+                                          Schema)
+import PostgREST.SchemaCache.Routine     (Routine (..), RoutineMap)
+import PostgREST.SchemaCache.Table       (TablesMap)
+
+import Protolude hiding (Handler)
+
+type DbHandler = ExceptT Error SQL.Transaction
+
+readQuery :: WrappedReadPlan -> AppConfig -> ApiRequest -> DbHandler ResultSet
+readQuery WrappedReadPlan{..} conf@AppConfig{..} apiReq@ApiRequest{iPreferences=Preferences{..}} = do
+  let countQuery = QueryBuilder.readPlanToCountQuery wrReadPlan
+  resultSet <-
+     lift . SQL.statement mempty $
+      Statements.prepareRead
+        wrIdent
+        (QueryBuilder.readPlanToQuery wrReadPlan)
+        (if preferCount == Just EstimatedCount then
+           -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed
+           QueryBuilder.limitedQuery countQuery ((+ 1) <$> configDbMaxRows)
+         else
+           countQuery
+        )
+        (shouldCount preferCount)
+        wrMedia
+        wrHandler
+        configDbPreparedStatements
+  failNotSingular wrMedia resultSet
+  optionalRollback conf apiReq
+  resultSetWTotal conf apiReq resultSet countQuery
+
+resultSetWTotal :: AppConfig -> ApiRequest -> ResultSet -> SQL.Snippet -> DbHandler ResultSet
+resultSetWTotal _ _ rs@RSPlan{} _ = return rs
+resultSetWTotal AppConfig{..} ApiRequest{iPreferences=Preferences{..}} rs@RSStandard{rsTableTotal=tableTotal} countQuery =
+  case preferCount of
+    Just PlannedCount -> do
+      total <- explain
+      return rs{rsTableTotal=total}
+    Just EstimatedCount ->
+      if tableTotal > (fromIntegral <$> configDbMaxRows) then do
+        total <- max tableTotal <$> explain
+        return rs{rsTableTotal=total}
+      else
+        return rs
+    Just ExactCount ->
+      return rs
+    Nothing ->
+      return rs
+  where
+    explain =
+      lift . SQL.statement mempty . Statements.preparePlanRows countQuery $
+        configDbPreparedStatements
+
+createQuery :: MutateReadPlan -> ApiRequest -> AppConfig -> DbHandler ResultSet
+createQuery mrPlan@MutateReadPlan{mrMedia} apiReq conf = do
+  resultSet <- writeQuery mrPlan apiReq conf
+  failNotSingular mrMedia resultSet
+  optionalRollback conf apiReq
+  pure resultSet
+
+updateQuery :: MutateReadPlan -> ApiRequest -> AppConfig -> DbHandler ResultSet
+updateQuery mrPlan@MutateReadPlan{mrMedia} apiReq@ApiRequest{..} conf = do
+  resultSet <- writeQuery mrPlan apiReq conf
+  failNotSingular mrMedia resultSet
+  failsChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) resultSet
+  optionalRollback conf apiReq
+  pure resultSet
+
+singleUpsertQuery :: MutateReadPlan -> ApiRequest -> AppConfig -> DbHandler ResultSet
+singleUpsertQuery mrPlan apiReq conf = do
+  resultSet <- writeQuery mrPlan apiReq conf
+  failPut resultSet
+  optionalRollback conf apiReq
+  pure resultSet
+
+-- 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
+failPut :: ResultSet -> DbHandler ()
+failPut RSPlan{} = pure ()
+failPut RSStandard{rsQueryTotal=queryTotal} =
+  when (queryTotal /= 1) $ do
+    lift SQL.condemn
+    throwError $ Error.ApiRequestError ApiRequestTypes.PutMatchingPkError
+
+deleteQuery :: MutateReadPlan -> ApiRequest -> AppConfig -> DbHandler ResultSet
+deleteQuery mrPlan@MutateReadPlan{mrMedia} apiReq@ApiRequest{..} conf = do
+  resultSet <- writeQuery mrPlan apiReq conf
+  failNotSingular mrMedia resultSet
+  failsChangesOffLimits (RangeQuery.rangeLimit iTopLevelRange) resultSet
+  optionalRollback conf apiReq
+  pure resultSet
+
+invokeQuery :: Routine -> CallReadPlan -> ApiRequest -> AppConfig -> PgVersion -> DbHandler ResultSet
+invokeQuery rout CallReadPlan{..} apiReq@ApiRequest{iPreferences=Preferences{..}} conf@AppConfig{..} pgVer = do
+  resultSet <-
+    lift . SQL.statement mempty $
+      Statements.prepareCall
+        crIdent
+        rout
+        (QueryBuilder.callPlanToQuery crCallPlan pgVer)
+        (QueryBuilder.readPlanToQuery crReadPlan)
+        (QueryBuilder.readPlanToCountQuery crReadPlan)
+        (shouldCount preferCount)
+        crMedia
+        crHandler
+        configDbPreparedStatements
+
+  optionalRollback conf apiReq
+  failNotSingular crMedia resultSet
+  pure resultSet
+
+openApiQuery :: SchemaCache -> PgVersion -> AppConfig -> Schema -> DbHandler (Maybe (TablesMap, RoutineMap, Maybe Text))
+openApiQuery sCache pgVer AppConfig{..} tSchema =
+  lift $ case configOpenApiMode of
+    OAFollowPriv -> do
+      tableAccess <- SQL.statement [tSchema] (SchemaCache.accessibleTables pgVer configDbPreparedStatements)
+      Just <$> ((,,)
+            (HM.filterWithKey (\qi _ -> S.member qi tableAccess) $ SchemaCache.dbTables sCache)
+        <$> SQL.statement tSchema (SchemaCache.accessibleFuncs pgVer configDbPreparedStatements)
+        <*> SQL.statement tSchema (SchemaCache.schemaDescription configDbPreparedStatements))
+    OAIgnorePriv ->
+      Just <$> ((,,)
+            (HM.filterWithKey (\(QualifiedIdentifier sch _) _ ->  sch == tSchema) $ SchemaCache.dbTables sCache)
+            (HM.filterWithKey (\(QualifiedIdentifier sch _) _ ->  sch == tSchema) $ SchemaCache.dbRoutines sCache)
+        <$> SQL.statement tSchema (SchemaCache.schemaDescription configDbPreparedStatements))
+    OADisabled ->
+      pure Nothing
+
+writeQuery :: MutateReadPlan -> ApiRequest -> AppConfig  -> DbHandler ResultSet
+writeQuery MutateReadPlan{..} ApiRequest{iPreferences=Preferences{..}} conf =
+  let
+    (isPut, isInsert, pkCols) = case mrMutatePlan of {Insert{where_,insPkCols} -> ((not . null) where_, True, insPkCols); _ -> (False,False, mempty);}
+  in
+  lift . SQL.statement mempty $
+    Statements.prepareWrite
+      mrIdent
+      (QueryBuilder.readPlanToQuery mrReadPlan)
+      (QueryBuilder.mutatePlanToQuery mrMutatePlan)
+      isInsert
+      isPut
+      mrMedia
+      mrHandler
+      preferRepresentation
+      preferResolution
+      pkCols
+      (configDbPreparedStatements conf)
+
+-- |
+-- Fail a response if a single JSON object was requested and not exactly one
+-- was found.
+failNotSingular :: MediaType -> ResultSet -> DbHandler ()
+failNotSingular _ RSPlan{} = pure ()
+failNotSingular mediaType RSStandard{rsQueryTotal=queryTotal} =
+  when (elem mediaType [MTVndSingularJSON True, MTVndSingularJSON False] && queryTotal /= 1) $ do
+    lift SQL.condemn
+    throwError $ Error.ApiRequestError . ApiRequestTypes.SingularityError $ toInteger queryTotal
+
+failsChangesOffLimits :: Maybe Integer -> ResultSet -> DbHandler ()
+failsChangesOffLimits _ RSPlan{} = pure ()
+failsChangesOffLimits Nothing _  = pure ()
+failsChangesOffLimits (Just maxChanges) RSStandard{rsQueryTotal=queryTotal} =
+  when (queryTotal > fromIntegral maxChanges) $ do
+    lift SQL.condemn
+    throwError $ Error.ApiRequestError $ ApiRequestTypes.OffLimitsChangesError queryTotal maxChanges
+
+-- | Set a transaction to roll back if requested
+optionalRollback :: AppConfig -> ApiRequest -> DbHandler ()
+optionalRollback AppConfig{..} ApiRequest{iPreferences=Preferences{..}} = do
+  lift $ when (shouldRollback || (configDbTxRollbackAll && not shouldCommit)) $ do
+    SQL.sql "SET CONSTRAINTS ALL IMMEDIATE"
+    SQL.condemn
+  where
+    shouldCommit =
+      preferTransaction == Just Commit
+    shouldRollback =
+      preferTransaction == Just Rollback
+
+-- | Set transaction scoped settings
+setPgLocals :: AppConfig  -> KM.KeyMap JSON.Value -> BS.ByteString -> [(ByteString, ByteString)] ->
+               ApiRequest -> Maybe Text -> DbHandler ()
+setPgLocals AppConfig{..} claims role roleSettings ApiRequest{..} tout = lift $
+  SQL.statement mempty $ SQL.dynamicallyParameterized
+    -- To ensure `GRANT SET ON PARAMETER <superuser_setting> TO authenticator` works, the role settings must be set before the impersonated role.
+    -- Otherwise the GRANT SET would have to be applied to the impersonated role. See https://github.com/PostgREST/postgrest/issues/3045
+    ("select " <> intercalateSnippet ", " (searchPathSql : roleSettingsSql ++ roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ timezoneSql ++ timeoutSql ++ appSettingsSql))
+    HD.noResult configDbPreparedStatements
+  where
+    methodSql = setConfigWithConstantName ("request.method", iMethod)
+    pathSql = setConfigWithConstantName ("request.path", iPath)
+    headersSql = setConfigWithConstantNameJSON "request.headers" iHeaders
+    cookiesSql = setConfigWithConstantNameJSON "request.cookies" iCookies
+    claimsSql = [setConfigWithConstantName ("request.jwt.claims", LBS.toStrict $ JSON.encode claims)]
+    roleSql = [setConfigWithConstantName ("role", role)]
+    roleSettingsSql = setConfigWithDynamicName <$> roleSettings
+    appSettingsSql = setConfigWithDynamicName <$> (join bimap toUtf8 <$> configAppSettings)
+    timezoneSql = maybe mempty (\(PreferTimezone tz) -> [setConfigWithConstantName ("timezone", tz)]) $ preferTimezone iPreferences
+    timeoutSql = maybe mempty ((\t -> [setConfigWithConstantName ("statement_timeout", t)]) . encodeUtf8) tout
+    searchPathSql =
+      let schemas = escapeIdentList (iSchema : configDbExtraSearchPath) in
+      setConfigWithConstantName ("search_path", schemas)
+
+-- | Runs the pre-request function.
+runPreReq :: AppConfig -> DbHandler ()
+runPreReq conf = lift $ traverse_ (SQL.statement mempty . stmt) (configDbPreRequest conf)
+  where
+    stmt req = SQL.dynamicallyParameterized
+      ("select " <> fromQi req <> "()")
+      HD.noResult
+      (configDbPreparedStatements conf)

src/PostgREST/Query/QueryBuilder.hs

@@ -1,179 +1,219 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-|
 Module      : PostgREST.Query.QueryBuilder
 Description : PostgREST SQL queries generating functions.
 
 This module provides functions to consume data types that
-represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment
+represent database queries (e.g. ReadPlanTree, MutatePlan) and SqlFragment
 to produce SqlQuery type outputs.
 -}
 module PostgREST.Query.QueryBuilder
-  ( readRequestToQuery
-  , mutateRequestToQuery
-  , readRequestToCountQuery
-  , requestToCallProcQuery
+  ( readPlanToQuery
+  , mutatePlanToQuery
+  , readPlanToCountQuery
+  , callPlanToQuery
   , limitedQuery
   ) where
 
 import qualified Data.ByteString.Char8           as BS
-import qualified Data.Set                        as S
 import qualified Hasql.DynamicStatements.Snippet as SQL
 
-import Data.Tree (Tree (..))
+import Data.Maybe (fromJust)
+import Data.Tree  (Tree (..))
 
-import PostgREST.DbStructure.Identifiers  (QualifiedIdentifier (..))
-import PostgREST.DbStructure.Proc         (ProcParam (..))
-import PostgREST.DbStructure.Relationship (Cardinality (..),
+import PostgREST.ApiRequest.Preferences   (PreferResolution (..))
+import PostgREST.Config.PgVersion         (PgVersion, pgVersion110,
+                                           pgVersion130)
+import PostgREST.SchemaCache.Identifiers  (QualifiedIdentifier (..))
+import PostgREST.SchemaCache.Relationship (Cardinality (..),
+                                           Junction (..),
                                            Relationship (..))
-import PostgREST.DbStructure.Table        (Table (..))
-import PostgREST.Request.Preferences      (PreferResolution (..))
+import PostgREST.SchemaCache.Routine      (RoutineParam (..))
 
+import PostgREST.ApiRequest.Types
+import PostgREST.Plan.CallPlan
+import PostgREST.Plan.MutatePlan
+import PostgREST.Plan.ReadPlan
+import PostgREST.Plan.Types
 import PostgREST.Query.SqlFragment
-import PostgREST.Request.Types
+import PostgREST.RangeQuery        (allRange)
 
 import Protolude
 
-readRequestToQuery :: ReadRequest -> SQL.Snippet
-readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) =
+readPlanToQuery :: ReadPlanTree -> SQL.Snippet
+readPlanToQuery node@(Node ReadPlan{select,from=mainQi,fromAlias,where_=logicForest,order, range_=readRange, relToParent, relJoinConds, relSelect} forest) =
   "SELECT " <>
-  intercalateSnippet ", " ((pgFmtSelectItem qi <$> colSelects) ++ selects) <>
-  "FROM " <> SQL.sql (BS.intercalate ", " (tabl : implJs)) <> " " <>
+  intercalateSnippet ", " ((pgFmtSelectItem qi <$> (if null select && null forest then defSelect else select)) ++ joinsSelects) <> " " <>
+  fromFrag <> " " <>
   intercalateSnippet " " joins <> " " <>
-  (if null logicForest && null joinConditions_ then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_))
-  <> " " <>
-  (if null ordts then mempty else "ORDER BY " <> intercalateSnippet ", " (map (pgFmtOrderTerm qi) ordts)) <> " " <>
-  limitOffsetF range
+  (if null logicForest && null relJoinConds
+    then mempty
+    else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition relJoinConds)) <> " " <>
+  groupF qi select relSelect <> " " <>
+  orderF qi order <> " " <>
+  limitOffsetF readRange
   where
-    implJs = fromQi <$> implJoins
-    tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias
-    qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias
-    (joins, selects) = foldr getJoinsSelects ([],[]) forest
+    fromFrag = fromF relToParent mainQi fromAlias
+    qi = getQualifiedIdentifier relToParent mainQi fromAlias
+    -- gets all the columns in case of an empty select, ignoring/obtaining these columns is done at the aggregation stage
+    defSelect = [CoercibleSelectField (unknownField "*" []) Nothing Nothing Nothing Nothing]
+    joins = getJoins node
+    joinsSelects = getJoinSelects node
 
-getJoinsSelects :: ReadRequest -> ([SQL.Snippet], [SQL.Snippet]) -> ([SQL.Snippet], [SQL.Snippet])
-getJoinsSelects rr@(Node (_, (name, Just Relationship{relCardinality=card,relTable=Table{tableName=table}}, alias, _, joinType, _)) _) (joins,selects) =
-  let subquery = readRequestToQuery rr in
-  case card of
-    M2O _ ->
-      let aliasOrName = fromMaybe name alias
-          localTableName = pgFmtIdent $ table <> "_" <> aliasOrName
-          sel = SQL.sql ("row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName)
-          joi = (if joinType == Just JTInner then " INNER" else " LEFT")
-            <> " JOIN LATERAL( " <> subquery <> " ) AS " <> SQL.sql localTableName <> " ON TRUE " in
-      (joi:joins,sel:selects)
-    _ -> case joinType of
-      Just JTInner ->
-        let aliasOrName = fromMaybe name alias
-            locTblName = table <> "_" <> aliasOrName
-            localTableName = pgFmtIdent locTblName
-            internalTableName = pgFmtIdent $ "_" <> locTblName
-            sel = SQL.sql $ localTableName <> "." <> internalTableName <> " AS " <> pgFmtIdent aliasOrName
-            joi = "INNER JOIN LATERAL(" <>
-                    "SELECT json_agg(" <> SQL.sql internalTableName <> ") AS " <> SQL.sql internalTableName <>
-                    "FROM (" <> subquery <> " ) AS " <> SQL.sql internalTableName <>
-                  ") AS " <> SQL.sql localTableName <> " ON " <> SQL.sql localTableName <> "IS NOT NULL" in
-        (joi:joins,sel:selects)
-      _ ->
-        let sel = "COALESCE (("
-               <> "SELECT json_agg(" <> SQL.sql (pgFmtIdent table) <> ".*) "
-               <> "FROM (" <> subquery <> ") " <> SQL.sql (pgFmtIdent table) <> " "
-               <> "), '[]') AS " <> SQL.sql (pgFmtIdent (fromMaybe name alias)) in
-        (joins,sel:selects)
-getJoinsSelects (Node (_, (_, Nothing, _, _, _, _)) _) _ = ([], [])
+getJoinSelects :: ReadPlanTree -> [SQL.Snippet]
+getJoinSelects (Node ReadPlan{relSelect} _) =
+  mapMaybe relSelectToSnippet relSelect
+  where
+    relSelectToSnippet :: RelSelectField -> Maybe SQL.Snippet
+    relSelectToSnippet fld =
+      let aggAlias = pgFmtIdent $ rsAggAlias fld
+      in
+        case fld of
+          JsonEmbed{rsEmptyEmbed = True} ->
+            Nothing
+          JsonEmbed{rsSelName, rsEmbedMode = JsonObject} ->
+            Just $ "row_to_json(" <> aggAlias <> ".*)::jsonb AS " <> pgFmtIdent rsSelName
+          JsonEmbed{rsSelName, rsEmbedMode = JsonArray} ->
+            Just $ "COALESCE( " <> aggAlias <> "." <> aggAlias <> ", '[]') AS " <> pgFmtIdent rsSelName
+          Spread{rsSpreadSel, rsAggAlias} ->
+            Just $ intercalateSnippet ", " (pgFmtSpreadSelectItem rsAggAlias <$> rsSpreadSel)
 
-mutateRequestToQuery :: MutateRequest -> SQL.Snippet
-mutateRequestToQuery (Insert mainQi iCols body onConflct putConditions returnings) =
-  "WITH " <> normalizedBody body <> " " <>
-  "INSERT INTO " <> SQL.sql (fromQi mainQi) <> SQL.sql (if S.null iCols then " " else "(" <> cols <> ") ") <>
-  "SELECT " <> SQL.sql cols <> " " <>
-  SQL.sql ("FROM json_populate_recordset (null::" <> fromQi mainQi <> ", " <> selectBody <> ") _ ") <>
+getJoins :: ReadPlanTree -> [SQL.Snippet]
+getJoins (Node _ []) = []
+getJoins (Node ReadPlan{relSelect} forest) =
+  map (\fld ->
+         let alias = rsAggAlias fld
+             matchingNode = fromJust $ find (\(Node ReadPlan{relAggAlias} _) -> alias == relAggAlias) forest
+         in getJoin fld matchingNode
+      ) relSelect
+
+getJoin :: RelSelectField -> ReadPlanTree -> SQL.Snippet
+getJoin fld node@(Node ReadPlan{relJoinType} _) =
+  let
+    correlatedSubquery sub al cond =
+      (if relJoinType == Just JTInner then "INNER" else "LEFT") <> " JOIN LATERAL ( " <> sub <> " ) AS " <> al <> " ON " <> cond
+    subquery = readPlanToQuery node
+    aggAlias = pgFmtIdent $ rsAggAlias fld
+  in
+    case fld of
+      JsonEmbed{rsEmbedMode = JsonObject} ->
+        correlatedSubquery subquery aggAlias "TRUE"
+      Spread{} ->
+        correlatedSubquery subquery aggAlias "TRUE"
+      JsonEmbed{rsEmbedMode = JsonArray} ->
+        let
+          subq = "SELECT json_agg(" <> aggAlias <> ")::jsonb AS " <> aggAlias <> " FROM (" <> subquery <> " ) AS " <> aggAlias
+          condition = if relJoinType == Just JTInner then aggAlias <> " IS NOT NULL" else "TRUE"
+        in correlatedSubquery subq aggAlias condition
+
+mutatePlanToQuery :: MutatePlan -> SQL.Snippet
+mutatePlanToQuery (Insert mainQi iCols body onConflct putConditions returnings _ applyDefaults) =
+  "INSERT INTO " <> fromQi mainQi <> (if null iCols then " " else "(" <> cols <> ") ") <>
+  fromJsonBodyF body iCols True False applyDefaults <>
   -- Only used for PUT
-  (if null putConditions then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) <>
-  SQL.sql (BS.unwords [
-    maybe "" (\(oncDo, oncCols) ->
-      if null oncCols then
-        mempty
-      else
-        "ON CONFLICT(" <> BS.intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of
-        IgnoreDuplicates ->
-          "DO NOTHING"
-        MergeDuplicates  ->
-          if S.null iCols
-             then "DO NOTHING"
-             else "DO UPDATE SET " <> BS.intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)
-      ) onConflct,
+  (if null putConditions then mempty else "WHERE " <> addConfigPgrstInserted True <> " AND " <> intercalateSnippet " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "pgrst_body") <$> putConditions)) <>
+  (if null putConditions && mergeDups then "WHERE " <> addConfigPgrstInserted True else mempty) <>
+  maybe mempty (\(oncDo, oncCols) ->
+    if null oncCols then
+      mempty
+    else
+      " ON CONFLICT(" <> intercalateSnippet ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of
+      IgnoreDuplicates ->
+        "DO NOTHING"
+      MergeDuplicates  ->
+        if null iCols
+           then "DO NOTHING"
+           else "DO UPDATE SET " <> intercalateSnippet ", " ((pgFmtIdent . cfName) <> const " = EXCLUDED." <> (pgFmtIdent . cfName) <$> iCols) <> (if null putConditions && not mergeDups then mempty else "WHERE " <> addConfigPgrstInserted False)
+    ) onConflct <> " " <>
     returningF mainQi returnings
-    ])
   where
-    cols = BS.intercalate ", " $ pgFmtIdent <$> S.toList iCols
-mutateRequestToQuery (Update mainQi uCols body logicForest returnings) =
-  if S.null uCols
+    cols = intercalateSnippet ", " $ pgFmtIdent . cfName <$> iCols
+    mergeDups = case onConflct of {Just (MergeDuplicates,_) -> True; _ -> False;}
+
+-- An update without a limit is always filtered with a WHERE
+mutatePlanToQuery (Update mainQi uCols body logicForest range ordts returnings applyDefaults)
+  | null uCols =
     -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax
     -- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select=
     -- the select has to be based on "returnings" to make computed overloaded functions not throw
-    then SQL.sql ("SELECT " <> emptyBodyReturnedColumns <> " FROM " <> fromQi mainQi <> " WHERE false")
-    else
-      "WITH " <> normalizedBody body <> " " <>
-      "UPDATE " <> SQL.sql (fromQi mainQi) <> " SET " <> SQL.sql cols <> " " <>
-      "FROM (SELECT * FROM json_populate_recordset (null::" <> SQL.sql (fromQi mainQi) <> " , " <> SQL.sql selectBody <> " )) _ " <>
-      (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)) <> " " <>
-      SQL.sql (returningF mainQi returnings)
+    "SELECT " <> emptyBodyReturnedColumns <> " FROM " <> fromQi mainQi <> " WHERE false"
+
+  | range == allRange =
+    "UPDATE " <> mainTbl <> " SET " <> nonRangeCols <> " " <>
+    fromJsonBodyF body uCols False False applyDefaults <>
+    whereLogic <> " " <>
+    returningF mainQi returnings
+
+  | otherwise =
+    "WITH " <>
+    "pgrst_update_body AS (" <> fromJsonBodyF body uCols True True applyDefaults <> "), " <>
+    "pgrst_affected_rows AS (" <>
+      "SELECT " <> rangeIdF <> " FROM " <> mainTbl <>
+      whereLogic <> " " <>
+      orderF mainQi ordts <> " " <>
+      limitOffsetF range <>
+    ") " <>
+    "UPDATE " <> mainTbl <> " SET " <> rangeCols <>
+    "FROM pgrst_affected_rows " <>
+    "WHERE " <> whereRangeIdF <> " " <>
+    returningF mainQi returnings
+
   where
-    cols = BS.intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)
-    emptyBodyReturnedColumns :: SqlFragment
-    emptyBodyReturnedColumns
-      | null returnings = "NULL"
-      | otherwise       = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)
-mutateRequestToQuery (Delete mainQi logicForest returnings) =
-  "DELETE FROM " <> SQL.sql (fromQi mainQi) <> " " <>
-  (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree mainQi) logicForest)) <> " " <>
-  SQL.sql (returningF mainQi returnings)
+    whereLogic = if null logicForest then mempty else " WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)
+    mainTbl = fromQi mainQi
+    emptyBodyReturnedColumns = if null returnings then "NULL" else intercalateSnippet ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)
+    nonRangeCols = intercalateSnippet ", " (pgFmtIdent . cfName <> const " = " <> pgFmtColumn (QualifiedIdentifier mempty "pgrst_body") . cfName <$> uCols)
+    rangeCols = intercalateSnippet ", " ((\col -> pgFmtIdent (cfName col) <> " = (SELECT " <> pgFmtIdent (cfName col) <> " FROM pgrst_update_body) ") <$> uCols)
+    (whereRangeIdF, rangeIdF) = mutRangeF mainQi (cfName . coField <$> ordts)
+
+mutatePlanToQuery (Delete mainQi logicForest range ordts returnings)
+  | range == allRange =
+    "DELETE FROM " <> fromQi mainQi <> " " <>
+    whereLogic <> " " <>
+    returningF mainQi returnings
+
+  | otherwise =
+    "WITH " <>
+    "pgrst_affected_rows AS (" <>
+      "SELECT " <> rangeIdF <> " FROM " <> fromQi mainQi <>
+       whereLogic <> " " <>
+      orderF mainQi ordts <> " " <>
+      limitOffsetF range <>
+    ") " <>
+    "DELETE FROM " <> fromQi mainQi <> " " <>
+    "USING pgrst_affected_rows " <>
+    "WHERE " <> whereRangeIdF <> " " <>
+    returningF mainQi returnings
 
-requestToCallProcQuery :: CallRequest -> SQL.Snippet
-requestToCallProcQuery (FunctionCall qi params args returnsScalar multipleCall returnings) =
-  prmsCTE <> argsBody
   where
-    (prmsCTE, argFrag) = case params of
-      OnePosParam prm -> ("WITH pgrst_args AS (SELECT NULL)", singleParameter args (encodeUtf8 $ ppType prm))
-      KeyParams []    -> (mempty, mempty)
-      KeyParams prms  -> (
-          "WITH " <> normalizedBody args <> ", " <>
-          SQL.sql (
-            BS.unwords [
-            "pgrst_args AS (",
-              "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtParams prms (const mempty) (\a -> " " <> encodeUtf8 (ppType a)) <> ")",
-            ")"])
-         , SQL.sql $ if multipleCall
-             then fmtParams prms varadicPrefix (\a -> " := pgrst_args." <> pgFmtIdent (ppName a))
-             else fmtParams prms varadicPrefix (\a -> " := (SELECT " <> pgFmtIdent (ppName a) <> " FROM pgrst_args LIMIT 1)")
-        )
+    whereLogic = if null logicForest then mempty else " WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)
+    (whereRangeIdF, rangeIdF) = mutRangeF mainQi (cfName . coField <$> ordts)
 
-    fmtParams :: [ProcParam] -> (ProcParam -> SqlFragment) -> (ProcParam -> SqlFragment) -> SqlFragment
-    fmtParams prms prmFragPre prmFragSuf = BS.intercalate ", "
-      ((\a -> prmFragPre a <> pgFmtIdent (ppName a) <> prmFragSuf a) <$> prms)
+callPlanToQuery :: CallPlan -> PgVersion -> SQL.Snippet
+callPlanToQuery (FunctionCall qi params args returnsScalar returnsSetOfScalar returnsCompositeAlias returnings) pgVer =
+  "SELECT " <> (if returnsScalar || returnsSetOfScalar then "pgrst_call.pgrst_scalar" else returnedColumns) <> " " <>
+  fromCall
+  where
+    fromCall = case params of
+      OnePosParam prm -> "FROM " <> callIt (singleParameter args $ encodeUtf8 $ ppType prm)
+      KeyParams []    -> "FROM " <> callIt mempty
+      KeyParams prms  -> fromJsonBodyF args ((\p -> CoercibleField (ppName p) mempty False (ppTypeMaxLength p) Nothing Nothing) <$> prms) False True False <> ", " <>
+                         "LATERAL " <> callIt (fmtParams prms)
 
-    varadicPrefix :: ProcParam -> SqlFragment
-    varadicPrefix a = if ppVar a then "VARIADIC " else mempty
+    callIt :: SQL.Snippet -> SQL.Snippet
+    callIt argument | pgVer < pgVersion130 && pgVer >= pgVersion110 && returnsCompositeAlias = "(SELECT (" <> fromQi qi <> "(" <> argument <> ")).*) pgrst_call"
+                    | returnsScalar || returnsSetOfScalar                                    = "(SELECT " <> fromQi qi <> "(" <> argument <> ") pgrst_scalar) pgrst_call"
+                    | otherwise                                                              = fromQi qi <> "(" <> argument <> ") pgrst_call"
 
-    argsBody :: SQL.Snippet
-    argsBody
-      | multipleCall =
-          if returnsScalar
-            then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"
-            else "SELECT pgrst_lat_args.* FROM pgrst_args, " <>
-                 "LATERAL ( SELECT " <> returnedColumns <> " FROM " <> callIt <> " ) pgrst_lat_args"
-      | otherwise =
-          if returnsScalar
-            then "SELECT " <> callIt <> " AS pgrst_scalar"
-            else "SELECT " <> returnedColumns <> " FROM " <> callIt
-
-    callIt :: SQL.Snippet
-    callIt = SQL.sql (fromQi qi) <> "(" <> argFrag <> ")"
+    fmtParams :: [RoutineParam] -> SQL.Snippet
+    fmtParams prms = intercalateSnippet ", "
+      ((\a -> (if ppVar a then "VARIADIC " else mempty) <> pgFmtIdent (ppName a) <> " := pgrst_body." <> pgFmtIdent (ppName a)) <$> prms)
 
     returnedColumns :: SQL.Snippet
     returnedColumns
       | null returnings = "*"
-      | otherwise       = SQL.sql $ BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings)
-
+      | otherwise       = intercalateSnippet ", " (pgFmtColumn (QualifiedIdentifier mempty "pgrst_call") <$> returnings)
 
 -- | SQL query meant for COUNTing the root node of the Tree.
 -- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT.
@@ -183,24 +223,57 @@ requestToCallProcQuery (FunctionCall qi params args returnsScalar multipleCall r
 -- For this case, we use a WHERE EXISTS instead of an INNER JOIN on the count query.
 -- See https://github.com/PostgREST/postgrest/issues/2009#issuecomment-977473031
 -- Only for the nodes that have an INNER JOIN linked to the root level.
-readRequestToCountQuery :: ReadRequest -> SQL.Snippet
-readRequestToCountQuery (Node (Select{from=qi, implicitJoins=implJoins, where_=logicForest, joinConditions=joinConditions_}, _) forest) =
-  "SELECT 1 FROM " <> SQL.sql (BS.intercalate ", " (fromQi qi:(fromQi <$> implJoins))) <>
-  (if null logicForest && null joinConditions_ && null subQueries
+readPlanToCountQuery :: ReadPlanTree -> SQL.Snippet
+readPlanToCountQuery (Node ReadPlan{from=mainQi, fromAlias=tblAlias, where_=logicForest, relToParent=rel, relJoinConds} forest) =
+  "SELECT 1 " <> fromFrag <>
+  (if null logicForest && null relJoinConds && null subQueries
     then mempty
     else " WHERE " ) <>
   intercalateSnippet " AND " (
-    map (pgFmtLogicTree qi) logicForest ++
-    map pgFmtJoinCondition joinConditions_ ++
+    map (pgFmtLogicTreeCount qi) logicForest ++
+    map pgFmtJoinCondition relJoinConds ++
     subQueries
   )
   where
+    qi = getQualifiedIdentifier rel mainQi tblAlias
+    fromFrag = fromF rel mainQi tblAlias
     subQueries = foldr existsSubquery [] forest
-    existsSubquery :: ReadRequest -> [SQL.Snippet] -> [SQL.Snippet]
-    existsSubquery readReq@(Node (_, (_, _, _, _, joinType, _)) _) rest =
+    existsSubquery :: ReadPlanTree -> [SQL.Snippet] -> [SQL.Snippet]
+    existsSubquery readReq@(Node ReadPlan{relJoinType=joinType} _) rest =
       if joinType == Just JTInner
-        then ("EXISTS (" <> readRequestToCountQuery readReq <> " )"):rest
-        else mempty
+        then ("EXISTS (" <> readPlanToCountQuery readReq <> " )"):rest
+        else rest
+    findNullEmbedRel fld = find (\(Node ReadPlan{relAggAlias} _) -> fld == relAggAlias) forest
+
+    -- https://github.com/PostgREST/postgrest/pull/2930#discussion_r1325293698
+    pgFmtLogicTreeCount :: QualifiedIdentifier -> CoercibleLogicTree -> SQL.Snippet
+    pgFmtLogicTreeCount qiCount (CoercibleExpr hasNot op frst) = SQL.sql notOp <> " (" <> intercalateSnippet (opSql op) (pgFmtLogicTreeCount qiCount <$> frst) <> ")"
+      where
+        notOp =  if hasNot then "NOT" else mempty
+        opSql And = " AND "
+        opSql Or  = " OR "
+    pgFmtLogicTreeCount _ (CoercibleStmnt (CoercibleFilterNullEmbed hasNot fld)) =
+      maybe mempty (\x -> (if not hasNot then "NOT " else mempty) <> "EXISTS (" <> readPlanToCountQuery x <> ")") (findNullEmbedRel fld)
+    pgFmtLogicTreeCount qiCount (CoercibleStmnt flt) = pgFmtFilter qiCount flt
 
 limitedQuery :: SQL.Snippet -> Maybe Integer -> SQL.Snippet
 limitedQuery query maxRows = query <> SQL.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows)
+
+-- TODO refactor so this function is uneeded and ComputedRelationship QualifiedIdentifier comes from the ReadPlan type
+getQualifiedIdentifier :: Maybe Relationship -> QualifiedIdentifier -> Maybe Alias -> QualifiedIdentifier
+getQualifiedIdentifier rel mainQi tblAlias = case rel of
+  Just ComputedRelationship{relFunction} -> QualifiedIdentifier mempty $ fromMaybe (qiName relFunction) tblAlias
+  _                                      -> maybe mainQi (QualifiedIdentifier mempty) tblAlias
+
+-- FROM clause plus implicit joins
+fromF :: Maybe Relationship -> QualifiedIdentifier -> Maybe Alias -> SQL.Snippet
+fromF rel mainQi tblAlias = "FROM " <>
+  (case rel of
+    -- Due to the use of CTEs on RPC, we need to cast the parameter to the table name in case of function overloading.
+    -- See https://github.com/PostgREST/postgrest/issues/2963#issuecomment-1736557386
+    Just ComputedRelationship{relFunction,relTableAlias,relTable} -> fromQi relFunction <> "(" <> pgFmtIdent (qiName relTableAlias) <> "::" <> fromQi relTable <> ")"
+    _                                                             -> fromQi mainQi) <>
+  maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias <>
+  (case rel of
+    Just Relationship{relCardinality=M2M Junction{junTable=jt}} -> ", " <> fromQi jt
+    _                                                           -> mempty)

src/PostgREST/Query/SqlFragment.hs

@@ -1,127 +1,138 @@
-{-# LANGUAGE LambdaCase  #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE LambdaCase     #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE QuasiQuotes    #-}
 {-|
 Module      : PostgREST.Query.SqlFragment
 Description : Helper functions for PostgREST.QueryBuilder.
-
-Any function that outputs a SqlFragment should be in this module.
 -}
 module PostgREST.Query.SqlFragment
   ( noLocationF
-  , SqlFragment
-  , asBinaryF
-  , asCsvF
-  , asJsonF
-  , asJsonSingleF
+  , handlerF
   , countF
+  , groupF
   , fromQi
-  , ftsOperators
   , limitOffsetF
   , locationF
-  , normalizedBody
-  , operators
+  , mutRangeF
+  , orderF
   , pgFmtColumn
+  , pgFmtFilter
   , pgFmtIdent
   , pgFmtJoinCondition
   , pgFmtLogicTree
   , pgFmtOrderTerm
   , pgFmtSelectItem
+  , pgFmtSpreadSelectItem
+  , fromJsonBodyF
   , responseHeadersF
   , responseStatusF
+  , addConfigPgrstInserted
+  , currentSettingF
   , returningF
-  , selectBody
   , singleParameter
+  , sourceCTE
   , sourceCTEName
   , unknownEncoder
   , intercalateSnippet
+  , explainF
+  , setConfigWithConstantName
+  , setConfigWithDynamicName
+  , setConfigWithConstantNameJSON
+  , escapeIdent
+  , escapeIdentList
   ) where
 
+import qualified Data.Aeson                      as JSON
 import qualified Data.ByteString.Char8           as BS
 import qualified Data.ByteString.Lazy            as LBS
-import qualified Data.HashMap.Strict             as M
+import qualified Data.HashMap.Strict             as HM
 import qualified Data.Text                       as T
+import qualified Data.Text.Encoding              as T
 import qualified Hasql.DynamicStatements.Snippet as SQL
 import qualified Hasql.Encoders                  as HE
 
+import Control.Arrow ((***))
+
 import Data.Foldable                 (foldr1)
 import Text.InterpolatedString.Perl6 (qc)
 
-import PostgREST.DbStructure.Identifiers (FieldName,
-                                          QualifiedIdentifier (..))
-import PostgREST.RangeQuery              (NonnegRange, allRange,
-                                          rangeLimit, rangeOffset)
-import PostgREST.Request.Types           (Alias, Field, Filter (..),
-                                          JoinCondition (..),
+import PostgREST.ApiRequest.Types        (AggregateFunction (..),
+                                          Alias, Cast,
+                                          FtsOperator (..),
                                           JsonOperand (..),
                                           JsonOperation (..),
                                           JsonPath,
                                           LogicOperator (..),
-                                          LogicTree (..), OpExpr (..),
+                                          OpExpr (..),
+                                          OpQuantifier (..),
                                           Operation (..),
                                           OrderDirection (..),
                                           OrderNulls (..),
-                                          OrderTerm (..), SelectItem,
+                                          QuantOperator (..),
+                                          SimpleOperator (..),
                                           TrileanVal (..))
+import PostgREST.MediaType               (MTVndPlanFormat (..),
+                                          MTVndPlanOption (..))
+import PostgREST.Plan.ReadPlan           (JoinCondition (..))
+import PostgREST.Plan.Types              (CoercibleField (..),
+                                          CoercibleFilter (..),
+                                          CoercibleLogicTree (..),
+                                          CoercibleOrderTerm (..),
+                                          CoercibleSelectField (..),
+                                          RelSelectField (..),
+                                          SpreadSelectField (..),
+                                          unknownField)
+import PostgREST.RangeQuery              (NonnegRange, allRange,
+                                          rangeLimit, rangeOffset)
+import PostgREST.SchemaCache.Identifiers (FieldName,
+                                          QualifiedIdentifier (..))
+import PostgREST.SchemaCache.Routine     (MediaHandler (..),
+                                          Routine (..),
+                                          funcReturnsScalar,
+                                          funcReturnsSetOfScalar,
+                                          funcReturnsSingleComposite)
 
-import Protolude hiding (cast)
+import Protolude hiding (Sum, cast)
 
-
--- | A part of a SQL query that cannot be executed independently
-type SqlFragment = ByteString
-
-noLocationF :: SqlFragment
-noLocationF = "array[]::text[]"
-
-sourceCTEName :: SqlFragment
+sourceCTEName :: Text
 sourceCTEName = "pgrst_source"
 
-operators :: M.HashMap Text SqlFragment
-operators = M.union (M.fromList [
-  ("eq", "="),
-  ("gte", ">="),
-  ("gt", ">"),
-  ("lte", "<="),
-  ("lt", "<"),
-  ("neq", "<>"),
-  ("like", "LIKE"),
-  ("ilike", "ILIKE"),
-  ("in", "IN"),
-  ("is", "IS"),
-  ("cs", "@>"),
-  ("cd", "<@"),
-  ("ov", "&&"),
-  ("sl", "<<"),
-  ("sr", ">>"),
-  ("nxr", "&<"),
-  ("nxl", "&>"),
-  ("adj", "-|-")]) ftsOperators
+sourceCTE :: SQL.Snippet
+sourceCTE = "pgrst_source"
 
-ftsOperators :: M.HashMap Text SqlFragment
-ftsOperators = M.fromList [
-  ("fts", "@@ to_tsquery"),
-  ("plfts", "@@ plainto_tsquery"),
-  ("phfts", "@@ phraseto_tsquery"),
-  ("wfts", "@@ websearch_to_tsquery")
-  ]
+noLocationF :: SQL.Snippet
+noLocationF = "array[]::text[]"
 
--- |
--- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads
--- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays
--- We do this in SQL to avoid processing the JSON in application code
--- TODO: At this stage there shouldn't be a Maybe since ApiRequest should ensure that an INSERT/UPDATE has a body
-normalizedBody :: Maybe LBS.ByteString -> SQL.Snippet
-normalizedBody body =
-  "pgrst_payload AS (SELECT " <> jsonPlaceHolder <> " AS json_data), " <>
-  SQL.sql (BS.unwords [
-    "pgrst_body AS (",
-      "SELECT",
-        "CASE WHEN json_typeof(json_data) = 'array'",
-          "THEN json_data",
-          "ELSE json_build_array(json_data)",
-        "END AS val",
-      "FROM pgrst_payload)"])
-  where
-    jsonPlaceHolder = SQL.encoderAndParam (HE.nullable HE.unknown) (LBS.toStrict <$> body) <> "::json"
+simpleOperator :: SimpleOperator -> SQL.Snippet
+simpleOperator = \case
+  OpNotEqual        -> "<>"
+  OpContains        -> "@>"
+  OpContained       -> "<@"
+  OpOverlap         -> "&&"
+  OpStrictlyLeft    -> "<<"
+  OpStrictlyRight   -> ">>"
+  OpNotExtendsRight -> "&<"
+  OpNotExtendsLeft  -> "&>"
+  OpAdjacent        -> "-|-"
+
+quantOperator :: QuantOperator -> SQL.Snippet
+quantOperator = \case
+  OpEqual            -> "="
+  OpGreaterThanEqual -> ">="
+  OpGreaterThan      -> ">"
+  OpLessThanEqual    -> "<="
+  OpLessThan         -> "<"
+  OpLike             -> "like"
+  OpILike            -> "ilike"
+  OpMatch            -> "~"
+  OpIMatch           -> "~*"
+
+ftsOperator :: FtsOperator -> SQL.Snippet
+ftsOperator = \case
+  FilterFts          -> "@@ to_tsquery"
+  FilterFtsPlain     -> "@@ plainto_tsquery"
+  FilterFtsPhrase    -> "@@ phraseto_tsquery"
+  FilterFtsWebsearch -> "@@ websearch_to_tsquery"
 
 singleParameter :: Maybe LBS.ByteString -> ByteString -> SQL.Snippet
 singleParameter body typ =
@@ -130,9 +141,6 @@ singleParameter body typ =
     then SQL.encoderAndParam (HE.nullable HE.bytea) (LBS.toStrict <$> body)
     else SQL.encoderAndParam (HE.nullable HE.unknown) (LBS.toStrict <$> body) <> "::" <> SQL.sql typ
 
-selectBody :: SqlFragment
-selectBody = "(SELECT val FROM pgrst_body)"
-
 -- Here we build the pg array literal, e.g '{"Hebdon, John","Other","Another"}', manually.
 -- This is necessary to pass an "unknown" array and let pg infer the type.
 -- There are backslashes here, but since this value is parametrized and is not a string constant
@@ -147,13 +155,34 @@ pgBuildArrayLiteral vals =
  "{" <> T.intercalate "," (escaped <$> vals) <> "}"
 
 -- TODO: refactor by following https://github.com/PostgREST/postgrest/pull/1631#issuecomment-711070833
-pgFmtIdent :: Text -> SqlFragment
-pgFmtIdent x = encodeUtf8 $ "\"" <> T.replace "\"" "\"\"" (trimNullChars x) <> "\""
+pgFmtIdent :: Text -> SQL.Snippet
+pgFmtIdent x = SQL.sql $ escapeIdent x
+
+escapeIdent :: Text -> ByteString
+escapeIdent x = encodeUtf8 $ "\"" <> T.replace "\"" "\"\"" (trimNullChars x) <> "\""
+
+-- Only use it if the input comes from the database itself, like on `jsonb_build_object('column_from_a_table', val)..`
+pgFmtLit :: Text -> Text
+pgFmtLit x =
+  let trimmed = trimNullChars x
+      escaped = "'" <> T.replace "'" "''" trimmed <> "'"
+      slashed = T.replace "\\" "\\\\" escaped in
+  if "\\" `T.isInfixOf` escaped
+    then "E" <> slashed
+    else slashed
 
 trimNullChars :: Text -> Text
 trimNullChars = T.takeWhile (/= '\x0')
 
-asCsvF :: SqlFragment
+-- |
+-- Format a list of identifiers and separate them by commas.
+--
+-- >>> escapeIdentList ["schema_1", "schema_2", "SPECIAL \"@/\\#~_-"]
+-- "\"schema_1\", \"schema_2\", \"SPECIAL \"\"@/\\#~_-\""
+escapeIdentList :: [Text] -> ByteString
+escapeIdentList schemas = BS.intercalate ", " $ escapeIdent <$> schemas
+
+asCsvF :: SQL.Snippet
 asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
   where
     asCsvHeaderF =
@@ -161,26 +190,43 @@ asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
       "  FROM (" <>
       "    SELECT json_object_keys(r)::text as k" <>
       "    FROM ( " <>
-      "      SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
+      "      SELECT row_to_json(hh) as r from " <> sourceCTE <> " as hh limit 1" <>
       "    ) s" <>
       "  ) a" <>
       ")"
     asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
 
-asJsonF :: Bool -> SqlFragment
-asJsonF returnsScalar
-  | returnsScalar = "coalesce(json_agg(_postgrest_t.pgrst_scalar), '[]')::character varying"
-  | otherwise     = "coalesce(json_agg(_postgrest_t), '[]')::character varying"
+addNullsToSnip :: Bool -> SQL.Snippet -> SQL.Snippet
+addNullsToSnip strip snip =
+  if strip then "json_strip_nulls(" <> snip <> ")" else  snip
 
-asJsonSingleF :: Bool -> SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
-asJsonSingleF returnsScalar
-  | returnsScalar = "coalesce(string_agg(to_json(_postgrest_t.pgrst_scalar)::text, ','), 'null')::character varying"
-  | otherwise     = "coalesce(string_agg(to_json(_postgrest_t)::text, ','), '')::character varying"
+asJsonSingleF :: Maybe Routine -> Bool -> SQL.Snippet
+asJsonSingleF rout strip
+  | returnsScalar = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t.pgrst_scalar)->0"  <> ", 'null')"
+  | otherwise     = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t)->0"  <> ", 'null')"
+  where
+    returnsScalar = maybe False funcReturnsScalar rout
 
-asBinaryF :: FieldName -> SqlFragment
-asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
+asJsonF :: Maybe Routine -> Bool -> SQL.Snippet
+asJsonF rout strip
+  | returnsSingleComposite    = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t)->0" <> ", 'null')"
+  | returnsScalar             = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t.pgrst_scalar)->0" <> ", 'null')"
+  | returnsSetOfScalar        = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t.pgrst_scalar)" <> ", '[]')"
+  | otherwise                 = "coalesce(" <> addNullsToSnip strip "json_agg(_postgrest_t)" <> ", '[]')"
+  where
+    (returnsSingleComposite, returnsScalar, returnsSetOfScalar) = case rout of
+      Just r  -> (funcReturnsSingleComposite r, funcReturnsScalar r, funcReturnsSetOfScalar r)
+      Nothing -> (False, False, False)
 
-locationF :: [Text] -> SqlFragment
+asGeoJsonF ::  SQL.Snippet
+asGeoJsonF = "json_build_object('type', 'FeatureCollection', 'features', coalesce(json_agg(ST_AsGeoJSON(_postgrest_t)::json), '[]'))"
+
+customFuncF :: Maybe Routine -> QualifiedIdentifier -> QualifiedIdentifier -> SQL.Snippet
+customFuncF rout funcQi target
+  | (funcReturnsScalar <$> rout) == Just True = fromQi funcQi <> "(_postgrest_t.pgrst_scalar)"
+  | otherwise                                 = fromQi funcQi <> "(_postgrest_t::" <> fromQi target <> ")"
+
+locationF :: [Text] -> SQL.Snippet
 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'))
@@ -190,85 +236,183 @@ locationF pKeys = [qc|(
   where
     fmtPKeys = T.intercalate "','" pKeys
 
-fromQi :: QualifiedIdentifier -> SqlFragment
+fromQi :: QualifiedIdentifier -> SQL.Snippet
 fromQi t = (if T.null s then mempty else pgFmtIdent s <> ".") <> pgFmtIdent n
   where
     n = qiName t
     s = qiSchema t
 
-pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
+pgFmtColumn :: QualifiedIdentifier -> Text -> SQL.Snippet
 pgFmtColumn table "*" = fromQi table <> ".*"
 pgFmtColumn table c   = fromQi table <> "." <> pgFmtIdent c
 
-pgFmtField :: QualifiedIdentifier -> Field -> SQL.Snippet
-pgFmtField table (c, jp) = SQL.sql (pgFmtColumn table c) <> pgFmtJsonPath jp
+pgFmtCallUnary :: Text -> SQL.Snippet -> SQL.Snippet
+pgFmtCallUnary f x = SQL.sql (encodeUtf8 f) <> "(" <> x <> ")"
 
-pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SQL.Snippet
-pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _, _) = pgFmtField table f <> SQL.sql (pgFmtAs fName jp alias)
+pgFmtField :: QualifiedIdentifier -> CoercibleField -> SQL.Snippet
+pgFmtField table CoercibleField{cfName=fn, cfJsonPath=[]}                                = pgFmtColumn table fn
+pgFmtField table CoercibleField{cfName=fn, cfToJson=doToJson, cfJsonPath=jp} | doToJson  = "to_jsonb(" <> pgFmtColumn table fn <> ")" <> pgFmtJsonPath jp
+                                                                             | otherwise = pgFmtColumn table fn <> pgFmtJsonPath jp
+
+-- Select the value of a named element from a table, applying its optional coercion mapping if any.
+pgFmtTableCoerce :: QualifiedIdentifier -> CoercibleField -> SQL.Snippet
+pgFmtTableCoerce table fld@(CoercibleField{cfTransform=(Just formatterProc)}) = pgFmtCallUnary formatterProc (pgFmtField table fld)
+pgFmtTableCoerce table f = pgFmtField table f
+
+-- | Like the previous but now we just have a name so no namespace or JSON paths.
+pgFmtCoerceNamed :: CoercibleField -> SQL.Snippet
+pgFmtCoerceNamed CoercibleField{cfName=fn, cfTransform=(Just formatterProc)} = pgFmtCallUnary formatterProc (pgFmtIdent fn) <> " AS " <> pgFmtIdent fn
+pgFmtCoerceNamed CoercibleField{cfName=fn} = pgFmtIdent fn
+
+pgFmtSelectItem :: QualifiedIdentifier -> CoercibleSelectField -> SQL.Snippet
+pgFmtSelectItem table CoercibleSelectField{csField=fld, csAggFunction=agg, csAggCast=aggCast, csCast=cast, csAlias=alias} =
+  pgFmtApplyAggregate agg aggCast (pgFmtApplyCast cast (pgFmtTableCoerce table fld)) <> pgFmtAs alias
+
+pgFmtSpreadSelectItem :: Alias -> SpreadSelectField -> SQL.Snippet
+pgFmtSpreadSelectItem aggAlias SpreadSelectField{ssSelName, ssSelAggFunction, ssSelAggCast, ssSelAlias} =
+  pgFmtApplyAggregate ssSelAggFunction ssSelAggCast fullSelName <> pgFmtAs ssSelAlias
+  where
+    fullSelName = case ssSelName of
+      "*" -> pgFmtIdent aggAlias <> ".*"
+      _   -> pgFmtIdent aggAlias <> "." <> pgFmtIdent ssSelName
+
+pgFmtApplyAggregate :: Maybe AggregateFunction -> Maybe Cast -> SQL.Snippet -> SQL.Snippet
+pgFmtApplyAggregate Nothing _ snippet = snippet
+pgFmtApplyAggregate (Just agg) aggCast snippet =
+  pgFmtApplyCast aggCast aggregatedSnippet
+  where
+    convertAggFunction :: AggregateFunction -> SQL.Snippet
+    -- Convert from e.g. Sum (the data type) to SUM
+    convertAggFunction = SQL.sql . BS.map toUpper . BS.pack . show
+    aggregatedSnippet = convertAggFunction agg <> "(" <> snippet <> ")"
+
+pgFmtApplyCast :: Maybe Cast -> SQL.Snippet -> SQL.Snippet
+pgFmtApplyCast Nothing snippet = snippet
 -- Ideally we'd quote the cast with "pgFmtIdent cast". However, that would invalidate common casts such as "int", "bigint", etc.
 -- Try doing: `select 1::"bigint"` - it'll err, using "int8" will work though. There's some parser magic that pg does that's invalidated when quoting.
 -- Not quoting should be fine, we validate the input on Parsers.
-pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _, _) = "CAST (" <> pgFmtField table f <> " AS " <> SQL.sql (encodeUtf8 cast) <> " )" <> SQL.sql (pgFmtAs fName jp alias)
+pgFmtApplyCast (Just cast) snippet = "CAST( " <> snippet <> " AS " <> SQL.sql (encodeUtf8 cast) <> " )"
 
-pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SQL.Snippet
-pgFmtOrderTerm qi ot =
-  pgFmtField qi (otTerm ot) <> " " <>
-  SQL.sql (BS.unwords [
-    maybe mempty direction $ otDirection ot,
-    maybe mempty nullOrder $ otNullOrder ot])
+-- TODO: At this stage there shouldn't be a Maybe since ApiRequest should ensure that an INSERT/UPDATE has a body
+fromJsonBodyF :: Maybe LBS.ByteString -> [CoercibleField] -> Bool -> Bool -> Bool -> SQL.Snippet
+fromJsonBodyF body fields includeSelect includeLimitOne includeDefaults =
+  (if includeSelect then "SELECT " <> namedCols <> " " else mempty) <>
+  "FROM (SELECT " <> jsonPlaceHolder <> " AS json_data) pgrst_payload, " <>
+  -- convert a json object into a json array, this way we can use json_to_recordset for all json payloads
+  -- Otherwise we'd have to use json_to_record for json objects and json_to_recordset for json arrays
+  -- We do this in SQL to avoid processing the JSON in application code
+  "LATERAL (SELECT CASE WHEN " <> jsonTypeofF <> "(pgrst_payload.json_data) = 'array' THEN pgrst_payload.json_data ELSE " <> jsonBuildArrayF <> "(pgrst_payload.json_data) END AS val) pgrst_uniform_json, " <>
+  (if includeDefaults
+    then "LATERAL (SELECT jsonb_agg(jsonb_build_object(" <> defsJsonb <> ") || elem) AS val from jsonb_array_elements(pgrst_uniform_json.val) elem) pgrst_json_defs, "
+    else mempty) <>
+  "LATERAL (SELECT " <> parsedCols <> " FROM " <>
+    (if null fields
+      -- When we are inserting no columns (e.g. using default values), we can't use our ordinary `json_to_recordset`
+      -- because it can't extract records with no columns (there's no valid syntax for the `AS (colName colType,...)`
+      -- part). But we still need to ensure as many rows are created as there are array elements.
+      then SQL.sql $ jsonArrayElementsF <> "(" <> finalBodyF <> ") _ "
+      else jsonToRecordsetF <> "(" <> SQL.sql finalBodyF <> ") AS _(" <> typedCols <> ") " <> if includeLimitOne then "LIMIT 1" else mempty
+    ) <>
+  ") pgrst_body "
   where
+    namedCols = intercalateSnippet ", " $ fromQi  . QualifiedIdentifier "pgrst_body" . cfName <$> fields
+    parsedCols = intercalateSnippet ", " $ pgFmtCoerceNamed <$> fields
+    typedCols = intercalateSnippet ", " $ pgFmtIdent . cfName <> const " " <> SQL.sql . encodeUtf8 . cfIRType <$> fields
+    defsJsonb = SQL.sql $ BS.intercalate "," fieldsWDefaults
+    fieldsWDefaults = mapMaybe (\case
+        CoercibleField{cfName=nam, cfDefault=Just def} -> Just $ encodeUtf8 (pgFmtLit nam <> ", " <> def)
+        CoercibleField{cfDefault=Nothing} -> Nothing
+      ) fields
+    (finalBodyF, jsonTypeofF, jsonBuildArrayF, jsonArrayElementsF, jsonToRecordsetF) =
+      if includeDefaults
+        then ("pgrst_json_defs.val", "jsonb_typeof", "jsonb_build_array", "jsonb_array_elements", "jsonb_to_recordset")
+        else ("pgrst_uniform_json.val", "json_typeof", "json_build_array", "json_array_elements", "json_to_recordset")
+    jsonPlaceHolder = SQL.encoderAndParam (HE.nullable $ if includeDefaults then HE.jsonbLazyBytes else HE.jsonLazyBytes) body
+
+pgFmtOrderTerm :: QualifiedIdentifier -> CoercibleOrderTerm -> SQL.Snippet
+pgFmtOrderTerm qi ot =
+  fmtOTerm ot <> " " <>
+  SQL.sql (BS.unwords [
+    maybe mempty direction $ coDirection ot,
+    maybe mempty nullOrder $ coNullOrder ot])
+  where
+    fmtOTerm = \case
+      CoercibleOrderTerm{coField=cof}                            -> pgFmtField qi cof
+      CoercibleOrderRelationTerm{coRelation, coRelTerm=(fn, jp)} -> pgFmtField (QualifiedIdentifier mempty coRelation) (unknownField fn jp)
+
     direction OrderAsc  = "ASC"
     direction OrderDesc = "DESC"
 
     nullOrder OrderNullsFirst = "NULLS FIRST"
     nullOrder OrderNullsLast  = "NULLS LAST"
 
+-- | Interpret a literal in the way the planner indicated through the CoercibleField.
+pgFmtUnknownLiteralForField :: SQL.Snippet -> CoercibleField -> SQL.Snippet
+pgFmtUnknownLiteralForField value CoercibleField{cfTransform=(Just parserProc)} = pgFmtCallUnary parserProc value
+-- But when no transform is requested, we just use the literal as-is.
+pgFmtUnknownLiteralForField value _ = value
 
-pgFmtFilter :: QualifiedIdentifier -> Filter -> SQL.Snippet
-pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of
-   Op op val  -> pgFmtFieldOp op <> " " <> case op of
-     "like"  -> unknownLiteral (T.map star val)
-     "ilike" -> unknownLiteral (T.map star val)
-     _       -> unknownLiteral val
+-- | Array version of the above, used by ANY().
+pgFmtArrayLiteralForField :: [Text] -> CoercibleField -> SQL.Snippet
+-- When a transformation is requested, we need to apply the transformation to each element of the array. This could be done by just making a query with `parser(value)` for each value, but may lead to huge query lengths. Imagine `data_representations.color_from_text('...'::text)` for repeated for a hundred values. Instead we use `unnest()` to unpack a standard array literal and then apply the transformation to each element, like a map.
+-- Note the literals will be treated as text since in every case when we use ANY() the parameters are textual (coming from a query string). We want to rely on the `text->domain` parser to do the right thing.
+pgFmtArrayLiteralForField values CoercibleField{cfTransform=(Just parserProc)} = SQL.sql "(SELECT " <> pgFmtCallUnary parserProc (SQL.sql "unnest(" <> unknownLiteral (pgBuildArrayLiteral values) <> "::text[])") <> ")"
+-- When no transformation is requested, we don't need a subquery.
+pgFmtArrayLiteralForField values _ = unknownLiteral (pgBuildArrayLiteral values)
+
+
+pgFmtFilter :: QualifiedIdentifier -> CoercibleFilter -> SQL.Snippet
+pgFmtFilter _ (CoercibleFilterNullEmbed hasNot fld) = pgFmtIdent fld <> " IS " <> (if not hasNot then "NOT " else mempty) <> "DISTINCT FROM NULL"
+pgFmtFilter _ (CoercibleFilter _ (NoOpExpr _)) = mempty -- TODO unreachable because NoOpExpr is filtered on QueryParams
+pgFmtFilter table (CoercibleFilter fld (OpExpr hasNot oper)) = notOp <> " " <> pgFmtField table fld <> case oper of
+   Op op val  -> " " <> simpleOperator op <> " " <> pgFmtUnknownLiteralForField (unknownLiteral val) fld
+
+   OpQuant op quant val -> " " <> quantOperator op <> " " <> case op of
+     OpLike  -> fmtQuant quant $ unknownLiteral (T.map star val)
+     OpILike -> fmtQuant quant $ unknownLiteral (T.map star val)
+     _       -> fmtQuant quant $ pgFmtUnknownLiteralForField (unknownLiteral val) fld
 
    -- IS cannot be prepared. `PREPARE boolplan AS SELECT * FROM projects where id IS $1` will give a syntax error.
    -- The above can be fixed by using `PREPARE boolplan AS SELECT * FROM projects where id IS NOT DISTINCT FROM $1;`
    -- However that would not accept the TRUE/FALSE/NULL/UNKNOWN keywords. See: https://stackoverflow.com/questions/6133525/proper-way-to-set-preparedstatement-parameter-to-null-under-postgres.
    -- This is why `IS` operands are whitelisted at the Parsers.hs level
-   Is triVal -> pgFmtField table fld <> " IS " <> case triVal of
+   Is triVal -> " IS " <> case triVal of
      TriTrue    -> "TRUE"
      TriFalse   -> "FALSE"
      TriNull    -> "NULL"
      TriUnknown -> "UNKNOWN"
 
+   IsDistinctFrom val -> " IS DISTINCT FROM " <> unknownLiteral val
+
    -- We don't use "IN", we use "= ANY". IN has the following disadvantages:
    -- + No way to use an empty value on IN: "col IN ()" is invalid syntax. With ANY we can do "= ANY('{}')"
    -- + Can invalidate prepared statements: multiple parameters on an IN($1, $2, $3) will lead to using different prepared statements and not take advantage of caching.
-   In vals -> pgFmtField table fld <> " " <> case vals of
+   In vals -> " " <> case vals of
       [""] -> "= ANY('{}') "
-      _    -> "= ANY (" <> unknownLiteral (pgBuildArrayLiteral vals) <> ") "
+      _    -> "= ANY (" <> pgFmtArrayLiteralForField vals fld <> ") "
 
-   Fts op lang val ->
-     pgFmtFieldOp op <> "(" <> ftsLang lang <> unknownLiteral val <> ") "
+   Fts op lang val -> " " <> ftsOperator op <> "(" <> ftsLang lang <> unknownLiteral val <> ") "
  where
    ftsLang = maybe mempty (\l -> unknownLiteral l <> ", ")
-   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
-   sqlOperator o = SQL.sql $ M.lookupDefault "=" o operators
    notOp = if hasNot then "NOT" else mempty
    star c = if c == '*' then '%' else c
+   fmtQuant q val = case q of
+    Just QuantAny -> "ANY(" <> val <> ")"
+    Just QuantAll -> "ALL(" <> val <> ")"
+    Nothing       -> val
 
 pgFmtJoinCondition :: JoinCondition -> SQL.Snippet
 pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) =
-  SQL.sql $ pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2
+  pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2
 
-pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SQL.Snippet
-pgFmtLogicTree qi (Expr hasNot op forest) = SQL.sql notOp <> " (" <> intercalateSnippet (opSql op) (pgFmtLogicTree qi <$> forest) <> ")"
+pgFmtLogicTree :: QualifiedIdentifier -> CoercibleLogicTree -> SQL.Snippet
+pgFmtLogicTree qi (CoercibleExpr hasNot op forest) = SQL.sql notOp <> " (" <> intercalateSnippet (opSql op) (pgFmtLogicTree qi <$> forest) <> ")"
   where
     notOp =  if hasNot then "NOT" else mempty
 
     opSql And = " AND "
     opSql Or  = " OR "
-pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
+pgFmtLogicTree qi (CoercibleStmnt flt) = pgFmtFilter qi flt
 
 pgFmtJsonPath :: JsonPath -> SQL.Snippet
 pgFmtJsonPath = \case
@@ -279,19 +423,42 @@ pgFmtJsonPath = \case
     pgFmtJsonOperand (JKey k) = unknownLiteral k
     pgFmtJsonOperand (JIdx i) = unknownLiteral i <> "::int"
 
-pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment
-pgFmtAs _ [] Nothing = mempty
-pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of
-  Just (JKey key) -> " AS " <> pgFmtIdent key
-  Just (JIdx _)   -> " AS " <> pgFmtIdent (fromMaybe fName lastKey)
-    -- We get the lastKey because on:
-    -- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ]
-    -- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ]
-    where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp)
-  Nothing -> mempty
-pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias
+pgFmtAs :: Maybe Alias -> SQL.Snippet
+pgFmtAs Nothing      = mempty
+pgFmtAs (Just alias) = " AS " <> pgFmtIdent alias
 
-countF :: SQL.Snippet -> Bool -> (SQL.Snippet, SqlFragment)
+groupF :: QualifiedIdentifier -> [CoercibleSelectField] -> [RelSelectField] -> SQL.Snippet
+groupF qi select relSelect
+  | (noSelectsAreAggregated && noRelSelectsAreAggregated) || null groupTerms = mempty
+  | otherwise = " GROUP BY " <> intercalateSnippet ", " groupTerms
+  where
+    noSelectsAreAggregated = null $ [s | s@(CoercibleSelectField { csAggFunction = Just _ }) <- select]
+    noRelSelectsAreAggregated = all (\case Spread sels _ -> all (isNothing . ssSelAggFunction) sels; _ -> True) relSelect
+    groupTermsFromSelect = mapMaybe (pgFmtGroup qi) select
+    groupTermsFromRelSelect = mapMaybe groupTermFromRelSelectField relSelect
+    groupTerms = groupTermsFromSelect ++ groupTermsFromRelSelect
+
+groupTermFromRelSelectField :: RelSelectField -> Maybe SQL.Snippet
+groupTermFromRelSelectField (JsonEmbed { rsSelName }) =
+  Just $ pgFmtIdent rsSelName
+groupTermFromRelSelectField (Spread { rsSpreadSel, rsAggAlias }) =
+  if null groupTerms
+  then Nothing
+  else
+    Just $ intercalateSnippet ", " groupTerms
+  where
+    processField :: SpreadSelectField -> Maybe SQL.Snippet
+    processField SpreadSelectField{ssSelAggFunction = Just _} = Nothing
+    processField SpreadSelectField{ssSelName, ssSelAlias} =
+      Just $ pgFmtIdent rsAggAlias <> "." <> pgFmtIdent (fromMaybe ssSelName ssSelAlias)
+    groupTerms = mapMaybe processField rsSpreadSel
+
+pgFmtGroup :: QualifiedIdentifier -> CoercibleSelectField -> Maybe SQL.Snippet
+pgFmtGroup _  CoercibleSelectField{csAggFunction=Just _} = Nothing
+pgFmtGroup _  CoercibleSelectField{csAlias=Just alias, csAggFunction=Nothing} = Just $ pgFmtIdent alias
+pgFmtGroup qi CoercibleSelectField{csField=fld, csAlias=Nothing, csAggFunction=Nothing} = Just $ pgFmtField qi fld
+
+countF :: SQL.Snippet -> Bool -> (SQL.Snippet, SQL.Snippet)
 countF countQuery shouldCount =
   if shouldCount
     then (
@@ -301,11 +468,11 @@ countF countQuery shouldCount =
         mempty
       , "null::bigint")
 
-returningF :: QualifiedIdentifier -> [FieldName] -> SqlFragment
+returningF :: QualifiedIdentifier -> [FieldName] -> SQL.Snippet
 returningF qi returnings =
   if null returnings
     then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified
-    else "RETURNING " <> BS.intercalate ", " (pgFmtColumn qi <$> returnings)
+    else "RETURNING " <> intercalateSnippet ", " (pgFmtColumn qi <$> returnings)
 
 limitOffsetF :: NonnegRange -> SQL.Snippet
 limitOffsetF range =
@@ -314,17 +481,33 @@ limitOffsetF range =
     limit = maybe "ALL" (\l -> unknownEncoder (BS.pack $ show l)) $ rangeLimit range
     offset = unknownEncoder (BS.pack . show $ rangeOffset range)
 
-responseHeadersF :: SqlFragment
+responseHeadersF :: SQL.Snippet
 responseHeadersF = currentSettingF "response.headers"
 
-responseStatusF :: SqlFragment
+responseStatusF :: SQL.Snippet
 responseStatusF = currentSettingF "response.status"
 
-currentSettingF :: SqlFragment -> SqlFragment
+addConfigPgrstInserted :: Bool -> SQL.Snippet
+addConfigPgrstInserted add =
+  let (symbol, num) =  if add then ("+", "0") else ("-", "-1") in
+  "set_config('pgrst.inserted', (coalesce(" <> currentSettingF "pgrst.inserted" <> "::int, 0) " <> symbol <> " 1)::text, true) <> '" <> num <> "'"
+
+currentSettingF :: SQL.Snippet -> SQL.Snippet
 currentSettingF setting =
   -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
   "nullif(current_setting('" <> setting <> "', true), '')"
 
+mutRangeF :: QualifiedIdentifier -> [FieldName] -> (SQL.Snippet, SQL.Snippet)
+mutRangeF mainQi rangeId =
+  (
+    intercalateSnippet " AND " $ (\col -> pgFmtColumn mainQi col <> " = " <> pgFmtColumn (QualifiedIdentifier mempty "pgrst_affected_rows") col) <$> rangeId
+  , intercalateSnippet ", " (pgFmtColumn mainQi <$> rangeId)
+  )
+
+orderF :: QualifiedIdentifier -> [CoercibleOrderTerm] -> SQL.Snippet
+orderF _ []    = mempty
+orderF qi ordts = "ORDER BY " <> intercalateSnippet ", " (pgFmtOrderTerm qi <$> ordts)
+
 -- Hasql Snippet utilities
 unknownEncoder :: ByteString -> SQL.Snippet
 unknownEncoder = SQL.encoderAndParam (HE.nonNullable HE.unknown)
@@ -335,3 +518,53 @@ unknownLiteral = unknownEncoder . encodeUtf8
 intercalateSnippet :: ByteString -> [SQL.Snippet] -> SQL.Snippet
 intercalateSnippet _ [] = mempty
 intercalateSnippet frag snippets = foldr1 (\a b -> a <> SQL.sql frag <> b) snippets
+
+explainF :: MTVndPlanFormat -> [MTVndPlanOption] -> SQL.Snippet -> SQL.Snippet
+explainF fmt opts snip =
+  "EXPLAIN (" <>
+    SQL.sql (BS.intercalate ", " (fmtPlanFmt fmt : (fmtPlanOpt <$> opts))) <>
+  ") " <> snip
+  where
+    fmtPlanOpt :: MTVndPlanOption -> BS.ByteString
+    fmtPlanOpt PlanAnalyze  = "ANALYZE"
+    fmtPlanOpt PlanVerbose  = "VERBOSE"
+    fmtPlanOpt PlanSettings = "SETTINGS"
+    fmtPlanOpt PlanBuffers  = "BUFFERS"
+    fmtPlanOpt PlanWAL      = "WAL"
+
+    fmtPlanFmt PlanText = "FORMAT TEXT"
+    fmtPlanFmt PlanJSON = "FORMAT JSON"
+
+-- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
+setConfigLocal :: (SQL.Snippet, ByteString) -> SQL.Snippet
+setConfigLocal (k, v) =
+  "set_config(" <> k <> ", " <> unknownEncoder v <> ", true)"
+
+-- | For when the settings are hardcoded and not parameterized
+setConfigWithConstantName :: (SQL.Snippet, ByteString) -> SQL.Snippet
+setConfigWithConstantName (k, v) = setConfigLocal ("'" <> k <> "'", v)
+
+-- | For when the settings need to be parameterized
+setConfigWithDynamicName :: (ByteString, ByteString) -> SQL.Snippet
+setConfigWithDynamicName (k, v) =
+  setConfigLocal (unknownEncoder k, v)
+
+-- | Starting from PostgreSQL v14, some characters are not allowed for config names (mostly affecting headers with "-").
+-- | A JSON format string is used to avoid this problem. See https://github.com/PostgREST/postgrest/issues/1857
+setConfigWithConstantNameJSON :: SQL.Snippet -> [(ByteString, ByteString)] -> [SQL.Snippet]
+setConfigWithConstantNameJSON prefix keyVals = [setConfigWithConstantName (prefix, gucJsonVal keyVals)]
+  where
+    gucJsonVal :: [(ByteString, ByteString)] -> ByteString
+    gucJsonVal = LBS.toStrict . JSON.encode . HM.fromList . arrayByteStringToText
+    arrayByteStringToText :: [(ByteString, ByteString)] -> [(Text,Text)]
+    arrayByteStringToText keyVal = (T.decodeUtf8 *** T.decodeUtf8) <$> keyVal
+
+handlerF :: Maybe Routine -> QualifiedIdentifier -> MediaHandler -> SQL.Snippet
+handlerF rout target = \case
+  BuiltinAggArrayJsonStrip   -> asJsonF rout True
+  BuiltinAggSingleJson strip -> asJsonSingleF rout strip
+  BuiltinOvAggJson           -> asJsonF rout False
+  BuiltinOvAggGeoJson        -> asGeoJsonF
+  BuiltinOvAggCsv            -> asCsvF
+  CustomFunc funcQi          -> customFuncF rout funcQi target
+  NoAgg                      -> "''::text"

src/PostgREST/Query/Statements.hs

@@ -6,192 +6,176 @@ This module constructs single SQL statements that can be parametrized and prepar
 
 - It consumes the SqlQuery types generated by the QueryBuilder module.
 - It generates the body format and some headers of the final HTTP response.
-
-TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718.
 -}
 module PostgREST.Query.Statements
-  ( createWriteStatement
-  , createReadStatement
-  , callProcStatement
-  , createExplainStatement
+  ( prepareWrite
+  , prepareRead
+  , prepareCall
+  , preparePlanRows
+  , ResultSet (..)
   ) where
 
-import qualified Data.Aeson                        as JSON
 import qualified Data.Aeson.Lens                   as L
 import qualified Data.ByteString.Char8             as BS
-import qualified Data.ByteString.Lazy              as LBS
 import qualified Hasql.Decoders                    as HD
 import qualified Hasql.DynamicStatements.Snippet   as SQL
 import qualified Hasql.DynamicStatements.Statement as SQL
 import qualified Hasql.Statement                   as SQL
 
-import Control.Lens              ((^?))
-import Data.Maybe                (fromJust)
-import Data.Text.Read            (decimal)
-import Network.HTTP.Types.Status (Status)
+import Control.Lens ((^?))
 
-import PostgREST.Error     (Error (..))
-import PostgREST.GucHeader (GucHeader)
-
-import PostgREST.DbStructure.Identifiers (FieldName)
+import PostgREST.ApiRequest.Preferences
+import PostgREST.MediaType               (MTVndPlanFormat (..),
+                                          MediaType (..))
 import PostgREST.Query.SqlFragment
-import PostgREST.Request.Preferences
+import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier)
+import PostgREST.SchemaCache.Routine     (MediaHandler (..), Routine,
+                                          funcReturnsSingle)
 
 import Protolude
 
-{-| The generic query result format used by API responses. The location header
-    is represented as a list of strings containing variable bindings like
-    @"k1=eq.42"@, or the empty list if there is no location header.
--}
-type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString, Either Error [GucHeader], Either Error (Maybe Status))
+-- | Standard result set format used for all queries
+data ResultSet
+  = RSStandard
+  { rsTableTotal :: Maybe Int64
+  -- ^ count of all the table rows
+  , rsQueryTotal :: Int64
+  -- ^ count of the query rows
+  , rsLocation   :: [(BS.ByteString, BS.ByteString)]
+  -- ^ The Location header(only used for inserts) is represented as a list of strings containing
+  -- variable bindings like @"k1=eq.42"@, or the empty list if there is no location header.
+  , rsBody       :: BS.ByteString
+  -- ^ the aggregated body of the query
+  , rsGucHeaders :: Maybe BS.ByteString
+  -- ^ the HTTP headers to be added to the response
+  , rsGucStatus  :: Maybe Text
+  -- ^ the HTTP status to be added to the response
+  , rsInserted   :: Maybe Int64
+  -- ^ the number of rows inserted (Only used for upserts)
+  }
+  | RSPlan BS.ByteString -- ^ the plan of the query
 
-createWriteStatement :: SQL.Snippet -> SQL.Snippet -> Bool -> Bool -> Bool ->
-                        PreferRepresentation -> [Text] -> Bool ->
-                        SQL.Statement () ResultsWithCount
-createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys =
-  SQL.dynamicallyParameterized snippet decodeStandard
+
+prepareWrite :: QualifiedIdentifier -> SQL.Snippet -> SQL.Snippet -> Bool -> Bool -> MediaType -> MediaHandler ->
+                Maybe PreferRepresentation -> Maybe PreferResolution -> [Text] -> Bool -> SQL.Statement () ResultSet
+prepareWrite qi selectQuery mutateQuery isInsert isPut mt handler rep resolution pKeys =
+  SQL.dynamicallyParameterized (mtSnippet mt snippet) decodeIt
  where
+  checkUpsert snip = if isInsert && (isPut || resolution == Just MergeDuplicates) then snip else "''"
+  pgrstInsertedF = checkUpsert "nullif(current_setting('pgrst.inserted', true),'')::int"
   snippet =
-    "WITH " <> SQL.sql sourceCTEName <> " AS (" <> mutateQuery <> ") " <>
-    SQL.sql (
+    "WITH " <> sourceCTE <> " AS (" <> mutateQuery <> ") " <>
     "SELECT " <>
       "'' AS total_result_set, " <>
       "pg_catalog.count(_postgrest_t) AS page_total, " <>
       locF <> " AS header, " <>
-      bodyF <> " AS body, " <>
+      handlerF Nothing qi handler <> " AS body, " <>
       responseHeadersF <> " AS response_headers, " <>
-      responseStatusF  <> " AS response_status "
-    ) <>
+      responseStatusF  <> " AS response_status, " <>
+      pgrstInsertedF <> " AS response_inserted " <>
     "FROM (" <> selectF <> ") _postgrest_t"
 
   locF =
-    if isInsert && rep `elem` [Full, HeadersOnly]
-      then BS.unwords [
-        "CASE WHEN pg_catalog.count(_postgrest_t) = 1",
-          "THEN coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")",
-          "ELSE " <> noLocationF,
-        "END"]
+    if isInsert && rep == Just HeadersOnly
+      then
+        "CASE WHEN pg_catalog.count(_postgrest_t) = 1 " <>
+          "THEN coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ") " <>
+          "ELSE " <> noLocationF <> " " <>
+        "END"
       else noLocationF
 
-  bodyF
-    | rep `elem` [None, HeadersOnly] = "''"
-    | asCsv = asCsvF
-    | wantSingle = asJsonSingleF False
-    | otherwise = asJsonF False
-
   selectF
     -- prevent using any of the column names in ?select= when no response is returned from the CTE
-    | rep `elem` [None, HeadersOnly] = SQL.sql ("SELECT * FROM " <> sourceCTEName)
-    | otherwise                      = selectQuery
+    | handler == NoAgg = "SELECT * FROM " <> sourceCTE
+    | otherwise        = selectQuery
 
-  decodeStandard :: HD.Result ResultsWithCount
-  decodeStandard =
-   fromMaybe (Nothing, 0, [], mempty, Right [], Right Nothing) <$> HD.rowMaybe standardRow
+  decodeIt :: HD.Result ResultSet
+  decodeIt = case mt of
+    MTVndPlan{} -> planRow
+    _           -> fromMaybe (RSStandard Nothing 0 mempty mempty Nothing Nothing Nothing) <$> HD.rowMaybe (standardRow False)
 
-createReadStatement :: SQL.Snippet -> SQL.Snippet -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool ->
-                       SQL.Statement () ResultsWithCount
-createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =
-  SQL.dynamicallyParameterized snippet decodeStandard
+prepareRead :: QualifiedIdentifier -> SQL.Snippet -> SQL.Snippet -> Bool -> MediaType -> MediaHandler -> Bool -> SQL.Statement () ResultSet
+prepareRead qi selectQuery countQuery countTotal mt handler =
+  SQL.dynamicallyParameterized (mtSnippet mt snippet) decodeIt
  where
   snippet =
-    "WITH " <>
-    SQL.sql sourceCTEName <> " AS ( " <> selectQuery <> " ) " <>
+    "WITH " <> sourceCTE <> " AS ( " <> selectQuery <> " ) " <>
     countCTEF <> " " <>
-    SQL.sql ("SELECT " <>
+    "SELECT " <>
       countResultF <> " AS total_result_set, " <>
       "pg_catalog.count(_postgrest_t) AS page_total, " <>
-      noLocationF <> " AS header, " <>
-      bodyF <> " AS body, " <>
+      handlerF Nothing qi handler <> " AS body, " <>
       responseHeadersF <> " AS response_headers, " <>
-      responseStatusF <> " AS response_status " <>
-    "FROM ( SELECT * FROM " <> sourceCTEName <> " ) _postgrest_t")
+      responseStatusF <> " AS response_status, " <>
+      "''" <> " AS response_inserted " <>
+    "FROM ( SELECT * FROM " <> sourceCTE <> " ) _postgrest_t"
 
   (countCTEF, countResultF) = countF countQuery countTotal
 
-  bodyF
-    | asCsv = asCsvF
-    | isSingle = asJsonSingleF False
-    | isJust binaryField = asBinaryF $ fromJust binaryField
-    | otherwise = asJsonF False
+  decodeIt :: HD.Result ResultSet
+  decodeIt = case mt of
+    MTVndPlan{} -> planRow
+    _           -> HD.singleRow $ standardRow True
 
-  decodeStandard :: HD.Result ResultsWithCount
-  decodeStandard =
-    HD.singleRow standardRow
-
-{-| Read and Write api requests use a similar response format which includes
-    various record counts and possible location header. This is the decoder
-    for that common type of query.
--}
-standardRow :: HD.Row ResultsWithCount
-standardRow = (,,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
-                      <*> arrayColumn HD.bytea <*> column HD.bytea
-                      <*> (fromMaybe (Right []) <$> nullableColumn decodeGucHeaders)
-                      <*> (fromMaybe (Right Nothing) <$> nullableColumn decodeGucStatus)
-
-type ProcResults = (Maybe Int64, Int64, ByteString, Either Error [GucHeader], Either Error (Maybe Status))
-
-callProcStatement :: Bool -> Bool -> SQL.Snippet -> SQL.Snippet -> SQL.Snippet -> Bool ->
-                     Bool -> Bool -> Bool -> Maybe FieldName -> Bool ->
-                     SQL.Statement () ProcResults
-callProcStatement returnsScalar returnsSingle callProcQuery selectQuery countQuery countTotal asSingle asCsv multObjects binaryField =
-  SQL.dynamicallyParameterized snippet decodeProc
+prepareCall :: QualifiedIdentifier -> Routine -> SQL.Snippet -> SQL.Snippet -> SQL.Snippet -> Bool ->
+               MediaType -> MediaHandler -> Bool ->
+               SQL.Statement () ResultSet
+prepareCall qi rout callProcQuery selectQuery countQuery countTotal mt handler =
+  SQL.dynamicallyParameterized (mtSnippet mt snippet) decodeIt
   where
     snippet =
-      "WITH " <> SQL.sql sourceCTEName <> " AS (" <> callProcQuery <> ") " <>
+      "WITH " <> sourceCTE <> " AS (" <> callProcQuery <> ") " <>
       countCTEF <>
-      SQL.sql (
       "SELECT " <>
         countResultF <> " AS total_result_set, " <>
-        "pg_catalog.count(_postgrest_t) AS page_total, " <>
-        bodyF <> " AS body, " <>
+        (if funcReturnsSingle rout
+          then "1"
+          else "pg_catalog.count(_postgrest_t)") <> " AS page_total, " <>
+        handlerF (Just rout) qi handler <> " AS body, " <>
         responseHeadersF <> " AS response_headers, " <>
-        responseStatusF <> " AS response_status ") <>
+        responseStatusF <> " AS response_status, " <>
+        "''" <> " AS response_inserted " <>
       "FROM (" <> selectQuery <> ") _postgrest_t"
 
     (countCTEF, countResultF) = countF countQuery countTotal
 
-    bodyF
-     | asSingle           = asJsonSingleF returnsScalar
-     | asCsv              = asCsvF
-     | isJust binaryField = asBinaryF $ fromJust binaryField
-     | returnsSingle
-       && not multObjects = asJsonSingleF returnsScalar
-     | otherwise          = asJsonF returnsScalar
+    decodeIt :: HD.Result ResultSet
+    decodeIt = case mt of
+      MTVndPlan{} -> planRow
+      _           -> fromMaybe (RSStandard (Just 0) 0 mempty mempty Nothing Nothing Nothing) <$> HD.rowMaybe (standardRow True)
 
-    decodeProc :: HD.Result ProcResults
-    decodeProc =
-      fromMaybe (Just 0, 0, mempty, defGucHeaders, defGucStatus) <$> HD.rowMaybe procRow
-      where
-        defGucHeaders = Right []
-        defGucStatus  = Right Nothing
-        procRow = (,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
-                         <*> column HD.bytea
-                         <*> (fromMaybe defGucHeaders <$> nullableColumn decodeGucHeaders)
-                         <*> (fromMaybe defGucStatus <$> nullableColumn decodeGucStatus)
-
-createExplainStatement :: SQL.Snippet -> Bool -> SQL.Statement () (Maybe Int64)
-createExplainStatement countQuery =
-  SQL.dynamicallyParameterized snippet decodeExplain
+preparePlanRows :: SQL.Snippet -> Bool -> SQL.Statement () (Maybe Int64)
+preparePlanRows countQuery =
+  SQL.dynamicallyParameterized snippet decodeIt
   where
-    snippet = "EXPLAIN (FORMAT JSON) " <> countQuery
-    -- |
-    -- An `EXPLAIN (FORMAT JSON) select * from items;` output looks like this:
-    -- [{
-    --   "Plan": {
-    --     "Node Type": "Seq Scan", "Parallel Aware": false, "Relation Name": "items",
-    --     "Alias": "items", "Startup Cost": 0.00, "Total Cost": 32.60,
-    --     "Plan Rows": 2260,"Plan Width": 8} }]
-    -- We only obtain the Plan Rows here.
-    decodeExplain :: HD.Result (Maybe Int64)
-    decodeExplain =
+    snippet = explainF PlanJSON mempty countQuery
+    decodeIt :: HD.Result (Maybe Int64)
+    decodeIt =
       let row = HD.singleRow $ column HD.bytea in
       (^? L.nth 0 . L.key "Plan" .  L.key "Plan Rows" . L._Integral) <$> row
 
-decodeGucHeaders :: HD.Value (Either Error [GucHeader])
-decodeGucHeaders = first (const GucHeadersError) . JSON.eitherDecode . LBS.fromStrict <$> HD.bytea
+standardRow :: Bool -> HD.Row ResultSet
+standardRow noLocation =
+  RSStandard <$> nullableColumn HD.int8 <*> column HD.int8
+             <*> (if noLocation then pure mempty else fmap splitKeyValue <$> arrayColumn HD.bytea)
+             <*> (fromMaybe mempty <$> nullableColumn HD.bytea)
+             <*> nullableColumn HD.bytea
+             <*> nullableColumn HD.text
+             <*> nullableColumn HD.int8
+  where
+    splitKeyValue :: ByteString -> (ByteString, ByteString)
+    splitKeyValue kv =
+      let (k, v) = BS.break (== '=') kv in
+      (k, BS.tail v)
 
-decodeGucStatus :: HD.Value (Either Error (Maybe Status))
-decodeGucStatus = first (const GucStatusError) . fmap (Just . toEnum . fst) . decimal <$> HD.text
+mtSnippet :: MediaType -> SQL.Snippet -> SQL.Snippet
+mtSnippet mediaType snippet = case mediaType of
+  MTVndPlan _ fmt opts -> explainF fmt opts snippet
+  _                    -> snippet
+
+-- | We use rowList because when doing EXPLAIN (FORMAT TEXT), the result comes as many rows. FORMAT JSON comes as one.
+planRow :: HD.Result ResultSet
+planRow = RSPlan . BS.unlines <$> HD.rowList (column HD.bytea)
 
 column :: HD.Value a -> HD.Row a
 column = HD.column . HD.nonNullable

src/PostgREST/RangeQuery.hs

@@ -10,6 +10,9 @@ module PostgREST.RangeQuery (
 , restrictRange
 , rangeGeq
 , allRange
+, limitZeroRange
+, hasLimitZero
+, convertToLimitZeroRange
 , NonnegRange
 , rangeStatusHeader
 , contentRangeH
@@ -34,13 +37,14 @@ rangeParse :: BS.ByteString -> NonnegRange
 rangeParse range = do
   let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString
 
-  case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of
-    Just parsedRange ->
-      let [_, mLower, mUpper] = readMaybe . BS.unpack <$> parsedRange
-          lower         = maybe emptyRange rangeGeq mLower
-          upper         = maybe allRange rangeLeq mUpper in
+  case range =~ rangeRegex :: [[BS.ByteString]] of
+    [[_, l, u]] ->
+      let lower  = maybe emptyRange rangeGeq (readInteger l)
+          upper  = maybe allRange rangeLeq (readInteger u) in
       rangeIntersection lower upper
-    Nothing -> allRange
+    _ -> allRange
+  where
+    readInteger = readMaybe . BS.unpack
 
 rangeRequested :: RequestHeaders -> NonnegRange
 rangeRequested headers = maybe allRange rangeParse $ lookup hRange headers
@@ -74,6 +78,21 @@ rangeLeq :: Integer -> NonnegRange
 rangeLeq n =
   Range BoundaryBelowAll (BoundaryAbove n)
 
+-- Special case to allow limit 0 queries
+-- https://github.com/PostgREST/postgrest/issues/1121
+-- 0 <= x <= -1
+limitZeroRange :: Range Integer
+limitZeroRange = Range (BoundaryBelow 0) (BoundaryAbove (-1))
+
+hasLimitZero :: Range Integer -> Bool
+hasLimitZero r = rangeUpper r == rangeUpper limitZeroRange
+
+-- Used to convert a range into a special limitZeroRange if it has a
+-- limit=0 in order to bypass validations for empty ranges.
+convertToLimitZeroRange :: Range Integer -> Range Integer -> Range Integer
+convertToLimitZeroRange range fallbackRange =
+  if hasLimitZero range then limitZeroRange else fallbackRange
+
 rangeStatusHeader :: NonnegRange -> Int64 -> Maybe Int64 -> (Status, Header)
 rangeStatusHeader topLevelRange queryTotal tableTotal =
   let lower = rangeOffset topLevelRange

src/PostgREST/Request/ApiRequest.hs

@@ -1,518 +0,0 @@
-{-|
-Module      : PostgREST.Request.ApiRequest
-Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
--}
-{-# LANGUAGE LambdaCase      #-}
-{-# LANGUAGE NamedFieldPuns  #-}
-{-# LANGUAGE RecordWildCards #-}
-
-module PostgREST.Request.ApiRequest
-  ( ApiRequest(..)
-  , InvokeMethod(..)
-  , ContentType(..)
-  , Action(..)
-  , Target(..)
-  , Payload(..)
-  , userApiRequest
-  ) where
-
-import qualified Data.Aeson            as JSON
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.ByteString.Lazy  as LBS
-import qualified Data.CaseInsensitive  as CI
-import qualified Data.Csv              as CSV
-import qualified Data.HashMap.Strict   as M
-import qualified Data.List             as L
-import qualified Data.List.NonEmpty    as NonEmptyList
-import qualified Data.Set              as S
-import qualified Data.Text             as T
-import qualified Data.Text.Encoding    as T
-import qualified Data.Vector           as V
-
-import Control.Arrow             ((***))
-import Data.Aeson.Types          (emptyArray, emptyObject)
-import Data.List                 (last, lookup, partition, union)
-import Data.Maybe                (fromJust)
-import Data.Ranged.Boundaries    (Boundary (..))
-import Data.Ranged.Ranges        (Range (..), emptyRange,
-                                  rangeIntersection)
-import Network.HTTP.Base         (urlEncodeVars)
-import Network.HTTP.Types.Header (hAuthorization, hCookie)
-import Network.HTTP.Types.URI    (parseQueryReplacePlus,
-                                  parseSimpleQuery)
-import Network.Wai               (Request (..))
-import Network.Wai.Parse         (parseHttpAccept)
-import Web.Cookie                (parseCookies)
-
-import PostgREST.Config                  (AppConfig (..),
-                                          OpenAPIMode (..))
-import PostgREST.ContentType             (ContentType (..))
-import PostgREST.DbStructure             (DbStructure (..))
-import PostgREST.DbStructure.Identifiers (FieldName,
-                                          QualifiedIdentifier (..),
-                                          Schema)
-import PostgREST.DbStructure.Proc        (ProcDescription (..),
-                                          ProcParam (..), ProcsMap)
-import PostgREST.Error                   (ApiRequestError (..))
-import PostgREST.Query.SqlFragment       (ftsOperators, operators)
-import PostgREST.RangeQuery              (NonnegRange, allRange,
-                                          rangeGeq, rangeLimit,
-                                          rangeOffset, rangeRequested,
-                                          restrictRange)
-import PostgREST.Request.Parsers         (pRequestColumns)
-import PostgREST.Request.Preferences     (PreferCount (..),
-                                          PreferParameters (..),
-                                          PreferRepresentation (..),
-                                          PreferResolution (..),
-                                          PreferTransaction (..))
-
-import qualified PostgREST.ContentType         as ContentType
-import qualified PostgREST.Request.Preferences as Preferences
-
-import Protolude
-
-
-type RequestBody = LBS.ByteString
-
-data Payload
-  = ProcessedJSON -- ^ Cached attributes of a JSON payload
-      { payRaw  :: LBS.ByteString
-      -- ^ This is the raw ByteString that comes from the request body.  We
-      -- cache this instead of an Aeson Value because it was detected that for
-      -- large payloads the encoding had high memory usage, see
-      -- https://github.com/PostgREST/postgrest/pull/1005 for more details
-      , payKeys :: S.Set Text
-      -- ^ Keys of the object or if it's an array these keys are guaranteed to
-      -- be the same across all its objects
-      }
-  | RawJSON { payRaw  :: LBS.ByteString }
-  | RawPay  { payRaw  :: LBS.ByteString }
-
-data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
--- | Types of things a user wants to do to tables/views/procs
-data Action = ActionCreate       | ActionRead{isHead :: Bool}
-            | ActionUpdate       | ActionDelete
-            | ActionSingleUpsert | ActionInvoke InvokeMethod
-            | ActionInfo         | ActionInspect{isHead :: Bool}
-            deriving Eq
--- | The path info that will be mapped to a target (used to handle validations and errors before defining the Target)
-data Path
-  = PathInfo
-      { pSchema        :: Schema,
-        pName          :: Text,
-        pHasRpc        :: Bool,
-        pIsDefaultSpec :: Bool,
-        pIsRootSpec    :: Bool
-      }
-  | PathUnknown
--- | The target db object of a user action
-data Target = TargetIdent QualifiedIdentifier
-            | TargetProc{tProc :: ProcDescription, tpIsRootSpec :: Bool}
-            | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/"
-            | TargetUnknown
-
--- | RPC query param value `/rpc/func?v=<value>`, used for VARIADIC functions on form-urlencoded POST and GETs
--- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3.
-data RpcParamValue = Fixed Text | Variadic [Text]
-instance JSON.ToJSON RpcParamValue where
-  toJSON (Fixed    v) = JSON.toJSON v
-  toJSON (Variadic v) = JSON.toJSON v
-
-toRpcParamValue :: ProcDescription -> (Text, Text) -> (Text, RpcParamValue)
-toRpcParamValue proc (k, v) | prmIsVariadic k = (k, Variadic [v])
-                            | otherwise       = (k, Fixed v)
-  where
-    prmIsVariadic prm = isJust $ find (\ProcParam{ppName, ppVar} -> ppName == prm && ppVar) $ pdParams proc
-
--- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"}
-jsonRpcParams :: ProcDescription -> [(Text, Text)] -> Payload
-jsonRpcParams proc prms =
-  if not $ pdHasVariadic proc then -- if proc has no variadic param, save steps and directly convert to json
-    ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> prms) (S.fromList $ fst <$> prms)
-  else
-    let paramsMap = M.fromListWith mergeParams $ toRpcParamValue proc <$> prms in
-    ProcessedJSON (JSON.encode paramsMap) (S.fromList $ M.keys paramsMap)
-  where
-    mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue
-    mergeParams (Variadic a) (Variadic b) = Variadic $ b ++ a
-    mergeParams v _                       = v -- repeated params for non-variadic parameters are not merged
-
-targetToJsonRpcParams :: Maybe Target -> [(Text, Text)] -> Maybe Payload
-targetToJsonRpcParams target params =
-  case target of
-    Just TargetProc{tProc} -> Just $ jsonRpcParams tProc params
-    _                      -> Nothing
-
-{-|
-  Describes what the user wants to do. This data type is a
-  translation of the raw elements of an HTTP request into domain
-  specific language.  There is no guarantee that the intent is
-  sensible, it is up to a later stage of processing to determine
-  if it is an action we are able to perform.
--}
-data ApiRequest = ApiRequest {
-    iAction               :: Action                           -- ^ Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
-  , iRange                :: M.HashMap Text NonnegRange -- ^ Requested range of rows within response
-  , iTopLevelRange        :: NonnegRange                      -- ^ Requested range of rows from the top level
-  , iTarget               :: Target                           -- ^ The target, be it calling a proc or accessing a table
-  , iPayload              :: Maybe Payload                    -- ^ Data sent by client and used for mutation actions
-  , iPreferRepresentation :: PreferRepresentation             -- ^ If client wants created items echoed back
-  , iPreferParameters     :: Maybe PreferParameters           -- ^ How to pass parameters to a stored procedure
-  , iPreferCount          :: Maybe PreferCount                -- ^ Whether the client wants a result count
-  , iPreferResolution     :: Maybe PreferResolution           -- ^ Whether the client wants to UPSERT or ignore records on PK conflict
-  , iPreferTransaction    :: Maybe PreferTransaction          -- ^ Whether the clients wants to commit or rollback the transaction
-  , iFilters              :: [(Text, Text)]                   -- ^ Filters on the result ("id", "eq.10")
-  , iLogic                :: [(Text, Text)]                   -- ^ &and and &or parameters used for complex boolean logic
-  , iSelect               :: Maybe Text                       -- ^ &select parameter used to shape the response
-  , iOnConflict           :: Maybe Text                       -- ^ &on_conflict parameter used to upsert on specific unique keys
-  , iColumns              :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and payload
-  , iOrder                :: [(Text, Text)]                   -- ^ &order parameters for each level
-  , iCanonicalQS          :: ByteString                       -- ^ Alphabetized (canonical) request query string for response URLs
-  , iJWT                  :: Text                             -- ^ JSON Web Token
-  , iHeaders              :: [(ByteString, ByteString)]       -- ^ HTTP request headers
-  , iCookies              :: [(ByteString, ByteString)]       -- ^ Request Cookies
-  , iPath                 :: ByteString                       -- ^ Raw request path
-  , iMethod               :: ByteString                       -- ^ Raw request method
-  , iProfile              :: Maybe Schema                     -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/.
-  , iSchema               :: Schema                           -- ^ The request schema. Can vary depending on iProfile.
-  , iAcceptContentType    :: ContentType
-  }
-
--- | Examines HTTP request and translates it into user intent.
-userApiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest
-userApiRequest conf@AppConfig{..} dbStructure req reqBody
-  | isJust profile && fromJust profile `notElem` configDbSchemas = Left $ UnacceptableSchema $ toList configDbSchemas
-  | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate
-  | topLevelRange == emptyRange = Left InvalidRange
-  | shouldParsePayload && isLeft payload = either (Left . InvalidBody) witness payload
-  | isLeft parsedColumns = either Left witness parsedColumns
-  | otherwise = do
-     acceptContentType <- findAcceptContentType conf action path accepts
-     checkedTarget <- target
-     return ApiRequest {
-      iAction = action
-      , iTarget = checkedTarget
-      , iRange = ranges
-      , iTopLevelRange = topLevelRange
-      , iPayload = relevantPayload
-      , iPreferRepresentation = fromMaybe None preferRepresentation
-      , iPreferParameters = preferParameters
-      , iPreferCount = preferCount
-      , iPreferResolution = preferResolution
-      , iPreferTransaction = preferTransaction
-      , iFilters = filters
-      , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
-      , iSelect = toS <$> join (lookup "select" qParams)
-      , iOnConflict = toS <$> join (lookup "on_conflict" qParams)
-      , iColumns = payloadColumns
-      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
-      , iCanonicalQS = BS.pack $ urlEncodeVars
-        . L.sortOn fst
-        . map (join (***) BS.unpack . second (fromMaybe mempty))
-        $ qString
-      , iJWT = tokenStr
-      , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]
-      , iCookies = maybe [] parseCookies $ lookupHeader "Cookie"
-      , iPath = rawPathInfo req
-      , iMethod = method
-      , iProfile = profile
-      , iSchema = schema
-      , iAcceptContentType = acceptContentType
-      }
- where
-  accepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept"
-  -- queryString with '+' converted to ' '(space)
-  qString = parseQueryReplacePlus True $ rawQueryString req
-  -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)
-  (filters, rpcQParams) =
-    case action of
-      ActionInvoke InvGet  -> partitionFlts
-      ActionInvoke InvHead -> partitionFlts
-      _                    -> (flts, [])
-  partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts
-  flts =
-    [ (toS k, toS $ fromJust v) |
-      (k,v) <- qParams, isJust v,
-      k `notElem` ["select", "columns"],
-      not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
-  hasOperator val = any (`T.isPrefixOf` val) $
-                      ((<> ".") <$> "not":M.keys operators) ++
-                      ((<> "(") <$> M.keys ftsOperators)
-  isEmbedPath = T.isInfixOf "."
-  isTargetingProc = case path of
-    PathInfo{pHasRpc, pIsRootSpec} -> pHasRpc || pIsRootSpec
-    _                              -> False
-  isTargetingDefaultSpec = case path of
-    PathInfo{pIsDefaultSpec=True} -> True
-    _                             -> False
-  contentType = maybe CTApplicationJSON ContentType.decodeContentType $ lookupHeader "content-type"
-  columns
-    | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
-    | otherwise = Nothing
-  parsedColumns = pRequestColumns columns
-  payloadColumns =
-    case (contentType, action) of
-      (_, ActionInvoke InvGet)  -> S.fromList $ fst <$> rpcQParams
-      (_, ActionInvoke InvHead) -> S.fromList $ fst <$> rpcQParams
-      (CTUrlEncoded, _)         -> S.fromList $ map (T.decodeUtf8 . fst) $ parseSimpleQuery $ LBS.toStrict reqBody
-      _ -> case (relevantPayload, fromRight Nothing parsedColumns) of
-        (Just ProcessedJSON{payKeys}, _) -> payKeys
-        (Just RawJSON{}, Just cls)       -> cls
-        _                                -> S.empty
-  payload :: Either ByteString Payload
-  payload = case contentType of
-    CTApplicationJSON ->
-      if isJust columns
-        then Right $ RawJSON reqBody
-        else note "All object keys must match" . payloadAttributes reqBody
-               =<< if LBS.null reqBody && isTargetingProc
-                     then Right emptyObject
-                     else first BS.pack $ JSON.eitherDecode reqBody
-    CTTextCSV -> do
-      json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody)
-      note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
-    CTUrlEncoded ->
-      let paramsMap = M.fromList $ (T.decodeUtf8 *** JSON.String . T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody) in
-      Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (M.keys paramsMap)
-    ct ->
-      if isTargetingProc && ct `elem` [CTTextPlain, CTOctetStream]
-        then Right $ RawPay reqBody
-        else Left $ "Content-Type not acceptable: " <> ContentType.toMime ct
-  topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows
-  action =
-    case method of
-      -- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response
-      -- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4
-      "HEAD"     | isTargetingDefaultSpec -> ActionInspect{isHead=True}
-                 | isTargetingProc        -> ActionInvoke InvHead
-                 | otherwise              -> ActionRead{isHead=True}
-      "GET"      | isTargetingDefaultSpec -> ActionInspect{isHead=False}
-                 | isTargetingProc        -> ActionInvoke InvGet
-                 | otherwise              -> ActionRead{isHead=False}
-      "POST"    -> if isTargetingProc
-                    then ActionInvoke InvPost
-                    else ActionCreate
-      "PATCH"   -> ActionUpdate
-      "PUT"     -> ActionSingleUpsert
-      "DELETE"  -> ActionDelete
-      "OPTIONS" -> ActionInfo
-      _         -> ActionInspect{isHead=False}
-
-  defaultSchema = NonEmptyList.head configDbSchemas
-  profile
-    | length configDbSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config
-      = Nothing
-    | otherwise = case action of
-        -- POST/PATCH/PUT/DELETE don't use the same header as per the spec
-        ActionCreate         -> contentProfile
-        ActionUpdate         -> contentProfile
-        ActionSingleUpsert   -> contentProfile
-        ActionDelete         -> contentProfile
-        ActionInvoke InvPost -> contentProfile
-        _                    -> acceptProfile
-    where
-      contentProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Content-Profile"
-      acceptProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Accept-Profile"
-  schema = fromMaybe defaultSchema profile
-  target =
-    let
-      callFindProc procSch procNam = findProc
-        (QualifiedIdentifier procSch procNam) payloadColumns (preferParameters == Just SingleObject) (dbProcs dbStructure)
-        contentType (action == ActionInvoke InvPost)
-    in
-    case path of
-      PathInfo{pSchema, pName, pHasRpc, pIsRootSpec, pIsDefaultSpec}
-        | pHasRpc || pIsRootSpec -> (`TargetProc` pIsRootSpec) <$> callFindProc pSchema pName
-        | pIsDefaultSpec         -> Right $ TargetDefaultSpec pSchema
-        | otherwise              -> Right $ TargetIdent $ QualifiedIdentifier pSchema pName
-      PathUnknown -> Right TargetUnknown
-
-  shouldParsePayload = case (contentType, action) of
-    (CTUrlEncoded, ActionInvoke InvPost) -> False
-    (_, act)                             -> act `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke InvPost]
-  relevantPayload = case (contentType, action) of
-    -- Though ActionInvoke GET/HEAD doesn't really have a payload, we use the payload variable as a way
-    -- to store the query string arguments to the function.
-    (_, ActionInvoke InvGet)             -> targetToJsonRpcParams (rightToMaybe target) rpcQParams
-    (_, ActionInvoke InvHead)            -> targetToJsonRpcParams (rightToMaybe target) rpcQParams
-    (CTUrlEncoded, ActionInvoke InvPost) -> targetToJsonRpcParams (rightToMaybe target) $ (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
-    _ | shouldParsePayload               -> rightToMaybe payload
-      | otherwise                        -> Nothing
-  path =
-    case pathInfo req of
-      []             -> case configDbRootSpec of
-                          Just (QualifiedIdentifier pSch pName)     -> PathInfo (if pSch == mempty then schema else pSch) pName False False True
-                          Nothing | configOpenApiMode == OADisabled -> PathUnknown
-                                  | otherwise                       -> PathInfo schema "" False True False
-      [table]        -> PathInfo schema table False False False
-      ["rpc", pName] -> PathInfo schema pName True False False
-      _              -> PathUnknown
-  method          = requestMethod req
-  hdrs            = requestHeaders req
-  qParams         = [(T.decodeUtf8 k, T.decodeUtf8 <$> v)|(k,v) <- qString]
-  lookupHeader    = flip lookup hdrs
-  Preferences.Preferences{..} = Preferences.fromHeaders hdrs
-  auth = fromMaybe "" $ lookupHeader hAuthorization
-  tokenStr = case T.split (== ' ') (T.decodeUtf8 auth) of
-    ("Bearer" : t : _) -> t
-    ("bearer" : t : _) -> t
-    _                  -> ""
-  endingIn:: [Text] -> Text -> Bool
-  endingIn xx key = lastWord `elem` xx
-    where lastWord = last $ T.split (=='.') key
-
-  headerRange = rangeRequested hdrs
-  replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]
-  limitParams :: M.HashMap Text NonnegRange
-  limitParams  = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe . toS =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]
-  offsetParams :: M.HashMap Text NonnegRange
-  offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe . toS =<< v)) | (k,v) <- qParams, isJust v, endingIn ["offset"] k]
-
-  urlRange = M.unionWith f limitParams offsetParams
-    where
-      f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)
-        where
-          l = fromMaybe 0 $ rangeLimit rl
-          o = rangeOffset ro
-  ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange
-
-{-|
-  Find the best match from a list of content types accepted by the
-  client in order of decreasing preference and a list of types
-  producible by the server.  If there is no match but the client
-  accepts */* then return the top server pick.
--}
-mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType
-mutuallyAgreeable sProduces cAccepts =
-  let exact = listToMaybe $ L.intersect cAccepts sProduces in
-  if isNothing exact && CTAny `elem` cAccepts
-     then listToMaybe sProduces
-     else exact
-
-type CsvData = V.Vector (M.HashMap Text LBS.ByteString)
-
-{-|
-  Converts CSV like
-  a,b
-  1,hi
-  2,bye
-
-  into a JSON array like
-  [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
-
-  The reason for its odd signature is so that it can compose
-  directly with CSV.decodeByName
--}
-csvToJson :: (CSV.Header, CsvData) -> JSON.Value
-csvToJson (_, vals) =
-  JSON.Array $ V.map rowToJsonObj vals
- where
-  rowToJsonObj = JSON.Object .
-    M.map (\str ->
-        if str == "NULL"
-          then JSON.Null
-          else JSON.String . T.decodeUtf8 $ LBS.toStrict str
-      )
-
-payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
-payloadAttributes raw json =
-  -- Test that Array contains only Objects having the same keys
-  case json of
-    JSON.Array arr ->
-      case arr V.!? 0 of
-        Just (JSON.Object o) ->
-          let canonicalKeys = S.fromList $ M.keys o
-              areKeysUniform = all (\case
-                JSON.Object x -> S.fromList (M.keys x) == canonicalKeys
-                _ -> False) arr in
-          if areKeysUniform
-            then Just $ ProcessedJSON raw canonicalKeys
-            else Nothing
-        Just _ -> Nothing
-        Nothing -> Just emptyPJArray
-
-    JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ M.keys o)
-
-    -- truncate everything else to an empty array.
-    _ -> Just emptyPJArray
-  where
-    emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
-
-findAcceptContentType :: AppConfig -> Action -> Path -> [ContentType] -> Either ApiRequestError ContentType
-findAcceptContentType conf action path accepts =
-  case mutuallyAgreeable (requestContentTypes conf action path) accepts of
-    Just ct ->
-      Right ct
-    Nothing ->
-      Left . ContentTypeError $ map ContentType.toMime accepts
-
-requestContentTypes :: AppConfig -> Action -> Path -> [ContentType]
-requestContentTypes conf action path =
-  case action of
-    ActionRead _    -> defaultContentTypes ++ rawContentTypes conf
-    ActionInvoke _  -> invokeContentTypes
-    ActionInspect _ -> [CTOpenAPI, CTApplicationJSON]
-    ActionInfo      -> [CTTextCSV]
-    _               -> defaultContentTypes
-  where
-    invokeContentTypes =
-      defaultContentTypes
-        ++ rawContentTypes conf
-        ++ [CTOpenAPI | pIsRootSpec path]
-    defaultContentTypes =
-      [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-
-rawContentTypes :: AppConfig -> [ContentType]
-rawContentTypes AppConfig{..} =
-  (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
-
-{-|
-  Search a pg proc by matching name and arguments keys to parameters. Since a function can be overloaded,
-  the name is not enough to find it. An overloaded function can have a different volatility or even a different return type.
--}
-findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> ContentType -> Bool -> Either ApiRequestError ProcDescription
-findProc qi argumentsKeys paramsAsSingleObject allProcs contentType isInvPost =
-  case matchProc of
-    ([], [])     -> Left $ NoRpc (qiSchema qi) (qiName qi) (S.toList argumentsKeys) paramsAsSingleObject contentType isInvPost
-    -- If there are no functions with named arguments, fallback to the single unnamed argument function
-    ([], [proc]) -> Right proc
-    ([], procs)  -> Left $ AmbiguousRpc (toList procs)
-    -- Matches the functions with named arguments
-    ([proc], _)  -> Right proc
-    (procs, _)   -> Left $ AmbiguousRpc (toList procs)
-  where
-    matchProc = overloadedProcPartition $ M.lookupDefault mempty qi allProcs -- first find the proc by name
-    -- The partition obtained has the form (overloadedProcs,fallbackProcs)
-    -- where fallbackProcs are functions with a single unnamed parameter
-    overloadedProcPartition procs = foldr select ([],[]) procs
-    select proc ~(ts,fs)
-      | matchesParams proc         = (proc:ts,fs)
-      | hasSingleUnnamedParam proc = (ts,proc:fs)
-      | otherwise                  = (ts,fs)
-    -- If the function is called with post and has a single unnamed parameter
-    -- it can be called depending on content type and the parameter type
-    hasSingleUnnamedParam proc = isInvPost && case pdParams proc of
-      [ProcParam "" ppType _ _]
-        | contentType == CTApplicationJSON -> ppType `elem` ["json", "jsonb"]
-        | contentType == CTTextPlain       -> ppType == "text"
-        | contentType == CTOctetStream     -> ppType == "bytea"
-        | otherwise                        -> False
-      _ -> False
-    matchesParams proc =
-      let params = pdParams proc in
-      -- exceptional case for Prefer: params=single-object
-      if paramsAsSingleObject
-        then length params == 1 && (ppType <$> headMay params) `elem` [Just "json", Just "jsonb"]
-      -- If the function has no parameters, the arguments keys must be empty as well
-      else if null params
-        then null argumentsKeys && contentType `notElem` [CTTextPlain, CTOctetStream]
-      -- A function has optional and required parameters. Optional parameters have a default value and
-      -- don't require arguments for the function to be executed, required parameters must have an argument present.
-      else case L.partition ppReq params of
-      -- If the function only has required parameters, the arguments keys must match those parameters
-        (reqParams, [])        -> argumentsKeys == S.fromList (ppName <$> reqParams)
-      -- If the function only has optional parameters, the arguments keys can match none or any of them(a subset)
-        ([], optParams)        -> argumentsKeys `S.isSubsetOf` S.fromList (ppName <$> optParams)
-      -- If the function has required and optional parameters, the arguments keys have to match the required parameters
-      -- and can match any or none of the default parameters.
-        (reqParams, optParams) -> argumentsKeys `S.difference` S.fromList (ppName <$> optParams) == S.fromList (ppName <$> reqParams)

src/PostgREST/Request/DbRequestBuilder.hs

@@ -1,397 +0,0 @@
-{-|
-Module      : PostgREST.Request.DbRequestBuilder
-Description : PostgREST database request builder
-
-This module is in charge of building an intermediate
-representation(ReadRequest, MutateRequest) between the HTTP request and the
-final resulting SQL query.
-
-A query tree is built in case of resource embedding. By inferring the
-relationship between tables, join conditions are added for every embedded
-resource.
--}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE NamedFieldPuns        #-}
-{-# LANGUAGE RecordWildCards       #-}
-
-module PostgREST.Request.DbRequestBuilder
-  ( readRequest
-  , mutateRequest
-  , callRequest
-  ) where
-
-import qualified Data.HashMap.Strict as M
-import qualified Data.Set            as S
-
-import Control.Arrow           ((***))
-import Data.Either.Combinators (mapLeft)
-import Data.List               (delete)
-import Data.Text               (isInfixOf)
-import Data.Tree               (Tree (..))
-
-import PostgREST.DbStructure.Identifiers  (FieldName,
-                                           QualifiedIdentifier (..),
-                                           Schema, TableName)
-import PostgREST.DbStructure.Proc         (ProcDescription (..),
-                                           ProcParam (..),
-                                           procReturnsScalar)
-import PostgREST.DbStructure.Relationship (Cardinality (..),
-                                           Junction (..),
-                                           Relationship (..))
-import PostgREST.DbStructure.Table        (Column (..), Table (..),
-                                           tableQi)
-import PostgREST.Error                    (ApiRequestError (..),
-                                           Error (..))
-import PostgREST.Query.SqlFragment        (sourceCTEName)
-import PostgREST.RangeQuery               (NonnegRange, allRange,
-                                           restrictRange)
-import PostgREST.Request.ApiRequest       (Action (..),
-                                           ApiRequest (..),
-                                           Payload (..))
-
-import PostgREST.Request.Parsers
-import PostgREST.Request.Preferences
-import PostgREST.Request.Types
-
-import qualified PostgREST.DbStructure.Relationship as Relationship
-
-import Protolude hiding (from)
-
--- | Builds the ReadRequest tree on a number of stages.
--- | Adds filters, order, limits on its respective nodes.
--- | Adds joins conditions obtained from resource embedding.
-readRequest :: Schema -> TableName -> Maybe Integer -> [Relationship] -> ApiRequest -> Either Error ReadRequest
-readRequest schema rootTableName maxRows allRels apiRequest  =
-  mapLeft ApiRequestError $
-  treeRestrictRange maxRows =<<
-  augmentRequestWithJoin schema rootRels =<<
-  (addFiltersOrdersRanges apiRequest . initReadRequest rootName =<< pRequestSelect sel)
-  where
-    sel = fromMaybe "*" $ iSelect apiRequest -- default to all columns requested (SELECT *) for a non existent ?select querystring param
-    (rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest)
-
--- Get the root table name with its relationships according to the Action type.
--- This is done because of the shape of the final SQL Query. The mutation cases
--- are wrapped in a WITH {sourceCTEName}(see Statements.hs).  So we need a FROM
--- {sourceCTEName} instead of FROM {tableName}.
-rootWithRels :: Schema -> TableName -> [Relationship] -> Action -> (QualifiedIdentifier, [Relationship])
-rootWithRels schema rootTableName allRels action = case action of
-  ActionRead _ -> (QualifiedIdentifier schema rootTableName, allRels) -- normal read case
-  _            -> (QualifiedIdentifier mempty _sourceCTEName, mapMaybe toSourceRel allRels ++ allRels) -- mutation cases and calling proc
-  where
-    _sourceCTEName = decodeUtf8 sourceCTEName
-    -- To enable embedding in the sourceCTEName cases we need to replace the
-    -- foreign key tableName in the Relationship with {sourceCTEName}. This way
-    -- findRel can find relationships with sourceCTEName.
-    toSourceRel :: Relationship -> Maybe Relationship
-    toSourceRel r@Relationship{relTable=t}
-      | rootTableName == tableName t = Just $ r {relTable=t {tableName=_sourceCTEName}}
-      | otherwise                    = Nothing
-
--- Build the initial tree with a Depth attribute so when a self join occurs we
--- can differentiate the parent and child tables by having an alias like
--- "table_depth", this is related to
--- http://github.com/PostgREST/postgrest/issues/987.
-initReadRequest :: QualifiedIdentifier -> [Tree SelectItem] -> ReadRequest
-initReadRequest rootQi =
-  foldr (treeEntry rootDepth) initial
-  where
-    rootDepth = 0
-    rootSchema = qiSchema rootQi
-    rootName = qiName rootQi
-    initial = Node (Select [] rootQi Nothing [] [] [] [] allRange, (rootName, Nothing, Nothing, Nothing, Nothing, rootDepth)) []
-    treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest
-    treeEntry depth (Node fld@((fn, _),_,alias, hint, joinType) fldForest) (Node (q, i) rForest) =
-      let nxtDepth = succ depth in
-      case fldForest of
-        [] -> Node (q {select=fld:select q}, i) rForest
-        _  -> Node (q, i) $
-              foldr (treeEntry nxtDepth)
-              (Node (Select [] (QualifiedIdentifier rootSchema fn) Nothing [] [] [] [] allRange,
-                (fn, Nothing, alias, hint, joinType, nxtDepth)) [])
-              fldForest:rForest
-
--- | Enforces the `max-rows` config on the result
-treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
-treeRestrictRange maxRows request = pure $ nodeRestrictRange maxRows <$> request
-  where
-    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
-    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
-
-augmentRequestWithJoin :: Schema -> [Relationship] -> ReadRequest -> Either ApiRequestError ReadRequest
-augmentRequestWithJoin schema allRels request =
-  addRels schema allRels Nothing request
-  >>= addJoinConditions Nothing
-
-addRels :: Schema -> [Relationship] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
-addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, hint, joinType, depth)) forest) =
-  case parentNode of
-    Just (Node (Select{from=parentNodeQi}, _) _) ->
-      let newFrom r = if qiName tbl == nodeName then tableQi (relForeignTable r) else tbl
-          newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, hint, joinType, depth))) <$> rel
-          rel = findRel schema allRels (qiName parentNodeQi) nodeName hint
-      in
-      Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest)
-    _ ->
-      let rn = (query, (nodeName, Nothing, alias, Nothing, joinType, depth)) in
-      Node rn <$> updateForest (Just $ Node rn forest)
-  where
-    updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
-    updateForest rq = addRels schema allRels rq `traverse` forest
-
--- Finds a relationship between an origin and a target in the request:
--- /origin?select=target(*) If more than one relationship is found then the
--- request is ambiguous and we return an error.  In that case the request can
--- be disambiguated by adding precision to the target or by using a hint:
--- /origin?select=target!hint(*) The elements will be matched according to
--- these rules:
--- origin = table / view
--- target = table / view / constraint / column-from-origin
--- hint   = table / view / constraint / column-from-origin / column-from-target
--- (hint can take table / view values to aid in finding the junction in an m2m relationship)
-findRel :: Schema -> [Relationship] -> NodeName -> NodeName -> Maybe Hint -> Either ApiRequestError Relationship
-findRel schema allRels origin target hint =
-  case rel of
-    []  -> Left $ NoRelBetween origin target
-    [r] -> Right r
-    -- Here we handle a self reference relationship to not cause a breaking
-    -- change: In a self reference we get two relationships with the same
-    -- foreign key and relTable/relFtable but with different
-    -- cardinalities(m2o/o2m) We output the O2M rel, the M2O rel can be
-    -- obtained by using the origin column as an embed hint.
-    rs@[rel0, rel1]  -> case (relCardinality rel0, relCardinality rel1, relTable rel0 == relTable rel1 && relForeignTable rel0 == relForeignTable rel1) of
-      (O2M cons1, M2O cons2, True) -> if cons1 == cons2 then Right rel0 else Left $ AmbiguousRelBetween origin target rs
-      (M2O cons1, O2M cons2, True) -> if cons1 == cons2 then Right rel1 else Left $ AmbiguousRelBetween origin target rs
-      _                            -> Left $ AmbiguousRelBetween origin target rs
-    rs -> Left $ AmbiguousRelBetween origin target rs
-  where
-    matchFKSingleCol hint_ cols = length cols == 1 && hint_ == (colName <$> head cols)
-    matchConstraint tar card = case card of
-      O2M cons -> tar == Just cons
-      M2O cons -> tar == Just cons
-      _        -> False
-    matchJunction hint_ card = case card of
-      M2M Junction{junTable} -> hint_ == Just (tableName junTable)
-      _                      -> False
-    rel = filter (
-      \Relationship{..} ->
-        -- Both relationship ends need to be on the exposed schema
-        schema == tableSchema relTable && schema == tableSchema relForeignTable &&
-        (
-          -- /projects?select=clients(*)
-          origin == tableName relTable  &&  -- projects
-          target == tableName relForeignTable ||  -- clients
-
-          -- /projects?select=projects_client_id_fkey(*)
-          (
-            origin == tableName relTable &&              -- projects
-            matchConstraint (Just target) relCardinality -- projects_client_id_fkey
-          ) ||
-          -- /projects?select=client_id(*)
-          (
-            origin == tableName relTable &&           -- projects
-            matchFKSingleCol (Just target) relColumns -- client_id
-          )
-        ) && (
-          isNothing hint || -- hint is optional
-
-          -- /projects?select=clients!projects_client_id_fkey(*)
-          matchConstraint hint relCardinality || -- projects_client_id_fkey
-
-          -- /projects?select=clients!client_id(*) or /projects?select=clients!id(*)
-          matchFKSingleCol hint relColumns  || -- client_id
-          matchFKSingleCol hint relForeignColumns || -- id
-
-          -- /users?select=tasks!users_tasks(*) many-to-many between users and tasks
-          matchJunction hint relCardinality -- users_tasks
-        )
-      ) allRels
-
--- previousAlias is only used for the case of self joins
-addJoinConditions :: Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest
-addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, rel, _, _, _, depth)) forest) =
-  case rel of
-    Just r@Relationship{relCardinality=M2M Junction{junTable}} ->
-      let rq = augmentQuery r in
-      Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest
-    Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest
-    Nothing -> Node node <$> updatedForest
-  where
-    newAlias = case Relationship.isSelfReference <$> rel of
-      Just True
-        | depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased
-        | otherwise  -> Nothing
-      _              -> Nothing
-    augmentQuery r =
-      foldr
-        (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs})
-        query{fromAlias=newAlias}
-        (getJoinConditions previousAlias newAlias r)
-    updatedForest = addJoinConditions newAlias `traverse` forest
-
--- previousAlias and newAlias are used in the case of self joins
-getJoinConditions :: Maybe Alias -> Maybe Alias -> Relationship -> [JoinCondition]
-getJoinConditions previousAlias newAlias (Relationship Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols card) =
-  case card of
-    M2M (Junction Table{tableName=jtn} _ jc1 _ jc2) ->
-      zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2
-    _ ->
-      zipWith (toJoinCondition tN ftN) cols fCols
-  where
-    toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition
-    toJoinCondition tb ftb c fc =
-      let qi1 = removeSourceCTESchema tSchema tb
-          qi2 = removeSourceCTESchema tSchema ftb in
-        JoinCondition (maybe qi1 (QualifiedIdentifier mempty) previousAlias, colName c)
-                      (maybe qi2 (QualifiedIdentifier mempty) newAlias, colName fc)
-
-    -- On mutation and calling proc cases we wrap the target table in a WITH
-    -- {sourceCTEName} if this happens remove the schema `FROM
-    -- "schema"."{sourceCTEName}"` and use only the `FROM "{sourceCTEName}"`.
-    -- If the schema remains the FROM would be invalid.
-    removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
-    removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == decodeUtf8 sourceCTEName then mempty else schema) tbl
-
-addFiltersOrdersRanges :: ApiRequest -> ReadRequest -> Either ApiRequestError ReadRequest
-addFiltersOrdersRanges apiRequest rReq = do
-  rFlts <- foldr addFilter rReq <$> filters
-  rOrds <- foldr addOrder rFlts <$> orders
-  rRngs <- foldr addRange rOrds <$> ranges
-  foldr addLogicTree rRngs      <$> logicForest
-  where
-    filters :: Either ApiRequestError [(EmbedPath, Filter)]
-    filters = pRequestFilter `traverse` flts
-    orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]
-    orders = pRequestOrder `traverse` iOrder apiRequest
-    ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]
-    ranges = pRequestRange `traverse` M.toList (iRange apiRequest)
-    logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)]
-    logicForest = pRequestLogicTree `traverse` logFrst
-    action = iAction apiRequest
-    -- there can be no filters on the root table when we are doing insert/update/delete
-    (flts, logFrst) =
-      case action of
-        ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest)
-        ActionRead _   -> (iFilters apiRequest, iLogic apiRequest)
-        _              -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
-
-addFilterToNode :: Filter -> ReadRequest -> ReadRequest
-addFilterToNode flt (Node (q@Select {where_=lf}, i) f) = Node (q{where_=addFilterToLogicForest flt lf}::ReadQuery, i) f
-
-addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest
-addFilter = addProperty addFilterToNode
-
-addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest
-addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f
-
-addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest
-addOrder = addProperty addOrderToNode
-
-addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest
-addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f
-
-addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest
-addRange = addProperty addRangeToNode
-
-addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest
-addLogicTreeToNode t (Node (q@Select{where_=lf},i) f) = Node (q{where_=t:lf}::ReadQuery, i) f
-
-addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest
-addLogicTree = addProperty addLogicTreeToNode
-
-addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest
-addProperty f ([], a) rr = f a rr
-addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =
-  case pathNode of
-    Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path
-    Just tn -> Node rn (addProperty f (remainingPath, a) tn:delete tn forest)
-  where
-    pathNode = find (\(Node (_,(nodeName,_,alias,_,_, _)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest
-
-mutateRequest :: Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Error MutateRequest
-mutateRequest schema tName apiRequest pkCols readReq = mapLeft ApiRequestError $
-  case action of
-    ActionCreate -> do
-        confCols <- case iOnConflict apiRequest of
-            Nothing    -> pure pkCols
-            Just param -> pRequestOnConflict param
-        pure $ Insert qi (iColumns apiRequest) body ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
-    ActionUpdate -> Update qi (iColumns apiRequest) body  <$> combinedLogic <*> pure returnings
-    ActionSingleUpsert ->
-      (\flts ->
-        if null (iLogic apiRequest) &&
-           S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols &&
-           not (null (S.fromList pkCols)) &&
-           all (\case
-              Filter _ (OpExpr False (Op "eq" _)) -> True
-              _                                   -> False) flts
-          then Insert qi (iColumns apiRequest) body (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
-        else
-          Left InvalidFilters) =<< filters
-    ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings
-    _            -> Left UnsupportedVerb
-  where
-    qi = QualifiedIdentifier schema tName
-    action = iAction apiRequest
-    returnings =
-      if iPreferRepresentation apiRequest == None
-        then []
-        else returningCols readReq pkCols
-    filters = map snd <$> pRequestFilter `traverse` mutateFilters
-    logic = map snd <$> pRequestLogicTree `traverse` logicFilters
-    combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters
-    -- update/delete filters can be only on the root table
-    (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest)
-    onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
-    body = payRaw <$> iPayload apiRequest -- the body is assumed to be json at this stage(ApiRequest validates)
-
-callRequest :: ProcDescription -> ApiRequest -> ReadRequest -> CallRequest
-callRequest proc apiReq readReq = FunctionCall {
-  funCQi = QualifiedIdentifier (pdSchema proc) (pdName proc)
-, funCParams = callParams
-, funCArgs = payRaw <$> iPayload apiReq
-, funCScalar = procReturnsScalar proc
-, funCMultipleCall = iPreferParameters apiReq == Just MultipleObjects
-, funCReturning = returningCols readReq []
-}
-  where
-    paramsAsSingleObject = iPreferParameters apiReq == Just SingleObject
-    callParams = case pdParams proc of
-      [prm] | paramsAsSingleObject -> OnePosParam prm
-            | ppName prm == mempty -> OnePosParam prm
-            | otherwise            -> KeyParams $ specifiedParams [prm]
-      prms  -> KeyParams $ specifiedParams prms
-    specifiedParams params = filter (\x -> ppName x `S.member` iColumns apiReq) params
-
-returningCols :: ReadRequest -> [FieldName] -> [FieldName]
-returningCols rr@(Node _ forest) pkCols
-  -- if * is part of the select, we must not add pk or fk columns manually -
-  -- otherwise those would be selected and output twice
-  | "*" `elem` fldNames = ["*"]
-  | otherwise           = returnings
-  where
-    fldNames = fstFieldNames rr
-    -- Without fkCols, when a mutateRequest to
-    -- /projects?select=name,clients(name) occurs, the RETURNING SQL part would
-    -- be `RETURNING name`(see QueryBuilder).  This would make the embedding
-    -- fail because the following JOIN would need the "client_id" column from
-    -- projects.  So this adds the foreign key columns to ensure the embedding
-    -- succeeds, result would be `RETURNING name, client_id`.
-    fkCols = concat $ mapMaybe (\case
-        Node (_, (_, Just Relationship{relColumns=cols}, _, _, _, _)) _ -> Just cols
-        _                                                        -> Nothing
-      ) forest
-    -- However if the "client_id" is present, e.g. mutateRequest to
-    -- /projects?select=client_id,name,clients(name) we would get `RETURNING
-    -- client_id, name, client_id` and then we would produce the "column
-    -- reference \"client_id\" is ambiguous" error from PostgreSQL. So we
-    -- deduplicate with Set: We are adding the primary key columns as well to
-    -- make sure, that a proper location header can always be built for
-    -- INSERT/POST
-    returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols) ++ pkCols
-
--- Traditional filters(e.g. id=eq.1) are added as root nodes of the LogicTree
--- they are later concatenated with AND in the QueryBuilder
-addFilterToLogicForest :: Filter -> [LogicTree] -> [LogicTree]
-addFilterToLogicForest flt lf = Stmnt flt : lf

src/PostgREST/Request/Parsers.hs

@@ -1,294 +0,0 @@
-{-|
-Module      : PostgREST.Request.Parsers
-Description : PostgREST parser combinators
-
-This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.
--}
-module PostgREST.Request.Parsers
-  ( pColumns
-  , pLogicPath
-  , pLogicSingleVal
-  , pLogicTree
-  , pOrder
-  , pOrderTerm
-  , pRequestColumns
-  , pRequestFilter
-  , pRequestLogicTree
-  , pRequestOnConflict
-  , pRequestOrder
-  , pRequestRange
-  , pRequestSelect
-  , pSingleVal
-  , pTreePath
-  ) where
-
-import qualified Data.HashMap.Strict as M
-import qualified Data.Set            as S
-
-import Data.Either.Combinators       (mapLeft)
-import Data.Foldable                 (foldl1)
-import Data.List                     (init, last)
-import Data.Text                     (intercalate, replace, strip)
-import Data.Tree                     (Tree (..))
-import Text.Parsec.Error             (errorMessages,
-                                      showErrorMessages)
-import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,
-                                      anyChar, between, char, digit,
-                                      eof, errorPos, letter,
-                                      lookAhead, many1, noneOf,
-                                      notFollowedBy, oneOf, option,
-                                      optionMaybe, parse, sepBy1,
-                                      string, try, (<?>))
-
-import PostgREST.DbStructure.Identifiers (FieldName)
-import PostgREST.Error                   (ApiRequestError (ParseRequestError))
-import PostgREST.Query.SqlFragment       (ftsOperators, operators)
-import PostgREST.RangeQuery              (NonnegRange)
-
-import PostgREST.Request.Types
-
-import Protolude hiding (intercalate, option, replace, try)
-
-pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
-pRequestSelect selStr =
-  mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
-
-pRequestOnConflict :: Text -> Either ApiRequestError  [FieldName]
-pRequestOnConflict oncStr =
-  mapError $ parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr)
-
-pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter)
-pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
-  where
-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
-    oper = parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
-    path = fst <$> treePath
-    fld = snd <$> treePath
-
-pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm])
-pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
-  where
-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
-    path = fst <$> treePath
-    ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
-
-pRequestRange :: (Text, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange)
-pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
-  where
-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
-    path = fst <$> treePath
-
-pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree)
-pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
-  where
-    path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k
-    embedPath = fst <$> path
-    logicTree = do
-      op <- snd <$> path
-      -- Concat op and v to make pLogicTree argument regular,
-      -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
-      parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v)
-
-pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName))
-pRequestColumns colStr =
-  case colStr of
-    Just str ->
-      mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)
-    _ -> Right Nothing
-
-ws :: Parser Text
-ws = toS <$> many (oneOf " \t")
-
-lexeme :: Parser a -> Parser a
-lexeme p = ws *> p <* ws
-
-pTreePath :: Parser (EmbedPath, Field)
-pTreePath = do
-  p <- pFieldName `sepBy1` pDelimiter
-  jp <- option [] pJsonPath
-  return (init p, (last p, jp))
-
-pFieldForest :: Parser [Tree SelectItem]
-pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
-  where
-    pFieldTree :: Parser (Tree SelectItem)
-    pFieldTree =  try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|>
-                  Node <$> pFieldSelect <*> pure []
-
-pStar :: Parser Text
-pStar = string "*" $> "*"
-
-pFieldName :: Parser Text
-pFieldName =
-  pQuotedValue <|>
-  intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) <?>
-  "field name (* or [a..z0..9_])"
-  where
-    isDash :: GenParser Char st ()
-    isDash = try ( char '-' >> notFollowedBy (char '>') )
-    dash :: Parser Char
-    dash = isDash $> '-'
-
-pJsonPath :: Parser JsonPath
-pJsonPath = many pJsonOperation
-  where
-    pJsonOperation :: Parser JsonOperation
-    pJsonOperation = pJsonArrow <*> pJsonOperand
-
-    pJsonArrow   =
-      try (string "->>" $> J2Arrow) <|>
-      try (string "->" $> JArrow)
-
-    pJsonOperand =
-      let pJKey = JKey . toS <$> pFieldName
-          pJIdx = JIdx . toS <$> ((:) <$> option '+' (char '-') <*> many1 digit) <* pEnd
-          pEnd = try (void $ lookAhead (string "->")) <|>
-                 try (void $ lookAhead (string "::")) <|>
-                 try eof in
-      try pJIdx <|> try pJKey
-
-pField :: Parser Field
-pField = lexeme $ (,) <$> pFieldName <*> option [] pJsonPath
-
-aliasSeparator :: Parser ()
-aliasSeparator = char ':' >> notFollowedBy (char ':')
-
-pRelationSelect :: Parser SelectItem
-pRelationSelect = lexeme $ try ( do
-    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
-    fld <- pField
-    prm1 <- optionMaybe pEmbedParam
-    prm2 <- optionMaybe pEmbedParam
-    return (fld, Nothing, alias, embedParamHint prm1 <|> embedParamHint prm2, embedParamJoin prm1 <|> embedParamJoin prm2)
-  )
-  where
-    pEmbedParam :: Parser EmbedParam
-    pEmbedParam =
-      char '!' *> (
-        try (string "left"  $> EPJoinType JTLeft)  <|>
-        try (string "inner" $> EPJoinType JTInner) <|>
-        try (EPHint <$> pFieldName))
-    embedParamHint prm = case prm of
-      Just (EPHint hint) -> Just hint
-      _                  -> Nothing
-    embedParamJoin prm = case prm of
-      Just (EPJoinType jt) -> Just jt
-      _                    -> Nothing
-
-pFieldSelect :: Parser SelectItem
-pFieldSelect = lexeme $
-  try (
-    do
-      alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
-      fld <- pField
-      cast' <- optionMaybe (string "::" *> many letter)
-      return (fld, toS <$> cast', alias, Nothing, Nothing)
-  )
-  <|> do
-    s <- pStar
-    return ((s, []), Nothing, Nothing, Nothing, Nothing)
-
-pOpExpr :: Parser SingleVal -> Parser OpExpr
-pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation
-  where
-    pOperation :: Parser Operation
-    pOperation =
-          Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal
-      <|> In <$> (try (string "in" *> pDelimiter) *> pListVal)
-      <|> Is <$> (try (string "is" *> pDelimiter) *> pTriVal)
-      <|> pFts
-      <?> "operator (eq, gt, ...)"
-
-    pTriVal = try (string "null"    $> TriNull)
-          <|> try (string "unknown" $> TriUnknown)
-          <|> try (string "true"    $> TriTrue)
-          <|> try (string "false"   $> TriFalse)
-          <?> "null or trilean value (unknown, true, false)"
-
-    pFts = do
-      op   <- foldl1 (<|>) (try . string . toS <$> ftsOps)
-      lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_")))
-      pDelimiter >> Fts (toS op) (toS <$> lang) <$> pSVal
-
-    ops = M.filterWithKey (const . flip notElem ("in":"is":ftsOps)) operators
-    ftsOps = M.keys ftsOperators
-
-pSingleVal :: Parser SingleVal
-pSingleVal = toS <$> many anyChar
-
-pListVal :: Parser ListVal
-pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')
-
-pListElement :: Parser Text
-pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)"))
-
-pQuotedValue :: Parser Text
-pQuotedValue = toS <$> (char '"' *> many pCharsOrSlashed <* char '"')
-  where
-    pCharsOrSlashed = noneOf "\\\"" <|> (char '\\' *> anyChar)
-
-pDelimiter :: Parser Char
-pDelimiter = char '.' <?> "delimiter (.)"
-
-pOrder :: Parser [OrderTerm]
-pOrder = lexeme pOrderTerm `sepBy1` char ','
-
-pOrderTerm :: Parser OrderTerm
-pOrderTerm = do
-  fld <- pField
-  dir <- optionMaybe $
-         try (pDelimiter *> string "asc" $> OrderAsc) <|>
-         try (pDelimiter *> string "desc" $> OrderDesc)
-  nls <- optionMaybe pNulls <* pEnd <|>
-         pEnd $> Nothing
-  return $ OrderTerm fld dir nls
-  where
-    pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>
-             try (pDelimiter *> string "nullslast"  $> OrderNullsLast)
-    pEnd = try (void $ lookAhead (char ',')) <|>
-           try eof
-
-pLogicTree :: Parser LogicTree
-pLogicTree = Stmnt <$> try pLogicFilter
-             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')'))
-  where
-    pLogicFilter :: Parser Filter
-    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal
-    pNot :: Parser Bool
-    pNot = try (string "not" *> pDelimiter $> True)
-           <|> pure False
-           <?> "negation operator (not)"
-    pLogicOp :: Parser LogicOperator
-    pLogicOp = try (string "and" $> And)
-               <|> string "or" $> Or
-               <?> "logic operator (and, or)"
-
-pLogicSingleVal :: Parser SingleVal
-pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)"))
-  where
-    pPgArray :: Parser Text
-    pPgArray =  do
-      a <- string "{"
-      b <- many (noneOf "{}")
-      c <- string "}"
-      pure (toS $ a ++ b ++ c)
-
-pLogicPath :: Parser (EmbedPath, Text)
-pLogicPath = do
-  path <- pFieldName `sepBy1` pDelimiter
-  let op = last path
-      notOp = "not." <> op
-  return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)
-
-pColumns :: Parser [FieldName]
-pColumns = pFieldName `sepBy1` lexeme (char ',')
-
-mapError :: Either ParseError a -> Either ApiRequestError a
-mapError = mapLeft translateError
-  where
-    translateError e =
-      ParseRequestError message details
-      where
-        message = show $ errorPos e
-        details = strip $ replace "\n" " " $ toS
-           $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)

src/PostgREST/Request/Types.hs

@@ -1,232 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-module PostgREST.Request.Types
-  ( Alias
-  , Depth
-  , EmbedParam(..)
-  , EmbedPath
-  , Field
-  , Filter(..)
-  , Hint
-  , CallQuery(..)
-  , CallParams(..)
-  , CallRequest
-  , JoinCondition(..)
-  , JoinType(..)
-  , JsonOperand(..)
-  , JsonOperation(..)
-  , JsonPath
-  , ListVal
-  , LogicOperator(..)
-  , LogicTree(..)
-  , MutateQuery(..)
-  , MutateRequest
-  , NodeName
-  , OpExpr(..)
-  , Operation (..)
-  , OrderDirection(..)
-  , OrderNulls(..)
-  , OrderTerm(..)
-  , ReadNode
-  , ReadQuery(..)
-  , ReadRequest
-  , SelectItem
-  , SingleVal
-  , TrileanVal(..)
-  , fstFieldNames
-  ) where
-
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Set             as S
-
-import Data.Tree (Tree (..))
-
-import PostgREST.DbStructure.Identifiers  (FieldName,
-                                           QualifiedIdentifier)
-import PostgREST.DbStructure.Proc         (ProcParam (..))
-import PostgREST.DbStructure.Relationship (Relationship)
-import PostgREST.RangeQuery               (NonnegRange)
-import PostgREST.Request.Preferences      (PreferResolution)
-
-import Protolude
-
-
-type ReadRequest = Tree ReadNode
-type MutateRequest = MutateQuery
-type CallRequest = CallQuery
-
-type ReadNode =
-  (ReadQuery, (NodeName, Maybe Relationship, Maybe Alias, Maybe Hint, Maybe JoinType, Depth))
-
-type NodeName = Text
-type Depth = Integer
-
-data ReadQuery = Select
-  { select         :: [SelectItem]
-  , from           :: QualifiedIdentifier
-  -- ^ A table alias is used in case of self joins
-  , fromAlias      :: Maybe Alias
-  -- ^ Only used for Many to Many joins. Parent and Child joins use explicit joins.
-  , implicitJoins  :: [QualifiedIdentifier]
-  , where_         :: [LogicTree]
-  , joinConditions :: [JoinCondition]
-  , order          :: [OrderTerm]
-  , range_         :: NonnegRange
-  }
-  deriving (Eq)
-
-data JoinCondition =
-  JoinCondition
-    (QualifiedIdentifier, FieldName)
-    (QualifiedIdentifier, FieldName)
-  deriving (Eq)
-
-data OrderTerm = OrderTerm
-  { otTerm      :: Field
-  , otDirection :: Maybe OrderDirection
-  , otNullOrder :: Maybe OrderNulls
-  }
-  deriving (Eq)
-
-data OrderDirection
-  = OrderAsc
-  | OrderDesc
-  deriving (Eq)
-
-data OrderNulls
-  = OrderNullsFirst
-  | OrderNullsLast
-  deriving (Eq)
-
-data MutateQuery
-  = Insert
-      { in_        :: QualifiedIdentifier
-      , insCols    :: S.Set FieldName
-      , insBody    :: Maybe LBS.ByteString
-      , onConflict :: Maybe (PreferResolution, [FieldName])
-      , where_     :: [LogicTree]
-      , returning  :: [FieldName]
-      }
-  | Update
-      { in_       :: QualifiedIdentifier
-      , updCols   :: S.Set FieldName
-      , updBody   :: Maybe LBS.ByteString
-      , where_    :: [LogicTree]
-      , returning :: [FieldName]
-      }
-  | Delete
-      { in_       :: QualifiedIdentifier
-      , where_    :: [LogicTree]
-      , returning :: [FieldName]
-      }
-
-data CallQuery = FunctionCall
-  { funCQi           :: QualifiedIdentifier
-  , funCParams       :: CallParams
-  , funCArgs         :: Maybe LBS.ByteString
-  , funCScalar       :: Bool
-  , funCMultipleCall :: Bool
-  , funCReturning    :: [FieldName]
-  }
-
-data CallParams
-  = KeyParams [ProcParam] -- ^ Call with key params: func(a := val1, b:= val2)
-  | OnePosParam ProcParam -- ^ Call with positional params(only one supported): func(val)
-
--- | The select value in `/tbl?select=alias:field::cast`
-type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe Hint, Maybe JoinType)
-
-type Field = (FieldName, JsonPath)
-type Cast = Text
-type Alias = Text
-type Hint = Text
-
-data EmbedParam
-  -- | Disambiguates an embedding operation when there's multiple relationships
-  -- between two tables. Can be the name of a foreign key constraint, column
-  -- name or the junction in an m2m relationship.
-  = EPHint Hint
-  | EPJoinType JoinType
-
-data JoinType
-  = JTInner
-  | JTLeft
-  deriving Eq
-
--- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path
--- ["clients", "projects"]
-type EmbedPath = [Text]
-
--- | Json path operations as specified in
--- https://www.postgresql.org/docs/current/static/functions-json.html
-type JsonPath = [JsonOperation]
-
--- | Represents the single arrow `->` or double arrow `->>` operators
-data JsonOperation
-  = JArrow { jOp :: JsonOperand }
-  | J2Arrow { jOp :: JsonOperand }
-  deriving (Eq)
-
--- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text
--- because we reuse our escaping functons and let pg do the casting with
--- '1'::int
-data JsonOperand
-  = JKey { jVal :: Text }
-  | JIdx { jVal :: Text }
-  deriving (Eq)
-
--- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))
-fstFieldNames :: ReadRequest -> [FieldName]
-fstFieldNames (Node (sel, _) _) =
-  fst . (\(f, _, _, _, _) -> f) <$> select sel
-
-
--- | Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
---
---            And
---           /   \
---  name.eq.N     Or
---               /  \
---         id.eq.1   id.eq.2
-data LogicTree
-  = Expr Bool LogicOperator [LogicTree]
-  | Stmnt Filter
-  deriving (Eq)
-
-data LogicOperator
-  = And
-  | Or
-  deriving Eq
-
-data Filter = Filter
-  { field  :: Field
-  , opExpr :: OpExpr
-  }
-  deriving (Eq)
-
-data OpExpr =
-  OpExpr Bool Operation
-  deriving (Eq)
-
-data Operation
-  = Op Operator SingleVal
-  | In ListVal
-  | Is TrileanVal
-  | Fts Operator (Maybe Language) SingleVal
-  deriving (Eq)
-
-type Operator = Text
-type Language = Text
-
--- | Represents a single value in a filter, e.g. id=eq.singleval
-type SingleVal = Text
-
--- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)
-type ListVal = [Text]
-
--- | Three-valued logic values
-data TrileanVal
-  = TriTrue
-  | TriFalse
-  | TriNull
-  | TriUnknown
-  deriving Eq

src/PostgREST/Response.hs

@@ -0,0 +1,300 @@
+{- |
+   Module      : PostgREST.Response
+   Description : Generate HTTP Response
+-}
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.Response
+  ( createResponse
+  , deleteResponse
+  , infoIdentResponse
+  , infoProcResponse
+  , infoRootResponse
+  , invokeResponse
+  , openApiResponse
+  , readResponse
+  , singleUpsertResponse
+  , updateResponse
+  , PgrstResponse(..)
+  ) where
+
+import qualified Data.Aeson                as JSON
+import qualified Data.ByteString.Char8     as BS
+import qualified Data.ByteString.Lazy      as LBS
+import qualified Data.HashMap.Strict       as HM
+import           Data.Maybe                (fromJust)
+import           Data.Text.Read            (decimal)
+import qualified Network.HTTP.Types.Header as HTTP
+import qualified Network.HTTP.Types.Status as HTTP
+import qualified Network.HTTP.Types.URI    as HTTP
+
+import qualified PostgREST.Error            as Error
+import qualified PostgREST.MediaType        as MediaType
+import qualified PostgREST.RangeQuery       as RangeQuery
+import qualified PostgREST.Response.OpenAPI as OpenAPI
+
+import PostgREST.ApiRequest              (ApiRequest (..),
+                                          InvokeMethod (..))
+import PostgREST.ApiRequest.Preferences  (PreferRepresentation (..),
+                                          PreferResolution (..),
+                                          Preferences (..),
+                                          prefAppliedHeader,
+                                          shouldCount)
+import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
+import PostgREST.Config                  (AppConfig (..))
+import PostgREST.MediaType               (MediaType (..))
+import PostgREST.Plan                    (CallReadPlan (..),
+                                          MutateReadPlan (..),
+                                          WrappedReadPlan (..))
+import PostgREST.Plan.MutatePlan         (MutatePlan (..))
+import PostgREST.Query.Statements        (ResultSet (..))
+import PostgREST.Response.GucHeader      (GucHeader, unwrapGucHeader)
+import PostgREST.SchemaCache             (SchemaCache (..))
+import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..),
+                                          Schema)
+import PostgREST.SchemaCache.Routine     (FuncVolatility (..),
+                                          Routine (..), RoutineMap)
+import PostgREST.SchemaCache.Table       (Table (..), TablesMap)
+
+import qualified PostgREST.ApiRequest.Types    as ApiRequestTypes
+import qualified PostgREST.SchemaCache.Routine as Routine
+
+import Protolude      hiding (Handler, toS)
+import Protolude.Conv (toS)
+
+data PgrstResponse = PgrstResponse {
+  pgrstStatus  :: HTTP.Status
+, pgrstHeaders :: [HTTP.Header]
+, pgrstBody    :: LBS.ByteString
+}
+
+readResponse :: WrappedReadPlan -> Bool -> QualifiedIdentifier -> ApiRequest -> ResultSet -> Either Error.Error PgrstResponse
+readResponse WrappedReadPlan{wrMedia} headersOnly identifier ctxApiRequest@ApiRequest{iPreferences=Preferences{..},..} resultSet =
+  case resultSet of
+    RSStandard{..} -> do
+      let
+        (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
+        prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing Nothing Nothing preferCount preferTransaction Nothing preferHandling preferTimezone []
+        headers =
+          [ contentRange
+          , ( "Content-Location"
+            , "/"
+                <> toUtf8 (qiName identifier)
+                <> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams
+            )
+          ]
+          ++ contentTypeHeaders wrMedia ctxApiRequest
+          ++ prefHeader
+
+      (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers
+
+      let bod | status == HTTP.status416 = Error.errorPayload $ Error.ApiRequestError $ ApiRequestTypes.InvalidRange $
+                                           ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
+              | headersOnly              = mempty
+              | otherwise                = LBS.fromStrict rsBody
+
+      Right $ PgrstResponse ovStatus ovHeaders bod
+
+    RSPlan plan ->
+      Right $ PgrstResponse HTTP.status200 (contentTypeHeaders wrMedia ctxApiRequest) $ LBS.fromStrict plan
+
+createResponse :: QualifiedIdentifier -> MutateReadPlan -> ApiRequest -> ResultSet -> Either Error.Error PgrstResponse
+createResponse QualifiedIdentifier{..} MutateReadPlan{mrMutatePlan, mrMedia} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}, ..} resultSet = case resultSet of
+  RSStandard{..} -> do
+    let
+      pkCols = case mrMutatePlan of { Insert{insPkCols} -> insPkCols; _ -> mempty;}
+      prefHeader = prefAppliedHeader $
+        Preferences (if null pkCols && isNothing (qsOnConflict iQueryParams) then Nothing else preferResolution)
+        preferRepresentation Nothing preferCount preferTransaction preferMissing preferHandling preferTimezone []
+      headers =
+        catMaybes
+          [ if null rsLocation then
+              Nothing
+            else
+              Just
+                ( HTTP.hLocation
+                , "/"
+                    <> toUtf8 qiName
+                    <> HTTP.renderSimpleQuery True rsLocation
+                )
+          , Just . RangeQuery.contentRangeH 1 0 $
+              if shouldCount preferCount then Just rsQueryTotal else Nothing
+          , prefHeader ]
+
+    let isInsertIfGTZero i =
+          if i <= 0 && preferResolution == Just MergeDuplicates then
+            HTTP.status200
+          else
+            HTTP.status201
+        status = maybe HTTP.status200 isInsertIfGTZero rsInserted
+        (headers', bod) = case preferRepresentation of
+          Just Full -> (headers ++ contentTypeHeaders mrMedia ctxApiRequest, LBS.fromStrict rsBody)
+          Just None -> (headers, mempty)
+          Just HeadersOnly -> (headers, mempty)
+          Nothing -> (headers, mempty)
+
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
+
+    Right $ PgrstResponse ovStatus ovHeaders bod
+  RSPlan plan ->
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
+
+updateResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Either Error.Error PgrstResponse
+updateResponse MutateReadPlan{mrMedia} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
+  RSStandard{..} -> do
+    let
+      contentRangeHeader =
+        Just . RangeQuery.contentRangeH 0 (rsQueryTotal - 1) $
+          if shouldCount preferCount then Just rsQueryTotal else Nothing
+      prefHeader = prefAppliedHeader $ Preferences Nothing preferRepresentation Nothing preferCount preferTransaction preferMissing preferHandling preferTimezone []
+      headers = catMaybes [contentRangeHeader, prefHeader]
+
+    let (status, headers', body) =
+          case preferRepresentation of
+            Just Full -> (HTTP.status200, headers ++ contentTypeHeaders mrMedia ctxApiRequest, LBS.fromStrict rsBody)
+            Just None -> (HTTP.status204, headers, mempty)
+            _         -> (HTTP.status204, headers, mempty)
+
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
+
+    Right $ PgrstResponse ovStatus ovHeaders body
+
+  RSPlan plan ->
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
+
+singleUpsertResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Either Error.Error PgrstResponse
+singleUpsertResponse MutateReadPlan{mrMedia} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
+  RSStandard {..} -> do
+    let
+      prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing preferRepresentation Nothing preferCount preferTransaction Nothing preferHandling preferTimezone []
+      cTHeader = contentTypeHeaders mrMedia ctxApiRequest
+
+    let isInsertIfGTZero i = if i > 0 then HTTP.status201 else HTTP.status200
+        upsertStatus       = isInsertIfGTZero $ fromJust rsInserted
+        (status, headers, body) =
+          case preferRepresentation of
+            Just Full -> (upsertStatus, cTHeader ++ prefHeader, LBS.fromStrict rsBody)
+            Just None -> (HTTP.status204,  prefHeader, mempty)
+            _ -> (HTTP.status204, prefHeader, mempty)
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers
+
+    Right $ PgrstResponse ovStatus ovHeaders body
+
+  RSPlan plan ->
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
+
+deleteResponse :: MutateReadPlan -> ApiRequest -> ResultSet -> Either Error.Error PgrstResponse
+deleteResponse MutateReadPlan{mrMedia} ctxApiRequest@ApiRequest{iPreferences=Preferences{..}} resultSet = case resultSet of
+  RSStandard {..} -> do
+    let
+      contentRangeHeader =
+        RangeQuery.contentRangeH 1 0 $
+          if shouldCount preferCount then Just rsQueryTotal else Nothing
+      prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing preferRepresentation Nothing preferCount preferTransaction Nothing preferHandling preferTimezone []
+      headers = contentRangeHeader : prefHeader
+
+    let (status, headers', body) =
+          case preferRepresentation of
+              Just Full -> (HTTP.status200, headers ++ contentTypeHeaders mrMedia ctxApiRequest, LBS.fromStrict rsBody)
+              Just None -> (HTTP.status204, headers, mempty)
+              _ -> (HTTP.status204, headers, mempty)
+
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status headers'
+
+    Right $ PgrstResponse ovStatus ovHeaders body
+
+  RSPlan plan ->
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders mrMedia ctxApiRequest) $ LBS.fromStrict plan
+
+infoIdentResponse :: QualifiedIdentifier -> SchemaCache -> Either Error.Error PgrstResponse
+infoIdentResponse identifier sCache = do
+  case HM.lookup identifier (dbTables sCache) of
+    Just tbl -> respondInfo $ allowH tbl
+    Nothing  -> Left $ Error.ApiRequestError ApiRequestTypes.NotFound
+  where
+    allowH table =
+      let hasPK = not . null $ tablePKCols table in
+      BS.intercalate "," $
+          ["OPTIONS,GET,HEAD"] ++
+          ["POST" | tableInsertable table] ++
+          ["PUT" | tableInsertable table && tableUpdatable table && hasPK] ++
+          ["PATCH" | tableUpdatable table] ++
+          ["DELETE" | tableDeletable table]
+
+infoProcResponse :: Routine -> Either Error.Error PgrstResponse
+infoProcResponse proc | pdVolatility proc == Volatile = respondInfo "OPTIONS,POST"
+                      | otherwise                     = respondInfo "OPTIONS,GET,HEAD,POST"
+
+infoRootResponse :: Either Error.Error PgrstResponse
+infoRootResponse = respondInfo "OPTIONS,GET,HEAD"
+
+respondInfo :: ByteString -> Either Error.Error PgrstResponse
+respondInfo allowHeader =
+  let allOrigins = ("Access-Control-Allow-Origin", "*") in
+  Right $ PgrstResponse HTTP.status200 [allOrigins, (HTTP.hAllow, allowHeader)] mempty
+
+invokeResponse :: CallReadPlan -> InvokeMethod -> Routine -> ApiRequest -> ResultSet -> Either Error.Error PgrstResponse
+invokeResponse CallReadPlan{crMedia} invMethod proc ctxApiRequest@ApiRequest{iPreferences=Preferences{..},..} resultSet = case resultSet of
+  RSStandard {..} -> do
+    let
+      (status, contentRange) =
+        RangeQuery.rangeStatusHeader iTopLevelRange rsQueryTotal rsTableTotal
+      rsOrErrBody = if status == HTTP.status416
+        then Error.errorPayload $ Error.ApiRequestError $ ApiRequestTypes.InvalidRange
+          $ ApiRequestTypes.OutOfBounds (show $ RangeQuery.rangeOffset iTopLevelRange) (maybe "0" show rsTableTotal)
+        else LBS.fromStrict rsBody
+      prefHeader = maybeToList . prefAppliedHeader $ Preferences Nothing Nothing preferParameters preferCount preferTransaction Nothing preferHandling preferTimezone []
+      headers = contentRange : prefHeader
+
+    let (status', headers', body) =
+          if Routine.funcReturnsVoid proc then
+              (HTTP.status204, headers, mempty)
+            else
+              (status,
+                headers ++ contentTypeHeaders crMedia ctxApiRequest,
+                if invMethod == InvHead then mempty else rsOrErrBody)
+
+    (ovStatus, ovHeaders) <- overrideStatusHeaders rsGucStatus rsGucHeaders status' headers'
+
+    Right $ PgrstResponse ovStatus ovHeaders body
+
+  RSPlan plan ->
+    Right $ PgrstResponse HTTP.status200 (contentTypeHeaders crMedia ctxApiRequest) $ LBS.fromStrict plan
+
+openApiResponse :: (Text, Text) -> Bool -> Maybe (TablesMap, RoutineMap, Maybe Text) -> AppConfig -> SchemaCache -> Schema -> Bool -> Either Error.Error PgrstResponse
+openApiResponse versions headersOnly body conf sCache schema negotiatedByProfile =
+  Right $ PgrstResponse HTTP.status200
+    (MediaType.toContentType MTOpenAPI : maybeToList (profileHeader schema negotiatedByProfile))
+    (maybe mempty (\(x, y, z) -> if headersOnly then mempty else OpenAPI.encode versions conf sCache x y z) body)
+
+-- Status and headers can be overridden as per https://postgrest.org/en/stable/references/transactions.html#response-headers
+overrideStatusHeaders :: Maybe Text -> Maybe BS.ByteString -> HTTP.Status -> [HTTP.Header]-> Either Error.Error (HTTP.Status, [HTTP.Header])
+overrideStatusHeaders rsGucStatus rsGucHeaders pgrstStatus pgrstHeaders = do
+  gucStatus <- decodeGucStatus rsGucStatus
+  gucHeaders <- decodeGucHeaders rsGucHeaders
+  Right (fromMaybe pgrstStatus gucStatus, addHeadersIfNotIncluded pgrstHeaders $ map unwrapGucHeader gucHeaders)
+
+decodeGucHeaders :: Maybe BS.ByteString -> Either Error.Error [GucHeader]
+decodeGucHeaders =
+  maybe (Right []) $ first (const . Error.ApiRequestError $ ApiRequestTypes.GucHeadersError) . JSON.eitherDecode . LBS.fromStrict
+
+decodeGucStatus :: Maybe Text -> Either Error.Error (Maybe HTTP.Status)
+decodeGucStatus =
+  maybe (Right Nothing) $ first (const . Error.ApiRequestError $ ApiRequestTypes.GucStatusError) . fmap (Just . toEnum . fst) . decimal
+
+contentTypeHeaders :: MediaType -> ApiRequest -> [HTTP.Header]
+contentTypeHeaders mediaType ApiRequest{..} =
+  MediaType.toContentType mediaType : maybeToList (profileHeader iSchema iNegotiatedByProfile)
+
+profileHeader :: Schema -> Bool -> Maybe HTTP.Header
+profileHeader schema negotiatedByProfile =
+  if negotiatedByProfile
+    then Just $ (,) "Content-Profile" (toS schema)
+  else
+    Nothing
+
+-- | Add headers not already included to allow the user to override them instead of duplicating them
+addHeadersIfNotIncluded :: [HTTP.Header] -> [HTTP.Header] -> [HTTP.Header]
+addHeadersIfNotIncluded newHeaders initialHeaders =
+  filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
+  initialHeaders

src/PostgREST/Response/GucHeader.hs

@@ -1,12 +1,12 @@
-module PostgREST.GucHeader
+module PostgREST.Response.GucHeader
   ( GucHeader
   , unwrapGucHeader
-  , addHeadersIfNotIncluded
   ) where
 
 import qualified Data.Aeson           as JSON
+import qualified Data.Aeson.Key       as K
+import qualified Data.Aeson.KeyMap    as KM
 import qualified Data.CaseInsensitive as CI
-import qualified Data.HashMap.Strict  as M
 
 import Network.HTTP.Types.Header (Header)
 
@@ -21,16 +21,10 @@ newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
 
 instance JSON.FromJSON GucHeader where
   parseJSON (JSON.Object o) =
-    case M.toList o of
-      [(k, JSON.String s)] -> pure $ GucHeader (CI.mk $ toUtf8 k, toUtf8 s)
+    case KM.toList o of
+      [(k, JSON.String s)] -> pure $ GucHeader (CI.mk $ toUtf8 $ K.toText k, toUtf8 s)
       _ -> mzero
   parseJSON _ = mzero
 
 unwrapGucHeader :: GucHeader -> Header
 unwrapGucHeader (GucHeader (k, v)) = (k, v)
-
--- | Add headers not already included to allow the user to override them instead of duplicating them
-addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
-addHeadersIfNotIncluded newHeaders initialHeaders =
-  filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
-  initialHeaders

src/PostgREST/Response/OpenAPI.hs

@@ -3,17 +3,15 @@ Module      : PostgREST.OpenAPI
 Description : Generates the OpenAPI output
 -}
 {-# LANGUAGE LambdaCase      #-}
-{-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
-module PostgREST.OpenAPI (encode) where
+module PostgREST.Response.OpenAPI (encode) where
 
 import qualified Data.Aeson            as JSON
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy  as LBS
-import qualified Data.HashMap.Strict   as M
+import qualified Data.HashMap.Strict   as HM
 import qualified Data.HashSet.InsOrd   as Set
 import qualified Data.Text             as T
-import qualified Data.Text.Encoding    as T
 
 import Control.Arrow              ((&&&))
 import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
@@ -27,86 +25,105 @@ import Data.Swagger
 
 import PostgREST.Config                   (AppConfig (..), Proxy (..),
                                            isMalformedProxyUri, toURI)
-import PostgREST.DbStructure              (DbStructure (..),
-                                           tableCols, tablePKCols)
-import PostgREST.DbStructure.Proc         (ProcDescription (..),
-                                           ProcParam (..))
-import PostgREST.DbStructure.Relationship (Cardinality (..),
-                                           PrimaryKey (..),
-                                           Relationship (..))
-import PostgREST.DbStructure.Table        (Column (..), Table (..))
-import PostgREST.Version                  (docsVersion, prettyVersion)
+import PostgREST.SchemaCache              (SchemaCache (..))
+import PostgREST.SchemaCache.Identifiers  (QualifiedIdentifier (..))
+import PostgREST.SchemaCache.Relationship (Cardinality (..),
+                                           Relationship (..),
+                                           RelationshipsMap)
+import PostgREST.SchemaCache.Routine      (Routine (..),
+                                           RoutineParam (..))
+import PostgREST.SchemaCache.Table        (Column (..), Table (..),
+                                           TablesMap,
+                                           tableColumnsList)
 
-import PostgREST.ContentType
+import PostgREST.MediaType
 
 import Protolude hiding (Proxy, get)
 
-encode :: AppConfig -> DbStructure -> [Table] -> M.HashMap k [ProcDescription] -> Maybe Text -> LBS.ByteString
-encode conf dbStructure tables procs schemaDescription =
+encode :: (Text, Text) -> AppConfig -> SchemaCache -> TablesMap -> HM.HashMap k [Routine] -> Maybe Text -> LBS.ByteString
+encode versions conf sCache tables procs schemaDescription =
   JSON.encode $
     postgrestSpec
-      (dbRelationships dbStructure)
-      (concat $ M.elems procs)
-      (openApiTableInfo dbStructure <$> tables)
+      versions
+      (dbRelationships sCache)
+      (concat $ HM.elems procs)
+      (snd <$> HM.toList tables)
       (proxyUri conf)
       schemaDescription
-      (dbPrimaryKeys dbStructure)
+      (configOpenApiSecurityActive conf)
 
-makeMimeList :: [ContentType] -> MimeList
+makeMimeList :: [MediaType] -> MimeList
 makeMimeList cs = MimeList $ fmap (fromString . BS.unpack . toMime) cs
 
-toSwaggerType :: Text -> SwaggerType t
-toSwaggerType "character varying" = SwaggerString
-toSwaggerType "character"         = SwaggerString
-toSwaggerType "text"              = SwaggerString
-toSwaggerType "boolean"           = SwaggerBoolean
-toSwaggerType "smallint"          = SwaggerInteger
-toSwaggerType "integer"           = SwaggerInteger
-toSwaggerType "bigint"            = SwaggerInteger
-toSwaggerType "numeric"           = SwaggerNumber
-toSwaggerType "real"              = SwaggerNumber
-toSwaggerType "double precision"  = SwaggerNumber
-toSwaggerType "ARRAY"             = SwaggerArray
-toSwaggerType _                   = SwaggerString
+toSwaggerType :: Text -> Maybe (SwaggerType t)
+toSwaggerType "character varying" = Just SwaggerString
+toSwaggerType "character"         = Just SwaggerString
+toSwaggerType "text"              = Just SwaggerString
+toSwaggerType "boolean"           = Just SwaggerBoolean
+toSwaggerType "smallint"          = Just SwaggerInteger
+toSwaggerType "integer"           = Just SwaggerInteger
+toSwaggerType "bigint"            = Just SwaggerInteger
+toSwaggerType "numeric"           = Just SwaggerNumber
+toSwaggerType "real"              = Just SwaggerNumber
+toSwaggerType "double precision"  = Just SwaggerNumber
+toSwaggerType "json"              = Nothing
+toSwaggerType "jsonb"             = Nothing
+toSwaggerType colType             = case T.takeEnd 2 colType of
+  "[]" -> Just SwaggerArray
+  _    -> Just SwaggerString
+
+typeFromArray :: Text -> Text
+typeFromArray = T.dropEnd 2
+
+toSwaggerTypeFromArray :: Text -> Maybe (SwaggerType t)
+toSwaggerTypeFromArray arrType = toSwaggerType $ typeFromArray arrType
+
+makePropertyItems :: Text -> Maybe (Referenced Schema)
+makePropertyItems arrType = case toSwaggerType arrType of
+  Just SwaggerArray -> Just $ Inline (mempty & type_ .~ toSwaggerTypeFromArray arrType)
+  _                 -> Nothing
 
 parseDefault :: Text -> Text -> Text
 parseDefault colType colDefault =
   case toSwaggerType colType of
-    SwaggerString -> wrapInQuotations $ case T.stripSuffix ("::" <> colType) colDefault of
+    Just SwaggerString -> wrapInQuotations $ case T.stripSuffix ("::" <> colType) colDefault of
       Just def -> T.dropAround (=='\'')  def
       Nothing  -> colDefault
     _ -> colDefault
   where
     wrapInQuotations text = "\"" <> text <> "\""
 
-makeTableDef :: [Relationship] -> [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)
-makeTableDef rels pks (t, cs, _) =
+makeTableDef :: RelationshipsMap -> Table -> (Text, Schema)
+makeTableDef rels t =
   let tn = tableName t in
       (tn, (mempty :: Schema)
         & description .~ tableDescription t
         & type_ ?~ SwaggerObject
-        & properties .~ fromList (fmap (makeProperty rels pks) cs)
-        & required .~ fmap colName (filter (not . colNullable) cs))
+        & properties .~ fromList (makeProperty t rels <$> tableColumnsList t)
+        & required .~ fmap colName (filter (not . colNullable) $ tableColumnsList t))
 
-makeProperty :: [Relationship] -> [PrimaryKey] -> Column -> (Text, Referenced Schema)
-makeProperty rels pks c = (colName c, Inline s)
+makeProperty :: Table -> RelationshipsMap -> Column -> (Text, Referenced Schema)
+makeProperty tbl rels col = (colName col, Inline s)
   where
-    e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c
+    e = if null $ colEnum col then Nothing else JSON.decode $ JSON.encode $ colEnum col
     fk :: Maybe Text
     fk =
       let
+        searchedRels = fromMaybe mempty $ HM.lookup (QualifiedIdentifier (tableSchema tbl) (tableName tbl), tableSchema tbl) rels
+        -- Sorts the relationship list to get tables first
+        relsSortedByIsView = sortOn relFTableIsView [ r | r@Relationship{} <- searchedRels]
         -- Finds the relationship that has a single column foreign key
         rel = find (\case
-          Relationship{relColumns, relCardinality=M2O _} -> [c] == relColumns
-          _                                                 -> False
-          ) rels
-        fCol = colName <$> (headMay . relForeignColumns =<< rel)
-        fTbl = tableName . relForeignTable <$> rel
+          Relationship{relCardinality=(M2O _ relColumns)} -> [colName col] == (fst <$> relColumns)
+          _                                               -> False
+          ) relsSortedByIsView
+        fCol = (headMay . (\r -> snd <$> relColumns (relCardinality r)) =<< rel)
+        fTbl = qiName . relForeignTable <$> rel
         fTblCol = (,) <$> fTbl <*> fCol
       in
         (\(a, b) -> T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]) <$> fTblCol
     pk :: Bool
-    pk = any (\p -> pkTable p == colTable c && pkName p == colName c) pks
+    pk = colName col `elem` tablePKCols tbl
     n = catMaybes
       [ Just "Note:"
       , if pk then Just "This is a Primary Key.<pk/>" else Nothing
@@ -114,19 +131,20 @@ makeProperty rels pks c = (colName c, Inline s)
       ]
     d =
       if length n > 1 then
-        Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription c) (T.intercalate "\n" n)
+        Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription col) (T.intercalate "\n" n)
       else
-        colDescription c
+        colDescription col
     s =
       (mempty :: Schema)
-        & default_ .~ (JSON.decode . toUtf8Lazy . parseDefault (colType c) =<< colDefault c)
+        & default_ .~ (JSON.decode . toUtf8Lazy . parseDefault (colType col) =<< colDefault col)
         & description .~ d
         & enum_ .~ e
-        & format ?~ colType c
-        & maxLength .~ (fromIntegral <$> colMaxLen c)
-        & type_ ?~ toSwaggerType (colType c)
+        & format ?~ colType col
+        & maxLength .~ (fromIntegral <$> colMaxLen col)
+        & type_ .~ toSwaggerType (colType col)
+        & items .~ (SwaggerItemsObject <$> makePropertyItems (colType col))
 
-makeProcSchema :: ProcDescription -> Schema
+makeProcSchema :: Routine -> Schema
 makeProcSchema pd =
   (mempty :: Schema)
   & description .~ pdDescription pd
@@ -134,11 +152,12 @@ makeProcSchema pd =
   & properties .~ fromList (fmap makeProcProperty (pdParams pd))
   & required .~ fmap ppName (filter ppReq (pdParams pd))
 
-makeProcProperty :: ProcParam -> (Text, Referenced Schema)
-makeProcProperty (ProcParam n t _ _) = (n, Inline s)
+makeProcProperty :: RoutineParam -> (Text, Referenced Schema)
+makeProcProperty (RoutineParam n t _ _ _) = (n, Inline s)
   where
     s = (mempty :: Schema)
-          & type_ ?~ toSwaggerType t
+          & type_ .~ toSwaggerType t
+          & items .~ (SwaggerItemsObject <$> makePropertyItems t)
           & format ?~ t
 
 makePreferParam :: [Text] -> Param
@@ -150,10 +169,47 @@ makePreferParam ts =
   & schema .~ ParamOther ((mempty :: ParamOtherSchema)
     & in_ .~ ParamHeader
     & type_ ?~ SwaggerString
-    & enum_ .~ JSON.decode (JSON.encode ts))
+    & enum_ .~ JSON.decode (JSON.encode $ foldl (<>) [] (val <$> ts)))
+  where
+    val :: Text -> [Text]
+    val = \case
+      "count"      -> ["count=none"]
+      "params"     -> ["params=single-object"]
+      "return"     -> ["return=representation", "return=minimal", "return=none"]
+      "resolution" -> ["resolution=ignore-duplicates", "resolution=merge-duplicates"]
+      _            -> []
 
-makeProcParam :: ProcDescription -> [Referenced Param]
-makeProcParam pd =
+makeProcGetParam :: RoutineParam -> Referenced Param
+makeProcGetParam (RoutineParam n t _ r v) =
+  Inline $ (mempty :: Param)
+    & name .~ n
+    & required ?~ r
+    & schema .~ ParamOther fullSchema
+  where
+    fullSchema = if v then schemaMulti else schemaNotMulti
+    baseSchema = (mempty :: ParamOtherSchema)
+      & in_ .~ ParamQuery
+    schemaNotMulti = baseSchema
+      & format ?~ t
+      & type_ ?~ toParamType (toSwaggerType t)
+    schemaMulti = baseSchema
+      & type_ ?~ fromMaybe SwaggerString (toSwaggerType t)
+      & items ?~ SwaggerItemsPrimitive (Just CollectionMulti)
+        ((mempty :: ParamSchema x)
+          & type_ .~ toSwaggerTypeFromArray t
+          & format ?~ typeFromArray t)
+    toParamType paramType = case paramType of
+      -- Array uses {} in query params
+      Just SwaggerArray -> SwaggerString
+      -- Type must be specified in query params
+      Nothing           -> SwaggerString
+      _                 -> fromJust paramType
+
+makeProcGetParams :: [RoutineParam] -> [Referenced Param]
+makeProcGetParams = fmap makeProcGetParam
+
+makeProcPostParams :: Routine -> [Referenced Param]
+makeProcPostParams pd =
   [ Inline $ (mempty :: Param)
     & name     .~ "args"
     & required ?~ True
@@ -161,11 +217,13 @@ makeProcParam pd =
   , Ref $ Reference "preferParams"
   ]
 
-makeParamDefs :: [(Table, [Column], [Text])] -> [(Text, Param)]
+makeParamDefs :: [Table] -> [(Text, Param)]
 makeParamDefs ti =
-  [ ("preferParams", makePreferParam ["params=single-object"])
-  , ("preferReturn", makePreferParam ["return=representation", "return=minimal", "return=none"])
-  , ("preferCount", makePreferParam ["count=none"])
+  -- TODO: create Prefer for each method (GET, PATCH, etc.)
+  [ ("preferParams", makePreferParam ["params"])
+  , ("preferReturn", makePreferParam ["return"])
+  , ("preferCount", makePreferParam ["count"])
+  , ("preferPost", makePreferParam ["return", "resolution"])
   , ("select", (mempty :: Param)
       & name        .~ "select"
       & description ?~ "Filtering Columns"
@@ -217,8 +275,8 @@ makeParamDefs ti =
         & in_ .~ ParamQuery
         & type_ ?~ SwaggerString))
   ]
-  <> concat [ makeObjectBody (tableName t) : makeRowFilters (tableName t) cs
-            | (t, cs, _) <- ti
+  <> concat [ makeObjectBody (tableName t) : makeRowFilters (tableName t) (tableColumnsList t)
+            | t <- ti
             ]
 
 makeObjectBody :: Text -> (Text, Param)
@@ -243,8 +301,8 @@ makeRowFilter tn c =
 makeRowFilters :: Text -> [Column] -> [(Text, Param)]
 makeRowFilters tn = fmap (makeRowFilter tn)
 
-makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
-makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable t)
+makePathItem :: Table -> (FilePath, PathItem)
+makePathItem t = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable t)
   where
     -- Use first line of table description as summary; rest as description (if present)
     -- We strip leading newlines from description so that users can include a blank line between summary and description
@@ -265,7 +323,7 @@ makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpd
         )
       )
     postOp = tOp
-      & parameters .~ fmap ref ["body." <> tn, "select", "preferReturn"]
+      & parameters .~ fmap ref ["body." <> tn, "select", "preferPost"]
       & at 201 ?~ "Created"
     patchOp = tOp
       & parameters .~ fmap ref (rs <> ["body." <> tn, "preferReturn"])
@@ -278,24 +336,29 @@ makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpd
     p False = pr
     p True  = pw
     tn = tableName t
-    rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]
+    rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- tableColumnsList t ]
     ref = Ref . Reference
 
-makeProcPathItem :: ProcDescription -> (FilePath, PathItem)
+makeProcPathItem :: Routine -> (FilePath, PathItem)
 makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
   where
     -- Use first line of proc description as summary; rest as description (if present)
     -- We strip leading newlines from description so that users can include a blank line between summary and description
     (pSum, pDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
                     T.breakOn "\n" <$> pdDescription pd
-    postOp = (mempty :: Operation)
+    procOp = (mempty :: Operation)
       & summary .~ pSum
       & description .~ mfilter (/="") pDesc
-      & parameters .~ makeProcParam pd
       & tags .~ Set.fromList ["(rpc) " <> pdName pd]
-      & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON]
+      & produces ?~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False]
       & at 200 ?~ "OK"
-    pe = (mempty :: PathItem) & post ?~ postOp
+    getOp = procOp
+      & parameters .~ makeProcGetParams (pdParams pd)
+    postOp = procOp
+      & parameters .~ makeProcPostParams pd
+    pe = (mempty :: PathItem)
+      & get ?~ getOp
+      & post ?~ postOp
 
 makeRootPathItem :: (FilePath, PathItem)
 makeRootPathItem = ("/", p)
@@ -303,15 +366,23 @@ makeRootPathItem = ("/", p)
     getOp = (mempty :: Operation)
       & tags .~ Set.fromList ["Introspection"]
       & summary ?~ "OpenAPI description (this document)"
-      & produces ?~ makeMimeList [CTOpenAPI, CTApplicationJSON]
+      & produces ?~ makeMimeList [MTOpenAPI, MTApplicationJSON]
       & at 200 ?~ "OK"
     pr = (mempty :: PathItem) & get ?~ getOp
     p = pr
 
-makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
+makePathItems :: [Routine] -> [Table] -> InsOrdHashMap FilePath PathItem
 makePathItems pds ti = fromList $ makeRootPathItem :
   fmap makePathItem ti ++ fmap makeProcPathItem pds
 
+makeSecurityDefinitions :: Text -> Bool -> SecurityDefinitions
+makeSecurityDefinitions secName allow
+  | allow = SecurityDefinitions (fromList [(secName, SecurityScheme secSchType secSchDescription)])
+  | otherwise    = mempty
+  where
+    secSchType = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader)
+    secSchDescription = Just "Add the token prepending \"Bearer \" (without quotes) to it"
+
 escapeHostName :: Text -> Text
 escapeHostName "*"  = "0.0.0.0"
 escapeHostName "*4" = "0.0.0.0"
@@ -320,27 +391,31 @@ escapeHostName "*6" = "0.0.0.0"
 escapeHostName "!6" = "0.0.0.0"
 escapeHostName h    = h
 
-postgrestSpec :: [Relationship] -> [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
-postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
+postgrestSpec :: (Text, Text) -> RelationshipsMap -> [Routine] -> [Table] -> (Text, Text, Integer, Text) -> Maybe Text -> Bool -> Swagger
+postgrestSpec (prettyVersion, docsVersion) rels pds ti (s, h, p, b) sd allowSecurityDef = (mempty :: Swagger)
   & basePath ?~ T.unpack b
   & schemes ?~ [s']
   & info .~ ((mempty :: Info)
-      & version .~ T.decodeUtf8 prettyVersion
-      & title .~ "PostgREST API"
-      & description ?~ d)
+      & version .~ prettyVersion
+      & title .~ fromMaybe "PostgREST API" dTitle
+      & description ?~ fromMaybe "This is a dynamic API generated by PostgREST" dDesc)
   & externalDocs ?~ ((mempty :: ExternalDocs)
     & description ?~ "PostgREST Documentation"
     & url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))
   & host .~ h'
-  & definitions .~ fromList (makeTableDef rels pks <$> ti)
+  & definitions .~ fromList (makeTableDef rels <$> ti)
   & parameters .~ fromList (makeParamDefs ti)
   & paths .~ makePathItems pds ti
-  & produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-  & consumes .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
+  & produces .~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False, MTTextCSV]
+  & consumes .~ makeMimeList [MTApplicationJSON, MTVndSingularJSON True, MTVndSingularJSON False, MTTextCSV]
+  & securityDefinitions .~ makeSecurityDefinitions securityDefName allowSecurityDef
+  & security .~ [SecurityRequirement (fromList [(securityDefName, [])]) | allowSecurityDef]
     where
       s' = if s == "http" then Http else Https
       h' = Just $ Host (T.unpack $ escapeHostName h) (Just (fromInteger p))
-      d = fromMaybe "This is a dynamic API generated by PostgREST" sd
+      securityDefName = "JWT"
+      (dTitle, dDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
+                    T.breakOn "\n" <$> sd
 
 pickProxy :: Maybe Text -> Maybe Proxy
 pickProxy proxy
@@ -378,10 +453,3 @@ proxyUri AppConfig{..} =
       (proxyScheme, proxyHost, proxyPort, proxyPath)
     Nothing ->
       ("http", configServerHost, toInteger configServerPort, "/")
-
-openApiTableInfo :: DbStructure -> Table -> (Table, [Column], [Text])
-openApiTableInfo dbStructure table =
-  ( table
-  , tableCols dbStructure (tableSchema table) (tableName table)
-  , tablePKCols dbStructure (tableSchema table) (tableName table)
-  )

src/PostgREST/Response/Performance.hs

@@ -0,0 +1,36 @@
+module PostgREST.Response.Performance
+  ( ServerTiming (..)
+  , serverTimingHeader
+  )
+where
+import qualified Data.ByteString.Char8 as BS
+import qualified Network.HTTP.Types    as HTTP
+import           Numeric               (showFFloat)
+import           Protolude
+
+data ServerTiming =
+  ServerTiming
+    { jwt         :: Maybe Double
+    , parse       :: Maybe Double
+    , plan        :: Maybe Double
+    , transaction :: Maybe Double
+    , response    :: Maybe Double
+    }
+  deriving (Show)
+
+-- | Render the Server-Timing header from a ServerTimingData
+--
+-- >>> serverTimingHeader ServerTiming { plan=Just 0.1, transaction=Just 0.2, response=Just 0.3, jwt=Just 0.4, parse=Just 0.5}
+-- ("Server-Timing","jwt;dur=400000.0, parse;dur=500000.0, plan;dur=100000.0, transaction;dur=200000.0, response;dur=300000.0")
+serverTimingHeader :: ServerTiming -> HTTP.Header
+serverTimingHeader timing =
+  ("Server-Timing", renderTiming)
+  where
+    renderMetric metric = maybe "" (\dur -> BS.concat [metric, BS.pack $ ";dur=" <> showFFloat (Just 1) (dur * 1000000) ""])
+    renderTiming = BS.intercalate ", " $ (\(k, v) -> renderMetric k (v timing)) <$>
+      [ ("jwt", jwt)
+      , ("parse", parse)
+      , ("plan", plan)
+      , ("transaction", transaction)
+      , ("response", response)
+      ]

src/PostgREST/SchemaCache/Identifiers.hs

@@ -1,20 +1,27 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
 
-module PostgREST.DbStructure.Identifiers
+module PostgREST.SchemaCache.Identifiers
   ( QualifiedIdentifier(..)
+  , RelIdentifier(..)
+  , isAnyElement
   , Schema
   , TableName
   , FieldName
+  , AccessSet
   , dumpQi
   , toQi
   ) where
 
 import qualified Data.Aeson as JSON
+import qualified Data.Set   as S
 import qualified Data.Text  as T
 
 import Protolude
 
+data RelIdentifier = RelId QualifiedIdentifier | RelAnyElement
+  deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
+instance Hashable RelIdentifier
 
 -- | Represents a pg identifier with a prepended schema name "schema.table".
 -- When qiSchema is "", the schema is defined by the pg search_path.
@@ -22,10 +29,13 @@ data QualifiedIdentifier = QualifiedIdentifier
   { qiSchema :: Schema
   , qiName   :: TableName
   }
-  deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
+  deriving (Eq, Show, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
 
 instance Hashable QualifiedIdentifier
 
+isAnyElement :: QualifiedIdentifier -> Bool
+isAnyElement y = QualifiedIdentifier "pg_catalog" "anyelement" == y
+
 dumpQi :: QualifiedIdentifier -> Text
 dumpQi (QualifiedIdentifier s i) =
   (if T.null s then mempty else s <> ".") <> i
@@ -40,3 +50,5 @@ toQi txt = case T.drop 1 <$> T.breakOn "." txt of
 type Schema = Text
 type TableName = Text
 type FieldName = Text
+
+type AccessSet = S.Set QualifiedIdentifier