Bump to v9 (#2045)

* Reorganize the CHANGELOG
* Add missing change for dropping support for embedding hints used with '.'
* Move the pg 14 compatibility entry to Added

.cirrus.yml

@@ -0,0 +1,15 @@
+freebsd_instance:
+  image_family: freebsd-13-0
+
+build_task:
+  name: Build FreeBSD (Stack)
+  install_script: pkg install -y postgresql13-client hs-stack
+
+  stack_cache:
+    folders: /.stack
+    fingerprint_script: cat postgrest.cabal stack.yaml.lock
+    reupload_on_changes: false
+
+  build_script: stack build -j 1 --local-bin-path . --copy-bins
+  bin_artifacts:
+    path: postgrest

.github/CONTRIBUTING.md

@@ -15,14 +15,14 @@ your contributions.
 
 ## Issues
 
+For questions on how to use PostgREST, please use
+[GitHub discussions](https://github.com/PostgREST/postgrest/discussions).
+
 ### Reporting an Issue
 
-* Make sure you test against the latest released version. It is possible
-  we already fixed the bug you're experiencing.
-
-* Also check the `CHANGELOG.md` to see if any unreleased changes affect
-  the issue. The very newest changes can take a little while to be released
-  as a new official version.
+* Make sure you test against the latest [stable release](https://github.com/PostgREST/postgrest/releases/latest)
+  and also against the latest [nightly release](https://github.com/PostgREST/postgrest/releases/tag/nightly).
+  It is possible we already fixed the bug you're experiencing.
 
 * Provide steps to reproduce the issue, including your OS version and
   the specific database schema that you are using.
@@ -32,38 +32,24 @@ your contributions.
   then [find your logs](http://blog.endpoint.com/2014/11/dear-postgresql-where-are-my-logs.html).
 
 * If your database schema has changed while the PostgREST server is running,
-  send the server a `SIGHUP` signal or restart it to ensure the schema cache
+  [send the server a `SIGUSR1` signal](http://postgrest.org/en/latest/admin.html#schema-reloading) or restart it to ensure the schema cache
   is not stale. This sometimes fixes apparent bugs.
 
 ## Code
 
+We have a fully nix-based development environment with many tools for a smooth development workflow available.
+Check the [development docs](https://github.com/PostgREST/postgrest/blob/main/nix/README.md) on how to set it up and use it.
+
 ### Haskell Conventions
 
 * All contributions must pass the tests before being merged. When
   you create a pull request your code will automatically be tested.
 
-* All code must also pass [hlint](http://community.haskell.org/~ndm/hlint/)
-  with no warnings. This helps enforce a uniform style for all
-  committers. Continuous integration will check this as well on every
-  pull request.
+* All code must also pass [hlint](http://community.haskell.org/~ndm/hlint/) and [stylish-haskell](https://github.com/jaspervdj/stylish-haskell)
+  with no warnings. This helps enforce a uniform style for all committers. Continuous integration will check this as well on every
+  pull request. There are useful tools in the nix-shell that help with checking this locally. You can run `postgrest-check` to do this manually but
+  we recommend adding it to `.git/hooks/pre-commit` as `nix-shell --run postgrest-check` to automatically check this before doing a commit.
 
-* For help building the Haskell code on your computer check out the [building from
-source](https://postgrest.com/en/stable/install.html#build-from-source)
-wiki page.
+### Running Tests
 
-## Maintenance
-
-### Schedule
-
-Currently I (@begriffs) am the sole maintainer, and while I am
-overjoyed to help resolve issues I also have to balance this with
-my other obligations.  If you don't get a response right away
-don't worry, I will definitely get to it. Also you can join the
-Gitter [chat room](https://gitter.im/begriffs/postgrest) to
-discuss issues you are having.
-
-## Running Tests
-
-For instructions on running tests, see the official docs hosted here:
-
-https://postgrest.com/en/stable/install.html#postgrest-test-suite
+For instructions on running tests, see the [development docs](https://github.com/PostgREST/postgrest/blob/main/nix/README.md#testing).

.github/FUNDING.yml

@@ -0,0 +1,3 @@
+# These are supported funding model platforms
+
+patreon: postgrest

.github/ISSUE_TEMPLATE.md

@@ -0,0 +1,17 @@
+<!--
+Before reporting a bug:
+If your database schema has changed while the PostgREST server is running,
+send the server a SIGUSR1 signal or restart it(http://postgrest.org/en/stable/admin.html#schema-reloading)
+to ensure the schema cache is not stale. This sometimes fixes apparent bugs.
+-->
+### Environment
+
+* PostgreSQL version: (if using docker, specify the image)
+* PostgREST version: (if using docker, specify the image)
+* Operating system:
+
+### Description of issue
+
+(Expected behavior vs actual behavior)
+
+(Steps to reproduce: Include a minimal SQL definition plus how you make the request to PostgREST and the response body)

.github/PULL_REQUEST_TEMPLATE.md

@@ -0,0 +1,6 @@
+<!--
+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
+-->

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

@@ -0,0 +1,21 @@
+name: Setup Nix
+
+description: Installs nix, sets up cachix and installs a subset of tooling.
+
+inputs:
+  authToken:
+    description: Token to pass to cachix
+  tools:
+    description: Tools to install with nix-env -iA <tools>
+
+runs:
+  using: composite
+  steps:
+    - uses: cachix/install-nix-action@v16
+    - uses: cachix/cachix-action@v10
+      with:
+        name: postgrest
+        authToken: ${{ inputs.authToken }}
+    - if: ${{ inputs.tools }}
+      run: nix-env -f default.nix -iA ${{ inputs.tools }}
+      shell: bash

.github/codecov.yml

@@ -0,0 +1,18 @@
+codecov:
+  branch: main
+  require_ci_to_pass: false
+
+comment: false
+
+coverage:
+  status:
+    project:
+      default:
+        target: auto
+        threshold: 1%
+        only_pulls: false
+    patch:
+      default:
+        target: auto
+        threshold: 1%
+        only_pulls: true

.github/dependabot.yml

@@ -0,0 +1,6 @@
+version: 2
+updates:
+- package-ecosystem: github-actions
+  directory: /
+  schedule:
+    interval: weekly

.github/get_cirrusci_freebsd

@@ -0,0 +1,56 @@
+#!/usr/bin/env bash
+set -euo pipefail
+
+# Get the FreeBSD PostgREST executable built by CirrusCI for the given GITHUB_COMMIT in GITHUB_REPOSITORY
+
+# We use the GitHub API for 'check suites' to find the corresponding CirrusCI job, see:
+# https://docs.github.com/en/rest/reference/checks#list-check-suites-for-a-git-reference
+
+cirrus_artifact_name=bin
+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" \
+    | jq -r '.check_suites[] | select(.app.slug == "cirrus-ci") | .check_runs_url'
+}
+
+wait_for_cirrusci() {
+  gh_check_runs_url="$(get_gh_check_runs_url)"
+  >&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')
+    if [ "$status" == "completed" ]; then
+      break
+    else
+      echo "CirrusCI task is still $status, waiting..."
+      sleep 60
+    fi
+  done
+}
+
+# The CirrusCI taskid can change if a new check run is started for the same commit,
+# e.g. when pushing both a branch and tag. We make sure that we have the very
+# latest taskid by re-loading the 'gh_check_runs_url' and the 'check run' itself.
+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" \
+    | jq -r '.check_runs[] | .external_id'
+}
+
+download_artifact() {
+  cirrus_task_id="$(get_cirrus_taskid)"
+  cirrus_artifact_url="https://api.cirrus-ci.com/v1/artifact/task/$cirrus_task_id/$cirrus_artifact_name.zip"
+  >&2 echo "Attemping to download the CirrusCI artifact from $cirrus_artifact_url ..."
+  curl --fail "$cirrus_artifact_url" -o freebsd.zip
+}
+
+wait_for_cirrusci
+download_artifact
+
+echo "Unpacking executable..."
+unzip freebsd.zip -d .
+rm -rf freebsd.zip

.github/release

@@ -0,0 +1,12 @@
+#!/usr/bin/env bash
+
+# Tag a release that will be built with Github Actions. The version is
+# read from 'postgrest.cabal'.
+
+version="$(grep -oP '^version:\s*\K.*' postgrest.cabal)"
+
+echo "Tagging version v$version"
+git tag -f "v$version"
+
+echo "Pushing tag..."
+git push -f origin "refs/tags/v$version"

.github/workflows/ci.yaml

@@ -0,0 +1,373 @@
+name: CI
+
+on:
+  push:
+    branches:
+      - main
+    tags:
+      - v*
+  pull_request:
+    branches:
+      - main
+
+jobs:
+  Lint-Style:
+    name: Lint & check code style
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2.4.0
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          tools: style
+      - 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`)
+        run: postgrest-style-check
+
+
+  Test-Nix:
+    name: Test (Nix)
+    runs-on: ubuntu-latest
+    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
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          tools: tests withTools
+
+      - name: Run coverage (IO tests and Spec tests against PostgreSQL 14)
+        run: postgrest-coverage
+      - name: Upload coverage to codecov
+        uses: codecov/codecov-action@v2.1.0
+        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
+
+      - name: Check the spec tests for idempotence
+        if: always()
+        run: postgrest-test-spec-idempotence
+
+
+  Test-Memory-Nix:
+    name: Test memory (Nix)
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2.4.0
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          tools: memory
+      - name: Run memory tests
+        run: postgrest-test-memory
+
+
+  Build-Nix:
+    name: Build Linux static (Nix)
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2.4.0
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}'
+
+      - name: Build static executable
+        run: nix-build -A postgrestStatic
+      - name: Save built executable as artifact
+        uses: actions/upload-artifact@v2.2.4
+        with:
+          name: postgrest-linux-static-x64
+          path: result/bin/postgrest
+          if-no-files-found: error
+
+      - 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
+        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' }}
+        run: |
+          nix-build
+          nix-env -f default.nix -iA devTools
+          postgrest-push-cachix
+
+
+  Build-Stack:
+    strategy:
+      fail-fast: false
+      matrix:
+        include:
+          - name: Linux & test
+            runs-on: ubuntu-latest
+            cache: |
+              ~/.stack
+              .stack-work
+            test: true
+            pgdir: /usr/lib/postgresql
+            artifact: postgrest-ubuntu-x64
+
+          - name: MacOS & test
+            runs-on: macos-latest
+            cache: |
+              ~/.stack
+              .stack-work
+            test: true
+            pgdir: /usr/local/Cellar/postgresql
+            artifact: postgrest-macos-x64
+
+          - name: Windows
+            runs-on: windows-latest
+            cache: |
+              ~\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
+            artifact: postgrest-windows-x64
+
+    name: Build ${{ matrix.name }} (Stack)
+    runs-on: ${{ matrix.runs-on }}
+    steps:
+      - uses: actions/checkout@v2.4.0
+      - name: Stack working files cache
+        uses: actions/cache@v2.1.7
+        with:
+          path: ${{ matrix.cache }}
+          key: ${{ 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
+        with:
+          name: ${{ matrix.artifact }}
+          path: |
+            result/postgrest
+            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
+      - 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}}
+        run: .github/get_cirrusci_freebsd
+      - name: Save executable as artifact
+        uses: actions/upload-artifact@v2.2.4
+        with:
+          name: postgrest-freebsd-x64
+          path: postgrest
+          if-no-files-found: error
+
+
+  Prepare-Release:
+    name: Prepare release
+    if: startsWith(github.ref, 'refs/tags/v')
+    runs-on: ubuntu-latest
+    needs:
+      - Lint-Style
+      - Test-Nix
+      - Test-Memory-Nix
+      - Build-Nix
+      - Build-Stack
+      - Get-FreeBSD-CirrusCI
+    outputs:
+      version: ${{ steps.Identify-Version.outputs.version }}
+      isprerelease: ${{ steps.Identify-Version.outputs.isprerelease }}
+    steps:
+      - uses: actions/checkout@v2.4.0
+      - id: Identify-Version
+        name: Identify the version to be released
+        run: |
+          tag_version="${GITHUB_REF##*/}"
+          cabal_version="$(grep -oP '^version:\s*\K.*' postgrest.cabal)"
+
+          if [ "$tag_version" != "v$cabal_version" ]; then
+            echo "Tagged version ($tag_version) does not match the one in postgrest.cabal (v$cabal_version). Aborting release..."
+            exit 1
+          else
+            echo "Version to be released is $cabal_version"
+            echo "::set-output name=version::$cabal_version"
+          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"
+          fi
+      - name: Identify changes from CHANGELOG.md
+        run: |
+          version="${{ steps.Identify-Version.outputs.version }}"
+          isprerelease="${{ steps.Identify-Version.outputs.isprerelease }}"
+
+          if [ -n "$isprerelease" ]; then
+            echo "Getting unreleased changes..."
+            sed -n "1,/## Unreleased/d;/## \[/q;p" CHANGELOG.md > CHANGES.md
+          else
+            echo "Full release (no '-' in version), getting changes for version $version ..."
+            sed -n "1,/## \[$version\]/d;/## \[/q;p" CHANGELOG.md > CHANGES.md
+          fi
+
+          echo "Relevant extract from CHANGELOG.md:"
+          cat CHANGES.md
+      - name: Save CHANGES.md as artifact
+        uses: actions/upload-artifact@v2.2.4
+        with:
+          name: release-changes
+          path: CHANGES.md
+          if-no-files-found: error
+
+
+  Release-GitHub:
+    name: Release on GitHub
+    permissions:
+      contents: write
+    runs-on: ubuntu-latest
+    needs: Prepare-Release
+    env:
+      VERSION: ${{ needs.Prepare-Release.outputs.version }}
+    steps:
+      - uses: actions/checkout@v2.4.0
+      - name: Download all artifacts
+        uses: actions/download-artifact@v2.0.10
+        with:
+          path: artifacts
+      - name: Create release bundle with archives for all builds
+        run: |
+          find artifacts -type f -iname postgrest -exec chmod +x {} \;
+
+          mkdir -p release-bundle
+
+          tar cJvf "release-bundle/postgrest-v$VERSION-linux-static-x64.tar.xz" \
+            -C artifacts/postgrest-linux-static-x64 postgrest
+
+          # No need to release Ubuntu, as the static Linux binary built with Nix
+          # covers all Linux use-cases
+          #tar cfJv "release-bundle/postgrest-v$VERSION-ubuntu-x64.tar.xz" \
+          #  -C artifacts/postgrest-ubuntu-x64 postgrest
+
+          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
+
+          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
+        with:
+          name: release-bundle
+          path: release-bundle
+          if-no-files-found: error
+
+      - name: Publish release on GitHub
+        env:
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+        run: |
+          isprerelease="${{ needs.Prepare-Release.outputs.isprerelease }}"
+          echo "Releasing version v$VERSION on GitHub (isprerelease=$isprerelease)..."
+
+          gh release delete "v$VERSION" || true
+          gh release create "v$VERSION" \
+            -F artifacts/release-changes/CHANGES.md \
+            ${isprerelease:+"--prerelease"} \
+            release-bundle/*
+
+
+  Release-Docker:
+    name: Release on Docker Hub
+    runs-on: ubuntu-latest
+    needs: Prepare-Release
+    env:
+      DOCKER_REPO: postgrest
+      DOCKER_USER: stevechavez
+      VERSION: ${{ needs.Prepare-Release.outputs.version }}
+      ISPRERELEASE: ${{ needs.Prepare-Release.outputs.isprerelease }}
+    steps:
+      - uses: actions/checkout@v2.4.0
+      - name: Setup Nix Environment
+        uses: ./.github/actions/setup-nix
+        with:
+          tools: release
+      - name: Download Docker image
+        uses: actions/download-artifact@v2.0.10
+        with:
+          name: postgrest-docker-x64
+      - name: Publish images on Docker Hub
+        run: |
+          docker login -u "$DOCKER_USER" -p "${{ secrets.DOCKER_PASS }}"
+          docker load -i postgrest-docker.tar.gz
+
+          docker tag postgrest:latest "$DOCKER_REPO/postgrest:v$VERSION"
+          docker push "$DOCKER_REPO/postgrest:v$VERSION"
+
+          # Only tag 'latest' for full releases
+          if [[ -z "$ISPRERELEASE" ]]; then
+            echo "Pushing to 'latest' tag for full release of v$VERSION ..."
+            docker tag postgrest:latest "$DOCKER_REPO"/postgrest:latest
+            docker push "$DOCKER_REPO"/postgrest:latest
+          else
+            echo "Skipping pushing to 'latest' tag for v$VERSION pre-release..."
+          fi
+      - 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

.github/workflows/report.yaml

@@ -0,0 +1,33 @@
+name: Upload Reports
+
+on:
+  workflow_run:
+    workflows: ["Loadtest"]
+    types:
+      - completed
+
+jobs:
+  upload:
+    name: Loadtest
+    permissions:
+      checks: write
+    runs-on: ubuntu-latest
+    if: ${{ github.event.workflow_run.conclusion == 'success' }}
+    steps:
+      - name: Download from Artifacts
+        uses: dawidd6/action-download-artifact@v2
+        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
+        with:
+          token: ${{ secrets.GITHUB_TOKEN }}
+          sha: ${{ github.event.workflow_run.head_sha }}
+          name: Loadtest Results
+          conclusion: neutral
+          output: |
+            {"summary":""}
+          output_text_description_file: artifacts/loadtest.md

.gitignore

@@ -12,3 +12,12 @@ site
 *~
 *#*
 .#*
+*.swp
+result*
+dist-newstyle
+postgrest.hp
+postgrest.prof
+__pycache__
+*.tix
+coverage
+.hpc

.stylish-haskell.yaml

@@ -0,0 +1,225 @@
+# stylish-haskell configuration file
+# ==================================
+
+# The stylish-haskell tool is mainly configured by specifying steps. These steps
+# are a list, so they have an order, and one specific step may appear more than
+# once (if needed). Each file is processed by these steps in the given order.
+steps:
+  # Convert some ASCII sequences to their Unicode equivalents. This is disabled
+  # by default.
+  # - unicode_syntax:
+  #     # In order to make this work, we also need to insert the UnicodeSyntax
+  #     # language pragma. If this flag is set to true, we insert it when it's
+  #     # not already present. You may want to disable it if you configure
+  #     # language extensions using some other method than pragmas. Default:
+  #     # true.
+  #     add_language_pragma: true
+
+  # Align the right hand side of some elements.  This is quite conservative
+  # and only applies to statements where each element occupies a single
+  # line.
+  - simple_align:
+      cases: true
+      top_level_patterns: true
+      records: true
+
+  # Import cleanup
+  - imports:
+      # There are different ways we can align names and lists.
+      #
+      # - global: Align the import names and import list throughout the entire
+      #   file.
+      #
+      # - file: Like global, but don't add padding when there are no qualified
+      #   imports in the file.
+      #
+      # - group: Only align the imports per group (a group is formed by adjacent
+      #   import lines).
+      #
+      # - none: Do not perform any alignment.
+      #
+      # Default: global.
+      align: group
+
+      # The following options affect only import list alignment.
+      #
+      # List align has following options:
+      #
+      # - after_alias: Import list is aligned with end of import including
+      #   'as' and 'hiding' keywords.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                          init, last, length)
+      #
+      # - with_alias: Import list is aligned with start of alias or hiding.
+      #
+      #   > import qualified Data.List      as List (concat, foldl, foldr, head,
+      #   >                                 init, last, length)
+      #
+      # - new_line: Import list starts always on new line.
+      #
+      #   > import qualified Data.List      as List
+      #   >     (concat, foldl, foldr, head, init, last, length)
+      #
+      # Default: after_alias
+      list_align: after_alias
+
+      # Right-pad the module names to align imports in a group:
+      #
+      # - true: a little more readable
+      #
+      #   > import qualified Data.List       as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # - false: diff-safe
+      #
+      #   > import qualified Data.List as List (concat, foldl, foldr, init,
+      #   >                                     last, length)
+      #   > import qualified Data.List.Extra as List (concat, foldl, foldr,
+      #   >                                           init, last, length)
+      #
+      # Default: true
+      pad_module_names: true
+
+      # Long list align style takes effect when import is too long. This is
+      # determined by 'columns' setting.
+      #
+      # - inline: This option will put as much specs on same line as possible.
+      #
+      # - new_line: Import list will start on new line.
+      #
+      # - new_line_multiline: Import list will start on new line when it's
+      #   short enough to fit to single line. Otherwise it'll be multiline.
+      #
+      # - multiline: One line per import list entry.
+      #   Type with constructor list acts like single import.
+      #
+      #   > import qualified Data.Map as M
+      #   >     ( empty
+      #   >     , singleton
+      #   >     , ...
+      #   >     , delete
+      #   >     )
+      #
+      # Default: inline
+      long_list_align: inline
+
+      # Align empty list (importing instances)
+      #
+      # Empty list align has following options
+      #
+      # - inherit: inherit list_align setting
+      #
+      # - right_after: () is right after the module name:
+      #
+      #   > import Vector.Instances ()
+      #
+      # Default: inherit
+      empty_list_align: inherit
+
+      # List padding determines indentation of import list on lines after import.
+      # This option affects 'long_list_align'.
+      #
+      # - <integer>: constant value
+      #
+      # - module_name: align under start of module name.
+      #   Useful for 'file' and 'group' align settings.
+      list_padding: 4
+
+      # Separate lists option affects formatting of import list for type
+      # or class. The only difference is single space between type and list
+      # of constructors, selectors and class functions.
+      #
+      # - true: There is single space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable (fold, foldl, foldMap))
+      #
+      # - false: There is no space between Foldable type and list of it's
+      #   functions.
+      #
+      #   > import Data.Foldable (Foldable(fold, foldl, foldMap))
+      #
+      # Default: true
+      separate_lists: true
+
+      # Space surround option affects formatting of import lists on a single
+      # line. The only difference is single space after the initial
+      # parenthesis and a single space before the terminal parenthesis.
+      #
+      # - true: There is single space associated with the enclosing
+      #   parenthesis.
+      #
+      #   > import Data.Foo ( foo )
+      #
+      # - false: There is no space associated with the enclosing parenthesis
+      #
+      #   > import Data.Foo (foo)
+      #
+      # Default: false
+      space_surround: false
+
+  # Language pragmas
+  - language_pragmas:
+      # We can generate different styles of language pragma lists.
+      #
+      # - vertical: Vertical-spaced language pragmas, one per line.
+      #
+      # - compact: A more compact style.
+      #
+      # - compact_line: Similar to compact, but wrap each line with
+      #   `{-#LANGUAGE #-}'.
+      #
+      # Default: vertical.
+      style: vertical
+
+      # Align affects alignment of closing pragma brackets.
+      #
+      # - true: Brackets are aligned in same column.
+      #
+      # - false: Brackets are not aligned together. There is only one space
+      #   between actual import and closing bracket.
+      #
+      # Default: true
+      align: true
+
+      # stylish-haskell can detect redundancy of some language pragmas. If this
+      # is set to true, it will remove those redundant pragmas. Default: true.
+      remove_redundant: true
+
+  # Replace tabs by spaces. This is disabled by default.
+  # - tabs:
+  #     # Number of spaces to use for each tab. Default: 8, as specified by the
+  #     # Haskell report.
+  #     spaces: 8
+
+  # Remove trailing whitespace
+  - trailing_whitespace: {}
+
+# A common setting is the number of columns (parts of) code will be wrapped
+# to. Different steps take this into account. Default: 80.
+columns: 70
+
+# By default, line endings are converted according to the OS. You can override
+# preferred format here.
+#
+# - native: Native newline format. CRLF on Windows, LF on other OSes.
+#
+# - lf: Convert to LF ("\n").
+#
+# - crlf: Convert to CRLF ("\r\n").
+#
+# Default: native.
+newline: native
+
+# Sometimes, language extensions are specified in a cabal file or from the
+# command line instead of using language pragmas in the file. stylish-haskell
+# needs to be aware of these, so it can parse the file correctly.
+#
+# No language extensions are enabled by default.
+language_extensions:
+  - TemplateHaskell
+  - QuasiQuotes
+  - CPP

BACKERS.md

@@ -0,0 +1,85 @@
+# Sponsors & Backers
+
+PostgREST ongoing development is only possible thanks to our Sponsors and Backers, listed below. If you'd like to join them, you can do so by supporting the PostgREST organization on [Patreon](https://www.patreon.com/postgrest).
+
+## Sponsors
+
+<table>
+  <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">
+        </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>
+      </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>
+      </td>
+    </tr>
+  </tbody>
+</table>
+
+## Lead Backers
+
+- Evans Fernandes
+- [Jan Sommer](https://github.com/nerfpops)
+- [Franz Gusenbauer](https://www.igutech.at/)
+
+## Backers
+
+- Tsingson Qin
+- Michel Pelletier
+- Jay Hannah
+- Robert Stolarz
+- Nicholas DiBiase
+- Christopher Reid
+- Nathan Bouscal
+- Daniel Rafaj
+- David Fenko
+- Remo Rechkemmer
+- Severin Ibarluzea
+- Tom Saleeba
+- Pawel Tyll
+
+## Former Backers
+
+<table>
+  <tbody>
+    <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">
+        </a>
+      </td>
+    </tr>
+  </tbody>
+</table>
+
+- [Christiaan Westerbeek](https://devotis.nl)
+- [Daniel Babiak](https://github.com/dbabiak)
+- Kofi Gumbs

CHANGELOG.md

@@ -5,8 +5,335 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ## Unreleased
 
+### Added
+
 ### Fixed
 
+## [9.0.0] - 2021-11-25
+
+### Added
+
+ - #1783, Include partitioned tables into the schema cache. Allows embedding, UPSERT, INSERT with Location response, OPTIONS request and OpenAPI support for partitioned tables - @laurenceisla
+ - #1878, Add Retry-After hint header when in recovery mode - @gautam1168
+ - #1735, Allow calling function with single unnamed param through RPC POST. - @steve-chavez
+   + Enables calling a function with a single json parameter without using `Prefer: params=single-object`
+   + Enables uploading bytea to a function with `Content-Type: application/octet-stream`
+   + Enables uploading raw text to a function with `Content-Type: text/plain`
+ - #1938, Allow escaping inside double quotes with a backslash, e.g. `?col=in.("Double\"Quote")`, `?col=in.("Back\\slash")` - @steve-chavez
+ - #1075, Allow filtering top-level resource based on embedded resources filters. This is enabled by adding `!inner` to the embedded resource, e.g. `/projects?select=*,clients!inner(*)&clients.id=eq.12`- @steve-chavez, @Iced-Sun
+ - #1857, Make GUC names for headers, cookies and jwt claims compatible with PostgreSQL v14 - @laurenceisla, @robertsosinski
+   + Getting the value for a header GUC on PostgreSQL 14 is done using `current_setting('request.headers')::json->>'name-of-header'` and in a similar way for `request.cookies` and `request.jwt.claims`
+   + PostgreSQL versions below 14 can opt in to the new JSON GUCs by setting the `db-use-legacy-gucs` config option to false (true by default)
+ - #1988, Allow specifying `unknown` for the `is` operator - @steve-chavez
+ - #2031, Improve error message for ambiguous embedding and add a relevant hint that includes unambiguous embedding suggestions - @laurenceisla
+
+### Fixed
+
+ - #1871, Fix OpenAPI missing default values for String types and identify Array types as "array" instead of "string" - @laurenceisla
+ - #1930, Fix RPC return type handling for `RETURNS TABLE` with a single column. Regression of #1615. - @wolfgangwalther
+ - #1938, Fix using single double quotes(`"`) and backslashes(`/`) as values on the "in" operator - @steve-chavez
+ - #1992, Fix schema cache query failing with standard_conforming_strings = off - @wolfgangwalther
+
+### Changed
+
+ - #1949, Drop support for embedding hints used with '.'(`select=projects.client_id(*)`), '!' should be used instead(`select=projects!client_id(*)`) - @steve-chavez
+ - #1783, Partitions (created using `PARTITION OF`) are no longer included in the schema cache. - @laurenceisla
+ - #2038, Dropped support for PostgreSQL 9.5 - @wolfgangwalther
+
+## [8.0.0] - 2021-07-25
+
+### Added
+
+ - #1525, Allow http status override through response.status guc - @steve-chavez
+ - #1512, Allow schema cache reloading with NOTIFY - @steve-chavez
+ - #1119, Allow config file reloading with SIGUSR2 - @steve-chavez
+ - #1558, Allow 'Bearer' with and without capitalization as authentication schema - @wolfgangwalther
+ - #1470, Allow calling RPC with variadic argument by passing repeated params - @wolfgangwalther
+ - #1559, No downtime when reloading the schema cache with SIGUSR1 - @steve-chavez
+ - #504, Add `log-level` config option. The admitted levels are: crit, error, warn and info - @steve-chavez
+ - #1607, Enable embedding through multiple views recursively - @wolfgangwalther
+ - #1598, Allow rollback of the transaction with Prefer tx=rollback - @wolfgangwalther
+ - #1633, Enable prepared statements for GET filters. When behind a connection pooler, you can disable preparing with `db-prepared-statements=false`
+   + This increases throughput by around 30% for simple GET queries(no embedding, with filters applied).
+ - #1729, #1760, Get configuration parameters from the db and allow reloading config with NOTIFY  - @steve-chavez
+ - #1824, Allow OPTIONS to generate certain HTTP methods for a DB view - @laurenceisla
+ - #1872, Show timestamps in startup/worker logs - @steve-chavez
+ - #1881, Add `openapi-mode` config option that allows ignoring roles privileges when showing the OpenAPI output - @steve-chavez
+ - CLI options(for debugging):
+   + #1678, Add --dump-config CLI option that prints loaded config and exits - @wolfgangwalther
+   + #1691, Add --example CLI option to show example config file - @wolfgangwalther
+   + #1697, #1723, Add --dump-schema CLI option for debugging purposes - @monacoremo, @wolfgangwalther
+ - #1794, (Experimental) Add `request.spec` GUC for db-root-spec - @steve-chavez
+
+### Fixed
+
+ - #1592, Removed single column restriction to allow composite foreign keys in join tables - @goteguru
+ - #1530, Fix how the PostgREST version is shown in the help text when the `.git` directory is not available - @monacoremo
+ - #1094, Fix expired JWTs starting an empty transaction on the db - @steve-chavez
+ - #1162, Fix location header for POST request with select= without PK - @wolfgangwalther
+ - #1585, Fix error messages on connection failure for localized postgres on Windows - @wolfgangwalther
+ - #1636, Fix `application/octet-stream` appending `charset=utf-8` - @steve-chavez
+ - #1469, #1638 Fix overloading of functions with unnamed arguments - @wolfgangwalther
+ - #1560, Return 405 Method not Allowed for GET of volatile RPC instead of 500 - @wolfgangwalther
+ - #1584, Fix RPC return type handling and embedding for domains with composite base type (#1615) - @wolfgangwalther
+ - #1608, #1635, Fix embedding through views that have COALESCE with subselect - @wolfgangwalther
+ - #1572, Fix parsing of boolean config values for Docker environment variables, now it accepts double quoted truth values ("true", "false") and numbers("1", "0") - @wolfgangwalther
+ - #1624, Fix using `app.settings.xxx` config options in Docker, now they can be used as `PGRST_APP_SETTINGS_xxx` - @wolfgangwalther
+ - #1814, Fix panic when attempting to run with unix socket on non-unix host and properly close unix domain socket on exit - @monacoremo
+ - #1825, Disregard internal junction(in non-exposed schema) when embedding - @steve-chavez
+ - #1846, Fix requests for overloaded functions from html forms to no longer hang (#1848) - @laurenceisla
+ - #1858, Add a hint and clarification to the no relationship found error - @laurenceisla
+ - #1841, Show comprehensive error when an RPC is not found in a stale schema cache - @laurenceisla
+ - #1875, Fix Location headers in headers only representation for null PK inserts on views - @laurenceisla
+
+### Changed
+
+ - #1522, #1528, #1535, Docker images are now built from scratch based on a the static PostgREST executable (#1494) and with Nix instead of a `Dockerfile`. This reduces the compressed image size from over 30mb to about 4mb - @monacoremo
+ - #1461, Location header for POST request is only included when PK is available on the table - @wolfgangwalther
+ - #1560, Volatile RPC called with GET now returns 405 Method not Allowed instead of 500 - @wolfgangwalther
+ - #1584, #1849 Functions that declare `returns composite_type` no longer return a single object array by default, only functions with `returns setof composite_type` return an array of objects - @wolfgangwalther
+ - #1604, Change the default logging level to `log-level=error`. Only requests with a status greater or equal than 500 will be logged. If you wish to go back to the previous behaviour and log all the requests, use `log-level=info` - @steve-chavez
+   + Because currently there's no buffering for logging, defaulting to the `error` level(minimum logging) increases throughput by around 15% for simple GET queries(no embedding, with filters applied).
+ - #1617, Dropped support for PostgreSQL 9.4 - @wolfgangwalther
+ - #1679, Renamed config settings with fallback aliases. e.g. `max-rows` is now `db-max-rows`, but `max-rows` is still accepted - @wolfgangwalther
+ - #1656, Allow `Prefer=headers-only` on POST requests and change default to `minimal` (#1813) - @laurenceisla
+ - #1854, Dropped undocumented support for gzip compression (which was surprisingly slow and easily enabled by mistake). In some use-cases this makes Postgres up to 3x faster - @aljungberg
+ - #1872, Send startup/worker logs to stderr to differentiate from access logs on stdout - @steve-chavez
+
+## [7.0.1] - 2020-05-18
+
+### Fixed
+
+- #1473, Fix overloaded computed columns on RPC - @wolfgangwalther
+- #1471, Fix POST, PATCH, DELETE with ?select= and return=minimal and PATCH with empty body - @wolfgangwalther
+- #1500, Fix missing `openapi-server-proxy-uri` config option - @steve-chavez
+- #1508, Fix `Content-Profile` not working for POST RPC - @steve-chavez
+- #1452, Fix PUT restriction for all columns - @steve-chavez
+
+### Changed
+
+- From this version onwards, the release page will only include a single Linux static executable that can be run on any Linux distribution.
+
+## [7.0.0] - 2020-04-03
+
+### Added
+
+- #1417, `Accept: application/vnd.pgrst.object+json` behavior is now enforced for POST/PATCH/DELETE regardless of `Prefer: return=representation/minimal` - @dwagin
+- #1415, Add support for user defined socket permission via `server-unix-socket-mode` config option - @Dansvidania
+- #1383, Add support for HEAD request - @steve-chavez
+- #1378, Add support for `Prefer: count=planned` and `Prefer: count=estimated` on GET /table - @steve-chavez, @LorenzHenk
+- #1327, Add support for optional query parameter `on_conflict` to upsert with specified keys for POST - @ykst
+- #1430, Allow specifying the foreign key constraint name(`/source?select=fk_constraint(*)`) to disambiguate an embedding - @steve-chavez
+- #1168, Allow access to the `Authorization` header through the `request.header.authorization` GUC - @steve-chavez
+- #1435, Add `request.method` and `request.path` GUCs - @steve-chavez
+- #1088, Allow adding headers to GET/POST/PATCH/PUT/DELETE responses through the `response.headers` GUC - @steve-chavez
+- #1427, Allow overriding provided headers(Location, Content-Type, etc) through the `response.headers` GUC - @steve-chavez
+- #1450, Allow multiple schemas to be exposed in one instance. The schema to use can be selected through the headers `Accept-Profile` for GET/HEAD and `Content-Profile` for POST/PATCH/PUT/DELETE - @steve-chavez, @mahmoudkassem
+
+### Fixed
+
+- #1301, Fix self join resource embedding on PATCH - @herulume, @steve-chavez
+- #1389, Fix many to many resource embedding on RPC/PATCH - @steve-chavez
+- #1355, Allow PATCH/DELETE without `return=minimal` on tables with no select privileges - @steve-chavez
+- #1361, Fix embedding a VIEW when its source foreign key is UNIQUE - @bwbroersma
+
+### Changed
+
+- #1385, bulk RPC call now should be done by specifying a `Prefer: params=multiple-objects` header - @steve-chavez
+- #1401, resource embedding now outputs an error when multiple relationships between two tables are found - @steve-chavez
+- #1423, default Unix Socket file mode from 755 to 660 - @dwagin
+- #1430, Remove embedding with duck typed column names `GET /projects?select=client(*)`- @steve-chavez
+  + You can rename the foreign key to `client` to make this request work in the new version: `alter table projects rename constraint projects_client_id_fkey to client`
+- #1413, Change `server-proxy-uri` config option to `openapi-server-proxy-uri` - @steve-chavez
+
+## [6.0.2] - 2019-08-22
+
+### Fixed
+
+- #1369, Change `raw-media-types` to accept a string of comma separated MIME types - @Dansvidania
+- #1368, Fix long column descriptions being truncated at 63 characters in PostgreSQL 12 - @amedeedaboville
+- #1348, Go back to converting plus "+" to space " " in querystrings by default - @steve-chavez
+
+### Deprecated
+
+- #1348, Deprecate `.` symbol for disambiguating resource embedding(added in #918). The url-safe '!' should be used instead. We refrained from using `+` as part of our syntax because it conflicts with some http clients and proxies.
+
+## [6.0.1] - 2019-07-30
+
+### Added
+
+- #1349, Add user defined raw output media types via `raw-media-types` config option - @Dansvidania
+- #1243, Add websearch_to_tsquery support - @herulume
+
+### Fixed
+
+- #1336, Error when testing on Chrome/Firefox: text/html requested but a single column was not selected - @Dansvidania
+- #1334, Unable to compile v6.0.0 on windows - @steve-chavez
+
+## [6.0.0] - 2019-06-21
+
+### Added
+
+- #1186, Add support for user defined unix socket via `server-unix-socket` config option - @Dansvidania
+- #690, Add `?columns` query parameter for faster bulk inserts, also ignores unspecified json keys in a payload - @steve-chavez
+- #1239, Add support for resource embedding on materialized views - @vitorbaptista
+- #1264, Add support for bulk RPC call - @steve-chavez
+- #1278, Add db-pool-timeout config option - @qu4tro
+- #1285, Abort on wrong database password - @qu4tro
+- #790, Allow override of OpenAPI spec through `root-spec` config option - @steve-chavez
+- #1308, Accept `text/plain` and `text/html` for raw output - @steve-chavez
+
+
+### Fixed
+
+- #1223, Fix incorrect OpenAPI externalDocs url - @steve-chavez
+- #1221, Fix embedding other resources when having a self join - @steve-chavez
+- #1242, Fix embedding a view having a select in a where - @steve-chavez
+- #1238, Fix PostgreSQL to OpenAPI type mappings for numeric and character types - @fpusch
+- #1265, Fix query generated on bulk upsert with an empty array - @qu4tro
+- #1273, Fix RPC ignoring unknown arguments by default - @steve-chavez
+- #1257, Fix incorrect status when a PATCH request doesn't find rows to change - @qu4tro
+
+### Changed
+
+- #1288, Change server-host default of 127.0.0.1 to !4
+
+### Deprecated
+
+- #1288, Deprecate `.` symbol for disambiguating resource embedding(added in #918). '+' should be used instead. Though '+' is url safe, certain clients might need to encode it to '%2B'.
+
+### Removed
+
+- #1288, Removed support for schema reloading with SIGHUP, SIGUSR1 should be used instead - @steve-chavez
+
+## [5.2.0] - 2018-12-12
+
+### Added
+
+- #1205, Add support for parsing JSON Web Key Sets - @russelldavies
+- #1203, Add support for reading db-uri from a separate file - @zhoufeng1989
+- #1200, Add db-extra-search-path config for adding schemas to the search_path, solves issues related to extensions created on the public schema - @steve-chavez
+- #1219, Add ability to quote column names on filters - @steve-chavez
+
+### Fixed
+
+- #1182, Fix embedding on views with composite pks - @steve-chavez
+- #1180, Fix embedding on views with subselects in pg10 - @steve-chavez
+- #1197, Allow CORS for PUT - @bkylerussell
+- #1181, Correctly qualify function argument of custom type in public schema - @steve-chavez
+- #1008, Allow columns that contain spaces in filters - @steve-chavez
+
+## [5.1.0] - 2018-08-31
+
+### Added
+
+- #1099, Add support for getting json/jsonb by array index - @steve-chavez
+- #1145, Add materialized view columns to OpenAPI output - @steve-chavez
+- #709, Allow embedding on views with subselects/CTE - @steve-chavez
+- #1148, OpenAPI: add `required` section for the non-nullable columns - @laughedelic
+- #1158, Add summary to OpenAPI doc for RPC functions - @mdr1384
+
+### Fixed
+
+- #1113, Fix UPSERT failing when having a camel case PK column - @steve-chavez
+- #945, Fix slow start-up time on big schemas - @steve-chavez
+- #1129, Fix view embedding when table is capitalized - @steve-chavez
+- #1149, OpenAPI: Change `GET` response type to array - @laughedelic
+- #1152, Fix RPC failing when having arguments with reserved or uppercase keywords - @mdr1384
+- #905, Fix intermittent empty replies - @steve-chavez
+- #1139, Fix JWTIssuedAtFuture failure for valid iat claim - @steve-chavez
+- #1141, Fix app.settings resetting on pool timeout - @steve-chavez
+
+### Changed
+
+- #1099, Numbers in json path `?select=data->1->>key` now get treated as json array indexes instead of keys - @steve-chavez
+- #1128, Allow finishing a json path with a single arrow `->`. Now a json can be obtained without resorting to casting, Previously: `/json_arr?select=data->>2::json`, now: `/json_arr?select=data->2` - @steve-chavez
+- #724, Change server-host default of *4 to 127.0.0.1
+
+### Deprecated
+
+- #724, SIGHUP deprecated, SIGUSR1 should be used instead
+
+## [0.5.0.0] - 2018-05-14
+
+### Added
+
+- The configuration (e.g. `postgrest.conf`) now accepts arbitrary settings that will be passed through as session-local database settings. This can be used to pass in secret keys directly as strings, or via OS environment variables. For instance: `app.settings.jwt_secret = "$(MYAPP_JWT_SECRET)"` will take `MYAPP_JWT_SECRET` from the environment and make it available to postgresql functions as `current_setting('app.settings.jwt_secret')`. Only `app.settings.*` values in the configuration file are treated in this way. - @canadaduane
+- #256, Add support for bulk UPSERT with POST and single UPSERT with PUT - @steve-chavez
+- #1078, Add ability to specify source column in embed - @steve-chavez
+- #821, Allow embeds alias to be used in filters - @steve-chavez
+- #906, Add jspath configurable `role-claim-key` - @steve-chavez
+- #1061, Add foreign tables to OpenAPI output - @rhyamada
+
+### Fixed
+
+- #828, Fix computed column only working in public schema - @steve-chavez
+- #925, Fix RPC high memory usage by using parametrized query and avoiding json encoding - @steve-chavez
+- #987, Fix embedding with self-reference foreign key - @steve-chavez
+- #1044, Fix view parent embedding when having many views - @steve-chavez
+- #781, Fix accepting misspelled desc/asc ordering modificators - @onporat, @steve-chavez
+
+### Changed
+
+- #828, A `SET SCHEMA <db-schema>` is done on each request, this has the following implications:
+  - Computed columns now only work if they belong to the db-schema
+  - Stored procedures might require a `search_path` to work properly, for further details see https://postgrest.org/en/v5.0/api.html#explicit-qualification
+- To use RPC now the `json_to_record/json_to_recordset` functions are needed, these are available starting from PostgreSQL 9.4 - @steve-chavez
+- Overloaded functions now depend on the `dbStructure`, restart/sighup may be needed for their correct functioning - @steve-chavez
+- #1098, Removed support for:
+  + curly braces `{}` in embeds, i.e. `/clients?select=*,projects{*}` can no longer be used, from now on parens `()` should be used `/clients?select=*,projects(*)` - @steve-chavez
+  + "in" operator without parens, i.e. `/clients?id=in.1,2,3` no longer supported, `/clients?id=in.(1,2,3)` should be used - @steve-chavez
+  + "@@", "@>" and "<@" operators, from now on their mnemonic equivalents should be used "fts", "cs" and "cd" respectively - @steve-chavez
+
+## [0.4.4.0] - 2018-01-08
+
+### Added
+
+- #887, #601, #1007, Allow specifying dictionary and plain/phrase tsquery in full text search - @steve-chavez
+- #328, Allow doing GET on rpc - @steve-chavez
+- #917, Add ability to map RAISE errorcode/message to http status - @steve-chavez
+- #940, Add ability to map GUC to http response headers - @steve-chavez
+- #1022, Include git sha in version report - @begriffs
+- Faster queries using json_agg - @ruslantalpa
+
+### Fixed
+
+- #876, Read secret files as binary, discard final LF if any - @eric-brechemier
+- #968, Treat blank proxy uri as missing - @begriffs
+- #933, OpenAPI externals docs url to current version - @steve-chavez
+- #962, OpenAPI don't err on nonexistent schema - @steve-chavez
+- #954, make OpenAPI rpc output dependent on user privileges - @steve-chavez
+- #955, Support configurable aud claim - @statik
+- #996, Fix embedded column conflicts table name - @grotsev
+- #974, Fix RPC error when function has single OUT param - @steve-chavez
+- #1021, Reduce join size in allColumns for faster program start - @nextstopsun
+- #411, Remove the need for pk in &select for parent embed - @steve-chavez
+- #1016, Fix anonymous requests when configured with jwt-aud - @ruslantalpa
+
+## [0.4.3.0] - 2017-09-06
+
+### Added
+
+- #567, Support more JWT signing algorithms, including RSA - @begriffs
+- #889, Allow more than two conditions in a single and/or - @steve-chavez
+- #883, Binary output support for RPC - @steve-chavez
+- #885, Postgres COMMENTs on SCHEMA/TABLE/COLUMN are used for OpenAPI - @ldesgoui
+- #907, Ability to embed using a specific relation when there are multiple between tables - @ruslantalpa
+- #930, Split table comment on newline to get OpenAPI operation summary and description - @daurnimator
+- #938, Support for range operators - @russelldavies
+
+### Fixed
+
+- #877, Base64 secret read from a file ending with a newline - @eric-brechemier
+- #896, Boolean env var interpolation in config file - @begriffs
+- #885, OpenAPI repetition reduced by using more definitions- @ldesgoui
+- #924, Improve relations initialization time - @9too
+- #927, Treat blank pre-request as missing - @begriffs
+
+### Changed
+
+- #938, Deprecate symbol operators with mnemonic names. - @russelldavies
+
 ## [0.4.2.0] - 2017-06-11
 
 ### Added

CODE_OF_CONDUCT.md

@@ -0,0 +1,132 @@
+
+# Contributor Covenant Code of Conduct
+
+## Our Pledge
+
+We as members, contributors, and leaders pledge to make participation in our
+community a harassment-free experience for everyone, regardless of age, body
+size, visible or invisible disability, ethnicity, sex characteristics, gender
+identity and expression, level of experience, education, socio-economic status,
+nationality, personal appearance, race, caste, color, religion, or sexual identity
+and orientation.
+
+We pledge to act and interact in ways that contribute to an open, welcoming,
+diverse, inclusive, and healthy community.
+
+## Our Standards
+
+Examples of behavior that contributes to a positive environment for our
+community include:
+
+* Demonstrating empathy and kindness toward other people
+* Being respectful of differing opinions, viewpoints, and experiences
+* Giving and gracefully accepting constructive feedback
+* Accepting responsibility and apologizing to those affected by our mistakes,
+  and learning from the experience
+* Focusing on what is best not just for us as individuals, but for the
+  overall community
+
+Examples of unacceptable behavior include:
+
+* The use of sexualized language or imagery, and sexual attention or
+  advances of any kind
+* Trolling, insulting or derogatory comments, and personal or political attacks
+* Public or private harassment
+* Publishing others' private information, such as a physical or email
+  address, without their explicit permission
+* Other conduct which could reasonably be considered inappropriate in a
+  professional setting
+
+## Enforcement Responsibilities
+
+Community leaders are responsible for clarifying and enforcing our standards of
+acceptable behavior and will take appropriate and fair corrective action in
+response to any behavior that they deem inappropriate, threatening, offensive,
+or harmful.
+
+Community leaders have the right and responsibility to remove, edit, or reject
+comments, commits, code, wiki edits, issues, and other contributions that are
+not aligned to this Code of Conduct, and will communicate reasons for moderation
+decisions when appropriate.
+
+## Scope
+
+This Code of Conduct applies within all community spaces, and also applies when
+an individual is officially representing the community in public spaces.
+Examples of representing our community include using an official e-mail address,
+posting via an official social media account, or acting as an appointed
+representative at an online or offline event.
+
+## Enforcement
+
+Instances of abusive, harassing, or otherwise unacceptable behavior may be
+reported to the community leaders responsible for enforcement at support@postgrest.org.
+All complaints will be reviewed and investigated promptly and fairly.
+
+All community leaders are obligated to respect the privacy and security of the
+reporter of any incident.
+
+## Enforcement Guidelines
+
+Community leaders will follow these Community Impact Guidelines in determining
+the consequences for any action they deem in violation of this Code of Conduct:
+
+### 1. Correction
+
+**Community Impact**: Use of inappropriate language or other behavior deemed
+unprofessional or unwelcome in the community.
+
+**Consequence**: A private, written warning from community leaders, providing
+clarity around the nature of the violation and an explanation of why the
+behavior was inappropriate. A public apology may be requested.
+
+### 2. Warning
+
+**Community Impact**: A violation through a single incident or series
+of actions.
+
+**Consequence**: A warning with consequences for continued behavior. No
+interaction with the people involved, including unsolicited interaction with
+those enforcing the Code of Conduct, for a specified period of time. This
+includes avoiding interactions in community spaces as well as external channels
+like social media. Violating these terms may lead to a temporary or
+permanent ban.
+
+### 3. Temporary Ban
+
+**Community Impact**: A serious violation of community standards, including
+sustained inappropriate behavior.
+
+**Consequence**: A temporary ban from any sort of interaction or public
+communication with the community for a specified period of time. No public or
+private interaction with the people involved, including unsolicited interaction
+with those enforcing the Code of Conduct, is allowed during this period.
+Violating these terms may lead to a permanent ban.
+
+### 4. Permanent Ban
+
+**Community Impact**: Demonstrating a pattern of violation of community
+standards, including sustained inappropriate behavior,  harassment of an
+individual, or aggression toward or disparagement of classes of individuals.
+
+**Consequence**: A permanent ban from any sort of public interaction within
+the community.
+
+## Attribution
+
+This Code of Conduct is adapted from the [Contributor Covenant][homepage],
+version 2.0, available at
+[https://www.contributor-covenant.org/version/2/0/code_of_conduct.html][v2.0].
+
+Community Impact Guidelines were inspired by
+[Mozilla's code of conduct enforcement ladder][Mozilla CoC].
+
+For answers to common questions about this code of conduct, see the FAQ at
+[https://www.contributor-covenant.org/faq][FAQ]. Translations are available
+at [https://www.contributor-covenant.org/translations][translations].
+
+[homepage]: https://www.contributor-covenant.org
+[v2.0]: https://www.contributor-covenant.org/version/2/0/code_of_conduct.html
+[Mozilla CoC]: https://github.com/mozilla/diversity
+[FAQ]: https://www.contributor-covenant.org/faq
+[translations]: https://www.contributor-covenant.org/translations

LICENSE

@@ -1,4 +1,5 @@
 Copyright (c) 2014 Joe Nelson
+Copyright (c) 2019 Steve Chavez
 
 Permission is hereby granted, free of charge, to any person obtaining
 a copy of this software and associated documentation files (the

README.md

@@ -1,32 +1,83 @@
-![Logo](static/logo.png "Logo")
+![Logo](static/bigger-logo.png "Logo")
 
-[![Build Status](https://circleci.com/gh/begriffs/postgrest.png?style=shield&circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2)](https://circleci.com/gh/begriffs/postgrest/tree/master)
-<a href="https://heroku.com/deploy?template=https://github.com/begriffs/postgrest">
+[![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.com)
+[![Docs](https://img.shields.io/badge/docs-latest-brightgreen.svg?style=flat)](http://postgrest.org)
+[![Docker Stars](https://img.shields.io/docker/pulls/postgrest/postgrest.svg)](https://hub.docker.com/r/postgrest/postgrest/)
+[![Build Status](https://github.com/postgrest/postgrest/actions/workflows/ci.yaml/badge.svg?branch=main)](https://github.com/PostgREST/postgrest/actions?query=branch%3Amain)
+[![Coverage Status](https://img.shields.io/codecov/c/github/postgrest/postgrest/main)](https://app.codecov.io/gh/PostgREST/postgrest)
+[![Hackage docs](https://img.shields.io/hackage/v/postgrest.svg?label=hackage)](http://hackage.haskell.org/package/postgrest)
 
 PostgREST serves a fully RESTful API from any existing PostgreSQL
 database. It provides a cleaner, more standards-compliant, faster
 API than you are likely to write from scratch.
 
-### Usage
+## Sponsors
 
-1. Download the binary ([latest release](https://github.com/begriffs/postgrest/releases/latest))
+<table>
+  <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">
+        </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>
+      </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>
+      </td>
+    </tr>
+  </tbody>
+</table>
+
+Big thanks to our sponsors! You can join them by supporting PostgREST on [Patreon](https://www.patreon.com/postgrest).
+
+## Usage
+
+1. Download the binary ([latest release](https://github.com/PostgREST/postgrest/releases/latest))
    for your platform.
 2. Invoke for help:
 
     ```bash
     postgrest --help
     ```
+## [Documentation](http://postgrest.org)
 
-### Performance
+Latest documentation is at [postgrest.org](http://postgrest.org). You can contribute to the docs in [PostgREST/postgrest-docs](https://github.com/PostgREST/postgrest-docs).
+
+## Performance
 
 TLDR; subsecond response times for up to 2000 requests/sec on Heroku
-free tier. If you're used to servers written in interpreted languages
-(or named after precious gems), prepare to be pleasantly surprised by
-PostgREST performance.
+free tier. If you're used to servers written in interpreted languages,
+prepare to be pleasantly surprised by PostgREST performance.
 
 Three factors contribute to the speed. First the server is written
 in [Haskell](https://www.haskell.org/) using the
@@ -49,13 +100,10 @@ by
 * Using the PostgreSQL binary protocol
 * Being stateless to allow horizontal scaling
 
-Other optimizations are possible, and some are outlined in the
-[Future Features](#future-features).
-
-### Security
+## Security
 
 PostgREST [handles
-authentication](http://postgrest.com/en/stable/auth.html) (via JSON Web
+authentication](http://postgrest.org/en/stable/auth.html) (via JSON Web
 Tokens) and delegates authorization to the role information defined in
 the database. This ensures there is a single declarative source of truth
 for security.  When dealing with the database the server assumes the
@@ -64,16 +112,7 @@ the connection cannot do anything the user themselves couldn't. Other
 forms of authentication can be built on top of the JWT primitive. See
 the docs for more information.
 
-PostgreSQL 9.5 supports true [row-level
-security](http://www.postgresql.org/docs/9.5/static/ddl-rowsecurity.html).
-In previous versions it can be simulated with triggers and
-security-barrier views. Because the possible queries to the database
-are limited to certain templates using
-[leakproof](http://blog.2ndquadrant.com/how-do-postgresql-security_barrier-views-work/)
-functions, the trigger workaround does not compromise row-level
-security.
-
-### Versioning
+## Versioning
 
 A robust long-lived API needs the freedom to exist in multiple
 versions. PostgREST does versioning through database schemas. This
@@ -81,7 +120,7 @@ allows you to expose tables and views without making the app brittle.
 Underlying tables can be superseded and hidden behind public facing
 views.
 
-### Self-documentation
+## Self-documentation
 
 PostgREST uses the [OpenAPI](https://openapis.org/) standard to
 generate up-to-date documentation for APIs. You can use a tool like
@@ -93,7 +132,7 @@ instance the number of rows returned by an endpoint is reported by -
 and limited with - range headers. More about
 [that](http://begriffs.com/posts/2014-03-06-beyond-http-header-links.html).
 
-### Data Integrity
+## Data Integrity
 
 Rather than relying on an Object Relational Mapper and custom
 imperative coding, this system requires you put declarative constraints
@@ -105,14 +144,24 @@ surprises, such as enforcing idempotent PUT requests.
 
 See examples of [PostgreSQL
 constraints](http://www.tutorialspoint.com/postgresql/postgresql_constraints.htm)
-and the [API guide](http://postgrest.com/en/stable/api.html).
+and the [API guide](http://postgrest.org/en/stable/api.html).
 
-### Thanks
+## Supporting development
 
-I'm grateful to the generous project
-[contributors](https://github.com/begriffs/postgrest/graphs/contributors)
-who have improved PostgREST immensely with their code and good
-judgement.  See more details in the
-[changelog](https://github.com/begriffs/postgrest/blob/master/CHANGELOG.md).
+You can help PostgREST ongoing maintenance and development by:
+
+- Making a regular donation through Patreon https://www.patreon.com/postgrest
+
+- Alternatively, you can make a one-time donation via Paypal https://www.paypal.me/postgrest
+
+Every donation will be spent on making PostgREST better for the whole community.
+
+## Thanks
+
+The PostgREST organization is grateful to:
+
+- The project [sponsors and backers](https://github.com/PostgREST/postgrest/blob/main/BACKERS.md) who support PostgREST's development.
+- The project [contributors](https://github.com/PostgREST/postgrest/graphs/contributors) who have improved PostgREST immensely with their code
+  and good judgement. See more details in the [changelog](https://github.com/PostgREST/postgrest/blob/main/CHANGELOG.md).
 
 The cool logo came from [Mikey Casalaina](https://github.com/casalaina).

Setup.hs

@@ -1,2 +1,3 @@
+-- This file is required by Hackage.
 import Distribution.Simple
 main = defaultMain

app.json

@@ -1,19 +1,19 @@
 {
   "name": "PostgREST",
   "description": "RESTful API for any PostgreSQL database.",
-  "logo": "https://halcyon.sh/logo.svg",
-  "repository": "https://github.com/begriffs/postgrest",
+  "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/begriffs/postgrest-heroku"
+      "value": "https://github.com/PostgREST/postgrest-heroku"
     },
     "POSTGREST_VER": {
       "description": "Version of PostgREST to deploy",
-      "value": "0.4.2.0"
+      "value": "8.0.0"
     },
     "DB_URI": {
-      "description": "Database connection string",
+      "description": "Database connection string, e.g. postgres://user:pass@xxxxxxx.rds.amazonaws.com/mydb",
       "required": true
     },
     "DB_SCHEMA": {
@@ -43,6 +43,10 @@
       "required": false,
       "value": "false"
     },
+    "JWT_AUD": {
+      "description": "The audience that should be validated if the JWT token contains an aud claim",
+      "required": false
+    },
     "MAX_ROWS": {
       "description": "A hard limit to the number of rows PostgREST will fetch from a view, table, or stored procedure",
       "required": false

circle.yml

@@ -1,25 +0,0 @@
-dependencies:
-  cache_directories:
-    - "~/.stack"
-    - ".stack-work"
-  pre:
-    - curl -L https://github.com/commercialhaskell/stack/releases/download/v1.1.2/stack-1.1.2-linux-x86_64.tar.gz | tar zx -C /tmp
-    - sudo mv /tmp/stack-1.1.2-linux-x86_64/stack /usr/bin
-    - sudo apt-get update; sudo apt-get install --only-upgrade binutils
-  override:
-    - stack setup
-    - rm -fr $(stack path --dist-dir) $(stack path --local-install-root)
-    - stack install hlint packdeps cabal-install
-    - stack build --fast
-    - stack build --fast --test --no-run-tests
-
-test:
-  override:
-    - POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://ubuntu@localhost" postgrest_test) stack test
-    - git ls-files | grep '\.l\?hs$' | xargs stack exec -- hlint -X QuasiQuotes -X NoPatternSynonyms "$@"
-    - stack exec -- cabal update
-    - stack exec --no-ghc-package-path -- cabal install --only-d --dry-run
-    - stack exec -- packdeps *.cabal || true
-    - stack exec -- cabal check
-    - stack haddock --no-haddock-deps
-    - stack sdist

default.nix

@@ -0,0 +1,152 @@
+let
+  name =
+    "postgrest";
+
+  compiler =
+    "ghc8107";
+
+  # 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
+  # added here will increase the space used in the Nix store and trigger the
+  # build of new Nix derivations when changed.
+  src =
+    pkgs.lib.sourceFilesBySuffices
+      (pkgs.gitignoreSource ./.)
+      [ ".cabal" ".hs" ".lhs" "LICENSE" ];
+
+  # Commit of the Nixpkgs repository that we want to use.
+  nixpkgsVersion =
+    import nix/nixpkgs-version.nix;
+
+  # Nix files that describe the Nixpkgs repository. We evaluate the expression
+  # using `import` below.
+  nixpkgs =
+    builtins.fetchTarball {
+      url = "https://github.com/nixos/nixpkgs/archive/${nixpkgsVersion.rev}.tar.gz";
+      sha256 = nixpkgsVersion.tarballHash;
+    };
+
+  allOverlays =
+    import nix/overlays;
+
+  overlays =
+    [
+      allOverlays.build-toolbox
+      allOverlays.checked-shell-script
+      allOverlays.gitignore
+      allOverlays.postgresql-default
+      allOverlays.postgresql-legacy
+      allOverlays.postgresql-future
+      (allOverlays.haskell-packages { inherit compiler; })
+    ];
+
+  # Evaluated expression of the Nixpkgs repository.
+  pkgs =
+    import nixpkgs { inherit overlays; };
+
+  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; }
+    ];
+
+  patches =
+    pkgs.callPackage nix/patches { };
+
+  # Dynamic derivation for PostgREST
+  postgrest =
+    pkgs.haskell.packages."${compiler}".callCabal2nix name src { };
+
+  # Function 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; };
+
+  # Options passed to cabal in dev tools and tests
+  devCabalOptions =
+    "-f dev --test-show-detail=direct";
+
+  profiledHaskellPackages =
+    pkgs.haskell.packages."${compiler}".extend (self: super:
+      {
+        mkDerivation =
+          args:
+          super.mkDerivation (args // { enableLibraryProfiling = true; });
+      }
+    );
+
+  inherit (pkgs.haskell) lib;
+in
+rec {
+  inherit nixpkgs pkgs;
+
+  # Derivation for the PostgREST Haskell package, including the executable,
+  # libraries and documentation. We disable running the test suite on Nix
+  # builds, as they require a database to be set up.
+  postgrestPackage =
+    lib.dontCheck postgrest;
+
+  # Static executable.
+  postgrestStatic =
+    lib.justStaticExecutables (lib.dontCheck (staticHaskellPackage name src));
+
+  # Profiled dynamic executable.
+  postgrestProfiled =
+    lib.enableExecutableProfiling (
+      lib.dontHaddock (
+        lib.dontCheck (profiledHaskellPackages.callCabal2nix name src { })
+      )
+    );
+
+  inherit (postgrest) env;
+
+  # Tooling for analyzing Haskell imports and exports.
+  hsie =
+    pkgs.callPackage nix/hsie {
+      inherit (pkgs.haskell.packages."${compiler}") ghcWithPackages;
+    };
+
+  ### Tools
+
+  cabalTools =
+    pkgs.callPackage nix/tools/cabalTools.nix { inherit devCabalOptions 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; };
+
+  # Script for running memory tests.
+  memory =
+    pkgs.callPackage nix/tools/memory.nix { inherit postgrestProfiled withTools; };
+
+  # Utility for updating the pinned version of Nixpkgs.
+  nixpkgsTools =
+    pkgs.callPackage nix/tools/nixpkgsTools.nix { };
+
+  # Scripts for publishing new releases.
+  release =
+    pkgs.callPackage nix/tools/release { };
+
+  # Linting and styling tools.
+  style =
+    pkgs.callPackage nix/tools/style.nix { inherit hsie; };
+
+  # Scripts for running tests.
+  tests =
+    pkgs.callPackage nix/tools/tests.nix {
+      inherit postgrest devCabalOptions withTools;
+      ghc = pkgs.haskell.compiler."${compiler}";
+      inherit (pkgs.haskell.packages."${compiler}") hpc-codecov;
+    };
+
+  withTools =
+    pkgs.callPackage nix/tools/withTools.nix { inherit postgresqlVersions; };
+}

docker/Dockerfile

@@ -1,42 +0,0 @@
-FROM debian:jessie
-
-# Install libpq5
-RUN apt-get -qq update && \
-    apt-get -qq install -y --no-install-recommends libpq5 && \
-    apt-get -qq clean && \
-    rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/*
-
-# Install postgrest
-RUN POSTGREST_VERSION="0.4.2.0" \
-    BUILD_DEPS="curl ca-certificates xz-utils" && \
-    apt-get -qq update && \
-    apt-get -qq install -y --no-install-recommends $BUILD_DEPS && \
-    cd /tmp && \
-    curl -SLO https://github.com/begriffs/postgrest/releases/download/v${POSTGREST_VERSION}/postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
-    tar -xJvf postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
-    mv postgrest /usr/local/bin/postgrest && \
-    cd / && \
-    apt-get -qq purge --auto-remove -y $BUILD_DEPS && \
-    apt-get -qq clean && \
-    rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/*
-
-COPY postgrest.conf /etc/postgrest.conf
-
-
-ENV PGRST_DB_URI= \
-    PGRST_DB_SCHEMA=public \
-    PGRST_DB_ANON_ROLE= \
-    PGRST_DB_POOL=100 \
-    PGRST_SERVER_HOST=*4 \
-    PGRST_SERVER_PORT=3000 \
-    PGRST_SERVER_PROXY_URL= \
-    PGRST_JWT_SECRET= \
-    PGRST_SECRET_IS_BASE64=false \
-    PGRST_MAX_ROWS= \
-    PGRST_PRE_REQUEST=
-
-# PostgREST reads /etc/postgrest.conf so map the configuration
-# file in when you run this container
-CMD exec postgrest /etc/postgrest.conf
-
-EXPOSE 3000

docker/config.conf

@@ -1,3 +0,0 @@
-db-uri = "postgres://app_user:password@postgres:5432/app_db"
-db-schema = "public"
-db-anon-role = "app_user"

docker/docker-compose.yml

@@ -1,19 +0,0 @@
-stgrest:
-  image: pg_local
-  ports:
-    - "3000:3000"
-  links:
-    - postgres:postgres
-  environment:
-    PGRST_DB_URI: postgres://app_user:password@postgres:5432/app_db
-    PGRST_DB_SCHEMA: public
-    PGRST_DB_ANON_ROLE: app_user
-
-postgres:
-  image: postgres
-  ports:
-    - "5432:5432"
-  environment:
-    POSTGRES_DB: app_db
-    POSTGRES_USER: app_user
-    POSTGRES_PASSWORD: password

docker/postgrest.conf

@@ -1,14 +0,0 @@
-db-uri = "$(PGRST_DB_URI)"
-db-schema = "$(PGRST_DB_SCHEMA)"
-db-anon-role = "$(PGRST_DB_ANON_ROLE)"
-db-pool = "$(PGRST_DB_POOL)"
-
-server-host = "$(PGRST_SERVER_HOST)"
-server-port = "$(PGRST_SERVER_PORT)"
-
-server-proxy-url = "$(PGRST_SERVER_PROXY_URL)"
-jwt-secret = "$(PGRST_JWT_SECRET)"
-secret-is-base64 = "$(PGRST_SECRET_IS_BASE64)"
-
-max-rows = "$(PGRST_MAX_ROWS)"
-pre-request = "$(PGRST_PRE_REQUEST)"

main/Main.hs

@@ -1,181 +1,47 @@
 {-# LANGUAGE CPP #-}
 
-module Main where
+module Main (main) where
 
-import           Protolude
-import           PostgREST.App
-import           PostgREST.Config                     (AppConfig (..),
-                                                       PgVersion (..),
-                                                       minimumPgVersion,
-                                                       prettyVersion,
-                                                       readOptions)
-import           PostgREST.Error                      (encodeError)
-import           PostgREST.OpenAPI                    (isMalformedProxyUri)
-import           PostgREST.DbStructure
-import           PostgREST.Types                      (DbStructure, Schema)
+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
 
-import           Control.AutoUpdate
-import           Control.Retry
-import           Data.ByteString.Base64               (decode)
-import           Data.String                          (IsString (..))
-import           Data.Text                            (stripPrefix, pack, replace)
-import           Data.Text.Encoding                   (encodeUtf8, decodeUtf8)
-import           Data.Text.IO                         (hPutStrLn, readFile)
-import           Data.Time.Clock.POSIX                (getPOSIXTime)
-import qualified Hasql.Query                          as H
-import qualified Hasql.Session                        as H
-import qualified Hasql.Decoders                       as HD
-import qualified Hasql.Encoders                       as HE
-import qualified Hasql.Pool                           as P
-import           Network.Wai.Handler.Warp
-import           System.IO                            (BufferMode (..),
-                                                       hSetBuffering)
-import           Data.IORef
 #ifndef mingw32_HOST_OS
-import           System.Posix.Signals
+import qualified PostgREST.Unix as Unix
 #endif
 
-isServerVersionSupported :: H.Session Bool
-isServerVersionSupported = do
-  ver <- H.query () pgVersion
-  return $ ver >= pgvNum minimumPgVersion
- where
-  pgVersion =
-    H.statement "SELECT current_setting('server_version_num')::integer"
-      HE.unit (HD.singleRow $ HD.value HD.int4) False
-
-{-|
-  Background thread that does the following :
-  1. Tries to connect to pg server and will keep trying until success.
-  2. Checks if the pg version is supported and if it's not it kills the main program.
-  3. Obtains the dbStructure.
-  4. If 2 or 3 fail to give their result it means the connection is down so it goes back to 1,
-     otherwise it finishes his work successfully.
--}
-connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IORef Bool -> IO ()
-connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
-  isWorkerOn <- readIORef refIsWorkerOn
-  unless isWorkerOn $ do
-    atomicWriteIORef refIsWorkerOn True
-    void $ forkIO work
-  where
-    work = do
-      atomicWriteIORef refDbStructure Nothing
-      putStrLn ("Attempting to connect to the database..." :: Text)
-      connected <- connectingSucceeded pool
-      when connected $ do
-        result <- P.use pool $ do
-          supported <- isServerVersionSupported
-          unless supported $ liftIO $ do
-            hPutStrLn stderr
-              ("Cannot run in this PostgreSQL version, PostgREST needs at least "
-              <> pgvName minimumPgVersion)
-            killThread mainTid
-          dbStructure <- getDbStructure schema
-          liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
-        case result of
-          Left e -> do
-            putStrLn ("Failed to query the database. Retrying." :: Text)
-            hPutStrLn stderr (toS $ encodeError e)
-            work
-          Right _ -> do
-            atomicWriteIORef refIsWorkerOn False
-            putStrLn ("Connection successful" :: Text)
-
--- | Connect to pg server if it fails retry with capped exponential backoff until success
-connectingSucceeded :: P.Pool -> IO Bool
-connectingSucceeded pool =
-  retrying (capDelay 32000000 $ exponentialBackoff 1000000)
-           shouldRetry
-           (const $ P.release pool >> isConnectionSuccessful)
-  where
-    isConnectionSuccessful :: IO Bool
-    isConnectionSuccessful = do
-      testConn <- P.use pool $ H.sql "SELECT 1"
-      case testConn of
-        Left e -> hPutStrLn stderr (toS $ encodeError e) >> pure False
-        _ -> pure True
-    shouldRetry :: RetryStatus -> Bool -> IO Bool
-    shouldRetry rs isConnSucc = do
-      delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000
-      itShould <- pure $ not isConnSucc
-      when itShould $
-        putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
-      return itShould
-
 main :: IO ()
 main = do
-  hSetBuffering stdout LineBuffering
-  hSetBuffering stdin  LineBuffering
-  hSetBuffering stderr NoBuffering
-
-  conf <- loadSecretFile =<< readOptions
-  let host = configHost conf
-      port = configPort conf
-      proxy = configProxyUri conf
-      pgSettings = toS (configDatabase conf)
-      appSettings = setHost ((fromString . toS) host)
-                  . setPort port
-                  . setServerName (toS $ "postgrest/" <> prettyVersion)
-                  . setTimeout 3600
-                  $ defaultSettings
-
-  when (isMalformedProxyUri $ toS <$> proxy) $ panic
-    "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
-
-  putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)
-
-  pool <- P.acquire (configPool conf, 10, pgSettings)
-
-  refDbStructure <- newIORef Nothing
-
-  -- Helper ref to make sure just one connectionWorker can run at a time
-  refIsWorkerOn <- newIORef False
-
-  mainTid <- myThreadId
-
-  connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn
+  setBuffering
+  hasPGRSTEnv <- not . M.null <$> readPGRSTEnvironment
+  opts <- CLI.readCLIShowHelp hasPGRSTEnv
+  CLI.main installSignalHandlers runAppInSocket opts
 
+installSignalHandlers :: App.SignalHandlerInstaller
 #ifndef mingw32_HOST_OS
-  forM_ [sigINT, sigTERM] $ \sig ->
-    void $ installHandler sig (Catch $ do
-        P.release pool
-        throwTo mainTid UserInterrupt
-      ) Nothing
-
-  void $ installHandler sigHUP (
-      Catch $ connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn
-   ) Nothing
+installSignalHandlers = Unix.installSignalHandlers
+#else
+installSignalHandlers _ = pass
 #endif
 
-  -- ask for the OS time at most once per second
-  getTime <- mkAutoUpdate
-    defaultUpdateSettings { updateAction = getPOSIXTime }
+runAppInSocket :: Maybe App.SocketRunner
+#ifndef mingw32_HOST_OS
+runAppInSocket = Just Unix.runAppWithSocket
+#else
+runAppInSocket = Nothing
+#endif
 
-  runSettings appSettings $ postgrest conf refDbStructure pool getTime
-    (connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn)
-
-loadSecretFile :: AppConfig -> IO AppConfig
-loadSecretFile conf = extractAndTransform mSecret
-  where
-    mSecret   = decodeUtf8 <$> configJwtSecret conf
-    isB64     = configJwtSecretIsBase64 conf
-
-    extractAndTransform :: Maybe Text -> IO AppConfig
-    extractAndTransform Nothing  = return conf
-    extractAndTransform (Just s) =
-      fmap setSecret $ transformString isB64 =<<
-        case stripPrefix "@" s of
-            Nothing       -> return s
-            Just filename -> readFile (toS filename)
-
-    transformString :: Bool -> Text -> IO ByteString
-    transformString False t = return . encodeUtf8 $ t
-    transformString True  t =
-      case decode (encodeUtf8 $ replaceUrlChars t) of
-        Left errMsg -> panic $ pack errMsg
-        Right bs    -> return bs
-
-    setSecret bs = conf { configJwtSecret = Just bs }
-
-    replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
+setBuffering :: IO ()
+setBuffering = do
+  -- LineBuffering: the entire output buffer is flushed whenever a newline is
+  -- output, the buffer overflows, a hFlush is issued or the handle is closed
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stdin LineBuffering
+  hSetBuffering stderr LineBuffering

nix/Dockerfile

@@ -0,0 +1,22 @@
+# This Dockerfile is only used as a development environment for
+# non-nix systems, i.e. Windows.
+
+FROM nixos/nix:latest
+
+RUN apk --no-cache add \
+    wget
+
+RUN nix-env -iA cachix -f https://cachix.org/api/v1/install \
+ && cachix use postgrest
+
+# We need an unprivileged user here, to make PG run at all.
+RUN adduser --disabled-password --ingroup root nix \
+ && chown -R nix:root /nix
+USER nix:root
+ENV USER=nix
+
+VOLUME /nix
+VOLUME /postgrest
+WORKDIR /postgrest
+
+CMD nix-shell

nix/README.md

@@ -0,0 +1,260 @@
+# Nix development and build environment
+
+With Nix it's possible to quickly and reliably recreate the full environments
+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.
+
+## Building PostgREST
+
+To build PostgREST from your local checkout of the repository, run:
+
+```bash
+nix-build --attr postgrestPackage
+
+```
+
+This will create a `result` directory that contains the PostgREST binary at
+`result/bin/postgrest`. The `--attr` parameter (or short: `-A`) tells Nix to
+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.
+
+## Binary cache
+
+We recommend that you use the PostgREST binary cache on
+[cachix](https://cachix.org/):
+
+```bash
+# Install cachix:
+nix-env -iA cachix -f https://cachix.org/api/v1/install
+
+# Set cachix up to use the PostgREST binary cache:
+cachix use postgrest
+
+```
+
+Without cachix, your machine will have to rebuild all the dependencies that are
+derived on top of `Musl` for the static builds, which can take a very long time.
+
+## Developing
+
+A development environment for PostgREST is available with `nix-shell`. The
+following command will put you into a new shell that has GHC and Cabal on the
+PATH:
+
+```bash
+nix-shell
+
+```
+
+Within `nix-shell`, you can run Cabal commands as usual. You can also run
+stack with the `--nix` option, which causes stack to pick up the non-Haskell
+dependencies from the same pinned Nixpkgs version that the Nix builds use.
+
+## Working with `nix-shell` and the PostgREST utility scripts
+
+The PostgREST utilities available in `nix-shell` all have names that begin with
+`postgrest-`, so you can use tab completion (typing `postgrest-` and pressing
+`<tab>`) in `nix-shell` to see all that are available:
+
+```bash
+# Note: The utilities listed here might not be up to date.
+[nix-shell]$ postgrest-<tab>
+postgrest-build                   postgrest-test-spec
+postgrest-check                   postgrest-watch
+postgrest-clean                   postgrest-with-all
+postgrest-coverage                postgrest-with-postgresql-10
+postgrest-lint                    postgrest-with-postgresql-11
+postgrest-run                     postgrest-with-postgresql-12
+postgrest-style                   postgrest-with-postgresql-13
+postgrest-style-check             postgrest-with-postgresql-9.6
+postgrest-test-io
+...
+
+[nix-shell]$
+
+```
+
+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:
+
+```bash
+$ nix-shell --arg memory true
+[nix-shell]$ postgrest-<tab>
+postgrest-build                   postgrest-test-spec
+postgrest-check                   postgrest-watch
+postgrest-clean                   postgrest-with-all
+postgrest-coverage                postgrest-with-postgresql-10
+postgrest-lint                    postgrest-with-postgresql-11
+postgrest-run                     postgrest-with-postgresql-12
+postgrest-style                   postgrest-with-postgresql-13
+postgrest-style-check             postgrest-with-postgresql-9.6
+postgrest-test-io
+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
+completion will not work with `nix-shell --run`, as Nix has yet to evaluate
+our Nix expressions to see which utilities are available.
+
+```bash
+$ nix-shell --run postgrest-style
+
+# Note that you need to quote any arguments that you would like to pass to
+# the command to be run in nix-shell:
+$ nix-shell --run "postgrest-foo --bar"
+
+```
+
+A third option is to install utilities that you use very often locally:
+
+```bash
+$ nix-env -f default.nix -iA devTools
+
+# `postgrest-style` can now be run directly:
+$ postgrest-style
+
+```
+
+If you use `nix-shell` very often, you might like to use
+https://github.com/xzfc/cached-nix-shell, which skips evaluating all our Nix
+expressions if nothing changed, reducing startup time for the shell
+considerably.
+
+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
+# 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
+```
+
+## 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
+temporary test databases:
+
+```bash
+# Run the tests against the most recent version of PostgreSQL:
+$ nix-shell --run postgrest-test-spec
+
+# Run the tests against all supported versions of PostgreSQL:
+$ nix-shell --run "postgrest-with-all postgrest-test-spec"
+
+# Run the tests against a specific version of PostgreSQL (use tab-completion in
+# nix-shell to see all available versions):
+$ nix-shell --run "postgrest-with-postgresql-13 postgrest-test-spec"
+
+```
+
+The io-test that test PostgREST as a black box with inputs and outputs can be
+run with `postgrest-test-io`. The test runner under the hood is
+[pytest](https://docs.pytest.org/) and you can pass it the usual options:
+
+```bash
+# Filter the tests to run by name, including all that contain 'config':
+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
+
+```
+
+## Linting and styling code
+
+The nix-shell also contains scripts for linting and styling the PostgREST
+source code:
+
+```bash
+# Linting
+$ nix-shell --run postgrest-lint
+
+# Styling / auto-formatting code
+$ 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.
+
+## General development tools
+
+Tools like `postgrest-build`, `postgrest-run` 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.
+
+`postgrest-with-postgresql-*` take a command as an argument and will run it
+with a temporary database. `postgrest-with-all` will run the command against
+all supported PostgreSQL versions. Tests run without `postgrest-with-*` are
+run against the latest PostgreSQL version by default.
+
+`postgrest-watch` takes a command as an argument that it will re-run if any source
+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.
+
+## Tour
+
+The following is not required for working on PostgREST with Nix, but it will
+give you some more background and details on how it works.
+
+### `default.nix`
+
+[`default.nix`](../default.nix) is our 'repository expression' that pulls all
+the pieces that we define with Nix together. It returns a set (like a dict in
+other programming languages), where each attribute is a derivation that Nix
+knows how to build, like the `postgrest` attribute from earlier.
+
+Internally, our `default.nix` uses the `pkgs.callPackage` function to import
+the modules that we defined in the `nix` directory. It automatically passes the
+arguments those modules require if they are available in `pkgs` (this means
+that `pkgs` is defined in terms of itself, better not to think too much about
+that).
+
+We also use `default.nix` to load our pinned version of the `nixpkgs`
+repository. This set of packages will always be the same, independently from
+where or when you use it. The pinned version can be upgraded with the small
+`nixpkgs-upgrade` utility. Running `nixpkgs-upgrade > nix/nixpkgs-version.nix`
+in `nix-shell` will upgrade the pinned version to the latest `nixpkgs-unstable`
+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`
+attribute with useful utilities that will be put on the PATH in `nix-shell`.
+
+### `nix/overlays`
+
+Our overlays to the Nix package set are defined here. They allow us to tweak our
+`pkgs` in `default.nix` by adding new packages or overriding existing ones.
+
+## Upgrading dependencies
+
+See the [upgrading checklist](UPGRADE.md) for how to upgrade the PostgREST
+dependencies.

nix/UPGRADE.md

@@ -0,0 +1,91 @@
+# Checklist for upgrading Nix dependencies
+
+The Nix dependencies of PostgREST should be updated regularly, in most cases it
+should be a very simple operation.
+
+```bash
+# Update pinned version of Nixpkgs
+nix-shell --run postgrest-nixpkgs-upgrade
+
+# Verify that everything builds
+nix-build
+```
+
+The following checklist guides you through the complete process in more detail.
+
+## Upgrade the pinned version of `nixpkgs`
+
+The pinned version of [`nixpkgs`](https://github.com/NixOS/nixpkgs) is defined
+in [`nix/nixpkgs-version.nix`](nixpkgs-version.nix). The pin refers directly to
+a GitHub tarball for the given revision, which is more efficient than pulling
+the complete Git repository. To upgrade it to the current `main` of
+`nixpkgs`, you can use a small utility script defined in
+[`nix/nixpkgs-update.nix`](nixpkgs-update.nix):
+
+```bash
+# From the root of the repository, enter nix-shell
+nix-shell
+
+# Run the utility script to pin the latest revision in main
+postgrest-nixpkgs-upgrade
+
+# Exit the nix-shell with Ctrl-d
+
+```
+
+## Update pinned version of `static-haskell-nix`
+
+We pin [`static-haskell-nix`](https://github.com/nh2/static-haskell-nix) in
+[`nix/static-haskell-package.nix`](static-haskell-package.nix). Upgrade the
+pinned revision and the tarball hash if necessary. See
+[`nix/nixpkgs-upgrade.nix`](nixpkgs-upgrade.nix) for how to get the correct
+tarball hash, or just change the hash to an arbitrary value of correct length,
+run `nix-build` and use the expected value from the resulting error message.
+
+## Review overlays
+
+Check whether the individual [overlays](overlays) are still required.
+
+## Check if patches are still required and update them as needed
+
+We track a number of PostgREST-specific patches in [`nix/patches`](patches).
+Check whether the pull-requests/issues linked in the
+[`default.nix`](patches/default.nix) have progressed and remove/modify the
+patches if they did. If conflicting changes occurred, you might have to rebase
+the respective patches.
+
+## Build everything
+
+Using the PostgREST binary Nix cache is recommended. Install
+[Cachix](https://cachix.org/) and run `cachix use postgrest`.
+
+Run `nix-build` in the root directory of the project to build all PostgREST
+artifacts. This might take a long time, e.g. when our static GHC version needs
+to be rebuilt due to changes to some underlying package. If there are any
+errors, this is probably due to one of our patches. Try to fix them and re-run
+`nix-build` until everything builds.
+
+## Update the PostgREST binary cache
+
+If you have access to the PostgREST cachix signing key, you can push the
+artifacts that you built locally to the binary cache. This will accelerate the
+CI builds and tests, sometimes dramatically. This might sometimes even be
+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.
+
+To push all new artifacts to Cachix, run:
+
+```
+nix-store -qR --include-outputs $$(nix-instantiate) | cachix push postgrest
+
+# Or, equivalently
+nix-shell --run postgrest-push-cachix
+
+```
+
+The `nix-store` command will query the nix-store to list all dependencies and
+build artifacts of PostgREST. The `cachix` command will efficiently push
+everything that is not yet cached to the binary cache.

nix/docker-compose.yml

@@ -0,0 +1,12 @@
+version: '3'
+
+services:
+  nix:
+    container_name: postgrest-nix
+    build: .
+    volumes:
+      - ../:/postgrest
+      - nix:/nix
+
+volumes:
+  nix:

nix/hsie/Main.hs

@@ -0,0 +1,361 @@
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+-- | Haskell Imports and Exports tool
+--
+-- This tool parses imports and exports from Haskell source files and provides
+-- analysis on these imports. For example, you can check whether consistent
+-- import aliases are used across your codebase.
+
+module Main (main) where
+
+import qualified Data.Aeson                              as JSON
+import qualified Data.ByteString.Lazy.Char8              as LBS8
+import qualified Data.Csv                                as Csv
+import qualified Data.List                               as List
+import qualified Data.Map                                as Map
+import qualified Data.Set                                as Set
+import qualified Data.Text                               as T
+import qualified Data.Text.IO                            as T
+import qualified Dot
+import qualified GHC
+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.Generics               (Generic)
+import GHC.Hs.Extension           (GhcPs)
+import Module                     (moduleNameString)
+import OccName                    (occNameString)
+import RdrName                    (rdrNameOcc)
+import System.Directory.Recursive (getFilesRecursive)
+import System.Exit                (exitFailure)
+
+-- TYPES
+
+data Options =
+  Options
+    { command :: Command
+    , sources :: [FilePath]
+    }
+
+data Command
+  = Dump OutputFormat
+  | GraphSymbols
+  | GraphModules
+  | CheckAliases
+  | CheckWildcards [Text]
+
+data OutputFormat = OutputCsv | OutputJson
+
+data ImportedSymbol =
+  ImportedSymbol
+    { impFromModule :: Text
+    , impModule     :: Text
+    , impQualified  :: ImportQualified
+    , impAlias      :: Maybe Text
+    , impType       :: ImportType
+    , impSymbol     :: Maybe Text
+    , impInternal   :: ModuleInternal
+    , impSource     :: FilePath
+    , impFile       :: FilePath
+    }
+    deriving (Generic, Csv.ToNamedRecord, Csv.DefaultOrdered, JSON.ToJSON)
+
+data ImportQualified
+  = Qualified
+  | NotQualified
+  deriving (Eq, Generic, JSON.ToJSON)
+
+instance Csv.ToField ImportQualified where
+  toField Qualified    = "qualified"
+  toField NotQualified = "not qualified"
+
+data ModuleInternal
+  = Internal
+  | External
+  deriving (Eq, Generic, JSON.ToJSON)
+
+instance Csv.ToField ModuleInternal where
+  toField Internal = "internal"
+  toField External = "external"
+
+data ImportType
+  = Wildcard
+  | Hiding
+  | Explicit
+  deriving (Eq, Generic, JSON.ToJSON)
+
+instance Csv.ToField ImportType where
+  toField Wildcard = "wildcard"
+  toField Hiding   = "hiding"
+  toField Explicit = "explicit"
+
+-- | Mapping of modules to their aliases and to the files they are found in
+type ModuleAliases = [(Text, [(Text, [FilePath])])]
+
+-- | Mapping of modules to files
+type WildcardImports = [(FilePath, [Text])]
+
+
+-- MAIN
+
+main :: IO ()
+main =
+  run =<< O.customExecParser prefs infoOpts
+  where
+    prefs = O.prefs $ O.subparserInline <> O.showHelpOnEmpty
+    infoOpts =
+      O.info (O.helper <*> opts) $
+        O.fullDesc
+        <> O.header "hsie - Swiss army knife for HaSkell Imports and Exports"
+        <> O.progDesc "Parse Haskell code to analyze imports and exports"
+    opts =
+      Options <$> commandOption <*> O.some srcOption
+    srcOption =
+      O.argument O.str $
+        O.metavar "SRCDIR"
+        <> O.help "Haskell source directory"
+        <> O.action "directory"
+    commandOption =
+      O.subparser $
+        command "dump-imports" "Dump imported symbols as CSV or JSON"
+          (Dump <$> jsonOutputFlag)
+        <> command "graph-modules" "Print dot graph of module imports"
+             (pure GraphModules)
+        <> command "graph-symbols" "Print dot graph of symbol imports"
+             (pure GraphSymbols)
+        <> command "check-aliases"
+             "Check that aliases of imported modules are consistent"
+             (pure CheckAliases)
+        <> command "check-wildcards"
+             "Check that no modules are imported as unqualified wildcards"
+             (CheckWildcards <$> O.many okModuleOption)
+    command name desc options =
+      O.command name . O.info (O.helper <*> options) $ O.progDesc desc
+    jsonOutputFlag =
+      O.flag OutputCsv OutputJson $
+        O.long "json" <> O.short 'j' <> O.help "Output JSON"
+    okModuleOption =
+      O.strOption $
+        O.long "ok"
+        <> O.short 'o'
+        <> O.metavar "OKMODULE"
+        <> O.help "Module that is ok to import as unqualified wildcard"
+
+run :: Options -> IO ()
+run Options{command, sources} =
+  runCommand command . markInternal . concat =<< mapM sourceSymbols sources
+  where
+    runCommand :: Command -> [ImportedSymbol] -> IO ()
+    runCommand (Dump format) = LBS8.putStr . dump format
+    runCommand GraphSymbols = T.putStr . symbolsGraph
+    runCommand GraphModules = T.putStr . Dot.encode . modulesGraph
+    runCommand CheckAliases = runInconsistentAliases . inconsistentAliases
+    runCommand (CheckWildcards okModules) = runWildcards . wildcards okModules
+
+    runInconsistentAliases :: ModuleAliases -> IO ()
+    runInconsistentAliases [] = T.putStrLn "No inconsistent module aliases found."
+    runInconsistentAliases xs = T.putStr (formatInconsistentAliases xs) >> exitFailure
+
+    runWildcards :: WildcardImports -> IO ()
+    runWildcards [] = T.putStrLn "No unwanted wildcard imports found."
+    runWildcards xs = T.putStr (formatWildcards xs) >> exitFailure
+
+-- | Mark imports from modules that are among the analyzed ones as internal.
+markInternal :: [ImportedSymbol] -> [ImportedSymbol]
+markInternal symbols =
+  fmap mark symbols
+  where
+    mark s = s { impInternal = if isInternal s then Internal else External }
+    isInternal = flip Set.member internalModules . impModule
+    internalModules = Set.fromList $ fmap impFromModule symbols
+
+
+-- SYMBOLS
+
+-- | Parse all imported symbols from a source of Haskell source files
+sourceSymbols :: FilePath -> IO [ImportedSymbol]
+sourceSymbols source = do
+  files <- filterExts [".hs", ".imports"] <$> getFilesRecursive source
+  concat <$> mapM moduleSymbols files
+  where
+    filterExts exts = filter $ flip elem exts . FP.takeExtension
+    moduleSymbols filepath = do
+      GHC.HsModule{..} <- parseModule filepath
+      return $ concatMap (importSymbols source filepath . GHC.unLoc) hsmodImports
+
+-- | Parse a Haskell module
+parseModule :: String -> IO (GHC.HsModule GhcPs)
+parseModule filepath = do
+  result <- ExactPrint.parseModule filepath
+  case result of
+    Right (_, hsmod) ->
+      return $ GHC.unLoc hsmod
+    Left errs ->
+      fail $ "Errors with " <> show filepath <> ":\n    "
+        <> List.intercalate "\n    " (show <$> bagToList errs)
+
+-- | Symbols imported in an import declaration.
+--
+-- 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) ->
+      symbol (if hiding then Hiding else Explicit) . Just . GHC.unLoc <$> GHC.unLoc syms
+    Nothing ->
+      [ symbol Wildcard Nothing ]
+  where
+    symbol hiding sym =
+      ImportedSymbol
+        { impFile = relativePath filepath
+        , impSource = source
+        , impFromModule = T.pack $ moduleFromPath filepath
+        , impModule = T.pack . moduleNameString . GHC.unLoc $ ideclName
+        , impQualified = if ideclQualified /= GHC.NotQualified then Qualified else NotQualified
+        , impAlias = T.pack . moduleNameString . GHC.unLoc <$> ideclAs
+        , impInternal = External
+        , impType = hiding
+        , impSymbol = T.pack . occNameString . rdrNameOcc . GHC.ieName <$> sym
+        }
+    moduleFromPath =
+      intercalate "." . FP.splitDirectories . FP.dropExtension . relativePath
+    relativePath = FP.makeRelative source
+
+
+-- DUMP
+
+-- | Dump list of symbols as CSV or JSON
+dump :: OutputFormat -> [ImportedSymbol] -> LBS8.ByteString
+dump OutputCsv  = Csv.encodeDefaultOrderedByName
+dump OutputJson = encodePretty
+
+
+-- ALIASES
+
+-- | Find modules that are imported under different aliases
+inconsistentAliases :: [ImportedSymbol] -> ModuleAliases
+inconsistentAliases symbols =
+  fmap moduleAlias symbols
+    & foldr insertSetMapMap Map.empty
+    & Map.map (aliases . Map.toList)
+    & Map.filter ((<) 1 . length)
+    & Map.toList
+  where
+    moduleAlias ImportedSymbol{..} =
+      (impModule, impAlias, FP.joinPath [impSource, impFile])
+    insertSetMapMap (k1, k2, v) =
+      Map.insertWith (Map.unionWith Set.union) k1
+        (Map.singleton k2 $ Set.singleton v)
+    aliases :: [(Maybe Text, Set.Set FilePath)] -> [(Text, [FilePath])]
+    aliases = mapMaybe (\(k, v) -> fmap (, Set.toList v) k)
+
+formatInconsistentAliases :: ModuleAliases -> Text
+formatInconsistentAliases modules =
+  "The following imports have inconsistent aliases:\n\n"
+    <> T.concat (fmap formatModule modules)
+  where
+    formatModule (modName, aliases) =
+      "Module '"
+        <> modName
+        <> "' has the aliases:\n"
+        <> T.concat (fmap formatAlias aliases)
+        <> "\n"
+    formatAlias (alias, sourceFiles) =
+      "  '"
+        <> alias
+        <> "' in file"
+        <> (if length sourceFiles > 2 then "s" else "")
+        <> ":\n"
+        <> T.concat (fmap formatFile sourceFiles)
+    formatFile sourceFile =
+      "    " <> T.pack sourceFile <> "\n"
+
+
+-- WILDCARDS
+
+-- | Find modules that are imported as wildcards, excluding whitelisted modules.
+--
+-- Wildcard imports are ones that are not qualified and do not specify which
+-- symbols should be imported.
+wildcards :: [Text] -> [ImportedSymbol] -> WildcardImports
+wildcards okModules =
+  groupByFile . filter isWildcard . filter (not . isOkModule)
+  where
+    isWildcard ImportedSymbol{..} =
+      impQualified == NotQualified && impType /= Explicit
+    isOkModule = flip Set.member (Set.fromList okModules) . impModule
+    groupByFile = Map.toList . fmap Set.toList . foldr insertMap Map.empty
+    insertMap ImportedSymbol{..} =
+      Map.insertWith Set.union impFile (Set.singleton impModule)
+
+formatWildcards :: WildcardImports -> Text
+formatWildcards files =
+  "Modules in the following files were imported as wildcards:\n\n"
+    <> T.concat (fmap formatFile files)
+  where
+    formatFile (filepath, modules) =
+      "In " <> T.pack filepath <> ":\n" <> T.concat (fmap formatModule modules) <> "\n"
+    formatModule moduleName = "  " <> moduleName <> "\n"
+
+
+-- GRAPHS
+
+modulesGraph :: [ImportedSymbol] -> Dot.DotGraph
+modulesGraph symbols =
+  Dot.DotGraph Dot.Strict Dot.Directed (Just "Modules") $ fmap edge edges
+  where
+    edge (from, to) =
+      Dot.StatementEdge $ Dot.EdgeStatement
+        (Dot.ListTwo (edgeNode from) (edgeNode to) mempty) mempty
+    edgeNode t = Dot.EdgeNode $ Dot.NodeId (Dot.Id t) Nothing
+    edges = unique . fmap edgeTuple . filter ((==) Internal . impInternal) $ symbols
+    edgeTuple ImportedSymbol{..} = (impFromModule, impModule)
+    unique = Set.toList . Set.fromList
+
+-- Building Text directly as the Dot package currently doesn't support subgraphs.
+symbolsGraph :: [ImportedSymbol] -> Text
+symbolsGraph symbols =
+  "digraph Symbols {\n"
+    <> "  rankdir=LR\n"
+    <> "  ranksep=5\n"
+    <> T.concat (fmap edge edges)
+    <> T.concat (fmap cluster symbolsByModule)
+    <> "}\n"
+  where
+    edge (from, to, symbol) =
+      "  "
+        <> quoted from
+        <> " -> "
+        <> quoted (to <> maybe "" ("." <>) symbol)
+        <> "\n"
+    cluster (moduleName, clusterSymbols) =
+      "  subgraph "
+        <> quoted ("cluster_" <> moduleName)
+        <> " {\n"
+        <> "    " <> quoted moduleName <> "\n"
+        <> T.concat (fmap (clusterNode moduleName) clusterSymbols)
+        <> "  }\n"
+    clusterNode moduleName symbol =
+      "    " <> quoted (moduleName <> "." <> symbol) <> "\n"
+    quoted t = "\"" <> t <> "\""
+    edges = unique . fmap edgeTuple . filter ((==) Internal . impInternal) $ symbols
+    edgeTuple ImportedSymbol{..} = (impFromModule, impModule, impSymbol)
+    unique = Set.toList . Set.fromList
+    symbolsByModule =
+      Map.toList . Map.map (catMaybes . Set.toList) . foldr insertMap Map.empty $ edges
+    insertMap (_, to, symbol) = Map.insertWith Set.union to $ Set.singleton symbol

nix/hsie/README.md

@@ -0,0 +1,67 @@
+# hsie - Swiss army knife for HaSkell Imports and Exports
+
+This tool parses Haskell source code to analyse the imports and exports in a
+project. It's available in PostgREST's `nix-shell` by default.
+
+## Dumping imports
+
+Given source code in the directories `src` and `main`, for example, you can run:
+
+```
+hsie dump-imports src main
+```
+
+This dumps all imports of the modules in the given directory to a CSV file,
+printed on `stdout`.
+
+To dump to a JSON file (e.g., to further process with `jq`), add the `--json`
+flag:
+
+```
+hsie dump-imports --json src main
+```
+
+## Graphing imports
+
+The tool can generate `graphviz` graphs of module and symbol imports by printing
+a file to `stdout` that can directly be rendered with `dot`:
+
+```
+hsie graph-modules src main | dot -Tpng -o modules.png
+```
+
+The command `graph-modules` prints a graph of which modules insert which other
+modules. `graph-symbols` shows which symbols are imported from which modules.
+
+## Checking imports
+
+To check whether modules are imported under consistent aliases in your project,
+run:
+
+```
+hsie check-aliases main src
+```
+
+This will exit with a non-zero exit code if any inconsistent aliases are found.
+
+The following command checks whether any modules are imported as wildcards, i.e.
+not qualified and without specifying symbols.
+
+```
+hsie check-wildcards main src
+```
+
+To whitelist certain modules to be imported as wildcards, use `--ok`:
+
+```
+hsie check-wildcards main src --ok Protolude --ok Test.Module
+```
+
+## Current limitations
+
+This tool uses the GHC parser to parse Haskell source code. Language extensions
+required to parse each file are detected based on the `{-# LANGUAGE ... #-}`
+pragmas. If they are not available (e.g., as they are listed as default
+extensions in the `.cabal` file), parses may fail. We can fix this by using
+an extended set of non-conflicting extensions by default, as `hlint` does for
+example.

nix/hsie/default.nix

@@ -0,0 +1,30 @@
+{ ghcWithPackages
+, runCommand
+}:
+let
+  name = "hsie";
+  src = ./Main.hs;
+  modules = ps: [
+    ps.aeson
+    ps.aeson-pretty
+    ps.cassava
+    ps.dir-traverse
+    ps.dot
+    ps.ghc-exactprint
+    ps.optparse-applicative
+  ];
+  ghc = ghcWithPackages modules;
+  hsie =
+    runCommand "haskellimports" { inherit name src; }
+      "${ghc}/bin/ghc -O -Werror -Wall -package ghc $src -o $out";
+  bin =
+    runCommand name { inherit hsie name; }
+      ''
+        mkdir -p $out/bin
+        ln -s $hsie $out/bin/$name
+      '';
+  bashCompletion =
+    runCommand "${name}-bash-completion" { inherit bin name; }
+      "$bin/bin/$name --bash-completion-script $bin/bin/$name > $out";
+in
+hsie // { inherit bashCompletion bin; }

nix/nixpkgs-version.nix

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

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

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

nix/overlays/build-toolbox/default.nix

@@ -0,0 +1,5 @@
+self: super:
+# Overlay that adds `buildToolbox`, an enhanced version of `buildEnv`
+{
+  buildToolbox = super.callPackage ./build-toolbox.nix { };
+}

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

@@ -0,0 +1,142 @@
+# Create a bash script that is checked with shellcheck. You can either use it
+# 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
+, coreutils
+, git
+, lib
+, runCommand
+, shellcheck
+, stdenv
+, writeTextFile
+}:
+{ name
+, docs
+, args ? [ ]
+, addCommandCompletion ? false
+, inRootDir ? false
+, redirectTixFiles ? true
+, withEnv ? null
+, withPath ? [ ]
+, withTmpDir ? false
+}: text:
+let
+  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
+
+      text =
+        ''
+          # BASH_ARGV0 sets $0 - which is used in parser.sh for usage information
+          # stripping the /nix/store/... path for nicer display
+          BASH_ARGV0="$(basename "$0")"
+
+          # ARG_HELP([${name}], [${escapedDocs}])
+          ${lib.strings.concatMapStrings (arg: "# " + arg) args}
+          # ARG_POSITIONAL_DOUBLEDASH()
+          # ARG_DEFAULTS_POS()
+          # ARGBASH_GO
+
+        '';
+    };
+
+  argsParser =
+    runCommand "${name}-parser" { }
+      ''
+        ${argbash}/bin/argbash ${argsTemplate}/${name}.m4 > $out
+
+        # This forces optional arguments to go *before* positional arguments,
+        # which allows leftovers to pass optional arguments to sub-commands.
+        # Example: This way `postgrest-watch -h` will return the help output for watch, while
+        # `postgrest-watch postgrest-test-spec -h` will return the help output for test-spec.
+        # Taken from: https://github.com/matejak/argbash/issues/114#issuecomment-557108274
+        sed '/_positionals_count + 1/a\\t\t\t\tset -- "''${@:1:1}" "--" "''${@:2}"' -i $out
+      '';
+
+  bashCompletion =
+    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
+      ''
+    );
+
+  bin =
+    writeTextFile {
+      inherit name;
+      executable = true;
+      destination = "/bin/${name}";
+
+      text =
+        ''
+          #!${bash_5}/bin/bash
+          source ${argsParser}
+          set -euo pipefail
+        ''
+
+        + lib.optionalString redirectTixFiles ''
+          # storing tix files in a temporary throw away directory avoids mix/tix conflicts after changes
+          hpctixdir=$(${coreutils}/bin/mktemp -d)
+          export HPCTIXFILE="$hpctixdir"/postgrest.tix
+          trap 'rm -rf $hpctixdir' EXIT
+        ''
+
+        + lib.optionalString inRootDir ''
+          cd "$(${git}/bin/git rev-parse --show-toplevel)"
+
+          if test ! -f postgrest.cabal; then
+            >&2 echo "Couldn't find postgrest.cabal. Please make sure to" \
+                     "run this command somewhere in the PostgREST repo."
+            exit 1
+          fi
+        ''
+
+        + lib.optionalString withTmpDir ''
+          mkdir -p "''${TMPDIR:-/tmp}/postgrest"
+          tmpdir="$(${coreutils}/bin/mktemp -d --tmpdir postgrest/${name}-XXX)"
+
+          # we keep the tmpdir when an error occurs for debugging
+          trap 'echo Temporary directory kept at: $tmpdir' ERR
+          # remove the tmpdir when cancelled (postgrest-watch)
+          trap 'rm -rf "$tmpdir"' SIGINT SIGTERM
+        ''
+
+        + lib.optionalString (withEnv != null) ''
+          env="$(cat ${withEnv})"
+          export PATH="$env/bin:$PATH"
+        ''
+
+        + lib.optionalString (lib.length withPath > 0) ''
+          export PATH="${lib.concatMapStrings (p: p + "/bin:") withPath}$PATH"
+        ''
+
+        + "(${text})"
+
+        + lib.optionalString withTmpDir ''
+
+          rm -rf "$tmpdir"
+        '';
+
+      checkPhase =
+        ''
+          # check syntax
+          ${stdenv.shell} -n $out/bin/${name}
+
+          # check for shellcheck recommendations
+          ${shellcheck}/bin/shellcheck -x $out/bin/${name}
+        '';
+    };
+
+  script =
+    runCommand name { inherit bin name; } "ln -s $bin/bin/$name $out";
+in
+script // { inherit bin bashCompletion; }

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

@@ -0,0 +1,6 @@
+self: super:
+# Overlay that adds `checkedShellScript`, an enhanced version of
+# writeShellScript and writeShellScriptBin
+{
+  checkedShellScript = super.callPackage ./checked-shell-script.nix { };
+}

nix/overlays/default.nix

@@ -0,0 +1,9 @@
+{
+  build-toolbox = import ./build-toolbox;
+  checked-shell-script = import ./checked-shell-script;
+  gitignore = import ./gitignore.nix;
+  haskell-packages = import ./haskell-packages.nix;
+  postgresql-default = import ./postgresql-default.nix;
+  postgresql-legacy = import ./postgresql-legacy.nix;
+  postgresql-future = import ./postgresql-future.nix;
+}

nix/overlays/gitignore.nix

@@ -0,0 +1,20 @@
+self: super:
+# Overlay that adds the `gitignoreSource` function from Hercules-CI.
+# This function is useful for filtering which files are added to the Nix store.
+# See: https://github.com/hercules-ci/gitignore.nix
+
+# To update to a newer revision, the simplest way is to add a new commit hash
+# from GitHub under `rev` and to then add the hash that Nix suggests on first
+# use.
+{
+  gitignoreSource =
+    let
+      gitignoreSrc = super.fetchFromGitHub {
+        owner = "hercules-ci";
+        repo = "gitignore";
+        rev = "211907489e9f198594c0eb0ca9256a1949c9d412";
+        sha256 = "06j7wpvj54khw0z10fjyi31kpafkr6hi1k0di13k1xp8kywvfyx8";
+      };
+    in
+    (super.callPackage gitignoreSrc { }).gitignoreSource;
+}

nix/overlays/haskell-packages.nix

@@ -0,0 +1,41 @@
+{ compiler, extraOverrides ? (final: prev: { }) }:
+
+self: super:
+let
+  inherit (self.haskell) lib;
+
+  overrides =
+    final: prev:
+    rec {
+      # To pin custom versions of Haskell packages:
+      #   protolude =
+      #     prev.callHackageDirect
+      #       {
+      #         pkg = "protolude";
+      #         ver = "0.3.0";
+      #         sha256 = "0iwh4wsjhb7pms88lw1afhdal9f86nrrkkvv65f9wxbd1b159n72";
+      #       }
+      #       { };
+      #
+      # To get the sha256:
+      #   nix-prefetch-url --unpack https://hackage.haskell.org/package/protolude-0.3.0/protolude-0.3.0.tar.gz
+
+      hasql-dynamic-statements =
+        lib.dontCheck (lib.unmarkBroken prev.hasql-dynamic-statements);
+
+      hasql-implicits =
+        lib.dontCheck (lib.unmarkBroken prev.hasql-implicits);
+
+      ptr =
+        lib.dontCheck (lib.unmarkBroken prev.ptr);
+    } // extraOverrides final prev;
+in
+{
+  haskell =
+    super.haskell // {
+      packages = super.haskell.packages // {
+        "${compiler}" =
+          super.haskell.packages."${compiler}".override { inherit overrides; };
+      };
+    };
+}

nix/overlays/postgresql-default.nix

@@ -0,0 +1,5 @@
+self: super:
+# Overlay that sets the default version of PostgreSQL.
+{
+  postgresql = super.postgresql_14;
+}

nix/overlays/postgresql-future.nix

@@ -0,0 +1,19 @@
+self: super:
+# Overlay that adds future versions of PostgreSQL that are supported by
+# PostgREST.
+{
+  ## 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;
+}

nix/overlays/postgresql-legacy.nix

@@ -0,0 +1,20 @@
+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
+  # 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;
+}

nix/patches/default.nix

@@ -0,0 +1,24 @@
+{ runCommand }:
+
+{
+  applyPatches =
+    name: src: patches:
+    runCommand
+      name
+      { inherit src patches; }
+      ''
+        set -eou pipefail
+
+        cp -r $src $out
+        chmod -R u+w $out
+
+        for patch in $patches; do
+          echo "Applying patch $patch"
+          patch -d "$out" -p1 < "$patch"
+        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;
+}

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

@@ -0,0 +1,76 @@
+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/static-haskell-package.nix

@@ -0,0 +1,67 @@
+# Derive a fully static Haskell package based on musl instead of glibc.
+{ nixpkgs, compiler, patches, allOverlays }:
+
+name: src:
+let
+  # The nh2/static-haskell-nix project does all the hard work for us.
+  static-haskell-nix =
+    let
+      rev = "bd66b86b72cff4479e1c76d5916a853c38d09837";
+    in
+    builtins.fetchTarball {
+      url = "https://github.com/nh2/static-haskell-nix/archive/${rev}.tar.gz";
+      sha256 = "0rnsxaw7v27znsg9lgqk1i4007ydqrc8gfgimrmhf24lv6galbjh";
+    };
+
+  patched-static-haskell-nix =
+    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
+      ];
+
+  extraOverrides =
+    final: prev:
+    rec {
+      # We need to add our package needs to the package set that we pass to
+      # static-haskell-nix. Using callCabal2nix on the haskellPackages that
+      # it returns would result in a dynamic build based on musl, and not the
+      # fully static build that we want.
+      "${name}" = prev.callCabal2nix name src { };
+    };
+
+  overlays =
+    [
+      allOverlays.postgresql-future
+      allOverlays.postgresql-default
+      (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
+      # tests)
+      (self: super:
+        { postgresql = super.postgresql.overrideAttrs (_: { doCheck = false; }); }
+      )
+    ];
+
+  # Apply our overlay to the given pkgs.
+  normalPkgs =
+    import patchedNixpkgs { inherit overlays; };
+
+  defaultCabalPackageVersionComingWithGhc =
+    {
+      ghc8107 = "Cabal_3_2_1_0";
+    }."${compiler}";
+
+  # The static-haskell-nix 'survey' derives a full static set of Haskell
+  # packages, applying fixes where necessary.
+  survey =
+    import "${patched-static-haskell-nix}/survey" { inherit normalPkgs compiler defaultCabalPackageVersionComingWithGhc; };
+in
+survey.haskellPackages."${name}"

nix/tools/cabalTools.nix

@@ -0,0 +1,57 @@
+{ buildToolbox
+, cabal-install
+, checkedShellScript
+, devCabalOptions
+, postgrest
+}:
+let
+  build =
+    checkedShellScript
+      {
+        name = "postgrest-build";
+        docs = "Build PostgREST interactively using cabal-install.";
+        args = [ "ARG_LEFTOVERS([Cabal arguments])" ];
+        inRootDir = true;
+        withEnv = postgrest.env;
+      }
+      ''
+        exec ${cabal-install}/bin/cabal v2-build ${devCabalOptions} "''${_arg_leftovers[@]}"
+      '';
+
+  clean =
+    checkedShellScript
+      {
+        name = "postgrest-clean";
+        docs = "Clean the PostgREST project, including all cabal-install artifacts.";
+        inRootDir = true;
+      }
+      ''
+        # clean old coverage data, too
+        rm -rf .hpc coverage
+        exec ${cabal-install}/bin/cabal v2-clean
+      '';
+
+  run =
+    checkedShellScript
+      {
+        name = "postgrest-run";
+        docs = "Run PostgREST after buidling it interactively with cabal-install";
+        args = [ "ARG_LEFTOVERS([PostgREST arguments])" ];
+        inRootDir = true;
+        withEnv = postgrest.env;
+      }
+      ''
+        exec ${cabal-install}/bin/cabal v2-run ${devCabalOptions} --verbose=0 -- \
+          postgrest "''${_arg_leftovers[@]}"
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-cabal";
+  tools = [
+    build
+    clean
+    run
+  ];
+}

nix/tools/devTools.nix

@@ -0,0 +1,154 @@
+{ buildToolbox
+, cabal-install
+, cachix
+, checkedShellScript
+, devCabalOptions
+, entr
+, graphviz
+, hsie
+, nix
+, silver-searcher
+, style
+, tests
+, withTools
+}:
+let
+  watch =
+    checkedShellScript
+      {
+        name = "postgrest-watch";
+        docs =
+          ''
+            Watch the project for changes and reinvoke the given command.
+
+            Example:
+              postgrest-watch postgrest-test-io
+          '';
+        args =
+          [
+            "ARG_POSITIONAL_SINGLE([command], [Command to run])"
+            "ARG_LEFTOVERS([command arguments])"
+          ];
+        addCommandCompletion = true;
+        redirectTixFiles = false; # will be done by sub-command
+        inRootDir = true;
+      }
+      ''
+        while true; do
+          (! ${silver-searcher}/bin/ag -l . | ${entr}/bin/entr -dr "$_arg_command" "''${_arg_leftovers[@]}")
+        done
+      '';
+
+  pushCachix =
+    checkedShellScript
+      {
+        name = "postgrest-push-cachix";
+        docs = ''
+          Push all build artifacts to cachix.
+
+          Requires authentication with `cachix authtoken ...`.
+        '';
+        inRootDir = true;
+      }
+      ''
+        ${nix}/bin/nix-instantiate \
+          | while read -r drv; do
+              ${nix}/bin/nix-store -qR --include-outputs "$drv"
+            done \
+          | ${cachix}/bin/cachix push postgrest
+      '';
+
+  check =
+    checkedShellScript
+      {
+        name = "postgrest-check";
+        docs =
+          ''
+            Run most checks that will also run on CI.
+
+            This currently excludes the memory 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-doctests
+        ${tests}/bin/postgrest-test-spec-idempotence
+        ${tests}/bin/postgrest-test-io
+        ${style}/bin/postgrest-lint
+        ${style}/bin/postgrest-style-check
+      '';
+
+  dumpMinimalImports =
+    checkedShellScript
+      {
+        name = "postgrest-dump-minimal-imports";
+        docs = "Dump minimal imports into given directory.";
+        args = [ "ARG_POSITIONAL_SINGLE([dumpdir], [Output directory])" ];
+        inRootDir = true;
+        withTmpDir = true;
+      }
+      ''
+        mkdir -p "$_arg_dumpdir"
+        ${cabal-install}/bin/cabal v2-build ${devCabalOptions} \
+          --builddir="$tmpdir" \
+          --ghc-option=-ddump-minimal-imports \
+          --ghc-option=-dumpdir="$_arg_dumpdir" \
+          1>&2
+
+        # Fix OverloadedRecordFields imports
+        # shellcheck disable=SC2016
+        sed -E 's/\$sel:.*://g' -i "$_arg_dumpdir"/*
+      '';
+
+  hsieMinimalImports =
+    checkedShellScript
+      {
+        name = "postgrest-hsie-minimal-imports";
+        docs = "Run hsie with a provided dump of minimal imports.";
+        args = [ "ARG_LEFTOVERS([hsie arguments])" ];
+        withTmpDir = true;
+      }
+      ''
+        ${dumpMinimalImports} "$tmpdir"
+        ${hsie} "$tmpdir" "''${_arg_leftovers[@]}"
+      '';
+
+  hsieGraphModules =
+    checkedShellScript
+      {
+        name = "postgrest-hsie-graph-modules";
+        docs = "Create a PNG graph of modules imported within the codebase.";
+        args = [ "ARG_POSITIONAL_SINGLE([outfile], [Output filename])" ];
+      }
+      ''
+        ${hsie} graph-modules main src | ${graphviz}/bin/dot -Tpng -o "$_arg_outfile"
+      '';
+
+  hsieGraphSymbols =
+    checkedShellScript
+      {
+        name = "postgrest-hsie-graph-symbols";
+        docs = "Create a PNG graph of symbols imported within the codebase.";
+        args = [ "ARG_POSITIONAL_SINGLE([outfile], [Output filename])" ];
+      }
+      ''
+        ${hsieMinimalImports} graph-symbols | ${graphviz}/bin/dot -Tpng -o "$_arg_outfile"
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-dev";
+  tools = [
+    watch
+    pushCachix
+    check
+    dumpMinimalImports
+    hsieMinimalImports
+    hsieGraphModules
+    hsieGraphSymbols
+  ];
+}

nix/tools/docker/README.md

@@ -0,0 +1,95 @@
+# Docker image built with Nix
+
+In order to build an optimal PostgREST Docker image, we create the image from
+scratch (i.e., without a parent image like `debian` or `alpine`), and only
+include the file that is essential for running PostgREST: the static
+PostgREST binary.
+
+This is similar to what you would get with the following `Dockerfile`:
+
+```Dockerfile
+# `scratch` is a minimal, reserved image in Docker, see
+# https://docs.docker.com/develop/develop-images/baseimages/ . It essentially
+# means "don't use a parent image and start with an empty one".
+FROM scratch
+
+# The static PostgREST executable has no runtime dependencies, so it's all we
+# need to include for running the application.
+ADD /absolute/path/to/postgrest /bin/postgrest
+
+EXPOSE 3000
+
+# This is the user id that Docker will run our image under by default. Note
+# that we don't actually add the user to `/etc/passwd` or `/etc/shadow`. This
+# means that tools like whoami would not work properly, but we don't include
+# those in the image anyway. Not adding the user has the benefit that the image
+# can be run under any user you specify.
+USER 1000
+
+CMD [ "/bin/postgrest" ]
+```
+
+# Building the Docker image with Nix
+
+As we are building the static PostgREST executable with Nix and that's the main
+input to the Docker file, we can also create the Docker image directly with Nix
+using the [`dockerTools`
+utilities](https://nixos.org/nixpkgs/manual/#sec-pkgs-dockerTools). Those
+utilities don't actually use `Dockerfiles` or Docker to build Docker images,
+but create them directly by putting together the required `json` and `tar`
+files that make up an image. This is more efficient, does not rely on Docker or
+root permissions and results in fully reproducible builds. See
+[`nix/docker/default.nix`](./default.nix) for details how the image is built.
+
+# Building and loading the image
+
+The Nix expression provides a helper script `postgrest-docker-load` that loads
+the optimized image into your local Docker instance (using `docker load -i
+<image file>` under the hood). You can use it by running:
+
+```
+# Running from the root directory of the repository:
+
+# Build the `docker` attribute from `default.nix`, the result will be symlinked
+# to `result`:
+nix-build -A docker
+
+# Run the loading script:
+result/bin/postgrest-docker-load
+```
+
+The Docker image built with Nix always has the name "postgrest:latest" when
+loaded.
+
+# Inspecting the optimized image
+
+The image does not come with the usual utilities like `bash` and `ls`.
+
+You can, however, explore the `tar` file of the image by saving it with `docker
+save postgrest:latest > image.tar`.
+
+[Dive](https://github.com/wagoodman/dive) is also useful for looking at the
+contents of the image:
+
+```
+┃ ● Layers ┣━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ │ Current Layer Contents ├────────────────────────────────────────────────────────────────────────────────
+Cmp   Size  Command                                                                                        Permission     UID:GID       Size  Filetree
+     14 MB  FROM 20ee65c811575d2                                                                           dr-xr-xr-x         0:0      14 MB  ├── bin
+                                                                                                           -r-xr-xr-x         0:0      14 MB  │   └── postgrest
+│ Layer Details ├───────────────────────────────────────────────────────────────────────────────────────── drwxr-xr-x         0:0      783 B  ├── etc
+                                                                                                           -r--r--r--         0:0      783 B  │   └── postgrest.conf
+Tags:   (unavailable)                                                                                      dr-xr-xr-x         0:0      23 kB  └── nix
+Id:     20ee65c811575d206eb673e1887e7f7e6b7ccde902a63ccb924c5faa50b32cee                                   dr-xr-xr-x         0:0      23 kB      └── store
+Digest: sha256:ece77302b83fd38fb54395dabc10c2eba06fc1d1933801d36cc2c4732d9c8f38                            dr-xr-xr-x         0:0      23 kB          └── s440jbrn94wmpzy7f8yfsp6jr2shllw5-openssl-1.1.1g-etc
+Command:                                                                                                   dr-xr-xr-x         0:0      23 kB              └── etc
+                                                                                                           dr-xr-xr-x         0:0      23 kB                  └── ssl
+                                                                                                           -r--r--r--         0:0      412 B                      ├── ct_log_list.cnf
+│ Image Details ├───────────────────────────────────────────────────────────────────────────────────────── -r--r--r--         0:0      412 B                      ├── ct_log_list.cnf.dist
+                                                                                                           dr-xr-xr-x         0:0        0 B                      ├── engines-1.1
+                                                                                                           -r--r--r--         0:0      11 kB                      ├── openssl.cnf
+Total Image size: 14 MB                                                                                    -r--r--r--         0:0      11 kB                      └── openssl.cnf.dist
+Potential wasted space: 0 B
+Image efficiency score: 100 %
+
+Count   Total Space  Path
+```

nix/tools/docker/default.nix

@@ -0,0 +1,49 @@
+{ buildToolbox
+, postgrest
+, dockerTools
+, checkedShellScript
+}:
+let
+  image =
+    dockerTools.buildImage {
+      name = "postgrest";
+      tag = "latest";
+      contents = 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.
+      created = "now";
+
+      extraCommands =
+        ''
+          rmdir share
+        '';
+
+      config = {
+        Cmd = [ "/bin/postgrest" ];
+        User = "1000";
+        ExposedPorts = {
+          "3000/tcp" = { };
+        };
+      };
+    };
+
+  load =
+    checkedShellScript
+      {
+        name = "postgrest-docker-load";
+        docs = "Load the PostgREST image into Docker.";
+      }
+      ''
+        docker load -i ${image}
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-docker";
+  tools = [ load ];
+  extra = {
+    inherit image;
+  };
+}

nix/tools/memory.nix

@@ -0,0 +1,28 @@
+# The memory tests have large dependencies (a profiled build of PostgREST)
+# and are run less often than the spec tests, so we don't include them in
+# the default test environment. We make them available through a separate module.
+{ buildToolbox
+, checkedShellScript
+, curl
+, postgrestProfiled
+, withTools
+}:
+let
+  test =
+    checkedShellScript
+      {
+        name = "postgrest-test-memory";
+        docs = "Run the memory tests.";
+        inRootDir = true;
+        withPath = [ postgrestProfiled curl ];
+      }
+      ''
+        ${withTools.latest} test/memory-tests.sh
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-memory";
+  tools = [ test ];
+}

nix/tools/nixpkgsTools.nix

@@ -0,0 +1,53 @@
+{ buildToolbox
+, checkedShellScript
+, curl
+, jq
+, nix
+}:
+# Utility script for pinning the latest unstable version of Nixpkgs.
+
+# Instead of pinning Nixpkgs based on the huge Git repository, we reference a
+# specific tarball that only contains the source of the revision that we want
+# to pin.
+let
+  name =
+    "postgrest-nixpkgs-upgrade";
+
+  refUrl =
+    "https://api.github.com/repos/nixos/nixpkgs/git/ref/heads/nixpkgs-unstable";
+
+  githubV3Header =
+    "Accept: application/vnd.github.v3+json";
+
+  tarballUrlBase =
+    "https://github.com/nixos/nixpkgs/archive/";
+
+  upgrade =
+    checkedShellScript
+      {
+        inherit name;
+        docs = "Pin the newest unstable version of Nixpkgs.";
+        inRootDir = true;
+      }
+      ''
+        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)"
+
+        cat > nix/nixpkgs-version.nix << EOF
+        # Pinned version of Nixpkgs, generated with ${name}.
+        {
+          date = "$currentDate";
+          rev = "$commitHash";
+          tarballHash = "$tarballHash";
+        }
+        EOF
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-nixpkgs";
+  tools = [ upgrade ];
+}

nix/tools/release/default.nix

@@ -0,0 +1,54 @@
+{ buildToolbox
+, checkedShellScript
+, curl
+, jq
+}:
+let
+  dockerHubDescription =
+    let
+      description =
+        ./docker-hub-description.md;
+
+      fullDescription =
+        ./docker-hub-full-description.md;
+    in
+    checkedShellScript
+      {
+        name = "postgrest-release-dockerhub-description";
+        docs = "Update the repository description on Docker Hub.";
+        args = [
+          "ARG_USE_ENV([DOCKER_USER], [], [DockerHub user name])"
+          "ARG_USE_ENV([DOCKER_PASS], [], [DockerHub password])"
+          "ARG_USE_ENV([DOCKER_REPO], [], [DockerHub repository])"
+        ];
+      }
+      ''
+        # 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
+        : "''${DOCKER_USER:?DOCKER_USER is required}"
+        : "''${DOCKER_PASS:?DOCKER_PASS is required}"
+        : "''${DOCKER_REPO:?DOCKER_REPO is required}"
+
+        echo "Logging in to Docker Hub to get an auth token..."
+        token="$(
+          ${curl}/bin/curl --fail -s \
+            --data-urlencode "username=$DOCKER_USER" \
+            --data-urlencode "password=$DOCKER_PASS" \
+            "https://hub.docker.com/v2/users/login/" \
+           | ${jq}/bin/jq -r .token
+        )"
+
+        repo_url="https://hub.docker.com/v2/repositories/$DOCKER_REPO/postgrest/"
+        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}
+      '';
+in
+buildToolbox
+{
+  name = "postgrest-release";
+  tools = [ dockerHubDescription ];
+}

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

@@ -0,0 +1 @@
+REST API for any Postgres database

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

@@ -0,0 +1,70 @@
+# PostgREST
+
+[![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)
+[![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)
+[![Docs](https://img.shields.io/badge/docs-latest-brightgreen.svg?style=flat)](http://postgrest.org)
+[![Build Status](https://github.com/postgrest/postgrest/actions/workflows/ci.yaml/badge.svg?branch=main)](https://github.com/PostgREST/postgrest/actions?query=branch%3Amain)
+
+PostgREST serves a fully RESTful API from any existing PostgreSQL database. It
+provides a cleaner, more standards-compliant, faster API than you are likely to
+write from scratch.
+
+## Sponsors
+
+<table>
+  <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">
+        </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>
+      </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>
+      </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>
+      </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="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/supabase.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="https://raw.githubusercontent.com/PostgREST/postgrest/main/static/oblivious.jpg">
+        </a>
+      </td>
+    </tr>
+  </tbody>
+</table>
+
+# Usage
+
+To learn how to use this container, see the [PostgREST Docker
+documentation](https://postgrest.com/en/stable/install.html#docker).
+
+You can configure the PostgREST image by setting
+[enviroment 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
+no commands are listed in the image history. See the [PostgREST
+respository](https://github.com/PostgREST/postgrest/tree/main/nix/docker) for
+details on the build process and how to inspect the image.

nix/tools/style.nix

@@ -0,0 +1,82 @@
+{ actionlint
+, black
+, buildToolbox
+, checkedShellScript
+, git
+, hlint
+, hsie
+, nixpkgs-fmt
+, shellcheck
+, silver-searcher
+, statix
+, stylish-haskell
+}:
+let
+  style =
+    checkedShellScript
+      {
+        name = "postgrest-style";
+        docs = "Automatically format Haskell, Nix and Python files.";
+        inRootDir = true;
+      }
+      ''
+        # Format Nix files
+        ${statix}/bin/statix fix
+        ${nixpkgs-fmt}/bin/nixpkgs-fmt . > /dev/null 2> /dev/null
+
+        # Format Haskell files
+        # --vimgrep fixes a bug in ag: https://github.com/ggreer/the_silver_searcher/issues/753
+        ${silver-searcher}/bin/ag -l --vimgrep -g '\.l?hs$' . \
+          | xargs ${stylish-haskell}/bin/stylish-haskell -i
+
+        # Format Python files
+        ${black}/bin/black . 2> /dev/null
+      '';
+
+  # Script to check whether any uncommited changes result from postgrest-style
+  styleCheck =
+    checkedShellScript
+      {
+        name = "postgrest-style-check";
+        docs = "Check whether postgrest-style results in any uncommited changes.";
+        inRootDir = true;
+      }
+      ''
+        ${style}
+
+        ${git}/bin/git diff-index --exit-code HEAD -- '*.hs' '*.lhs' '*.nix'
+      '';
+
+  lint =
+    checkedShellScript
+      {
+        name = "postgrest-lint";
+        docs = "Lint all Haskell files, bash scripts and github workflows.";
+        inRootDir = true;
+      }
+      ''
+        echo "Checking consistency of import aliases in Haskell code..."
+        ${hsie} check-aliases main src
+
+
+        echo "Linting Haskell files..."
+        # --vimgrep fixes a bug in ag: https://github.com/ggreer/the_silver_searcher/issues/753
+        ${silver-searcher}/bin/ag -l --vimgrep -g '\.l?hs$' . \
+          | xargs ${hlint}/bin/hlint -X QuasiQuotes -X NoPatternSynonyms
+
+        echo "Linting bash scripts..."
+        ${shellcheck}/bin/shellcheck \
+          .github/get_cirrusci_freebsd \
+          .github/release \
+          test/with_tmp_db
+
+        echo "Linting workflows..."
+        ${actionlint}/bin/actionlint
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-style";
+  tools = [ style styleCheck lint ];
+}

nix/tools/tests.nix

@@ -0,0 +1,210 @@
+{ buildToolbox
+, cabal-install
+, checkedShellScript
+, devCabalOptions
+, ghc
+, glibcLocales
+, gnugrep
+, haskell
+, hpc-codecov
+, jq
+, postgrest
+, python3
+, runtimeShell
+, withTools
+, yq
+}:
+let
+  testSpec =
+    checkedShellScript
+      {
+        name = "postgrest-test-spec";
+        docs = "Run the Haskell test suite";
+        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
+      '';
+
+  testDoctests =
+    checkedShellScript
+      {
+        name = "postgrest-test-doctests";
+        docs = "Run the Haskell doctest test suite";
+        inRootDir = true;
+        withEnv = postgrest.env;
+      }
+      ''
+        # For unknown reasons, doctests uses the wrong GHC package database outside
+        # nix-shell and fails, so we set the package path explicitly
+        #ghcWithPackages="$(cat ${postgrest.env})"
+        #ghcVersion="$(ls "$ghcWithPackages/lib")"
+        #export GHC_PACKAGE_PATH="$ghcWithPackages/lib/$ghcVersion/package.conf.d/"
+
+        ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:doctests
+      '';
+
+  testSpecIdempotence =
+    checkedShellScript
+      {
+        name = "postgrest-test-spec-idempotence";
+        docs = "Check that the Haskell tests can be run multiple times against the same db.";
+        inRootDir = true;
+        withEnv = postgrest.env;
+      }
+      ''
+        ${withTools.latest} ${runtimeShell} -c " \
+          ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec && \
+          ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec"
+      '';
+
+  ioTestPython =
+    python3.withPackages (ps: [
+      ps.pyjwt
+      ps.pytest
+      ps.pytest_xdist
+      ps.pyyaml
+      ps.requests
+      ps.requests-unixsocket
+    ]);
+
+  testIO =
+    checkedShellScript
+      {
+        name = "postgrest-test-io";
+        docs = "Run the pytest-based IO tests.";
+        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[@]}"
+      '';
+
+  dumpSchema =
+    checkedShellScript
+      {
+        name = "postgrest-dump-schema";
+        docs = "Dump the loaded schema's DbStructure as a yaml file.";
+        inRootDir = true;
+        withEnv = postgrest.env;
+        withPath = [ jq ];
+      }
+      ''
+        ${withTools.latest} \
+            ${cabal-install}/bin/cabal v2-run ${devCabalOptions} --verbose=0 -- \
+            postgrest --dump-schema \
+            | ${yq}/bin/yq -y .
+      '';
+
+  coverage =
+    checkedShellScript
+      {
+        name = "postgrest-coverage";
+        docs = "Run spec and io tests while collecting hpc coverage data.";
+        args = [ "ARG_LEFTOVERS([hpc report arguments])" ];
+        inRootDir = true;
+        redirectTixFiles = false;
+        withEnv = postgrest.env;
+        withTmpDir = true;
+      }
+      ''
+        export LOCALE_ARCHIVE="${glibcLocales}/lib/locale/locale-archive"
+
+        # 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
+
+        # 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
+
+        HPCTIXFILE="$tmpdir"/querycost.tix \
+          ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:querycost
+
+        # Note: No coverage for doctests, as doctests leverage GHCi and GHCi does not support hpc
+
+        # 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
+
+        # 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
+
+        # 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
+
+          # 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
+      '';
+
+  coverageDraftOverlay =
+    checkedShellScript
+      {
+        name = "postgrest-coverage-draft-overlay";
+        docs = "Create a draft overlay from current coverage report.";
+        inRootDir = true;
+      }
+      ''
+        ${ghc}/bin/hpc draft --output=test/coverage.overlay coverage/postgrest.tix
+        sed -i 's|^module \(.*\):|module \1/|g' test/coverage.overlay
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-tests";
+  tools =
+    [
+      testSpec
+      testQuerycost
+      testDoctests
+      testSpecIdempotence
+      testIO
+      dumpSchema
+      coverage
+      coverageDraftOverlay
+    ];
+}

nix/tools/withTools.nix

@@ -0,0 +1,133 @@
+{ bashCompletion
+, buildToolbox
+, checkedShellScript
+, lib
+, postgresqlVersions
+, writeTextFile
+}:
+let
+  withTmpDb =
+    { name, postgresql }:
+    checkedShellScript
+      {
+        name = "postgrest-with-${name}";
+        docs = "Run the given command in a temporary database with ${name}";
+        args =
+          [
+            "ARG_OPTIONAL_SINGLE([fixtures], [f], [SQL file to load fixtures from], [test/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])"
+          ];
+        addCommandCompletion = true;
+        inRootDir = true;
+        redirectTixFiles = false;
+        withPath = [ postgresql ];
+        withTmpDir = true;
+      }
+      ''
+        # avoid starting multiple layers of withTmpDb
+        if test -v PGRST_DB_URI; then
+          exec "$@"
+        fi
+
+        setuplog="$tmpdir/setup.log"
+
+        log () {
+          echo "$1" >> "$setuplog"
+        }
+
+        mkdir -p "$tmpdir"/{db,socket}
+        # remove data dir, even if we keep tmpdir - no need to upload it to artifacts
+        trap 'rm -rf $tmpdir/db' EXIT
+
+        export PGDATA="$tmpdir/db"
+        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
+
+        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 \
+          >> "$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" \
+          >> "$setuplog"
+
+        stop () {
+          log "Stopping the database cluster..."
+          pg_ctl stop -m i >> "$setuplog"
+          rm -rf "$tmpdir/db"
+        }
+        trap stop EXIT
+
+        log "Loading fixtures..."
+        psql -v ON_ERROR_STOP=1 -f "$_arg_fixtures" >> "$setuplog"
+
+        log "Done. Running command..."
+        ("$_arg_command" "''${_arg_leftovers[@]}")
+      '';
+
+  # Helper script for running a command against all PostgreSQL versions.
+  withAll =
+    let
+      runners =
+        builtins.map
+          (pg:
+            ''
+              cat << EOF
+
+              Running against ${pg.name}...
+
+              EOF
+
+              trap 'echo "Failed on ${pg.name}"' exit
+
+              (${withTmpDb pg} "$_arg_command" "''${_arg_leftovers[@]}")
+
+              trap "" exit
+
+              cat << EOF
+
+              Done running against ${pg.name}.
+
+              EOF
+            '')
+          postgresqlVersions;
+    in
+    checkedShellScript
+      {
+        name = "postgrest-with-all";
+        docs = "Run command against all supported PostgreSQL versions.";
+        args =
+          [
+            "ARG_POSITIONAL_SINGLE([command], [Command to run])"
+            "ARG_LEFTOVERS([command arguments])"
+          ];
+        addCommandCompletion = true;
+        inRootDir = true;
+      }
+      (lib.concatStringsSep "\n\n" runners);
+
+  # Create a `postgrest-with-postgresql-` for each PostgreSQL version
+  withVersions = builtins.map withTmpDb postgresqlVersions;
+
+in
+buildToolbox
+{
+  name = "postgrest-with";
+  tools = [ withAll ] ++ withVersions;
+  extra = {
+    # make withTools.latest available for other nix files
+    latest = withTmpDb (builtins.head postgresqlVersions);
+  };
+}

postgrest.cabal

@@ -1,162 +1,298 @@
-name:                  postgrest
-description:           Reads the schema of a PostgreSQL database and creates RESTful routes
-                       for the tables and views, supporting all HTTP verbs that security
-                       permits.
-version:               0.4.2.0
-synopsis:              REST API for any Postgres database
-license:               MIT
-license-file:          LICENSE
-author:                Joe Nelson, Adam Baker
-homepage:              https://github.com/begriffs/postgrest
-maintainer:            cred+github@begriffs.com
-category:              Web
-build-type:            Simple
-cabal-version:         >=1.10
+name:               postgrest
+version:            9.0.0
+synopsis:           REST API for any Postgres database
+description:        Reads the schema of a PostgreSQL database and creates RESTful routes
+                    for the tables and views, supporting all HTTP verbs that security
+                    permits.
+license:            MIT
+license-file:       LICENSE
+author:             Joe Nelson, Adam Baker, Steve Chavez
+maintainer:         Steve Chavez <stevechavezast@gmail.com>
+category:           Executable, PostgreSQL, Network APIs
+homepage:           https://postgrest.org
+bug-reports:        https://github.com/PostgREST/postgrest/issues
+build-type:         Simple
+extra-source-files: CHANGELOG.md
+cabal-version:      >= 1.10
+
 source-repository head
-  type: git
-  location: git://github.com/begriffs/postgrest.git
+  type:     git
+  location: git://github.com/PostgREST/postgrest.git
 
-Flag CI
-  Description: No warnings allowed in continuous integration
-  Manual:      True
-  Default:     False
+flag dev
+  default:     False
+  manual:      True
+  description: Development flags
 
-executable postgrest
-  main-is:             Main.hs
-  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
-  ghc-options:
-    -threaded
-    -rtsopts
-    "-with-rtsopts=-N -I2"
-  default-language:    Haskell2010
-  build-depends:       auto-update
-                     , base
-                     , hasql
-                     , hasql-pool
-                     , postgrest
-                     , protolude
-                     , text
-                     , time
-                     , warp
-                     , bytestring
-                     , base64-bytestring
-                     , retry
-  if !os(windows)
-    build-depends:     unix
-
-  hs-source-dirs:      main
+flag hpc
+  default:     True
+  manual:      True
+  description: Enable HPC (dev only)
 
 library
+  default-language:   Haskell2010
+  default-extensions: OverloadedStrings
+                      NoImplicitPrelude
+  hs-source-dirs:     src
+  exposed-modules:    PostgREST.App
+                      PostgREST.AppState
+                      PostgREST.Auth
+                      PostgREST.CLI
+                      PostgREST.Config
+                      PostgREST.Config.Database
+                      PostgREST.Config.JSPath
+                      PostgREST.Config.PgVersion
+                      PostgREST.Config.Proxy
+                      PostgREST.ContentType
+                      PostgREST.DbStructure
+                      PostgREST.DbStructure.Identifiers
+                      PostgREST.DbStructure.Proc
+                      PostgREST.DbStructure.Relationship
+                      PostgREST.DbStructure.Table
+                      PostgREST.Error
+                      PostgREST.GucHeader
+                      PostgREST.Middleware
+                      PostgREST.OpenAPI
+                      PostgREST.Query.QueryBuilder
+                      PostgREST.Query.SqlFragment
+                      PostgREST.Query.Statements
+                      PostgREST.RangeQuery
+                      PostgREST.Request.ApiRequest
+                      PostgREST.Request.DbRequestBuilder
+                      PostgREST.Request.Parsers
+                      PostgREST.Request.Preferences
+                      PostgREST.Request.Types
+                      PostgREST.Version
+                      PostgREST.Workers
+  other-modules:      Paths_postgrest
+  build-depends:      base                      >= 4.9 && < 4.16
+                    , HTTP                      >= 4000.3.7 && < 4000.4
+                    , Ranged-sets               >= 0.3 && < 0.5
+                    , aeson                     >= 1.4.7 && < 1.6
+                    , ansi-wl-pprint            >= 0.6.7 && < 0.7
+                    , 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
+                    , 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
+                    , either                    >= 4.4.1 && < 5.1
+                    , fast-logger               >= 2.4.5
+                    , gitrev                    >= 1.2 && < 1.4
+                    , hasql                     >= 1.4 && < 1.5
+                    , hasql-dynamic-statements  == 0.3.1
+                    , hasql-notifications       >= 0.1 && < 0.3
+                    , hasql-pool                >= 0.5 && < 0.6
+                    , hasql-transaction         >= 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
+                    , mtl                       >= 2.2.2 && < 2.3
+                    , network-uri               >= 2.6.1 && < 2.8
+                    , optparse-applicative      >= 0.13 && < 0.17
+                    , parsec                    >= 3.1.11 && < 3.2
+                    , protolude                 >= 0.3 && < 0.4
+                    , regex-tdfa                >= 1.2.2 && < 1.4
+                    , retry                     >= 0.7.4 && < 0.10
+                    , scientific                >= 0.3.4 && < 0.4
+                    , swagger2                  >= 2.4 && < 2.7
+                    , text                      >= 1.2.2 && < 1.3
+                    , time                      >= 1.6 && < 1.11
+                    , unordered-containers      >= 0.2.8 && < 0.3
+                    , vector                    >= 0.11 && < 0.13
+                    , wai                       >= 3.2.1 && < 3.3
+                    , wai-cors                  >= 0.2.5 && < 0.3
+                    , wai-extra                 >= 3.0.19 && < 3.2
+                    , wai-logger                >= 2.3.2
+                    , wai-middleware-static     >= 0.8.1 && < 0.10
+                    , warp                      >= 3.2.12 && < 3.4
+                      -- -fno-spec-constr may help keep compile time memory use in check,
+                      --   see https://gitlab.haskell.org/ghc/ghc/issues/16017#note_219304
+                      -- -optP-Wno-nonportable-include-path
+                      --   prevents build failures on case-insensitive filesystems (macos),
+                      --   see https://github.com/commercialhaskell/stack/issues/3918
+  ghc-options:        -Werror -Wall -fwarn-identities
+                      -fno-spec-constr -optP-Wno-nonportable-include-path
+
+  if flag(dev)
+    ghc-options: -O0
+    if flag(hpc)
+      ghc-options: -fhpc -hpcdir .hpc
+  else
+    ghc-options: -O2
+
+  if !os(windows)
+    build-depends:
+      unix
+      , directory >= 1.2.6 && < 1.4
+      , network   >= 2.6 && < 3.2
+    exposed-modules:
+      PostgREST.Unix
+
+executable postgrest
+  default-language:   Haskell2010
+  default-extensions: OverloadedStrings
+                      NoImplicitPrelude
+  hs-source-dirs:     main
+  main-is:            Main.hs
+  build-depends:      base                >= 4.9 && < 4.16
+                    , containers          >= 0.5.7 && < 0.7
+                    , postgrest
+                    , protolude           >= 0.3 && < 0.4
+  ghc-options:        -threaded -rtsopts "-with-rtsopts=-N -I2"
+                      -O2 -Werror -Wall -fwarn-identities
+                      -fno-spec-constr -optP-Wno-nonportable-include-path
+
+  if flag(dev)
+    ghc-options: -O0
+    if flag(hpc)
+      ghc-options: -fhpc -hpcdir .hpc
+  else
+    ghc-options: -O2
+
+test-suite spec
+  type:               exitcode-stdio-1.0
+  default-language:   Haskell2010
+  default-extensions: OverloadedStrings
+                      QuasiQuotes
+                      NoImplicitPrelude
+  hs-source-dirs:     test
+  main-is:            Main.hs
+  other-modules:      Feature.AndOrParamsSpec
+                      Feature.AsymmetricJwtSpec
+                      Feature.AudienceJwtSecretSpec
+                      Feature.AuthSpec
+                      Feature.BinaryJwtSecretSpec
+                      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.OptionsSpec
+                      Feature.ProxySpec
+                      Feature.QueryLimitedSpec
+                      Feature.QuerySpec
+                      Feature.RangeSpec
+                      Feature.RawOutputTypesSpec
+                      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
+                    , 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-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
+                      -fno-warn-missing-signatures
+
+test-suite querycost
+  type:                exitcode-stdio-1.0
   default-language:    Haskell2010
-  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
-  build-depends:       aeson
-                     , ansi-wl-pprint
-                     , base >= 4.8 && < 6
-                     , bytestring
-                     , case-insensitive
-                     , cassava
-                     , configurator-ng == 0.0.0.1
-                     , containers
-                     , contravariant
-                     , either
-                     , hasql
-                     , hasql-pool == 0.4.1
-                     , hasql-transaction == 0.5
-                     , heredoc
-                     , HTTP
-                     , http-types
-                     , insert-ordered-containers
-                     , interpolatedstring-perl6
-                     , jwt
-                     , lens
-                     , lens-aeson
-                     , network-uri
-                     , optparse-applicative >= 0.13 && < 0.14
-                     , parsec
-                     , protolude
-                     , Ranged-sets == 0.3.0
-                     , regex-tdfa
-                     , safe
-                     , scientific
-                     , swagger2
-                     , text
-                     , time
-                     , unordered-containers
-                     , vector
-                     , wai
-                     , wai-cors
-                     , wai-extra
-                     , wai-middleware-static
-                     , cookie
-
-  Other-Modules:       Paths_postgrest
-  Exposed-Modules:     PostgREST.ApiRequest
-                     , PostgREST.App
-                     , PostgREST.Auth
-                     , PostgREST.Config
-                     , PostgREST.DbStructure
-                     , PostgREST.DbRequestBuilder
-                     , PostgREST.Error
-                     , PostgREST.Middleware
-                     , PostgREST.OpenAPI
-                     , PostgREST.Parsers
-                     , PostgREST.QueryBuilder
-                     , PostgREST.RangeQuery
-                     , PostgREST.Types
-  hs-source-dirs:      src
-
-Test-Suite spec
-  Type:                exitcode-stdio-1.0
-  Default-Language:    Haskell2010
-  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
-  Hs-Source-Dirs:      test
-  Main-Is:             Main.hs
-  Other-Modules:       Feature.AuthSpec
-                     , Feature.BinaryJwtSecretSpec
-                     , Feature.ConcurrentSpec
-                     , Feature.CorsSpec
-                     , Feature.DeleteSpec
-                     , Feature.InsertSpec
-                     , Feature.NoJwtSpec
-                     , Feature.ProxySpec
-                     , Feature.QueryLimitedSpec
-                     , Feature.QuerySpec
-                     , Feature.RangeSpec
-                     , Feature.SingularSpec
-                     , Feature.StructureSpec
-                     , Feature.UnicodeSpec
-                     , Feature.AndOrParamsSpec
-                     , SpecHelper
-                     , TestTypes
-  Build-Depends:       aeson
-                     , aeson-qq
-                     , async
-                     , auto-update
-                     , base
-                     , bytestring
-                     , base64-bytestring
-                     , case-insensitive
-                     , cassava
-                     , containers
-                     , contravariant
-                     , hasql
-                     , hasql-pool
-                     , heredoc
-                     , hjsonpointer
-                     , hjsonschema
-                     , hspec
-                     , hspec-wai >= 0.7.0
-                     , hspec-wai-json
-                     , http-types
-                     , lens
-                     , lens-aeson
-                     , monad-control
+  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
-                     , protolude
-                     , regex-tdfa
-                     , time
-                     , transformers-base
-                     , wai
-                     , wai-extra
+                     , 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
+
+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

scripts/release_s3.sh

@@ -1,10 +0,0 @@
-export POSTGREST_VER=`grep ^version /app/postgrest.cabal | sed -En 's/.*\s+([0-9\.]+)/\1/p'`
-
-curl -L http://sourceforge.net/projects/s3tools/files/s3cmd/1.5.0-alpha1/s3cmd-1.5.0-alpha1.tar.gz | tar zx
-
-cp /app/dist/build/postgrest/postgrest postgrest-${POSTGREST_VER}
-tar cJf postgrest-${POSTGREST_VER}.tar.xz postgrest-${POSTGREST_VER}
-
-touch ~/.s3cfg
-
-s3cmd-1.5.0-alpha1/s3cmd put --access_key=${S3_ACCESS_KEY} --secret_key=${S3_SECRET_KEY} -P -f postgrest-${POSTGREST_VER}.tar.xz $S3_BUCKET/postgrest-${POSTGREST_VER}.tar.xz

shell.nix

@@ -0,0 +1,57 @@
+# The additional modules below have large dependencies and are therefore
+# disabled by default. You can activate them by passing arguments to nix-shell,
+# e.g.:
+#
+#    nix-shell --arg docker true
+#
+# We highly recommend that use the PostgREST binary cache by installing cachix
+# (https://app.cachix.org/) and running `cachix use postgrest`.
+{ docker ? false
+, memory ? false
+}:
+let
+  postgrest =
+    import ./default.nix;
+
+  inherit (postgrest) pkgs;
+
+  inherit (pkgs) lib;
+
+  toolboxes =
+    [
+      postgrest.cabalTools
+      postgrest.devTools
+      postgrest.nixpkgsTools
+      postgrest.style
+      postgrest.tests
+      postgrest.withTools
+      postgrest.release
+    ]
+    ++ lib.optional docker postgrest.docker
+    ++ lib.optional memory postgrest.memory;
+
+in
+lib.overrideDerivation postgrest.env (
+  base: {
+    buildInputs =
+      base.buildInputs ++ [
+        pkgs.cabal-install
+        pkgs.cabal2nix
+        pkgs.postgresql
+        postgrest.hsie.bin
+      ]
+      ++ toolboxes;
+
+    shellHook =
+      ''
+        source ${pkgs.bashCompletion}/etc/profile.d/bash_completion.sh
+        source ${postgrest.hsie.bashCompletion}
+
+      ''
+      + builtins.concatStringsSep "\n" (
+        builtins.map (bashCompletion: "source ${bashCompletion}") (
+          builtins.concatLists (builtins.map (toolbox: toolbox.bashCompletion) toolboxes)
+        )
+      );
+  }
+)

src/PostgREST/ApiRequest.hs

@@ -1,291 +0,0 @@
-{-|
-Module      : PostgREST.ApiRequest
-Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
--}
-module PostgREST.ApiRequest ( ApiRequest(..)
-                            , ContentType(..)
-                            , Action(..)
-                            , Target(..)
-                            , PreferRepresentation (..)
-                            , mutuallyAgreeable
-                            , userApiRequest
-                            ) where
-
-import           Protolude
-import qualified Data.Aeson                as JSON
-import           Data.Aeson.Types          (emptyObject)
-import qualified Data.ByteString           as BS
-import qualified Data.ByteString.Internal  as BS (c2w)
-import qualified Data.ByteString.Lazy      as BL
-import qualified Data.Csv                  as CSV
-import qualified Data.List                 as L
-import           Data.List                 (lookup, last)
-import qualified Data.HashMap.Strict       as M
-import qualified Data.Set                  as S
-import           Data.Maybe                (fromJust)
-import           Control.Arrow             ((***))
-import qualified Data.Text                 as T
-import qualified Data.Vector               as V
-import           Network.HTTP.Base         (urlEncodeVars)
-import           Network.HTTP.Types.Header (hAuthorization, hCookie)
-import           Network.HTTP.Types.URI    (parseSimpleQuery)
-import           Network.Wai               (Request (..))
-import           Network.Wai.Parse         (parseHttpAccept)
-import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
-import           Data.Ranged.Boundaries
-import           PostgREST.Types           ( QualifiedIdentifier (..)
-                                           , Schema
-                                           , PayloadJSON(..)
-                                           , ContentType(..)
-                                           , ApiRequestError(..)
-                                           , toMime)
-import           Data.Ranged.Ranges        (Range(..), rangeIntersection, emptyRange)
-import qualified Data.CaseInsensitive      as CI
-import           Web.Cookie                (parseCookiesText)
-
-type RequestBody = BL.ByteString
-
--- | Types of things a user wants to do to tables/views/procs
-data Action = ActionCreate | ActionRead
-            | ActionUpdate | ActionDelete
-            | ActionInfo   | ActionInvoke
-            | ActionInspect
-            deriving Eq
--- | The target db object of a user action
-data Target = TargetIdent QualifiedIdentifier
-            | TargetProc  QualifiedIdentifier
-            | TargetRoot
-            | TargetUnknown [Text]
-            deriving Eq
--- | How to return the inserted data
-data PreferRepresentation = Full | HeadersOnly | None deriving Eq
-                          --
-{-|
-  Describes what the user wants to do. This data type is a
-  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 {
-  -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
-    iAction :: Action
-  -- | Requested range of rows within response
-  , iRange  :: M.HashMap ByteString NonnegRange
-  -- | The target, be it calling a proc or accessing a table
-  , iTarget :: Target
-  -- | Content types the client will accept, [CTAny] if no Accept header
-  , iAccepts :: [ContentType]
-  -- | Data sent by client and used for mutation actions
-  , iPayload :: Maybe PayloadJSON
-  -- | If client wants created items echoed back
-  , iPreferRepresentation :: PreferRepresentation
-  -- | Pass all parameters as a single json object to a stored procedure
-  , iPreferSingleObjectParameter :: Bool
-  -- | Whether the client wants a result count (slower)
-  , iPreferCount :: Bool
-  -- | Filters on the result ("id", "eq.10")
-  , iFilters :: [(Text, Text)]
-  -- | &and and &or parameters used for complex boolean logic
-  , iLogic :: [(Text, Text)]
-  -- | &select parameter used to shape the response
-  , iSelect :: Text
-  -- | &order parameters for each level
-  , iOrder :: [(Text, Text)]
-  -- | Alphabetized (canonical) request query string for response URLs
-  , iCanonicalQS :: ByteString
-  -- | JSON Web Token
-  , iJWT :: Text
-  -- | HTTP request headers
-  , iHeaders :: [(Text, Text)]
-  -- | Request Cookies
-  , iCookies :: [(Text, Text)]
-  }
-
--- | Examines HTTP request and translates it into user intent.
-userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
-userApiRequest schema req reqBody
-  | isTargetingProc && method /= "POST" = Left ActionInappropriate
-  | topLevelRange == emptyRange = Left InvalidRange
-  | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) undefined payload
-  | otherwise = Right ApiRequest {
-      iAction = action
-      , iTarget = target
-      , iRange = ranges
-      , iAccepts = fromMaybe [CTAny] $
-        map decodeContentType . parseHttpAccept <$> lookupHeader "accept"
-      , iPayload = relevantPayload
-      , iPreferRepresentation = representation
-      , iPreferSingleObjectParameter = singleObject
-      , iPreferCount = hasPrefer "count=exact"
-      , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
-      , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
-      , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
-      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
-      , iCanonicalQS = toS $ urlEncodeVars
-        . L.sortBy (comparing fst)
-        . map (join (***) toS)
-        . parseSimpleQuery
-        $ rawQueryString req
-      , iJWT = tokenStr
-      , iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hAuthorization, k /= hCookie]
-      , iCookies = fromMaybe [] $ parseCookiesText <$> lookupHeader "Cookie"
-      }
- where
-  isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
-  payload =
-    case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of
-      CTApplicationJSON ->
-        note "All object keys must match" . ensureUniform . pluralize
-          =<< if BL.null reqBody && isTargetingProc
-               then Right emptyObject
-               else JSON.eitherDecode reqBody
-      CTTextCSV ->
-        note "All lines must have same number of fields" . ensureUniform . csvToJson
-          =<< CSV.decodeByName reqBody
-      CTOther "application/x-www-form-urlencoded" ->
-        Right . PayloadJSON . V.singleton . M.fromList
-                    . map (toS *** JSON.String . toS) . parseSimpleQuery
-                    $ toS reqBody
-      ct ->
-        Left $ toS $ "Content-Type not acceptable: " <> toMime ct
-  topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges
-  action = case method of
-            "GET"     -> if target == TargetRoot
-                          then ActionInspect
-                          else ActionRead
-            "POST"    -> if isTargetingProc
-                          then ActionInvoke
-                          else ActionCreate
-            "PATCH"   -> ActionUpdate
-            "DELETE"  -> ActionDelete
-            "OPTIONS" -> ActionInfo
-            _         -> ActionInspect
-  target = case path of
-              []            -> TargetRoot
-              [table]       -> TargetIdent
-                              $ QualifiedIdentifier schema table
-              ["rpc", proc] -> TargetProc
-                              $ QualifiedIdentifier schema proc
-              other         -> TargetUnknown other
-  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke]
-  relevantPayload = if shouldParsePayload
-                      then rightToMaybe payload
-                      else Nothing
-  path            = pathInfo req
-  method          = requestMethod req
-  hdrs            = requestHeaders req
-  qParams         = [(toS k, v)|(k,v) <- queryString req]
-  lookupHeader    = flip lookup hdrs
-  hasPrefer :: Text -> Bool
-  hasPrefer val   = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs
-    where
-        split :: BS.ByteString -> [Text]
-        split = map T.strip . T.split (==',') . toS
-  singleObject    = hasPrefer "params=single-object"
-  representation
-    | hasPrefer "return=representation" = Full
-    | hasPrefer "return=minimal" = None
-    | otherwise = HeadersOnly
-  auth = fromMaybe "" $ lookupHeader hAuthorization
-  tokenStr = case T.split (== ' ') (toS auth) of
-    ("Bearer" : t : _) -> t
-    _                  -> ""
-  endingIn:: [Text] -> Text -> Bool
-  endingIn xx key = lastWord `elem` xx
-    where lastWord = last $ T.split (=='.') key
-
-  headerRange = rangeRequested hdrs
-  replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]
-  limitParams :: M.HashMap ByteString NonnegRange
-  limitParams  = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]
-  offsetParams :: M.HashMap ByteString NonnegRange
-  offsetParams = M.fromList [(toS (replaceLast "limit" k), fromMaybe 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
-
--- PRIVATE ---------------------------------------------------------------
-
-{-|
-  Warning: discards MIME parameters
--}
-decodeContentType :: BS.ByteString -> ContentType
-decodeContentType ct =
-  case BS.takeWhile (/= BS.c2w ';') ct of
-    "application/json"                  -> CTApplicationJSON
-    "text/csv"                          -> CTTextCSV
-    "application/openapi+json"          -> CTOpenAPI
-    "application/vnd.pgrst.object+json" -> CTSingularJSON
-    "application/vnd.pgrst.object"      -> CTSingularJSON
-    "application/octet-stream"          -> CTOctetStream
-    "*/*"                               -> CTAny
-    ct'                                 -> CTOther ct'
-
-type CsvData = V.Vector (M.HashMap Text BL.ByteString)
-
-{-|
-  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.Array
-csvToJson (_, vals) =
-  V.map rowToJsonObj vals
- where
-  rowToJsonObj = JSON.Object .
-    M.map (\str ->
-        if str == "NULL"
-          then JSON.Null
-          else JSON.String $ toS str
-      )
-
--- | Convert {foo} to [{foo}], leave arrays unchanged
--- and truncate everything else to an empty array.
-pluralize :: JSON.Value -> JSON.Array
-pluralize obj@(JSON.Object _) = V.singleton obj
-pluralize (JSON.Array arr)    = arr
-pluralize _                   = V.empty
-
--- | Test that Array contains only Objects having the same keys
--- and if so mark it as PayloadJSON
-ensureUniform :: JSON.Array -> Maybe PayloadJSON
-ensureUniform arr =
-  let objs :: V.Vector JSON.Object
-      objs = foldr -- filter non-objects, map to raw objects
-               (\val result -> case val of
-                  JSON.Object o -> V.cons o result
-                  _ -> result)
-               V.empty arr
-      keysPerObj = V.map (S.fromList . M.keys) objs
-      canonicalKeys = fromMaybe S.empty $ keysPerObj V.!? 0
-      areKeysUniform = all (==canonicalKeys) keysPerObj in
-
-  if (V.length objs == V.length arr) && areKeysUniform
-    then Just (PayloadJSON objs)
-    else Nothing

src/PostgREST/App.hs

@@ -1,357 +1,611 @@
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
---module PostgREST.App where
-module PostgREST.App (
-  postgrest
-) where
+{-|
+Module      : PostgREST.App
+Description : PostgREST main application
 
-import           Control.Applicative
-import qualified Data.ByteString.Char8     as BS
-import           Data.Maybe
-import           Data.IORef                (IORef, readIORef)
-import           Data.Text                 (intercalate)
-import           Data.Time.Clock.POSIX     (POSIXTime)
+This module is in charge of mapping HTTP requests to PostgreSQL queries.
+Some of its functionality includes:
 
-import qualified Hasql.Pool                 as P
-import qualified Hasql.Transaction          as HT
-import qualified Hasql.Transaction.Sessions as HT
+- Mapping HTTP request methods to proper SQL statements. For example, a GET request is translated to executing a SELECT query in a read-only TRANSACTION.
+- Producing HTTP Headers according to RFCs.
+- Content Negotiation
+-}
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.App
+  ( SignalHandlerInstaller
+  , SocketRunner
+  , postgrest
+  , run
+  ) where
 
-import           Network.HTTP.Types.Header
-import           Network.HTTP.Types.Status
-import           Network.HTTP.Types.URI    (renderSimpleQuery)
-import           Network.Wai
-import           Network.Wai.Middleware.RequestLogger (logStdout)
-import           Web.JWT                   (binarySecret)
+import Control.Monad.Except     (liftEither)
+import Data.Either.Combinators  (mapLeft)
+import Data.List                (union)
+import Data.String              (IsString (..))
+import Data.Time.Clock          (UTCTime)
+import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
+                                 setServerName)
+import System.Posix.Types       (FileMode)
 
-import qualified Data.Vector               as V
-import qualified Hasql.Transaction         as H
+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 M
+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           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
-                                        , Action(..), Target(..)
-                                        , PreferRepresentation (..)
-                                        , mutuallyAgreeable
-                                        , userApiRequest
-                                        )
-import           PostgREST.Auth            (jwtClaims, containsRole)
-import           PostgREST.Config          (AppConfig (..))
-import           PostgREST.DbStructure
-import           PostgREST.DbRequestBuilder( readRequest
-                                           , mutateRequest
-                                           , fieldNames
-                                           )
-import           PostgREST.Error           ( simpleError, pgError
-                                           , apiRequestError
-                                           , singularityError, binaryFieldError
-                                           , connectionLostError
-                                           )
-import           PostgREST.RangeQuery      (allRange, rangeOffset)
-import           PostgREST.Middleware
-import           PostgREST.QueryBuilder ( callProc
-                                        , requestToQuery
-                                        , requestToCountQuery
-                                        , createReadStatement
-                                        , createWriteStatement
-                                        , ResultsWithCount
-                                        )
-import           PostgREST.Types
-import           PostgREST.OpenAPI
+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           Data.Function (id)
-import           Protolude              hiding (intercalate, Proxy)
-import           Safe                   (headMay)
+import qualified PostgREST.ContentType      as ContentType
+import qualified PostgREST.DbStructure.Proc as Proc
 
-postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO POSIXTime ->
-             IO () -> Application
-postgrest conf refDbStructure pool getTime worker =
-  let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in
+import Protolude hiding (Handler)
 
-  middle $ \ req respond -> do
-    time <- getTime
-    body <- strictRequestBody req
-    maybeDbStructure <- readIORef refDbStructure
+
+data RequestContext = RequestContext
+  { ctxConfig      :: AppConfig
+  , ctxDbStructure :: DbStructure
+  , ctxApiRequest  :: ApiRequest
+  , ctxPgVersion   :: PgVersion
+  }
+
+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
+  conf@AppConfig{..} <- AppState.getConfig appState
+  connectionWorker appState -- Loads the initial DbStructure
+  installHandlers appState
+  -- reload schema cache + config on NOTIFY
+  when configDbChannelEnabled $ listener appState
+
+  let app = postgrest configLogLevel appState (connectionWorker appState)
+
+  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
+
+serverSettings :: AppConfig -> Warp.Settings
+serverSettings AppConfig{..} =
+  defaultSettings
+    & setHost (fromString $ toS configServerHost)
+    & setPort configServerPort
+    & 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
+
+      let
+        eitherResponse :: IO (Either Error Wai.Response)
+        eitherResponse =
+          runExceptT $ postgrestResponse conf maybeDbStructure jsonDbS pgVer (AppState.getPool appState) time 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
+
+postgrestResponse
+  :: AppConfig
+  -> Maybe DbStructure
+  -> ByteString
+  -> PgVersion
+  -> SQL.Pool
+  -> UTCTime
+  -> Wai.Request
+  -> Handler IO Wai.Response
+postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time req = do
+  body <- lift $ Wai.strictRequestBody req
+
+  dbStructure <-
     case maybeDbStructure of
-      Nothing -> respond connectionLostError
-      Just dbStructure -> do
-        response <- case userApiRequest (configSchema conf) req body of
-          Left err -> return $ apiRequestError err
-          Right apiRequest -> do
-            let jwtSecret = binarySecret <$> configJwtSecret conf
-                eClaims = jwtClaims jwtSecret (iJWT apiRequest) time
-                authed = containsRole eClaims
-                handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
-                txMode = transactionMode dbStructure
-                  (iTarget apiRequest) (iAction apiRequest)
-            response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
-            return $ either (pgError authed) identity response
-        when (isResponse503 response) worker
-        respond response
+      Just dbStructure ->
+        return dbStructure
+      Nothing ->
+        throwError Error.ConnectionLostError
 
-isResponse503 :: Response -> Bool
-isResponse503 resp = statusCode (responseStatus resp) == 503
+  apiRequest@ApiRequest{..} <-
+    liftEither . mapLeft Error.ApiRequestError $
+      ApiRequest.userApiRequest conf dbStructure req body
 
-transactionMode :: DbStructure -> Target -> Action -> H.Mode
-transactionMode structure target action =
-  case action of
-    ActionRead -> HT.Read
-    ActionInfo -> HT.Read
-    ActionInspect -> HT.Read
-    ActionInvoke ->
-      let proc =
-            case target of
-              (TargetProc qi) -> M.lookup (qiName qi) $
-                                   dbProcs structure
-              _               -> Nothing
-          v = fromMaybe Volatile $ pdVolatility <$> proc in
-      if v == Stable || v == Immutable
-         then HT.Read
-         else HT.Write
-    _ -> HT.Write
+  -- The JWT must be checked before touching the db
+  jwtClaims <- Auth.jwtClaims conf (toUtf8Lazy iJWT) time
 
-app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
-app dbStructure conf apiRequest =
-  case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of
-    Left errorResponse -> return errorResponse
-    Right contentType ->
-      case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
+  let
+    handleReq apiReq =
+      handleRequest $ RequestContext conf dbStructure apiReq pgVer
 
-        (ActionRead, TargetIdent qi, Nothing) ->
-          let partsField = (,) <$> readSqlParts
-                <*> (binaryField contentType =<< fldNames) in
-          case partsField of
-            Left errorResponse -> return errorResponse
-            Right ((q, cq), bField) -> do
-              let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount
-                                            (contentType == CTTextCSV) bField
-              row <- H.query () stm
-              let (tableTotal, queryTotal, _ , body) = row
-                  (status, contentRange) = rangeHeader queryTotal tableTotal
-                  canonical = iCanonicalQS apiRequest
-              return $
-                if contentType == CTSingularJSON && queryTotal /= 1
-                  then singularityError (toInteger queryTotal)
-                  else responseLBS status
-                    [toHeader contentType, contentRange,
-                      ("Content-Location",
-                        "/" <> toS (qiName qi) <>
-                          if BS.null canonical then "" else "?" <> toS canonical
-                      )
-                    ] (toS body)
+  runDbHandler pool (txMode apiRequest) jwtClaims (configDbPreparedStatements conf) .
+    Middleware.optionalRollback conf apiRequest $
+      Middleware.runPgLocals conf jwtClaims handleReq apiRequest jsonDbS pgVer
 
-        (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->
-          case mutateSqlParts of
-            Left errorResponse -> return errorResponse
-            Right (sq, mq) -> do
-              let isSingle = (==1) $ V.length rows
-              if contentType == CTSingularJSON
-                 && not isSingle
-                 && iPreferRepresentation apiRequest == Full
-                then return $ singularityError (toInteger $ V.length rows)
-                else do
-                  let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-                      stm = createWriteStatement sq mq
-                        (contentType == CTSingularJSON) isSingle
-                        (contentType == CTTextCSV) (iPreferRepresentation apiRequest)
-                        pKeys
-                  row <- H.query payload stm
-                  let (_, _, fs, body) = extractQueryResult row
-                      headers = catMaybes [
-                          if null fs
-                            then Nothing
-                            else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
-                        , if iPreferRepresentation apiRequest == Full
-                            then Just $ toHeader contentType
-                            else Nothing
-                        , Just . contentRangeH 1 0 $
-                            toInteger <$> if shouldCount then Just (V.length rows) else Nothing
-                        ]
+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
 
-                  return . responseLBS status201 headers $
-                    if iPreferRepresentation apiRequest == Full
-                      then toS body else ""
+  resp <-
+    liftEither . mapLeft Error.PgErr $
+      mapLeft (Error.PgError $ Auth.containsRole jwtClaims) dbResp
 
-        (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON rows)) ->
-          case (mutateSqlParts, null <$> rows V.!? 0, iPreferRepresentation apiRequest == Full) of
-            (Left errorResponse, _, _) -> return errorResponse
-            (_, Just True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"
-            (_, Just True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""
-            (Right (sq, mq), _, _) -> do
-              let stm = createWriteStatement sq mq
-                    (contentType == CTSingularJSON) False (contentType == CTTextCSV)
-                    (iPreferRepresentation apiRequest) []
-              row <- H.query payload stm
-              let (_, queryTotal, _, body) = extractQueryResult row
-              if contentType == CTSingularJSON
-                 && queryTotal /= 1
-                 && iPreferRepresentation apiRequest == Full
-                then do
-                  HT.condemn
-                  return $ singularityError (toInteger queryTotal)
-                else do
-                  let r = contentRangeH 0 (toInteger $ queryTotal-1)
-                            (toInteger <$> if shouldCount then Just queryTotal else Nothing)
-                      s = if iPreferRepresentation apiRequest == Full
-                            then status200
-                            else status204
-                  return $ if iPreferRepresentation apiRequest == Full
-                    then responseLBS s [toHeader contentType, r] (toS body)
-                    else responseLBS s [r] ""
+  liftEither resp
 
-        (ActionDelete, TargetIdent _, Nothing) ->
-          case mutateSqlParts of
-            Left errorResponse -> return errorResponse
-            Right (sq, mq) -> do
-              let emptyPayload = PayloadJSON V.empty
-                  stm = createWriteStatement sq mq
-                    (contentType == CTSingularJSON) False
-                    (contentType == CTTextCSV)
-                    (iPreferRepresentation apiRequest) []
-              row <- H.query emptyPayload stm
-              let (_, queryTotal, _, body) = extractQueryResult row
-                  r = contentRangeH 1 0 $
-                        toInteger <$> if shouldCount then Just queryTotal else Nothing
-              if contentType == CTSingularJSON
-                 && queryTotal /= 1
-                 && iPreferRepresentation apiRequest == Full
-                then do
-                  HT.condemn
-                  return $ singularityError (toInteger queryTotal)
-                else
-                  return $ if iPreferRepresentation apiRequest == Full
-                    then responseLBS status200 [toHeader contentType, r] (toS body)
-                    else responseLBS status204 [r] ""
+handleRequest :: RequestContext -> DbHandler Wai.Response
+handleRequest context@(RequestContext _ _ ApiRequest{..} _) =
+  case (iAction, iTarget) of
+    (ActionRead headersOnly, TargetIdent identifier) ->
+      handleRead headersOnly identifier context
+    (ActionCreate, TargetIdent identifier) ->
+      handleCreate identifier context
+    (ActionUpdate, TargetIdent identifier) ->
+      handleUpdate identifier context
+    (ActionSingleUpsert, TargetIdent identifier) ->
+      handleSingleUpsert identifier context
+    (ActionDelete, TargetIdent identifier) ->
+      handleDelete identifier context
+    (ActionInfo, TargetIdent identifier) ->
+      handleInfo identifier context
+    (ActionInvoke invMethod, TargetProc proc _) ->
+      handleInvoke invMethod proc context
+    (ActionInspect headersOnly, TargetDefaultSpec tSchema) ->
+      handleOpenApi headersOnly tSchema context
+    _ ->
+      throwError Error.NotFound
 
-        (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
-          let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
-          case mTable of
-            Nothing -> return notFound
-            Just table ->
-              let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
-              return $ responseLBS status200 [allOrigins, acceptH] ""
+handleRead :: Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
+handleRead headersOnly identifier context@RequestContext{..} = do
+  req <- readRequest identifier context
+  bField <- binaryField context req
 
-        (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->
-          case readSqlParts of
-            Left errorResponse -> return errorResponse
-            Right (q, cq) -> do
-              let p = V.head payload
-                  singular = contentType == CTSingularJSON
-                  paramsAsSingleObject = iPreferSingleObjectParameter apiRequest
-              row <- H.query () $
-                callProc qi p q cq topLevelRange shouldCount singular
-                         paramsAsSingleObject (contentType == CTTextCSV)
-              let (tableTotal, queryTotal, body) =
-                    fromMaybe (Just 0, 0, "[]") row
-                  (status, contentRange) = rangeHeader queryTotal tableTotal
-              if singular && queryTotal /= 1
-                then do
-                  HT.condemn
-                  return $ singularityError (toInteger queryTotal)
-                else return $ responseLBS status [toHeader contentType, contentRange] (toS body)
+  let
+    ApiRequest{..} = ctxApiRequest
+    AppConfig{..} = ctxConfig
+    countQuery = QueryBuilder.readRequestToCountQuery req
 
-        (ActionInspect, TargetRoot, Nothing) -> do
-          let host = configHost conf
-              port = toInteger $ configPort conf
-              proxy = pickProxy $ toS <$> configProxyUri conf
-              uri Nothing = ("http", host, port, "/")
-              uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
-              uri' = uri proxy
-              encodeApi ti = encodeOpenAPI (M.elems $ dbProcs dbStructure) ti uri'
-          body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
-          return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body
+  (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
 
-        _ -> return notFound
+  total <- readTotal ctxConfig ctxApiRequest tableTotal countQuery
+  response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders
 
-    where
-      toTableInfo :: [Table] -> [(Table, [Column], [Text])]
-      toTableInfo = map (\t ->
-        let tSchema = tableSchema t
-            tTable = tableName t
-            cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
-            pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
-        in (t, cols, pkeys))
-      notFound = responseLBS status404 [] ""
-      filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
-      filterCol :: Schema -> TableName -> Column -> Bool
-      filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
-      allPrKeys = dbPrimaryKeys dbStructure
-      allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
-      shouldCount = iPreferCount apiRequest
-      schema = toS $ configSchema conf
-      topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
-      rangeHeader queryTotal tableTotal =
-        let lower = rangeOffset topLevelRange
-            upper = lower + toInteger queryTotal - 1
-            contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
-            status = rangeStatus lower upper (toInteger <$> tableTotal)
-        in (status, contentRange)
+  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
 
-      readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) (dbProcs dbStructure) apiRequest
-      fldNames = fieldNames <$> readReq
-      readDbRequest = DbRead <$> readReq
-      mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< fldNames)
-      selectQuery = requestToQuery schema False <$> readDbRequest
-      mutateQuery = requestToQuery schema False <$> mutateDbRequest
-      countQuery = requestToCountQuery schema <$> readDbRequest
-      readSqlParts = (,) <$> selectQuery <*> countQuery
-      mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
+  failNotSingular iAcceptContentType queryTotal . response status headers $
+    if headersOnly then mempty else LBS.fromStrict body
 
-responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
-responseContentTypeOrError accepts action = serves contentTypesForRequest accepts
+readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64)
+readTotal AppConfig{..} ApiRequest{..} tableTotal countQuery =
+  case iPreferCount of
+    Just PlannedCount ->
+      explain
+    Just EstimatedCount ->
+      if tableTotal > (fromIntegral <$> configDbMaxRows) then
+        max tableTotal <$> explain
+      else
+        return tableTotal
+    _ ->
+      return tableTotal
   where
-    contentTypesForRequest =
-      case action of
-        ActionRead ->    [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
-        ActionCreate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionUpdate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionDelete ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionInspect -> [CTOpenAPI, CTApplicationJSON]
-        ActionInfo ->    [CTTextCSV]
-    serves sProduces cAccepts =
-      case mutuallyAgreeable sProduces cAccepts of
-        Nothing -> do
-          let failed = intercalate ", " $ map (toS . toMime) cAccepts
-          Left $ simpleError status415 $
-            "None of these Content-Types are available: " <> failed
-        Just ct -> Right ct
+    explain =
+      lift . SQL.statement mempty . Statements.createExplainStatement countQuery $
+        configDbPreparedStatements
 
-binaryField :: ContentType -> [FieldName] -> Either Response (Maybe FieldName)
-binaryField CTOctetStream fldNames =
-  if length fldNames == 1 && fieldName /= Just "*"
-    then Right fieldName
-    else Left binaryFieldError
+handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
+handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
+  let
+    ApiRequest{..} = ctxApiRequest
+    pkCols = tablePKCols ctxDbStructure qiSchema qiName
+
+  WriteQueryResult{..} <- writeQuery identifier True pkCols context
+
+  let
+    response = gucResponse resGucStatus resGucHeaders
+    headers =
+      catMaybes
+        [ if null resFields then
+            Nothing
+          else
+            Just
+              ( HTTP.hLocation
+              , "/"
+                  <> 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
+        ]
+
+  failNotSingular iAcceptContentType resQueryTotal $
+    if iPreferRepresentation == Full then
+      response HTTP.status201 (headers ++ contentTypeHeaders context) (LBS.fromStrict resBody)
+    else
+      response HTTP.status201 headers mempty
+
+handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response
+handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do
+  WriteQueryResult{..} <- writeQuery identifier False mempty context
+
+  let
+    response = gucResponse resGucStatus resGucHeaders
+    fullRepr = iPreferRepresentation == Full
+    updateIsNoOp = 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
-    fieldName = headMay fldNames
-binaryField _ _ = Right Nothing
+    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)
 
-splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
-splitKeyValue kv = (k, BS.tail v)
-  where (k, v) = BS.break (== '=') kv
+handleInvoke :: InvokeMethod -> ProcDescription -> RequestContext -> DbHandler Wai.Response
+handleInvoke invMethod proc context@RequestContext{..} = do
+  let
+    ApiRequest{..} = ctxApiRequest
 
-renderLocationFields :: [BS.ByteString] -> BS.ByteString
-renderLocationFields fields =
-  renderSimpleQuery True $ map splitKeyValue fields
+    identifier =
+      QualifiedIdentifier
+        (pdSchema proc)
+        (fromMaybe (pdName proc) $ Proc.procTableName proc)
 
-rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
-rangeStatus _ _ Nothing = status200
-rangeStatus lower upper (Just total)
-  | lower > total            = status416
-  | (1 + upper - lower) < total = status206
-  | otherwise               = status200
+  req <- readRequest identifier context
+  bField <- binaryField context req
 
-contentRangeH :: Integer -> Integer -> Maybe Integer -> Header
-contentRangeH lower upper total =
-    ("Content-Range", headerValue)
-    where
-      headerValue   = rangeString <> "/" <> totalString
-      rangeString
-        | totalNotZero && fromInRange = show lower <> "-" <> show upper
-        | otherwise = "*"
-      totalString   = fromMaybe "*" (show <$> total)
-      totalNotZero  = fromMaybe True ((/=) 0 <$> total)
-      fromInRange   = lower <= upper
+  let callReq = ReqBuilder.callRequest proc ctxApiRequest req
 
-extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
-extractQueryResult = fromMaybe (Nothing, 0, [], "")
+  (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

src/PostgREST/AppState.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module PostgREST.AppState
+  ( AppState
+  , getConfig
+  , getDbStructure
+  , getIsWorkerOn
+  , getJsonDbS
+  , getMainThreadId
+  , getPgVersion
+  , getPool
+  , getTime
+  , getRetryNextIn
+  , init
+  , initWithPool
+  , logWithZTime
+  , putConfig
+  , putDbStructure
+  , putIsWorkerOn
+  , putJsonDbS
+  , putPgVersion
+  , putRetryNextIn
+  , releasePool
+  , signalListener
+  , waitListener
+  ) where
+
+import qualified Hasql.Pool as SQL
+
+import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
+                           updateAction)
+import Data.IORef         (IORef, atomicWriteIORef, newIORef,
+                           readIORef)
+import Data.Time          (ZonedTime, defaultTimeLocale, formatTime,
+                           getZonedTime)
+import Data.Time.Clock    (UTCTime, getCurrentTime)
+
+import PostgREST.Config           (AppConfig (..))
+import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion)
+import PostgREST.DbStructure      (DbStructure)
+
+import Protolude
+
+
+data AppState = AppState
+  { statePool         :: SQL.Pool -- | Connection pool, either a 'Connection' or a 'ConnectionError'
+  , statePgVersion    :: IORef PgVersion
+  -- | No schema cache at the start. Will be filled in by the connectionWorker
+  , stateDbStructure  :: IORef (Maybe DbStructure)
+  -- | Cached DbStructure in json
+  , stateJsonDbS      :: IORef ByteString
+  -- | Helper ref to make sure just one connectionWorker can run at a time
+  , stateIsWorkerOn   :: IORef Bool
+  -- | Binary semaphore used to sync the listener(NOTIFY reload) with the connectionWorker.
+  , stateListener     :: MVar ()
+  -- | Config that can change at runtime
+  , stateConf         :: IORef AppConfig
+  -- | Time used for verifying JWT expiration
+  , stateGetTime      :: IO UTCTime
+  -- | Time with time zone used for worker logs
+  , stateGetZTime     :: IO ZonedTime
+  -- | Used for killing the main thread in case a subthread fails
+  , stateMainThreadId :: ThreadId
+  -- | Keeps track of when the next retry for connecting to database is scheduled
+  , stateRetryNextIn  :: IORef Int
+  }
+
+init :: AppConfig -> IO AppState
+init conf = do
+  newPool <- initPool conf
+  initWithPool newPool conf
+
+initWithPool :: SQL.Pool -> AppConfig -> IO AppState
+initWithPool newPool conf =
+  AppState newPool
+    <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
+    <*> newIORef Nothing
+    <*> newIORef mempty
+    <*> newIORef False
+    <*> newEmptyMVar
+    <*> newIORef conf
+    <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }
+    <*> mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime }
+    <*> myThreadId
+    <*> newIORef 0
+
+initPool :: AppConfig -> IO SQL.Pool
+initPool AppConfig{..} =
+  SQL.acquire (configDbPoolSize, configDbPoolTimeout, toUtf8 configDbUri)
+
+getPool :: AppState -> SQL.Pool
+getPool = statePool
+
+releasePool :: AppState -> IO ()
+releasePool AppState{..} = SQL.release statePool >> throwTo stateMainThreadId UserInterrupt
+
+getPgVersion :: AppState -> IO PgVersion
+getPgVersion = readIORef . statePgVersion
+
+putPgVersion :: AppState -> PgVersion -> IO ()
+putPgVersion = atomicWriteIORef . statePgVersion
+
+getDbStructure :: AppState -> IO (Maybe DbStructure)
+getDbStructure = readIORef . stateDbStructure
+
+putDbStructure :: AppState -> DbStructure -> IO ()
+putDbStructure appState structure =
+  atomicWriteIORef (stateDbStructure appState) $ Just structure
+
+getJsonDbS :: AppState -> IO ByteString
+getJsonDbS = readIORef . stateJsonDbS
+
+putJsonDbS :: AppState -> ByteString -> IO ()
+putJsonDbS appState = atomicWriteIORef (stateJsonDbS appState)
+
+getIsWorkerOn :: AppState -> IO Bool
+getIsWorkerOn = readIORef . stateIsWorkerOn
+
+putIsWorkerOn :: AppState -> Bool -> IO ()
+putIsWorkerOn = atomicWriteIORef . stateIsWorkerOn
+
+getRetryNextIn :: AppState -> IO Int
+getRetryNextIn = readIORef . stateRetryNextIn
+
+putRetryNextIn :: AppState -> Int -> IO ()
+putRetryNextIn = atomicWriteIORef . stateRetryNextIn
+
+getConfig :: AppState -> IO AppConfig
+getConfig = readIORef . stateConf
+
+putConfig :: AppState -> AppConfig -> IO ()
+putConfig = atomicWriteIORef . stateConf
+
+getTime :: AppState -> IO UTCTime
+getTime = stateGetTime
+
+-- | Log to stderr with local time
+logWithZTime :: AppState -> Text -> IO ()
+logWithZTime appState txt = do
+  zTime <- stateGetZTime appState
+  hPutStrLn stderr $ toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <> txt
+
+getMainThreadId :: AppState -> ThreadId
+getMainThreadId = stateMainThreadId
+
+-- | As this IO action uses `takeMVar` internally, it will only return once
+-- `stateListener` has been set using `signalListener`. This is currently used
+-- to syncronize workers.
+waitListener :: AppState -> IO ()
+waitListener = takeMVar . stateListener
+
+-- tryPutMVar doesn't lock the thread. It should always succeed since
+-- the connectionWorker is the only mvar producer.
+signalListener :: AppState -> IO ()
+signalListener appState = void $ tryPutMVar (stateListener appState) ()

src/PostgREST/Auth.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
 {-|
 Module      : PostgREST.Auth
 Description : PostgREST authorization functions.
@@ -11,70 +10,73 @@ Authentication should always be implemented in an external service.
 In the test suite there is an example of simple login function that can be used for a
 very simple authentication system inside the PostgreSQL database.
 -}
-module PostgREST.Auth (
-    containsRole
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.Auth
+  ( containsRole
   , jwtClaims
-  , tokenJWT
-  , JWTAttempt(..)
+  , JWTClaims
   ) where
 
-import           Protolude
-import           Control.Lens
-import           Data.Aeson              (Value (..), parseJSON, toJSON)
-import           Data.Aeson.Lens
-import           Data.Aeson.Types        (parseMaybe, emptyObject, emptyArray)
-import qualified Data.Vector             as V
-import qualified Data.HashMap.Strict     as M
-import           Data.Maybe              (fromJust)
-import           Data.Time.Clock         (NominalDiffTime)
-import qualified Web.JWT                 as JWT
+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 Control.Lens            (set)
+import Control.Monad.Except    (liftEither)
+import Data.Either.Combinators (mapLeft)
+import Data.Time.Clock         (UTCTime)
+
+import PostgREST.Config (AppConfig (..), JSPath, JSPathExp (..))
+import PostgREST.Error  (Error (..))
+
+import Protolude
 
 
-{-|
-  Possible situations encountered with client JWTs
--}
-data JWTAttempt = JWTExpired
-                | JWTInvalid
-                | JWTMissingSecret
-                | JWTClaims (M.HashMap Text Value)
-                deriving Eq
+type JWTClaims = M.HashMap Text JSON.Value
 
-{-|
-  Receives the JWT secret (from config) and a JWT and returns a map
-  of JWT claims.
--}
-jwtClaims :: Maybe JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt
-jwtClaims _ "" _ = JWTClaims M.empty
-jwtClaims secret jwt time =
-  case secret of
-    Nothing -> JWTMissingSecret
-    Just s ->
-      let mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature s jwt in
-      case isExpired <$> mClaims of
-        Just True -> JWTExpired
-        Nothing -> JWTInvalid
-        Just False -> JWTClaims $ value2map $ fromJust mClaims
- where
-  isExpired claims =
-    let mExp = claims ^? key "exp" . _Integer
-    in fromMaybe False $ (<= time) . fromInteger <$> mExp
-  value2map (Object o) = o
-  value2map _          = M.empty
+-- | Receives the JWT secret and audience (from config) and a JWT and returns a
+-- map of JWT claims.
+jwtClaims :: Monad m =>
+  AppConfig -> LByteString -> UTCTime -> ExceptT Error m JWTClaims
+jwtClaims _ "" _ = return M.empty
+jwtClaims AppConfig{..} payload time = do
+  secret <- liftEither . maybeToRight JwtTokenMissing $ configJWKS
+  eitherClaims <-
+    lift . runExceptT $
+      JWT.verifyClaimsAt validation secret time =<< JWT.decodeCompact payload
+  liftEither . mapLeft jwtClaimsError $ claimsMap configJwtRoleClaimKey <$> eitherClaims
+  where
+    validation =
+      JWT.defaultJWTValidationSettings audienceCheck & set JWT.allowedSkew 1
 
-{-|
-  Receives the JWT secret (from config) and a JWT and a JSON value
-  and returns a signed JWT.
--}
-tokenJWT :: JWT.Secret -> Value -> Text
-tokenJWT secret (Array arr) =
-  let obj = if V.null arr then emptyObject else V.head arr
-      jcs = parseMaybe parseJSON obj :: Maybe JWT.JWTClaimsSet in
-  JWT.encodeSigned JWT.HS256 secret $ fromMaybe JWT.def jcs
-tokenJWT secret _ = tokenJWT secret emptyArray
+    audienceCheck :: JWT.StringOrURI -> Bool
+    audienceCheck = maybe (const True) (==) configJwtAudience
 
-{-|
-  Whether a response from jwtClaims contains a role claim
--}
-containsRole :: JWTAttempt -> Bool
-containsRole (JWTClaims claims) = M.member "role" claims
-containsRole _ = False
+    jwtClaimsError :: JWT.JWTError -> Error
+    jwtClaimsError JWT.JWTExpired = JwtTokenInvalid "JWT expired"
+    jwtClaimsError e              = JwtTokenInvalid $ show e
+
+-- | Turn JWT ClaimSet into something easier to work with.
+--
+-- Also, here the jspath is applied to put the "role" in the map.
+claimsMap :: JSPath -> JWT.ClaimsSet -> JWTClaims
+claimsMap jspath claims =
+  case JSON.toJSON claims of
+    val@(JSON.Object o) ->
+      M.delete "role" o `M.union` role val
+    _ ->
+      M.empty
+  where
+    role value =
+      maybe M.empty (M.singleton "role") $ walkJSPath (Just value) jspath
+
+    walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value
+    walkJSPath x                      []                = x
+    walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest
+    walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest
+    walkJSPath _                      _                 = Nothing
+
+-- | Whether a response from jwtClaims contains a role claim
+containsRole :: JWTClaims -> Bool
+containsRole = M.member "role"

src/PostgREST/CLI.hs

@@ -0,0 +1,223 @@
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.CLI
+  ( main
+  , CLI (..)
+  , Command (..)
+  , readCLIShowHelp
+  ) where
+
+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
+
+import Data.Text.IO (hPutStrLn)
+import Text.Heredoc (str)
+
+import PostgREST.AppState    (AppState)
+import PostgREST.Config      (AppConfig (..))
+import PostgREST.DbStructure (queryDbStructure)
+import PostgREST.Version     (prettyVersion)
+import PostgREST.Workers     (reReadConfig)
+
+import qualified PostgREST.App      as App
+import qualified PostgREST.AppState as AppState
+import qualified PostgREST.Config   as Config
+
+import Protolude hiding (hPutStrLn)
+
+
+main :: App.SignalHandlerInstaller -> Maybe App.SocketRunner -> CLI -> IO ()
+main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do
+  conf@AppConfig{..} <-
+    either panic identity <$> Config.readAppConfig mempty cliPath Nothing
+  appState <- AppState.init conf
+
+  -- Override the config with config options from the db
+  -- TODO: the same operation is repeated on connectionWorker, ideally this
+  -- would be done only once, but dump CmdDumpConfig needs it for tests.
+  when configDbConfig $ reReadConfig True appState
+
+  exec cliCommand appState
+  where
+    exec :: Command -> AppState -> IO ()
+    exec CmdDumpConfig appState = putStr . Config.toText =<< AppState.getConfig appState
+    exec CmdDumpSchema appState = putStrLn =<< dumpSchema appState
+    exec CmdRun appState = App.run installSignalHandlers runAppWithSocket appState
+
+-- | Dump DbStructure schema to JSON
+dumpSchema :: AppState -> IO LBS.ByteString
+dumpSchema appState = do
+  AppConfig{..} <- AppState.getConfig appState
+  actualPgVersion <- AppState.getPgVersion appState
+  result <-
+    let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
+    SQL.use (AppState.getPool appState) $
+      transaction SQL.ReadCommitted SQL.Read $
+        queryDbStructure
+          (toList configDbSchemas)
+          configDbExtraSearchPath
+          actualPgVersion
+          configDbPreparedStatements
+  SQL.release $ AppState.getPool appState
+  case result of
+    Left e -> do
+      hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e
+      exitFailure
+    Right dbStructure -> return $ JSON.encode dbStructure
+
+-- | Command line interface options
+data CLI = CLI
+  { cliCommand :: Command
+  , cliPath    :: Maybe FilePath
+  }
+
+data Command
+  = CmdRun
+  | CmdDumpConfig
+  | CmdDumpSchema
+
+-- | Read command line interface options. Also prints help.
+readCLIShowHelp :: Bool -> IO CLI
+readCLIShowHelp hasEnvironment =
+  O.customExecParser prefs opts
+  where
+    prefs = O.prefs $ O.showHelpOnError <> O.showHelpOnEmpty
+    opts = O.info parser $ O.fullDesc <> progDesc <> footer
+    parser = O.helper <*> exampleParser <*> cliParser
+
+    progDesc =
+      O.progDesc $
+        "PostgREST "
+        <> 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."
+
+    exampleParser =
+      O.infoOption exampleConfigFile $
+        O.long "example"
+        <> O.short 'e'
+        <> O.help "Show an example configuration file"
+
+    cliParser :: O.Parser CLI
+    cliParser =
+      CLI
+        <$> (dumpConfigFlag <|> dumpSchemaFlag)
+        <*> optionalIf hasEnvironment configFileOption
+
+    configFileOption =
+      O.strArgument $
+        O.metavar "FILENAME"
+        <> O.help "Path to configuration file (optional with PGRST_ environment variables)"
+
+    dumpConfigFlag =
+      O.flag CmdRun CmdDumpConfig $
+        O.long "dump-config"
+        <> O.help "Dump loaded configuration and exit"
+
+    dumpSchemaFlag =
+      O.flag CmdRun CmdDumpSchema $
+        O.long "dump-schema"
+        <> O.help "Dump loaded schema as JSON and exit (for debugging, output structure is unstable)"
+
+    optionalIf :: Alternative f => Bool -> f a -> f (Maybe a)
+    optionalIf True  = O.optional
+    optionalIf False = fmap Just
+
+exampleConfigFile :: [Char]
+exampleConfigFile =
+  [str|### REQUIRED:
+      |db-uri = "postgres://user:pass@localhost:5432/dbname"
+      |db-schema = "public"
+      |db-anon-role = "postgres"
+      |
+      |### OPTIONAL:
+      |## number of open connections in the pool
+      |db-pool = 10
+      |
+      |## Time to live, in seconds, for an idle database pool connection.
+      |db-pool-timeout = 10
+      |
+      |## extra schemas to add to the search_path of every request
+      |db-extra-search-path = "public"
+      |
+      |## limit rows in response
+      |# db-max-rows = 1000
+      |
+      |## stored proc to exec immediately after auth
+      |# db-pre-request = "stored_proc_name"
+      |
+      |## stored proc that overrides the root "/" spec
+      |## it must be inside the db-schema
+      |# db-root-spec = "stored_proc_name"
+      |
+      |## Notification channel for reloading the schema cache
+      |db-channel = "pgrst"
+      |
+      |## Enable or disable the notification channel
+      |db-channel-enabled = true
+      |
+      |## Enable in-database configuration
+      |db-config = true
+      |
+      |## 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
+      |
+      |## how to terminate database transactions
+      |## possible values are:
+      |## commit (default)
+      |##   transaction is always committed, this can not be overriden
+      |## commit-allow-override
+      |##   transaction is committed, but can be overriden with Prefer tx=rollback header
+      |## rollback
+      |##   transaction is always rolled back, this can not be overriden
+      |## rollback-allow-override
+      |##   transaction is rolled back, but can be overriden with Prefer tx=commit header
+      |db-tx-end = "commit"
+      |
+      |## enable or disable prepared statements. disabling is only necessary when behind a connection pooler.
+      |## when disabled, statements will be parametrized but won't be prepared.
+      |db-prepared-statements = true
+      |
+      |server-host = "!4"
+      |server-port = 3000
+      |
+      |## unix socket location
+      |## if specified it takes precedence over server-port
+      |# server-unix-socket = "/tmp/pgrst.sock"
+      |
+      |## unix socket file mode
+      |## when none is provided, 660 is applied by default
+      |# server-unix-socket-mode = "660"
+      |
+      |## determine if the OpenAPI output should follow or ignore role privileges or be disabled entirely
+      |## admitted values: follow-privileges, ignore-privileges, disabled
+      |openapi-mode = "follow-privileges"
+      |
+      |## base url for the OpenAPI output
+      |openapi-server-proxy-uri = ""
+      |
+      |## choose a secret, JSON Web Key (or set) to enable JWT auth
+      |## (use "@filename" to load from separate file)
+      |# jwt-secret = "secret_with_at_least_32_characters"
+      |# jwt-aud = "your_audience_claim"
+      |jwt-secret-is-base64 = false
+      |
+      |## jspath to the role claim key
+      |jwt-role-claim-key = ".role"
+      |
+      |## content types to produce raw output
+      |# raw-media-types="image/png, image/jpg"
+      |
+      |## logging level, the admitted values are: crit, error, warn and info.
+      |log-level = "error"
+      |]

src/PostgREST/Config.hs

@@ -1,191 +1,450 @@
-{-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {-|
 Module      : PostgREST.Config
-Description : Manages PostgREST configuration options.
+Description : Manages PostgREST configuration type and parser.
 
-This module provides a helper function to read the command line
-arguments using the optparse-applicative and the AppConfig type to store
-them.  It also can be used to define other middleware configuration that
-may be delegated to some sort of external configuration.
-
-It currently includes a hardcoded CORS policy but this could easly be
-turned in configurable behaviour if needed.
-
-Other hardcoded options such as the minimum version number also belong here.
 -}
-module PostgREST.Config ( prettyVersion
-                        , readOptions
-                        , corsPolicy
-                        , minimumPgVersion
-                        , PgVersion (..)
-                        , AppConfig (..)
-                        )
-       where
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
 
-import           System.IO.Error             (IOError)
-import           Control.Applicative
-import qualified Data.ByteString             as B
-import qualified Data.ByteString.Char8       as BS
-import qualified Data.CaseInsensitive        as CI
-import qualified Data.Configurator           as C
-import qualified Data.Configurator.Parser    as C
-import           Data.Configurator.Types     (Value(..))
-import           Data.List                   (lookup)
-import           Data.Monoid
-import           Data.Scientific             (floatingOrInteger)
-import           Data.Text                   (strip, intercalate, lines)
-import           Data.Text.Encoding          (encodeUtf8)
-import           Data.Text.IO                (hPutStrLn)
-import           Data.Version                (versionBranch)
-import           Network.Wai
-import           Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
-import           Options.Applicative hiding  (str)
-import           Paths_postgrest             (version)
-import           System.IO                   (hPrint)
-import           Text.Heredoc
-import           Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>))
-import qualified Text.PrettyPrint.ANSI.Leijen as L
-import           Protolude hiding            (intercalate, (<>))
+module PostgREST.Config
+  ( AppConfig (..)
+  , Environment
+  , JSPath
+  , JSPathExp(..)
+  , LogLevel(..)
+  , OpenAPIMode(..)
+  , Proxy(..)
+  , toText
+  , isMalformedProxyUri
+  , readAppConfig
+  , readPGRSTEnvironment
+  , toURI
+  , parseSecret
+  ) where
 
--- | Config file settings for the server
-data AppConfig = AppConfig {
-    configDatabase          :: Text
-  , configAnonRole          :: Text
-  , configProxyUri          :: Maybe Text
-  , configSchema            :: Text
-  , configHost              :: Text
-  , configPort              :: Int
+import qualified Crypto.JOSE.Types      as JOSE
+import qualified Crypto.JWT             as JWT
+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.Configurator      as C
+import qualified Data.Map.Strict        as M
+import qualified Data.Text              as T
+import qualified Data.Text.Encoding     as T
 
-  , configJwtSecret         :: Maybe B.ByteString
-  , configJwtSecretIsBase64 :: Bool
+import Control.Lens            (preview)
+import Control.Monad           (fail)
+import Crypto.JWT              (JWK, JWKSet, StringOrURI, stringOrUri)
+import Data.Aeson              (toJSON)
+import Data.Either.Combinators (mapLeft)
+import Data.List               (lookup)
+import Data.List.NonEmpty      (fromList, toList)
+import Data.Maybe              (fromJust)
+import Data.Scientific         (floatingOrInteger)
+import Data.Time.Clock         (NominalDiffTime)
+import Numeric                 (readOct, showOct)
+import System.Environment      (getEnvironment)
+import System.Posix.Types      (FileMode)
 
-  , configPool              :: Int
-  , configMaxRows           :: Maybe Integer
-  , configReqCheck          :: Maybe Text
-  , configQuiet             :: Bool
+import PostgREST.Config.JSPath           (JSPath, JSPathExp (..),
+                                          dumpJSPath, pRoleClaimKey)
+import PostgREST.Config.Proxy            (Proxy (..),
+                                          isMalformedProxyUri, toURI)
+import PostgREST.DbStructure.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
   }
 
-defaultCorsPolicy :: CorsResourcePolicy
-defaultCorsPolicy =  CorsResourcePolicy Nothing
-  ["GET", "POST", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
-  (Just $ 60*60*24) False False True
+data LogLevel = LogCrit | LogError | LogWarn | LogInfo
 
--- | CORS policy to be used in by Wai Cors middleware
-corsPolicy :: Request -> Maybe CorsResourcePolicy
-corsPolicy req = case lookup "origin" headers of
-  Just origin -> Just defaultCorsPolicy {
-      corsOrigins = Just ([origin], True)
-    , corsRequestHeaders = "Authentication":accHeaders
-    , corsExposedHeaders = Just [
-        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
-      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
-      ]
-    }
-  Nothing -> Nothing
+dumpLogLevel :: LogLevel -> Text
+dumpLogLevel = \case
+  LogCrit  -> "crit"
+  LogError -> "error"
+  LogWarn  -> "warn"
+  LogInfo  -> "info"
+
+data OpenAPIMode = OAFollowPriv | OAIgnorePriv | OADisabled
+  deriving Eq
+
+dumpOpenApiMode :: OpenAPIMode -> Text
+dumpOpenApiMode = \case
+  OAFollowPriv -> "follow-privileges"
+  OAIgnorePriv -> "ignore-privileges"
+  OADisabled   -> "disabled"
+
+-- | Dump the config
+toText :: AppConfig -> Text
+toText conf =
+  unlines $ (\(k, v) -> k <> " = " <> v) <$> pgrstSettings ++ appSettings
   where
-    headers = requestHeaders req
-    accHeaders = case lookup "access-control-request-headers" headers of
-      Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs
-      Nothing -> []
+    -- apply conf to all pgrst settings
+    pgrstSettings = (\(k, v) -> (k, v conf)) <$>
+      [("db-anon-role",              q . configDbAnonRole)
+      ,("db-channel",                q . configDbChannel)
+      ,("db-channel-enabled",            T.toLower . show . configDbChannelEnabled)
+      ,("db-extra-search-path",      q . T.intercalate "," . configDbExtraSearchPath)
+      ,("db-max-rows",                   maybe "\"\"" show . configDbMaxRows)
+      ,("db-pool",                       show . configDbPoolSize)
+      ,("db-pool-timeout",               show . floor . configDbPoolTimeout)
+      ,("db-pre-request",            q . maybe mempty 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-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)
+      ,("log-level",                 q . dumpLogLevel . configLogLevel)
+      ,("openapi-mode",              q . dumpOpenApiMode . configOpenApiMode)
+      ,("openapi-server-proxy-uri",  q . fromMaybe mempty . configOpenApiServerProxyUri)
+      ,("raw-media-types",           q . T.decodeUtf8 . BS.intercalate "," . configRawMediaTypes)
+      ,("server-host",               q . configServerHost)
+      ,("server-port",                   show . configServerPort)
+      ,("server-unix-socket",        q . maybe mempty T.pack . configServerUnixSocket)
+      ,("server-unix-socket-mode",   q . T.pack . showSocketMode)
+      ]
 
--- | User friendly version number
-prettyVersion :: Text
-prettyVersion = intercalate "." $ map show $ versionBranch version
+    -- quote all app.settings
+    appSettings = second q <$> configAppSettings conf
 
--- | Function to read and parse options from the command line
-readOptions :: IO AppConfig
-readOptions = do
-  -- First read the config file path from command line
-  cfgPath <- customExecParser parserPrefs opts
-  -- Now read the actual config file
-  conf <- catch
-    (C.readConfig =<< C.load [C.Required cfgPath])
-    configNotfoundHint
+    -- quote strings and replace " with \"
+    q s = "\"" <> T.replace "\"" "\\\"" s <> "\""
 
-  let (mAppConf, errs) = flip C.runParserA conf $
-        AppConfig <$>
-            C.key "db-uri"
-          <*> C.key "db-anon-role"
-          <*> C.key "server-proxy-uri"
-          <*> C.key "db-schema"
-          <*> (fromMaybe "*4" <$> C.key "server-host")
-          <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port")
-          <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret")
-          <*> (fromMaybe False <$> C.key "secret-is-base64")
-          <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool")
-          <*> (join . fmap coerceInt <$> C.key "max-rows")
-          <*> C.key "pre-request"
-          <*> pure False
+    showTxEnd c = case (configDbTxRollbackAll c, configDbTxAllowOverride c) of
+      ( False, False ) -> "commit"
+      ( False, True  ) -> "commit-allow-override"
+      ( True , False ) -> "rollback"
+      ( True , True  ) -> "rollback-allow-override"
+    showJwtSecret c
+      | configJwtSecretIsBase64 c = B64.encode secret
+      | otherwise                 = secret
+      where
+        secret = fromMaybe mempty $ configJwtSecret c
+    showSocketMode c = showOct (configServerUnixSocketMode c) mempty
 
-  case mAppConf of
-    Nothing -> do
-      forM_ errs $ hPrint stderr
-      exitFailure
-    Just appConf ->
-      return appConf
+-- This class is needed for the polymorphism of overrideFromDbOrEnvironment
+-- because C.required and C.optional have different signatures
+class JustIfMaybe a b where
+  justIfMaybe :: a -> b
 
- where
-  coerceInt :: (Read i, Integral i) => Value -> Maybe i
-  coerceInt (Number x) = rightToMaybe $ floatingOrInteger x
-  coerceInt (String x) = readMaybe $ toS x
-  coerceInt _ = Nothing
+instance JustIfMaybe a a where
+  justIfMaybe a = a
 
-  opts = info (helper <*> pathParser) $
-           fullDesc
-           <> progDesc (
-               "PostgREST "
-               <> toS prettyVersion
-               <> " / create a REST API to an existing Postgres database"
-             )
-           <> footerDoc (Just $
-               text "Example Config File:"
-               L.<> nest 2 (hardline L.<> exampleCfg)
-             )
+instance JustIfMaybe a (Maybe a) where
+  justIfMaybe a = Just a
 
-  parserPrefs = prefs showHelpOnError
+-- | Reads and parses the config and overrides its parameters from env vars,
+-- files or db settings.
+readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> IO (Either Text AppConfig)
+readAppConfig dbSettings optPath prevDbUri = do
+  env <- readPGRSTEnvironment
+  -- if no filename provided, start with an empty map to read config from environment
+  conf <- maybe (return $ Right M.empty) loadConfig optPath
 
-  configNotfoundHint :: IOError -> IO a
-  configNotfoundHint e = do
-    hPutStrLn stderr $
-      "Cannot open config file:\n\t" <> show e
-    exitFailure
+  case C.runParser (parser optPath env dbSettings) =<< mapLeft show conf of
+    Left err ->
+      return . Left $ "Error in config " <> err
+    Right parsedConfig ->
+      Right <$> decodeLoadFiles parsedConfig
+  where
+    -- Both C.ParseError and IOError are shown here
+    loadConfig :: FilePath -> IO (Either SomeException C.Config)
+    loadConfig = try . C.load
 
-  exampleCfg :: Doc
-  exampleCfg = vsep . map (text . toS) . lines $
-    [str|db-uri = "postgres://user:pass@localhost:5432/dbname"
-        |db-schema = "public"
-        |db-anon-role = "postgres"
-        |db-pool = 10
-        |
-        |server-host = "*4"
-        |server-port = 3000
-        |
-        |## base url for swagger output
-        |# server-proxy-uri = ""
-        |
-        |## choose a secret to enable JWT auth
-        |## (use "@filename" to load from separate file)
-        |# jwt-secret = "foo"
-        |# secret-is-base64 = false
-        |
-        |## limit rows in response
-        |# max-rows = 1000
-        |
-        |## stored proc to exec immediately after auth
-        |# pre-request = "stored_proc_name"
-        |]
+    decodeLoadFiles :: AppConfig -> IO AppConfig
+    decodeLoadFiles parsedConfig =
+      decodeJWKS <$>
+        (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig)
 
-pathParser :: Parser FilePath
-pathParser =
-  strArgument $
-    metavar "FILENAME" <>
-    help "Path to configuration file"
+parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> C.Parser C.Config AppConfig
+parser optPath env dbSettings =
+  AppConfig
+    <$> parseAppSettings "app.settings"
+    <*> reqString "db-anon-role"
+    <*> (fromMaybe "pgrst" <$> optString "db-channel")
+    <*> (fromMaybe True <$> optBool "db-channel-enabled")
+    <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path")
+    <*> optWithAlias (optInt "db-max-rows")
+                     (optInt "max-rows")
+    <*> (fromMaybe 10 <$> optInt "db-pool")
+    <*> (fromIntegral . fromMaybe 10 <$> optInt "db-pool-timeout")
+    <*> (fmap toQi <$> optWithAlias (optString "db-pre-request")
+                                    (optString "pre-request"))
+    <*> (fromMaybe True <$> optBool "db-prepared-statements")
+    <*> (fmap toQi <$> optWithAlias (optString "db-root-spec")
+                                    (optString "root-spec"))
+    <*> (fromList . splitOnCommas <$> reqWithAlias (optValue "db-schemas")
+                                                   (optValue "db-schema")
+                                                   "missing key: either db-schemas or db-schema must be set")
+    <*> (fromMaybe True <$> optBool "db-config")
+    <*> parseTxEnd "db-tx-end" snd
+    <*> parseTxEnd "db-tx-end" fst
+    <*> reqString "db-uri"
+    <*> (fromMaybe True <$> optBool "db-use-legacy-gucs")
+    <*> pure optPath
+    <*> pure Nothing
+    <*> parseJwtAudience "jwt-aud"
+    <*> parseRoleClaimKey "jwt-role-claim-key" "role-claim-key"
+    <*> (fmap encodeUtf8 <$> optString "jwt-secret")
+    <*> (fromMaybe False <$> optWithAlias
+          (optBool "jwt-secret-is-base64")
+          (optBool "secret-is-base64"))
+    <*> parseLogLevel "log-level"
+    <*> parseOpenAPIMode "openapi-mode"
+    <*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri"
+    <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")
+    <*> (fromMaybe "!4" <$> optString "server-host")
+    <*> (fromMaybe 3000 <$> optInt "server-port")
+    <*> (fmap T.unpack <$> optString "server-unix-socket")
+    <*> parseSocketFileMode "server-unix-socket-mode"
+  where
+    parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
+    parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value
+      where
+        addFromEnv f = M.toList $ M.union fromEnv $ M.fromList f
+        fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env
+        normalize k = ("app.settings." <>) <$> T.stripPrefix "PGRST_APP_SETTINGS_" (toS k)
 
-data PgVersion = PgVersion {
-  pgvNum  :: Int32
-, pgvName :: Text
-}
+    parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode
+    parseSocketFileMode k =
+      optString k >>= \case
+        Nothing -> pure 432 -- return default 660 mode if no value was provided
+        Just fileModeText ->
+          case readOct $ T.unpack fileModeText of
+            []              ->
+              fail "Invalid server-unix-socket-mode: not an octal"
+            (fileMode, _):_ ->
+              if fileMode < 384 || fileMode > 511
+                then fail "Invalid server-unix-socket-mode: needs to be between 600 and 777"
+                else pure fileMode
 
--- | Tells the minimum PostgreSQL version required by this version of PostgREST
-minimumPgVersion :: PgVersion
-minimumPgVersion = PgVersion 90300 "9.3"
+    parseOpenAPIMode :: C.Key -> C.Parser C.Config OpenAPIMode
+    parseOpenAPIMode k =
+      optString k >>= \case
+        Nothing                  -> pure OAFollowPriv
+        Just "follow-privileges" -> pure OAFollowPriv
+        Just "ignore-privileges" -> pure OAIgnorePriv
+        Just "disabled"          -> pure OADisabled
+        Just _                   -> fail "Invalid openapi-mode. Check your configuration."
+
+    parseOpenAPIServerProxyURI :: C.Key -> C.Parser C.Config (Maybe Text)
+    parseOpenAPIServerProxyURI k =
+      optString k >>= \case
+        Nothing                            -> pure Nothing
+        Just val | isMalformedProxyUri val -> fail "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
+                 | otherwise               -> pure $ Just val
+
+    parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI)
+    parseJwtAudience k =
+      optString k >>= \case
+        Nothing -> pure Nothing -- no audience in config file
+        Just aud -> case preview stringOrUri (T.unpack aud) of
+          Nothing -> fail "Invalid Jwt audience. Check your configuration."
+          aud' -> pure aud'
+
+    parseLogLevel :: C.Key -> C.Parser C.Config LogLevel
+    parseLogLevel k =
+      optString k >>= \case
+        Nothing      -> pure LogError
+        Just "crit"  -> pure LogCrit
+        Just "error" -> pure LogError
+        Just "warn"  -> pure LogWarn
+        Just "info"  -> pure LogInfo
+        Just _       -> fail "Invalid logging level. Check your configuration."
+
+    parseTxEnd :: C.Key -> ((Bool, Bool) -> Bool) -> C.Parser C.Config Bool
+    parseTxEnd k f =
+      optString k >>= \case
+        --                                          RollbackAll AllowOverride
+        Nothing                        -> pure $ f (False,      False)
+        Just "commit"                  -> pure $ f (False,      False)
+        Just "commit-allow-override"   -> pure $ f (False,      True)
+        Just "rollback"                -> pure $ f (True,       False)
+        Just "rollback-allow-override" -> pure $ f (True,       True)
+        Just _                         -> fail "Invalid transaction termination. Check your configuration."
+
+    parseRoleClaimKey :: C.Key -> C.Key -> C.Parser C.Config JSPath
+    parseRoleClaimKey k al =
+      optWithAlias (optString k) (optString al) >>= \case
+        Nothing  -> pure [JSPKey "role"]
+        Just rck -> either (fail . show) pure $ pRoleClaimKey rck
+
+    reqWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> [Char] -> C.Parser C.Config a
+    reqWithAlias orig alias err =
+      orig >>= \case
+        Just v  -> pure v
+        Nothing ->
+          alias >>= \case
+            Just v  -> pure v
+            Nothing -> fail err
+
+    optWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a)
+    optWithAlias orig alias =
+      orig >>= \case
+        Just v  -> pure $ Just v
+        Nothing -> alias
+
+    reqString :: C.Key -> C.Parser C.Config Text
+    reqString k = overrideFromDbOrEnvironment C.required k coerceText
+
+    optString :: C.Key -> C.Parser C.Config (Maybe Text)
+    optString k = mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText
+
+    optValue :: C.Key -> C.Parser C.Config (Maybe C.Value)
+    optValue k = overrideFromDbOrEnvironment C.optional k identity
+
+    optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i)
+    optInt k = join <$> overrideFromDbOrEnvironment C.optional k coerceInt
+
+    optBool :: C.Key -> C.Parser C.Config (Maybe Bool)
+    optBool k = join <$> overrideFromDbOrEnvironment C.optional k coerceBool
+
+    overrideFromDbOrEnvironment :: JustIfMaybe a b =>
+                               (C.Key -> C.Parser C.Value a -> C.Parser C.Config b) ->
+                               C.Key -> (C.Value -> a) -> C.Parser C.Config b
+    overrideFromDbOrEnvironment necessity key coercion =
+      case reloadableDbSetting <|> M.lookup envVarName env of
+        Just dbOrEnvVal -> pure $ justIfMaybe $ coercion $ C.String dbOrEnvVal
+        Nothing  -> necessity key (coercion <$> C.value)
+      where
+        dashToUnderscore '-' = '_'
+        dashToUnderscore c   = c
+        envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key)
+        reloadableDbSetting =
+          let dbSettingName = T.pack $ dashToUnderscore <$> toS key in
+          if dbSettingName `notElem` [
+            "server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "log_level",
+            "db_anon_role", "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_timeout", "db_config"]
+          then lookup dbSettingName dbSettings
+          else Nothing
+
+    coerceText :: C.Value -> Text
+    coerceText (C.String s) = s
+    coerceText v            = show v
+
+    coerceInt :: (Read i, Integral i) => C.Value -> Maybe i
+    coerceInt (C.Number x) = rightToMaybe $ floatingOrInteger x
+    coerceInt (C.String x) = readMaybe $ toS x
+    coerceInt _            = Nothing
+
+    coerceBool :: C.Value -> Maybe Bool
+    coerceBool (C.Bool b)   = Just b
+    coerceBool (C.String s) =
+      -- parse all kinds of text: True, true, TRUE, "true", ...
+      case readMaybe . toS $ T.toTitle $ T.filter isAlpha $ toS s of
+        Just b  -> Just b
+        -- numeric instead?
+        Nothing -> (> 0) <$> (readMaybe $ toS s :: Maybe Integer)
+    coerceBool _            = Nothing
+
+    splitOnCommas :: C.Value -> [Text]
+    splitOnCommas (C.String s) = T.strip <$> T.splitOn "," s
+    splitOnCommas _            = []
+
+-- | Read the JWT secret from a file if configJwtSecret is actually a
+-- filepath(has @ as its prefix). To check if the JWT secret is provided is
+-- in fact a file path, it must be decoded as 'Text' to be processed.
+readSecretFile :: AppConfig -> IO AppConfig
+readSecretFile conf =
+  maybe (return conf) readSecret maybeFilename
+  where
+    maybeFilename = T.stripPrefix "@" . decodeUtf8 =<< configJwtSecret conf
+    readSecret filename = do
+      jwtSecret <- chomp <$> BS.readFile (toS filename)
+      return $ conf { configJwtSecret = Just jwtSecret }
+    chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs)
+
+decodeSecret :: AppConfig -> IO AppConfig
+decodeSecret conf@AppConfig{..} =
+  case (configJwtSecretIsBase64, configJwtSecret) of
+    (True, Just secret) ->
+      either fail (return . updateSecret) $ decodeB64 secret
+    _ -> return conf
+  where
+    updateSecret bs = conf { configJwtSecret = Just bs }
+    decodeB64 = B64.decode . encodeUtf8 . T.strip . replaceUrlChars . decodeUtf8
+    replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "="
+
+-- | Parse `jwt-secret` configuration option and turn into a JWKSet.
+--
+-- There are three ways to specify `jwt-secret`: text secret, JSON Web Key
+-- (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JWKSet
+-- with one key and the last is converted as is.
+decodeJWKS :: AppConfig -> AppConfig
+decodeJWKS conf =
+  conf { configJWKS = parseSecret <$> configJwtSecret conf }
+
+parseSecret :: ByteString -> JWKSet
+parseSecret bytes =
+  fromMaybe (maybe secret (\jwk' -> JWT.JWKSet [jwk']) maybeJWK)
+    maybeJWKSet
+  where
+    maybeJWKSet = JSON.decodeStrict bytes :: Maybe JWKSet
+    maybeJWK = JSON.decodeStrict bytes :: Maybe JWK
+    secret = JWT.JWKSet [JWT.fromKeyMaterial keyMaterial]
+    keyMaterial = JWT.OctKeyMaterial . JWT.OctKeyParameters $ JOSE.Base64Octets bytes
+
+-- | Read database uri from a separate file if `db-uri` is a filepath.
+readDbUriFile :: Maybe Text -> AppConfig -> IO AppConfig
+readDbUriFile maybeDbUri conf =
+  case maybeDbUri of
+    Just prevDbUri ->
+      pure $ conf { configDbUri = prevDbUri }
+    Nothing ->
+      case T.stripPrefix "@" $ configDbUri conf of
+        Nothing -> return conf
+        Just filename -> do
+          dbUri <- T.strip <$> readFile (toS filename)
+          return $ conf { configDbUri = dbUri }
+
+type Environment = M.Map [Char] Text
+
+-- | Read environment variables that start with PGRST_
+readPGRSTEnvironment :: IO Environment
+readPGRSTEnvironment =
+  M.map T.pack . M.fromList . filter (isPrefixOf "PGRST_" . fst) <$> getEnvironment

src/PostgREST/Config/Database.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module PostgREST.Config.Database
+  ( queryDbSettings
+  , queryPgVersion
+  ) where
+
+import PostgREST.Config.PgVersion (PgVersion (..))
+
+import qualified Hasql.Decoders             as HD
+import qualified Hasql.Encoders             as HE
+import qualified Hasql.Pool                 as 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 Protolude
+
+queryPgVersion :: Session PgVersion
+queryPgVersion = statement mempty $ SQL.Statement sql HE.noParams versionRow False
+  where
+    sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"
+    versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text
+
+queryDbSettings :: SQL.Pool -> Bool -> IO (Either SQL.UsageError [(Text, Text)])
+queryDbSettings pool prepared =
+  let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in
+  SQL.use pool . transaction SQL.ReadCommitted SQL.Read $
+    SQL.statement mempty dbSettingsStatement
+
+-- | 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
+  where
+    sql = [q|
+      with
+      role_setting as (
+        select setdatabase, unnest(setconfig) as setting from pg_catalog.pg_db_role_setting
+        where setrole = current_user::regrole::oid
+          and setdatabase in (0, (select oid from pg_catalog.pg_database where datname = current_catalog))
+      ),
+      kv_settings as (
+        select setdatabase, split_part(setting, '=', 1) as k, split_part(setting, '=', 2) as value from role_setting
+        where setting like 'pgrst.%'
+      )
+      select distinct on (key) replace(k, 'pgrst.', '') as key, value
+      from kv_settings
+      order by key, setdatabase desc;
+    |]
+    decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
+
+column :: HD.Value a -> HD.Row a
+column = HD.column . HD.nonNullable

src/PostgREST/Config/JSPath.hs

@@ -0,0 +1,51 @@
+module PostgREST.Config.JSPath
+  ( JSPath
+  , JSPathExp(..)
+  , dumpJSPath
+  , pRoleClaimKey
+  ) where
+
+import qualified Text.ParserCombinators.Parsec as P
+
+import Data.Either.Combinators       (mapLeft)
+import Text.ParserCombinators.Parsec ((<?>))
+import Text.Read                     (read)
+
+import Protolude
+
+
+-- | full jspath, e.g. .property[0].attr.detail
+type JSPath = [JSPathExp]
+
+-- | jspath expression, e.g. .property, .property[0] or ."property-dash"
+data JSPathExp
+  = JSPKey Text
+  | JSPIdx Int
+
+dumpJSPath :: JSPathExp -> Text
+-- TODO: this needs to be quoted properly for special chars
+dumpJSPath (JSPKey k) = "." <> show k
+dumpJSPath (JSPIdx i) = "[" <> show i <> "]"
+
+-- Used for the config value "role-claim-key"
+pRoleClaimKey :: Text -> Either Text JSPath
+pRoleClaimKey selStr =
+  mapLeft show $ P.parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)
+
+pJSPath :: P.Parser JSPath
+pJSPath = toJSPath <$> (period *> pPath `P.sepBy` period <* P.eof)
+  where
+    toJSPath :: [(Text, Maybe Int)] -> JSPath
+    toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))
+    period = P.char '.' <?> "period (.)"
+    pPath :: P.Parser (Text, Maybe Int)
+    pPath = (,) <$> pJSPKey <*> P.optionMaybe pJSPIdx
+
+pJSPKey :: P.Parser Text
+pJSPKey = toS <$> P.many1 (P.alphaNum <|> P.oneOf "_$@") <|> pQuotedValue <?> "attribute name [a..z0..9_$@])"
+
+pJSPIdx :: P.Parser Int
+pJSPIdx = P.char '[' *> (read <$> P.many1 P.digit) <* P.char ']' <?> "array index [0..n]"
+
+pQuotedValue :: P.Parser Text
+pQuotedValue = toS <$> (P.char '"' *> P.many (P.noneOf "\"") <* P.char '"')

src/PostgREST/Config/PgVersion.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+module PostgREST.Config.PgVersion
+  ( PgVersion(..)
+  , minimumPgVersion
+  , pgVersion96
+  , pgVersion100
+  , pgVersion109
+  , pgVersion110
+  , pgVersion112
+  , pgVersion114
+  , pgVersion121
+  , pgVersion130
+  , pgVersion140
+  ) where
+
+import qualified Data.Aeson as JSON
+
+import Protolude
+
+
+data PgVersion = PgVersion
+  { pgvNum  :: Int32
+  , pgvName :: Text
+  }
+  deriving (Eq, Generic, JSON.ToJSON)
+
+instance Ord PgVersion where
+  (PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2
+
+-- | Tells the minimum PostgreSQL version required by this version of PostgREST
+minimumPgVersion :: PgVersion
+minimumPgVersion = pgVersion96
+
+pgVersion96 :: PgVersion
+pgVersion96 = PgVersion 90600 "9.6"
+
+pgVersion100 :: PgVersion
+pgVersion100 = PgVersion 100000 "10"
+
+pgVersion109 :: PgVersion
+pgVersion109 = PgVersion 100009 "10.9"
+
+pgVersion110 :: PgVersion
+pgVersion110 = PgVersion 110000 "11.0"
+
+pgVersion112 :: PgVersion
+pgVersion112 = PgVersion 110002 "11.2"
+
+pgVersion114 :: PgVersion
+pgVersion114 = PgVersion 110004 "11.4"
+
+pgVersion121 :: PgVersion
+pgVersion121 = PgVersion 120001 "12.1"
+
+pgVersion130 :: PgVersion
+pgVersion130 = PgVersion 130000 "13.0"
+
+pgVersion140 :: PgVersion
+pgVersion140 = PgVersion 140000 "14.0"

src/PostgREST/Config/Proxy.hs

@@ -0,0 +1,77 @@
+{-|
+Module      : PostgREST.Private.ProxyUri
+Description : Proxy Uri validator
+-}
+module PostgREST.Config.Proxy
+  ( Proxy(..)
+  , isMalformedProxyUri
+  , toURI
+  ) where
+
+import qualified Data.Text as T
+
+import Data.Maybe  (fromJust)
+import Network.URI (URI (..), URIAuth (..), isAbsoluteURI, parseURI)
+
+import Protolude hiding (Proxy)
+
+data Proxy = Proxy
+  { proxyScheme :: Text
+  , proxyHost   :: Text
+  , proxyPort   :: Integer
+  , proxyPath   :: Text
+  }
+
+{-|
+  Test whether a proxy uri is malformed or not.
+  A valid proxy uri should be an absolute uri without query and user info,
+  only http(s) schemes are valid, port number range is 1-65535.
+
+  For example
+  http://postgrest.com/openapi.json
+  https://postgrest.com:8080/openapi.json
+-}
+isMalformedProxyUri :: Text -> Bool
+isMalformedProxyUri uri
+  | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri
+  | otherwise = True
+
+toURI :: Text -> URI
+toURI uri = fromJust $ parseURI (toS uri)
+
+isUriValid:: URI -> Bool
+isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]
+
+fAnd :: [a -> Bool] -> a -> Bool
+fAnd fs x = all ($ x) fs
+
+isSchemeValid :: URI -> Bool
+isSchemeValid URI {uriScheme = s}
+  | T.toLower (T.pack s) == "https:" = True
+  | T.toLower (T.pack s) == "http:" = True
+  | otherwise = False
+
+isQueryValid :: URI -> Bool
+isQueryValid URI {uriQuery = ""} = True
+isQueryValid _                   = False
+
+isAuthorityValid :: URI -> Bool
+isAuthorityValid URI {uriAuthority = a}
+  | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a
+  | otherwise = False
+
+isUserInfoValid :: URIAuth -> Bool
+isUserInfoValid URIAuth {uriUserInfo = ""} = True
+isUserInfoValid _                          = False
+
+isHostValid :: URIAuth -> Bool
+isHostValid URIAuth {uriRegName = ""} = False
+isHostValid _                         = True
+
+isPortValid :: URIAuth -> Bool
+isPortValid URIAuth {uriPort = ""} = True
+isPortValid URIAuth {uriPort = (':':p)} =
+  case readMaybe p of
+    Just i  -> i > (0 :: Integer) && i < 65536
+    Nothing -> False
+isPortValid _ = False

src/PostgREST/ContentType.hs

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

src/PostgREST/DbRequestBuilder.hs

@@ -1,286 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DuplicateRecordFields    #-}
-module PostgREST.DbRequestBuilder (
-  readRequest
-, mutateRequest
-, fieldNames
-) where
-
-import           Control.Applicative
-import           Control.Arrow             ((***))
-import           Control.Lens.Getter       (view)
-import           Control.Lens.Tuple        (_1)
-import qualified Data.ByteString.Char8     as BS
-import           Data.List                 (delete)
-import           Data.Maybe                (fromJust)
-import           Data.Text                 (isInfixOf)
-import           Data.Tree
-import           Data.Either.Combinators   (mapLeft)
-
-import           Network.Wai
-
-import           Data.Foldable (foldr1)
-import qualified Data.HashMap.Strict       as M
-
-import           PostgREST.ApiRequest   ( ApiRequest(..)
-                                        , PreferRepresentation(..)
-                                        , Action(..), Target(..)
-                                        , PreferRepresentation (..)
-                                        )
-import           PostgREST.Error           (apiRequestError)
-import           PostgREST.Parsers
-import           PostgREST.RangeQuery      (NonnegRange, restrictRange)
-import           PostgREST.QueryBuilder (getJoinConditions, sourceCTEName)
-import           PostgREST.Types
-
-import           Protolude                hiding (from, dropWhile, drop)
-import           Text.Regex.TDFA         ((=~))
-import           Unsafe                  (unsafeHead)
-
-readRequest :: Maybe Integer -> [Relation] -> M.HashMap Text ProcDescription -> ApiRequest -> Either Response ReadRequest
-readRequest maxRows allRels allProcs apiRequest  =
-  mapLeft apiRequestError $
-  treeRestrictRange maxRows =<<
-  augumentRequestWithJoin schema relations =<<
-  parseReadRequest
-  where
-    (schema, rootTableName) = fromJust $ -- Make it safe
-      let target = iTarget apiRequest in
-      case target of
-        (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
-        (TargetProc  (QualifiedIdentifier s proc) ) -> Just (s, tName)
-          where
-            retType = pdReturnType <$> M.lookup proc allProcs
-            tName = case retType of
-              Just (SetOf (Composite qi)) -> qiName qi
-              Just (Single (Composite qi)) -> qiName qi
-              _ -> proc
-
-        _ -> Nothing
-
-    action :: Action
-    action = iAction apiRequest
-
-    parseReadRequest :: Either ApiRequestError ReadRequest
-    parseReadRequest = addFiltersOrdersRanges apiRequest <*>
-      pRequestSelect rootName selStr
-      where
-        selStr = iSelect apiRequest
-        rootName = if action == ActionRead
-          then rootTableName
-          else sourceCTEName
-
-    relations :: [Relation]
-    relations = case action of
-      ActionCreate -> fakeSourceRelations ++ allRels
-      ActionUpdate -> fakeSourceRelations ++ allRels
-      ActionDelete -> fakeSourceRelations ++ allRels
-      ActionInvoke -> fakeSourceRelations ++ allRels
-      _       -> allRels
-      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
-
-treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
-treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
-  where
-    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
-    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
-
-augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either ApiRequestError ReadRequest
-augumentRequestWithJoin schema allRels request =
-  addRelations schema allRels Nothing request
-  >>= addJoinConditions schema
-
-addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
-addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) =
-  case parentNode of
-    (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) ->
-      Node <$> readNode' <*> forest'
-      where
-        forest' = updateForest $ hush node'
-        node' = Node <$> readNode' <*> pure forest
-        readNode' = addRel readNode <$> rel
-        rel :: Either ApiRequestError Relation
-        rel = note (NoRelationBetween parentNodeTable name)
-            $ findRelation schema name parentNodeTable
-
-            where
-              findRelation s nodeTableName parentNodeTableName =
-                find (\r ->
-                  s == tableSchema (relTable r) && -- match schema for relation table
-                  s == tableSchema (relFTable r) && -- match schema for relation foriegn table
-                  (
-
-                    -- (request)        => projects { ..., clients{...} }
-                    -- will match
-                    -- (relation type)  => parent
-                    -- (entity)         => clients  {id}
-                    -- (foriegn entity) => projects {client_id}
-                    (
-                      nodeTableName == tableName (relTable r) && -- match relation table name
-                      parentNodeTableName == tableName (relFTable r) -- match relation foreign table name
-                    ) ||
-
-
-                    -- (request)        => projects { ..., client_id{...} }
-                    -- will match
-                    -- (relation type)  => parent
-                    -- (entity)         => clients  {id}
-                    -- (foriegn entity) => projects {client_id}
-                    (
-                      parentNodeTableName == tableName (relFTable r) &&
-                      length (relFColumns r) == 1 &&
-                      nodeTableName `colMatches` (colName . unsafeHead . relFColumns) r
-                    )
-
-                    -- (request)        => project_id { ..., client_id{...} }
-                    -- will match
-                    -- (relation type)  => parent
-                    -- (entity)         => clients  {id}
-                    -- (foriegn entity) => projects {client_id}
-                    -- this case works becasue before reaching this place
-                    -- addRelation will turn project_id to project so the above condition will match
-                  )
-                ) allRelations
-                where n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString)
-        addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
-        addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a))
-          where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query')
-
-    _ -> n' <$> updateForest (Just (n' forest))
-      where
-        n' = Node (query, (name, Just r, alias))
-        t = Table schema name True -- !!! TODO find another way to get the table from the query
-        r = Relation t [] t [] Root Nothing Nothing Nothing
-  where
-    updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
-    updateForest n = mapM (addRelations schema allRelations n) forest
-
-addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest
-addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
-  case r of
-    Just Relation{relType=Root} -> Node nn  <$> updatedForest -- this is the root node
-    Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest
-    Just Relation{relType=Parent} -> Node nn <$> updatedForest
-    Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->
-      Node (qq, (n, r, a)) <$> updatedForest
-      where
-         query' = addCond query (getJoinConditions rel)
-         qq = query'{from=tableName linkTable : from query'}
-    _ -> Left UnknownRelation
-  where
-    updatedForest = mapM (addJoinConditions schema) forest
-    addCond query' con = query'{flt_=con ++ flt_ query'}
-
-addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest)
-addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
-    flip (foldr addFilter) <$> filters,
-    flip (foldr addOrder) <$> orders,
-    flip (foldr addRange) <$> ranges,
-    flip (foldr addLogicTree) <$> logicForest
-  ]
-  {-
-  The esence of what is going on above is that we are composing tree functions
-  of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context
-  -}
-  where
-    filters :: Either ApiRequestError [(EmbedPath, Filter)]
-    filters = mapM pRequestFilter flts
-    logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)]
-    logicForest = mapM pRequestLogicTree logFrst
-    action = iAction apiRequest
-    -- there can be no filters on the root table when we are doing insert/update/delete
-    (flts, logFrst)
-      | action == ActionRead || action == ActionInvoke = (iFilters apiRequest, iLogic apiRequest)
-      | otherwise = join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
-    orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]
-    orders = mapM pRequestOrder $ iOrder apiRequest
-    ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]
-    ranges = mapM pRequestRange $ M.toList $ iRange apiRequest
-
-addFilterToNode :: Filter -> ReadRequest -> ReadRequest
-addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f
-
-addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest
-addFilter = addProperty addFilterToNode
-
-addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest
-addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f
-
-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{logic=l},i) f) = Node (q{logic=t:l}::ReadQuery, i) f
-
-addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest
-addLogicTree = addProperty addLogicTreeToNode
-
-addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest
-addProperty f ([], a) n = f a n
-addProperty f (path, a) (Node rn forest) =
-  case targetNode of
-    Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path
-    Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest)
-  where
-    targetNodeName:remainingPath = path
-    (targetNode,restForest) = splitForest targetNodeName forest
-    splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode)
-    splitForest name forst =
-      case maybeNode of
-        Nothing -> (Nothing,forest)
-        Just node -> (Just node, delete node forest)
-      where
-        maybeNode :: Maybe ReadRequest
-        maybeNode = find fnd forst
-          where
-            fnd :: ReadRequest -> Bool
-            fnd (Node (_,(n,_,_)) _) = n == name
-
--- in a relation where one of the tables mathces "TableName"
--- replace the name to that table with pg_source
--- this "fake" relations is needed so that in a mutate query
--- we can look a the "returning *" part which is wrapped with a "with"
--- as just another table that has relations with other tables
-toSourceRelation :: TableName -> Relation -> Maybe Relation
-toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
-  | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}
-  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}
-  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}
-  | otherwise = Nothing
-
-mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest
-mutateRequest apiRequest fldNames = mapLeft apiRequestError $
-  case action of
-    ActionCreate -> Right $ Insert rootTableName payload returnings
-    ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> logic_ <*> pure returnings
-    ActionDelete -> Delete rootTableName <$> filters <*> logic_ <*> pure returnings
-    _        -> Left UnsupportedVerb
-  where
-    action = iAction apiRequest
-    payload = fromJust $ iPayload apiRequest
-    rootTableName = -- TODO: Make it safe
-      let target = iTarget apiRequest in
-      case target of
-        (TargetIdent (QualifiedIdentifier _ t) ) -> t
-        _ -> undefined
-    returnings = if iPreferRepresentation apiRequest == None then [] else fldNames
-    filters = map snd <$> mapM pRequestFilter mutateFilters
-    logic_ = map snd <$> mapM pRequestLogicTree logicFilters
-    -- update/delete filters can be only on the root table
-    mutateFilters = onlyRoot $ iFilters apiRequest
-    logicFilters = onlyRoot $ iLogic apiRequest
-    onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
-
-fieldNames :: ReadRequest -> [FieldName]
-fieldNames (Node (sel, _) forest) =
-  map (fst . view _1) (select sel) ++ map colName fks
-  where
-    fks = concatMap (fromMaybe [] . f) forest
-    f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _)) _) = Just cols
-    f _ = Nothing

src/PostgREST/DbStructure/Identifiers.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+
+module PostgREST.DbStructure.Identifiers
+  ( QualifiedIdentifier(..)
+  , Schema
+  , TableName
+  , FieldName
+  , dumpQi
+  , toQi
+  ) where
+
+import qualified Data.Aeson as JSON
+import qualified Data.Text  as T
+
+import Protolude
+
+
+-- | Represents a pg identifier with a prepended schema name "schema.table".
+-- When qiSchema is "", the schema is defined by the pg search_path.
+data QualifiedIdentifier = QualifiedIdentifier
+  { qiSchema :: Schema
+  , qiName   :: TableName
+  }
+  deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey)
+
+instance Hashable QualifiedIdentifier
+
+dumpQi :: QualifiedIdentifier -> Text
+dumpQi (QualifiedIdentifier s i) =
+  (if T.null s then mempty else s <> ".") <> i
+
+-- TODO: Handle a case where the QI comes like this: "my.fav.schema"."my.identifier"
+-- Right now it only handles the schema.identifier case
+toQi :: Text -> QualifiedIdentifier
+toQi txt = case T.drop 1 <$> T.breakOn "." txt of
+  (i, "") -> QualifiedIdentifier mempty i
+  (s, i)  -> QualifiedIdentifier s i
+
+type Schema = Text
+type TableName = Text
+type FieldName = Text

src/PostgREST/DbStructure/Proc.hs

@@ -0,0 +1,85 @@
+{-# 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

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

src/PostgREST/DbStructure/Table.hs

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

src/PostgREST/Error.hs

@@ -1,85 +1,88 @@
+{-|
+Module      : PostgREST.Error
+Description : PostgREST error HTTP responses
+-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE RecordWildCards #-}
 
-module PostgREST.Error (
-  apiRequestError
-, pgError
-, simpleError
-, singularityError
-, binaryFieldError
-, connectionLostError
-, encodeError
-) where
+module PostgREST.Error
+  ( errorResponseFor
+  , ApiRequestError(..)
+  , PgError(..)
+  , Error(..)
+  , errorPayload
+  , checkIsFatal
+  , singularityError
+  ) where
 
-import           Protolude
-import           Data.Aeson                ((.=))
 import qualified Data.Aeson                as JSON
-import           Data.Text                 (unwords)
-import qualified Hasql.Pool                as P
-import qualified Hasql.Session             as H
-import qualified Network.HTTP.Types.Status as HT
-import           Network.Wai               (Response, responseLBS)
-import           PostgREST.Types
+import qualified Data.ByteString.Char8     as BS
+import qualified Data.Text                 as T
+import qualified Data.Text.Encoding        as T
+import qualified Data.Text.Encoding.Error  as T
+import qualified Hasql.Pool                as SQL
+import qualified Hasql.Session             as SQL
+import qualified Network.HTTP.Types.Status as HTTP
 
-apiRequestError :: ApiRequestError -> Response
-apiRequestError err = errorResponse status err
-  where
-    status =
-      case err of
-        ActionInappropriate -> HT.status405
-        UnsupportedVerb -> HT.status405
-        InvalidBody _ -> HT.status400
-        ParseRequestError _ _ -> HT.status400
-        NoRelationBetween _ _ -> HT.status400
-        InvalidRange -> HT.status416
-        UnknownRelation -> HT.status404
+import Data.Aeson  ((.=))
+import Network.Wai (Response, responseLBS)
 
-simpleError :: HT.Status -> Text -> Response
-simpleError status message =
-  errorResponse status $ JSON.object ["message" .= message]
+import Network.HTTP.Types.Header (Header)
 
-errorResponse :: JSON.ToJSON a => HT.Status -> a -> Response
-errorResponse status e =
-  responseLBS status [toHeader CTApplicationJSON] $ encodeError e
+import           PostgREST.ContentType (ContentType (..))
+import qualified PostgREST.ContentType as ContentType
 
-pgError :: Bool -> P.UsageError -> Response
-pgError authed e =
-  let status = httpStatus authed e
-      jsonType = toHeader CTApplicationJSON
-      wwwAuth = ("WWW-Authenticate", "Bearer")
-      hdrs = if status == HT.status401
-                then [jsonType, wwwAuth]
-                else [jsonType] in
-  responseLBS status hdrs (encodeError e)
+import PostgREST.DbStructure.Proc         (ProcDescription (..),
+                                           ProcParam (..))
+import PostgREST.DbStructure.Relationship (Cardinality (..),
+                                           Junction (..),
+                                           Relationship (..))
+import PostgREST.DbStructure.Table        (Column (..), Table (..))
 
-singularityError :: Integer -> Response
-singularityError numRows =
-  responseLBS HT.status406
-    [toHeader CTSingularJSON]
-    $ toS . formatGeneralError
-      "JSON object requested, multiple (or no) rows returned"
-      $ unwords
-        [ "Results contain", show numRows, "rows,"
-        , toS (toMime CTSingularJSON), "requires 1 row"
-        ]
-  where
-    formatGeneralError :: Text -> Text -> Text
-    formatGeneralError message details = toS . JSON.encode $
-      JSON.object ["message" .= message, "details" .= details]
+import Protolude
 
 
-binaryFieldError :: Response
-binaryFieldError =
-  simpleError HT.status406 (toS (toMime CTOctetStream) <>
-  " requested but a single column was not selected")
+class (JSON.ToJSON a) => PgrstError a where
+  status   :: a -> HTTP.Status
+  headers  :: a -> [Header]
 
-connectionLostError :: Response
-connectionLostError =
-  simpleError HT.status503 "Database connection lost, retrying the connection."
+  errorPayload :: a -> LByteString
+  errorPayload = JSON.encode
 
-encodeError :: JSON.ToJSON a => a -> LByteString
-encodeError = 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?
+
+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 AmbiguousRelBetween{}   = HTTP.status300
+  status (AmbiguousRpc _)        = HTTP.status300
+  status NoRpc{}                 = HTTP.status404
+  status (UnacceptableSchema _)  = HTTP.status406
+  status (ContentTypeError _)    = HTTP.status415
+
+  headers _ = [ContentType.toHeader CTApplicationJSON]
 
 instance JSON.ToJSON ApiRequestError where
   toJSON (ParseRequestError message details) = JSON.object [
@@ -87,81 +90,256 @@ instance JSON.ToJSON ApiRequestError where
   toJSON ActionInappropriate = JSON.object [
     "message" .= ("Bad Request" :: Text)]
   toJSON (InvalidBody errorMessage) = JSON.object [
-    "message" .= (toS errorMessage :: Text)]
+    "message" .= T.decodeUtf8 errorMessage]
   toJSON InvalidRange = JSON.object [
     "message" .= ("HTTP Range error" :: Text)]
-  toJSON UnknownRelation = JSON.object [
-    "message" .= ("Unknown relation" :: Text)]
-  toJSON (NoRelationBetween parent child) = JSON.object [
-    "message" .= ("Could not find foreign keys between these entities, No relation found between " <> parent <> " and " <> child :: Text)]
+  toJSON (NoRelBetween parent child) = JSON.object [
+    "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 <>
+      (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))]
 
-instance JSON.ToJSON P.UsageError where
-  toJSON (P.ConnectionError e) = JSON.object [
-    "code" .= ("" :: Text),
-    "message" .= ("Database connection error" :: Text),
-    "details" .= (toS $ fromMaybe "" e :: Text)]
-  toJSON (P.SessionError e) = JSON.toJSON e -- H.Error
+compressedRel :: Relationship -> JSON.Value
+compressedRel Relationship{..} =
+  let
+    fmtTbl Table{..} = tableSchema <> "." <> tableName
+    fmtEls els = "[" <> T.intercalate ", " els <> "]"
+  in
+  JSON.object $
+    ("embedding" .= (tableName relTable <> " with " <> tableName relForeignTable :: Text))
+    : case relCardinality of
+        M2M Junction{..} -> [
+            "cardinality" .= ("many-to-many" :: Text)
+          , "relationship" .= (fmtTbl junTable <> fmtEls [junConstraint1] <> fmtEls [junConstraint2])
+          ]
+        M2O cons -> [
+            "cardinality" .= ("many-to-one" :: Text)
+          , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns))
+          ]
+        O2M cons -> [
+            "cardinality" .= ("one-to-many" :: Text)
+          , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns))
+          ]
 
-instance JSON.ToJSON H.Error where
-  toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [
-    "code" .= (toS c::Text),
-    "message" .= (toS m::Text),
-    "details" .= (fmap toS d::Maybe Text),
-    "hint" .= (fmap toS h::Maybe Text)]
-  toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [
-    "message" .= (m::Text)]
-  toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [
-    "message" .= ("Row error: end of input"::Text),
-    "details" .=
-      ("Attempt to parse more columns than there are in the result"::Text),
-    "details" .= (("Row number " <> show i)::Text)]
-  toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [
-    "message" .= ("Row error: unexpected null"::Text),
-    "details" .= ("Attempt to parse a NULL as some value."::Text),
-    "details" .= (("Row number " <> show i)::Text)]
-  toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [
-    "message" .= ("Row error: Wrong value parser used"::Text),
+relHint :: [Relationship] -> Text
+relHint rels = T.intercalate ", " (hintList <$> rels)
+  where
+    hintList Relationship{..} =
+      let buildHint rel = "'" <> tableName relForeignTable <> "!" <> rel <> "'" in
+      case relCardinality of
+        M2M Junction{..} -> buildHint (tableName junTable)
+        M2O cons         -> buildHint cons
+        O2M cons         -> buildHint cons
+
+data PgError = PgError Authenticated SQL.UsageError
+type Authenticated = Bool
+
+instance PgrstError PgError where
+  status (PgError authed usageError) = pgErrorStatus authed usageError
+
+  headers err =
+    if status err == HTTP.status401
+       then [ContentType.toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
+       else [ContentType.toHeader CTApplicationJSON]
+
+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
+
+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]
+
+    _         -> 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,
-    "details" .= (("Row number " <> show i)::Text)]
-  toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [
-    "message" .= ("Unexpected amount of rows"::Text),
+    "hint"    .= (("Row number " <> show i) :: Text)]
+  toJSON (SQL.ResultError (SQL.UnexpectedAmountOfRows i)) = JSON.object [
+    "message" .= ("Unexpected amount of rows" :: Text),
     "details" .= i]
-  toJSON (H.ClientError d) = JSON.object [
-    "message" .= ("Database client error"::Text),
-    "details" .= (fmap toS d::Maybe Text)]
+  toJSON (SQL.ClientError d) = JSON.object [
+    "message" .= ("Database client error. Retrying the connection." :: Text),
+    "details" .= (fmap T.decodeUtf8 d :: Maybe Text)]
 
-httpStatus :: Bool -> P.UsageError -> HT.Status
-httpStatus _ (P.ConnectionError _) = HT.status503
-httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
-  case toS c of
-    '0':'8':_ -> HT.status503 -- pg connection err
-    '0':'9':_ -> HT.status500 -- triggered action exception
-    '0':'L':_ -> HT.status403 -- invalid grantor
-    '0':'P':_ -> HT.status403 -- invalid role specification
-    "23503"   -> HT.status409 -- foreign_key_violation
-    "23505"   -> HT.status409 -- unique_violation
-    '2':'5':_ -> HT.status500 -- invalid tx state
-    '2':'8':_ -> HT.status403 -- invalid auth specification
-    '2':'D':_ -> HT.status500 -- invalid tx termination
-    '3':'8':_ -> HT.status500 -- external routine exception
-    '3':'9':_ -> HT.status500 -- external routine invocation
-    '3':'B':_ -> HT.status500 -- savepoint exception
-    '4':'0':_ -> HT.status500 -- tx rollback
-    '5':'3':_ -> HT.status503 -- insufficient resources
-    '5':'4':_ -> HT.status413 -- too complex
-    '5':'5':_ -> HT.status500 -- obj not on prereq state
-    '5':'7':_ -> HT.status500 -- operator intervention
-    '5':'8':_ -> HT.status500 -- system error
-    'F':'0':_ -> HT.status500 -- conf file error
-    'H':'V':_ -> HT.status500 -- foreign data wrapper error
-    "P0001"   -> HT.status400 -- default code for "raise"
-    'P':'0':_ -> HT.status500 -- PL/pgSQL Error
-    'X':'X':_ -> HT.status500 -- internal Error
-    "42883"   -> HT.status404 -- undefined function
-    "42P01"   -> HT.status404 -- undefined table
-    "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
-    _         -> HT.status400
-httpStatus _ (P.SessionError (H.ResultError _)) = HT.status500
-httpStatus _ (P.SessionError (H.ClientError _)) = HT.status503
+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))) =
+  case rError of
+    (SQL.ServerError c m _ _) ->
+      case BS.unpack c of
+        '0':'8':_ -> HTTP.status503 -- pg connection err
+        '0':'9':_ -> HTTP.status500 -- triggered action exception
+        '0':'L':_ -> HTTP.status403 -- invalid grantor
+        '0':'P':_ -> HTTP.status403 -- invalid role specification
+        "23503"   -> HTTP.status409 -- foreign_key_violation
+        "23505"   -> HTTP.status409 -- unique_violation
+        "25006"   -> HTTP.status405 -- read_only_sql_transaction
+        '2':'5':_ -> HTTP.status500 -- invalid tx state
+        '2':'8':_ -> HTTP.status403 -- invalid auth specification
+        '2':'D':_ -> HTTP.status500 -- invalid tx termination
+        '3':'8':_ -> HTTP.status500 -- external routine exception
+        '3':'9':_ -> HTTP.status500 -- external routine invocation
+        '3':'B':_ -> HTTP.status500 -- savepoint exception
+        '4':'0':_ -> HTTP.status500 -- tx rollback
+        '5':'3':_ -> HTTP.status503 -- insufficient resources
+        '5':'4':_ -> HTTP.status413 -- too complex
+        '5':'5':_ -> HTTP.status500 -- obj not on prereq state
+        '5':'7':_ -> HTTP.status500 -- operator intervention
+        '5':'8':_ -> HTTP.status500 -- system error
+        'F':'0':_ -> HTTP.status500 -- conf file error
+        'H':'V':_ -> HTTP.status500 -- foreign data wrapper error
+        "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
+        "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)
+        _         -> 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
+  | JwtTokenInvalid Text
+  | SingularityError Integer
+  | NotFound
+  | ApiRequestError ApiRequestError
+  | 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
+
+  headers (SingularityError _)     = [ContentType.toHeader CTSingularJSON]
+  headers (JwtTokenInvalid m)      = [ContentType.toHeader CTApplicationJSON, invalidTokenHeader m]
+  headers (PgErr err)              = headers err
+  headers (ApiRequestError err)    = headers err
+  headers _                        = [ContentType.toHeader CTApplicationJSON]
+
+instance JSON.ToJSON 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 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 (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 JwtTokenMissing           = JSON.object [
+    "message" .= ("Server lacks JWT secret" :: Text)]
+  toJSON (JwtTokenInvalid message) = JSON.object [
+    "message" .= (message :: Text)]
+  toJSON NotFound = JSON.object []
+  toJSON (PgErr err) = JSON.toJSON err
+  toJSON (ApiRequestError err) = JSON.toJSON err
+
+invalidTokenHeader :: Text -> Header
+invalidTokenHeader m =
+  ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m))
+
+singularityError :: (Integral a) => a -> Error
+singularityError = SingularityError . toInteger

src/PostgREST/GucHeader.hs

@@ -0,0 +1,36 @@
+module PostgREST.GucHeader
+  ( GucHeader
+  , unwrapGucHeader
+  , addHeadersIfNotIncluded
+  ) where
+
+import qualified Data.Aeson           as JSON
+import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict  as M
+
+import Network.HTTP.Types.Header (Header)
+
+import Protolude
+
+
+{-|
+  Custom guc header, it's obtained by parsing the json in a:
+  `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
+-}
+newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
+
+instance JSON.FromJSON GucHeader where
+  parseJSON (JSON.Object o) =
+    case M.toList o of
+      [(k, JSON.String s)] -> pure $ GucHeader (CI.mk $ toUtf8 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/Middleware.hs

@@ -1,63 +1,204 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-|
+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
 
-module PostgREST.Middleware 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           Data.Aeson                    (Value (..))
-import qualified Data.HashMap.Strict           as M
-import qualified Hasql.Transaction             as H
+import Control.Arrow ((***))
 
-import           Network.HTTP.Types.Status     (unauthorized401, status500)
-import           Network.Wai                   (Application, Response,
-                                                responseLBS)
-import           Network.Wai.Middleware.Cors   (cors)
-import           Network.Wai.Middleware.Gzip   (def, gzip)
-import           Network.Wai.Middleware.Static (only, staticPolicy)
+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.ApiRequest          (ApiRequest(..))
-import           PostgREST.Auth                (JWTAttempt(..))
-import           PostgREST.Config              (AppConfig (..), corsPolicy)
-import           PostgREST.Error               (simpleError)
-import           PostgREST.Types               (ContentType (..), toHeader)
-import           PostgREST.QueryBuilder        (pgFmtLit, unquoted, pgFmtEnvVar)
+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           Protolude                     hiding (concat, null)
+import PostgREST.Request.Preferences
 
-runWithClaims :: AppConfig -> JWTAttempt ->
-                 (ApiRequest -> H.Transaction Response) ->
-                 ApiRequest -> H.Transaction Response
-runWithClaims conf eClaims app req =
-  case eClaims of
-    JWTExpired -> return $ unauthed "JWT expired"
-    JWTInvalid -> return $ unauthed "JWT invalid"
-    JWTMissingSecret -> return $ simpleError status500 "Server lacks JWT secret"
-    JWTClaims claims -> do
-      H.sql $ toS.mconcat $ setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql
-      mapM_ H.sql customReqCheck
-      app req
-      where
-        headersSql = map (pgFmtEnvVar "request.header.") $ iHeaders req
-        cookiesSql = map (pgFmtEnvVar "request.cookie.") $ iCookies req
-        claimsSql = map (pgFmtEnvVar "request.jwt.claim.") [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]
-        setRoleSql = maybeToList $
-          (\r -> "set local role " <> r <> ";") . toS . pgFmtLit . unquoted <$> M.lookup "role" claimsWithRole
-        -- role claim defaults to anon if not specified in jwt
-        claimsWithRole = M.union claims (M.singleton "role" anon)
-        anon = String . toS $ configAnonRole conf
-        customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
+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
-    unauthed message = responseLBS unauthorized401
-      [ toHeader CTApplicationJSON
-      , ( "WWW-Authenticate"
-        , "Bearer error=\"invalid_token\", " <>
-          "error_description=\"" <> message <> "\""
-        )
-      ]
-      (toS $ "{\"message\":\""<>message<>"\"}")
+    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
 
-defaultMiddle :: Application -> Application
-defaultMiddle =
-    gzip def
-  . cors corsPolicy
-  . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+-- | Log in apache format. Only requests that have a status greater than minStatus are logged.
+-- | There's no way to filter logs in the apache format on wai-extra: https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html#t:OutputFormat.
+-- | So here we copy wai-logger apacheLogStr function: https://github.com/kazu-yamamoto/logger/blob/a4f51b909a099c51af7a3f75cf16e19a06f9e257/wai-logger/Network/Wai/Logger/Apache.hs#L45
+-- | TODO: Add the ability to filter apache logs on wai-extra and remove this function.
+pgrstFormat :: Status -> Wai.OutputFormatter
+pgrstFormat minStatus date req status responseSize =
+  if status < minStatus
+    then mempty
+  else toLogStr (getSourceFromSocket req)
+    <> " - - ["
+    <> toLogStr date
+    <> "] \""
+    <> toLogStr (Wai.requestMethod req)
+    <> " "
+    <> toLogStr (Wai.rawPathInfo req <> Wai.rawQueryString req)
+    <> " "
+    <> toLogStr (show (Wai.httpVersion req)::Text)
+    <> "\" "
+    <> toLogStr (show (statusCode status)::Text)
+    <> " "
+    <> toLogStr (maybe "-" show responseSize::Text)
+    <> " \""
+    <> toLogStr (fromMaybe mempty $ Wai.requestHeaderReferer req)
+    <> "\" \""
+    <> toLogStr (fromMaybe mempty $ Wai.requestHeaderUserAgent req)
+    <> "\"\n"
+  where
+    getSourceFromSocket = BS.pack . Wai.showSockAddr . Wai.remoteHost
+
+pgrstMiddleware :: LogLevel -> Wai.Application -> Wai.Application
+pgrstMiddleware logLevel =
+    logger
+  . Wai.cors corsPolicy
+  . Wai.staticPolicy (Wai.only [("favicon.ico", "static/favicon.ico")])
+  where
+    logger = case logLevel of
+      LogCrit  -> id
+      LogError -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status500}
+      LogWarn  -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400}
+      LogInfo  -> Wai.logStdout
+
+defaultCorsPolicy :: Wai.CorsResourcePolicy
+defaultCorsPolicy =  Wai.CorsResourcePolicy Nothing
+  ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing
+  (Just $ 60*60*24) False False True
+
+-- | CORS policy to be used in by Wai Cors middleware
+corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy
+corsPolicy req = case lookup "origin" headers of
+  Just origin -> Just defaultCorsPolicy {
+      Wai.corsOrigins = Just ([origin], True)
+    , Wai.corsRequestHeaders = "Authentication" : accHeaders
+    , Wai.corsExposedHeaders = Just [
+        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
+      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
+      ]
+    }
+  Nothing -> Nothing
+  where
+    headers = Wai.requestHeaders req
+    accHeaders = case lookup "access-control-request-headers" headers of
+      Just hdrs -> map (CI.mk . 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/OpenAPI.hs

@@ -1,135 +1,146 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-|
+Module      : PostgREST.OpenAPI
+Description : Generates the OpenAPI output
+-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.OpenAPI (encode) where
 
-module PostgREST.OpenAPI (
-  encodeOpenAPI
-  , isMalformedProxyUri
-  , pickProxy
-  ) 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.HashSet.InsOrd   as Set
+import qualified Data.Text             as T
+import qualified Data.Text.Encoding    as T
 
-import           Control.Lens
-import           Data.Aeson                  (decode, encode)
-import qualified Data.HashMap.Strict         as M
-import           Data.HashMap.Strict.InsOrd  (InsOrdHashMap, fromList)
-import           Data.Maybe                  (fromJust)
-import qualified Data.Set                    as Set
-import           Data.String                 (IsString (..))
-import           Data.Text                   (unpack, pack, concat, intercalate, init, tail, toLower)
-import           Network.URI                 (parseURI, isAbsoluteURI,
-                                              URI (..), URIAuth (..))
+import Control.Arrow              ((&&&))
+import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
+import Data.Maybe                 (fromJust)
+import Data.String                (IsString (..))
+import Network.URI                (URI (..), URIAuth (..))
 
-import           Protolude hiding              (concat, (&), Proxy, get, intercalate)
+import Control.Lens (at, (.~), (?~))
 
-import           Data.Swagger
+import Data.Swagger
 
-import           PostgREST.ApiRequest        (ContentType(..))
-import           PostgREST.Config            (prettyVersion)
-import           PostgREST.Types             (Table(..), Column(..), PgArg(..),
-                                              Proxy(..), ProcDescription(..), toMime, operators)
+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.ContentType
+
+import Protolude hiding (Proxy, get)
+
+encode :: AppConfig -> DbStructure -> [Table] -> M.HashMap k [ProcDescription] -> Maybe Text -> LBS.ByteString
+encode conf dbStructure tables procs schemaDescription =
+  JSON.encode $
+    postgrestSpec
+      (dbRelationships dbStructure)
+      (concat $ M.elems procs)
+      (openApiTableInfo dbStructure <$> tables)
+      (proxyUri conf)
+      schemaDescription
+      (dbPrimaryKeys dbStructure)
 
 makeMimeList :: [ContentType] -> MimeList
-makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
+makeMimeList cs = MimeList $ fmap (fromString . BS.unpack . toMime) cs
 
 toSwaggerType :: Text -> SwaggerType t
-toSwaggerType "text"      = SwaggerString
-toSwaggerType "integer"   = SwaggerInteger
-toSwaggerType "boolean"   = SwaggerBoolean
-toSwaggerType "numeric"   = SwaggerNumber
-toSwaggerType _           = SwaggerString
+toSwaggerType "character varying" = SwaggerString
+toSwaggerType "character"         = SwaggerString
+toSwaggerType "text"              = SwaggerString
+toSwaggerType "boolean"           = SwaggerBoolean
+toSwaggerType "smallint"          = SwaggerInteger
+toSwaggerType "integer"           = SwaggerInteger
+toSwaggerType "bigint"            = SwaggerInteger
+toSwaggerType "numeric"           = SwaggerNumber
+toSwaggerType "real"              = SwaggerNumber
+toSwaggerType "double precision"  = SwaggerNumber
+toSwaggerType "ARRAY"             = SwaggerArray
+toSwaggerType _                   = SwaggerString
 
-makeTableDef :: (Table, [Column], [Text]) -> (Text, Schema)
-makeTableDef (t, cs, _) =
+parseDefault :: Text -> Text -> Text
+parseDefault colType colDefault =
+  case toSwaggerType colType of
+    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, _) =
   let tn = tableName t in
       (tn, (mempty :: Schema)
-        & type_ .~ SwaggerObject
-        & properties .~ fromList (map makeProperty cs))
+        & description .~ tableDescription t
+        & type_ ?~ SwaggerObject
+        & properties .~ fromList (fmap (makeProperty rels pks) cs)
+        & required .~ fmap colName (filter (not . colNullable) cs))
 
-makeProperty :: Column -> (Text, Referenced Schema)
-makeProperty c = (colName c, Inline u)
+makeProperty :: [Relationship] -> [PrimaryKey] -> Column -> (Text, Referenced Schema)
+makeProperty rels pks c = (colName c, Inline s)
   where
-    r = mempty :: Schema
-    s = if null $ colEnum c
-           then r
-           else r & enum_ .~ decode (encode (colEnum c))
-    t = s & type_ .~ toSwaggerType (colType c)
-    u = t & format ?~ colType c
+    e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c
+    fk :: Maybe Text
+    fk =
+      let
+        -- Finds the relationship that has a single column foreign key
+        rel = find (\case
+          Relationship{relColumns, relCardinality=M2O _} -> [c] == relColumns
+          _                                                 -> False
+          ) rels
+        fCol = colName <$> (headMay . relForeignColumns =<< rel)
+        fTbl = tableName . relForeignTable <$> rel
+        fTblCol = (,) <$> fTbl <*> fCol
+      in
+        (\(a, b) -> T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]) <$> fTblCol
+    pk :: Bool
+    pk = any (\p -> pkTable p == colTable c && pkName p == colName c) pks
+    n = catMaybes
+      [ Just "Note:"
+      , if pk then Just "This is a Primary Key.<pk/>" else Nothing
+      , fk
+      ]
+    d =
+      if length n > 1 then
+        Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription c) (T.intercalate "\n" n)
+      else
+        colDescription c
+    s =
+      (mempty :: Schema)
+        & default_ .~ (JSON.decode . toUtf8Lazy . parseDefault (colType c) =<< colDefault c)
+        & description .~ d
+        & enum_ .~ e
+        & format ?~ colType c
+        & maxLength .~ (fromIntegral <$> colMaxLen c)
+        & type_ ?~ toSwaggerType (colType c)
 
-makeProcDef :: ProcDescription -> (Text, Schema)
-makeProcDef pd = ("(rpc) " <> pdName pd, s)
+makeProcSchema :: ProcDescription -> Schema
+makeProcSchema pd =
+  (mempty :: Schema)
+  & description .~ pdDescription pd
+  & type_ ?~ SwaggerObject
+  & 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)
   where
     s = (mempty :: Schema)
-          & type_ .~ SwaggerObject
-          & properties .~ fromList (map makeProcProperty (pdArgs pd))
-          & required .~ map pgaName (filter pgaReq (pdArgs pd))
-
-makeProcProperty :: PgArg -> (Text, Referenced Schema)
-makeProcProperty (PgArg n t _) = (n, Inline s)
-  where
-    s = (mempty :: Schema)
-          & type_ .~ toSwaggerType t
+          & type_ ?~ toSwaggerType t
           & format ?~ t
 
-makeOperatorPattern :: Text
-makeOperatorPattern =
-  intercalate "|"
-  [ concat ["^", x, y, "[.]"] |
-    x <- ["not[.]", ""],
-    y <- M.keys operators ]
-
-makeRowFilter :: Column -> Param
-makeRowFilter c =
-  (mempty :: Param)
-  & name .~ colName c
-  & required ?~ False
-  & schema .~ ParamOther ((mempty :: ParamOtherSchema)
-    & in_ .~ ParamQuery
-    & type_ .~ SwaggerString
-    & format ?~ colType c
-    & pattern ?~ makeOperatorPattern)
-
-makeRowFilters :: [Column] -> [Param]
-makeRowFilters = map makeRowFilter
-
-makeOrderItems :: [Column] -> [Text]
-makeOrderItems cs =
-  [ concat [x, y, z] |
-    x <- map colName cs,
-    y <- [".asc", ".desc", ""],
-    z <- [".nullsfirst", ".nulllast", ""]
-  ]
-
-makeRangeParams :: [Param]
-makeRangeParams =
-  [ (mempty :: Param)
-    & name        .~ "Range"
-    & description ?~ "Limiting and Pagination"
-    & required    ?~ False
-    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
-      & in_ .~ ParamHeader
-      & type_ .~ SwaggerString)
-  , (mempty :: Param)
-    & name        .~ "Range-Unit"
-    & description ?~ "Limiting and Pagination"
-    & required    ?~ False
-    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
-      & in_ .~ ParamHeader
-      & type_ .~ SwaggerString
-      & default_ .~ decode "\"items\"")
-  , (mempty :: Param)
-    & name        .~ "offset"
-    & description ?~ "Limiting and Pagination"
-    & required    ?~ False
-    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
-      & in_ .~ ParamQuery
-      & type_ .~ SwaggerString)
-  , (mempty :: Param)
-    & name        .~ "limit"
-    & description ?~ "Limiting and Pagination"
-    & required    ?~ False
-    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
-      & in_ .~ ParamQuery
-      & type_ .~ SwaggerString)
-  ]
-
 makePreferParam :: [Text] -> Param
 makePreferParam ts =
   (mempty :: Param)
@@ -138,95 +149,149 @@ makePreferParam ts =
   & required    ?~ False
   & schema .~ ParamOther ((mempty :: ParamOtherSchema)
     & in_ .~ ParamHeader
-    & type_ .~ SwaggerString
-    & enum_ .~ decode (encode ts))
+    & type_ ?~ SwaggerString
+    & enum_ .~ JSON.decode (JSON.encode ts))
 
-makeSelectParam :: Param
-makeSelectParam =
-  (mempty :: Param)
-    & name        .~ "select"
-    & description ?~ "Filtering Columns"
-    & required    ?~ False
-    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
-      & in_ .~ ParamQuery
-      & type_ .~ SwaggerString)
-
-makeGetParams :: [Column] -> [Param]
-makeGetParams [] =
-  makeRangeParams ++
-  [ makeSelectParam
-  , makePreferParam ["count=none"]
-  ]
-makeGetParams cs =
-  makeRangeParams ++
-  [ makeSelectParam
-  , (mempty :: Param)
-    & name        .~ "order"
-    & description ?~ "Ordering"
-    & required    ?~ False
-    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
-      & in_ .~ ParamQuery
-      & type_ .~ SwaggerString
-      & enum_ .~ decode (encode $ makeOrderItems cs))
-  , makePreferParam ["count=none"]
-  ]
-
-makePostParams :: Text -> [Param]
-makePostParams tn =
-  [ makePreferParam ["return=representation",
-                     "return=minimal", "return=none"]
-  , (mempty :: Param)
-    & name        .~ "body"
-    & description ?~ tn
-    & required    ?~ False
-    & schema .~ ParamBody (Ref (Reference tn))
-  ]
-
-makeProcParam :: Text -> [Param]
-makeProcParam refName =
-  [ makePreferParam ["params=single-object"]
-  , (mempty :: Param)
+makeProcParam :: ProcDescription -> [Referenced Param]
+makeProcParam pd =
+  [ Inline $ (mempty :: Param)
     & name     .~ "args"
     & required ?~ True
-    & schema   .~ ParamBody (Ref (Reference refName))
+    & schema   .~ ParamBody (Inline $ makeProcSchema pd)
+  , Ref $ Reference "preferParams"
   ]
 
-makeDeleteParams :: [Param]
-makeDeleteParams =
-  [ makePreferParam ["return=representation", "return=minimal", "return=none"] ]
+makeParamDefs :: [(Table, [Column], [Text])] -> [(Text, Param)]
+makeParamDefs ti =
+  [ ("preferParams", makePreferParam ["params=single-object"])
+  , ("preferReturn", makePreferParam ["return=representation", "return=minimal", "return=none"])
+  , ("preferCount", makePreferParam ["count=none"])
+  , ("select", (mempty :: Param)
+      & name        .~ "select"
+      & description ?~ "Filtering Columns"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ ?~ SwaggerString))
+  , ("on_conflict", (mempty :: Param)
+      & name        .~ "on_conflict"
+      & description ?~ "On Conflict"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ ?~ SwaggerString))
+  , ("order", (mempty :: Param)
+      & name        .~ "order"
+      & description ?~ "Ordering"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ ?~ SwaggerString))
+  , ("range", (mempty :: Param)
+      & name        .~ "Range"
+      & description ?~ "Limiting and Pagination"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamHeader
+        & type_ ?~ SwaggerString))
+  , ("rangeUnit", (mempty :: Param)
+      & name        .~ "Range-Unit"
+      & description ?~ "Limiting and Pagination"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamHeader
+        & type_ ?~ SwaggerString
+        & default_ .~ JSON.decode "\"items\""))
+  , ("offset", (mempty :: Param)
+      & name        .~ "offset"
+      & description ?~ "Limiting and Pagination"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ ?~ SwaggerString))
+  , ("limit", (mempty :: Param)
+      & name        .~ "limit"
+      & description ?~ "Limiting and Pagination"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ ?~ SwaggerString))
+  ]
+  <> concat [ makeObjectBody (tableName t) : makeRowFilters (tableName t) cs
+            | (t, cs, _) <- ti
+            ]
+
+makeObjectBody :: Text -> (Text, Param)
+makeObjectBody tn =
+  ("body." <> tn, (mempty :: Param)
+     & name .~ tn
+     & description ?~ tn
+     & required ?~ False
+     & schema .~ ParamBody (Ref (Reference tn)))
+
+makeRowFilter :: Text -> Column -> (Text, Param)
+makeRowFilter tn c =
+  (T.intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
+    & name .~ colName c
+    & description .~ colDescription c
+    & required ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamQuery
+      & type_ ?~ SwaggerString
+      & format ?~ colType c))
+
+makeRowFilters :: Text -> [Column] -> [(Text, Param)]
+makeRowFilters tn = fmap (makeRowFilter tn)
 
 makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
-makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
+makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable t)
   where
+    -- Use first line of table description as summary; rest as description (if present)
+    -- We strip leading newlines from description so that users can include a blank line between summary and description
+    (tSum, tDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
+                    T.breakOn "\n" <$> tableDescription t
     tOp = (mempty :: Operation)
       & tags .~ Set.fromList [tn]
-      & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-      & at 200 ?~ "OK"
+      & summary .~ tSum
+      & description .~ mfilter (/="") tDesc
     getOp = tOp
-      & parameters .~ map Inline (makeGetParams cs ++ rs)
+      & parameters .~ fmap ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])
       & at 206 ?~ "Partial Content"
+      & at 200 ?~ Inline ((mempty :: Response)
+        & description .~ "OK"
+        & schema ?~ Inline (mempty
+          & type_ ?~ SwaggerArray
+          & items ?~ SwaggerItemsObject (Ref $ Reference $ tableName t)
+        )
+      )
     postOp = tOp
-      & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-      & parameters .~ map Inline (makePostParams tn)
+      & parameters .~ fmap ref ["body." <> tn, "select", "preferReturn"]
       & at 201 ?~ "Created"
     patchOp = tOp
-      & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-      & parameters .~ map Inline (makePostParams tn ++ rs)
+      & parameters .~ fmap ref (rs <> ["body." <> tn, "preferReturn"])
       & at 204 ?~ "No Content"
     deletOp = tOp
-      & parameters .~ map Inline (makeDeleteParams ++ rs)
+      & parameters .~ fmap ref (rs <> ["preferReturn"])
+      & at 204 ?~ "No Content"
     pr = (mempty :: PathItem) & get ?~ getOp
     pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp
     p False = pr
     p True  = pw
-    rs = makeRowFilters cs
     tn = tableName t
+    rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]
+    ref = Ref . Reference
 
 makeProcPathItem :: ProcDescription -> (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)
-      & parameters .~ map Inline (makeProcParam $ "(rpc) " <> pdName pd)
+      & summary .~ pSum
+      & description .~ mfilter (/="") pDesc
+      & parameters .~ makeProcParam pd
       & tags .~ Set.fromList ["(rpc) " <> pdName pd]
       & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON]
       & at 200 ?~ "OK"
@@ -236,7 +301,8 @@ makeRootPathItem :: (FilePath, PathItem)
 makeRootPathItem = ("/", p)
   where
     getOp = (mempty :: Operation)
-      & tags .~ Set.fromList ["/"]
+      & tags .~ Set.fromList ["Introspection"]
+      & summary ?~ "OpenAPI description (this document)"
       & produces ?~ makeMimeList [CTOpenAPI, CTApplicationJSON]
       & at 200 ?~ "OK"
     pr = (mempty :: PathItem) & get ?~ getOp
@@ -244,7 +310,7 @@ makeRootPathItem = ("/", p)
 
 makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
 makePathItems pds ti = fromList $ makeRootPathItem :
-  map makePathItem ti ++ map makeProcPathItem pds
+  fmap makePathItem ti ++ fmap makeProcPathItem pds
 
 escapeHostName :: Text -> Text
 escapeHostName "*"  = "0.0.0.0"
@@ -254,41 +320,27 @@ escapeHostName "*6" = "0.0.0.0"
 escapeHostName "!6" = "0.0.0.0"
 escapeHostName h    = h
 
-postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Swagger
-postgrestSpec pds ti (s, h, p, b) = (mempty :: Swagger)
-  & basePath ?~ unpack b
+postgrestSpec :: [Relationship] -> [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
+postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
+  & basePath ?~ T.unpack b
   & schemes ?~ [s']
   & info .~ ((mempty :: Info)
-      & version .~ prettyVersion
+      & version .~ T.decodeUtf8 prettyVersion
       & title .~ "PostgREST API"
-      & description ?~ "This is a dynamic API generated by PostgREST")
+      & description ?~ d)
+  & externalDocs ?~ ((mempty :: ExternalDocs)
+    & description ?~ "PostgREST Documentation"
+    & url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))
   & host .~ h'
-  & definitions .~ fromList (map makeTableDef ti <> map makeProcDef pds)
+  & definitions .~ fromList (makeTableDef rels pks <$> ti)
+  & parameters .~ fromList (makeParamDefs ti)
   & paths .~ makePathItems pds ti
+  & produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
+  & consumes .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
     where
       s' = if s == "http" then Http else Https
-      h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))
-
-encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> LByteString
-encodeOpenAPI pds ti uri = encode $ postgrestSpec pds ti uri
-
-{-|
-  Test whether a proxy uri is malformed or not.
-  A valid proxy uri should be an absolute uri without query and user info,
-  only http(s) schemes are valid, port number range is 1-65535.
-
-  For example
-  http://postgrest.com/openapi.json
-  https://postgrest.com:8080/openapi.json
--}
-isMalformedProxyUri :: Maybe Text -> Bool
-isMalformedProxyUri Nothing =  False
-isMalformedProxyUri (Just uri)
-  | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri
-  | otherwise = True
-
-toURI :: Text -> URI
-toURI uri = fromJust $ parseURI (toS uri)
+      h' = Just $ Host (T.unpack $ escapeHostName h) (Just (fromInteger p))
+      d = fromMaybe "This is a dynamic API generated by PostgREST" sd
 
 pickProxy :: Maybe Text -> Maybe Proxy
 pickProxy proxy
@@ -296,7 +348,7 @@ pickProxy proxy
   -- should never happen
   -- since the request would have been rejected by the middleware if proxy uri
   -- is malformed
-  | isMalformedProxyUri proxy = Nothing
+  | isMalformedProxyUri $ fromMaybe mempty proxy = Nothing
   | otherwise = Just Proxy {
     proxyScheme = scheme
   , proxyHost = host'
@@ -305,53 +357,31 @@ pickProxy proxy
   }
  where
    uri = toURI $ fromJust proxy
-   scheme = init $ toLower $ pack $ uriScheme uri
+   scheme = T.init $ T.toLower $ T.pack $ uriScheme uri
    path URI {uriPath = ""} =  "/"
-   path URI {uriPath = p} = p
-   path' = pack $ path uri
+   path URI {uriPath = p}  = p
+   path' = T.pack $ path uri
    authority = fromJust $ uriAuthority uri
-   host' = pack $ uriRegName authority
+   host' = T.pack $ uriRegName authority
    port' = uriPort authority
    readPort = fromMaybe 80 . readMaybe
    port'' :: Integer
    port'' = case (port', scheme) of
-             ("", "http") -> 80
+             ("", "http")  -> 80
              ("", "https") -> 443
-             _ -> readPort $ unpack $ tail $ pack port'
+             _             -> readPort $ T.unpack $ T.tail $ T.pack port'
 
-isUriValid:: URI -> Bool
-isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]
+proxyUri :: AppConfig -> (Text, Text, Integer, Text)
+proxyUri AppConfig{..} =
+  case pickProxy $ toS <$> configOpenApiServerProxyUri of
+    Just Proxy{..} ->
+      (proxyScheme, proxyHost, proxyPort, proxyPath)
+    Nothing ->
+      ("http", configServerHost, toInteger configServerPort, "/")
 
-fAnd :: [a -> Bool] -> a -> Bool
-fAnd fs x = all ($x) fs
-
-isSchemeValid :: URI -> Bool
-isSchemeValid URI {uriScheme = s}
-  | toLower (pack s) == "https:" = True
-  | toLower (pack s) == "http:" = True
-  | otherwise = False
-
-isQueryValid :: URI -> Bool
-isQueryValid URI {uriQuery = ""} = True
-isQueryValid _ = False
-
-isAuthorityValid :: URI -> Bool
-isAuthorityValid URI {uriAuthority = a}
-  | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a
-  | otherwise = False
-
-isUserInfoValid :: URIAuth -> Bool
-isUserInfoValid URIAuth {uriUserInfo = ""} = True
-isUserInfoValid _ = False
-
-isHostValid :: URIAuth -> Bool
-isHostValid URIAuth {uriRegName = ""} = False
-isHostValid _ = True
-
-isPortValid :: URIAuth -> Bool
-isPortValid URIAuth {uriPort = ""} = True
-isPortValid URIAuth {uriPort = (':':p)} =
-  case readMaybe p of
-    Just i -> i > (0 :: Integer) && i < 65536
-    Nothing -> False
-isPortValid _ = False
+openApiTableInfo :: DbStructure -> Table -> (Table, [Column], [Text])
+openApiTableInfo dbStructure table =
+  ( table
+  , tableCols dbStructure (tableSchema table) (tableName table)
+  , tablePKCols dbStructure (tableSchema table) (tableName table)
+  )

src/PostgREST/Parsers.hs

@@ -1,221 +0,0 @@
-module PostgREST.Parsers where
-
-import           Protolude                     hiding (try, intercalate)
-import           Control.Monad                 ((>>))
-import           Data.Foldable                 (foldl1)
-import qualified Data.HashMap.Strict           as M
-import           Data.Text                     (intercalate, replace, strip)
-import           Data.List                     (init, last)
-import           Data.Tree
-import           Data.Either.Combinators       (mapLeft)
-import           PostgREST.RangeQuery          (NonnegRange,allRange)
-import           PostgREST.Types
-import           Text.ParserCombinators.Parsec hiding (many, (<|>))
-import           Text.Parsec.Error
-
-pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest
-pRequestSelect rootName selStr =
-  mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
-
-pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter)
-pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
-  where
-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
-    oper = parse (pOperation pVText pVTextL) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
-    path = fst <$> treePath
-    fld = snd <$> treePath
-
-pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm])
-pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
-  where
-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
-    path = fst <$> treePath
-    ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
-
-pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange)
-pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
-  where
-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
-    path = fst <$> treePath
-
-pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree)
-pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
-  where
-    path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k
-    embedPath = fst <$> path
-    op = snd <$> path
-    -- Concat op and v to make pLogicTree argument regular, in the form of "op(.,.)"
-    logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v)
-
-ws :: Parser Text
-ws = toS <$> many (oneOf " \t")
-
-lexeme :: Parser a -> Parser a
-lexeme p = ws *> p <* ws
-
-pReadRequest :: Text -> Parser ReadRequest
-pReadRequest rootNodeName = do
-  fieldTree <- pFieldForest
-  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree
-  where
-    readQuery = Select [] [rootNodeName] [] [] Nothing allRange
-    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
-    treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =
-      case fldForest of
-        [] -> Node (q {select=fld:select q}, i) rForest
-        _  -> Node (q, i) newForest
-          where
-            newForest =
-              foldr treeEntry (Node (Select [] [fn] [] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest
-
-pTreePath :: Parser (EmbedPath, Field)
-pTreePath = do
-  p <- pFieldName `sepBy1` pDelimiter
-  jp <- optionMaybe pJsonPath
-  return (init p, (last p, jp))
-
-pFieldForest :: Parser [Tree SelectItem]
-pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
-
-pFieldTree :: Parser (Tree SelectItem)
-pFieldTree =  try (Node <$> pSimpleSelect <*> between (char '{') (char '}') pFieldForest)
-          <|> try (Node <$> pSimpleSelect <*> between (char '(') (char ')') pFieldForest)
-          <|> Node <$> pSelect <*> pure []
-
-pStar :: Parser Text
-pStar = toS <$> (string "*" *> pure ("*"::ByteString))
-
-
-pFieldName :: Parser Text
-pFieldName = do
-  matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"
-  return $ intercalate "-" $ map toS matches
-  where
-    isDash :: GenParser Char st ()
-    isDash = try ( char '-' >> notFollowedBy (char '>') )
-    dash :: Parser Char
-    dash = isDash *> pure '-'
-
-
-pJsonPathStep :: Parser Text
-pJsonPathStep = toS <$> try (string "->" *> pFieldName)
-
-pJsonPath :: Parser [Text]
-pJsonPath = (<>) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) )
-
-pField :: Parser Field
-pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath
-
-aliasSeparator :: Parser ()
-aliasSeparator = char ':' >> notFollowedBy (char ':')
-
-pSimpleSelect :: Parser SelectItem
-pSimpleSelect = lexeme $ try ( do
-    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
-    fld <- pField
-    return (fld, Nothing, alias)
-  )
-
-pSelect :: Parser SelectItem
-pSelect = lexeme $
-  try (
-    do
-      alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
-      fld <- pField
-      cast' <- optionMaybe (string "::" *> many letter)
-      return (fld, toS <$> cast', alias)
-  )
-  <|> do
-    s <- pStar
-    return ((s, Nothing), Nothing, Nothing)
-
-pOperation :: Parser Operand -> Parser Operand -> Parser Operation
-pOperation parserVText parserVTextL = try ( string "not" *> pDelimiter *> (Operation True <$> pExpr)) <|> Operation False <$> pExpr
-  where
-    pExpr :: Parser (Operator, Operand)
-    pExpr =
-          ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys notInOps)) <*> parserVText)
-      <|> ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys inOps)) <*> parserVTextL)
-      <?> "operator (eq, gt, ...)"
-    inOps = M.filterWithKey (const . flip elem ["in", "notin"]) operators
-    notInOps = M.difference operators inOps
-
-pVText :: Parser Operand
-pVText = VText . toS <$> many anyChar
-
-pVTextL :: Parser Operand
-pVTextL =     VTextL <$> try (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))
-          <|> VTextL <$> lexeme pVTextLElement `sepBy1` char ','
-
-pVTextLElement :: Parser Text
-pVTextLElement = try pQuotedValue <|> (toS <$> many (noneOf ",)"))
-
-pQuotedValue :: Parser Text
-pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",)"))
-
-pDelimiter :: Parser Char
-pDelimiter = char '.' <?> "delimiter (.)"
-
-pOrder :: Parser [OrderTerm]
-pOrder = lexeme pOrderTerm `sepBy` char ','
-
-pOrderTerm :: Parser OrderTerm
-pOrderTerm =
-  try ( do
-    c <- pField
-    d <- optionMaybe (try $ pDelimiter *> (
-               try(string "asc" *> pure OrderAsc)
-           <|> try(string "desc" *> pure OrderDesc)
-         ))
-    nls <- optionMaybe (pDelimiter *> (
-                 try(string "nullslast" *> pure OrderNullsLast)
-             <|> try(string "nullsfirst" *> pure OrderNullsFirst)
-           ))
-    return $ OrderTerm c d nls
-  )
-  <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing
-
-pLogicTree :: Parser LogicTree
-pLogicTree = Stmnt <$> try pLogicFilter
-             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree) <*> (lexeme (char ',') *> pLogicTree <* lexeme (char ')'))
-  where
-    pLogicFilter :: Parser Filter
-    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOperation pLogicVText pLogicVTextL
-    pNot :: Parser Bool
-    pNot = try (string "not" *> pDelimiter *> pure True) 
-           <|> pure False
-           <?> "negation operator (not)"
-    pLogicOp :: Parser LogicOperator
-    pLogicOp = try (string "and"  *> pure And)
-               <|> string "or" *> pure Or
-               <?> "logic operator (and, or)"
-
-pLogicVText :: Parser Operand
-pLogicVText = VText <$> (try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)")))
-  where
-    pPgArray :: Parser Text
-    pPgArray =  do
-      a <- string "{"
-      b <- many (noneOf "{}")
-      c <- string "}"
-      toS <$> pure (a ++ b ++ c)
-
-pLogicVTextL :: Parser Operand
-pLogicVTextL = VTextL <$> (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))
-
-pLogicPath :: Parser (EmbedPath, Text)
-pLogicPath = do
-  path <- pFieldName `sepBy1` pDelimiter
-  let op = last path
-      notOp = "not." <> op
-  return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)
-
-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/Query/QueryBuilder.hs

@@ -0,0 +1,206 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-|
+Module      : PostgREST.Query.QueryBuilder
+Description : PostgREST SQL queries generating functions.
+
+This module provides functions to consume data types that
+represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment
+to produce SqlQuery type outputs.
+-}
+module PostgREST.Query.QueryBuilder
+  ( readRequestToQuery
+  , mutateRequestToQuery
+  , readRequestToCountQuery
+  , requestToCallProcQuery
+  , limitedQuery
+  ) where
+
+import qualified Data.ByteString.Char8           as BS
+import qualified Data.Set                        as S
+import qualified Hasql.DynamicStatements.Snippet as SQL
+
+import Data.Tree (Tree (..))
+
+import PostgREST.DbStructure.Identifiers  (QualifiedIdentifier (..))
+import PostgREST.DbStructure.Proc         (ProcParam (..))
+import PostgREST.DbStructure.Relationship (Cardinality (..),
+                                           Relationship (..))
+import PostgREST.DbStructure.Table        (Table (..))
+import PostgREST.Request.Preferences      (PreferResolution (..))
+
+import PostgREST.Query.SqlFragment
+import PostgREST.Request.Types
+
+import Protolude
+
+readRequestToQuery :: ReadRequest -> SQL.Snippet
+readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) =
+  "SELECT " <>
+  intercalateSnippet ", " ((pgFmtSelectItem qi <$> colSelects) ++ selects) <>
+  "FROM " <> SQL.sql (BS.intercalate ", " (tabl : implJs)) <> " " <>
+  intercalateSnippet " " joins <> " " <>
+  (if null logicForest && null joinConditions_ then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_))
+  <> " " <>
+  (if null ordts then mempty else "ORDER BY " <> intercalateSnippet ", " (map (pgFmtOrderTerm qi) ordts)) <> " " <>
+  limitOffsetF range
+  where
+    implJs = fromQi <$> implJoins
+    tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias
+    qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias
+    (joins, selects) = foldr getJoinsSelects ([],[]) forest
+
+getJoinsSelects :: ReadRequest -> ([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, _, _, _, _)) _) _ = ([], [])
+
+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 <> ") _ ") <>
+  -- 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,
+    returningF mainQi returnings
+    ])
+  where
+    cols = BS.intercalate ", " $ pgFmtIdent <$> S.toList iCols
+mutateRequestToQuery (Update mainQi uCols body logicForest returnings) =
+  if S.null uCols
+    -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax
+    -- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select=
+    -- the select has to be based on "returnings" to make computed overloaded functions not throw
+    then 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)
+  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)
+
+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)")
+        )
+
+    fmtParams :: [ProcParam] -> (ProcParam -> SqlFragment) -> (ProcParam -> SqlFragment) -> SqlFragment
+    fmtParams prms prmFragPre prmFragSuf = BS.intercalate ", "
+      ((\a -> prmFragPre a <> pgFmtIdent (ppName a) <> prmFragSuf a) <$> prms)
+
+    varadicPrefix :: ProcParam -> SqlFragment
+    varadicPrefix a = if ppVar a then "VARIADIC " else mempty
+
+    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 <> ")"
+
+    returnedColumns :: SQL.Snippet
+    returnedColumns
+      | null returnings = "*"
+      | otherwise       = SQL.sql $ BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings)
+
+
+-- | SQL query meant for COUNTing the root node of the Tree.
+-- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT.
+-- SELECT 1 is done instead of SELECT * to prevent doing expensive operations(like functions based on the columns)
+-- inside the FROM target.
+-- If the request contains INNER JOINs, then the COUNT of the root node will change.
+-- 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
+    then mempty
+    else " WHERE " ) <>
+  intercalateSnippet " AND " (
+    map (pgFmtLogicTree qi) logicForest ++
+    map pgFmtJoinCondition joinConditions_ ++
+    subQueries
+  )
+  where
+    subQueries = foldr existsSubquery [] forest
+    existsSubquery :: ReadRequest -> [SQL.Snippet] -> [SQL.Snippet]
+    existsSubquery readReq@(Node (_, (_, _, _, _, joinType, _)) _) rest =
+      if joinType == Just JTInner
+        then ("EXISTS (" <> readRequestToCountQuery readReq <> " )"):rest
+        else mempty
+
+limitedQuery :: SQL.Snippet -> Maybe Integer -> SQL.Snippet
+limitedQuery query maxRows = query <> SQL.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows)

src/PostgREST/Query/SqlFragment.hs

@@ -0,0 +1,337 @@
+{-# LANGUAGE LambdaCase  #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-|
+Module      : PostgREST.Query.SqlFragment
+Description : Helper functions for PostgREST.QueryBuilder.
+
+Any function that outputs a SqlFragment should be in this module.
+-}
+module PostgREST.Query.SqlFragment
+  ( noLocationF
+  , SqlFragment
+  , asBinaryF
+  , asCsvF
+  , asJsonF
+  , asJsonSingleF
+  , countF
+  , fromQi
+  , ftsOperators
+  , limitOffsetF
+  , locationF
+  , normalizedBody
+  , operators
+  , pgFmtColumn
+  , pgFmtIdent
+  , pgFmtJoinCondition
+  , pgFmtLogicTree
+  , pgFmtOrderTerm
+  , pgFmtSelectItem
+  , responseHeadersF
+  , responseStatusF
+  , returningF
+  , selectBody
+  , singleParameter
+  , sourceCTEName
+  , unknownEncoder
+  , intercalateSnippet
+  ) where
+
+import qualified Data.ByteString.Char8           as BS
+import qualified Data.ByteString.Lazy            as LBS
+import qualified Data.HashMap.Strict             as M
+import qualified Data.Text                       as T
+import qualified Hasql.DynamicStatements.Snippet as SQL
+import qualified Hasql.Encoders                  as HE
+
+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 (..),
+                                          JsonOperand (..),
+                                          JsonOperation (..),
+                                          JsonPath,
+                                          LogicOperator (..),
+                                          LogicTree (..), OpExpr (..),
+                                          Operation (..),
+                                          OrderDirection (..),
+                                          OrderNulls (..),
+                                          OrderTerm (..), SelectItem,
+                                          TrileanVal (..))
+
+import Protolude hiding (cast)
+
+
+-- | A part of a SQL query that cannot be executed independently
+type SqlFragment = ByteString
+
+noLocationF :: SqlFragment
+noLocationF = "array[]::text[]"
+
+sourceCTEName :: SqlFragment
+sourceCTEName = "pgrst_source"
+
+operators :: 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
+
+ftsOperators :: M.HashMap Text SqlFragment
+ftsOperators = M.fromList [
+  ("fts", "@@ to_tsquery"),
+  ("plfts", "@@ plainto_tsquery"),
+  ("phfts", "@@ phraseto_tsquery"),
+  ("wfts", "@@ websearch_to_tsquery")
+  ]
+
+-- |
+-- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads
+-- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays
+-- We do this in SQL to avoid processing the JSON in application code
+-- 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"
+
+singleParameter :: Maybe LBS.ByteString -> ByteString -> SQL.Snippet
+singleParameter body typ =
+  if typ == "bytea"
+    -- TODO: Hasql fails when using HE.unknown with bytea(pg tries to utf8 encode).
+    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
+-- https://www.postgresql.org/docs/current/sql-syntax-lexical.html#SQL-SYNTAX-STRINGS
+-- we don't need to use the E'string' form for C-style escapes
+-- https://www.postgresql.org/docs/current/sql-syntax-lexical.html#SQL-SYNTAX-STRINGS-ESCAPE
+pgBuildArrayLiteral :: [Text] -> Text
+pgBuildArrayLiteral vals =
+ let trimmed = trimNullChars
+     slashed = T.replace "\\" "\\\\" . trimmed
+     escaped x = "\"" <> T.replace "\"" "\\\"" (slashed x) <> "\"" in
+ "{" <> 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) <> "\""
+
+trimNullChars :: Text -> Text
+trimNullChars = T.takeWhile (/= '\x0')
+
+asCsvF :: SqlFragment
+asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
+  where
+    asCsvHeaderF =
+      "(SELECT coalesce(string_agg(a.k, ','), '')" <>
+      "  FROM (" <>
+      "    SELECT json_object_keys(r)::text as k" <>
+      "    FROM ( " <>
+      "      SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
+      "    ) s" <>
+      "  ) a" <>
+      ")"
+    asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
+
+asJsonF :: Bool -> SqlFragment
+asJsonF returnsScalar
+  | returnsScalar = "coalesce(json_agg(_postgrest_t.pgrst_scalar), '[]')::character varying"
+  | otherwise     = "coalesce(json_agg(_postgrest_t), '[]')::character varying"
+
+asJsonSingleF :: Bool -> SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
+asJsonSingleF returnsScalar
+  | returnsScalar = "coalesce(string_agg(to_json(_postgrest_t.pgrst_scalar)::text, ','), 'null')::character varying"
+  | otherwise     = "coalesce(string_agg(to_json(_postgrest_t)::text, ','), '')::character varying"
+
+asBinaryF :: FieldName -> SqlFragment
+asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
+
+locationF :: [Text] -> SqlFragment
+locationF pKeys = [qc|(
+  WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1)
+  SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))
+  FROM data CROSS JOIN json_each_text(data.row) AS json_data
+  WHERE json_data.key IN ('{fmtPKeys}')
+)|]
+  where
+    fmtPKeys = T.intercalate "','" pKeys
+
+fromQi :: QualifiedIdentifier -> SqlFragment
+fromQi t = (if T.null s then mempty else pgFmtIdent s <> ".") <> pgFmtIdent n
+  where
+    n = qiName t
+    s = qiSchema t
+
+pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
+pgFmtColumn table "*" = fromQi table <> ".*"
+pgFmtColumn table c   = fromQi table <> "." <> pgFmtIdent c
+
+pgFmtField :: QualifiedIdentifier -> Field -> SQL.Snippet
+pgFmtField table (c, jp) = SQL.sql (pgFmtColumn table c) <> pgFmtJsonPath jp
+
+pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SQL.Snippet
+pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _, _) = pgFmtField table f <> SQL.sql (pgFmtAs fName jp alias)
+-- Ideally we'd quote the cast with "pgFmtIdent cast". However, that would invalidate common casts such as "int", "bigint", etc.
+-- Try doing: `select 1::"bigint"` - it'll err, using "int8" will work though. There's some parser magic that pg does that's invalidated when quoting.
+-- Not quoting should be fine, we validate the input on Parsers.
+pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _, _) = "CAST (" <> pgFmtField table f <> " AS " <> SQL.sql (encodeUtf8 cast) <> " )" <> SQL.sql (pgFmtAs fName jp alias)
+
+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])
+  where
+    direction OrderAsc  = "ASC"
+    direction OrderDesc = "DESC"
+
+    nullOrder OrderNullsFirst = "NULLS FIRST"
+    nullOrder OrderNullsLast  = "NULLS LAST"
+
+
+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
+
+   -- 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
+     TriTrue    -> "TRUE"
+     TriFalse   -> "FALSE"
+     TriNull    -> "NULL"
+     TriUnknown -> "UNKNOWN"
+
+   -- We don't use "IN", we use "= ANY". IN has the following disadvantages:
+   -- + No way to use an empty value on IN: "col IN ()" is invalid syntax. With ANY we can do "= ANY('{}')"
+   -- + Can invalidate prepared statements: multiple parameters on an IN($1, $2, $3) will lead to using different prepared statements and not take advantage of caching.
+   In vals -> pgFmtField table fld <> " " <> case vals of
+      [""] -> "= ANY('{}') "
+      _    -> "= ANY (" <> unknownLiteral (pgBuildArrayLiteral vals) <> ") "
+
+   Fts op lang val ->
+     pgFmtFieldOp op <> "(" <> ftsLang lang <> unknownLiteral val <> ") "
+ where
+   ftsLang = maybe mempty (\l -> unknownLiteral l <> ", ")
+   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
+   sqlOperator o = SQL.sql $ M.lookupDefault "=" o operators
+   notOp = if hasNot then "NOT" else mempty
+   star c = if c == '*' then '%' else c
+
+pgFmtJoinCondition :: JoinCondition -> SQL.Snippet
+pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) =
+  SQL.sql $ 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) <> ")"
+  where
+    notOp =  if hasNot then "NOT" else mempty
+
+    opSql And = " AND "
+    opSql Or  = " OR "
+pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
+
+pgFmtJsonPath :: JsonPath -> SQL.Snippet
+pgFmtJsonPath = \case
+  []             -> mempty
+  (JArrow x:xs)  -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
+  (J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
+  where
+    pgFmtJsonOperand (JKey k) = unknownLiteral k
+    pgFmtJsonOperand (JIdx i) = unknownLiteral i <> "::int"
+
+pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment
+pgFmtAs _ [] Nothing = mempty
+pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of
+  Just (JKey key) -> " AS " <> pgFmtIdent key
+  Just (JIdx _)   -> " AS " <> pgFmtIdent (fromMaybe fName lastKey)
+    -- We get the lastKey because on:
+    -- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ]
+    -- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ]
+    where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp)
+  Nothing -> mempty
+pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias
+
+countF :: SQL.Snippet -> Bool -> (SQL.Snippet, SqlFragment)
+countF countQuery shouldCount =
+  if shouldCount
+    then (
+        ", pgrst_source_count AS (" <> countQuery <> ")"
+      , "(SELECT pg_catalog.count(*) FROM pgrst_source_count)" )
+    else (
+        mempty
+      , "null::bigint")
+
+returningF :: QualifiedIdentifier -> [FieldName] -> SqlFragment
+returningF qi returnings =
+  if null returnings
+    then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified
+    else "RETURNING " <> BS.intercalate ", " (pgFmtColumn qi <$> returnings)
+
+limitOffsetF :: NonnegRange -> SQL.Snippet
+limitOffsetF range =
+  if range == allRange then mempty else "LIMIT " <> limit <> " OFFSET " <> offset
+  where
+    limit = maybe "ALL" (\l -> unknownEncoder (BS.pack $ show l)) $ rangeLimit range
+    offset = unknownEncoder (BS.pack . show $ rangeOffset range)
+
+responseHeadersF :: SqlFragment
+responseHeadersF = currentSettingF "response.headers"
+
+responseStatusF :: SqlFragment
+responseStatusF = currentSettingF "response.status"
+
+currentSettingF :: SqlFragment -> SqlFragment
+currentSettingF setting =
+  -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
+  "nullif(current_setting('" <> setting <> "', true), '')"
+
+-- Hasql Snippet utilities
+unknownEncoder :: ByteString -> SQL.Snippet
+unknownEncoder = SQL.encoderAndParam (HE.nonNullable HE.unknown)
+
+unknownLiteral :: Text -> SQL.Snippet
+unknownLiteral = unknownEncoder . encodeUtf8
+
+intercalateSnippet :: ByteString -> [SQL.Snippet] -> SQL.Snippet
+intercalateSnippet _ [] = mempty
+intercalateSnippet frag snippets = foldr1 (\a b -> a <> SQL.sql frag <> b) snippets

src/PostgREST/Query/Statements.hs

@@ -0,0 +1,203 @@
+{-|
+Module      : PostgREST.Query.Statements
+Description : PostgREST single SQL statements.
+
+This module constructs single SQL statements that can be parametrized and prepared.
+
+- It consumes the SqlQuery types generated by the QueryBuilder module.
+- It generates the body format and some headers of the final HTTP response.
+
+TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718.
+-}
+module PostgREST.Query.Statements
+  ( createWriteStatement
+  , createReadStatement
+  , callProcStatement
+  , createExplainStatement
+  ) where
+
+import qualified Data.Aeson                        as JSON
+import qualified Data.Aeson.Lens                   as L
+import qualified Data.ByteString.Char8             as BS
+import qualified 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 PostgREST.Error     (Error (..))
+import PostgREST.GucHeader (GucHeader)
+
+import PostgREST.DbStructure.Identifiers (FieldName)
+import PostgREST.Query.SqlFragment
+import PostgREST.Request.Preferences
+
+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))
+
+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
+ where
+  snippet =
+    "WITH " <> SQL.sql sourceCTEName <> " AS (" <> mutateQuery <> ") " <>
+    SQL.sql (
+    "SELECT " <>
+      "'' AS total_result_set, " <>
+      "pg_catalog.count(_postgrest_t) AS page_total, " <>
+      locF <> " AS header, " <>
+      bodyF <> " AS body, " <>
+      responseHeadersF <> " AS response_headers, " <>
+      responseStatusF  <> " AS response_status "
+    ) <>
+    "FROM (" <> selectF <> ") _postgrest_t"
+
+  locF =
+    if isInsert && rep `elem` [Full, HeadersOnly]
+      then BS.unwords [
+        "CASE WHEN pg_catalog.count(_postgrest_t) = 1",
+          "THEN coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")",
+          "ELSE " <> noLocationF,
+        "END"]
+      else noLocationF
+
+  bodyF
+    | rep `elem` [None, HeadersOnly] = "''"
+    | asCsv = asCsvF
+    | wantSingle = asJsonSingleF False
+    | otherwise = asJsonF False
+
+  selectF
+    -- prevent using any of the column names in ?select= when no response is returned from the CTE
+    | rep `elem` [None, HeadersOnly] = SQL.sql ("SELECT * FROM " <> sourceCTEName)
+    | otherwise                      = selectQuery
+
+  decodeStandard :: HD.Result ResultsWithCount
+  decodeStandard =
+   fromMaybe (Nothing, 0, [], mempty, Right [], Right Nothing) <$> HD.rowMaybe standardRow
+
+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
+ where
+  snippet =
+    "WITH " <>
+    SQL.sql sourceCTEName <> " AS ( " <> selectQuery <> " ) " <>
+    countCTEF <> " " <>
+    SQL.sql ("SELECT " <>
+      countResultF <> " AS total_result_set, " <>
+      "pg_catalog.count(_postgrest_t) AS page_total, " <>
+      noLocationF <> " AS header, " <>
+      bodyF <> " AS body, " <>
+      responseHeadersF <> " AS response_headers, " <>
+      responseStatusF <> " AS response_status " <>
+    "FROM ( SELECT * FROM " <> sourceCTEName <> " ) _postgrest_t")
+
+  (countCTEF, countResultF) = countF countQuery countTotal
+
+  bodyF
+    | asCsv = asCsvF
+    | isSingle = asJsonSingleF False
+    | isJust binaryField = asBinaryF $ fromJust binaryField
+    | otherwise = asJsonF False
+
+  decodeStandard :: HD.Result ResultsWithCount
+  decodeStandard =
+    HD.singleRow standardRow
+
+{-| Read and Write api requests use a similar response format which includes
+    various record counts and possible location header. This is the decoder
+    for that common type of query.
+-}
+standardRow :: HD.Row ResultsWithCount
+standardRow = (,,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
+                      <*> arrayColumn HD.bytea <*> column HD.bytea
+                      <*> (fromMaybe (Right []) <$> nullableColumn decodeGucHeaders)
+                      <*> (fromMaybe (Right Nothing) <$> nullableColumn decodeGucStatus)
+
+type ProcResults = (Maybe Int64, Int64, ByteString, Either Error [GucHeader], Either Error (Maybe Status))
+
+callProcStatement :: Bool -> Bool -> 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
+  where
+    snippet =
+      "WITH " <> SQL.sql sourceCTEName <> " AS (" <> callProcQuery <> ") " <>
+      countCTEF <>
+      SQL.sql (
+      "SELECT " <>
+        countResultF <> " AS total_result_set, " <>
+        "pg_catalog.count(_postgrest_t) AS page_total, " <>
+        bodyF <> " AS body, " <>
+        responseHeadersF <> " AS response_headers, " <>
+        responseStatusF <> " AS response_status ") <>
+      "FROM (" <> selectQuery <> ") _postgrest_t"
+
+    (countCTEF, countResultF) = countF countQuery countTotal
+
+    bodyF
+     | asSingle           = asJsonSingleF returnsScalar
+     | asCsv              = asCsvF
+     | isJust binaryField = asBinaryF $ fromJust binaryField
+     | returnsSingle
+       && not multObjects = asJsonSingleF returnsScalar
+     | otherwise          = asJsonF returnsScalar
+
+    decodeProc :: HD.Result ProcResults
+    decodeProc =
+      fromMaybe (Just 0, 0, mempty, defGucHeaders, defGucStatus) <$> HD.rowMaybe procRow
+      where
+        defGucHeaders = Right []
+        defGucStatus  = Right Nothing
+        procRow = (,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
+                         <*> column HD.bytea
+                         <*> (fromMaybe defGucHeaders <$> nullableColumn decodeGucHeaders)
+                         <*> (fromMaybe defGucStatus <$> nullableColumn decodeGucStatus)
+
+createExplainStatement :: SQL.Snippet -> Bool -> SQL.Statement () (Maybe Int64)
+createExplainStatement countQuery =
+  SQL.dynamicallyParameterized snippet decodeExplain
+  where
+    snippet = "EXPLAIN (FORMAT JSON) " <> countQuery
+    -- |
+    -- An `EXPLAIN (FORMAT JSON) select * from items;` output looks like this:
+    -- [{
+    --   "Plan": {
+    --     "Node Type": "Seq Scan", "Parallel Aware": false, "Relation Name": "items",
+    --     "Alias": "items", "Startup Cost": 0.00, "Total Cost": 32.60,
+    --     "Plan Rows": 2260,"Plan Width": 8} }]
+    -- We only obtain the Plan Rows here.
+    decodeExplain :: HD.Result (Maybe Int64)
+    decodeExplain =
+      let row = HD.singleRow $ column HD.bytea in
+      (^? L.nth 0 . L.key "Plan" .  L.key "Plan Rows" . L._Integral) <$> row
+
+decodeGucHeaders :: HD.Value (Either Error [GucHeader])
+decodeGucHeaders = first (const GucHeadersError) . JSON.eitherDecode . LBS.fromStrict <$> HD.bytea
+
+decodeGucStatus :: HD.Value (Either Error (Maybe Status))
+decodeGucStatus = first (const GucStatusError) . fmap (Just . toEnum . fst) . decimal <$> HD.text
+
+column :: HD.Value a -> HD.Row a
+column = HD.column . HD.nonNullable
+
+nullableColumn :: HD.Value a -> HD.Row (Maybe a)
+nullableColumn = HD.column . HD.nullable
+
+arrayColumn :: HD.Value a -> HD.Row [a]
+arrayColumn = column . HD.listArray . HD.nonNullable

src/PostgREST/QueryBuilder.hs

@@ -1,473 +0,0 @@
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE TupleSections        #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-|
-Module      : PostgREST.QueryBuilder
-Description : PostgREST SQL generating functions.
-
-This module provides functions to consume data types that
-represent database objects (e.g. Relation, Schema, SqlQuery)
-and produces SQL Statements.
-
-Any function that outputs a SQL fragment should be in this module.
--}
-module PostgREST.QueryBuilder (
-    callProc
-  , createReadStatement
-  , createWriteStatement
-  , getJoinConditions
-  , pgFmtIdent
-  , pgFmtLit
-  , requestToQuery
-  , requestToCountQuery
-  , sourceCTEName
-  , unquoted
-  , ResultsWithCount
-  , pgFmtEnvVar
-  ) where
-
-import qualified Hasql.Query             as H
-import qualified Hasql.Encoders          as HE
-import qualified Hasql.Decoders          as HD
-
-import qualified Data.Aeson              as JSON
-
-import           PostgREST.RangeQuery    (NonnegRange, rangeLimit, rangeOffset, allRange)
-import           Data.Functor.Contravariant (contramap)
-import qualified Data.HashMap.Strict     as HM
-import           Data.Maybe
-import           Data.Text               (intercalate, unwords, replace, isInfixOf, toLower)
-import qualified Data.Text as T          (map, takeWhile, null)
-import qualified Data.Text.Encoding as T
-import           Data.Tree               (Tree(..))
-import qualified Data.Vector as V
-import           PostgREST.Types
-import           Text.InterpolatedString.Perl6 (qc)
-import qualified Data.ByteString.Char8   as BS
-import           Data.Scientific         ( FPFormat (..)
-                                         , formatScientific
-                                         , isInteger
-                                         )
-import           Protolude hiding        (from, intercalate, ord, cast)
-import           PostgREST.ApiRequest    (PreferRepresentation (..))
-
-{-| The generic query result format used by API responses. The location header
-    is represented as a list of strings containing variable bindings like
-    @"k1=eq.42"@, or the empty list if there is no location header.
--}
-type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString)
-
-standardRow :: HD.Row ResultsWithCount
-standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
-                    <*> HD.value header <*> HD.value HD.bytea
-  where
-    header = HD.array $ HD.arrayDimension replicateM $ HD.arrayValue HD.bytea
-
-noLocationF :: Text
-noLocationF = "array[]::text[]"
-
-{-| Read and Write api requests use a similar response format which includes
-    various record counts and possible location header. This is the decoder
-    for that common type of query.
--}
-decodeStandard :: HD.Result ResultsWithCount
-decodeStandard =
-  HD.singleRow standardRow
-
-decodeStandardMay :: HD.Result (Maybe ResultsWithCount)
-decodeStandardMay =
-  HD.maybeRow standardRow
-
-{-| JSON and CSV payloads from the client are given to us as
-    PayloadJSON (objects who all have the same keys),
-    and we turn this into an old fasioned JSON array
--}
-encodeUniformObjs :: HE.Params PayloadJSON
-encodeUniformObjs =
-  contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json)
-
-createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName ->
-                       H.Query () ResultsWithCount
-createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =
-  unicodeStatement sql HE.unit decodeStandard False
- where
-  sql = [qc|
-      WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}
-      FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |]
-  countResultF = if countTotal then "("<>countQuery<>")" else "null"
-  cols = intercalate ", " [
-      countResultF <> " AS total_result_set",
-      "pg_catalog.count(_postgrest_t) AS page_total",
-      noLocationF <> " AS header",
-      bodyF <> " AS body"
-    ]
-  bodyF
-    | asCsv = asCsvF
-    | isSingle = asJsonSingleF
-    | isJust binaryField = asBinaryF $ fromJust binaryField
-    | otherwise = asJsonF
-
-createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
-                        PreferRepresentation -> [Text] ->
-                        H.Query PayloadJSON (Maybe ResultsWithCount)
-createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys =
-  unicodeStatement sql encodeUniformObjs decodeStandardMay True
-
- where
-  sql = case rep of
-    None -> [qc|
-      WITH {sourceCTEName} AS ({mutateQuery})
-      SELECT '', 0, {noLocationF}, '' |]
-    HeadersOnly -> [qc|
-      WITH {sourceCTEName} AS ({mutateQuery})
-      SELECT {cols}
-      FROM (SELECT 1 FROM {sourceCTEName}) _postgrest_t |]
-    Full -> [qc|
-      WITH {sourceCTEName} AS ({mutateQuery})
-      SELECT {cols}
-      FROM ({selectQuery}) _postgrest_t |]
-
-  cols = intercalate ", " [
-      "'' AS total_result_set", -- when updateing it does not make sense
-      "pg_catalog.count(_postgrest_t) AS page_total",
-      if wantHdrs
-         then locationF pKeys
-         else noLocationF <> " AS header",
-      if rep == Full
-         then bodyF <> " AS body"
-         else "''"
-    ]
-
-  bodyF
-    | asCsv = asCsvF
-    | wantSingle = asJsonSingleF
-    | otherwise = asJsonF
-
-type ProcResults = (Maybe Int64, Int64, ByteString)
-callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange ->
-  Bool -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults)
-callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson asCsv =
-  unicodeStatement sql HE.unit decodeProc True
-  where
-    sql = [qc|
-            WITH {sourceCTEName} AS ({_callSql})
-            SELECT
-              {countResultF} AS total_result_set,
-              pg_catalog.count(_postgrest_t) AS page_total,
-              case
-                when pg_catalog.count(*) > 1 then
-                  {bodyF}
-                else
-                  coalesce(((array_agg(row_to_json(_postgrest_t)))[1]->{_procName})::character varying, {bodyF})
-
-              end as body
-            FROM ({selectQuery}) _postgrest_t;
-          |]
-          -- FROM (select * from {sourceCTEName} {limitF range}) t;
-    countResultF = if countTotal then "("<>countQuery<>")" else "null::bigint" :: Text
-    _args = if paramsAsJson
-                then insertableValueWithType "json" $ JSON.Object params
-                else intercalate "," $ map _assignment (HM.toList params)
-    _procName = pgFmtLit $ qiName qi
-    _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
-    _callSql = [qc|select * from {fromQi qi}({_args}) |] :: Text
-    _countExpr = if countTotal
-                   then [qc|(select pg_catalog.count(*) from {sourceCTEName})|]
-                   else "null::bigint" :: Text
-    decodeProc = HD.maybeRow procRow
-    procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
-                   <*> HD.value HD.bytea
-    bodyF
-     | isSingle = asJsonSingleF
-     | asCsv = asCsvF
-     | otherwise = asJsonF
-
-pgFmtIdent :: SqlFragment -> SqlFragment
-pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""
-
-pgFmtLit :: SqlFragment -> SqlFragment
-pgFmtLit x =
- let trimmed = trimNullChars x
-     escaped = "'" <> replace "'" "''" trimmed <> "'"
-     slashed = replace "\\" "\\\\" escaped in
- if "\\" `isInfixOf` escaped
-   then "E" <> slashed
-   else slashed
-
-requestToCountQuery :: Schema -> DbRequest -> SqlQuery
-requestToCountQuery _ (DbMutate _) = undefined
-requestToCountQuery schema (DbRead (Node (Select _ _ conditions logic_ _ _, (mainTbl, _, _)) _)) =
- unwords [
-   "SELECT pg_catalog.count(*)",
-   "FROM ", fromQi qi,
-    -- logic_ doesn't not need localFilter filtering because it doesn't have VForeignKey vals
-    ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) localConditions ++ map (pgFmtLogicTree qi) logic_))
-      `emptyOnFalse` (null conditions && null logic_)
-   ]
- where
-   qi = removeSourceCTESchema schema mainTbl
-   localFilter :: Filter -> Bool
-   localFilter Filter{operation=Operation{expr=(_, val)}} = case val of
-    VText _ -> True
-    VTextL _ -> True
-    VForeignKey _ _ -> False
-   localConditions = filter localFilter conditions
-
-requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery
-requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions logic_ ord range, (nodeName, maybeRelation, _)) forest)) =
-  query
-  where
-    mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)
-    qi = removeSourceCTESchema schema mainTbl
-    toQi = removeSourceCTESchema schema
-    query = unwords [
-      "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
-      "FROM ", intercalate ", " (map (fromQi . toQi) tbls),
-      unwords joins,
-      ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))
-        `emptyOnFalse` (null conditions && null logic_),
-      orderF (fromMaybe [] ord),
-      if isParent then "" else limitF range
-      ]
-    orderF ts =
-        if null ts
-            then ""
-            else "ORDER BY " <> clause
-        where
-            clause = intercalate "," (map queryTerm ts)
-            queryTerm :: OrderTerm -> Text
-            queryTerm t = " "
-                <> toS (pgFmtField qi $ otTerm t) <> " "
-                <> maybe "" show (otDirection t) <> " "
-                <> maybe "" show (otNullOrder t) <> " "
-    (joins, selects) = foldr getQueryParts ([],[]) forest
-
-    getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
-    getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s)
-      where
-        sel = "COALESCE(("
-           <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
-           <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
-           <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
-           where subquery = requestToQuery schema False (DbRead (Node n forst))
-    getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (joi:j,sel:s)
-      where
-        node_name = fromMaybe name alias
-        local_table_name = table <> "_" <> node_name
-        replaceTableName localTableName (Filter a (Operation b (c, VForeignKey (QualifiedIdentifier "" _) d))) = Filter a (Operation b (c, VForeignKey (QualifiedIdentifier "" localTableName) d))
-        replaceTableName _ x = x
-        sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name
-        joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name  <>
-              " ON " <> intercalate " AND " ( map (pgFmtFilter qi . replaceTableName local_table_name) (getJoinConditions r) )
-          where subquery = requestToQuery schema True (DbRead (Node n forst))
-    getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s)
-      where
-        sel = "COALESCE (("
-           <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
-           <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
-           <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
-           where subquery = requestToQuery schema False (DbRead (Node n forst))
-    --the following is just to remove the warning
-    --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
-    --posible relations are Child Parent Many
-    getQueryParts _ _ = undefined
-requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) =
-  insInto <> vals <> ret
-  where qi = QualifiedIdentifier schema mainTbl
-        cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
-        colsString = intercalate ", " cols
-        insInto = unwords [ "INSERT INTO" , fromQi qi,
-            if T.null colsString then "" else "(" <> colsString <> ")"
-          ]
-        vals = unwords $
-          if T.null colsString
-            then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"]
-            else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"]
-        ret = if null returnings
-                  then ""
-                  else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)]
-requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions logic_ returnings)) =
-  case rows V.!? 0 of
-    Just obj ->
-      let assignments = map
-            (\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in
-      unwords [
-        "UPDATE ", fromQi qi,
-        " SET " <> intercalate "," assignments <> " ",
-        ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))
-          `emptyOnFalse` (null conditions && null logic_),
-        ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
-        ]
-    Nothing -> undefined
-  where
-    qi = QualifiedIdentifier schema mainTbl
-requestToQuery schema _ (DbMutate (Delete mainTbl conditions logic_ returnings)) =
-  query
-  where
-    qi = QualifiedIdentifier schema mainTbl
-    query = unwords [
-      "DELETE FROM ", fromQi qi,
-      ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))
-        `emptyOnFalse` (null conditions && null logic_),
-      ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
-      ]
-
-sourceCTEName :: SqlFragment
-sourceCTEName = "pg_source"
-
-removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
-removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl
-
-unquoted :: JSON.Value -> Text
-unquoted (JSON.String t) = t
-unquoted (JSON.Number n) =
-  toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
-unquoted (JSON.Bool b) = show b
-unquoted v = toS $ JSON.encode v
-
--- private functions
-asCsvF :: SqlFragment
-asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
-  where
-    asCsvHeaderF =
-      "(SELECT coalesce(string_agg(a.k, ','), '')" <>
-      "  FROM (" <>
-      "    SELECT json_object_keys(r)::TEXT as k" <>
-      "    FROM ( " <>
-      "      SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
-      "    ) s" <>
-      "  ) a" <>
-      ")"
-    asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
-
-asJsonF :: SqlFragment
-asJsonF = "coalesce(array_to_json(array_agg(row_to_json(_postgrest_t))), '[]')::character varying"
-
-asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
-asJsonSingleF = "coalesce(string_agg(row_to_json(_postgrest_t)::text, ','), '')::character varying "
-
-asBinaryF :: FieldName -> SqlFragment
-asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
-
-locationF :: [Text] -> SqlFragment
-locationF pKeys =
-    "(" <>
-    " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceCTEName <> " as ss  limit 1)" <>
-    " SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))" <>
-    " FROM s, json_each_text(s.r) AS json_data" <>
-    (
-      if null pKeys
-      then ""
-      else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')"
-    ) <> ")"
-
-limitF :: NonnegRange -> SqlFragment
-limitF r  = if r == allRange
-  then ""
-  else "LIMIT " <> limit <> " OFFSET " <> offset
-  where
-    limit  = maybe "ALL" show $ rangeLimit r
-    offset = show $ rangeOffset r
-
-fromQi :: QualifiedIdentifier -> SqlFragment
-fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
-  where
-    n = qiName t
-    s = qiSchema t
-
-getJoinConditions :: Relation -> [Filter]
-getJoinConditions (Relation t cols ft fcs typ lt lc1 lc2) =
-  case typ of
-    Child  -> zipWith (toFilter tN ftN) cols fcs
-    Parent -> zipWith (toFilter tN ftN) cols fcs
-    Many   -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2)
-    Root   -> undefined --error "undefined getJoinConditions"
-  where
-    s = if typ == Parent then "" else tableSchema t
-    tN = tableName t
-    ftN = tableName ft
-    ltN = fromMaybe "" (tableName <$> lt)
-    toFilter :: Text -> Text -> Column -> Column -> Filter
-    toFilter tb ftb c fc = Filter (colName c, Nothing) (Operation False ("=", VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})))
-
-unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Query a b
-unicodeStatement = H.statement . T.encodeUtf8
-
-emptyOnFalse :: Text -> Bool -> Text
-emptyOnFalse val cond = if cond then "" else val
-
-insertableValue :: JSON.Value -> SqlFragment
-insertableValue JSON.Null = "null"
-insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v
-
-insertableValueWithType :: Text -> JSON.Value -> SqlFragment
-insertableValueWithType t v =
-  pgFmtLit (unquoted v) <> "::" <> t
-
-pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
-pgFmtColumn table "*" = fromQi table <> ".*"
-pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
-
-pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment
-pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp
-
-pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment
-pgFmtSelectItem table (f@(_, jp), Nothing, alias) = pgFmtField table f <> pgFmtAs jp alias
-pgFmtSelectItem table (f@(_, jp), Just cast, alias) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs jp alias
-
-pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment
-pgFmtFilter table (Filter fld (Operation hasNot_ ex)) = notOp <> " " <> case ex of
-   (op, VText val) -> pgFmtFieldOp op <> " " <> case op of
-     "like"  -> unknownLiteral (T.map star val)
-     "ilike" -> unknownLiteral (T.map star val)
-     "@@"    -> "to_tsquery(" <> unknownLiteral val <> ") "
-     "is"    -> whiteList val
-     "isnot" -> whiteList val
-     _       -> unknownLiteral val
-   (op, VTextL vals) -> pgFmtIn op vals -- in and notin
-   (op, VForeignKey fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName})) ->
-     pgFmtField fQi fld <> " " <> sqlOperator op <> " " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName
- where
-   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
-   sqlOperator o = HM.lookupDefault "=" o operators
-   notOp = if hasNot_ then "NOT" else ""
-   star c = if c == '*' then '%' else c
-   unknownLiteral = (<> "::unknown ") . pgFmtLit
-   whiteList :: Text -> SqlFragment
-   whiteList v = fromMaybe
-     (toS (pgFmtLit v) <> "::unknown ")
-     (find ((==) . toLower $ v) ["null","true","false"])
-   pgFmtIn :: Operator -> [Text] -> SqlFragment
-   pgFmtIn op vals =
-    -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"
-    let emptyValForIn o = (if "not" `isInfixOf` o then "NOT " else "") -- handle case of "notin" operator
-                          <> pgFmtField table fld <> " = any('{}') " in
-    case T.null <$> headMay vals of
-      Just isNull -> if isNull && length vals == 1
-                        then emptyValForIn op
-                        else pgFmtFieldOp op <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "
-      Nothing -> emptyValForIn op
-
-pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment
-pgFmtLogicTree qi (Expr hasNot_ op lt rt) = notOp <> " (" <> pgFmtLogicTree qi lt <> " " <> show op <> " " <> pgFmtLogicTree qi rt <> ")"
-  where notOp =  if hasNot_ then "NOT" else ""
-pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
-
-pgFmtJsonPath :: Maybe JsonPath -> SqlFragment
-pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
-pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )
-pgFmtJsonPath _ = ""
-
-pgFmtAs :: Maybe JsonPath -> Maybe Alias -> SqlFragment
-pgFmtAs Nothing Nothing = ""
-pgFmtAs (Just xx) Nothing = case lastMay xx of
-  Just alias -> " AS " <> pgFmtIdent alias
-  Nothing -> ""
-pgFmtAs _ (Just alias) = " AS " <> pgFmtIdent alias
-
-pgFmtEnvVar :: Text -> (Text, Text) -> SqlFragment
-pgFmtEnvVar prefix (k, v) =
-  "set local " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";"
-
-trimNullChars :: Text -> Text
-trimNullChars = T.takeWhile (/= '\x0')

src/PostgREST/RangeQuery.hs

@@ -1,3 +1,7 @@
+{-|
+Module      : PostgREST.RangeQuery
+Description : Logic regarding the `Range`/`Content-Range` headers and `limit`/`offset` querystring arguments.
+-}
 module PostgREST.RangeQuery (
   rangeParse
 , rangeRequested
@@ -7,21 +11,22 @@ module PostgREST.RangeQuery (
 , rangeGeq
 , allRange
 , NonnegRange
+, rangeStatusHeader
+, contentRangeH
 ) where
 
+import qualified Data.ByteString.Char8 as BS
 
-import           Control.Applicative
-import           Network.HTTP.Types.Header
+import Data.List       (lookup)
+import Text.Regex.TDFA ((=~))
 
-import qualified Data.ByteString.Char8     as BS
-import           Data.Ranged.Boundaries
-import           Data.Ranged.Ranges
+import Control.Applicative
+import Data.Ranged.Boundaries
+import Data.Ranged.Ranges
+import Network.HTTP.Types.Header
+import Network.HTTP.Types.Status
 
-import           Text.Regex.TDFA           ((=~))
-
-import Data.List (lookup)
-
-import           Protolude
+import Protolude
 
 type NonnegRange = Range Integer
 
@@ -31,15 +36,14 @@ rangeParse range = do
 
   case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of
     Just parsedRange ->
-      let [_, mLower, mUpper] = readMaybe . toS <$> parsedRange
-          lower         = fromMaybe emptyRange   (rangeGeq <$> mLower)
-          upper         = fromMaybe allRange (rangeLeq <$> mUpper) in
+      let [_, mLower, mUpper] = readMaybe . BS.unpack <$> parsedRange
+          lower         = maybe emptyRange rangeGeq mLower
+          upper         = maybe allRange rangeLeq mUpper in
       rangeIntersection lower upper
     Nothing -> allRange
 
 rangeRequested :: RequestHeaders -> NonnegRange
-rangeRequested headers = fromMaybe allRange $
-  rangeParse <$> lookup hRange headers
+rangeRequested headers = maybe allRange rangeParse $ lookup hRange headers
 
 restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange
 restrictRange Nothing r = r
@@ -57,7 +61,7 @@ rangeOffset :: NonnegRange -> Integer
 rangeOffset range =
   case rangeLower range of
     BoundaryBelow lower -> lower
-    _ -> panic "range without lower bound" -- should never happen
+    _                   -> panic "range without lower bound" -- should never happen
 
 rangeGeq :: Integer -> NonnegRange
 rangeGeq n =
@@ -69,3 +73,30 @@ allRange = rangeGeq 0
 rangeLeq :: Integer -> NonnegRange
 rangeLeq n =
   Range BoundaryBelowAll (BoundaryAbove n)
+
+rangeStatusHeader :: NonnegRange -> Int64 -> Maybe Int64 -> (Status, Header)
+rangeStatusHeader topLevelRange queryTotal tableTotal =
+  let lower = rangeOffset topLevelRange
+      upper = lower + toInteger queryTotal - 1
+      contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
+      status = rangeStatus lower upper (toInteger <$> tableTotal)
+  in (status, contentRange)
+  where
+    rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
+    rangeStatus _ _ Nothing = status200
+    rangeStatus lower upper (Just total)
+      | lower > total               = status416 -- 416 Range Not Satisfiable
+      | (1 + upper - lower) < total = status206 -- 206 Partial Content
+      | otherwise                   = status200 -- 200 OK
+
+contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header
+contentRangeH lower upper total =
+    ("Content-Range", toUtf8 headerValue)
+    where
+      headerValue   = rangeString <> "/" <> totalString :: Text
+      rangeString
+        | totalNotZero && fromInRange = show lower <> "-" <> show upper
+        | otherwise = "*"
+      totalString   = maybe "*" show total
+      totalNotZero  = Just 0 /= total
+      fromInRange   = lower <= upper

src/PostgREST/Request/ApiRequest.hs

@@ -0,0 +1,518 @@
+{-|
+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

@@ -0,0 +1,397 @@
+{-|
+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

@@ -0,0 +1,294 @@
+{-|
+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/Preferences.hs

@@ -0,0 +1,200 @@
+-- |
+-- Module: PostgREST.Request.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
+  ( Preferences(..)
+  , PreferCount(..)
+  , PreferParameters(..)
+  , PreferRepresentation(..)
+  , PreferResolution(..)
+  , PreferTransaction(..)
+  , fromHeaders
+  , ToAppliedHeader(..)
+  ) where
+
+import qualified Data.ByteString.Char8     as BS
+import qualified Data.Map                  as Map
+import qualified Network.HTTP.Types.Header as HTTP
+
+import Protolude
+
+
+-- $setup
+-- Setup for doctests
+-- >>> import Text.Pretty.Simple (pPrint)
+-- >>> deriving instance Show PreferResolution
+-- >>> deriving instance Show PreferRepresentation
+-- >>> deriving instance Show PreferParameters
+-- >>> deriving instance Show PreferCount
+-- >>> deriving instance Show PreferTransaction
+-- >>> deriving instance Show Preferences
+
+-- | Preferences recognized by the application.
+data Preferences
+  = Preferences
+    { preferResolution     :: Maybe PreferResolution
+    , preferRepresentation :: Maybe PreferRepresentation
+    , preferParameters     :: Maybe PreferParameters
+    , preferCount          :: Maybe PreferCount
+    , preferTransaction    :: Maybe PreferTransaction
+    }
+
+-- |
+-- Parse HTTP headers based on RFC7240[1] to identify preferences.
+--
+-- One header with comma-separated values can be used to set multiple preferences:
+--
+-- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates, count=exact")]
+-- Preferences
+--     { preferResolution = Just IgnoreDuplicates
+--     , preferRepresentation = Nothing
+--     , preferParameters = Nothing
+--     , preferCount = Just ExactCount
+--     , preferTransaction = Nothing
+--     }
+--
+-- Multiple headers can also be used:
+--
+-- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates"), ("Prefer", "count=exact")]
+-- Preferences
+--     { preferResolution = Just IgnoreDuplicates
+--     , preferRepresentation = Nothing
+--     , preferParameters = Nothing
+--     , preferCount = Just ExactCount
+--     , preferTransaction = Nothing
+--     }
+--
+-- If a preference is set more than once, only the first is used:
+--
+-- >>> preferTransaction $ fromHeaders [("Prefer", "tx=commit, tx=rollback")]
+-- Just Commit
+--
+-- This is also the case across multiple headers:
+--
+-- >>> :{
+--   preferResolution . fromHeaders $
+--     [ ("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")]
+-- Preferences
+--     { preferResolution = Nothing
+--     , preferRepresentation = Just None
+--     , preferParameters = Nothing
+--     , preferCount = Just ExactCount
+--     , preferTransaction = Just Commit
+--     }
+--
+fromHeaders :: [HTTP.Header] -> Preferences
+fromHeaders headers =
+  Preferences
+    { preferResolution = parsePrefs [MergeDuplicates, IgnoreDuplicates]
+    , preferRepresentation = parsePrefs [Full, None, HeadersOnly]
+    , preferParameters = parsePrefs [SingleObject, MultipleObjects]
+    , preferCount = parsePrefs [ExactCount, PlannedCount, EstimatedCount]
+    , preferTransaction = parsePrefs [Commit, Rollback]
+    }
+  where
+    prefHeaders = filter ((==) HTTP.hPrefer . fst) headers
+    prefs = fmap BS.strip . concatMap (BS.split ',' . snd) $ prefHeaders
+
+    parsePrefs :: ToHeaderValue a => [a] -> Maybe a
+    parsePrefs vals =
+      head $ mapMaybe (flip Map.lookup $ prefMap vals) prefs
+
+    prefMap :: ToHeaderValue a => [a] -> Map.Map ByteString a
+    prefMap = Map.fromList . fmap (\pref -> (toHeaderValue pref, pref))
+
+-- |
+-- Convert a preference into the value that we look for in the 'Prefer' headers.
+--
+-- >>> toHeaderValue MergeDuplicates
+-- "resolution=merge-duplicates"
+--
+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
+
+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).
+  | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
+  | None        -- ^ Return nothing from the mutated data.
+  deriving Eq
+
+instance ToHeaderValue PreferRepresentation where
+  toHeaderValue Full        = "return=representation"
+  toHeaderValue None        = "return=minimal"
+  toHeaderValue HeadersOnly = "return=headers-only"
+
+-- | 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
+  = ExactCount     -- ^ Exact count (slower).
+  | PlannedCount   -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
+  | EstimatedCount -- ^ Use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
+  deriving Eq
+
+instance ToHeaderValue PreferCount where
+  toHeaderValue ExactCount     = "count=exact"
+  toHeaderValue PlannedCount   = "count=planned"
+  toHeaderValue EstimatedCount = "count=estimated"
+
+-- | Whether to commit or roll back transactions.
+data PreferTransaction
+  = Commit   -- ^ Commit transaction - the default.
+  | Rollback -- ^ Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
+  deriving Eq
+
+instance ToHeaderValue PreferTransaction where
+  toHeaderValue Commit   = "tx=commit"
+  toHeaderValue Rollback = "tx=rollback"
+
+instance ToAppliedHeader PreferTransaction

src/PostgREST/Request/Types.hs

@@ -0,0 +1,232 @@
+{-# 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/Types.hs

@@ -1,245 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields    #-}
-module PostgREST.Types where
-import           Protolude
-import qualified GHC.Show
-import           Data.Aeson
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.HashMap.Strict  as M
-import           Data.Tree
-import qualified Data.Vector          as V
-import           PostgREST.RangeQuery (NonnegRange)
-import           Network.HTTP.Types.Header (hContentType, Header)
-
--- | Enumeration of currently supported response content types
-data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
-                 | CTSingularJSON | CTOctetStream
-                 | CTAny | CTOther ByteString deriving Eq
-
-data ApiRequestError = ActionInappropriate
-                     | InvalidBody ByteString
-                     | InvalidRange
-                     | ParseRequestError Text Text
-                     | UnknownRelation
-                     | NoRelationBetween Text Text
-                     | UnsupportedVerb
-                     deriving (Show, Eq)
-
-data DbStructure = DbStructure {
-  dbTables      :: [Table]
-, dbColumns     :: [Column]
-, dbRelations   :: [Relation]
-, dbPrimaryKeys :: [PrimaryKey]
-, dbProcs       :: M.HashMap Text ProcDescription
-} deriving (Show, Eq)
-
-data PgArg = PgArg {
-  pgaName :: Text
-, pgaType :: Text
-, pgaReq  :: Bool
-} deriving (Show, Eq)
-
-data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier | Pseudo Text deriving (Eq, Show)
-
-data RetType = Single PgType | SetOf PgType deriving (Eq, Show)
-
-data ProcVolatility = Volatile | Stable | Immutable
-  deriving (Eq, Show)
-
-data ProcDescription = ProcDescription {
-  pdName       :: Text
-, pdArgs       :: [PgArg]
-, pdReturnType :: RetType
-, pdVolatility :: ProcVolatility
-} deriving (Show, Eq)
-
-type Schema = Text
-type TableName = Text
-type SqlQuery = Text
-type SqlFragment = Text
-type RequestBody = BL.ByteString
-
-data Table = Table {
-  tableSchema     :: Schema
-, tableName       :: TableName
-, tableInsertable :: Bool
-} deriving (Show, Ord)
-
-newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord)
-
-data Column =
-    Column {
-      colTable     :: Table
-    , colName      :: Text
-    , colPosition  :: Int32
-    , colNullable  :: Bool
-    , colType      :: Text
-    , colUpdatable :: Bool
-    , colMaxLen    :: Maybe Int32
-    , colPrecision :: Maybe Int32
-    , colDefault   :: Maybe Text
-    , colEnum      :: [Text]
-    , colFK        :: Maybe ForeignKey
-    } deriving (Show, Ord)
-
-type Synonym = (Column,Column)
-
-data PrimaryKey = PrimaryKey {
-    pkTable :: Table
-  , pkName  :: Text
-} deriving (Show, Eq)
-
-data OrderDirection = OrderAsc | OrderDesc deriving (Eq)
-instance Show OrderDirection where
-  show OrderAsc  = "asc"
-  show OrderDesc = "desc"
-
-data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq)
-instance Show OrderNulls where
-  show OrderNullsFirst = "nulls first"
-  show OrderNullsLast  = "nulls last"
-
-data OrderTerm = OrderTerm {
-  otTerm      :: Field
-, otDirection :: Maybe OrderDirection
-, otNullOrder :: Maybe OrderNulls
-} deriving (Show, Eq)
-
-data QualifiedIdentifier = QualifiedIdentifier {
-  qiSchema :: Schema
-, qiName   :: TableName
-} deriving (Show, Eq)
-
-
-data RelationType = Child | Parent | Many | Root deriving (Show, Eq)
-data Relation = Relation {
-  relTable    :: Table
-, relColumns  :: [Column]
-, relFTable   :: Table
-, relFColumns :: [Column]
-, relType     :: RelationType
-, relLTable   :: Maybe Table
-, relLCols1   :: Maybe [Column]
-, relLCols2   :: Maybe [Column]
-} deriving (Show, Eq)
-
--- | An array of JSON objects that has been verified to have
--- the same keys in every object
-newtype PayloadJSON = PayloadJSON (V.Vector Object)
-  deriving (Show, Eq)
-
-unPayloadJSON :: PayloadJSON -> V.Vector Object
-unPayloadJSON (PayloadJSON objs) = objs
-
-data Proxy = Proxy {
-  proxyScheme     :: Text
-, proxyHost       :: Text
-, proxyPort       :: Integer
-, proxyPath       :: Text
-} deriving (Show, Eq)
-
-type Operator = Text
-operators :: M.HashMap Operator SqlFragment
-operators = M.fromList [
-  ("eq", "="),
-  ("gte", ">="),
-  ("gt", ">"),
-  ("lte", "<="),
-  ("lt", "<"),
-  ("neq", "<>"),
-  ("like", "LIKE"),
-  ("ilike", "ILIKE"),
-  ("in", "IN"),
-  ("notin", "NOT IN"),
-  ("isnot", "IS NOT"),
-  ("is", "IS"),
-  ("@@", "@@"),
-  ("@>", "@>"),
-  ("<@", "<@")]
-data Operation = Operation{ hasNot::Bool, expr::(Operator, Operand) } deriving (Eq, Show)
-data Operand = VText Text | VTextL [Text] | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
-
-data LogicOperator = And | Or deriving Eq
-instance Show LogicOperator where
-  show And  = "AND"
-  show Or = "OR"
-{-|
-  Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
-
-            And
-           /   \
-  name.eq.N     Or
-               /  \
-         id.eq.1   id.eq.2
--}
-data LogicTree = Expr Bool LogicOperator LogicTree LogicTree | Stmnt Filter deriving (Show, Eq)
-
-type FieldName = Text
-type JsonPath = [Text]
-type Field = (FieldName, Maybe JsonPath)
-type Alias = Text
-type Cast = Text
-type NodeName = Text
-type SelectItem = (Field, Maybe Cast, Maybe Alias)
--- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]
-type EmbedPath = [Text]
-data Filter = Filter { field::Field, operation::Operation } deriving (Show, Eq)
-
-data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], logic::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
-data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }
-                 | Delete { in_::TableName, where_::[Filter], logic::[LogicTree], returning::[FieldName] }
-                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], logic::[LogicTree], returning::[FieldName] } deriving (Show, Eq)
-type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
-type ReadRequest = Tree ReadNode
-type MutateRequest = MutateQuery
-data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
-
-instance ToJSON Column where
-  toJSON c = object [
-      "schema"    .= tableSchema t
-    , "name"      .= colName c
-    , "position"  .= colPosition c
-    , "nullable"  .= colNullable c
-    , "type"      .= colType c
-    , "updatable" .= colUpdatable c
-    , "maxLen"    .= colMaxLen c
-    , "precision" .= colPrecision c
-    , "references".= colFK c
-    , "default"   .= colDefault c
-    , "enum"      .= colEnum c ]
-    where
-      t = colTable c
-
-instance ToJSON ForeignKey where
-  toJSON fk = object [
-      "schema" .= tableSchema t
-    , "table"  .= tableName t
-    , "column" .= colName c ]
-    where
-      c = fkCol fk
-      t = colTable c
-
-instance ToJSON Table where
-  toJSON v = object [
-      "schema"     .= tableSchema v
-    , "name"       .= tableName v
-    , "insertable" .= tableInsertable v ]
-
-instance Eq Table where
-  Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
-
-instance Eq Column where
-  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
-
--- | Convert from ContentType to a full HTTP Header
-toHeader :: ContentType -> Header
-toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
-
--- | Convert from ContentType to a ByteString representing the mime type
-toMime :: ContentType -> ByteString
-toMime CTApplicationJSON = "application/json"
-toMime CTTextCSV         = "text/csv"
-toMime CTOpenAPI         = "application/openapi+json"
-toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
-toMime CTOctetStream     = "application/octet-stream"
-toMime CTAny             = "*/*"
-toMime (CTOther ct)      = ct

src/PostgREST/Unix.hs

@@ -0,0 +1,59 @@
+module PostgREST.Unix
+  ( runAppWithSocket
+  , installSignalHandlers
+  ) where
+
+import qualified Network.Socket           as Socket
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified System.Posix.Signals     as Signals
+
+import Network.Wai        (Application)
+import System.Directory   (removeFile)
+import System.IO.Error    (isDoesNotExistError)
+import System.Posix.Files (setFileMode)
+import System.Posix.Types (FileMode)
+
+import qualified PostgREST.AppState as AppState
+import qualified PostgREST.Workers  as Workers
+
+import Protolude
+
+
+-- | Run the PostgREST application with user defined socket.
+runAppWithSocket :: Warp.Settings -> Application -> FileMode -> FilePath -> IO ()
+runAppWithSocket settings app socketFileMode socketFilePath =
+  bracket createAndBindSocket Socket.close $ \socket -> do
+    Socket.listen socket Socket.maxListenQueue
+    Warp.runSettingsSocket settings socket app
+  where
+    createAndBindSocket = do
+      deleteSocketFileIfExist socketFilePath
+      sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol
+      Socket.bind sock $ Socket.SockAddrUnix socketFilePath
+      setFileMode socketFilePath socketFileMode
+      return sock
+
+    deleteSocketFileIfExist path =
+      removeFile path `catch` handleDoesNotExist
+
+    handleDoesNotExist e
+      | isDoesNotExistError e = return ()
+      | otherwise = throwIO e
+
+-- | Set signal handlers, only for systems with signals
+installSignalHandlers :: AppState.AppState -> IO ()
+installSignalHandlers appState = do
+  -- Releases the connection pool whenever the program is terminated,
+  -- see https://github.com/PostgREST/postgrest/issues/268
+  install Signals.sigINT $ AppState.releasePool appState
+  install Signals.sigTERM $ AppState.releasePool appState
+
+  -- The SIGUSR1 signal updates the internal 'DbStructure' by running
+  -- 'connectionWorker' exactly as before.
+  install Signals.sigUSR1 $ Workers.connectionWorker appState
+
+  -- Re-read the config on SIGUSR2
+  install Signals.sigUSR2 $ Workers.reReadConfig False appState
+  where
+    install signal handler =
+      void $ Signals.installHandler signal (Signals.Catch handler) Nothing

src/PostgREST/Version.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell #-}
+module PostgREST.Version
+  ( docsVersion
+  , prettyVersion
+  ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.Text       as T
+
+import Data.Version       (showVersion, versionBranch)
+import Development.GitRev (gitHash)
+import Paths_postgrest    (version)
+
+import Protolude
+
+
+-- | User friendly version number such as '1.1.1'.
+-- Pre-release versions are tagged as such, e.g., '1.1.1.1 (pre-release)'.
+-- If a git hash is available, it's added to the version, e.g., '1.1.1 (abcdef0)'.
+prettyVersion :: ByteString
+prettyVersion =
+  toUtf8 (showVersion version) <> preRelease <> gitRev
+  where
+    gitRev =
+      if $(gitHash) == ("UNKNOWN" :: Text) then
+        mempty
+      else
+        " (" <> BS.take 7 $(gitHash) <> ")"
+    preRelease = if isPreRelease then " (pre-release)" else mempty
+
+
+-- | Version number used in docs.
+-- Uses only the two first components of the version. Example: 'v1.1'
+docsVersion :: Text
+docsVersion =
+  "v" <> (T.intercalate "." . map show . take 2 $ versionBranch version)
+
+
+-- | Versions with four components (e.g., '1.1.1.1') are treated as pre-releases.
+isPreRelease :: Bool
+isPreRelease =
+  length (versionBranch version) == 4

src/PostgREST/Workers.hs

@@ -0,0 +1,264 @@
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module PostgREST.Workers
+  ( connectionWorker
+  , reReadConfig
+  , listener
+  ) where
+
+import qualified Data.Aeson                 as JSON
+import qualified Data.ByteString            as BS
+import qualified Data.ByteString.Lazy       as LBS
+import qualified Data.Text.Encoding         as T
+import qualified Hasql.Notifications        as SQL
+import qualified Hasql.Pool                 as SQL
+import qualified Hasql.Transaction.Sessions as SQL
+
+import Control.Retry    (RetryStatus, capDelay, exponentialBackoff,
+                         retrying, rsPreviousDelay)
+import Hasql.Connection (acquire)
+
+import PostgREST.AppState         (AppState)
+import PostgREST.Config           (AppConfig (..), readAppConfig)
+import PostgREST.Config.Database  (queryDbSettings, queryPgVersion)
+import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion)
+import PostgREST.DbStructure      (queryDbStructure)
+import PostgREST.Error            (PgError (PgError), checkIsFatal,
+                                   errorPayload)
+
+import qualified PostgREST.AppState as AppState
+
+import Protolude
+
+
+-- | Current database connection status data ConnectionStatus
+data ConnectionStatus
+  = NotConnected
+  | Connected PgVersion
+  | FatalConnectionError Text
+  deriving (Eq)
+
+-- | Schema cache status
+data SCacheStatus
+  = SCLoaded
+  | SCOnRetry
+  | SCFatalFail
+
+-- | The purpose of this worker is to obtain a healthy connection to pg and an
+-- up-to-date schema cache(DbStructure).  This method is meant to be called
+-- multiple times by the same thread, but does nothing if the previous
+-- invocation has not terminated. In all cases this method does not halt the
+-- calling thread, the work is preformed in a separate thread.
+--
+-- Background thread that does the following :
+--  1. Tries to connect to pg server and will keep trying until success.
+--  2. Checks if the pg version is supported and if it's not it kills the main
+--     program.
+--  3. Obtains the dbStructure. If this fails, it goes back to 1.
+connectionWorker :: AppState -> IO ()
+connectionWorker appState = do
+  isWorkerOn <- AppState.getIsWorkerOn appState
+  -- Prevents multiple workers to be running at the same time. Could happen on
+  -- too many SIGUSR1s.
+  unless isWorkerOn $ do
+    AppState.putIsWorkerOn appState True
+    void $ forkIO work
+  where
+    work = do
+      AppConfig{..} <- AppState.getConfig appState
+      AppState.logWithZTime appState "Attempting to connect to the database..."
+      connected <- connectionStatus appState
+      case connected of
+        FatalConnectionError reason ->
+          -- Fatal error when connecting
+          AppState.logWithZTime appState reason >> killThread (AppState.getMainThreadId appState)
+        NotConnected ->
+          -- Unreachable because connectionStatus will keep trying to connect
+          return ()
+        Connected actualPgVersion -> do
+          -- Procede with initialization
+          AppState.putPgVersion appState actualPgVersion
+          when configDbChannelEnabled $
+            AppState.signalListener appState
+          AppState.logWithZTime appState "Connection successful"
+          -- this could be fail because the connection drops, but the
+          -- loadSchemaCache will pick the error and retry again
+          when configDbConfig $ reReadConfig False appState
+          scStatus <- loadSchemaCache appState
+          case scStatus of
+            SCLoaded ->
+              -- do nothing and proceed if the load was successful
+              return ()
+            SCOnRetry ->
+              work
+            SCFatalFail ->
+              -- die if our schema cache query has an error
+              killThread $ AppState.getMainThreadId appState
+          AppState.putIsWorkerOn appState False
+
+-- | Check if a connection from the pool allows access to the PostgreSQL
+-- database.  If not, the pool connections are released and a new connection is
+-- tried.  Releasing the pool is key for rapid recovery. Otherwise, the pool
+-- timeout would have to be reached for new healthy connections to be acquired.
+-- Which might not happen if the server is busy with requests. No idle
+-- connection, no pool timeout.
+--
+-- The connection tries are capped, but if the connection times out no error is
+-- thrown, just 'False' is returned.
+connectionStatus :: AppState -> IO ConnectionStatus
+connectionStatus appState =
+  retrying retrySettings shouldRetry $
+    const $ SQL.release pool >> getConnectionStatus
+  where
+    pool = AppState.getPool appState
+    retrySettings = capDelay delayMicroseconds $ exponentialBackoff backoffMicroseconds
+    delayMicroseconds = 32000000 -- 32 seconds
+    backoffMicroseconds = 1000000 -- 1 second
+
+    getConnectionStatus :: IO ConnectionStatus
+    getConnectionStatus = do
+      pgVersion <- SQL.use pool queryPgVersion
+      case pgVersion of
+        Left e -> do
+          let err = PgError False e
+          AppState.logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ errorPayload err
+          case checkIsFatal err of
+            Just reason ->
+              return $ FatalConnectionError reason
+            Nothing ->
+              return NotConnected
+        Right version ->
+          if version < minimumPgVersion then
+            return . FatalConnectionError $
+              "Cannot run in this PostgreSQL version, PostgREST needs at least "
+              <> pgvName minimumPgVersion
+          else
+            return . Connected  $ version
+
+    shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool
+    shouldRetry rs isConnSucc = do
+      let
+        delay = fromMaybe 0 (rsPreviousDelay rs) `div` backoffMicroseconds
+        itShould = NotConnected == isConnSucc
+      when itShould . AppState.logWithZTime appState $
+        "Attempting to reconnect to the database in "
+        <> (show delay::Text)
+        <> " seconds..."
+      when itShould $ AppState.putRetryNextIn appState delay
+      return itShould
+
+-- | Load the DbStructure by using a connection from the pool.
+loadSchemaCache :: AppState -> IO SCacheStatus
+loadSchemaCache appState = do
+  AppConfig{..} <- AppState.getConfig appState
+  actualPgVersion <- AppState.getPgVersion appState
+  result <-
+    let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
+    SQL.use (AppState.getPool appState) . transaction SQL.ReadCommitted SQL.Read $
+      queryDbStructure (toList configDbSchemas) configDbExtraSearchPath actualPgVersion configDbPreparedStatements
+  case result of
+    Left e -> do
+      let
+        err = PgError False e
+        putErr = AppState.logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ errorPayload err
+      case checkIsFatal err of
+        Just hint -> do
+          AppState.logWithZTime appState "A fatal error ocurred when loading the schema cache"
+          putErr
+          AppState.logWithZTime appState hint
+          return SCFatalFail
+        Nothing -> do
+          AppState.logWithZTime appState "An error ocurred when loading the schema cache"
+          putErr
+          return SCOnRetry
+
+    Right dbStructure -> do
+      AppState.putDbStructure appState dbStructure
+      when (isJust configDbRootSpec) .
+        AppState.putJsonDbS appState . LBS.toStrict $ JSON.encode dbStructure
+      AppState.logWithZTime appState "Schema cache loaded"
+      return SCLoaded
+
+-- | Starts a dedicated pg connection to LISTEN for notifications.  When a
+-- NOTIFY <db-channel> - with an empty payload - is done, it refills the schema
+-- cache.  It uses the connectionWorker in case the LISTEN connection dies.
+listener :: AppState -> IO ()
+listener appState = do
+  AppConfig{..} <- AppState.getConfig appState
+  let dbChannel = toS configDbChannel
+
+  -- The listener has to wait for a signal from the connectionWorker.
+  -- This is because when the connection to the db is lost, the listener also
+  -- tries to recover the connection, but not with the same pace as the connectionWorker.
+  -- Not waiting makes stderr quickly fill with connection retries messages from the listener.
+  AppState.waitListener appState
+
+  -- forkFinally allows to detect if the thread dies
+  void . flip forkFinally (handleFinally dbChannel) $ do
+    dbOrError <- acquire $ toUtf8 configDbUri
+    case dbOrError of
+      Right db -> do
+        AppState.logWithZTime appState $ "Listening for notifications on the " <> dbChannel <> " channel"
+        SQL.listen db $ SQL.toPgIdentifier dbChannel
+        SQL.waitForNotifications handleNotification db
+      _ ->
+        die $ "Could not listen for notifications on the " <> dbChannel <> " channel"
+  where
+    handleFinally dbChannel _ = do
+      -- if the thread dies, we try to recover
+      AppState.logWithZTime appState $ "Retrying listening for notifications on the " <> dbChannel <> " channel.."
+      -- assume the pool connection was also lost, call the connection worker
+      connectionWorker appState
+      -- retry the listener
+      listener appState
+
+    handleNotification _ msg
+      | BS.null msg            = scLoader -- reload the schema cache
+      | msg == "reload schema" = scLoader -- reload the schema cache
+      | msg == "reload config" = reReadConfig False appState -- reload the config
+      | otherwise              = pure () -- Do nothing if anything else than an empty message is sent
+
+    scLoader =
+      -- It's not necessary to check the loadSchemaCache success
+      -- here. If the connection drops, the thread will die and
+      -- proceed to recover.
+      void $ loadSchemaCache appState
+
+-- | Re-reads the config plus config options from the db
+reReadConfig :: Bool -> AppState -> IO ()
+reReadConfig startingUp appState = do
+  AppConfig{..} <- AppState.getConfig appState
+  dbSettings <-
+    if configDbConfig then do
+      qDbSettings <- queryDbSettings (AppState.getPool appState) configDbPreparedStatements
+      case qDbSettings of
+        Left e -> do
+          let
+            err = PgError False e
+            putErr = AppState.logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ errorPayload err
+          AppState.logWithZTime appState
+            "An error ocurred when trying to query database settings for the config parameters"
+          case checkIsFatal err of
+            Just hint -> do
+              putErr
+              AppState.logWithZTime appState hint
+              killThread (AppState.getMainThreadId appState)
+            Nothing -> do
+              AppState.logWithZTime appState $ show e
+          pure []
+        Right x -> pure x
+    else
+      pure mempty
+  readAppConfig dbSettings configFilePath (Just configDbUri) >>= \case
+    Left err   ->
+      if startingUp then
+        panic err -- die on invalid config if the program is starting up
+      else
+        AppState.logWithZTime appState $ "Failed re-loading config: " <> err
+    Right newConf -> do
+      AppState.putConfig appState newConf
+      if startingUp then
+        pass
+      else
+        AppState.logWithZTime appState "Config re-loaded"