Bump to version v8.0.0

* Removed some entries that were fixes for the nigthly versions, not
stable versions.
* Reference the actual issue number(not the PR number) on some entries
* Remove duplicate entries
* Clarify some entries
* Grouped CLI entries

.circleci/config.yml

@@ -1,92 +1,53 @@
 version: 2
 
-build-distro-bin: &build-distro-bin
-  machine: true
-  steps:
-    - checkout
-    # cannot interpolate env var and use as a cache key so just copy the Dockerfile to another filename
-    - run: cp docker/distro_release/Dockerfile.$CIRCLE_JOB docker/distro_release/Dockerfile
-    - restore_cache:
-        keys:
-        - v1-{{ .Environment.CIRCLE_JOB }}-image-{{ checksum "docker/distro_release/Dockerfile" }}
-    - restore_cache:
-        keys:
-        - v1-{{ .Environment.CIRCLE_JOB }}-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
-    - run:
-        name: load or build docker image
-        command: |
-          if [[ -e ~/image.tar ]]; then
-            docker load -i ~/image.tar
-          else
-            docker build --rm=false -t $CIRCLE_JOB -f docker/distro_release/Dockerfile.$CIRCLE_JOB docker/distro_release/
-            docker save $CIRCLE_JOB > ~/image.tar
-          fi
-    - run:
-        name: build binary
-        command: |
-          docker run -it \
-            -v $HOME/.stack:/root/.stack \
-            -v $(pwd):/source \
-            -v $HOME/bin/:/root/.local/bin/ \
-            $CIRCLE_JOB build --allow-different-user --install-ghc --copy-bins
-          # volumes owned by root if chown is not done the save_cache step fails silently
-          sudo chown -R circleci:circleci ~/.stack .stack-work
-    - run:
-        name: compress binary
-        command: |
-          mkdir -p /tmp/workspace/bin
-          cd /tmp/workspace/bin
-          tar cvJf postgrest-$CIRCLE_TAG-$CIRCLE_JOB.tar.xz -C ~/bin postgrest
-    - persist_to_workspace:
-        root: /tmp/workspace
-        paths:
-          - bin/*
-    - save_cache:
-        paths:
-          - ~/image.tar
-        key: v1-{{ .Environment.CIRCLE_JOB }}-image-{{ checksum "docker/distro_release/Dockerfile" }}
-    - save_cache:
-        paths:
-          - "~/.stack"
-          - ".stack-work"
-        key: v1-{{ .Environment.CIRCLE_JOB }}-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
-
 jobs:
-  build-test-9.4:
+  # Make sure that there are no outstanding linting hints and that
+  # auto-formatting does not result in any changes.
+  style-check:
     docker:
-      - image: circleci/buildpack-deps:trusty
+      - image: nixos/nix:2.3
+    steps:
+      - checkout
+      - run:
+          name: Install linting and styling scripts
+          command: nix-env -f default.nix -iA style
+      - run:
+          name: Run linter
+          command: |
+            # Note: For checking this locally, use `nix-shell --run postgrest-lint`
+            postgrest-lint
+      - run:
+          name: Run style check
+          command: |
+            # 'Note: For checking this locally, use `nix-shell --run postgrest-style`
+            postgrest-style-check
+
+  # Run tests based on stack and docker against the oldest PostgreSQL version
+  # that we support.
+  stack-test:
+    docker:
+      - image: cimg/base:2021.03
         environment:
           - PGHOST=localhost
-      - image: circleci/postgres:9.4.14
+      - image: circleci/postgres:9.5
         environment:
           - POSTGRES_USER=circleci
           - POSTGRES_DB=circleci
+          - POSTGRES_HOST_AUTH_METHOD=trust
     steps:
       - checkout
       - restore_cache:
           keys:
           - v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
-      - run:
-          name: install ncat
-          command: |
-            # utility needed to test socket connection with curl <  7.40
-            sudo apt-get install nmap
       - run:
           name: install stack & dependencies
           command: |
-            curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
+            curl -L https://github.com/commercialhaskell/stack/releases/download/v2.3.1/stack-2.3.1-linux-x86_64.tar.gz | tar zx -C /tmp
-            sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
+            sudo mv /tmp/stack-2.3.1-linux-x86_64/stack /usr/bin
             sudo apt-get update
-            sudo apt-get install -y libgmp-dev
+            sudo apt-get install -y libgmp-dev postgresql-client
             sudo apt-get install -y --only-upgrade binutils
-            sudo apt-get install -y postgresql-client
             stack setup
-            rm -rf $(stack path --dist-dir) $(stack path --local-install-root)
-            stack install hlint stylish-haskell
-      - run:
-          name: Add stack tools to $PATH
-          command: |
-            echo "export PATH=/home/circleci/.local/bin:$PATH" >> $BASH_ENV
       - run:
           name: build src and tests dependencies
           command: |
@@ -103,262 +64,213 @@ jobs:
             stack build --fast -j1
             stack build --fast --test --no-run-tests
       - run:
-          name: run tests
+          name: run spec tests
           command: |
-            POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://circleci@localhost" postgrest_test) stack test
+            test/create_test_db "postgres://circleci@localhost" postgrest_test stack test
-            test/io-tests.sh
+      - store_artifacts:
-      - run:
+          path: /tmp/postgrest
-          name: run linter
-          command: make lint
-      - run:
-          name: run styler
-          command: make style
-
-  build-test-9.6:
-    docker:
-      - image: circleci/buildpack-deps:trusty
-        environment:
-          - PGHOST=localhost
-      - image: circleci/postgres:9.6.2
-        environment:
-          - POSTGRES_USER=circleci
-          - POSTGRES_DB=circleci
-    steps:
-      - checkout
-      - restore_cache:
-          keys:
-          - v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
-      - run:
-          name: install stack & dependencies
-          command: |
-            curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
-            sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
-            sudo apt-get update
-            sudo apt-get install -y libgmp-dev
-            sudo apt-get install -y postgresql-client
-            stack setup
-      - run:
-          name: build src and tests
-          command: |
-            stack build --fast -j1
-            stack build --fast --test --no-run-tests
-      - run:
-          name: run tests
-          command: POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://circleci@localhost" postgrest_test) stack test postgrest:spec
-
-  build-test-10:
-    docker:
-      - image: circleci/buildpack-deps:trusty
-        environment:
-          - PGHOST=localhost
-      - image: circleci/postgres:10.5
-        environment:
-          - POSTGRES_USER=circleci
-          - POSTGRES_DB=circleci
-    steps:
-      - checkout
-      - restore_cache:
-          keys:
-          - v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
-      - run:
-          name: install stack & dependencies
-          command: |
-            curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
-            sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
-            sudo apt-get update
-            sudo apt-get install -y libgmp-dev
-            sudo apt-get install -y postgresql-client
-            stack setup
-      - run:
-          name: build src and tests
-          command: |
-            stack build --fast -j1
-            stack build --fast --test --no-run-tests
-      - run:
-          name: run tests
-          command: POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://circleci@localhost" postgrest_test) stack test postgrest:spec
-
-  build-test-11:
-    docker:
-      - image: circleci/buildpack-deps:trusty
-        environment:
-          - PGHOST=localhost
-      - image: circleci/postgres:11.4
-        environment:
-          - POSTGRES_USER=circleci
-          - POSTGRES_DB=circleci
-    steps:
-      - checkout
-      - restore_cache:
-          keys:
-          - v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
-      - run:
-          name: install stack & dependencies
-          command: |
-            curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
-            sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
-            sudo apt-get update
-            sudo apt-get install -y libgmp-dev
-            sudo apt-get install -y postgresql-client
-            stack setup
-      - run:
-          name: build src and tests
-          command: |
-            stack build --fast -j1
-            stack build --fast --test --no-run-tests
-      - run:
-          name: run tests
-          command: POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://circleci@localhost" postgrest_test) stack test postgrest:spec
-
-  build-prof-test:
-    docker:
-      - image: circleci/buildpack-deps:trusty
-        environment:
-          - PGHOST=localhost
-          - TERM=xterm
-      - image: circleci/postgres:9.6.2
-        environment:
-          - POSTGRES_USER=circleci
-          - POSTGRES_DB=circleci
-    steps:
-      - checkout
-      - restore_cache:
-          keys:
-          - v1-stack-prof-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
-      - run:
-          name: install stack & dependencies
-          command: |
-            curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar zx -C /tmp
-            sudo mv /tmp/stack-2.1.3-linux-x86_64/stack /usr/bin
-            sudo apt-get update
-            sudo apt-get install -y libgmp-dev
-            sudo apt-get install -y postgresql-client
-            stack setup
-      - run:
-          name: build dependencies with profiling enabled
-          command: |
-            stack build --profile -j1  --only-dependencies
-      - save_cache:
-          paths:
-            - "~/.stack"
-            - ".stack-work"
-          key: v1-stack-prof-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
-      - run:
-          name: build with profiling enabled
-          command: |
-            stack build --profile -j1
-      - run:
-          name: run memory usage tests
-          command: |
-            test/create_test_db "postgres://circleci@localhost" postgrest_test
-            psql "postgres:///postgrest_test" -f test/fixtures/database.sql
-            psql "postgres:///postgrest_test" -f test/fixtures/roles.sql
-            psql "postgres:///postgrest_test" -f test/fixtures/schema.sql
-            psql "postgres:///postgrest_test" -f test/fixtures/jwt.sql
-            psql "postgres:///postgrest_test" -f test/fixtures/jsonschema.sql
-            psql "postgres:///postgrest_test" -f test/fixtures/privileges.sql
-            test/memory-tests.sh
-
-  centos7:
-    <<: *build-distro-bin
-
-  ubuntu:
-    <<: *build-distro-bin
-
-  ubuntui386:
-    <<: *build-distro-bin
 
+  # Publish a new release. This only runs when a release is tagged (see
+  # workflow below).
   release:
-    docker:
+    machine: true
-      - image: circleci/golang:1.9
     steps:
-      - attach_workspace:
-          at: /tmp/workspace
       - checkout
       - run:
-          name: add body and tars to github release
+          name: Install Nix
           command: |
-            go get -u github.com/tcnksm/ghr
+            curl -L https://nixos.org/nix/install | sh
-            START=$(echo $CIRCLE_TAG | cut -c2-)
+            echo "source $HOME/.nix-profile/etc/profile.d/nix.sh" >> $BASH_ENV
-            END='## \['
-            BODY=$(sed -n "1,/$START/d;/$END/q;p" CHANGELOG.md)
-            ghr -t $GITHUB_TOKEN -u $CIRCLE_PROJECT_USERNAME -r $CIRCLE_PROJECT_REPONAME -b "$BODY" --replace $CIRCLE_TAG /tmp/workspace/bin
-      - setup_remote_docker
       - run:
-          name: publish docker image
+          name: Change postgrest.cabal if nightly
           command: |
-            docker build --build-arg POSTGREST_VERSION=$CIRCLE_TAG -t postgrest ./docker/
+            if test "$CIRCLE_TAG" = "nightly"
-            docker login -u $DOCKER_USER -p $DOCKER_PASS
+            then
-            docker tag postgrest postgrest/postgrest:$CIRCLE_TAG
+              cabal_nightly_version=$(git show -s --format='%cd' --date='format:%Y%m%d')
-            docker push postgrest/postgrest:$CIRCLE_TAG
+              sed -i "s/^version:.*/version:$cabal_nightly_version/" postgrest.cabal
-            docker tag postgrest postgrest/postgrest:latest
+            fi
-            docker push postgrest/postgrest:latest
+      - run:
+          name: Install and use the Cachix binary cache
+          command: |
+            nix-env -iA cachix -f https://cachix.org/api/v1/install
+            cachix use postgrest
+      - run:
+          name: Install release scripts
+          command: nix-env -f default.nix -iA release
+      - run:
+          name: Publish GitHub release
+          command: |
+            export GITHUB_USERNAME="$CIRCLE_PROJECT_USERNAME"
+            export GITHUB_REPONAME="$CIRCLE_PROJECT_REPONAME"
+            postgrest-release-github $CIRCLE_TAG
+      - run:
+          name: Publish Docker images
+          command: |
+            export DOCKER_REPO=postgrest
+            postgrest-release-docker-login
+            postgrest-release-dockerhub $CIRCLE_TAG
+            if test "$CIRCLE_TAG" != "nightly"
+            then
+              postgrest-release-dockerhub-description
+            fi
+      - store_artifacts:
+          path: /tmp/postgrest
+
+  # Build everything in default.nix and push to the Cachix binary cache if running on main
+  nix-build:
+    machine: true
+    steps:
+      - checkout
+      - run:
+          name: Install Nix
+          command: |
+            curl -L https://nixos.org/nix/install | sh
+            echo "source $HOME/.nix-profile/etc/profile.d/nix.sh" >> $BASH_ENV
+      - run:
+          name: Install and use the Cachix binary cache
+          command: |
+            nix-env -iA cachix -f https://cachix.org/api/v1/install
+            cachix use postgrest
+      - run:
+          name: Change postgrest.cabal if nightly
+          command: |
+            if test "$CIRCLE_TAG" = "nightly"
+            then
+              cabal_nightly_version=$(git show -s --format='%cd' --date='format:%Y%m%d')
+              sed -i "s/^version:.*/version:$cabal_nightly_version/" postgrest.cabal
+            fi
+      - run:
+          name: Build all derivations from default.nix and push results to Cachix
+          command: |
+            # Only push to the cache when CircleCI makes the CACHIX_SIGNING_KEY
+            # available (e.g. not for pull requests).
+            if [ -n "${CACHIX_AUTH_TOKEN:-""}" ]; then
+              echo "Building and caching all derivations..."
+              cachix authtoken "$CACHIX_AUTH_TOKEN"
+
+              # Push new builds as we go
+              nix-build | cachix push postgrest
+
+              # Make sure that everything, including .drv files, is pushed
+              nix-env -f default.nix -iA devTools
+              postgrest-push-cachix
+            else
+              echo "Building all derivations (caching skipped for outside pull requests)..."
+              nix-build
+            fi
+      - store_artifacts:
+          path: /tmp/postgrest
+
+  # Run tests
+  nix-test:
+    machine: true
+    steps:
+      - checkout
+      - run:
+          name: Install Nix
+          command: |
+            curl -L https://nixos.org/nix/install | sh
+            echo "source $HOME/.nix-profile/etc/profile.d/nix.sh" >> $BASH_ENV
+      - run:
+          name: Install and use the Cachix binary cache
+          command: |
+            nix-env -iA cachix -f https://cachix.org/api/v1/install
+            cachix use postgrest
+      - run:
+          name: Install testing scripts
+          command: nix-env -f default.nix -iA tests memory withTools
+      - run:
+          name: Run coverage (io tests and spec tests against PostgreSQL 13)
+          command: postgrest-coverage
+          when: always
+      - run:
+          name: Skip tests on build or primary test failure
+          command: circleci-agent step halt
+          when: on_fail
+      - run:
+          name: Upload coverage to codecov
+          command: |
+            # Modified from:
+            # https://docs.codecov.io/docs/about-the-codecov-bash-uploader#validating-the-bash-script
+            curl -s https://codecov.io/bash > codecov;
+            VERSION=$(grep 'VERSION=\".*\"' codecov | cut -d'"' -f2);
+            shasum -a 512 -c <(curl -s https://raw.githubusercontent.com/codecov/codecov-bash/${VERSION}/SHA512SUM | grep codecov)
+            bash codecov -f coverage/codecov.json
+      - run:
+          name: Run the spec tests against PostgreSQL 12
+          command: postgrest-with-postgresql-12 postgrest-test-spec
+          when: always
+      - run:
+          name: Run the spec tests against PostgreSQL 11
+          command: postgrest-with-postgresql-11 postgrest-test-spec
+          when: always
+      - run:
+          name: Run the spec tests against PostgreSQL 10
+          command: postgrest-with-postgresql-10 postgrest-test-spec
+          when: always
+      - run:
+          name: Run the spec tests against PostgreSQL 9.6
+          command: postgrest-with-postgresql-9.6 postgrest-test-spec
+          when: always
+      - run:
+          name: Run the spec tests against PostgreSQL 9.5
+          command: postgrest-with-postgresql-9.5 postgrest-test-spec
+          when: always
+      - run:
+          name: Check the spec tests for idempotence
+          command: postgrest-test-spec-idempotence
+          when: always
+      - run:
+          name: Run memory tests
+          command: postgrest-test-memory
+          when: always
+      - store_artifacts:
+          path: /tmp/postgrest
 
 workflows:
   version: 2
   build-test-release:
     jobs:
-      - build-test-9.4:
+      - style-check:
+          # Make sure that this job also runs when releases are tagged.
           filters:
             tags:
-              only: /v[0-9]+(\.[0-9]+)*/
+              only:
-      - build-test-9.6:
+                - /v[0-9]+(\.[0-9]+)*/
+                - nightly
+      - stack-test:
           filters:
             tags:
-              only: /v[0-9]+(\.[0-9]+)*/
+              only:
-      - build-test-10:
+                - /v[0-9]+(\.[0-9]+)*/
+                - nightly
+      - nix-build:
           filters:
             tags:
-              only: /v[0-9]+(\.[0-9]+)*/
+              only:
-      - build-test-11:
+                - /v[0-9]+(\.[0-9]+)*/
+                - nightly
+          context:
+            - cachix
+      - nix-test:
           filters:
             tags:
-              only: /v[0-9]+(\.[0-9]+)*/
+              only:
-      - build-prof-test:
+                - /v[0-9]+(\.[0-9]+)*/
-          filters:
+                - nightly
-            tags:
-              only: /v[0-9]+(\.[0-9]+)*/
-      - centos7:
-          requires:
-            - build-test-9.4
-            - build-test-9.6
-            - build-test-10
-            - build-test-11
-            - build-prof-test
-          filters:
-            tags:
-              only: /v[0-9]+(\.[0-9]+)*/
-            branches:
-              ignore: /.*/
-      - ubuntu:
-          requires:
-            - build-test-9.4
-            - build-test-9.6
-            - build-test-10
-            - build-test-11
-            - build-prof-test
-          filters:
-            tags:
-              only: /v[0-9]+(\.[0-9]+)*/
-            branches:
-              ignore: /.*/
-      - ubuntui386:
-          requires:
-            - build-test-9.4
-            - build-test-9.6
-            - build-test-10
-            - build-test-11
-            - build-prof-test
-          filters:
-            tags:
-              only: /v[0-9]+(\.[0-9]+)*/
-            branches:
-              ignore: /.*/
       - release:
           requires:
-            - centos7
+            - style-check
-            - ubuntu
+            - stack-test
-            - ubuntui386
+            - nix-build
+            - nix-test
           filters:
             tags:
-              only: /v[0-9]+(\.[0-9]+)*/
+              only:
+                - /v[0-9]+(\.[0-9]+)*/
+                - nightly
+            branches:
+              ignore: /.*/
+          context:
+            - docker
+            - github

.cirrus.yml

@@ -0,0 +1,71 @@
+freebsd_instance:
+  image: freebsd-12-2-release-amd64
+
+build_task:
+  env:
+    GITHUB_TOKEN: ENCRYPTED[!1ecc3020fe8c6463c06ebc22153533239e132ee56e4faad95ce336bd2ee2bde6aa89c0352e89faaa2c10f4a5bac9b7fc!]
+  # caches the freebsd package downloads
+  # saves probably just a couple of seconds, but hey...
+  pkg_cache:
+    folder: /var/cache/pkg
+
+  install_script:
+  #  - pkg update
+    - pkg install -y postgresql12-client ghc hs-cabal-install jq git
+
+  # cache the hackage index file and downloads which are
+  # cabal v2-update downloads an incremental update, so we don't need to keep this up2date
+  packages_cache:
+    # warning: don't use ~/.cabal here, this will break the cache
+    folder: /.cabal/packages
+    reupload_on_changes: false
+
+  # cache the dependencies built by cabal
+  # they have to be uploaded on every change to make the next build fast
+  store_cache:
+    # warning: don't use ~/.cabal here, this will break the cache
+    folder: /.cabal/store
+    fingerprint_script: cat postgrest.cabal
+    reupload_on_changes: true
+
+  build_script:
+    - cabal v2-update
+    - |
+      if test "$CIRRUS_TAG" = "nightly"
+      then
+        cabal_nightly_version=$(git show -s --format='%cd' --date='format:%Y%m%d')
+        sed -i '' "s/^version:.*/version:$cabal_nightly_version/" postgrest.cabal
+      fi
+      ## compile for 30 minutes tops
+    - timeout 1800 cabal v2-build -j1 || test "$?" = "124"
+
+  publish_script:
+    - |
+      if test ! "$CIRRUS_TAG"
+      then
+        echo 'No tag pushed. Skip release.'
+      else
+        cabal v2-install
+
+        bin_name=""
+
+        if test $CIRRUS_TAG = "nightly"
+        then
+          suffix=$(git show -s --format="%cd-%h" --date="format:%Y-%m-%d-%H-%M")
+          bin_name=postgrest-nightly-$suffix-freebsd.tar.xz
+        else
+          bin_name=postgrest-$CIRRUS_TAG-freebsd.tar.xz
+        fi
+
+        release_id=$(curl -s https://api.github.com/repos/$CIRRUS_REPO_FULL_NAME/releases/tags/$CIRRUS_TAG | jq .id)
+
+        echo "Uploading $bin_name to gh release: $release_id"
+
+        tar cvJf $bin_name --dereference -C /.cabal/bin postgrest
+
+        ## We don't use ghr here because it doesn't provide freebsd binaries: https://github.com/tcnksm/ghr/issues/127
+        curl -X POST --data-binary @$bin_name \
+          -H "Authorization:token $GITHUB_TOKEN" \
+          -H "Content-Type:application/octet-stream" \
+          "https://uploads.github.com/repos/$CIRRUS_REPO_FULL_NAME/releases/$release_id/assets?name=$bin_name"
+      fi

.codecov.yml

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

.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
+* Make sure you test against the latest [stable release](https://github.com/PostgREST/postgrest/releases/latest)
-  we already fixed the bug you're experiencing.
+  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.
-* 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.
 
 * Provide steps to reproduce the issue, including your OS version and
   the specific database schema that you are using.
@@ -32,11 +32,14 @@ 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 `SIGUSR1` signal](http://postgrest.org/en/v5.2/admin.html#schema-reloading) 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
@@ -44,14 +47,9 @@ your contributions.
 
 * 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's a useful Makefile that helps with checking this locally. You can run `make commit-check` to do this manually but
+  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` to automatically check this before doing a commit.
+  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) docs section.
 
 ### Running Tests
 
-For instructions on running tests, see the official docs hosted here:
+For instructions on running tests, see the [development docs](https://github.com/PostgREST/postgrest/blob/main/nix/README.md#testing).
-
-https://postgrest.com/en/stable/install.html#postgrest-test-suite

.github/ISSUE_TEMPLATE.md

@@ -1,6 +1,8 @@
 <!--
 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/v5.2/admin.html#schema-reloading) to ensure the schema cache is not stale. This sometimes fixes apparent bugs.
+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
 

.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
+-->

.gitignore

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

.travis.yml

@@ -1,70 +1,80 @@
-## Travis is only used for building an OSX binary ,
-## no tests are run here.
 language: generic
 
 sudo: false
 
-os:
+jobs:
-- osx
+  include:
-
+    - name: Build OSX Binary
-cache:
+      os: osx
-  timeout: 1000
+      cache:
-  directories:
+        timeout: 1000
-    - $HOME/.stack
+        directories:
-    - $HOME/.local/bin
+          - $HOME/.stack
-
+          - $HOME/.local/bin
-before_install:
+      before_install:
-- mkdir -p "$HOME/.local/bin"
+        - mkdir -p "$HOME/.local/bin"
-- export PATH="$PATH:$HOME/.local/bin"
+        - export PATH="$PATH:$HOME/.local/bin"
-
+      install:
-install:
+        - |
-- |
+          if test -f "$HOME/.local/bin/stack"
-  if test -f "$HOME/.local/bin/stack"
+            then
-    then
+              echo 'Stack is already installed.'
-      echo 'Stack is already installed.'
+            else
-    else
+              echo "Installing Stack..."
-      echo "Installing Stack..."
+              travis_retry curl -L https://www.stackage.org/stack/osx-x86_64 > stack.tar.gz
-      travis_retry curl -L https://www.stackage.org/stack/osx-x86_64 > stack.tar.gz
+              gunzip stack.tar.gz
-      gunzip stack.tar.gz
+              tar -x -f stack.tar --strip-components 1
-      tar -x -f stack.tar --strip-components 1
+              mv stack "$HOME/.local/bin/"
-      mv stack "$HOME/.local/bin/"
+              rm stack.tar
-      rm stack.tar
+          fi
-  fi
+        - |
-- |
+          if test -f "$HOME/.local/bin/ghr"
-  if test -f "$HOME/.local/bin/ghr"
+          then
-  then
+            echo 'ghr is already installed.'
-    echo 'ghr is already installed.'
+          else
-  else
+            echo "Installing ghr..."
-    echo "Installing ghr..."
+            travis_retry curl -L https://github.com/tcnksm/ghr/releases/download/v0.5.4/ghr_v0.5.4_darwin_386.zip > ghr.zip
-    travis_retry curl -L https://github.com/tcnksm/ghr/releases/download/v0.5.4/ghr_v0.5.4_darwin_386.zip > ghr.zip
+            unzip ghr.zip -d "$HOME/.local/bin"
-    unzip ghr.zip -d "$HOME/.local/bin"
+            rm ghr.zip
-    rm ghr.zip
+          fi
-  fi
+      script:
-
+        - |
-script:
+          if test "$TRAVIS_TAG" = "nightly"
-## Building the whole project can take longer than 50 minutes. Since Travis has a global timeout of 50 minutes
+          then
-## we compile for 30 minutes tops(`gtimeout 1800`) and quit compiling with no error.
+            cabal_nightly_version=$(git show -s --format='%cd' --date='format:%Y%m%d')
-## Since we CACHE the compile results we can continue compiling from where we left off
+            sed -i '' "s/^version:.*/version:$cabal_nightly_version/" postgrest.cabal
-## on the next commit.
+          fi
-- gtimeout 1800 stack build --no-terminal --only-snapshot --install-ghc || true
+        ## Building the whole project can take longer than 50 minutes. Since Travis has a global timeout of 50 minutes
-- |
+        ## we compile for 30 minutes tops(`gtimeout 1800`) and quit compiling with no error.
-  if test ! "$TRAVIS_TAG"
+        ## Since we CACHE the compile results we can continue compiling from where we left off
-  then
+        ## on the next commit.
-    echo 'No tag pushed. Skip building binary.'
+        - gtimeout 1800 stack build --no-terminal --only-snapshot --install-ghc || (($?==124))
-  else
+        - |
-    stack build --no-terminal --copy-bins --local-bin-path .
+          if test ! "$TRAVIS_TAG"
-  fi
+          then
-- |
+            echo 'No tag pushed. Skip building binary.'
-  if test ! "$TRAVIS_TAG"
+          else
-  then
+            stack build --no-terminal --copy-bins --local-bin-path .
-    echo 'No tag pushed. Skipping release.'
+          fi
-  else
+        - |
-    OWNER="$(echo "$TRAVIS_REPO_SLUG" | cut -f1 -d/)"
+          if test ! "$TRAVIS_TAG"
-    REPO="$(echo "$TRAVIS_REPO_SLUG" | cut -f2 -d/)"
+          then
-    START=$(echo $TRAVIS_TAG | cut -c2-)
+            echo 'No tag pushed. Skipping release.'
-    END='## \['
+          else
-    BODY=$(sed -n "1,/$START/d;/$END/q;p" CHANGELOG.md)
+            owner="$(echo "$TRAVIS_REPO_SLUG" | cut -f1 -d/)"
-    strip postgrest
+            repo="$(echo "$TRAVIS_REPO_SLUG" | cut -f2 -d/)"
-    tar cJf postgrest-$TRAVIS_TAG-osx.tar.xz postgrest
+            if test $TRAVIS_TAG = "nightly"
-    ghr -t $GITHUB_TOKEN -u $OWNER -r $REPO -b "$BODY"--replace $TRAVIS_TAG postgrest-$TRAVIS_TAG-osx.tar.xz
+            then
-  fi
+              suffix=$(git show -s --format="%cd-%h" --date="format:%Y-%m-%d-%H-%M")
+              strip postgrest
+              tar cJf postgrest-nightly-$suffix-osx.tar.xz postgrest
+              ghr -t $GITHUB_TOKEN -u $owner -r $repo --replace nightly postgrest-nightly-$suffix-osx.tar.xz
+            else
+              start=$TRAVIS_TAG
+              end='## \['
+              body=$(sed -n "1,/$start/d;/$end/q;p" CHANGELOG.md)
+              strip postgrest
+              tar cJf postgrest-$TRAVIS_TAG-osx.tar.xz postgrest
+              ghr -t $GITHUB_TOKEN -u $owner -r $repo -b "$body"--replace $TRAVIS_TAG postgrest-$TRAVIS_TAG-osx.tar.xz
+            fi
+          fi

BACKERS.md

@@ -8,18 +8,36 @@ PostgREST ongoing development is only possible thanks to our Sponsors and Backer
   <tbody>
     <tr>
       <td align="center" valign="middle">
-        <a href="https://www.cybertec-postgresql.com/en/" target="_blank">
+        <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.png">
+          <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="222px" src="static/2ndquadrant.png">
+          <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="222px" src="static/retool.png">
+          <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>
@@ -28,8 +46,9 @@ PostgREST ongoing development is only possible thanks to our Sponsors and Backer
 
 ## Lead Backers
 
-- [Daniel Babiak](https://github.com/d-babiak)
 - Evans Fernandes
+- [Jan Sommer](https://github.com/nerfpops)
+- [Franz Gusenbauer](https://www.igutech.at/)
 
 ## Backers
 
@@ -37,12 +56,15 @@ PostgREST ongoing development is only possible thanks to our Sponsors and Backer
 - Michel Pelletier
 - Jay Hannah
 - Robert Stolarz
-- Kofi Gumbs
 - Nicholas DiBiase
 - Christopher Reid
 - Nathan Bouscal
 - Daniel Rafaj
 - David Fenko
+- Remo Rechkemmer
+- Severin Ibarluzea
+- Tom Saleeba
+- Pawel Tyll
 
 ## Former Backers
 
@@ -59,3 +81,5 @@ PostgREST ongoing development is only possible thanks to our Sponsors and Backer
 </table>
 
 - [Christiaan Westerbeek](https://devotis.nl)
+- [Daniel Babiak](https://github.com/dbabiak)
+- Kofi Gumbs

CHANGELOG.md

@@ -9,6 +9,80 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ### Fixed
 
+## [8.0.0] - 2021-07-25
+
+### Added
+
+ - #1525, Allow http status override through response.status guc - @steve-chavez
+ - #1512, Allow schema cache reloading with NOTIFY - @steve-chavez
+ - #1119, Allow config file reloading with SIGUSR2 - @steve-chavez
+ - #1558, Allow 'Bearer' with and without capitalization as authentication schema - @wolfgangwalther
+ - #1470, Allow calling RPC with variadic argument by passing repeated params - @wolfgangwalther
+ - #1559, No downtime when reloading the schema cache with SIGUSR1 - @steve-chavez
+ - #504, Add `log-level` config option. The admitted levels are: crit, error, warn and info - @steve-chavez
+ - #1607, Enable embedding through multiple views recursively - @wolfgangwalther
+ - #1598, Allow rollback of the transaction with Prefer tx=rollback - @wolfgangwalther
+ - #1633, Enable prepared statements for GET filters. When behind a connection pooler, you can disable preparing with `db-prepared-statements=false`
+   + This increases throughput by around 30% for simple GET queries(no embedding, with filters applied).
+ - #1729, #1760, Get configuration parameters from the db and allow reloading config with NOTIFY  - @steve-chavez
+ - #1824, Allow OPTIONS to generate certain HTTP methods for a DB view - @laurenceisla
+ - #1872, Show timestamps in startup/worker logs - @steve-chavez
+ - #1881, Add `openapi-mode` config option that allows ignoring roles privileges when showing the OpenAPI output - @steve-chavez
+ - CLI options(for debugging):
+   + #1678, Add --dump-config CLI option that prints loaded config and exits - @wolfgangwalther
+   + #1691, Add --example CLI option to show example config file - @wolfgangwalther
+   + #1697, #1723, Add --dump-schema CLI option for debugging purposes - @monacoremo, @wolfgangwalther
+ - #1794, (Experimental) Add `request.spec` GUC for db-root-spec - @steve-chavez
+
+### Fixed
+
+ - #1592, Removed single column restriction to allow composite foreign keys in join tables - @goteguru
+ - #1530, Fix how the PostgREST version is shown in the help text when the `.git` directory is not available - @monacoremo
+ - #1094, Fix expired JWTs starting an empty transaction on the db - @steve-chavez
+ - #1162, Fix location header for POST request with select= without PK - @wolfgangwalther
+ - #1585, Fix error messages on connection failure for localized postgres on Windows - @wolfgangwalther
+ - #1636, Fix `application/octet-stream` appending `charset=utf-8` - @steve-chavez
+ - #1469, #1638 Fix overloading of functions with unnamed arguments - @wolfgangwalther
+ - #1560, Return 405 Method not Allowed for GET of volatile RPC instead of 500 - @wolfgangwalther
+ - #1584, Fix RPC return type handling and embedding for domains with composite base type (#1615) - @wolfgangwalther
+ - #1608, #1635, Fix embedding through views that have COALESCE with subselect - @wolfgangwalther
+ - #1572, Fix parsing of boolean config values for Docker environment variables, now it accepts double quoted truth values ("true", "false") and numbers("1", "0") - @wolfgangwalther
+ - #1624, Fix using `app.settings.xxx` config options in Docker, now they can be used as `PGRST_APP_SETTINGS_xxx` - @wolfgangwalther
+ - #1814, Fix panic when attempting to run with unix socket on non-unix host and properly close unix domain socket on exit - @monacoremo
+ - #1825, Disregard internal junction(in non-exposed schema) when embedding - @steve-chavez
+ - #1846, Fix requests for overloaded functions from html forms to no longer hang (#1848) - @laurenceisla
+ - #1858, Add a hint and clarification to the no relationship found error - @laurenceisla
+ - #1841, Show comprehensive error when an RPC is not found in a stale schema cache - @laurenceisla
+ - #1875, Fix Location headers in headers only representation for null PK inserts on views - @laurenceisla
+
+### Changed
+
+ - #1522, #1528, #1535, Docker images are now built from scratch based on a the static PostgREST executable (#1494) and with Nix instead of a `Dockerfile`. This reduces the compressed image size from over 30mb to about 4mb - @monacoremo
+ - #1461, Location header for POST request is only included when PK is available on the table - @wolfgangwalther
+ - #1560, Volatile RPC called with GET now returns 405 Method not Allowed instead of 500 - @wolfgangwalther
+ - #1584, #1849 Functions that declare `returns composite_type` no longer return a single object array by default, only functions with `returns setof composite_type` return an array of objects - @wolfgangwalther
+ - #1604, Change the default logging level to `log-level=error`. Only requests with a status greater or equal than 500 will be logged. If you wish to go back to the previous behaviour and log all the requests, use `log-level=info` - @steve-chavez
+   + Because currently there's no buffering for logging, defaulting to the `error` level(minimum logging) increases throughput by around 15% for simple GET queries(no embedding, with filters applied).
+ - #1617, Dropped support for PostgreSQL 9.4 - @wolfgangwalther
+ - #1679, Renamed config settings with fallback aliases. e.g. `max-rows` is now `db-max-rows`, but `max-rows` is still accepted - @wolfgangwalther
+ - #1656, Allow `Prefer=headers-only` on POST requests and change default to `minimal` (#1813) - @laurenceisla
+ - #1854, Dropped undocumented support for gzip compression (which was surprisingly slow and easily enabled by mistake). In some use-cases this makes Postgres up to 3x faster - @aljungberg
+ - #1872, Send startup/worker logs to stderr to differentiate from access logs on stdout - @steve-chavez
+
+## [7.0.1] - 2020-05-18
+
+### Fixed
+
+- #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

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

Makefile

@@ -1,39 +0,0 @@
-.PHONY: commit-check check clean lint style test test-watch coverage circleci circleci-prof-test check-dburi prompt-clean prompt-long-process
-
-commit-check: lint style
-
-check: lint style test
-
-clean: prompt-clean
-	stack clean --full
-
-lint:
-	git ls-files | grep '\.l\?hs$$' | xargs stack exec -- hlint -X QuasiQuotes -X NoPatternSynonyms "$$@"
-
-style:
-	git ls-files | grep '\.l\?hs$$' | xargs stack exec -- stylish-haskell -i && git diff-index --exit-code HEAD -- '*.hs' '*.lhs'
-
-test: check-dburi
-	stack test
-
-test-watch: check-dburi
-	stack build --file-watch --test --test-arguments '--rerun --failure-report=.TESTREPORT --rerun-all-on-success'
-
-coverage: check-dburi clean
-	stack build --coverage
-	stack test --coverage
-
-circleci: prompt-long-process
-	circleci local execute --job build-test-9.4
-
-circleci-prof-test: prompt-long-process
-	circleci local execute --job build-prof-test
-
-check-dburi:
-	test -n "$(POSTGREST_TEST_CONNECTION)" # Requires POSTGREST_TEST_CONNECTION environmental variable
-
-prompt-clean:
-	@echo -n 'Are you sure? You will have to rebuild. [y/N] ' && read ans && [ $${ans:-N} = y ]
-
-prompt-long-process:
-	@echo -n 'Are you sure? This might take a while. [y/N] ' && read ans && [ $${ans:-N} = y ]

README.md

@@ -8,7 +8,8 @@
 [![Join the chat at https://gitter.im/begriffs/postgrest](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%92-brightgreen.svg)](https://gitter.im/begriffs/postgrest)
 [![Docs](https://img.shields.io/badge/docs-latest-brightgreen.svg?style=flat)](http://postgrest.org)
 [![Docker Stars](https://img.shields.io/docker/pulls/postgrest/postgrest.svg)](https://hub.docker.com/r/postgrest/postgrest/)
-[![Build Status](https://circleci.com/gh/PostgREST/postgrest/tree/master.svg?style=shield)](https://circleci.com/gh/PostgREST/postgrest/tree/master)
+[![Build Status](https://circleci.com/gh/PostgREST/postgrest/tree/main.svg?style=shield)](https://circleci.com/gh/PostgREST/postgrest/tree/main)
+[![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
@@ -21,18 +22,36 @@ API than you are likely to write from scratch.
   <tbody>
     <tr>
       <td align="center" valign="middle">
-        <a href="https://www.cybertec-postgresql.com/en/" target="_blank">
+        <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.png">
+          <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="222px" src="static/2ndquadrant.png">
+          <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="222px" src="static/retool.png">
+          <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>
@@ -93,7 +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
+Since 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
@@ -150,8 +169,8 @@ Every donation will be spent on making PostgREST better for the whole community.
 
 The PostgREST organization is grateful to:
 
-- The project [sponsors and backers](https://github.com/PostgREST/postgrest/blob/master/BACKERS.md) who support PostgREST's development.
+- 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/master/CHANGELOG.md).
+  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

@@ -10,7 +10,7 @@
     },
     "POSTGREST_VER": {
       "description": "Version of PostgREST to deploy",
-      "value": "7.0.0"
+      "value": "8.0.0"
     },
     "DB_URI": {
       "description": "Database connection string, e.g. postgres://user:pass@xxxxxxx.rds.amazonaws.com/mydb",

appveyor.yml

@@ -1,5 +1,6 @@
 ## AppVeyor is only used for building a Windows binary, no tests are run here.
 platform: x64
+image: Visual Studio 2015
 
 cache:
 - "c:\\sr"
@@ -22,14 +23,25 @@ install:
 - go get -u github.com/tcnksm/ghr
 
 build_script:
+- ps: $env:cabal_nightly_version=(git show -s --format='%cd' --date='format:%Y%m%d')
+- IF "%APPVEYOR_REPO_TAG_NAME%"=="nightly" bash -lc "sed -i -r \"s/^(version:\s+)\S+$/\1$cabal_nightly_version/\" postgrest.cabal"
 - stack setup --no-terminal > nul
 # Appveyor has a timeout of 60 mins, building can take longer, limit the time and make sure this succeeds,
 # previous work will get cached and finish on next commit
-- bash -lc "timeout 2700 'C:\projects\postgrest\stack.exe' build -j1 --copy-bins --local-bin-path . || true"
+- bash -lc "timeout 2700 'C:\projects\postgrest\stack.exe' build -j1 --copy-bins --local-bin-path . || (($?==124))"
 
 artifacts:
 - path: postgrest.exe
 
 deploy_script:
-- IF DEFINED APPVEYOR_REPO_TAG_NAME 7z a -tzip postgrest-%APPVEYOR_REPO_TAG_NAME%-windows-x64.zip postgrest.exe
+## Use powershell(ps) for this because CMD commands having "%" don't work(even by escaping with "%%"). See https://github.com/appveyor/ci/issues/246.
-- IF DEFINED APPVEYOR_REPO_TAG_NAME bash -lc " exec 0</dev/null && cd $APPVEYOR_BUILD_FOLDER && ghr -t $GITHUB_TOKEN -u $APPVEYOR_ACCOUNT_NAME -r $APPVEYOR_PROJECT_NAME -b \"$(sed -n \"1,/$(echo $APPVEYOR_REPO_TAG_NAME | cut -c2-)/d;/## \[/q;p\" CHANGELOG.md)\" --replace $APPVEYOR_REPO_TAG_NAME postgrest-$APPVEYOR_REPO_TAG_NAME-windows-x64.zip"
+- ps: $env:suffix=(git show -s --format="%cd-%h" --date="format:%Y-%m-%d-%H-%M")
+- IF DEFINED APPVEYOR_REPO_TAG_NAME (
+    IF "%APPVEYOR_REPO_TAG_NAME%"=="nightly" (
+      7z a -tzip postgrest-nightly-%suffix%-windows-x64.zip postgrest.exe &&
+      bash -lc "exec 0</dev/null && cd $APPVEYOR_BUILD_FOLDER && ghr -t $GITHUB_TOKEN -u $APPVEYOR_ACCOUNT_NAME -r $APPVEYOR_PROJECT_NAME --replace nightly postgrest-nightly-$suffix-windows-x64.zip"
+    ) ELSE (
+      7z a -tzip postgrest-%APPVEYOR_REPO_TAG_NAME%-windows-x64.zip postgrest.exe &&
+      bash -lc "exec 0</dev/null && cd $APPVEYOR_BUILD_FOLDER && ghr -t $GITHUB_TOKEN -u $APPVEYOR_ACCOUNT_NAME -r $APPVEYOR_PROJECT_NAME -b \"`sed -n \"1,/$APPVEYOR_REPO_TAG_NAME/d;/## \[/q;p\" CHANGELOG.md`\" --replace $APPVEYOR_REPO_TAG_NAME postgrest-$APPVEYOR_REPO_TAG_NAME-windows-x64.zip"
+    )
+  )

default.nix

@@ -0,0 +1,157 @@
+let
+  name =
+    "postgrest";
+
+  compiler =
+    "ghc8104";
+
+  # 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.ghr
+      allOverlays.gitignore
+      allOverlays.postgresql-default
+      allOverlays.postgresql-legacy
+      (allOverlays.haskell-packages { inherit compiler; })
+    ];
+
+  # Evaluated expression of the Nixpkgs repository.
+  pkgs =
+    import nixpkgs { inherit overlays; };
+
+  postgresqlVersions =
+    [
+      { name = "postgresql-13"; postgresql = pkgs.postgresql_13; }
+      { name = "postgresql-12"; postgresql = pkgs.postgresql_12; }
+      { name = "postgresql-11"; postgresql = pkgs.postgresql_11; }
+      { name = "postgresql-10"; postgresql = pkgs.postgresql_10; }
+      { name = "postgresql-9.6"; postgresql = pkgs.postgresql_9_6; }
+      { name = "postgresql-9.5"; postgresql = pkgs.postgresql_9_5; }
+    ];
+
+  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; });
+      }
+    );
+
+  lib =
+    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 { })
+      )
+    );
+
+  env =
+    postgrest.env;
+
+  # Tooling for analyzing Haskell imports and exports.
+  hsie =
+    pkgs.callPackage nix/hsie {
+      ghcWithPackages = pkgs.haskell.packages.ghc884.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; };
+
+  # 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 {
+      inherit docker;
+      postgrest = postgrestStatic;
+    };
+
+  # Linting and styling tools.
+  style =
+    pkgs.callPackage nix/tools/style.nix { };
+
+  # Scripts for running tests.
+  tests =
+    pkgs.callPackage nix/tools/tests.nix {
+      inherit postgrest devCabalOptions withTools;
+      ghc = pkgs.haskell.compiler."${compiler}";
+      hpc-codecov = pkgs.haskell.packages."${compiler}".hpc-codecov;
+    };
+
+  withTools =
+    pkgs.callPackage nix/tools/withTools.nix { inherit postgresqlVersions; };
+}

docker/Dockerfile

@@ -1,57 +0,0 @@
-# To build use:
-# docker build --build-arg POSTGREST_VERSION=<v5.2.0 or another version> -t postgrest ./docker/
-
-FROM debian:buster-slim
-
-ARG POSTGREST_VERSION
-
-# 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 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/PostgREST/postgrest/releases/download/${POSTGREST_VERSION}/postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
-    tar -xJvf postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
-    mv postgrest /usr/local/bin/postgrest && \
-    cd / && \
-    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_DB_EXTRA_SEARCH_PATH=public \
-    PGRST_SERVER_HOST=*4 \
-    PGRST_SERVER_PORT=3000 \
-    PGRST_OPENAPI_SERVER_PROXY_URI= \
-    PGRST_JWT_SECRET= \
-    PGRST_SECRET_IS_BASE64=false \
-    PGRST_JWT_AUD= \
-    PGRST_MAX_ROWS= \
-    PGRST_PRE_REQUEST= \
-    PGRST_ROLE_CLAIM_KEY=".role" \
-    PGRST_ROOT_SPEC= \
-    PGRST_RAW_MEDIA_TYPES=
-
-RUN groupadd -g 1000 postgrest && \
-    useradd -r -u 1000 -g postgrest postgrest && \
-    chown postgrest:postgrest /etc/postgrest.conf
-
-USER 1000
-
-# 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/distro_release/Dockerfile.centos7

@@ -1,18 +0,0 @@
-FROM centos:centos7
-
-RUN yum -y update
-RUN yum -y install perl make automake gcc gmp-devel libffi zlib zlib-devel xz tar
-RUN yum -y install yum install https://download.postgresql.org/pub/repos/yum/10/redhat/rhel-7-x86_64/pgdg-centos10-10-2.noarch.rpm
-RUN yum -y install postgresql10-devel
-RUN yum clean all
-RUN curl -sSL https://get.haskellstack.org/ | sh
-
-ENV PATH $PATH:/usr/pgsql-10/bin
-
-# To disable warning when building
-ENV PATH $PATH:/root/.local/bin
-
-RUN mkdir /source
-WORKDIR /source
-
-ENTRYPOINT ["stack"]

docker/distro_release/Dockerfile.ubuntu

@@ -1,20 +0,0 @@
-FROM ubuntu:16.04
-
-## TODO pin the stack version
-#
-RUN BUILD_DEPS="curl ca-certificates build-essential" && \
-    apt-get -qq update && \
-    apt-get -qqy --no-install-recommends install \
-    $BUILD_DEPS \
-    libpq-dev && \
-    curl -sSL https://get.haskellstack.org/ | sh && \
-    apt-get -qq clean && \
-    rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/*
-
-# To disable warning when building
-ENV PATH $PATH:/root/.local/bin
-
-RUN mkdir /source
-WORKDIR /source
-
-ENTRYPOINT ["stack"]

docker/distro_release/Dockerfile.ubuntui386

@@ -1,20 +0,0 @@
-FROM i386/ubuntu:16.04
-
-## TODO pin the stack version
-
-RUN BUILD_DEPS="curl ca-certificates build-essential" && \
-    apt-get -qq update && \
-    apt-get -qqy --no-install-recommends install \
-    $BUILD_DEPS \
-    libpq-dev && \
-    curl -sSL https://get.haskellstack.org/ | sh && \
-    apt-get -qq clean && \
-    rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/*
-
-# To disable warning when building
-ENV PATH $PATH:/root/.local/bin
-
-RUN mkdir /source
-WORKDIR /source
-
-ENTRYPOINT ["stack"]

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,19 +0,0 @@
-db-uri = "$(PGRST_DB_URI)"
-db-schema = "$(PGRST_DB_SCHEMA)"
-db-anon-role = "$(PGRST_DB_ANON_ROLE)"
-db-pool = "$(PGRST_DB_POOL)"
-db-extra-search-path = "$(PGRST_DB_EXTRA_SEARCH_PATH)"
-
-server-host = "$(PGRST_SERVER_HOST)"
-server-port = "$(PGRST_SERVER_PORT)"
-
-openapi-server-proxy-uri = "$(PGRST_OPENAPI_SERVER_PROXY_URI)"
-jwt-secret = "$(PGRST_JWT_SECRET)"
-secret-is-base64 = "$(PGRST_SECRET_IS_BASE64)"
-jwt-aud = "$(PGRST_JWT_AUD)"
-role-claim-key = "$(PGRST_ROLE_CLAIM_KEY)"
-
-max-rows = "$(PGRST_MAX_ROWS)"
-pre-request = "$(PGRST_PRE_REQUEST)"
-root-spec = "$(PGRST_ROOT_SPEC)"
-raw-media-types = "$(PGRST_RAW_MEDIA_TYPES)"

main/Main.hs

@@ -1,330 +1,47 @@
 {-# LANGUAGE CPP #-}
 
-module Main where
+module Main (main) where
 
-import qualified Data.ByteString            as BS
+import qualified Data.Map.Strict as M
-import qualified Data.ByteString.Base64     as B64
-import qualified Hasql.Pool                 as P
-import qualified Hasql.Transaction.Sessions as HT
 
-import Control.AutoUpdate       (defaultUpdateSettings, mkAutoUpdate,
+import System.IO (BufferMode (..), hSetBuffering)
-                                 updateAction)
-import Control.Retry            (RetryStatus, capDelay,
-                                 exponentialBackoff, retrying,
-                                 rsPreviousDelay)
-import Data.Either.Combinators  (whenLeft)
-import Data.IORef               (IORef, atomicWriteIORef, newIORef,
-                                 readIORef)
-import Data.String              (IsString (..))
-import Data.Text                (pack, replace, strip, stripPrefix)
-import Data.Text.Encoding       (decodeUtf8, encodeUtf8)
-import Data.Text.IO             (hPutStrLn, readFile)
-import Data.Time.Clock          (getCurrentTime)
-import Network.Wai.Handler.Warp (defaultSettings, runSettings,
-                                 setHost, setPort, setServerName)
-import System.IO                (BufferMode (..), hSetBuffering)
 
-import PostgREST.App         (postgrest)
+import qualified PostgREST.App as App
-import PostgREST.Config      (AppConfig (..), configPoolTimeout',
+import qualified PostgREST.CLI as CLI
-                              prettyVersion, readOptions)
-import PostgREST.DbStructure (getDbStructure, getPgVersion)
-import PostgREST.Error       (PgError (PgError), checkIsFatal,
-                              errorPayload)
-import PostgREST.OpenAPI     (isMalformedProxyUri)
-import PostgREST.Types       (ConnectionStatus (..), DbStructure,
-                              PgVersion (..), Schema,
-                              minimumPgVersion)
-import Protolude             hiding (hPutStrLn, head, replace)
 
+import PostgREST.Config (readPGRSTEnvironment)
+
+import Protolude
 
 #ifndef mingw32_HOST_OS
-import System.Posix.Signals
+import qualified PostgREST.Unix as Unix
-import UnixSocket
 #endif
 
-
-{-|
-  The purpose of this worker is to fill the refDbStructure created in 'main'
-  with the 'DbStructure' returned from calling 'getDbStructure'. This method
-  is meant to be called by multiple times by the same thread, but does nothing if
-  the previous invocation has not terminated. In all cases this method does not
-  halt the calling thread, the work is preformed in a separate thread.
-
-  Note: 'atomicWriteIORef' is essentially a lazy semaphore that prevents two
-  threads from running 'connectionWorker' at the same time.
-
-  Background thread that does the following :
-  1. Tries to connect to pg server and will keep trying until success.
-  2. Checks if the pg version is supported and if it's not it kills the main
-     program.
-  3. Obtains the dbStructure.
-  4. If 2 or 3 fail to give their result it means the connection is down so it
-     goes back to 1, otherwise it finishes his work successfully.
--}
-connectionWorker
-  :: ThreadId -- ^ This thread is killed if pg version is unsupported
-  -> P.Pool   -- ^ The PostgreSQL connection pool
-  -> [Schema] -- ^ Schemas PostgREST is serving up
-  -> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure'
-  -> IORef Bool                -- ^ Used as a binary Semaphore
-  -> IO ()
-connectionWorker mainTid pool schemas refDbStructure refIsWorkerOn = do
-  isWorkerOn <- readIORef refIsWorkerOn
-  unless isWorkerOn $ do
-    atomicWriteIORef refIsWorkerOn True
-    void $ forkIO work
-  where
-    work = do
-      atomicWriteIORef refDbStructure Nothing
-      putStrLn ("Attempting to connect to the database..." :: Text)
-      connected <- connectionStatus pool
-      case connected of
-        FatalConnectionError reason -> hPutStrLn stderr reason
-                                      >> killThread mainTid    -- Fatal error when connecting
-        NotConnected                -> return ()               -- Unreachable
-        Connected actualPgVersion   -> do                      -- Procede with initialization
-          result <- P.use pool $ do
-            dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schemas actualPgVersion
-            liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
-          case result of
-            Left e -> do
-              putStrLn ("Failed to query the database. Retrying." :: Text)
-              hPutStrLn stderr . toS . errorPayload $ PgError False e
-              work
-
-            Right _ -> do
-              atomicWriteIORef refIsWorkerOn False
-              putStrLn ("Connection successful" :: Text)
-
-{-|
-  Used by 'connectionWorker' to check if the provided db-uri lets
-  the application access the PostgreSQL database. This method is used
-  the first time the connection is tested, but only to test before
-  calling 'getDbStructure' inside the 'connectionWorker' method.
-
-  The connection tries are capped, but if the connection times out no error is
-  thrown, just 'False' is returned.
--}
-connectionStatus :: P.Pool -> IO ConnectionStatus
-connectionStatus pool =
-  retrying (capDelay 32000000 $ exponentialBackoff 1000000)
-           shouldRetry
-           (const $ P.release pool >> getConnectionStatus)
-  where
-    getConnectionStatus :: IO ConnectionStatus
-    getConnectionStatus = do
-      pgVersion <- P.use pool getPgVersion
-      case pgVersion of
-        Left e -> do
-          let err = PgError False e
-          hPutStrLn stderr . toS $ errorPayload err
-          case checkIsFatal err of
-            Just reason -> return $ FatalConnectionError reason
-            Nothing     -> return NotConnected
-
-        Right version ->
-          if version < minimumPgVersion
-             then return . FatalConnectionError $ "Cannot run in this PostgreSQL version, PostgREST needs at least " <> pgvName minimumPgVersion
-             else return . Connected  $ version
-
-    shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool
-    shouldRetry rs isConnSucc = do
-      let delay    = fromMaybe 0 (rsPreviousDelay rs) `div` 1000000
-          itShould = NotConnected == isConnSucc
-      when itShould $
-        putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
-      return itShould
-
-
-{-|
-  This is where everything starts.
--}
 main :: IO ()
 main = do
-  --
+  setBuffering
+  hasPGRSTEnv <- not . M.null <$> readPGRSTEnvironment
+  opts <- CLI.readCLIShowHelp hasPGRSTEnv
+  CLI.main installSignalHandlers runAppInSocket opts
+
+installSignalHandlers :: App.SignalHandlerInstaller
+#ifndef mingw32_HOST_OS
+installSignalHandlers = Unix.installSignalHandlers
+#else
+installSignalHandlers _ = pass
+#endif
+
+runAppInSocket :: Maybe App.SocketRunner
+#ifndef mingw32_HOST_OS
+runAppInSocket = Just Unix.runAppWithSocket
+#else
+runAppInSocket = Nothing
+#endif
+
+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
-  --
-  -- NoBuffering: output is written immediately and never stored in the buffer
   hSetBuffering stdout LineBuffering
   hSetBuffering stdin LineBuffering
-  hSetBuffering stderr NoBuffering
+  hSetBuffering stderr LineBuffering
-  --
-  -- readOptions builds the 'AppConfig' from the config file specified on the
-  -- command line
-  conf <- loadDbUriFile =<< loadSecretFile =<< readOptions
-  let schemas = toList $ configSchemas conf
-      host = configHost conf
-      port = configPort conf
-      proxy = configOpenAPIProxyUri conf
-      maybeSocketAddr = configSocket conf
-      socketFileMode = configSocketMode conf
-      pgSettings = toS (configDatabase conf) -- is the db-uri
-      roleClaimKey = configRoleClaimKey conf
-      appSettings =
-        setHost ((fromString . toS) host) -- Warp settings
-        . setPort port
-        . setServerName (toS $ "postgrest/" <> prettyVersion) $
-        defaultSettings
-
-
-  whenLeft socketFileMode panic
-
-  -- Checks that the provided proxy uri is formated correctly
-  when (isMalformedProxyUri $ toS <$> proxy) $
-    panic
-      "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
-
-  -- Checks that the provided jspath is valid
-  whenLeft roleClaimKey $
-    panic $ show roleClaimKey
-
-  -- create connection pool with the provided settings, returns either
-  -- a 'Connection' or a 'ConnectionError'. Does not throw.
-  pool <- P.acquire (configPool conf, configPoolTimeout' conf, pgSettings)
-  --
-  -- To be filled in by connectionWorker
-  refDbStructure <- newIORef Nothing
-  --
-  -- Helper ref to make sure just one connectionWorker can run at a time
-  refIsWorkerOn <- newIORef False
-  --
-  -- This is passed to the connectionWorker method so it can kill the main
-  -- thread if the PostgreSQL's version is not supported.
-  mainTid <- myThreadId
-  --
-  -- Sets the refDbStructure
-  connectionWorker
-    mainTid
-    pool
-    schemas
-    refDbStructure
-    refIsWorkerOn
-  --
-  -- Only for systems with signals:
-  --
-  -- releases the connection pool whenever the program is terminated,
-  -- see issue #268
-  --
-  -- Plus the SIGHUP signal updates the internal 'DbStructure' by running
-  -- 'connectionWorker' exactly as before.
-#ifndef mingw32_HOST_OS
-  forM_ [sigINT, sigTERM] $ \sig ->
-    void $ installHandler sig (Catch $ do
-        P.release pool
-        throwTo mainTid UserInterrupt
-      ) Nothing
-
-  void $ installHandler sigUSR1 (
-    Catch $ connectionWorker
-              mainTid
-              pool
-              schemas
-              refDbStructure
-              refIsWorkerOn
-    ) Nothing
-#endif
-
-
-  -- ask for the OS time at most once per second
-  getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime}
-
-  let postgrestApplication =
-        postgrest
-          conf
-          refDbStructure
-          pool
-          getTime
-          (connectionWorker
-             mainTid
-             pool
-             schemas
-             refDbStructure
-             refIsWorkerOn)
-
-  -- run the postgrest application with user defined socket. Only for UNIX systems.
-#ifndef mingw32_HOST_OS
-  whenJust maybeSocketAddr $
-    runAppInSocket appSettings postgrestApplication socketFileMode
-#endif
-
-  -- run the postgrest application
-  whenNothing maybeSocketAddr $ do
-    putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)
-    runSettings appSettings postgrestApplication
-
-{-|
-  The purpose of this function is to load the JWT secret from a file if
-  configJwtSecret is actually a filepath and replaces some characters if the JWT
-  is base64 encoded.
-
-  The reason some characters need to be replaced is because JWT is actually
-  base64url encoded which must be turned into just base64 before decoding.
-
-  To check if the JWT secret is provided is in fact a file path, it must be
-  decoded as 'Text' to be processed.
-
-  decodeUtf8: Decode a ByteString containing UTF-8 encoded text that is known to
-  be valid.
--}
-loadSecretFile :: AppConfig -> IO AppConfig
-loadSecretFile conf = extractAndTransform mSecret
-  where
-    mSecret = decodeUtf8 <$> configJwtSecret conf
-    isB64 = configJwtSecretIsBase64 conf
-    --
-    -- The Text (variable name secret) here is mSecret from above which is the JWT
-    -- decoded as Utf8
-    --
-    -- stripPrefix: Return the suffix of the second string if its prefix matches
-    -- the entire first string.
-    --
-    -- The configJwtSecret is a filepath instead of the JWT secret itself if the
-    -- secret has @ as its prefix.
-    extractAndTransform :: Maybe Text -> IO AppConfig
-    extractAndTransform Nothing = return conf
-    extractAndTransform (Just secret) =
-      fmap setSecret $
-      transformString isB64 =<<
-      case stripPrefix "@" secret of
-        Nothing       -> return . encodeUtf8 $ secret
-        Just filename -> chomp <$> BS.readFile (toS filename)
-      where
-        chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs)
-    --
-    -- Turns the Base64url encoded JWT into Base64
-    transformString :: Bool -> ByteString -> IO ByteString
-    transformString False t = return t
-    transformString True t =
-      case B64.decode $ encodeUtf8 $ strip $ replaceUrlChars $ decodeUtf8 t of
-        Left errMsg -> panic $ pack errMsg
-        Right bs    -> return bs
-    setSecret bs = conf {configJwtSecret = Just bs}
-    --
-    -- replace: Replace every occurrence of one substring with another
-    replaceUrlChars =
-      replace "_" "/" . replace "-" "+" . replace "." "="
-
-{-
-  Load database uri from a separate file if `db-uri` is a filepath.
--}
-loadDbUriFile :: AppConfig -> IO AppConfig
-loadDbUriFile conf = extractDbUri mDbUri
-  where
-    mDbUri = configDatabase conf
-    extractDbUri :: Text -> IO AppConfig
-    extractDbUri dbUri =
-      fmap setDbUri $
-      case stripPrefix "@" dbUri of
-        Nothing       -> return dbUri
-        Just filename -> strip <$> readFile (toS filename)
-    setDbUri dbUri = conf {configDatabase = dbUri}
-
--- Utilitarian functions.
-whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()
-whenJust (Just x) f = f x
-whenJust Nothing _  = pass
-
-whenNothing :: Applicative f => Maybe a -> f () -> f ()
-whenNothing Nothing f = f
-whenNothing _       _ = pass

main/UnixSocket.hs

@@ -1,40 +0,0 @@
-module UnixSocket (
-  runAppInSocket
-)where
-
-import Network.Socket           (Family (AF_UNIX),
-                                 SockAddr (SockAddrUnix), Socket,
-                                 SocketType (Stream), bind, close,
-                                 defaultProtocol, listen,
-                                 maxListenQueue, socket)
-import Network.Wai              (Application)
-import Network.Wai.Handler.Warp
-import System.Directory         (removeFile)
-import System.IO.Error          (isDoesNotExistError)
-import System.Posix.Files       (setFileMode)
-import System.Posix.Types       (FileMode)
-
-import Protolude
-
-createAndBindSocket :: FilePath -> Maybe FileMode -> IO Socket
-createAndBindSocket socketFilePath maybeSocketFileMode = do
-  deleteSocketFileIfExist socketFilePath
-  sock <- socket AF_UNIX Stream defaultProtocol
-  bind sock $ SockAddrUnix socketFilePath
-  mapM_ (setFileMode socketFilePath) maybeSocketFileMode
-  return sock
-  where
-    deleteSocketFileIfExist path = removeFile path `catch` handleDoesNotExist
-    handleDoesNotExist e
-      | isDoesNotExistError e = return ()
-      | otherwise = throwIO e
-
--- run the postgrest application with user defined socket.
-runAppInSocket :: Settings -> Application -> Either Text FileMode -> FilePath -> IO ()
-runAppInSocket settings app socketFileMode sockPath = do
-  sock <- createAndBindSocket sockPath (rightToMaybe socketFileMode)
-  putStrLn $ ("Listening on unix socket " :: Text) <> show sockPath
-  listen sock maxListenQueue
-  runSettingsSocket settings sock app
-  -- clean socket up when done
-  close sock

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.5
+postgrest-test-io                 postgrest-with-postgresql-9.6
+...
+
+[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.5
+postgrest-test-io                 postgrest-with-postgresql-9.6
+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,358 @@
+{-# 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.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 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 HsExtension                (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 (loc, err) ->
+      fail $ "Error with " <> show filepath <> " at " <> show loc <> ": " <> err
+
+-- | 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 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-07-17";
+  rev = "d00b5a5fa6fe8bdf7005abb06c46ae0245aec8b5";
+  tarballHash = "08497wbpnf3w5dalcasqzymw3fmcn8qrnbkf8rxxwwvyjdnczxdv";
+}

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,137 @@
+# 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
+, 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"
+        ''
+
+        + "(${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;
+  ghr = import ./ghr;
+  gitignore = import ./gitignore.nix;
+  haskell-packages = import ./haskell-packages.nix;
+  postgresql-default = import ./postgresql-default.nix;
+  postgresql-legacy = import ./postgresql-legacy.nix;
+}

nix/overlays/ghr/default.nix

@@ -0,0 +1,7 @@
+self: super:
+# Overlay that adds `ghr`: Upload multiple artifacts to GitHub Release in
+# parallel, http://tcnksm.github.io/ghr/
+
+{
+  ghr = super.callPackage ./ghr.nix { };
+}

nix/overlays/ghr/ghr.nix

@@ -0,0 +1,18 @@
+{ buildGoModule, fetchFromGitHub }:
+
+buildGoModule rec {
+  pname = "ghr";
+  version = "0.14.0";
+
+  src = fetchFromGitHub {
+    rev = "v${version}";
+    owner = "tcnksm";
+    repo = "ghr";
+    sha256 = "1jjc3bwmyw831r1ayic1f1ysh5ggm88aszbndm0swg8byhz56pd4";
+  };
+
+  vendorSha256 = "06cbhsnxv4gisnwrhw61af7rpv2a9slf9z2wbn79r91xzkh51vzr";
+
+  # Disabling tests, as they require a GitHub API token
+  doCheck = false;
+}

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,42 @@
+{ compiler, extraOverrides ? (final: prev: { }) }:
+
+self: super:
+let
+  lib =
+    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_13;
+}

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,54 @@
+# 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.haskell-packages { inherit compiler extraOverrides; })
+    ];
+
+  # Apply our overlay to the given pkgs.
+  normalPkgs =
+    import patchedNixpkgs { inherit overlays; };
+
+  # 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; };
+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,151 @@
+{ buildToolbox
+, cabal-install
+, cachix
+, checkedShellScript
+, devCabalOptions
+, entr
+, graphviz
+, hsie
+, nix
+, silver-searcher
+, style
+, tests
+}:
+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;
+      }
+      ''
+        ${tests}/bin/postgrest-with-all ${tests}/bin/postgrest-test-spec
+        ${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,29 @@
+# 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;
+      }
+      ''
+        export PATH="${postgrestProfiled}/bin:${curl}/bin:$PATH"
+
+        ${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,174 @@
+{ buildToolbox
+, checkedShellScript
+, curl
+, docker
+, envsubst
+, ghr
+, git
+, jq
+, postgrest
+, runCommand
+}:
+let
+  github =
+    checkedShellScript
+      {
+        name = "postgrest-release-github";
+        docs = "Push a new release to GitHub.";
+        args = [
+          "ARG_POSITIONAL_SINGLE([version], [git version tag to make release for])"
+          "ARG_USE_ENV([GITHUB_TOKEN], [], [GitHub token])"
+          "ARG_USE_ENV([GITHUB_USERNAME], [], [GitHub user name])"
+          "ARG_USE_ENV([GITHUB_REPONAME], [], [GitHub repository name])"
+        ];
+        inRootDir = true;
+      }
+      ''
+        # 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
+        GITHUB_TOKEN="''${GITHUB_TOKEN:?GITHUB_TOKEN is required}"
+        GITHUB_USERNAME="''${GITHUB_USERNAME:?GITHUB_USERNAME is required}"
+        GITHUB_REPONAME="''${GITHUB_REPONAME:?GITHUB_REPONAME is required}"
+
+        if test "$_arg_version" = "nightly"
+        then
+          suffix=$(${git}/bin/git show -s --format="%cd-%h" --date="format:%Y-%m-%d-%H-%M")
+          tar cvJf "postgrest-nightly-$suffix-linux-x64-static.tar.xz" \
+            -C ${postgrest}/bin postgrest
+
+          ${ghr}/bin/ghr \
+            -t "$GITHUB_TOKEN" \
+            -u "$GITHUB_USERNAME" \
+            -r "$GITHUB_REPONAME" \
+            --replace nightly \
+            "postgrest-nightly-$suffix-linux-x64-static.tar.xz"
+        else
+          changes="$(sed -n "1,/$_arg_version/d;/## \[/q;p" ${../../../CHANGELOG.md})"
+
+          tar cvJf "postgrest-$_arg_version-linux-x64-static.tar.xz" \
+            -C ${postgrest}/bin postgrest
+
+          ${ghr}/bin/ghr \
+            -t "$GITHUB_TOKEN" \
+            -u "$GITHUB_USERNAME" \
+            -r "$GITHUB_REPONAME" \
+            -b "$changes" \
+            --replace "$_arg_version" \
+            "postgrest-$_arg_version-linux-x64-static.tar.xz"
+        fi
+      '';
+
+  dockerLogin =
+    checkedShellScript
+      {
+        name = "postgrest-release-docker-login";
+        docs =
+          ''
+            Log in to Docker Hub using the DOCKER_USER and DOCKER_PASS env vars.
+
+            Those env vars are usually provided by CircleCI. The DOCKER_USER is
+            not the same as DOCKER_REPO because we use the
+            https://hub.docker.com/u/postgrestbot account for uploading to dockerhub.
+          '';
+        args = [
+          "ARG_USE_ENV([DOCKER_USER], [], [DockerHub user name])"
+          "ARG_USE_ENV([DOCKER_PASS], [], [DockerHub password])"
+        ];
+      }
+      ''
+        # 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:?DOCKER_USER is required}"
+        DOCKER_PASS="''${DOCKER_PASS:?DOCKER_PASS is required}"
+
+        docker login -u "$DOCKER_USER" -p "$DOCKER_PASS"
+      '';
+
+  dockerHub =
+    checkedShellScript
+      {
+        name = "postgrest-release-dockerhub";
+        docs = "Push a new release to Docker Hub";
+        args = [
+          "ARG_POSITIONAL_SINGLE([version], [git version tag to tag image with])"
+          "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_REPO="''${DOCKER_REPO:?DOCKER_REPO is required}"
+
+        docker load -i ${docker.image}
+
+        if test "$_arg_version" = "nightly"
+        then
+          suffix=$(${git}/bin/git show -s --format="%cd-%h" --date="format:%Y-%m-%d-%H-%M")
+
+          docker tag postgrest:latest "$DOCKER_REPO/postgrest:nightly-$suffix"
+          docker push "$DOCKER_REPO/postgrest:nightly-$suffix"
+        else
+          docker tag postgrest:latest "$DOCKER_REPO"/postgrest:latest
+          docker tag postgrest:latest "$DOCKER_REPO/postgrest:$_arg_version"
+
+          docker push "$DOCKER_REPO"/postgrest:latest
+          docker push "$DOCKER_REPO/postgrest:$_arg_version"
+        fi
+      '';
+
+  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:?DOCKER_USER is required}"
+        DOCKER_PASS="''${DOCKER_PASS:?DOCKER_PASS is required}"
+        DOCKER_REPO="''${DOCKER_REPO:?DOCKER_REPO is required}"
+
+        # Login to Docker Hub and get a token.
+        token="$(
+          ${curl}/bin/curl -s \
+            --data-urlencode "username=$DOCKER_USER" \
+            --data-urlencode "password=$DOCKER_PASS" \
+            "https://hub.docker.com/v2/users/login/" \
+            | ${jq}/bin/jq -r .token
+        )"
+
+        # Patch both descriptions.
+        responseCode="$(
+          ${curl}/bin/curl -s --write-out "%{response_code}" \
+            --output /dev/null -H "Authorization: JWT $token" -X PATCH \
+            --data-urlencode description@${description} \
+            --data-urlencode full_description@${fullDescription} \
+            "https://hub.docker.com/v2/repositories/$DOCKER_REPO/postgrest/"
+        )"
+
+        [ "$responseCode" -eq 200 ]
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-release";
+  tools = [ github dockerLogin dockerHub 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://circleci.com/gh/PostgREST/postgrest/tree/main.svg?style=shield)](https://circleci.com/gh/PostgREST/postgrest/tree/main)
+
+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,68 @@
+{ black
+, buildToolbox
+, checkedShellScript
+, git
+, hlint
+, nixpkgs-fmt
+, shellcheck
+, silver-searcher
+, stylish-haskell
+}:
+let
+  style =
+    checkedShellScript
+      {
+        name = "postgrest-style";
+        docs = "Automatically format Haskell, Nix and Python files.";
+        inRootDir = true;
+      }
+      ''
+        # Format Nix files
+        ${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 and bash scripts.";
+        inRootDir = true;
+      }
+      ''
+        # Lint 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
+
+        # Lint bash scripts
+        ${shellcheck}/bin/shellcheck test/create_test_db test/memory-tests.sh
+      '';
+
+in
+buildToolbox
+{
+  name = "postgrest-style";
+  tools = [ style styleCheck lint ];
+}

nix/tools/tests.nix

@@ -0,0 +1,173 @@
+{ 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-test ${devCabalOptions}
+      '';
+
+  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-test ${devCabalOptions} && \
+          ${cabal-install}/bin/cabal v2-test ${devCabalOptions}"
+      '';
+
+  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;
+      }
+      ''
+        export PATH="${jq}/bin:$PATH"
+        
+        ${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:spec-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-test ${devCabalOptions}
+
+        # collect all the tix files
+        ${ghc}/bin/hpc sum  --union --exclude=Paths_postgrest --output="$tmpdir"/tests.tix "$tmpdir"/io*.tix "$tmpdir"/spec.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
+      testSpecIdempotence
+      testIO
+      dumpSchema
+      coverage
+      coverageDraftOverlay
+    ];
+}

nix/tools/withTools.nix

@@ -0,0 +1,138 @@
+{ 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;
+        withTmpDir = true;
+      }
+      ''
+        # avoid starting multiple layers of withTmpDb
+        if test -v PGRST_DB_URI; then
+          exec "$@"
+        fi
+        
+        export PATH=${postgresql}/bin:"$PATH"
+        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" start -o "-F -c listen_addresses=\"\" -k $PGHOST" \
+          >> "$setuplog"
+
+        log "Waiting for the database cluster to be ready..."
+        # Waiting is required for older versions of Postgres (< 10).
+        until pg_isready >> "$setuplog"; do
+          sleep 0.1
+        done
+
+        stop () {
+          log "Stopping the database cluster..."
+          pg_ctl stop -m i >> "$setuplog"
+        }
+        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,5 +1,5 @@
 name:               postgrest
-version:            7.0.0
+version:            8.0.0
 synopsis:           REST API for any Postgres database
 description:        Reads the schema of a PostgreSQL database and creates RESTful routes
                     for the tables and views, supporting all HTTP verbs that security
@@ -19,36 +19,59 @@ source-repository head
   type:     git
   location: git://github.com/PostgREST/postgrest.git
 
-flag ci
+flag dev
   default:     False
   manual:      True
-  description: No warnings allowed in continuous integration
+  description: Development flags
+
+flag hpc
+  default:     True
+  manual:      True
+  description: Enable HPC (dev only)
 
 library
-  exposed-modules:    PostgREST.ApiRequest
+  default-language:   Haskell2010
-                      PostgREST.App
+  default-extensions: OverloadedStrings
+                      NoImplicitPrelude
+  hs-source-dirs:     src
+  exposed-modules:    PostgREST.App
+                      PostgREST.AppState
                       PostgREST.Auth
+                      PostgREST.CLI
                       PostgREST.Config
-                      PostgREST.DbRequestBuilder
+                      PostgREST.Config.Database
+                      PostgREST.Config.JSPath
+                      PostgREST.Config.PgVersion
+                      PostgREST.Config.Proxy
+                      PostgREST.ContentType
                       PostgREST.DbStructure
+                      PostgREST.DbStructure.Identifiers
+                      PostgREST.DbStructure.Proc
+                      PostgREST.DbStructure.Relationship
+                      PostgREST.DbStructure.Table
                       PostgREST.Error
+                      PostgREST.GucHeader
                       PostgREST.Middleware
                       PostgREST.OpenAPI
-                      PostgREST.Parsers
+                      PostgREST.Query.QueryBuilder
-                      PostgREST.QueryBuilder
+                      PostgREST.Query.SqlFragment
-                      PostgREST.Statements
+                      PostgREST.Query.Statements
                       PostgREST.RangeQuery
-                      PostgREST.Types
+                      PostgREST.Request.ApiRequest
+                      PostgREST.Request.DbRequestBuilder
+                      PostgREST.Request.Parsers
+                      PostgREST.Request.Preferences
+                      PostgREST.Request.Types
+                      PostgREST.Version
+                      PostgREST.Workers
   other-modules:      Paths_postgrest
-                      PostgREST.Private.Common
+  build-depends:      base                      >= 4.9 && < 4.15
-                      PostgREST.Private.QueryFragment
-  hs-source-dirs:     src
-  build-depends:      base                      >= 4.9 && < 4.14
                     , HTTP                      >= 4000.3.7 && < 4000.4
                     , Ranged-sets               >= 0.3 && < 0.5
-                    , aeson                     >= 0.11.3 && < 1.5
+                    , aeson                     >= 1.4.7 && < 1.6
                     , ansi-wl-pprint            >= 0.6.7 && < 0.7
-                    , base64-bytestring         >= 1 && < 1.1
+                    , auto-update               >= 0.1.4 && < 0.2
+                    , base64-bytestring         >= 1 && < 1.3
                     , bytestring                >= 0.10.8 && < 0.11
                     , case-insensitive          >= 1.2 && < 1.3
                     , cassava                   >= 0.4.5 && < 0.6
@@ -58,69 +81,90 @@ library
                     , contravariant-extras      >= 0.3.3 && < 0.4
                     , cookie                    >= 0.4.2 && < 0.5
                     , either                    >= 4.4.1 && < 5.1
+                    , fast-logger               >= 2.4.5
                     , gitrev                    >= 1.2 && < 1.4
                     , hasql                     >= 1.4 && < 1.5
+                    , hasql-dynamic-statements  == 0.3.1
+                    , hasql-notifications       >= 0.1 && < 0.3
                     , hasql-pool                >= 0.5 && < 0.6
-                    , hasql-transaction         >= 0.7.2 && < 1.1
+                    , hasql-transaction         >= 1.0.1 && < 1.1
                     , heredoc                   >= 0.2 && < 0.3
                     , http-types                >= 0.12.2 && < 0.13
                     , insert-ordered-containers >= 0.2.2 && < 0.3
                     , interpolatedstring-perl6  >= 1 && < 1.1
                     , jose                      >= 0.8.1 && < 0.9
-                    , lens                      >= 4.14 && < 4.19
+                    , lens                      >= 4.14 && < 5.1
                     , lens-aeson                >= 1.0.1 && < 1.2
-                    , network-uri               >= 2.6.1 && < 2.7
+                    , mtl                       >= 2.2.2 && < 2.3
-                    , optparse-applicative      >= 0.13 && < 0.16
+                    , network-uri               >= 2.6.1 && < 2.8
+                    , optparse-applicative      >= 0.13 && < 0.17
                     , parsec                    >= 3.1.11 && < 3.2
-                    , protolude                 >= 0.2.2 && < 0.3
+                    , protolude                 >= 0.3 && < 0.4
                     , regex-tdfa                >= 1.2.2 && < 1.4
+                    , retry                     >= 0.7.4 && < 0.9
                     , scientific                >= 0.3.4 && < 0.4
-                    , swagger2                  >= 2.4 && < 2.6
+                    , swagger2                  >= 2.4 && < 2.7
                     , text                      >= 1.2.2 && < 1.3
-                    , time                      >= 1.6 && < 1.10
+                    , 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.1
+                    , wai-extra                 >= 3.0.19 && < 3.2
-                    , wai-middleware-static     >= 0.8.1 && < 0.9
+                    , wai-logger                >= 2.3.2
-  default-language:   Haskell2010
+                    , wai-middleware-static     >= 0.8.1 && < 0.10
-  default-extensions: OverloadedStrings
+                    , warp                      >= 3.2.12 && < 3.4
-                      QuasiQuotes
+                      -- -fno-spec-constr may help keep compile time memory use in check,
-                      NoImplicitPrelude
+                      --   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
 
-executable postgrest
+  if flag(dev)
-  main-is:            Main.hs
+    ghc-options: -O0
-  hs-source-dirs:     main
+    if flag(hpc)
-  build-depends:      base              >= 4.9 && < 4.14
+      ghc-options: -fhpc -hpcdir .hpc
-                    , auto-update       >= 0.1.4 && < 0.2
+  else
-                    , base64-bytestring >= 1 && < 1.1
+    ghc-options: -O2
-                    , bytestring        >= 0.10.8 && < 0.11
-                    , directory         >= 1.2.6 && < 1.4
-                    , either            >= 4.4.1 && < 5.1
-                    , hasql             >= 1.4 && < 1.5
-                    , hasql-pool        >= 0.5 && < 0.6
-                    , hasql-transaction >= 0.7.2 && < 1.1
-                    , network           < 3.2
-                    , postgrest
-                    , protolude         >= 0.2.2 && < 0.3
-                    , retry             >= 0.7.4 && < 0.9
-                    , text              >= 1.2.2 && < 1.3
-                    , time              >= 1.6 && < 1.10
-                    , wai               >= 3.2.1 && < 3.3
-                    , warp              >= 3.2.12 && < 3.4
-  default-language:   Haskell2010
-  default-extensions: OverloadedStrings
-                      QuasiQuotes
-                      NoImplicitPrelude
-  ghc-options:        -threaded -rtsopts "-with-rtsopts=-N -I2"
 
   if !os(windows)
-    build-depends: unix
+    build-depends:
-    other-modules: UnixSocket
+      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.15
+                    , 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
@@ -130,36 +174,39 @@ test-suite spec
                       Feature.ConcurrentSpec
                       Feature.CorsSpec
                       Feature.DeleteSpec
+                      Feature.DisabledOpenApiSpec
                       Feature.EmbedDisambiguationSpec
                       Feature.ExtraSearchPathSpec
+                      Feature.HtmlRawOutputSpec
                       Feature.InsertSpec
+                      Feature.IgnorePrivOpenApiSpec
                       Feature.JsonOperatorSpec
+                      Feature.MultipleSchemaSpec
                       Feature.NoJwtSpec
                       Feature.NonexistentSchemaSpec
-                      Feature.PgVersion95Spec
+                      Feature.OpenApiSpec
-                      Feature.PgVersion96Spec
+                      Feature.OptionsSpec
                       Feature.ProxySpec
                       Feature.QueryLimitedSpec
                       Feature.QuerySpec
                       Feature.RangeSpec
+                      Feature.RawOutputTypesSpec
+                      Feature.RollbackSpec
                       Feature.RootSpec
+                      Feature.RpcPreRequestGucsSpec
                       Feature.RpcSpec
                       Feature.SingularSpec
-                      Feature.StructureSpec
                       Feature.UnicodeSpec
+                      Feature.UpdateSpec
                       Feature.UpsertSpec
-                      Feature.RawOutputTypesSpec
-                      Feature.HtmlRawOutputSpec
-                      Feature.MultipleSchemaSpec
                       SpecHelper
                       TestTypes
-  hs-source-dirs:     test
+  build-depends:      base              >= 4.9 && < 4.15
-  build-depends:      base              >= 4.9 && < 4.14
+                    , aeson             >= 1.4.7 && < 1.6
-                    , aeson             >= 0.11.3 && < 1.5
                     , aeson-qq          >= 0.8.1 && < 0.9
                     , async             >= 2.1.1 && < 2.3
                     , auto-update       >= 0.1.4 && < 0.2
-                    , base64-bytestring >= 1 && < 1.1
+                    , base64-bytestring >= 1 && < 1.3
                     , bytestring        >= 0.10.8 && < 0.11
                     , case-insensitive  >= 1.2 && < 1.3
                     , cassava           >= 0.4.5 && < 0.6
@@ -167,65 +214,68 @@ test-suite spec
                     , contravariant     >= 1.4 && < 1.6
                     , hasql             >= 1.4 && < 1.5
                     , hasql-pool        >= 0.5 && < 0.6
-                    , hasql-transaction >= 0.7.2 && < 1.1
+                    , hasql-transaction >= 1.0.1 && < 1.1
                     , heredoc           >= 0.2 && < 0.3
                     , hspec             >= 2.3 && < 2.8
-                    , hspec-wai         >= 0.10 && < 0.11
+                    , hspec-wai         >= 0.10 && < 0.12
-                    , hspec-wai-json    >= 0.10 && < 0.11
+                    , hspec-wai-json    >= 0.10 && < 0.12
                     , http-types        >= 0.12.3 && < 0.13
-                    , lens              >= 4.14 && < 4.19
+                    , 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.2.2 && < 0.3
+                    , protolude         >= 0.3 && < 0.4
                     , regex-tdfa        >= 1.2.2 && < 1.4
                     , text              >= 1.2.2 && < 1.3
-                    , time              >= 1.6 && < 1.10
+                    , time              >= 1.6 && < 1.11
                     , transformers-base >= 0.4.4 && < 0.5
                     , wai               >= 3.2.1 && < 3.3
-                    , wai-extra         >= 3.0.19 && < 3.1
+                    , wai-extra         >= 3.0.19 && < 3.2
-  default-language:   Haskell2010
+  ghc-options:        -O0 -Werror -Wall -fwarn-identities
-  default-extensions: OverloadedStrings
+                      -fno-spec-constr -optP-Wno-nonportable-include-path
-                      QuasiQuotes
+                      -fno-warn-missing-signatures
-                      NoImplicitPrelude
-  ghc-options:        -threaded -rtsopts -with-rtsopts=-N
 
-Test-Suite spec-querycost
+test-suite spec-querycost
-  Type:                exitcode-stdio-1.0
+  type:                exitcode-stdio-1.0
-  Default-Language:    Haskell2010
+  default-language:    Haskell2010
-  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
+  default-extensions:  OverloadedStrings
-  Hs-Source-Dirs:      test
+                       QuasiQuotes
-  Main-Is:             QueryCost.hs
+                       NoImplicitPrelude
-  Other-Modules:       SpecHelper
+  hs-source-dirs:      test
-  Build-Depends:       base              >= 4.9 && < 4.14
+  main-is:             QueryCost.hs
-                     , aeson             >= 0.11.3 && < 1.5
+  other-modules:       SpecHelper
+  build-depends:       base              >= 4.9 && < 4.15
+                     , aeson             >= 1.4.7 && < 1.6
                      , aeson-qq          >= 0.8.1 && < 0.9
                      , async             >= 2.1.1 && < 2.3
                      , auto-update       >= 0.1.4 && < 0.2
-                     , base64-bytestring >= 1 && < 1.1
+                     , base64-bytestring >= 1 && < 1.3
                      , bytestring        >= 0.10.8 && < 0.11
                      , case-insensitive  >= 1.2 && < 1.3
                      , cassava           >= 0.4.5 && < 0.6
                      , containers        >= 0.5.7 && < 0.7
                      , contravariant     >= 1.4 && < 1.6
                      , hasql             >= 1.4 && < 1.5
+                     , hasql-dynamic-statements  == 0.3.1
                      , hasql-pool        >= 0.5 && < 0.6
-                     , hasql-transaction >= 0.7.2 && < 1.1
+                     , hasql-transaction >= 1.0.1 && < 1.1
                      , heredoc           >= 0.2 && < 0.3
                      , hspec             >= 2.3 && < 2.8
-                     , hspec-wai         >= 0.10 && < 0.11
+                     , hspec-wai         >= 0.10 && < 0.12
-                     , hspec-wai-json    >= 0.10 && < 0.11
+                     , hspec-wai-json    >= 0.10 && < 0.12
                      , http-types        >= 0.12.3 && < 0.13
-                     , lens              >= 4.14 && < 4.19
+                     , 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.2.2 && < 0.3
+                     , protolude         >= 0.3 && < 0.4
                      , regex-tdfa        >= 1.2.2 && < 1.4
                      , text              >= 1.2.2 && < 1.3
-                     , time              >= 1.6 && < 1.10
+                     , time              >= 1.6 && < 1.11
                      , transformers-base >= 0.4.4 && < 0.5
                      , wai               >= 3.2.1 && < 3.3
-                     , wai-extra         >= 3.0.19 && < 3.1
+                     , wai-extra         >= 3.0.19 && < 3.2
+  ghc-options:         -O0 -Werror -Wall -fwarn-identities
+                       -fno-spec-constr -optP-Wno-nonportable-include-path

shell.nix

@@ -0,0 +1,63 @@
+# 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 release true
+#
+# This will provide you with a shell where the `postgrest-release-*` scripts
+# are available.
+#
+# 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
+, release ? false
+}:
+let
+  postgrest =
+    import ./default.nix;
+
+  pkgs =
+    postgrest.pkgs;
+
+  lib =
+    pkgs.lib;
+
+  toolboxes =
+    [
+      postgrest.cabalTools
+      postgrest.devTools
+      postgrest.nixpkgsTools
+      postgrest.style
+      postgrest.tests
+      postgrest.withTools
+    ]
+    ++ lib.optional docker postgrest.docker
+    ++ lib.optional memory postgrest.memory
+    ++ lib.optional release postgrest.release;
+
+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,346 +0,0 @@
-{-|
-Module      : PostgREST.ApiRequest
-Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
--}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-
-module PostgREST.ApiRequest (
-  ApiRequest(..)
-, InvokeMethod(..)
-, ContentType(..)
-, Action(..)
-, Target(..)
-, mutuallyAgreeable
-, userApiRequest
-) where
-
-import qualified Data.Aeson           as JSON
-import qualified Data.ByteString      as BS
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Csv             as CSV
-import qualified Data.HashMap.Strict  as M
-import qualified Data.List            as L
-import qualified Data.Set             as S
-import qualified Data.Text            as T
-import qualified Data.Vector          as V
-
-import Control.Arrow             ((***))
-import Data.Aeson.Types          (emptyArray, emptyObject)
-import Data.List                 (elem, last, lookup, partition)
-import Data.List.NonEmpty        (NonEmpty, head)
-import Data.Maybe                (fromJust)
-import Data.Ranged.Ranges        (Range (..), emptyRange,
-                                  rangeIntersection)
-import Network.HTTP.Base         (urlEncodeVars)
-import Network.HTTP.Types.Header (hAuthorization, hCookie)
-import Network.HTTP.Types.URI    (parseQueryReplacePlus,
-                                  parseSimpleQuery)
-import Network.Wai               (Request (..))
-import Network.Wai.Parse         (parseHttpAccept)
-import Web.Cookie                (parseCookiesText)
-
-
-import Data.Ranged.Boundaries
-
-import PostgREST.Error      (ApiRequestError (..))
-import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq,
-                             rangeLimit, rangeOffset, rangeRequested,
-                             restrictRange)
-import PostgREST.Types
-import Protolude            hiding (head)
-
-type RequestBody = BL.ByteString
-
-data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
--- | Types of things a user wants to do to tables/views/procs
-data Action = ActionCreate       | ActionRead{isHead :: Bool}
-            | ActionUpdate       | ActionDelete
-            | ActionSingleUpsert | ActionInvoke InvokeMethod
-            | ActionInfo         | ActionInspect{isHead :: Bool}
-            deriving Eq
--- | The target db object of a user action
-data Target = TargetIdent QualifiedIdentifier
-            | TargetProc{tpQi :: QualifiedIdentifier, tpIsRootSpec :: Bool}
-            | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/"
-            | TargetUnknown [Text]
-            deriving Eq
-
-{-|
-  Describes what the user wants to do. This data type is a
-  translation of the raw elements of an HTTP request into domain
-  specific language.  There is no guarantee that the intent is
-  sensible, it is up to a later stage of processing to determine
-  if it is an action we are able to perform.
--}
-data ApiRequest = ApiRequest {
-    iAction               :: Action                           -- ^ Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
-  , iRange                :: M.HashMap ByteString NonnegRange -- ^ Requested range of rows within response
-  , iTopLevelRange        :: NonnegRange                      -- ^ Requested range of rows from the top level
-  , iTarget               :: Target                           -- ^ The target, be it calling a proc or accessing a table
-  , iAccepts              :: [ContentType]                    -- ^ Content types the client will accept, [CTAny] if no Accept header
-  , iPayload              :: Maybe PayloadJSON                -- ^ Data sent by client and used for mutation actions
-  , iPreferRepresentation :: PreferRepresentation             -- ^ If client wants created items echoed back
-  , iPreferParameters     :: Maybe PreferParameters           -- ^ How to pass parameters to a stored procedure
-  , iPreferCount          :: Maybe PreferCount                -- ^ Whether the client wants a result count
-  , iPreferResolution     :: Maybe PreferResolution           -- ^ Whether the client wants to UPSERT or ignore records on PK conflict
-  , iFilters              :: [(Text, Text)]                   -- ^ Filters on the result ("id", "eq.10")
-  , iLogic                :: [(Text, Text)]                   -- ^ &and and &or parameters used for complex boolean logic
-  , iSelect               :: Maybe Text                       -- ^ &select parameter used to shape the response
-  , iOnConflict           :: Maybe Text                       -- ^ &on_conflict parameter used to upsert on specific unique keys
-  , iColumns              :: Maybe Text                       -- ^ &columns parameter used to shape the payload
-  , iOrder                :: [(Text, Text)]                   -- ^ &order parameters for each level
-  , iCanonicalQS          :: ByteString                       -- ^ Alphabetized (canonical) request query string for response URLs
-  , iJWT                  :: Text                             -- ^ JSON Web Token
-  , iHeaders              :: [(Text, Text)]                   -- ^ HTTP request headers
-  , iCookies              :: [(Text, Text)]                   -- ^ Request Cookies
-  , iPath                 :: ByteString                       -- ^ Raw request path
-  , iMethod               :: ByteString                       -- ^ Raw request method
-  , iProfile              :: Maybe Schema                     -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/.
-  , iSchema               :: Schema                           -- ^ The request schema. Can vary depending on iProfile.
-  }
-
--- | Examines HTTP request and translates it into user intent.
-userApiRequest :: NonEmpty Schema -> Maybe Text -> Request -> RequestBody -> Either ApiRequestError ApiRequest
-userApiRequest confSchemas rootSpec req reqBody
-  | isJust profile && fromJust profile `notElem` confSchemas = Left $ UnacceptableSchema $ toList confSchemas
-  | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate
-  | topLevelRange == emptyRange = Left InvalidRange
-  | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload
-  | otherwise = Right ApiRequest {
-      iAction = action
-      , iTarget = target
-      , iRange = ranges
-      , iTopLevelRange = topLevelRange
-      , iAccepts = maybe [CTAny] (map decodeContentType . parseHttpAccept) $ lookupHeader "accept"
-      , iPayload = relevantPayload
-      , iPreferRepresentation = representation
-      , iPreferParameters = if | hasPrefer (show SingleObject)     -> Just SingleObject
-                               | hasPrefer (show MultipleObjects)  -> Just MultipleObjects
-                               | otherwise                         -> Nothing
-      , iPreferCount      = if | hasPrefer (show ExactCount)     -> Just ExactCount
-                               | hasPrefer (show PlannedCount)   -> Just PlannedCount
-                               | hasPrefer (show EstimatedCount) -> Just EstimatedCount
-                               | otherwise                         -> Nothing
-      , iPreferResolution = if | hasPrefer (show MergeDuplicates)  -> Just MergeDuplicates
-                               | hasPrefer (show IgnoreDuplicates) -> Just IgnoreDuplicates
-                               | otherwise                         -> Nothing
-      , iFilters = filters
-      , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
-      , iSelect = toS <$> join (lookup "select" qParams)
-      , iOnConflict = toS <$> join (lookup "on_conflict" qParams)
-      , iColumns = columns
-      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
-      , iCanonicalQS = toS $ urlEncodeVars
-        . L.sortOn fst
-        . map (join (***) toS . second (fromMaybe BS.empty))
-        $ qString
-      , iJWT = tokenStr
-      , iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hCookie]
-      , iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie"
-      , iPath = rawPathInfo req
-      , iMethod = method
-      , iProfile = profile
-      , iSchema = schema
-      }
- where
-  -- queryString with '+' converted to ' '(space)
-  qString = parseQueryReplacePlus True $ rawQueryString req
-  -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)
-  (filters, rpcQParams) =
-    case action of
-      ActionInvoke InvGet  -> partitionFlts
-      ActionInvoke InvHead -> partitionFlts
-      _                    -> (flts, [])
-  partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts
-  flts =
-    [ (toS k, toS $ fromJust v) |
-      (k,v) <- qParams, isJust v,
-      k `notElem` ["select", "columns"],
-      not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
-  hasOperator val = any (`T.isPrefixOf` val) $
-                      ((<> ".") <$> "not":M.keys operators) ++
-                      ((<> "(") <$> M.keys ftsOperators)
-  isEmbedPath = T.isInfixOf "."
-  isTargetingProc = case target of
-    TargetProc _ _ -> True
-    _              -> False
-  isTargetingDefaultSpec = case target of
-    TargetDefaultSpec _ -> True
-    _                   -> False
-  contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
-  columns
-    | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
-    | otherwise = Nothing
-  payload =
-    case (contentType, action) of
-      (_, ActionInvoke InvGet)  -> Right rpcPrmsToJson
-      (_, ActionInvoke InvHead) -> Right rpcPrmsToJson
-      (CTApplicationJSON, _) ->
-        if isJust columns
-          then Right $ RawJSON reqBody
-          else note "All object keys must match" . payloadAttributes reqBody
-                 =<< if BL.null reqBody && isTargetingProc
-                       then Right emptyObject
-                       else JSON.eitherDecode reqBody
-      (CTTextCSV, _) -> do
-        json <- csvToJson <$> CSV.decodeByName reqBody
-        note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
-      (CTOther "application/x-www-form-urlencoded", _) ->
-        let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody
-            keys = S.fromList $ M.keys json in
-        Right $ ProcessedJSON (JSON.encode json) PJObject keys
-      (ct, _) ->
-        Left $ toS $ "Content-Type not acceptable: " <> toMime ct
-  rpcPrmsToJson = ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams)
-                  PJObject (S.fromList $ fst <$> rpcQParams)
-  topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows
-  action =
-    case method of
-      -- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response
-      -- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4
-      "HEAD"     | isTargetingDefaultSpec -> ActionInspect{isHead=True}
-                 | isTargetingProc        -> ActionInvoke InvHead
-                 | otherwise              -> ActionRead{isHead=True}
-      "GET"      | isTargetingDefaultSpec -> ActionInspect{isHead=False}
-                 | isTargetingProc        -> ActionInvoke InvGet
-                 | otherwise              -> ActionRead{isHead=False}
-      "POST"    -> if isTargetingProc
-                    then ActionInvoke InvPost
-                    else ActionCreate
-      "PATCH"   -> ActionUpdate
-      "PUT"     -> ActionSingleUpsert
-      "DELETE"  -> ActionDelete
-      "OPTIONS" -> ActionInfo
-      _         -> ActionInspect{isHead=False}
-
-  defaultSchema = head confSchemas
-  profile
-    | length confSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config
-      = Nothing
-    | action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionDelete] -- POST/PATCH/PUT/DELETE don't use the same header as per the spec
-      = Just $ maybe defaultSchema toS $ lookupHeader "Content-Profile"
-    | action `elem` [ActionRead True, ActionRead False, ActionInvoke InvGet, ActionInvoke InvHead, ActionInvoke InvPost,
-                     ActionInspect False, ActionInspect True, ActionInfo]
-      = Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile"
-    | otherwise = Nothing
-  schema = fromMaybe defaultSchema profile
-  target = case path of
-    []            -> case rootSpec of
-                       Just pName -> TargetProc (QualifiedIdentifier schema pName) True
-                       Nothing    -> TargetDefaultSpec schema
-    [table]       -> TargetIdent $ QualifiedIdentifier schema table
-    ["rpc", proc] -> TargetProc (QualifiedIdentifier schema proc) False
-    other         -> TargetUnknown other
-
-  shouldParsePayload =
-    action `elem`
-    [ActionCreate, ActionUpdate, ActionSingleUpsert,
-    ActionInvoke InvPost,
-    -- Though ActionInvoke{isGet=True}(a GET /rpc/..) doesn't really have a payload, we use the payload variable as a way
-    -- to store the query string arguments to the function.
-    ActionInvoke InvGet,
-    ActionInvoke InvHead]
-  relevantPayload | shouldParsePayload = rightToMaybe payload
-                  | otherwise = Nothing
-  path            = pathInfo req
-  method          = requestMethod req
-  hdrs            = requestHeaders req
-  qParams         = [(toS k, v)|(k,v) <- qString]
-  lookupHeader    = flip lookup hdrs
-  hasPrefer :: Text -> Bool
-  hasPrefer val   = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs
-    where
-        split :: BS.ByteString -> [Text]
-        split = map T.strip . T.split (==',') . toS
-  representation
-    | hasPrefer (show Full) = Full
-    | hasPrefer (show None) = None
-    | otherwise             = if action == ActionCreate
-                                then HeadersOnly -- Assume the user wants the Location header(for POST) by default
-                                else None
-  auth = fromMaybe "" $ lookupHeader hAuthorization
-  tokenStr = case T.split (== ' ') (toS auth) of
-    ("Bearer" : t : _) -> t
-    _                  -> ""
-  endingIn:: [Text] -> Text -> Bool
-  endingIn xx key = lastWord `elem` xx
-    where lastWord = last $ T.split (=='.') key
-
-  headerRange = rangeRequested hdrs
-  replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]
-  limitParams :: M.HashMap ByteString NonnegRange
-  limitParams  = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]
-  offsetParams :: M.HashMap ByteString NonnegRange
-  offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe =<< (toS <$> v))) | (k,v) <- qParams, isJust v, endingIn ["offset"] k]
-
-  urlRange = M.unionWith f limitParams offsetParams
-    where
-      f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)
-        where
-          l = fromMaybe 0 $ rangeLimit rl
-          o = rangeOffset ro
-  ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange
-
-{-|
-  Find the best match from a list of content types accepted by the
-  client in order of decreasing preference and a list of types
-  producible by the server.  If there is no match but the client
-  accepts */* then return the top server pick.
--}
-mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType
-mutuallyAgreeable sProduces cAccepts =
-  let exact = listToMaybe $ L.intersect cAccepts sProduces in
-  if isNothing exact && CTAny `elem` cAccepts
-     then listToMaybe sProduces
-     else exact
-
-type CsvData = V.Vector (M.HashMap Text BL.ByteString)
-
-{-|
-  Converts CSV like
-  a,b
-  1,hi
-  2,bye
-
-  into a JSON array like
-  [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
-
-  The reason for its odd signature is so that it can compose
-  directly with CSV.decodeByName
--}
-csvToJson :: (CSV.Header, CsvData) -> JSON.Value
-csvToJson (_, vals) =
-  JSON.Array $ V.map rowToJsonObj vals
- where
-  rowToJsonObj = JSON.Object .
-    M.map (\str ->
-        if str == "NULL"
-          then JSON.Null
-          else JSON.String $ toS str
-      )
-
-payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON
-payloadAttributes raw json =
-  -- Test that Array contains only Objects having the same keys
-  case json of
-    JSON.Array arr ->
-      case arr V.!? 0 of
-        Just (JSON.Object o) ->
-          let canonicalKeys = S.fromList $ M.keys o
-              areKeysUniform = all (\case
-                JSON.Object x -> S.fromList (M.keys x) == canonicalKeys
-                _ -> False) arr in
-          if areKeysUniform
-            then Just $ ProcessedJSON raw (PJArray $ V.length arr) canonicalKeys
-            else Nothing
-        Just _ -> Nothing
-        Nothing -> Just emptyPJArray
-
-    JSON.Object o -> Just $ ProcessedJSON raw PJObject (S.fromList $ M.keys o)
-
-    -- truncate everything else to an empty array.
-    _ -> Just emptyPJArray
-  where
-    emptyPJArray = ProcessedJSON (JSON.encode emptyArray) (PJArray 0) S.empty

src/PostgREST/AppState.hs

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

src/PostgREST/Auth.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase       #-}
 {-|
 Module      : PostgREST.Auth
 Description : PostgREST authorization functions.
@@ -12,102 +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 (
+{-# LANGUAGE RecordWildCards #-}
-    containsRole
+module PostgREST.Auth
+  ( containsRole
   , jwtClaims
-  , JWTAttempt(..)
+  , JWTClaims
-  , parseSecret
   ) where
 
-import qualified Crypto.JOSE.Types   as JOSE.Types
+import qualified Crypto.JWT          as JWT
 import qualified Data.Aeson          as JSON
 import qualified Data.HashMap.Strict as M
-import           Data.Vector         as V
+import qualified Data.Vector         as V
 
-import Control.Lens    (set)
+import Control.Lens            (set)
-import Data.Time.Clock (UTCTime)
+import Control.Monad.Except    (liftEither)
+import Data.Either.Combinators (mapLeft)
+import Data.Time.Clock         (UTCTime)
 
-import Control.Lens.Operators
+import PostgREST.Config (AppConfig (..), JSPath, JSPathExp (..))
-import Crypto.JWT
+import PostgREST.Error  (Error (..))
 
-import PostgREST.Types
 import Protolude
 
-{-|
-  Possible situations encountered with client JWTs
--}
-data JWTAttempt = JWTInvalid JWTError
-                | JWTMissingSecret
-                | JWTClaims (M.HashMap Text JSON.Value)
-                deriving (Eq, Show)
 
-{-|
+type JWTClaims = M.HashMap Text JSON.Value
-  Receives the JWT secret and audience (from config) and a JWT and returns a map
-  of JWT claims.
--}
-jwtClaims :: Maybe JWKSet -> Maybe StringOrURI -> LByteString -> UTCTime -> Maybe JSPath -> IO JWTAttempt
-jwtClaims _ _ "" _ _ = return $ JWTClaims M.empty
-jwtClaims secret audience payload time jspath =
-  case secret of
-    Nothing -> return JWTMissingSecret
-    Just s -> do
-      let validation = set allowedSkew 1 $ defaultJWTValidationSettings (maybe (const True) (==) audience)
-      eJwt <- runExceptT $ do
-        jwt <- decodeCompact payload
-        verifyClaimsAt validation s time jwt
-      return $ case eJwt of
-        Left e    -> JWTInvalid e
-        Right jwt -> JWTClaims $ claims2map jwt jspath
 
-{-|
+-- | Receives the JWT secret and audience (from config) and a JWT and returns a
-  Turn JWT ClaimSet into something easier to work with,
+-- map of JWT claims.
-  also here the jspath is applied to put the "role" in the map
+jwtClaims :: Monad m =>
--}
+  AppConfig -> LByteString -> UTCTime -> ExceptT Error m JWTClaims
-claims2map :: ClaimsSet -> Maybe JSPath -> M.HashMap Text JSON.Value
+jwtClaims _ "" _ = return M.empty
-claims2map claims jspath = (\case
+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
+
+    audienceCheck :: JWT.StringOrURI -> Bool
+    audienceCheck = maybe (const True) (==) configJwtAudience
+
+    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) ->
-      let role = maybe M.empty (M.singleton "role") $
+      M.delete "role" o `M.union` role val
-                 walkJSPath (Just val) =<< jspath in
+    _ ->
-      M.delete "role" o `M.union` role -- mutating the map
+      M.empty
-    _ -> M.empty
+  where
-  ) $ JSON.toJSON claims
+    role value =
+      maybe M.empty (M.singleton "role") $ walkJSPath (Just value) jspath
 
-walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value
+    walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value
-walkJSPath x                      []                = x
+    walkJSPath x                      []                = x
-walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest
+    walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest
-walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest
+    walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest
-walkJSPath _                      _                 = Nothing
+    walkJSPath _                      _                 = Nothing
 
-{-|
+-- | Whether a response from jwtClaims contains a role claim
-  Whether a response from jwtClaims contains a role claim
+containsRole :: JWTClaims -> Bool
--}
+containsRole = M.member "role"
-containsRole :: JWTAttempt -> Bool
-containsRole (JWTClaims claims) = M.member "role" claims
-containsRole _                  = False
-
-{-|
-  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.
--}
-parseSecret :: ByteString -> JWKSet
-parseSecret str =
-  fromMaybe (maybe secret (\jwk' -> JWKSet [jwk']) maybeJWK)
-    maybeJWKSet
- where
-  maybeJWKSet = JSON.decode (toS str) :: Maybe JWKSet
-  maybeJWK = JSON.decode (toS str) :: Maybe JWK
-  secret = JWKSet [jwkFromSecret str]
-
-{-|
-  Internal helper to generate a symmetric HMAC-SHA256 JWK from a text secret.
--}
-jwkFromSecret :: ByteString -> JWK
-jwkFromSecret key =
-  fromKeyMaterial km
-    & jwkUse ?~ Sig
-    & jwkAlg ?~ JWSAlg HS256
- where
-  km = OctKeyMaterial (OctKeyParameters (JOSE.Types.Base64Octets key))

src/PostgREST/CLI.hs

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

src/PostgREST/Config.hs

@@ -1,219 +1,363 @@
 {-|
 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.
 -}
-{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards       #-}
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
 
-module PostgREST.Config ( prettyVersion
+module PostgREST.Config
-                        , docsVersion
+  ( AppConfig (..)
-                        , readOptions
+  , Environment
-                        , corsPolicy
+  , JSPath
-                        , AppConfig (..)
+  , JSPathExp(..)
-                        , configPoolTimeout'
+  , LogLevel(..)
-                        )
+  , OpenAPIMode(..)
-       where
+  , Proxy(..)
+  , toText
+  , isMalformedProxyUri
+  , readAppConfig
+  , readPGRSTEnvironment
+  , toURI
+  , parseSecret
+  ) where
 
-import qualified Data.ByteString              as B
+import qualified Crypto.JOSE.Types      as JOSE
-import qualified Data.ByteString.Char8        as BS
+import qualified Crypto.JWT             as JWT
-import qualified Data.CaseInsensitive         as CI
+import qualified Data.Aeson             as JSON
-import qualified Data.Configurator            as C
+import qualified Data.ByteString        as B
-import qualified Text.PrettyPrint.ANSI.Leijen as L
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Char8  as BS
+import qualified Data.Configurator      as C
+import qualified Data.Map.Strict        as M
+import qualified Data.Text              as T
 
-import Control.Exception           (Handler (..))
+import qualified GHC.Show (show)
-import Control.Lens                (preview)
-import Control.Monad               (fail)
-import Crypto.JWT                  (StringOrURI, stringOrUri)
-import Data.List                   (lookup)
-import Data.List.NonEmpty          (NonEmpty, fromList)
-import Data.Scientific             (floatingOrInteger)
-import Data.Text                   (dropEnd, dropWhileEnd,
-                                    intercalate, lines, splitOn,
-                                    strip, take, unpack)
-import Data.Text.Encoding          (encodeUtf8)
-import Data.Text.IO                (hPutStrLn)
-import Data.Version                (versionBranch)
-import Development.GitRev          (gitHash)
-import Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
-import Numeric                     (readOct)
-import Paths_postgrest             (version)
-import System.IO.Error             (IOError)
-import System.Posix.Types          (FileMode)
 
-import Control.Applicative
+import Control.Lens            (preview)
-import Data.Monoid
+import Control.Monad           (fail)
-import Network.Wai
+import Crypto.JWT              (JWK, JWKSet, StringOrURI, stringOrUri)
-import Options.Applicative          hiding (str)
+import Data.Aeson              (encode, toJSON)
-import Text.Heredoc
+import Data.Either.Combinators (mapLeft)
-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))
+import Data.List               (lookup)
+import Data.List.NonEmpty      (fromList, toList)
+import Data.Maybe              (fromJust)
+import Data.Scientific         (floatingOrInteger)
+import Data.Time.Clock         (NominalDiffTime)
+import Numeric                 (readOct, showOct)
+import System.Environment      (getEnvironment)
+import System.Posix.Types      (FileMode)
 
-import PostgREST.Error   (ApiRequestError (..))
+import PostgREST.Config.JSPath           (JSPath, JSPathExp (..),
-import PostgREST.Parsers (pRoleClaimKey)
+                                          pRoleClaimKey)
-import PostgREST.Types   (JSPath, JSPathExp (..))
+import PostgREST.Config.Proxy            (Proxy (..),
-import Protolude         hiding (concat, hPutStrLn, intercalate, null,
+                                          isMalformedProxyUri, toURI)
-                          take, (<>))
+import PostgREST.DbStructure.Identifiers (QualifiedIdentifier, toQi)
+
+import Protolude      hiding (Proxy, toList, toS)
+import Protolude.Conv (toS)
 
 
-
+data AppConfig = AppConfig
--- | Config file settings for the server
+  { configAppSettings           :: [(Text, Text)]
-data AppConfig = AppConfig {
+  , configDbAnonRole            :: Text
-    configDatabase          :: Text
+  , configDbChannel             :: Text
-  , configAnonRole          :: Text
+  , configDbChannelEnabled      :: Bool
-  , configOpenAPIProxyUri   :: Maybe Text
+  , configDbExtraSearchPath     :: [Text]
-  , configSchemas           :: NonEmpty Text
+  , configDbMaxRows             :: Maybe Integer
-  , configHost              :: Text
+  , configDbPoolSize            :: Int
-  , configPort              :: Int
+  , configDbPoolTimeout         :: NominalDiffTime
-  , configSocket            :: Maybe FilePath
+  , configDbPreRequest          :: Maybe QualifiedIdentifier
-  , configSocketMode        :: Either Text FileMode
+  , configDbPreparedStatements  :: Bool
-
+  , configDbRootSpec            :: Maybe QualifiedIdentifier
-  , configJwtSecret         :: Maybe B.ByteString
+  , configDbSchemas             :: NonEmpty Text
-  , configJwtSecretIsBase64 :: Bool
+  , configDbConfig              :: Bool
-  , configJwtAudience       :: Maybe StringOrURI
+  , configDbTxAllowOverride     :: Bool
-
+  , configDbTxRollbackAll       :: Bool
-  , configPool              :: Int
+  , configDbUri                 :: Text
-  , configPoolTimeout       :: Int
+  , configFilePath              :: Maybe FilePath
-  , configMaxRows           :: Maybe Integer
+  , configJWKS                  :: Maybe JWKSet
-  , configReqCheck          :: Maybe Text
+  , configJwtAudience           :: Maybe StringOrURI
-  , configQuiet             :: Bool
+  , configJwtRoleClaimKey       :: JSPath
-  , configSettings          :: [(Text, Text)]
+  , configJwtSecret             :: Maybe B.ByteString
-  , configRoleClaimKey      :: Either ApiRequestError JSPath
+  , configJwtSecretIsBase64     :: Bool
-  , configExtraSearchPath   :: [Text]
+  , configLogLevel              :: LogLevel
-
+  , configOpenApiMode           :: OpenAPIMode
-  , configRootSpec          :: Maybe Text
+  , configOpenApiServerProxyUri :: Maybe Text
-  , configRawMediaTypes     :: [B.ByteString]
+  , configRawMediaTypes         :: [B.ByteString]
+  , configServerHost            :: Text
+  , configServerPort            :: Int
+  , configServerUnixSocket      :: Maybe FilePath
+  , configServerUnixSocketMode  :: FileMode
   }
 
-configPoolTimeout' :: (Fractional a) => AppConfig -> a
+data LogLevel = LogCrit | LogError | LogWarn | LogInfo
-configPoolTimeout' =
-  fromRational . toRational . configPoolTimeout
 
+instance Show LogLevel where
+  show LogCrit  = "crit"
+  show LogError = "error"
+  show LogWarn  = "warn"
+  show LogInfo  = "info"
 
-defaultCorsPolicy :: CorsResourcePolicy
+data OpenAPIMode = OAFollowPriv | OAIgnorePriv | OADisabled
-defaultCorsPolicy =  CorsResourcePolicy Nothing
+  deriving Eq
-  ["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
+instance Show OpenAPIMode where
-corsPolicy :: Request -> Maybe CorsResourcePolicy
+  show OAFollowPriv = "follow-privileges"
-corsPolicy req = case lookup "origin" headers of
+  show OAIgnorePriv = "ignore-privileges"
-  Just origin -> Just defaultCorsPolicy {
+  show OADisabled   = "disabled"
-      corsOrigins = Just ([origin], True)
+
-    , corsRequestHeaders = "Authentication":accHeaders
+-- | Dump the config
-    , corsExposedHeaders = Just [
+toText :: AppConfig -> Text
-        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
+toText conf =
-      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
+  unlines $ (\(k, v) -> k <> " = " <> v) <$> pgrstSettings ++ appSettings
+  where
+    -- apply conf to all pgrst settings
+    pgrstSettings = (\(k, v) -> (k, v conf)) <$>
+      [("db-anon-role",              q . configDbAnonRole)
+      ,("db-channel",                q . configDbChannel)
+      ,("db-channel-enabled",            T.toLower . show . configDbChannelEnabled)
+      ,("db-extra-search-path",      q . T.intercalate "," . configDbExtraSearchPath)
+      ,("db-max-rows",                   maybe "\"\"" show . configDbMaxRows)
+      ,("db-pool",                       show . configDbPoolSize)
+      ,("db-pool-timeout",               show . floor . configDbPoolTimeout)
+      ,("db-pre-request",            q . maybe mempty show . configDbPreRequest)
+      ,("db-prepared-statements",        T.toLower . show . configDbPreparedStatements)
+      ,("db-root-spec",              q . maybe mempty show . configDbRootSpec)
+      ,("db-schemas",                q . T.intercalate "," . toList . configDbSchemas)
+      ,("db-config",                 q . T.toLower . show . configDbConfig)
+      ,("db-tx-end",                 q . showTxEnd)
+      ,("db-uri",                    q . configDbUri)
+      ,("jwt-aud",                       toS . encode . maybe "" toJSON . configJwtAudience)
+      ,("jwt-role-claim-key",        q . T.intercalate mempty . fmap show . configJwtRoleClaimKey)
+      ,("jwt-secret",                q . toS . showJwtSecret)
+      ,("jwt-secret-is-base64",          T.toLower . show . configJwtSecretIsBase64)
+      ,("log-level",                 q . show . configLogLevel)
+      ,("openapi-mode",              q . show . configOpenApiMode)
+      ,("openapi-server-proxy-uri",  q . fromMaybe mempty . configOpenApiServerProxyUri)
+      ,("raw-media-types",           q . toS . B.intercalate "," . configRawMediaTypes)
+      ,("server-host",               q . configServerHost)
+      ,("server-port",                   show . configServerPort)
+      ,("server-unix-socket",        q . maybe mempty T.pack . configServerUnixSocket)
+      ,("server-unix-socket-mode",   q . T.pack . showSocketMode)
       ]
-    }
-  Nothing -> Nothing
-  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 -> []
 
--- | User friendly version number
+    -- quote all app.settings
-prettyVersion :: Text
+    appSettings = second q <$> configAppSettings conf
-prettyVersion =
-  intercalate "." (map show $ versionBranch version)
-  <> " (" <> take 7 $(gitHash) <> ")"
 
--- | Version number used in docs
+    -- quote strings and replace " with \"
-docsVersion :: Text
+    q s = "\"" <> T.replace "\"" "\\\"" s <> "\""
-docsVersion = "v" <> dropEnd 1 (dropWhileEnd (/= '.') prettyVersion)
 
--- | Function to read and parse options from the command line
+    showTxEnd c = case (configDbTxRollbackAll c, configDbTxAllowOverride c) of
-readOptions :: IO AppConfig
+      ( False, False ) -> "commit"
-readOptions = do
+      ( False, True  ) -> "commit-allow-override"
-  -- First read the config file path from command line
+      ( True , False ) -> "rollback"
-  cfgPath <- customExecParser parserPrefs opts
+      ( True , True  ) -> "rollback-allow-override"
-  -- Now read the actual config file
+    showJwtSecret c
-  conf <- catches (C.load cfgPath)
+      | configJwtSecretIsBase64 c = B64.encode secret
-    [ Handler (\(ex :: IOError)    -> exitErr $ "Cannot open config file:\n\t" <> show ex)
+      | otherwise                 = toS secret
-    , Handler (\(C.ParseError err) -> exitErr $ "Error parsing config file:\n" <> err)
+      where
-    ]
+        secret = fromMaybe mempty $ configJwtSecret c
+    showSocketMode c = showOct (configServerUnixSocketMode c) mempty
 
-  case C.runParser parseConfig conf of
+-- This class is needed for the polymorphism of overrideFromDbOrEnvironment
+-- because C.required and C.optional have different signatures
+class JustIfMaybe a b where
+  justIfMaybe :: a -> b
+
+instance JustIfMaybe a a where
+  justIfMaybe a = a
+
+instance JustIfMaybe a (Maybe a) where
+  justIfMaybe a = Just a
+
+-- | Reads and parses the config and overrides its parameters from env vars,
+-- files or db settings.
+readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> IO (Either Text AppConfig)
+readAppConfig dbSettings optPath prevDbUri = do
+  env <- readPGRSTEnvironment
+  -- if no filename provided, start with an empty map to read config from environment
+  conf <- maybe (return $ Right M.empty) loadConfig optPath
+
+  case C.runParser (parser optPath env dbSettings) =<< mapLeft show conf of
     Left err ->
-      exitErr $ "Error parsing config file:\n\t" <> err
+      return . Left $ "Error in config " <> err
-    Right appConf ->
+    Right parsedConfig ->
-      return appConf
+      Right <$> decodeLoadFiles parsedConfig
-
   where
-    parseConfig =
+    -- Both C.ParseError and IOError are shown here
-      AppConfig
+    loadConfig :: FilePath -> IO (Either SomeException C.Config)
-        <$> reqString "db-uri"
+    loadConfig = try . C.load
-        <*> reqString "db-anon-role"
-        <*> optString "server-proxy-uri"
-        <*> (fromList . splitOnCommas <$> reqValue "db-schema")
-        <*> (fromMaybe "!4" <$> optString "server-host")
-        <*> (fromMaybe 3000 <$> optInt "server-port")
-        <*> (fmap unpack <$> optString "server-unix-socket")
-        <*> parseSocketFileMode "server-unix-socket-mode"
-        <*> (fmap encodeUtf8 <$> optString "jwt-secret")
-        <*> (fromMaybe False <$> optBool "secret-is-base64")
-        <*> parseJwtAudience "jwt-aud"
-        <*> (fromMaybe 10 <$> optInt "db-pool")
-        <*> (fromMaybe 10 <$> optInt "db-pool-timeout")
-        <*> optInt "max-rows"
-        <*> optString "pre-request"
-        <*> pure False
-        <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value)
-        <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key")
-        <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path")
-        <*> optString "root-spec"
-        <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")
 
-    parseSocketFileMode :: C.Key -> C.Parser C.Config (Either Text FileMode)
+    decodeLoadFiles :: AppConfig -> IO AppConfig
+    decodeLoadFiles parsedConfig =
+      decodeJWKS <$>
+        (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig)
+
+parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> C.Parser C.Config AppConfig
+parser optPath env dbSettings =
+  AppConfig
+    <$> parseAppSettings "app.settings"
+    <*> reqString "db-anon-role"
+    <*> (fromMaybe "pgrst" <$> optString "db-channel")
+    <*> (fromMaybe True <$> optBool "db-channel-enabled")
+    <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path")
+    <*> optWithAlias (optInt "db-max-rows")
+                     (optInt "max-rows")
+    <*> (fromMaybe 10 <$> optInt "db-pool")
+    <*> (fromIntegral . fromMaybe 10 <$> optInt "db-pool-timeout")
+    <*> (fmap toQi <$> optWithAlias (optString "db-pre-request")
+                                    (optString "pre-request"))
+    <*> (fromMaybe True <$> optBool "db-prepared-statements")
+    <*> (fmap toQi <$> optWithAlias (optString "db-root-spec")
+                                    (optString "root-spec"))
+    <*> (fromList . splitOnCommas <$> reqWithAlias (optValue "db-schemas")
+                                                   (optValue "db-schema")
+                                                   "missing key: either db-schemas or db-schema must be set")
+    <*> (fromMaybe True <$> optBool "db-config")
+    <*> parseTxEnd "db-tx-end" snd
+    <*> parseTxEnd "db-tx-end" fst
+    <*> reqString "db-uri"
+    <*> pure optPath
+    <*> pure Nothing
+    <*> parseJwtAudience "jwt-aud"
+    <*> parseRoleClaimKey "jwt-role-claim-key" "role-claim-key"
+    <*> (fmap encodeUtf8 <$> optString "jwt-secret")
+    <*> (fromMaybe False <$> optWithAlias
+          (optBool "jwt-secret-is-base64")
+          (optBool "secret-is-base64"))
+    <*> parseLogLevel "log-level"
+    <*> parseOpenAPIMode "openapi-mode"
+    <*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri"
+    <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")
+    <*> (fromMaybe "!4" <$> optString "server-host")
+    <*> (fromMaybe 3000 <$> optInt "server-port")
+    <*> (fmap T.unpack <$> optString "server-unix-socket")
+    <*> parseSocketFileMode "server-unix-socket-mode"
+  where
+    parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
+    parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value
+      where
+        addFromEnv f = M.toList $ M.union fromEnv $ M.fromList f
+        fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env
+        normalize k = ("app.settings." <>) <$> T.stripPrefix "PGRST_APP_SETTINGS_" (toS k)
+
+    parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode
     parseSocketFileMode k =
-      C.optional k C.string >>= \case
+      optString k >>= \case
-        Nothing -> pure $ Right 432 -- return default 660 mode if no value was provided
+        Nothing -> pure 432 -- return default 660 mode if no value was provided
         Just fileModeText ->
-          case (readOct . unpack) fileModeText of
+          case readOct $ T.unpack fileModeText of
             []              ->
-              pure $ Left "Invalid server-unix-socket-mode: not an octal"
+              fail "Invalid server-unix-socket-mode: not an octal"
             (fileMode, _):_ ->
               if fileMode < 384 || fileMode > 511
-                then pure $ Left "Invalid server-unix-socket-mode: needs to be between 600 and 777"
+                then fail "Invalid server-unix-socket-mode: needs to be between 600 and 777"
-                else pure $ Right fileMode
+                else pure fileMode
+
+    parseOpenAPIMode :: C.Key -> C.Parser C.Config OpenAPIMode
+    parseOpenAPIMode k =
+      optString k >>= \case
+        Nothing                  -> pure OAFollowPriv
+        Just "follow-privileges" -> pure OAFollowPriv
+        Just "ignore-privileges" -> pure OAIgnorePriv
+        Just "disabled"          -> pure OADisabled
+        Just _                   -> fail "Invalid openapi-mode. Check your configuration."
+
+    parseOpenAPIServerProxyURI :: C.Key -> C.Parser C.Config (Maybe Text)
+    parseOpenAPIServerProxyURI k =
+      optString k >>= \case
+        Nothing                            -> pure Nothing
+        Just val | isMalformedProxyUri val -> fail "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
+                 | otherwise               -> pure $ Just val
 
     parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI)
     parseJwtAudience k =
-      C.optional k C.string >>= \case
+      optString k >>= \case
         Nothing -> pure Nothing -- no audience in config file
-        Just aud -> case preview stringOrUri (unpack aud) of
+        Just aud -> case preview stringOrUri (T.unpack aud) of
           Nothing -> fail "Invalid Jwt audience. Check your configuration."
-          (Just "") -> pure Nothing
           aud' -> pure aud'
 
-    reqString :: C.Key -> C.Parser C.Config Text
+    parseLogLevel :: C.Key -> C.Parser C.Config LogLevel
-    reqString k = C.required k C.string
+    parseLogLevel k =
+      optString k >>= \case
+        Nothing      -> pure LogError
+        Just "crit"  -> pure LogCrit
+        Just "error" -> pure LogError
+        Just "warn"  -> pure LogWarn
+        Just "info"  -> pure LogInfo
+        Just _       -> fail "Invalid logging level. Check your configuration."
 
-    reqValue :: C.Key -> C.Parser C.Config C.Value
+    parseTxEnd :: C.Key -> ((Bool, Bool) -> Bool) -> C.Parser C.Config Bool
-    reqValue k = C.required k C.value
+    parseTxEnd k f =
+      optString k >>= \case
+        --                                          RollbackAll AllowOverride
+        Nothing                        -> pure $ f (False,      False)
+        Just "commit"                  -> pure $ f (False,      False)
+        Just "commit-allow-override"   -> pure $ f (False,      True)
+        Just "rollback"                -> pure $ f (True,       False)
+        Just "rollback-allow-override" -> pure $ f (True,       True)
+        Just _                         -> fail "Invalid transaction termination. Check your configuration."
+
+    parseRoleClaimKey :: C.Key -> C.Key -> C.Parser C.Config JSPath
+    parseRoleClaimKey k al =
+      optWithAlias (optString k) (optString al) >>= \case
+        Nothing  -> pure [JSPKey "role"]
+        Just rck -> either (fail . show) pure $ pRoleClaimKey rck
+
+    reqWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> [Char] -> C.Parser C.Config a
+    reqWithAlias orig alias err =
+      orig >>= \case
+        Just v  -> pure v
+        Nothing ->
+          alias >>= \case
+            Just v  -> pure v
+            Nothing -> fail err
+
+    optWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a)
+    optWithAlias orig alias =
+      orig >>= \case
+        Just v  -> pure $ Just v
+        Nothing -> alias
+
+    reqString :: C.Key -> C.Parser C.Config Text
+    reqString k = overrideFromDbOrEnvironment C.required k coerceText
 
     optString :: C.Key -> C.Parser C.Config (Maybe Text)
-    optString k = mfilter (/= "") <$> C.optional k C.string
+    optString k = mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText
 
     optValue :: C.Key -> C.Parser C.Config (Maybe C.Value)
-    optValue k = C.optional k C.value
+    optValue k = overrideFromDbOrEnvironment C.optional k identity
 
     optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i)
-    optInt k = join <$> C.optional k (coerceInt <$> C.value)
+    optInt k = join <$> overrideFromDbOrEnvironment C.optional k coerceInt
 
     optBool :: C.Key -> C.Parser C.Config (Maybe Bool)
-    optBool k = join <$> C.optional k (coerceBool <$> C.value)
+    optBool k = join <$> overrideFromDbOrEnvironment C.optional k coerceBool
+
+    overrideFromDbOrEnvironment :: JustIfMaybe a b =>
+                               (C.Key -> C.Parser C.Value a -> C.Parser C.Config b) ->
+                               C.Key -> (C.Value -> a) -> C.Parser C.Config b
+    overrideFromDbOrEnvironment necessity key coercion =
+      case reloadableDbSetting <|> M.lookup envVarName env of
+        Just dbOrEnvVal -> pure $ justIfMaybe $ coercion $ C.String dbOrEnvVal
+        Nothing  -> necessity key (coercion <$> C.value)
+      where
+        dashToUnderscore '-' = '_'
+        dashToUnderscore c   = c
+        envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key)
+        reloadableDbSetting =
+          let dbSettingName = T.pack $ dashToUnderscore <$> toS key in
+          if dbSettingName `notElem` [
+            "server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "log_level",
+            "db_anon_role", "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_timeout", "db_config"]
+          then lookup dbSettingName dbSettings
+          else Nothing
 
     coerceText :: C.Value -> Text
     coerceText (C.String s) = s
@@ -226,85 +370,77 @@ readOptions = do
 
     coerceBool :: C.Value -> Maybe Bool
     coerceBool (C.Bool b)   = Just b
-    coerceBool (C.String b) = readMaybe $ toS b
+    coerceBool (C.String s) =
+      -- parse all kinds of text: True, true, TRUE, "true", ...
+      case readMaybe . toS $ T.toTitle $ T.filter isAlpha $ toS s of
+        Just b  -> Just b
+        -- numeric instead?
+        Nothing -> (> 0) <$> (readMaybe $ toS s :: Maybe Integer)
     coerceBool _            = Nothing
 
-    parseRoleClaimKey :: C.Value -> Either ApiRequestError JSPath
-    parseRoleClaimKey (C.String s) = pRoleClaimKey s
-    parseRoleClaimKey v            = pRoleClaimKey $ show v
-
     splitOnCommas :: C.Value -> [Text]
-    splitOnCommas (C.String s) = strip <$> splitOn "," s
+    splitOnCommas (C.String s) = T.strip <$> T.splitOn "," s
     splitOnCommas _            = []
 
-    opts = info (helper <*> pathParser) $
+-- | Read the JWT secret from a file if configJwtSecret is actually a
-             fullDesc
+-- filepath(has @ as its prefix). To check if the JWT secret is provided is
-             <> progDesc (
+-- in fact a file path, it must be decoded as 'Text' to be processed.
-                 "PostgREST "
+readSecretFile :: AppConfig -> IO AppConfig
-                 <> toS prettyVersion
+readSecretFile conf =
-                 <> " / create a REST API to an existing Postgres database"
+  maybe (return conf) readSecret maybeFilename
-               )
+  where
-             <> footerDoc (Just $
+    maybeFilename = T.stripPrefix "@" . decodeUtf8 =<< configJwtSecret conf
-                 text "Example Config File:"
+    readSecret filename = do
-                 L.<> nest 2 (hardline L.<> exampleCfg)
+      jwtSecret <- chomp <$> BS.readFile (toS filename)
-               )
+      return $ conf { configJwtSecret = Just jwtSecret }
+    chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs)
 
-    parserPrefs = prefs showHelpOnError
+decodeSecret :: AppConfig -> IO AppConfig
+decodeSecret conf@AppConfig{..} =
+  case (configJwtSecretIsBase64, configJwtSecret) of
+    (True, Just secret) ->
+      either fail (return . updateSecret) $ decodeB64 secret
+    _ -> return conf
+  where
+    updateSecret bs = conf { configJwtSecret = Just bs }
+    decodeB64 = B64.decode . encodeUtf8 . T.strip . replaceUrlChars . decodeUtf8
+    replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "="
 
-    exitErr :: Text -> IO a
+-- | Parse `jwt-secret` configuration option and turn into a JWKSet.
-    exitErr err = do
+--
-      hPutStrLn stderr err
+-- There are three ways to specify `jwt-secret`: text secret, JSON Web Key
-      exitFailure
+-- (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JWKSet
+-- with one key and the last is converted as is.
+decodeJWKS :: AppConfig -> AppConfig
+decodeJWKS conf =
+  conf { configJWKS = parseSecret <$> configJwtSecret conf }
 
-    exampleCfg :: Doc
+parseSecret :: ByteString -> JWKSet
-    exampleCfg = vsep . map (text . toS) . lines $
+parseSecret bytes =
-      [str|db-uri = "postgres://user:pass@localhost:5432/dbname"
+  fromMaybe (maybe secret (\jwk' -> JWT.JWKSet [jwk']) maybeJWK)
-          |db-schema = "public" # this schema gets added to the search_path of every request
+    maybeJWKSet
-          |db-anon-role = "postgres"
+  where
-          |db-pool = 10
+    maybeJWKSet = JSON.decode (toS bytes) :: Maybe JWKSet
-          |db-pool-timeout = 10
+    maybeJWK = JSON.decode (toS bytes) :: Maybe JWK
-          |
+    secret = JWT.JWKSet [JWT.fromKeyMaterial keyMaterial]
-          |server-host = "!4"
+    keyMaterial = JWT.OctKeyMaterial . JWT.OctKeyParameters $ JOSE.Base64Octets bytes
-          |server-port = 3000
-          |
-          |## unix socket location
-          |## if specified it takes precedence over server-port
-          |# server-unix-socket = "/tmp/pgrst.sock"
-          |## unix socket file mode
-          |## when none is provided, 660 is applied by default
-          |# server-unix-socket-mode = "660"
-          |
-          |## base url for swagger output
-          |# openapi-server-proxy-uri = ""
-          |
-          |## choose a secret, JSON Web Key (or set) to enable JWT auth
-          |## (use "@filename" to load from separate file)
-          |# jwt-secret = "secret_with_at_least_32_characters"
-          |# secret-is-base64 = false
-          |# jwt-aud = "your_audience_claim"
-          |
-          |## limit rows in response
-          |# max-rows = 1000
-          |
-          |## stored proc to exec immediately after auth
-          |# pre-request = "stored_proc_name"
-          |
-          |## jspath to the role claim key
-          |# role-claim-key = ".role"
-          |
-          |## extra schemas to add to the search_path of every request
-          |# db-extra-search-path = "extensions, util"
-          |
-          |## stored proc that overrides the root "/" spec
-          |## it must be inside the db-schema
-          |# root-spec = "stored_proc_name"
-          |
-          |## content types to produce raw output
-          |# raw-media-types="image/png, image/jpg"
-          |]
 
-pathParser :: Parser FilePath
+-- | Read database uri from a separate file if `db-uri` is a filepath.
-pathParser =
+readDbUriFile :: Maybe Text -> AppConfig -> IO AppConfig
-  strArgument $
+readDbUriFile maybeDbUri conf =
-    metavar "FILENAME" <>
+  case maybeDbUri of
-    help "Path to configuration file"
+    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 P
+import qualified Hasql.Session              as H
+import qualified Hasql.Statement            as H
+import qualified Hasql.Transaction          as HT
+import qualified Hasql.Transaction.Sessions as HT
+
+import Text.InterpolatedString.Perl6 (q)
+
+import Protolude
+
+queryPgVersion :: H.Session PgVersion
+queryPgVersion = H.statement mempty $ H.Statement sql HE.noParams versionRow False
+  where
+    sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')"
+    versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text
+
+queryDbSettings :: P.Pool -> Bool -> IO (Either P.UsageError [(Text, Text)])
+queryDbSettings pool prepared =
+  let transaction = if prepared then HT.transaction else HT.unpreparedTransaction in
+  P.use pool . transaction HT.ReadCommitted HT.Read $
+    HT.statement mempty dbSettingsStatement
+
+-- | Get db settings from the connection role. Global settings will be overridden by database specific settings.
+dbSettingsStatement :: H.Statement () [(Text, Text)]
+dbSettingsStatement = H.Statement sql HE.noParams decodeSettings False
+  where
+    sql = [q|
+      with
+      role_setting as (
+        select setdatabase, unnest(setconfig) as setting from pg_catalog.pg_db_role_setting
+        where setrole = current_user::regrole::oid
+          and setdatabase in (0, (select oid from pg_catalog.pg_database where datname = current_catalog))
+      ),
+      kv_settings as (
+        select setdatabase, split_part(setting, '=', 1) as k, split_part(setting, '=', 2) as value from role_setting
+        where setting like 'pgrst.%'
+      )
+      select distinct on (key) replace(k, 'pgrst.', '') as key, value
+      from kv_settings
+      order by key, setdatabase desc;
+    |]
+    decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text
+
+column :: HD.Value a -> HD.Row a
+column = HD.column . HD.nonNullable

src/PostgREST/Config/JSPath.hs

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

src/PostgREST/Config/PgVersion.hs

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

src/PostgREST/Config/Proxy.hs

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

src/PostgREST/ContentType.hs

@@ -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/DbStructure/Identifiers.hs

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

src/PostgREST/DbStructure/Proc.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+
+module PostgREST.DbStructure.Proc
+  ( PgArg(..)
+  , PgType(..)
+  , ProcDescription(..)
+  , ProcVolatility(..)
+  , ProcsMap
+  , RetType(..)
+  , procReturnsScalar
+  , procReturnsSingle
+  , procTableName
+  , specifiedProcArgs
+  ) where
+
+import qualified Data.Aeson          as JSON
+import qualified Data.HashMap.Strict as M
+import qualified Data.Set            as S
+
+import PostgREST.DbStructure.Identifiers (FieldName,
+                                          QualifiedIdentifier (..),
+                                          Schema, TableName)
+
+import Protolude
+
+
+data PgArg = PgArg
+  { pgaName :: Text
+  , pgaType :: Text
+  , pgaReq  :: Bool
+  , pgaVar  :: Bool
+  }
+  deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data PgType
+  = Scalar
+  | Composite QualifiedIdentifier
+  deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data RetType
+  = Single PgType
+  | SetOf PgType
+  deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data ProcVolatility
+  = Volatile
+  | Stable
+  | Immutable
+  deriving (Eq, Ord, Generic, JSON.ToJSON)
+
+data ProcDescription = ProcDescription
+  { pdSchema      :: Schema
+  , pdName        :: Text
+  , pdDescription :: Maybe Text
+  , pdArgs        :: [PgArg]
+  , pdReturnType  :: RetType
+  , pdVolatility  :: ProcVolatility
+  , pdHasVariadic :: Bool
+  }
+  deriving (Eq, Generic, JSON.ToJSON)
+
+-- Order by least number of args in the case of overloaded functions
+instance Ord ProcDescription where
+  ProcDescription schema1 name1 des1 args1 rt1 vol1 hasVar1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2 hasVar2
+    | schema1 == schema2 && name1 == name2 && length args1 < length args2  = LT
+    | schema2 == schema2 && name1 == name2 && length args1 > length args2  = GT
+    | otherwise = (schema1, name1, des1, args1, rt1, vol1, hasVar1) `compare` (schema2, name2, des2, args2, rt2, vol2, hasVar2)
+
+-- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription).
+-- | It uses a HashMap for a faster lookup.
+type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
+
+{-|
+  Search the procedure parameters by matching them with the specified keys.
+  If the key doesn't match a parameter, a parameter with a default type "text" is assumed.
+-}
+specifiedProcArgs :: S.Set FieldName -> ProcDescription -> [PgArg]
+specifiedProcArgs keys proc =
+  (\k -> fromMaybe (PgArg k "text" True False) (find ((==) k . pgaName) (pdArgs proc))) <$> S.toList keys
+
+procReturnsScalar :: ProcDescription -> Bool
+procReturnsScalar proc = case proc of
+  ProcDescription{pdReturnType = (Single Scalar)} -> True
+  ProcDescription{pdReturnType = (SetOf Scalar)}  -> True
+  _                                               -> False
+
+procReturnsSingle :: ProcDescription -> Bool
+procReturnsSingle proc = case proc of
+  ProcDescription{pdReturnType = (Single _)} -> True
+  _                                          -> False
+
+procTableName :: ProcDescription -> Maybe TableName
+procTableName proc = case pdReturnType proc of
+  SetOf  (Composite qi) -> Just $ qiName qi
+  Single (Composite qi) -> Just $ qiName qi
+  _                     -> Nothing

src/PostgREST/DbStructure/Relationship.hs

@@ -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

@@ -3,17 +3,17 @@ Module      : PostgREST.Error
 Description : PostgREST error HTTP responses
 -}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RecordWildCards #-}
 
-module PostgREST.Error (
+module PostgREST.Error
-  errorResponseFor
+  ( errorResponseFor
-, ApiRequestError(..)
+  , ApiRequestError(..)
-, PgError(..)
+  , PgError(..)
-, SimpleError(..)
+  , Error(..)
-, errorPayload
+  , errorPayload
-, checkIsFatal
+  , checkIsFatal
-, singularityError
+  , singularityError
-) where
+  ) where
 
 import qualified Data.Aeson                as JSON
 import qualified Data.Text                 as T
@@ -23,12 +23,21 @@ import qualified Network.HTTP.Types.Status as HT
 
 import Data.Aeson  ((.=))
 import Network.Wai (Response, responseLBS)
-import Text.Read   (readMaybe)
 
-import Network.HTTP.Types.Header
+import Network.HTTP.Types.Header (Header)
 
-import PostgREST.Types
+import           PostgREST.ContentType (ContentType (..))
-import Protolude
+import qualified PostgREST.ContentType as ContentType
+
+import PostgREST.DbStructure.Proc         (PgArg (..),
+                                           ProcDescription (..))
+import PostgREST.DbStructure.Relationship (Cardinality (..),
+                                           Junction (..),
+                                           Relationship (..))
+import PostgREST.DbStructure.Table        (Column (..), Table (..))
+
+import Protolude      hiding (toS)
+import Protolude.Conv (toS, toSL)
 
 
 class (JSON.ToJSON a) => PgrstError a where
@@ -49,26 +58,29 @@ data ApiRequestError
   | InvalidBody ByteString
   | ParseRequestError Text Text
   | NoRelBetween Text Text
-  | AmbiguousRelBetween Text Text [Relation]
+  | AmbiguousRelBetween Text Text [Relationship]
+  | AmbiguousRpc [ProcDescription]
+  | NoRpc Text Text [Text] Bool
   | InvalidFilters
   | UnacceptableSchema [Text]
-  | UnknownRelation                -- Unreachable?
+  | ContentTypeError [ByteString]
   | UnsupportedVerb                -- Unreachable?
-  deriving (Show, Eq)
 
 instance PgrstError ApiRequestError where
   status InvalidRange            = HT.status416
   status InvalidFilters          = HT.status405
   status (InvalidBody _)         = HT.status400
   status UnsupportedVerb         = HT.status405
-  status UnknownRelation         = HT.status404
   status ActionInappropriate     = HT.status405
   status (ParseRequestError _ _) = HT.status400
   status (NoRelBetween _ _)      = HT.status400
   status AmbiguousRelBetween{}   = HT.status300
+  status (AmbiguousRpc _)        = HT.status300
+  status NoRpc{}                 = HT.status404
   status (UnacceptableSchema _)  = HT.status406
+  status (ContentTypeError _)    = HT.status415
 
-  headers _ = [toHeader CTApplicationJSON]
+  headers _ = [ContentType.toHeader CTApplicationJSON]
 
 instance JSON.ToJSON ApiRequestError where
   toJSON (ParseRequestError message details) = JSON.object [
@@ -79,41 +91,51 @@ instance JSON.ToJSON ApiRequestError where
     "message" .= (toS errorMessage :: Text)]
   toJSON InvalidRange = JSON.object [
     "message" .= ("HTTP Range error" :: Text)]
-  toJSON UnknownRelation = JSON.object [
-    "message" .= ("Unknown relation" :: Text)]
   toJSON (NoRelBetween parent child) = JSON.object [
-    "message" .= ("Could not find foreign keys between these entities. No relationship found between " <> parent <> " and " <> child :: Text)]
+    "hint"    .= ("If a new foreign key between these entities was created in the database, try reloading the schema cache." :: Text),
+    "message" .= ("Could not find a relationship between " <> parent <> " and " <> child <> " in the schema cache" :: Text)]
   toJSON (AmbiguousRelBetween parent child rels) = JSON.object [
     "hint"    .= ("By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)" :: Text),
     "message" .= ("More than one relationship was found for " <> parent <> " and " <> child :: Text),
     "details" .= (compressedRel <$> rels) ]
+  toJSON (AmbiguousRpc procs)  = JSON.object [
+    "hint"    .= ("Overloaded functions with the same argument name but different types are not supported" :: Text),
+    "message" .= ("Could not choose the best candidate function between: " <> T.intercalate ", " [pdSchema p <> "." <> pdName p <> "(" <> T.intercalate ", " [pgaName a <> " => " <> pgaType a | a <- pdArgs p] <> ")" | p <- procs])]
+  toJSON (NoRpc schema procName payloadKeys hasPreferSingleObject)  = JSON.object [
+    "hint"    .= ("If a new function was created in the database with this name and arguments, try reloading the schema cache." :: Text),
+    "message" .= ("Could not find the " <> schema <> "." <> procName <> (if hasPreferSingleObject then " function with a single json or jsonb argument" else "(" <> T.intercalate ", " payloadKeys <> ")" <> " function") <> " in the schema cache")]
   toJSON UnsupportedVerb = JSON.object [
     "message" .= ("Unsupported HTTP verb" :: Text)]
   toJSON InvalidFilters = JSON.object [
     "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)]
   toJSON (UnacceptableSchema schemas) = JSON.object [
     "message" .= ("The schema must be one of the following: " <> T.intercalate ", " schemas)]
+  toJSON (ContentTypeError cts)    = JSON.object [
+    "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]
 
-compressedRel :: Relation -> JSON.Value
+compressedRel :: Relationship -> JSON.Value
-compressedRel rel =
+compressedRel Relationship{..} =
   let
-    fmtTbl tbl = tableSchema tbl <> "." <> tableName tbl
+    fmtTbl Table{..} = tableSchema <> "." <> tableName
     fmtEls els = "[" <> T.intercalate ", " els <> "]"
   in
   JSON.object $ [
-    "origin"      .= fmtTbl (relTable rel)
+    "origin"      .= fmtTbl relTable
-  , "target"      .= fmtTbl (relFTable rel)
+  , "target"      .= fmtTbl relForeignTable
-  , "cardinality" .= (show $ relType rel :: Text)
   ] ++
-  case (relType rel, relJunction rel, relConstraint rel) of
+  case relCardinality of
-    (M2M, Just (Junction jt (Just const1) _ (Just const2) _), _) -> [
+    M2M Junction{..} -> [
-      "relationship" .= (fmtTbl jt <> fmtEls [const1] <> fmtEls [const2])
+        "cardinality" .= ("m2m" :: Text)
+      , "relationship" .= (fmtTbl junTable <> fmtEls [junConstraint1] <> fmtEls [junConstraint2])
       ]
-    (_, _, Just relCon) -> [
+    M2O cons -> [
-      "relationship" .= (relCon <> fmtEls (colName <$> relColumns rel) <> fmtEls (colName <$> relFColumns rel))
+        "cardinality" .= ("m2o" :: Text)
+      , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns))
+      ]
+    O2M cons -> [
+        "cardinality" .= ("o2m" :: Text)
+      , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns))
       ]
-    (_, _, _) ->
-      mempty
 
 data PgError = PgError Authenticated P.UsageError
 type Authenticated = Bool
@@ -123,8 +145,8 @@ instance PgrstError PgError where
 
   headers err =
     if status err == HT.status401
-       then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
+       then [ContentType.toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
-       else [toHeader CTApplicationJSON]
+       else [ContentType.toHeader CTApplicationJSON]
 
 instance JSON.ToJSON PgError where
   toJSON (PgError _ usageError) = JSON.toJSON usageError
@@ -132,8 +154,8 @@ instance JSON.ToJSON PgError where
 instance JSON.ToJSON P.UsageError where
   toJSON (P.ConnectionError e) = JSON.object [
     "code"    .= ("" :: Text),
-    "message" .= ("Database connection error" :: Text),
+    "message" .= ("Database connection error. Retrying the connection." :: Text),
-    "details" .= (toS $ fromMaybe "" e :: Text)]
+    "details" .= (toSL $ fromMaybe "" e :: Text)]
   toJSON (P.SessionError e) = JSON.toJSON e -- H.Error
 
 instance JSON.ToJSON H.QueryError where
@@ -169,7 +191,7 @@ instance JSON.ToJSON H.CommandError where
     "message" .= ("Unexpected amount of rows" :: Text),
     "details" .= i]
   toJSON (H.ClientError d) = JSON.object [
-    "message" .= ("Database client error" :: Text),
+    "message" .= ("Database client error. Retrying the connection." :: Text),
     "details" .= (fmap toS d :: Maybe Text)]
 
 pgErrorStatus :: Bool -> P.UsageError -> HT.Status
@@ -185,6 +207,7 @@ pgErrorStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError rError)))
         '0':'P':_ -> HT.status403 -- invalid role specification
         "23503"   -> HT.status409 -- foreign_key_violation
         "23505"   -> HT.status409 -- unique_violation
+        "25006"   -> HT.status405 -- read_only_sql_transaction
         '2':'5':_ -> HT.status500 -- invalid tx state
         '2':'8':_ -> HT.status403 -- invalid auth specification
         '2':'D':_ -> HT.status500 -- invalid tx termination
@@ -215,72 +238,90 @@ checkIsFatal (PgError _ (P.ConnectionError e))
   | isAuthFailureMessage = Just $ toS failureMessage
   | otherwise = Nothing
   where isAuthFailureMessage = "FATAL:  password authentication failed" `isPrefixOf` toS failureMessage
-        failureMessage = fromMaybe "" e
+        failureMessage = fromMaybe mempty e
+checkIsFatal (PgError _ (P.SessionError (H.QueryError _ _ (H.ResultError serverError))))
+  = case serverError of
+      -- Check for a syntax error (42601 is the pg code). This would mean the error is on our part somehow, so we treat it as fatal.
+      H.ServerError "42601" _ _ _
+        -> Just "Hint: This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues"
+      -- Check for a "prepared statement <name> already exists" error (Code 42P05: duplicate_prepared_statement).
+      -- This would mean that a connection pooler in transaction mode is being used
+      -- while prepared statements are enabled in the PostgREST configuration,
+      -- both of which are incompatible with each other.
+      H.ServerError "42P05" _ _ _
+        -> Just "Hint: If you are using connection poolers in transaction mode, try setting db-prepared-statements to false."
+      -- Check for a "transaction blocks not allowed in statement pooling mode" error (Code 08P01: protocol_violation).
+      -- This would mean that a connection pooler in statement mode is being used which is not supported in PostgREST.
+      H.ServerError "08P01" "transaction blocks not allowed in statement pooling mode" _ _
+        -> Just "Hint: Connection poolers in statement mode are not supported."
+      _ -> Nothing
 checkIsFatal _ = Nothing
 
 
-data SimpleError
+data Error
   = GucHeadersError
+  | GucStatusError
   | BinaryFieldError ContentType
   | ConnectionLostError
-  | PutSingletonError
   | PutMatchingPkError
   | PutRangeNotAllowedError
-  | PutPayloadIncompleteError
   | JwtTokenMissing
   | JwtTokenInvalid Text
   | SingularityError Integer
-  | ContentTypeError [ByteString]
+  | NotFound
-  deriving (Show, Eq)
+  | ApiRequestError ApiRequestError
+  | PgErr PgError
 
-instance PgrstError SimpleError where
+instance PgrstError Error where
-  status GucHeadersError           = HT.status500
+  status GucHeadersError         = HT.status500
-  status (BinaryFieldError _)      = HT.status406
+  status GucStatusError          = HT.status500
-  status ConnectionLostError       = HT.status503
+  status (BinaryFieldError _)    = HT.status406
-  status PutSingletonError         = HT.status400
+  status ConnectionLostError     = HT.status503
-  status PutMatchingPkError        = HT.status400
+  status PutMatchingPkError      = HT.status400
-  status PutRangeNotAllowedError   = HT.status400
+  status PutRangeNotAllowedError = HT.status400
-  status PutPayloadIncompleteError = HT.status400
+  status JwtTokenMissing         = HT.status500
-  status JwtTokenMissing           = HT.status500
+  status (JwtTokenInvalid _)     = HT.unauthorized401
-  status (JwtTokenInvalid _)       = HT.unauthorized401
+  status (SingularityError _)    = HT.status406
-  status (SingularityError _)      = HT.status406
+  status NotFound                = HT.status404
-  status (ContentTypeError _)      = HT.status415
+  status (PgErr err)             = status err
+  status (ApiRequestError err)   = status err
 
-  headers (SingularityError _)     = [toHeader CTSingularJSON]
+  headers (SingularityError _)     = [ContentType.toHeader CTSingularJSON]
-  headers (JwtTokenInvalid m)      = [toHeader CTApplicationJSON, invalidTokenHeader m]
+  headers (JwtTokenInvalid m)      = [ContentType.toHeader CTApplicationJSON, invalidTokenHeader m]
-  headers _                        = [toHeader CTApplicationJSON]
+  headers (PgErr err)              = headers err
+  headers (ApiRequestError err)    = headers err
+  headers _                        = [ContentType.toHeader CTApplicationJSON]
 
-instance JSON.ToJSON SimpleError where
+instance JSON.ToJSON Error where
   toJSON GucHeadersError           = JSON.object [
     "message" .= ("response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)]
+  toJSON GucStatusError           = JSON.object [
+    "message" .= ("response.status guc must be a valid status code" :: Text)]
   toJSON (BinaryFieldError ct)          = JSON.object [
-    "message" .= ((toS (toMime ct) <> " requested but more than one column was selected") :: Text)]
+    "message" .= ((toS (ContentType.toMime ct) <> " requested but more than one column was selected") :: Text)]
   toJSON ConnectionLostError       = JSON.object [
-    "message" .= ("Database connection lost, retrying the connection." :: Text)]
+    "message" .= ("Database connection lost. Retrying the connection." :: Text)]
 
-  toJSON PutSingletonError         = JSON.object [
-    "message" .= ("PUT payload must contain a single row" :: Text)]
   toJSON PutRangeNotAllowedError   = JSON.object [
     "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)]
-  toJSON PutPayloadIncompleteError = JSON.object [
-    "message" .= ("You must specify all columns in the payload when using PUT" :: Text)]
   toJSON PutMatchingPkError        = JSON.object [
     "message" .= ("Payload values do not match URL in primary key column(s)" :: Text)]
 
-  toJSON (ContentTypeError cts)    = JSON.object [
-    "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]
   toJSON (SingularityError n)      = JSON.object [
     "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
-    "details" .= T.unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]
+    "details" .= T.unwords ["Results contain", show n, "rows,", toS (ContentType.toMime CTSingularJSON), "requires 1 row"]]
 
   toJSON JwtTokenMissing           = JSON.object [
     "message" .= ("Server lacks JWT secret" :: Text)]
   toJSON (JwtTokenInvalid message) = JSON.object [
     "message" .= (message :: Text)]
+  toJSON NotFound = JSON.object []
+  toJSON (PgErr err) = JSON.toJSON err
+  toJSON (ApiRequestError err) = JSON.toJSON err
 
 invalidTokenHeader :: Text -> Header
 invalidTokenHeader m =
-  ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> show m)
+  ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m))
 
-singularityError :: (Integral a) => a -> SimpleError
+singularityError :: (Integral a) => a -> Error
 singularityError = SingularityError . toInteger

src/PostgREST/GucHeader.hs

@@ -0,0 +1,37 @@
+module PostgREST.GucHeader
+  ( GucHeader
+  , unwrapGucHeader
+  , addHeadersIfNotIncluded
+  ) where
+
+import qualified Data.Aeson           as JSON
+import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict  as M
+
+import Network.HTTP.Types.Header (Header)
+
+import Protolude      hiding (toS)
+import Protolude.Conv (toS)
+
+
+{-|
+  Custom guc header, it's obtained by parsing the json in a:
+  `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
+-}
+newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
+
+instance JSON.FromJSON GucHeader where
+  parseJSON (JSON.Object o) = case headMay (M.toList o) of
+    Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s)
+                            | otherwise     -> mzero
+    _ -> mzero
+  parseJSON _          = mzero
+
+unwrapGucHeader :: GucHeader -> Header
+unwrapGucHeader (GucHeader (k, v)) = (k, v)
+
+-- | Add headers not already included to allow the user to override them instead of duplicating them
+addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
+addHeadersIfNotIncluded newHeaders initialHeaders =
+  filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
+  initialHeaders

src/PostgREST/Middleware.hs

@@ -1,66 +1,152 @@
 {-|
 Module      : PostgREST.Middleware
-Description : Sets the PostgreSQL GUCs, role, search_path and pre-request function. Validates JWT.
+Description : Sets CORS policy. Also the PostgreSQL GUCs, role, search_path and pre-request function.
 -}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleContexts    #-}
+module PostgREST.Middleware
-{-# LANGUAGE ScopedTypeVariables #-}
+  ( runPgLocals
+  , pgrstFormat
+  , pgrstMiddleware
+  , defaultCorsPolicy
+  , corsPolicy
+  , optionalRollback
+  ) where
 
-module PostgREST.Middleware where
+import qualified Data.Aeson                           as JSON
+import qualified Data.ByteString.Char8                as BS
+import qualified Data.CaseInsensitive                 as CI
+import qualified Data.HashMap.Strict                  as M
+import qualified Data.Text                            as T
+import qualified Hasql.Decoders                       as HD
+import qualified Hasql.DynamicStatements.Snippet      as H hiding
+                                                           (sql)
+import qualified Hasql.DynamicStatements.Statement    as H
+import qualified Hasql.Transaction                    as H
+import qualified Network.HTTP.Types.Header            as HTTP
+import qualified Network.Wai                          as Wai
+import qualified Network.Wai.Logger                   as Wai
+import qualified Network.Wai.Middleware.Cors          as Wai
+import qualified Network.Wai.Middleware.Gzip          as Wai
+import qualified Network.Wai.Middleware.RequestLogger as Wai
+import qualified Network.Wai.Middleware.Static        as Wai
 
-import qualified Data.Aeson          as JSON
+import Data.Function             (id)
-import qualified Data.HashMap.Strict as M
+import Data.List                 (lookup)
-import           Data.Scientific     (FPFormat (..), formatScientific,
+import Data.Scientific           (FPFormat (..), formatScientific,
-                                      isInteger)
+                                  isInteger)
-import qualified Hasql.Transaction   as H
+import Network.HTTP.Types.Status (Status, status400, status500,
+                                  statusCode)
+import System.IO.Unsafe          (unsafePerformIO)
+import System.Log.FastLogger     (toLogStr)
 
-import Network.Wai                   (Application, Response)
+import PostgREST.Config             (AppConfig (..), LogLevel (..))
-import Network.Wai.Middleware.Cors   (cors)
+import PostgREST.Error              (Error, errorResponseFor)
-import Network.Wai.Middleware.Gzip   (def, gzip)
+import PostgREST.GucHeader          (addHeadersIfNotIncluded)
-import Network.Wai.Middleware.Static (only, staticPolicy)
+import PostgREST.Query.SqlFragment  (fromQi, intercalateSnippet,
+                                     unknownEncoder)
+import PostgREST.Request.ApiRequest (ApiRequest (..), Target (..))
 
-import Crypto.JWT
+import PostgREST.Request.Preferences
 
-import PostgREST.ApiRequest   (ApiRequest (..))
+import Protolude      hiding (head, toS)
-import PostgREST.Auth         (JWTAttempt (..))
+import Protolude.Conv (toS)
-import PostgREST.Config       (AppConfig (..), corsPolicy)
-import PostgREST.Error        (SimpleError (JwtTokenInvalid, JwtTokenMissing),
-                               errorResponseFor)
-import PostgREST.QueryBuilder (setLocalQuery, setLocalSearchPathQuery)
-import Protolude              hiding (head)
 
-runWithClaims :: AppConfig -> JWTAttempt ->
+-- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function
-                 (ApiRequest -> H.Transaction Response) ->
+runPgLocals :: AppConfig   -> M.HashMap Text JSON.Value ->
-                 ApiRequest -> H.Transaction Response
+               (ApiRequest -> ExceptT Error H.Transaction Wai.Response) ->
-runWithClaims conf eClaims app req =
+               ApiRequest  -> ByteString -> ExceptT Error H.Transaction Wai.Response
-  case eClaims of
+runPgLocals conf claims app req jsonDbS = do
-    JWTMissingSecret      -> return . errorResponseFor $ JwtTokenMissing
+  lift $ H.statement mempty $ H.dynamicallyParameterized
-    JWTInvalid JWTExpired -> return . errorResponseFor . JwtTokenInvalid $ "JWT expired"
+    ("select " <> intercalateSnippet ", " (searchPathSql : roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql ++ specSql))
-    JWTInvalid e          -> return . errorResponseFor . JwtTokenInvalid . show $ e
+    HD.noResult (configDbPreparedStatements conf)
-    JWTClaims claims      -> do
+  lift $ traverse_ H.sql preReqSql
-      H.sql $ toS . mconcat $ setSearchPathSql : setRoleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql
+  app req
-      mapM_ H.sql customReqCheck
+  where
-      app req
+    methodSql = setConfigLocal mempty ("request.method", iMethod req)
-      where
+    pathSql = setConfigLocal mempty ("request.path", iPath req)
-        methodSql = setLocalQuery mempty ("request.method", toS $ iMethod req)
+    headersSql = setConfigLocal "request.header." <$> iHeaders req
-        pathSql = setLocalQuery mempty ("request.path", toS $ iPath req)
+    cookiesSql = setConfigLocal "request.cookie." <$> iCookies req
-        headersSql = setLocalQuery "request.header." <$> iHeaders req
+    claimsWithRole =
-        cookiesSql = setLocalQuery "request.cookie." <$> iCookies req
+      let anon = JSON.String . toS $ configDbAnonRole conf in -- role claim defaults to anon if not specified in jwt
-        claimsSql = setLocalQuery "request.jwt.claim." <$> [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]
+      M.union claims (M.singleton "role" anon)
-        appSettingsSql = setLocalQuery mempty <$> configSettings conf
+    claimsSql = setConfigLocal "request.jwt.claim." <$> [(toS c, toS $ unquoted v) | (c,v) <- M.toList claimsWithRole]
-        setRoleSql = maybeToList $ (\x ->
+    roleSql = maybeToList $ (\x -> setConfigLocal mempty ("role", toS $ unquoted x)) <$> M.lookup "role" claimsWithRole
-          setLocalQuery mempty ("role", unquoted x)) <$> M.lookup "role" claimsWithRole
+    appSettingsSql = setConfigLocal mempty <$> (join bimap toS <$> configAppSettings conf)
-        setSearchPathSql = setLocalSearchPathQuery (iSchema req : configExtraSearchPath conf)
+    searchPathSql =
-        -- role claim defaults to anon if not specified in jwt
+      let schemas = T.intercalate ", " (iSchema req : configDbExtraSearchPath conf) in
-        claimsWithRole = M.union claims (M.singleton "role" anon)
+      setConfigLocal mempty ("search_path", toS schemas)
-        anon = JSON.String . toS $ configAnonRole conf
+    preReqSql = (\f -> "select " <> fromQi f <> "();") <$> configDbPreRequest conf
-        customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
+    specSql = case iTarget req of
+      TargetProc{tpIsRootSpec=True} -> [setConfigLocal mempty ("request.spec", jsonDbS)]
+      _                             -> mempty
+    -- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL.
+    setConfigLocal :: ByteString -> (ByteString, ByteString) -> H.Snippet
+    setConfigLocal prefix (k, v) =
+      "set_config(" <> unknownEncoder (prefix <> k) <> ", " <> unknownEncoder v <> ", true)"
 
-defaultMiddle :: Application -> Application
+-- | Log in apache format. Only requests that have a status greater than minStatus are logged.
-defaultMiddle =
+-- | 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.
-    gzip def
+-- | So here we copy wai-logger apacheLogStr function: https://github.com/kazu-yamamoto/logger/blob/a4f51b909a099c51af7a3f75cf16e19a06f9e257/wai-logger/Network/Wai/Logger/Apache.hs#L45
-  . cors corsPolicy
+-- | TODO: Add the ability to filter apache logs on wai-extra and remove this function.
-  . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+pgrstFormat :: Status -> Wai.OutputFormatter
+pgrstFormat minStatus date req status responseSize =
+  if status < minStatus
+    then mempty
+  else toLogStr (getSourceFromSocket req)
+    <> " - - ["
+    <> toLogStr date
+    <> "] \""
+    <> toLogStr (Wai.requestMethod req)
+    <> " "
+    <> toLogStr (Wai.rawPathInfo req <> Wai.rawQueryString req)
+    <> " "
+    <> toLogStr (show (Wai.httpVersion req)::Text)
+    <> "\" "
+    <> toLogStr (show (statusCode status)::Text)
+    <> " "
+    <> toLogStr (maybe "-" show responseSize::Text)
+    <> " \""
+    <> toLogStr (fromMaybe mempty $ Wai.requestHeaderReferer req)
+    <> "\" \""
+    <> toLogStr (fromMaybe mempty $ Wai.requestHeaderUserAgent req)
+    <> "\"\n"
+  where
+    getSourceFromSocket = BS.pack . Wai.showSockAddr . Wai.remoteHost
+
+pgrstMiddleware :: LogLevel -> Wai.Application -> Wai.Application
+pgrstMiddleware logLevel =
+    logger
+  . Wai.cors corsPolicy
+  . Wai.staticPolicy (Wai.only [("favicon.ico", "static/favicon.ico")])
+  where
+    logger = case logLevel of
+      LogCrit  -> id
+      LogError -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status500}
+      LogWarn  -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400}
+      LogInfo  -> Wai.logStdout
+
+defaultCorsPolicy :: Wai.CorsResourcePolicy
+defaultCorsPolicy =  Wai.CorsResourcePolicy Nothing
+  ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing
+  (Just $ 60*60*24) False False True
+
+-- | CORS policy to be used in by Wai Cors middleware
+corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy
+corsPolicy req = case lookup "origin" headers of
+  Just origin -> Just defaultCorsPolicy {
+      Wai.corsOrigins = Just ([origin], True)
+    , Wai.corsRequestHeaders = "Authentication" : accHeaders
+    , Wai.corsExposedHeaders = Just [
+        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
+      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
+      ]
+    }
+  Nothing -> Nothing
+  where
+    headers = Wai.requestHeaders req
+    accHeaders = case lookup "access-control-request-headers" headers of
+      Just hdrs -> map (CI.mk . toS . T.strip . toS) $ BS.split ',' hdrs
+      Nothing -> []
 
 unquoted :: JSON.Value -> Text
 unquoted (JSON.String t) = t
@@ -68,3 +154,30 @@ unquoted (JSON.Number n) =
   toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
 unquoted (JSON.Bool b) = show b
 unquoted v = toS $ JSON.encode v
+
+-- | Set a transaction to eventually roll back if requested and set respective
+-- headers on the response.
+optionalRollback
+  :: AppConfig
+  -> ApiRequest
+  -> ExceptT Error H.Transaction Wai.Response
+  -> ExceptT Error H.Transaction Wai.Response
+optionalRollback AppConfig{..} ApiRequest{..} transaction = do
+  resp <- catchError transaction $ return . errorResponseFor
+  when (shouldRollback || (configDbTxRollbackAll && not shouldCommit))
+    (lift H.condemn)
+  return $ Wai.mapResponseHeaders preferenceApplied resp
+  where
+    shouldCommit =
+      configDbTxAllowOverride && iPreferTransaction == Just Commit
+    shouldRollback =
+      configDbTxAllowOverride && iPreferTransaction == Just Rollback
+    preferenceApplied
+      | shouldCommit =
+          addHeadersIfNotIncluded
+            [(HTTP.hPreferenceApplied, BS.pack (show Commit))]
+      | shouldRollback =
+          addHeadersIfNotIncluded
+            [(HTTP.hPreferenceApplied, BS.pack (show Rollback))]
+      | otherwise =
+          identity

src/PostgREST/OpenAPI.hs

@@ -2,40 +2,57 @@
 Module      : PostgREST.OpenAPI
 Description : Generates the OpenAPI output
 -}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.OpenAPI (encode) where
 
-module PostgREST.OpenAPI (
+import qualified Data.Aeson           as JSON
-  encodeOpenAPI
+import qualified Data.ByteString.Lazy as LBS
-, isMalformedProxyUri
+import qualified Data.HashMap.Strict  as HashMap
-, pickProxy
+import qualified Data.HashSet.InsOrd  as Set
-) where
+import qualified Data.Text            as T
-
-import qualified Data.HashSet.InsOrd as Set
 
 import Control.Arrow              ((&&&))
-import Data.Aeson                 (decode, encode)
 import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
 import Data.Maybe                 (fromJust)
 import Data.String                (IsString (..))
-import Data.Text                  (append, breakOn, dropWhile, init,
+import Network.URI                (URI (..), URIAuth (..))
-                                   intercalate, pack, tail, toLower,
+
-                                   unpack)
+import Control.Lens (at, (.~), (?~))
-import Network.URI                (URI (..), URIAuth (..),
-                                   isAbsoluteURI, parseURI)
 
-import Control.Lens
 import Data.Swagger
 
-import PostgREST.ApiRequest (ContentType (..))
+import PostgREST.Config                   (AppConfig (..), Proxy (..),
-import PostgREST.Config     (docsVersion, prettyVersion)
+                                           isMalformedProxyUri, toURI)
-import PostgREST.Types      (Column (..), ForeignKey (..), PgArg (..),
+import PostgREST.DbStructure              (DbStructure (..),
-                             PrimaryKey (..), ProcDescription (..),
+                                           tableCols, tablePKCols)
-                             Proxy (..), Table (..), toMime)
+import PostgREST.DbStructure.Proc         (PgArg (..),
-import Protolude            hiding (Proxy, dropWhile, get,
+                                           ProcDescription (..))
-                             intercalate, (&))
+import PostgREST.DbStructure.Relationship (Cardinality (..),
+                                           PrimaryKey (..),
+                                           Relationship (..))
+import PostgREST.DbStructure.Table        (Column (..), Table (..))
+import PostgREST.Version                  (docsVersion, prettyVersion)
+
+import PostgREST.ContentType
+
+import Protolude      hiding (Proxy, get, toS)
+import Protolude.Conv (toS)
+
+encode :: AppConfig -> DbStructure -> [Table] -> HashMap.HashMap k [ProcDescription] -> Maybe Text -> LBS.ByteString
+encode conf dbStructure tables procs schemaDescription =
+  JSON.encode $
+    postgrestSpec
+      (dbRelationships dbStructure)
+      (concat $ HashMap.elems procs)
+      (openApiTableInfo dbStructure <$> tables)
+      (proxyUri conf)
+      schemaDescription
+      (dbPrimaryKeys dbStructure)
 
 makeMimeList :: [ContentType] -> MimeList
-makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
+makeMimeList cs = MimeList $ fmap (fromString . toS . toMime) cs
 
 toSwaggerType :: Text -> SwaggerType t
 toSwaggerType "character varying" = SwaggerString
@@ -50,36 +67,47 @@ toSwaggerType "real"              = SwaggerNumber
 toSwaggerType "double precision"  = SwaggerNumber
 toSwaggerType _                   = SwaggerString
 
-makeTableDef :: [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)
+makeTableDef :: [Relationship] -> [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)
-makeTableDef pks (t, cs, _) =
+makeTableDef rels pks (t, cs, _) =
   let tn = tableName t in
       (tn, (mempty :: Schema)
         & description .~ tableDescription t
         & type_ ?~ SwaggerObject
-        & properties .~ fromList (map (makeProperty pks) cs)
+        & properties .~ fromList (fmap (makeProperty rels pks) cs)
-        & required .~ map colName (filter (not . colNullable) cs))
+        & required .~ fmap colName (filter (not . colNullable) cs))
 
-makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema)
+makeProperty :: [Relationship] -> [PrimaryKey] -> Column -> (Text, Referenced Schema)
-makeProperty pks c = (colName c, Inline s)
+makeProperty rels pks c = (colName c, Inline s)
   where
-    e = if null $ colEnum c then Nothing else decode $ encode $ colEnum c
+    e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c
-    fk ForeignKey{fkCol=Column{colTable=Table{tableName=a}, colName=b}} =
+    fk :: Maybe Text
-      intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]
+    fk =
+      let
+        -- Finds the relationship that has a single column foreign key
+        rel = find (\case
+          Relationship{relColumns, relCardinality=M2O _} -> [c] == relColumns
+          _                                                 -> False
+          ) rels
+        fCol = colName <$> (headMay . relForeignColumns =<< rel)
+        fTbl = tableName . relForeignTable <$> rel
+        fTblCol = (,) <$> fTbl <*> fCol
+      in
+        (\(a, b) -> T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]) <$> fTblCol
     pk :: Bool
     pk = any (\p -> pkTable p == colTable c && pkName p == colName c) pks
     n = catMaybes
       [ Just "Note:"
       , if pk then Just "This is a Primary Key.<pk/>" else Nothing
-      , fk <$> colFK c
+      , fk
       ]
     d =
       if length n > 1 then
-        Just $ append (maybe "" (`append` "\n\n") $ colDescription c) (intercalate "\n" n)
+        Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription c) (T.intercalate "\n" n)
       else
         colDescription c
     s =
       (mempty :: Schema)
-        & default_ .~ (decode . toS =<< colDefault c)
+        & default_ .~ (JSON.decode . toS =<< colDefault c)
         & description .~ d
         & enum_ .~ e
         & format ?~ colType c
@@ -91,11 +119,11 @@ makeProcSchema pd =
   (mempty :: Schema)
   & description .~ pdDescription pd
   & type_ ?~ SwaggerObject
-  & properties .~ fromList (map makeProcProperty (pdArgs pd))
+  & properties .~ fromList (fmap makeProcProperty (pdArgs pd))
-  & required .~ map pgaName (filter pgaReq (pdArgs pd))
+  & required .~ fmap pgaName (filter pgaReq (pdArgs pd))
 
 makeProcProperty :: PgArg -> (Text, Referenced Schema)
-makeProcProperty (PgArg n t _) = (n, Inline s)
+makeProcProperty (PgArg n t _ _) = (n, Inline s)
   where
     s = (mempty :: Schema)
           & type_ ?~ toSwaggerType t
@@ -110,14 +138,14 @@ makePreferParam ts =
   & schema .~ ParamOther ((mempty :: ParamOtherSchema)
     & in_ .~ ParamHeader
     & type_ ?~ SwaggerString
-    & enum_ .~ decode (encode ts))
+    & enum_ .~ JSON.decode (JSON.encode ts))
 
 makeProcParam :: ProcDescription -> [Referenced Param]
 makeProcParam pd =
   [ Inline $ (mempty :: Param)
     & name     .~ "args"
     & required ?~ True
-    & schema   .~ (ParamBody $ Inline $ makeProcSchema pd)
+    & schema   .~ ParamBody (Inline $ makeProcSchema pd)
   , Ref $ Reference "preferParams"
   ]
 
@@ -161,7 +189,7 @@ makeParamDefs ti =
       & schema .~ ParamOther ((mempty :: ParamOtherSchema)
         & in_ .~ ParamHeader
         & type_ ?~ SwaggerString
-        & default_ .~ decode "\"items\""))
+        & default_ .~ JSON.decode "\"items\""))
   , ("offset", (mempty :: Param)
       & name        .~ "offset"
       & description ?~ "Limiting and Pagination"
@@ -191,7 +219,7 @@ makeObjectBody tn =
 
 makeRowFilter :: Text -> Column -> (Text, Param)
 makeRowFilter tn c =
-  (intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
+  (T.intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
     & name .~ colName c
     & description .~ colDescription c
     & required ?~ False
@@ -201,44 +229,44 @@ makeRowFilter tn c =
       & format ?~ colType c))
 
 makeRowFilters :: Text -> [Column] -> [(Text, Param)]
-makeRowFilters tn = map (makeRowFilter tn)
+makeRowFilters tn = fmap (makeRowFilter tn)
 
 makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
-makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
+makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable t)
   where
     -- Use first line of table description as summary; rest as description (if present)
     -- We strip leading newlines from description so that users can include a blank line between summary and description
-    (tSum, tDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $
+    (tSum, tDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
-                    breakOn "\n" <$> tableDescription t
+                    T.breakOn "\n" <$> tableDescription t
     tOp = (mempty :: Operation)
       & tags .~ Set.fromList [tn]
       & summary .~ tSum
       & description .~ mfilter (/="") tDesc
     getOp = tOp
-      & parameters .~ map ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])
+      & parameters .~ fmap ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"])
       & at 206 ?~ "Partial Content"
       & at 200 ?~ Inline ((mempty :: Response)
         & description .~ "OK"
         & schema ?~ Inline (mempty
           & type_ ?~ SwaggerArray
-          & items ?~ (SwaggerItemsObject $ Ref $ Reference $ tableName t)
+          & items ?~ SwaggerItemsObject (Ref $ Reference $ tableName t)
         )
       )
     postOp = tOp
-      & parameters .~ map ref ["body." <> tn, "select", "preferReturn"]
+      & parameters .~ fmap ref ["body." <> tn, "select", "preferReturn"]
       & at 201 ?~ "Created"
     patchOp = tOp
-      & parameters .~ map ref (rs <> ["body." <> tn, "preferReturn"])
+      & parameters .~ fmap ref (rs <> ["body." <> tn, "preferReturn"])
       & at 204 ?~ "No Content"
     deletOp = tOp
-      & parameters .~ map ref (rs <> ["preferReturn"])
+      & parameters .~ fmap ref (rs <> ["preferReturn"])
       & at 204 ?~ "No Content"
     pr = (mempty :: PathItem) & get ?~ getOp
     pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp
     p False = pr
     p True  = pw
     tn = tableName t
-    rs = [ intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]
+    rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]
     ref = Ref . Reference
 
 makeProcPathItem :: ProcDescription -> (FilePath, PathItem)
@@ -246,8 +274,8 @@ 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 (dropWhile (=='\n') . snd) $
+    (pSum, pDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $
-                    breakOn "\n" <$> pdDescription pd
+                    T.breakOn "\n" <$> pdDescription pd
     postOp = (mempty :: Operation)
       & summary .~ pSum
       & description .~ mfilter (/="") pDesc
@@ -270,7 +298,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"
@@ -280,9 +308,9 @@ escapeHostName "*6" = "0.0.0.0"
 escapeHostName "!6" = "0.0.0.0"
 escapeHostName h    = h
 
-postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
+postgrestSpec :: [Relationship] -> [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger
-postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
+postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
-  & basePath ?~ unpack b
+  & basePath ?~ T.unpack b
   & schemes ?~ [s']
   & info .~ ((mempty :: Info)
       & version .~ prettyVersion
@@ -292,44 +320,23 @@ postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
     & description ?~ "PostgREST Documentation"
     & url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html"))
   & host .~ h'
-  & definitions .~ fromList (map (makeTableDef pks) ti)
+  & definitions .~ fromList (makeTableDef rels pks <$> ti)
   & parameters .~ fromList (makeParamDefs ti)
   & paths .~ makePathItems pds ti
   & produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
   & consumes .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
     where
       s' = if s == "http" then Http else Https
-      h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))
+      h' = Just $ Host (T.unpack $ escapeHostName h) (Just (fromInteger p))
       d = fromMaybe "This is a dynamic API generated by PostgREST" sd
 
-encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] ->  LByteString
-encodeOpenAPI pds ti uri sd pks = encode $ postgrestSpec pds ti uri sd pks
-
-{-|
-  Test whether a proxy uri is malformed or not.
-  A valid proxy uri should be an absolute uri without query and user info,
-  only http(s) schemes are valid, port number range is 1-65535.
-
-  For example
-  http://postgrest.com/openapi.json
-  https://postgrest.com:8080/openapi.json
--}
-isMalformedProxyUri :: Maybe Text -> Bool
-isMalformedProxyUri Nothing =  False
-isMalformedProxyUri (Just uri)
-  | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri
-  | otherwise = True
-
-toURI :: Text -> URI
-toURI uri = fromJust $ parseURI (toS uri)
-
 pickProxy :: Maybe Text -> Maybe Proxy
 pickProxy proxy
   | isNothing proxy = Nothing
   -- should never happen
   -- since the request would have been rejected by the middleware if proxy uri
   -- is malformed
-  | isMalformedProxyUri proxy = Nothing
+  | isMalformedProxyUri $ fromMaybe mempty proxy = Nothing
   | otherwise = Just Proxy {
     proxyScheme = scheme
   , proxyHost = host'
@@ -338,53 +345,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' = T.pack $ path uri
    authority = fromJust $ uriAuthority uri
-   host' = pack $ uriRegName authority
+   host' = T.pack $ uriRegName authority
    port' = uriPort authority
    readPort = fromMaybe 80 . readMaybe
    port'' :: Integer
    port'' = case (port', scheme) of
              ("", "http")  -> 80
              ("", "https") -> 443
-             _             -> readPort $ unpack $ tail $ pack port'
+             _             -> readPort $ T.unpack $ T.tail $ T.pack port'
 
-isUriValid:: URI -> Bool
+proxyUri :: AppConfig -> (Text, Text, Integer, Text)
-isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]
+proxyUri AppConfig{..} =
+  case pickProxy $ toS <$> configOpenApiServerProxyUri of
+    Just Proxy{..} ->
+      (proxyScheme, proxyHost, proxyPort, proxyPath)
+    Nothing ->
+      ("http", configServerHost, toInteger configServerPort, "/")
 
-fAnd :: [a -> Bool] -> a -> Bool
+openApiTableInfo :: DbStructure -> Table -> (Table, [Column], [Text])
-fAnd fs x = all ($ x) fs
+openApiTableInfo dbStructure table =
-
+  ( table
-isSchemeValid :: URI -> Bool
+  , tableCols dbStructure (tableSchema table) (tableName table)
-isSchemeValid URI {uriScheme = s}
+  , tablePKCols dbStructure (tableSchema table) (tableName table)
-  | toLower (pack s) == "https:" = True
+  )
-  | toLower (pack s) == "http:" = True
-  | otherwise = False
-
-isQueryValid :: URI -> Bool
-isQueryValid URI {uriQuery = ""} = True
-isQueryValid _                   = False
-
-isAuthorityValid :: URI -> Bool
-isAuthorityValid URI {uriAuthority = a}
-  | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a
-  | otherwise = False
-
-isUserInfoValid :: URIAuth -> Bool
-isUserInfoValid URIAuth {uriUserInfo = ""} = True
-isUserInfoValid _                          = False
-
-isHostValid :: URIAuth -> Bool
-isHostValid URIAuth {uriRegName = ""} = False
-isHostValid _                         = True
-
-isPortValid :: URIAuth -> Bool
-isPortValid URIAuth {uriPort = ""} = True
-isPortValid URIAuth {uriPort = (':':p)} =
-  case readMaybe p of
-    Just i  -> i > (0 :: Integer) && i < 65536
-    Nothing -> False
-isPortValid _ = False

src/PostgREST/Private/Common.hs

@@ -1,25 +0,0 @@
-{-|
-Module      : PostgREST.Common
-Description : Common helper functions.
--}
-module PostgREST.Private.Common where
-
-import           Data.Maybe
-import qualified Hasql.Decoders as HD
-import qualified Hasql.Encoders as HE
-import           Protolude
-
-column :: HD.Value a -> HD.Row a
-column = HD.column . HD.nonNullable
-
-nullableColumn :: HD.Value a -> HD.Row (Maybe a)
-nullableColumn = HD.column . HD.nullable
-
-element :: HD.Value a -> HD.Array a
-element = HD.element . HD.nonNullable
-
-param :: HE.Value a -> HE.Params a
-param = HE.param . HE.nonNullable
-
-arrayParam :: HE.Value a -> HE.Params [a]
-arrayParam = param . HE.array . HE.dimension foldl' . HE.element . HE.nonNullable

src/PostgREST/Private/QueryFragment.hs

@@ -1,205 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-|
-Module      : PostgREST.Private.QueryFragment
-Description : Helper functions for PostgREST.QueryBuilder.
-
-Any function that outputs a SqlFragment should be in this module.
--}
-module PostgREST.Private.QueryFragment where
-
-import qualified Data.HashMap.Strict           as HM
-import           Data.Maybe
-import           Data.Text                     (intercalate,
-                                                isInfixOf, replace,
-                                                toLower, unwords)
-import qualified Data.Text                     as T (map, null,
-                                                     takeWhile)
-import           PostgREST.Types
-import           Protolude                     hiding (cast,
-                                                intercalate, replace)
-import           Text.InterpolatedString.Perl6 (qc)
-
-noLocationF :: SqlFragment
-noLocationF = "array[]::text[]"
-
--- Due to the use of the `unknown` encoder we need to cast '$1' when the value is not used in the main query
--- otherwise the query will err with a `could not determine data type of parameter $1`.
--- This happens because `unknown` relies on the context to determine the value type.
--- The error also happens on raw libpq used with C.
-ignoredBody :: SqlFragment
-ignoredBody = "pgrst_ignored_body AS (SELECT $1::text) "
-
--- |
--- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads
--- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays
--- We do this in SQL to avoid processing the JSON in application code
-normalizedBody :: SqlFragment
-normalizedBody =
-  unwords [
-    "pgrst_payload AS (SELECT $1::json AS json_data),",
-    "pgrst_body AS (",
-      "SELECT",
-        "CASE WHEN json_typeof(json_data) = 'array'",
-          "THEN json_data",
-          "ELSE json_build_array(json_data)",
-        "END AS val",
-      "FROM pgrst_payload)"]
-
-selectBody :: SqlFragment
-selectBody = "(SELECT val FROM pgrst_body)"
-
-pgFmtLit :: SqlFragment -> SqlFragment
-pgFmtLit x =
- let trimmed = trimNullChars x
-     escaped = "'" <> replace "'" "''" trimmed <> "'"
-     slashed = replace "\\" "\\\\" escaped in
- if "\\" `isInfixOf` escaped
-   then "E" <> slashed
-   else slashed
-
-pgFmtIdent :: SqlFragment -> SqlFragment
-pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""
-
-asCsvF :: SqlFragment
-asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
-  where
-    asCsvHeaderF =
-      "(SELECT coalesce(string_agg(a.k, ','), '')" <>
-      "  FROM (" <>
-      "    SELECT json_object_keys(r)::TEXT as k" <>
-      "    FROM ( " <>
-      "      SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
-      "    ) s" <>
-      "  ) a" <>
-      ")"
-    asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
-
-asJsonF :: SqlFragment
-asJsonF = "coalesce(json_agg(_postgrest_t), '[]')::character varying"
-
-asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
-asJsonSingleF = "coalesce(string_agg(row_to_json(_postgrest_t)::text, ','), '')::character varying "
-
-asBinaryF :: FieldName -> SqlFragment
-asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
-
-locationF :: [Text] -> SqlFragment
-locationF pKeys = [qc|(
-  WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1)
-  SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))
-  FROM data CROSS JOIN json_each_text(data.row) AS json_data
-  {("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys}
-)|]
-
-fromQi :: QualifiedIdentifier -> SqlFragment
-fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
-  where
-    n = qiName t
-    s = qiSchema t
-
-emptyOnFalse :: Text -> Bool -> Text
-emptyOnFalse val cond = if cond then "" else val
-
-pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
-pgFmtColumn table "*" = fromQi table <> ".*"
-pgFmtColumn table c   = fromQi table <> "." <> pgFmtIdent c
-
-pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment
-pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp
-
-pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment
-pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs fName jp alias
-pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs fName jp alias
-
-pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment
-pgFmtOrderTerm qi ot = unwords [
-  toS . pgFmtField qi $ otTerm ot,
-  maybe "" show $ otDirection ot,
-  maybe "" show $ otNullOrder ot]
-
-pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment
-pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of
-   Op op val  -> pgFmtFieldOp op <> " " <> case op of
-     "like"  -> unknownLiteral (T.map star val)
-     "ilike" -> unknownLiteral (T.map star val)
-     "is"    -> whiteList val
-     _       -> unknownLiteral val
-
-   In vals -> pgFmtField table fld <> " " <>
-    let emptyValForIn = "= any('{}') " in -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"
-    case (&&) (length vals == 1) . T.null <$> headMay vals of
-      Just False -> sqlOperator "in" <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "
-      Just True  -> emptyValForIn
-      Nothing    -> emptyValForIn
-
-   Fts op lang val ->
-     pgFmtFieldOp op
-       <> "("
-       <> maybe "" ((<> ", ") . pgFmtLit) lang
-       <> unknownLiteral val
-       <> ") "
- where
-   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
-   sqlOperator o = HM.lookupDefault "=" o operators
-   notOp = if hasNot then "NOT" else ""
-   star c = if c == '*' then '%' else c
-   unknownLiteral = (<> "::unknown ") . pgFmtLit
-   whiteList :: Text -> SqlFragment
-   whiteList v = fromMaybe
-     (toS (pgFmtLit v) <> "::unknown ")
-     (find ((==) . toLower $ v) ["null","true","false"])
-
-pgFmtJoinCondition :: JoinCondition -> SqlFragment
-pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) =
-  pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2
-
-pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment
-pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")"
-  where notOp =  if hasNot then "NOT" else ""
-pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
-
-pgFmtJsonPath :: JsonPath -> SqlFragment
-pgFmtJsonPath = \case
-  []             -> ""
-  (JArrow x:xs)  -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
-  (J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
-  where
-    pgFmtJsonOperand (JKey k) = pgFmtLit k
-    pgFmtJsonOperand (JIdx i) = pgFmtLit i <> "::int"
-
-pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment
-pgFmtAs _ [] Nothing = ""
-pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of
-  Just (JKey key) -> " AS " <> pgFmtIdent key
-  Just (JIdx _)   -> " AS " <> pgFmtIdent (fromMaybe fName lastKey)
-    -- We get the lastKey because on:
-    -- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ]
-    -- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ]
-    where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp)
-  Nothing -> ""
-pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias
-
-trimNullChars :: Text -> Text
-trimNullChars = T.takeWhile (/= '\x0')
-
-countF :: SqlQuery -> Bool -> (SqlFragment, SqlFragment)
-countF countQuery shouldCount =
-  if shouldCount
-    then (
-        ", pg_source_count AS (" <> countQuery <> ")"
-      , "(SELECT pg_catalog.count(*) FROM pg_source_count)" )
-    else (
-        mempty
-      , "null::bigint")
-
-returningF :: QualifiedIdentifier -> [FieldName] -> SqlFragment
-returningF qi returnings =
-  if null returnings
-    then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified
-    else "RETURNING " <> intercalate ", " (pgFmtColumn qi <$> returnings)
-
-responseHeadersF :: PgVersion -> SqlFragment
-responseHeadersF pgVer =
-  if pgVer >= pgVersion96
-    then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
-    else "'[]'" :: Text

src/PostgREST/Query/QueryBuilder.hs

@@ -0,0 +1,181 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-|
+Module      : PostgREST.Query.QueryBuilder
+Description : PostgREST SQL queries generating functions.
+
+This module provides functions to consume data types that
+represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment
+to produce SqlQuery type outputs.
+-}
+module PostgREST.Query.QueryBuilder
+  ( readRequestToQuery
+  , mutateRequestToQuery
+  , readRequestToCountQuery
+  , requestToCallProcQuery
+  , limitedQuery
+  ) where
+
+import qualified Data.ByteString.Char8           as BS
+import qualified Data.Set                        as S
+import qualified Hasql.DynamicStatements.Snippet as H
+
+import Data.Tree (Tree (..))
+
+import PostgREST.DbStructure.Identifiers  (FieldName,
+                                           QualifiedIdentifier (..))
+import PostgREST.DbStructure.Proc         (PgArg (..))
+import PostgREST.DbStructure.Relationship (Cardinality (..),
+                                           Relationship (..))
+import PostgREST.DbStructure.Table        (Table (..))
+import PostgREST.Request.ApiRequest       (PayloadJSON (..))
+import PostgREST.Request.Preferences      (PreferParameters (..),
+                                           PreferResolution (..))
+
+import PostgREST.Query.SqlFragment
+import PostgREST.Request.Types
+
+import Protolude
+
+readRequestToQuery :: ReadRequest -> H.Snippet
+readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) =
+  "SELECT " <>
+  intercalateSnippet ", " ((pgFmtSelectItem qi <$> colSelects) ++ selects) <>
+  "FROM " <> H.sql (BS.intercalate ", " (tabl : implJs)) <> " " <>
+  intercalateSnippet " " joins <> " " <>
+  (if null logicForest && null joinConditions_ then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_))
+  <> " " <>
+  (if null ordts then mempty else "ORDER BY " <> intercalateSnippet ", " (map (pgFmtOrderTerm qi) ordts)) <> " " <>
+  limitOffsetF range
+  where
+    implJs = fromQi <$> implJoins
+    tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias
+    qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias
+    (joins, selects) = foldr getJoinsSelects ([],[]) forest
+
+getJoinsSelects :: ReadRequest -> ([H.Snippet], [H.Snippet]) -> ([H.Snippet], [H.Snippet])
+getJoinsSelects rr@(Node (_, (name, Just Relationship{relCardinality=card,relTable=Table{tableName=table}}, alias, _, _)) _) (j,s) =
+  let subquery = readRequestToQuery rr in
+  case card of
+    M2O _ ->
+      let aliasOrName = fromMaybe name alias
+          localTableName = pgFmtIdent $ table <> "_" <> aliasOrName
+          sel = H.sql ("row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName)
+          joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> H.sql localTableName <> " ON TRUE " in
+      (joi:j,sel:s)
+    _ ->
+      let sel = "COALESCE (("
+             <> "SELECT json_agg(" <> H.sql (pgFmtIdent table) <> ".*) "
+             <> "FROM (" <> subquery <> ") " <> H.sql (pgFmtIdent table) <> " "
+             <> "), '[]') AS " <> H.sql (pgFmtIdent (fromMaybe name alias)) in
+      (j,sel:s)
+getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], [])
+
+mutateRequestToQuery :: MutateRequest -> H.Snippet
+mutateRequestToQuery (Insert mainQi iCols body onConflct putConditions returnings) =
+  "WITH " <> normalizedBody body <> " " <>
+  "INSERT INTO " <> H.sql (fromQi mainQi) <> H.sql (if S.null iCols then " " else "(" <> cols <> ") ") <>
+  "SELECT " <> H.sql cols <> " " <>
+  H.sql ("FROM json_populate_recordset (null::" <> fromQi mainQi <> ", " <> selectBody <> ") _ ") <>
+  -- Only used for PUT
+  (if null putConditions then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) <>
+  H.sql (BS.unwords [
+    maybe "" (\(oncDo, oncCols) ->
+      if null oncCols then
+        mempty
+      else
+        "ON CONFLICT(" <> BS.intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of
+        IgnoreDuplicates ->
+          "DO NOTHING"
+        MergeDuplicates  ->
+          if S.null iCols
+             then "DO NOTHING"
+             else "DO UPDATE SET " <> BS.intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)
+      ) onConflct,
+    returningF mainQi returnings
+    ])
+  where
+    cols = BS.intercalate ", " $ pgFmtIdent <$> S.toList iCols
+mutateRequestToQuery (Update mainQi uCols body logicForest returnings) =
+  if S.null uCols
+    -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax
+    -- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select=
+    -- the select has to be based on "returnings" to make computed overloaded functions not throw
+    then H.sql ("SELECT " <> emptyBodyReturnedColumns <> " FROM " <> fromQi mainQi <> " WHERE false")
+    else
+      "WITH " <> normalizedBody body <> " " <>
+      "UPDATE " <> H.sql (fromQi mainQi) <> " SET " <> H.sql cols <> " " <>
+      "FROM (SELECT * FROM json_populate_recordset (null::" <> H.sql (fromQi mainQi) <> " , " <> H.sql selectBody <> " )) _ " <>
+      (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)) <> " " <>
+      H.sql (returningF mainQi returnings)
+  where
+    cols = BS.intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)
+    emptyBodyReturnedColumns :: SqlFragment
+    emptyBodyReturnedColumns
+      | null returnings = "NULL"
+      | otherwise       = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)
+mutateRequestToQuery (Delete mainQi logicForest returnings) =
+  "DELETE FROM " <> H.sql (fromQi mainQi) <> " " <>
+  (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree mainQi) logicForest)) <> " " <>
+  H.sql (returningF mainQi returnings)
+
+requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Maybe PayloadJSON -> Bool -> Maybe PreferParameters -> [FieldName] -> H.Snippet
+requestToCallProcQuery qi pgArgs pj returnsScalar preferParams returnings =
+  argsCTE <> sourceBody
+  where
+    body = pjRaw <$> pj
+    paramsAsSingleObject    = preferParams == Just SingleObject
+    paramsAsMultipleObjects = preferParams == Just MultipleObjects
+
+    (argsCTE, args)
+      | null pgArgs = (mempty, mempty)
+      | paramsAsSingleObject = ("WITH pgrst_args AS (SELECT NULL)", jsonPlaceHolder body)
+      | otherwise = (
+          "WITH " <> normalizedBody body <> ", " <>
+          H.sql (
+            BS.unwords [
+            "pgrst_args AS (",
+              "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (const mempty) (\a -> " " <> encodeUtf8 (pgaType a)) <> ")",
+            ")"])
+         , H.sql $ if paramsAsMultipleObjects
+             then fmtArgs varadicPrefix (\a -> " := pgrst_args." <> pgFmtIdent (pgaName a))
+             else fmtArgs varadicPrefix (\a -> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM pgrst_args LIMIT 1)")
+        )
+
+    fmtArgs :: (PgArg -> SqlFragment) -> (PgArg -> SqlFragment) -> SqlFragment
+    fmtArgs argFragPre argFragSuf = BS.intercalate ", " ((\a -> argFragPre a <> pgFmtIdent (pgaName a) <> argFragSuf a) <$> pgArgs)
+
+    varadicPrefix :: PgArg -> SqlFragment
+    varadicPrefix a = if pgaVar a then "VARIADIC " else mempty
+
+    sourceBody :: H.Snippet
+    sourceBody
+      | paramsAsMultipleObjects =
+          if returnsScalar
+            then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"
+            else "SELECT pgrst_lat_args.* FROM pgrst_args, " <>
+                 "LATERAL ( SELECT " <> returnedColumns <> " FROM " <> callIt <> " ) pgrst_lat_args"
+      | otherwise =
+          if returnsScalar
+            then "SELECT " <> callIt <> " AS pgrst_scalar"
+            else "SELECT " <> returnedColumns <> " FROM " <> callIt
+
+    callIt :: H.Snippet
+    callIt = H.sql (fromQi qi) <> "(" <> args <> ")"
+
+    returnedColumns :: H.Snippet
+    returnedColumns
+      | null returnings = "*"
+      | otherwise       = H.sql $ BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings)
+
+
+-- | SQL query meant for COUNTing the root node of the Tree.
+-- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT.
+-- SELECT 1 is done instead of SELECT * to prevent doing expensive operations(like functions based on the columns)
+-- inside the FROM target.
+readRequestToCountQuery :: ReadRequest -> H.Snippet
+readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) =
+ "SELECT 1 " <> "FROM " <> H.sql (fromQi qi) <> " " <>
+ if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest)
+
+limitedQuery :: H.Snippet -> Maybe Integer -> H.Snippet
+limitedQuery query maxRows = query <> H.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows)

src/PostgREST/Query/SqlFragment.hs

@@ -0,0 +1,322 @@
+{-# LANGUAGE LambdaCase  #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-|
+Module      : PostgREST.Query.SqlFragment
+Description : Helper functions for PostgREST.QueryBuilder.
+
+Any function that outputs a SqlFragment should be in this module.
+-}
+module PostgREST.Query.SqlFragment
+  ( noLocationF
+  , SqlFragment
+  , asBinaryF
+  , asCsvF
+  , asJsonF
+  , asJsonSingleF
+  , countF
+  , fromQi
+  , ftsOperators
+  , jsonPlaceHolder
+  , limitOffsetF
+  , locationF
+  , normalizedBody
+  , operators
+  , pgFmtColumn
+  , pgFmtIdent
+  , pgFmtJoinCondition
+  , pgFmtLogicTree
+  , pgFmtOrderTerm
+  , pgFmtSelectItem
+  , responseHeadersF
+  , responseStatusF
+  , returningF
+  , selectBody
+  , sourceCTEName
+  , unknownEncoder
+  , intercalateSnippet
+  ) where
+
+import qualified Data.ByteString.Char8           as BS
+import qualified Data.ByteString.Lazy            as BL
+import qualified Data.HashMap.Strict             as HM
+import qualified Data.Text                       as T
+import qualified Hasql.DynamicStatements.Snippet as H
+import qualified Hasql.Encoders                  as HE
+
+import Data.Foldable                 (foldr1)
+import Text.InterpolatedString.Perl6 (qc)
+
+import PostgREST.Config.PgVersion        (PgVersion, pgVersion96)
+import PostgREST.DbStructure.Identifiers (FieldName,
+                                          QualifiedIdentifier (..))
+import PostgREST.RangeQuery              (NonnegRange, allRange,
+                                          rangeLimit, rangeOffset)
+import PostgREST.Request.Types           (Alias, Field, Filter (..),
+                                          JoinCondition (..),
+                                          JsonOperand (..),
+                                          JsonOperation (..),
+                                          JsonPath, LogicTree (..),
+                                          OpExpr (..), Operation (..),
+                                          OrderTerm (..), SelectItem)
+
+import Protolude      hiding (cast, toS)
+import Protolude.Conv (toS)
+
+
+-- | A part of a SQL query that cannot be executed independently
+type SqlFragment = ByteString
+
+noLocationF :: SqlFragment
+noLocationF = "array[]::text[]"
+
+sourceCTEName :: SqlFragment
+sourceCTEName = "pgrst_source"
+
+operators :: HM.HashMap Text SqlFragment
+operators = HM.union (HM.fromList [
+  ("eq", "="),
+  ("gte", ">="),
+  ("gt", ">"),
+  ("lte", "<="),
+  ("lt", "<"),
+  ("neq", "<>"),
+  ("like", "LIKE"),
+  ("ilike", "ILIKE"),
+  ("in", "IN"),
+  ("is", "IS"),
+  ("cs", "@>"),
+  ("cd", "<@"),
+  ("ov", "&&"),
+  ("sl", "<<"),
+  ("sr", ">>"),
+  ("nxr", "&<"),
+  ("nxl", "&>"),
+  ("adj", "-|-")]) ftsOperators
+
+ftsOperators :: HM.HashMap Text SqlFragment
+ftsOperators = HM.fromList [
+  ("fts", "@@ to_tsquery"),
+  ("plfts", "@@ plainto_tsquery"),
+  ("phfts", "@@ phraseto_tsquery"),
+  ("wfts", "@@ websearch_to_tsquery")
+  ]
+
+-- |
+-- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads
+-- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays
+-- We do this in SQL to avoid processing the JSON in application code
+normalizedBody :: Maybe BL.ByteString -> H.Snippet
+normalizedBody body =
+  "pgrst_payload AS (SELECT " <> jsonPlaceHolder body <> " AS json_data), " <>
+  H.sql (BS.unwords [
+    "pgrst_body AS (",
+      "SELECT",
+        "CASE WHEN json_typeof(json_data) = 'array'",
+          "THEN json_data",
+          "ELSE json_build_array(json_data)",
+        "END AS val",
+      "FROM pgrst_payload)"])
+
+-- | Equivalent to "$1::json"
+-- | TODO: At this stage there shouldn't be a Maybe since ApiRequest should ensure that an INSERT/UPDATE has a body
+jsonPlaceHolder :: Maybe BL.ByteString -> H.Snippet
+jsonPlaceHolder body =
+  H.encoderAndParam (HE.nullable HE.unknown) (toS <$> body) <> "::json"
+
+selectBody :: SqlFragment
+selectBody = "(SELECT val FROM pgrst_body)"
+
+pgFmtLit :: Text -> SqlFragment
+pgFmtLit x =
+ let trimmed = trimNullChars x
+     escaped = "'" <> T.replace "'" "''" trimmed <> "'"
+     slashed = T.replace "\\" "\\\\" escaped in
+ encodeUtf8 $ if "\\" `T.isInfixOf` escaped
+   then "E" <> slashed
+   else slashed
+
+-- TODO: refactor by following https://github.com/PostgREST/postgrest/pull/1631#issuecomment-711070833
+pgFmtIdent :: Text -> SqlFragment
+pgFmtIdent x = encodeUtf8 $ "\"" <> T.replace "\"" "\"\"" (trimNullChars x) <> "\""
+
+trimNullChars :: Text -> Text
+trimNullChars = T.takeWhile (/= '\x0')
+
+asCsvF :: SqlFragment
+asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
+  where
+    asCsvHeaderF =
+      "(SELECT coalesce(string_agg(a.k, ','), '')" <>
+      "  FROM (" <>
+      "    SELECT json_object_keys(r)::text as k" <>
+      "    FROM ( " <>
+      "      SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
+      "    ) s" <>
+      "  ) a" <>
+      ")"
+    asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
+
+asJsonF :: Bool -> SqlFragment
+asJsonF returnsScalar
+  | returnsScalar = "coalesce(json_agg(_postgrest_t.pgrst_scalar), '[]')::character varying"
+  | otherwise     = "coalesce(json_agg(_postgrest_t), '[]')::character varying"
+
+asJsonSingleF :: Bool -> SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
+asJsonSingleF returnsScalar
+  | returnsScalar = "coalesce(string_agg(to_json(_postgrest_t.pgrst_scalar)::text, ','), 'null')::character varying"
+  | otherwise     = "coalesce(string_agg(to_json(_postgrest_t)::text, ','), '')::character varying"
+
+asBinaryF :: FieldName -> SqlFragment
+asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
+
+locationF :: [Text] -> SqlFragment
+locationF pKeys = [qc|(
+  WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1)
+  SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))
+  FROM data CROSS JOIN json_each_text(data.row) AS json_data
+  WHERE json_data.key IN ('{fmtPKeys}')
+)|]
+  where
+    fmtPKeys = T.intercalate "','" pKeys
+
+fromQi :: QualifiedIdentifier -> SqlFragment
+fromQi t = (if T.null s then mempty else pgFmtIdent s <> ".") <> pgFmtIdent n
+  where
+    n = qiName t
+    s = qiSchema t
+
+pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
+pgFmtColumn table "*" = fromQi table <> ".*"
+pgFmtColumn table c   = fromQi table <> "." <> pgFmtIdent c
+
+pgFmtField :: QualifiedIdentifier -> Field -> H.Snippet
+pgFmtField table (c, jp) = H.sql (pgFmtColumn table c) <> pgFmtJsonPath jp
+
+pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> H.Snippet
+pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> H.sql (pgFmtAs fName jp alias)
+-- Ideally we'd quote the cast with "pgFmtIdent cast". However, that would invalidate common casts such as "int", "bigint", etc.
+-- Try doing: `select 1::"bigint"` - it'll err, using "int8" will work though. There's some parser magic that pg does that's invalidated when quoting.
+-- Not quoting should be fine, we validate the input on Parsers.
+pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> H.sql (encodeUtf8 cast) <> " )" <> H.sql (pgFmtAs fName jp alias)
+
+pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> H.Snippet
+pgFmtOrderTerm qi ot =
+  pgFmtField qi (otTerm ot) <> " " <>
+  H.sql (BS.unwords [
+    BS.pack $ maybe mempty show $ otDirection ot,
+    BS.pack $ maybe mempty show $ otNullOrder ot])
+
+pgFmtFilter :: QualifiedIdentifier -> Filter -> H.Snippet
+pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of
+   Op op val  -> pgFmtFieldOp op <> " " <> case op of
+     "like"  -> unknownLiteral (T.map star val)
+     "ilike" -> unknownLiteral (T.map star val)
+     "is"    -> isAllowed val
+     _       -> unknownLiteral val
+
+   -- We don't use "IN", we use "= ANY". IN has the following disadvantages:
+   -- + No way to use an empty value on IN: "col IN ()" is invalid syntax. With ANY we can do "= ANY('{}')"
+   -- + Can invalidate prepared statements: multiple parameters on an IN($1, $2, $3) will lead to using different prepared statements and not take advantage of caching.
+   In vals -> pgFmtField table fld <> " " <>
+    case vals of
+      [""] -> "= ANY('{}') "
+      -- Here we build the pg array, e.g '{"Hebdon, John","Other","Another"}', manually. We quote the values to prevent the "," being treated as an element separator.
+      -- TODO: Ideally this would be done on Hasql with an encoder, but the "array unknown" is not working(Hasql doesn't pass any value).
+      _    -> "= ANY (" <> unknownLiteral ("{" <> T.intercalate "," ((\x -> "\"" <> x <> "\"") <$> vals) <> "}") <> ")"
+
+   Fts op lang val ->
+     pgFmtFieldOp op <> "(" <> ftsLang lang <> unknownLiteral val <> ") "
+ where
+   ftsLang = maybe mempty (\l -> unknownLiteral l <> ", ")
+   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
+   sqlOperator o = H.sql $ HM.lookupDefault "=" o operators
+   notOp = if hasNot then "NOT" else mempty
+   star c = if c == '*' then '%' else c
+   -- IS cannot be prepared. `PREPARE boolplan AS SELECT * FROM projects where id IS $1` will give a syntax error.
+   -- The above can be fixed by using `PREPARE boolplan AS SELECT * FROM projects where id IS NOT DISTINCT FROM $1;`
+   -- However that would not accept the TRUE/FALSE/NULL keywords. See: https://stackoverflow.com/questions/6133525/proper-way-to-set-preparedstatement-parameter-to-null-under-postgres.
+   isAllowed :: Text -> H.Snippet
+   isAllowed v = H.sql $ maybe
+     (pgFmtLit v <> "::unknown") encodeUtf8
+     (find ((==) . T.toLower $ v) ["null","true","false"])
+
+pgFmtJoinCondition :: JoinCondition -> H.Snippet
+pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) =
+  H.sql $ pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2
+
+pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> H.Snippet
+pgFmtLogicTree qi (Expr hasNot op forest) = H.sql notOp <> " (" <> intercalateSnippet (" " <> BS.pack (show op) <> " ") (pgFmtLogicTree qi <$> forest) <> ")"
+  where notOp =  if hasNot then "NOT" else mempty
+pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
+
+pgFmtJsonPath :: JsonPath -> H.Snippet
+pgFmtJsonPath = \case
+  []             -> mempty
+  (JArrow x:xs)  -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
+  (J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs
+  where
+    pgFmtJsonOperand (JKey k) = unknownLiteral k
+    pgFmtJsonOperand (JIdx i) = unknownLiteral i <> "::int"
+
+pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment
+pgFmtAs _ [] Nothing = mempty
+pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of
+  Just (JKey key) -> " AS " <> pgFmtIdent key
+  Just (JIdx _)   -> " AS " <> pgFmtIdent (fromMaybe fName lastKey)
+    -- We get the lastKey because on:
+    -- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ]
+    -- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ]
+    where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp)
+  Nothing -> mempty
+pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias
+
+countF :: H.Snippet -> Bool -> (H.Snippet, SqlFragment)
+countF countQuery shouldCount =
+  if shouldCount
+    then (
+        ", pgrst_source_count AS (" <> countQuery <> ")"
+      , "(SELECT pg_catalog.count(*) FROM pgrst_source_count)" )
+    else (
+        mempty
+      , "null::bigint")
+
+returningF :: QualifiedIdentifier -> [FieldName] -> SqlFragment
+returningF qi returnings =
+  if null returnings
+    then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified
+    else "RETURNING " <> BS.intercalate ", " (pgFmtColumn qi <$> returnings)
+
+limitOffsetF :: NonnegRange -> H.Snippet
+limitOffsetF range =
+  if range == allRange then mempty else "LIMIT " <> limit <> " OFFSET " <> offset
+  where
+    limit = maybe "ALL" (\l -> unknownEncoder (BS.pack $ show l)) $ rangeLimit range
+    offset = unknownEncoder (BS.pack . show $ rangeOffset range)
+
+responseHeadersF :: PgVersion -> SqlFragment
+responseHeadersF pgVer =
+  if pgVer >= pgVersion96
+    then currentSettingF "response.headers"
+    else "null"
+
+responseStatusF :: PgVersion -> SqlFragment
+responseStatusF pgVer =
+  if pgVer >= pgVersion96
+    then currentSettingF "response.status"
+    else "null"
+
+currentSettingF :: Text -> SqlFragment
+currentSettingF setting =
+  -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15
+  "nullif(current_setting(" <> pgFmtLit setting <> ", true), '')"
+
+-- Hasql Snippet utilities
+unknownEncoder :: ByteString -> H.Snippet
+unknownEncoder = H.encoderAndParam (HE.nonNullable HE.unknown)
+
+unknownLiteral :: Text -> H.Snippet
+unknownLiteral = unknownEncoder . encodeUtf8
+
+intercalateSnippet :: ByteString -> [H.Snippet] -> H.Snippet
+intercalateSnippet _ [] = mempty
+intercalateSnippet frag snippets = foldr1 (\a b -> a <> H.sql frag <> b) snippets

src/PostgREST/Query/Statements.hs

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

src/PostgREST/QueryBuilder.hs

@@ -1,181 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# OPTIONS_GHC -fno-warn-orphans  #-}
-{-|
-Module      : PostgREST.QueryBuilder
-Description : PostgREST SQL queries generating functions.
-
-This module provides functions to consume data types that
-represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment
-to produce SqlQuery type outputs.
--}
-module PostgREST.QueryBuilder (
-    readRequestToQuery
-  , mutateRequestToQuery
-  , readRequestToCountQuery
-  , requestToCallProcQuery
-  , limitedQuery
-  , setLocalQuery
-  , setLocalSearchPathQuery
-  ) where
-
-import qualified Data.Set as S
-
-import Data.Text (intercalate, unwords)
-import Data.Tree (Tree (..))
-
-import Data.Maybe
-
-import PostgREST.Private.QueryFragment
-import PostgREST.RangeQuery            (allRange, rangeLimit,
-                                        rangeOffset)
-import PostgREST.Types
-import Protolude                       hiding (cast, intercalate,
-                                        replace)
-
-readRequestToQuery :: ReadRequest -> SqlQuery
-readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) =
-  unwords [
-    "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
-    "FROM " <> intercalate ", " (tabl : implJs),
-    unwords joins,
-    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_))
-      `emptyOnFalse` (null logicForest && null joinConditions_),
-    ("ORDER BY " <> intercalate ", " (map (pgFmtOrderTerm qi) ordts)) `emptyOnFalse` null ordts,
-    ("LIMIT " <> maybe "ALL" show (rangeLimit range) <> " OFFSET " <> show (rangeOffset range)) `emptyOnFalse` (range == allRange)
-    ]
-  where
-    implJs = fromQi <$> implJoins
-    tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias
-    qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias
-    (joins, selects) = foldr getJoinsSelects ([],[]) forest
-
-getJoinsSelects :: ReadRequest -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
-getJoinsSelects rr@(Node (_, (name, Just Relation{relType=relTyp,relTable=Table{tableName=table}}, alias, _, _)) _) (j,s) =
-  let subquery = readRequestToQuery rr in
-  case relTyp of
-    M2O ->
-      let aliasOrName = fromMaybe name alias
-          localTableName = pgFmtIdent $ table <> "_" <> aliasOrName
-          sel = "row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName
-          joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> localTableName <> " ON TRUE " in
-      (joi:j,sel:s)
-    _ ->
-      let sel = "COALESCE (("
-             <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) "
-             <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
-             <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias) in
-      (j,sel:s)
-getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], [])
-
-mutateRequestToQuery :: MutateRequest -> SqlQuery
-mutateRequestToQuery (Insert mainQi iCols onConflct putConditions returnings) =
-  unwords [
-    "WITH " <> normalizedBody,
-    "INSERT INTO ", fromQi mainQi, if S.null iCols then " " else "(" <> cols <> ")",
-    unwords [
-      "SELECT " <> cols <> " FROM",
-      "json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ") _",
-      -- Only used for PUT
-      ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) `emptyOnFalse` null putConditions],
-    maybe "" (\(oncDo, oncCols) -> (
-      "ON CONFLICT(" <> intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of
-      IgnoreDuplicates ->
-        "DO NOTHING"
-      MergeDuplicates  ->
-        if S.null iCols
-           then "DO NOTHING"
-           else "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols)
-                                   ) `emptyOnFalse` null oncCols) onConflct,
-    returningF mainQi returnings
-    ]
-  where
-    cols = intercalate ", " $ pgFmtIdent <$> S.toList iCols
-mutateRequestToQuery (Update mainQi uCols logicForest returnings) =
-  if S.null uCols
-    then "WITH " <> ignoredBody <> "SELECT null WHERE false" -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax
-    else
-      unwords [
-        "WITH " <> normalizedBody,
-        "UPDATE " <> fromQi mainQi <> " SET " <> cols,
-        "FROM (SELECT * FROM json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ")) _ ",
-        ("WHERE " <> intercalate " AND " (pgFmtLogicTree mainQi <$> logicForest)) `emptyOnFalse` null logicForest,
-        returningF mainQi returnings
-        ]
-  where
-    cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols)
-mutateRequestToQuery (Delete mainQi logicForest returnings) =
-  unwords [
-    "WITH " <> ignoredBody,
-    "DELETE FROM ", fromQi mainQi,
-    ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree mainQi) logicForest)) `emptyOnFalse` null logicForest,
-    returningF mainQi returnings
-    ]
-
-requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Bool -> Maybe PreferParameters -> SqlQuery
-requestToCallProcQuery qi pgArgs returnsScalar preferParams =
-  unwords [
-    "WITH",
-    argsCTE,
-    sourceBody ]
-  where
-    paramsAsSingleObject    = preferParams == Just SingleObject
-    paramsAsMulitpleObjects = preferParams == Just MultipleObjects
-
-    (argsCTE, args)
-      | null pgArgs = (ignoredBody, "")
-      | paramsAsSingleObject = ("pgrst_args AS (SELECT NULL)", "$1::json")
-      | otherwise = (
-          unwords [
-            normalizedBody <> ",",
-            "pgrst_args AS (",
-              "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (\a -> " " <> pgaType a) <> ")",
-            ")"]
-         , if paramsAsMulitpleObjects
-             then fmtArgs (\a -> " := pgrst_args." <> pgFmtIdent (pgaName a))
-             else fmtArgs (\a -> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM pgrst_args LIMIT 1)")
-        )
-
-    fmtArgs :: (PgArg -> SqlFragment) -> SqlFragment
-    fmtArgs argFrag = intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> argFrag a) <$> pgArgs)
-
-    sourceBody :: SqlFragment
-    sourceBody
-      | paramsAsMulitpleObjects =
-          if returnsScalar
-            then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"
-            else unwords [ "SELECT pgrst_lat_args.*"
-                         , "FROM pgrst_args,"
-                         , "LATERAL ( SELECT * FROM " <> callIt <> " ) pgrst_lat_args" ]
-      | otherwise =
-          if returnsScalar
-            then "SELECT " <> callIt <> " AS pgrst_scalar"
-            else "SELECT * FROM " <> callIt
-
-    callIt :: SqlFragment
-    callIt = fromQi qi <> "(" <> args <> ")"
-
-
--- | SQL query meant for COUNTing the root node of the Tree.
--- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT.
--- SELECT 1 is done instead of SELECT * to prevent doing expensive operations(like functions based on the columns)
--- inside the FROM target.
-readRequestToCountQuery :: ReadRequest -> SqlQuery
-readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) =
- unwords [
-   "SELECT 1",
-   "FROM " <> fromQi qi,
-   ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest
-   ]
-
-limitedQuery :: SqlQuery -> Maybe Integer -> SqlQuery
-limitedQuery query maxRows = query <> maybe mempty (\x -> " LIMIT " <> show x) maxRows
-
-setLocalQuery :: Text -> (Text, Text) -> SqlQuery
-setLocalQuery prefix (k, v) =
-  "SET LOCAL " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";"
-
-setLocalSearchPathQuery :: [Text] -> SqlQuery
-setLocalSearchPathQuery vals =
-  "SET LOCAL search_path = " <> intercalate ", " (pgFmtLit <$> vals) <> ";"

src/PostgREST/RangeQuery.hs

@@ -26,7 +26,8 @@ import Data.Ranged.Ranges
 import Network.HTTP.Types.Header
 import Network.HTTP.Types.Status
 
-import Protolude
+import Protolude      hiding (toS)
+import Protolude.Conv (toS)
 
 type NonnegRange = Range Integer
 
@@ -91,12 +92,12 @@ rangeStatusHeader topLevelRange queryTotal tableTotal =
 
 contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header
 contentRangeH lower upper total =
-    ("Content-Range", headerValue)
+    ("Content-Range", toUtf8 headerValue)
     where
-      headerValue   = rangeString <> "/" <> totalString
+      headerValue   = rangeString <> "/" <> totalString :: Text
       rangeString
         | totalNotZero && fromInRange = show lower <> "-" <> show upper
         | otherwise = "*"
       totalString   = maybe "*" show total
-      totalNotZero  = maybe True (0 /=) total
+      totalNotZero  = Just 0 /= total
       fromInRange   = lower <= upper

src/PostgREST/Request/ApiRequest.hs

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

src/PostgREST/Request/DbRequestBuilder.hs

@@ -1,69 +1,95 @@
 {-|
-Module      : PostgREST.DbRequestBuilder
+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.
+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.
+A query tree is built in case of resource embedding. By inferring the
+relationship between tables, join conditions are added for every embedded
+resource.
 -}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE RecordWildCards       #-}
 
-module PostgREST.DbRequestBuilder (
+module PostgREST.Request.DbRequestBuilder
-  readRequest
+  ( readRequest
-, mutateRequest
+  , mutateRequest
-) where
+  , returningCols
+  ) where
 
 import qualified Data.HashMap.Strict as M
 import qualified Data.Set            as S
 
 import Control.Arrow           ((***))
 import Data.Either.Combinators (mapLeft)
-import Data.Foldable           (foldr1)
 import Data.List               (delete)
 import Data.Text               (isInfixOf)
+import Data.Tree               (Tree (..))
 
-import Control.Applicative
+import PostgREST.DbStructure.Identifiers  (FieldName,
-import Data.Tree
+                                           QualifiedIdentifier (..),
-import Network.Wai
+                                           Schema, TableName)
+import PostgREST.DbStructure.Relationship (Cardinality (..),
+                                           Junction (..),
+                                           Relationship (..))
+import PostgREST.DbStructure.Table        (Column (..), Table (..),
+                                           tableQi)
+import PostgREST.Error                    (ApiRequestError (..),
+                                           Error (..))
+import PostgREST.Query.SqlFragment        (sourceCTEName)
+import PostgREST.RangeQuery               (NonnegRange, allRange,
+                                           restrictRange)
+import PostgREST.Request.ApiRequest       (Action (..),
+                                           ApiRequest (..),
+                                           PayloadJSON (..))
 
-import PostgREST.ApiRequest (Action (..), ApiRequest (..))
+import PostgREST.Request.Parsers
-import PostgREST.Error      (ApiRequestError (..), errorResponseFor)
+import PostgREST.Request.Preferences
-import PostgREST.Parsers
+import PostgREST.Request.Types
-import PostgREST.RangeQuery (NonnegRange, allRange, restrictRange)
-import PostgREST.Types
-import Protolude            hiding (from)
 
-readRequest :: Schema -> TableName -> Maybe Integer -> [Relation] -> ApiRequest -> Either Response ReadRequest
+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 errorResponseFor $
+  mapLeft ApiRequestError $
   treeRestrictRange maxRows =<<
-  augumentRequestWithJoin schema rootRels =<<
+  augmentRequestWithJoin schema rootRels =<<
-  addFiltersOrdersRanges apiRequest <*>
+  (addFiltersOrdersRanges apiRequest . initReadRequest rootName =<< pRequestSelect sel)
-  (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).
+-- This is done because of the shape of the final SQL Query. The mutation cases
--- So we need a FROM {sourceCTEName} instead of FROM {tableName}.
+-- are wrapped in a WITH {sourceCTEName}(see Statements.hs).  So we need a FROM
-rootWithRels :: Schema -> TableName -> [Relation] -> Action -> (QualifiedIdentifier, [Relation])
+-- {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
+  _            -> (QualifiedIdentifier mempty _sourceCTEName, mapMaybe toSourceRel allRels ++ allRels) -- mutation cases and calling proc
   where
-    -- To enable embedding in the sourceCTEName cases we need to replace the foreign key tableName in the Relation
+    _sourceCTEName = decodeUtf8 sourceCTEName
-    -- with {sourceCTEName}. This way findRel can find relationships with sourceCTEName.
+    -- To enable embedding in the sourceCTEName cases we need to replace the
-    toSourceRel :: Relation -> Maybe Relation
+    -- foreign key tableName in the Relationship with {sourceCTEName}. This way
-    toSourceRel r@Relation{relTable=t}
+    -- findRel can find relationships with sourceCTEName.
-      | rootTableName == tableName t = Just $ r {relTable=t {tableName=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
+-- Build the initial tree with a Depth attribute so when a self join occurs we
--- an alias like "table_depth", this is related to http://github.com/PostgREST/postgrest/issues/987.
+-- 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
@@ -83,22 +109,23 @@ initReadRequest rootQi =
                 (fn, Nothing, alias, embedHint, nxtDepth)) [])
               fldForest:rForest
 
+-- | Enforces the `max-rows` config on the result
 treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
 treeRestrictRange maxRows request = pure $ nodeRestrictRange maxRows <$> request
   where
     nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
     nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
 
-augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest
+augmentRequestWithJoin :: Schema -> [Relationship] -> ReadRequest -> Either ApiRequestError ReadRequest
-augumentRequestWithJoin schema allRels request =
+augmentRequestWithJoin schema allRels request =
   addRels schema allRels Nothing request
   >>= addJoinConditions Nothing
 
-addRels :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
+addRels :: Schema -> [Relationship] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
 addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, hint, depth)) forest) =
   case parentNode of
     Just (Node (Select{from=parentNodeQi}, _) _) ->
-      let newFrom r = if qiName tbl == nodeName then tableQi (relFTable r) else tbl
+      let newFrom r = if qiName tbl == nodeName then tableQi (relForeignTable r) else tbl
           newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel
           rel = findRel schema allRels (qiName parentNodeQi) nodeName hint
       in
@@ -108,46 +135,55 @@ addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, a
       Node rn <$> updateForest (Just $ Node rn forest)
   where
     updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
-    updateForest rq = mapM (addRels schema allRels rq) forest
+    updateForest rq = addRels schema allRels rq `traverse` forest
 
--- Finds a relationship between an origin and a target in the request: /origin?select=target(*)
+-- Finds a relationship between an origin and a target in the request:
--- If more than one relationship is found then the request is ambiguous and we return an error.
+-- /origin?select=target(*) If more than one relationship is found then the
--- In that case the request can be disambiguated by adding precision to the target or by using a hint: /origin?select=target!hint(*)
+-- request is ambiguous and we return an error.  In that case the request can
--- The elements will be matched according to these rules:
+-- be disambiguated by adding precision to the target or by using a hint:
+-- /origin?select=target!hint(*) The elements will be matched according to
+-- these rules:
 -- origin = table / view
 -- target = table / view / constraint / column-from-origin
 -- hint   = table / view / constraint / column-from-origin / column-from-target
 -- (hint can take table / view values to aid in finding the junction in an m2m relationship)
-findRel :: Schema -> [Relation] -> NodeName -> NodeName -> Maybe EmbedHint -> Either ApiRequestError Relation
+findRel :: Schema -> [Relationship] -> NodeName -> NodeName -> Maybe EmbedHint -> Either ApiRequestError Relationship
 findRel schema allRels origin target hint =
   case rel of
     []  -> Left $ NoRelBetween origin target
     [r] -> Right r
-    rs  ->
+    -- Here we handle a self reference relationship to not cause a breaking
-      -- Return error if more than one relationship is found, unless we're in a self reference case.
+    -- change: In a self reference we get two relationships with the same
-      --
+    -- foreign key and relTable/relFtable but with different
-      -- Here we handle a self reference relationship to not cause a breaking change:
+    -- cardinalities(m2o/o2m) We output the O2M rel, the M2O rel can be
-      -- In a self reference we get two relationships with the same foreign key and relTable/relFtable but with different cardinalities(m2o/o2m)
+    -- obtained by using the origin column as an embed hint.
-      -- 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
-      let [rel0, rel1] = take 2 rs in
+      (O2M cons1, M2O cons2, True) -> if cons1 == cons2 then Right rel0 else Left $ AmbiguousRelBetween origin target rs
-      if length rs == 2 && relConstraint rel0 == relConstraint rel1 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1
+      (M2O cons1, O2M cons2, True) -> if cons1 == cons2 then Right rel1 else Left $ AmbiguousRelBetween origin target rs
-        then note (NoRelBetween origin target) (find (\r -> relType r == O2M) rs)
+      _                            -> Left $ AmbiguousRelBetween origin target rs
-        else 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 (
-      \Relation{relTable, relColumns, relConstraint, relFTable, relFColumns, relType, relJunction} ->
+      \Relationship{..} ->
         -- Both relationship ends need to be on the exposed schema
-        schema == tableSchema relTable && schema == tableSchema relFTable &&
+        schema == tableSchema relTable && schema == tableSchema relForeignTable &&
         (
           -- /projects?select=clients(*)
           origin == tableName relTable  &&  -- projects
-          target == tableName relFTable ||  -- clients
+          target == tableName relForeignTable ||  -- clients
 
           -- /projects?select=projects_client_id_fkey(*)
           (
-            origin == tableName relTable && -- projects
+            origin == tableName relTable &&              -- projects
-            Just target == relConstraint    -- projects_client_id_fkey
+            matchConstraint (Just target) relCardinality -- projects_client_id_fkey
           ) ||
           -- /projects?select=client_id(*)
           (
@@ -158,17 +194,14 @@ findRel schema allRels origin target hint =
           isNothing hint || -- hint is optional
 
           -- /projects?select=clients!projects_client_id_fkey(*)
-          hint == relConstraint             || -- 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 relFColumns || -- id
+          matchFKSingleCol hint relForeignColumns || -- id
 
-          -- /users?select=tasks!users_tasks(*)
+          -- /users?select=tasks!users_tasks(*) many-to-many between users and tasks
-          (
+          matchJunction hint relCardinality -- users_tasks
-            relType == M2M &&                              -- many-to-many between users and tasks
-            hint == (tableName . junTable <$> relJunction) -- users_tasks
-          )
         )
       ) allRels
 
@@ -176,18 +209,13 @@ findRel schema allRels origin target hint =
 addJoinConditions :: Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest
 addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, rel, _, _, depth)) forest) =
   case rel of
-    Just r@Relation{relType=O2M} -> Node (augmentQuery r, nodeProps) <$> updatedForest
+    Just r@Relationship{relCardinality=M2M Junction{junTable}} ->
-    Just r@Relation{relType=M2O} -> Node (augmentQuery r, nodeProps) <$> updatedForest
+      let rq = augmentQuery r in
-    Just r@Relation{relType=M2M, relJunction=junction} ->
+      Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest
-      case junction of
+    Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest
-        Just Junction{junTable} ->
-          let rq = augmentQuery r in
-          Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest
-        Nothing ->
-          Left UnknownRelation
     Nothing -> Node node <$> updatedForest
   where
-    newAlias = case isSelfReference <$> rel of
+    newAlias = case Relationship.isSelfReference <$> rel of
       Just True
         | depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased
         | otherwise  -> Nothing
@@ -197,21 +225,16 @@ addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_
         (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs})
         query{fromAlias=newAlias}
         (getJoinConditions previousAlias newAlias r)
-    updatedForest = mapM (addJoinConditions newAlias) forest
+    updatedForest = addJoinConditions newAlias `traverse` forest
 
 -- previousAlias and newAlias are used in the case of self joins
-getJoinConditions :: Maybe Alias -> Maybe Alias -> Relation -> [JoinCondition]
+getJoinConditions :: Maybe Alias -> Maybe Alias -> Relationship -> [JoinCondition]
-getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, tableName=tN} cols _ Table{tableName=ftN} fCols typ jun) =
+getJoinConditions previousAlias newAlias (Relationship Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols card) =
-  case typ of
+  case card of
-    O2M ->
+    M2M (Junction Table{tableName=jtn} _ jc1 _ jc2) ->
-        zipWith (toJoinCondition tN ftN) cols fCols
+      zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2
-    M2O ->
+    _ ->
-        zipWith (toJoinCondition tN ftN) cols fCols
+      zipWith (toJoinCondition tN ftN) cols fCols
-    M2M -> case jun of
-        Just (Junction jt _ jc1 _ jc2) ->
-          let jtn = tableName jt in
-          zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2
-        Nothing -> []
   where
     toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition
     toJoinCondition tb ftb c fc =
@@ -220,28 +243,28 @@ getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, ta
         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}
+    -- On mutation and calling proc cases we wrap the target table in a WITH
-    -- if this happens remove the schema `FROM "schema"."{sourceCTEName}"` and use only the
+    -- {sourceCTEName} if this happens remove the schema `FROM
-    -- `FROM "{sourceCTEName}"`. If the schema remains the FROM would be invalid.
+    -- "schema"."{sourceCTEName}"` and use only the `FROM "{sourceCTEName}"`.
+    -- If the schema remains the FROM would be invalid.
     removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
-    removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then mempty else schema) tbl
+    removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == decodeUtf8 sourceCTEName then mempty else schema) tbl
 
-addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest)
+addFiltersOrdersRanges :: ApiRequest -> ReadRequest -> Either ApiRequestError ReadRequest
-addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
+addFiltersOrdersRanges apiRequest rReq = do
-    flip (foldr addFilter) <$> filters,
+  rFlts <- foldr addFilter rReq <$> filters
-    flip (foldr addOrder) <$> orders,
+  rOrds <- foldr addOrder rFlts <$> orders
-    flip (foldr addRange) <$> ranges,
+  rRngs <- foldr addRange rOrds <$> ranges
-    flip (foldr addLogicTree) <$> logicForest
+  foldr addLogicTree rRngs      <$> logicForest
-  ]
-  {-
-  The esence of what is going on above is that we are composing tree functions
-  of type (ReadRequest->ReadRequest) that are in (Either ApiRequestError a) context
-  -}
   where
     filters :: Either ApiRequestError [(EmbedPath, Filter)]
-    filters = mapM pRequestFilter flts
+    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 = mapM pRequestLogicTree logFrst
+    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) =
@@ -249,10 +272,6 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
         ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest)
         ActionRead _   -> (iFilters apiRequest, iLogic apiRequest)
         _              -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
-    orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]
-    orders = mapM pRequestOrder $ iOrder apiRequest
-    ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]
-    ranges = mapM pRequestRange $ M.toList $ iRange apiRequest
 
 addFilterToNode :: Filter -> ReadRequest -> ReadRequest
 addFilterToNode flt (Node (q@Select {where_=lf}, i) f) = Node (q{where_=addFilterToLogicForest flt lf}::ReadQuery, i) f
@@ -287,15 +306,15 @@ addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =
   where
     pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest
 
-mutateRequest :: Schema -> TableName -> ApiRequest -> S.Set FieldName -> [FieldName] -> ReadRequest -> Either Response MutateRequest
+mutateRequest :: Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Error MutateRequest
-mutateRequest schema tName apiRequest cols pkCols readReq = mapLeft errorResponseFor $
+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 cols ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
+        pure $ Insert qi (iColumns apiRequest) body ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
-    ActionUpdate -> Update qi cols <$> combinedLogic <*> pure returnings
+    ActionUpdate -> Update qi (iColumns apiRequest) body  <$> combinedLogic <*> pure returnings
     ActionSingleUpsert ->
       (\flts ->
         if null (iLogic apiRequest) &&
@@ -303,8 +322,8 @@ mutateRequest schema tName apiRequest cols pkCols readReq = mapLeft errorRespons
            not (null (S.fromList pkCols)) &&
            all (\case
               Filter _ (OpExpr False (Op "eq" _)) -> True
-              _ -> False) flts
+              _                                   -> False) flts
-          then Insert qi cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
+          then Insert qi (iColumns apiRequest) body (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
         else
           Left InvalidFilters) =<< filters
     ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings
@@ -315,34 +334,41 @@ mutateRequest schema tName apiRequest cols pkCols readReq = mapLeft errorRespons
     returnings =
       if iPreferRepresentation apiRequest == None
         then []
-        else returningCols readReq
+        else returningCols readReq pkCols
-    filters = map snd <$> mapM pRequestFilter mutateFilters
+    filters = map snd <$> pRequestFilter `traverse` mutateFilters
-    logic = map snd <$> mapM pRequestLogicTree logicFilters
+    logic = map snd <$> pRequestLogicTree `traverse` logicFilters
     combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters
     -- update/delete filters can be only on the root table
     (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest)
     onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
+    body = pjRaw <$> iPayload apiRequest
 
-returningCols :: ReadRequest -> [FieldName]
+returningCols :: ReadRequest -> [FieldName] -> [FieldName]
-returningCols rr@(Node _ forest) = returnings
+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
+    -- Without fkCols, when a mutateRequest to
-    -- `RETURNING name`(see QueryBuilder).
+    -- /projects?select=name,clients(name) occurs, the RETURNING SQL part would
-    -- This would make the embedding fail because the following JOIN would need the "client_id" column from projects.
+    -- be `RETURNING name`(see QueryBuilder).  This would make the embedding
-    -- So this adds the foreign key columns to ensure the embedding succeeds, result would be `RETURNING name, client_id`.
+    -- fail because the following JOIN would need the "client_id" column from
-    -- This also works for the other relType's.
+    -- 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 Relation{relColumns=cols, relType=relTyp}, _, _, _)) _ -> case relTyp of
+        Node (_, (_, Just Relationship{relColumns=cols}, _, _, _)) _ -> Just cols
-          O2M -> Just cols
+        _                                                        -> Nothing
-          M2O -> Just cols
-          M2M -> Just cols
-        _ -> Nothing
       ) forest
-    -- However if the "client_id" is present, e.g. mutateRequest to /projects?select=client_id,name,clients(name)
+    -- However if the "client_id" is present, e.g. mutateRequest to
-    -- we would get `RETURNING client_id, name, client_id` and then we would produce the "column reference \"client_id\" is ambiguous"
+    -- /projects?select=client_id,name,clients(name) we would get `RETURNING
-    -- error from PostgreSQL. So we deduplicate with Set:
+    -- client_id, name, client_id` and then we would produce the "column
-    returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols)
+    -- 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

src/PostgREST/Request/Parsers.hs

@@ -1,30 +1,54 @@
 {-|
-Module      : PostgREST.Parsers
+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.Parsers where
+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 Control.Monad           ((>>))
+import Data.Either.Combinators       (mapLeft)
-import Data.Either.Combinators (mapLeft)
+import Data.Foldable                 (foldl1)
-import Data.Foldable           (foldl1)
+import Data.List                     (init, last)
-import Data.Functor            (($>))
+import Data.Text                     (intercalate, replace, strip)
-import Data.List               (init, last)
+import Data.Tree                     (Tree (..))
-import Data.Text               (intercalate, replace, strip)
+import Text.Parsec.Error             (errorMessages,
-import Text.Read               (read)
+                                      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 Data.Tree
+import PostgREST.DbStructure.Identifiers (FieldName)
-import Text.Parsec.Error
+import PostgREST.Error                   (ApiRequestError (ParseRequestError))
-import Text.ParserCombinators.Parsec hiding (many, (<|>))
+import PostgREST.Query.SqlFragment       (ftsOperators, operators)
+import PostgREST.RangeQuery              (NonnegRange)
 
-import PostgREST.Error      (ApiRequestError (ParseRequestError))
+import PostgREST.Request.Types
-import PostgREST.RangeQuery (NonnegRange)
+
-import PostgREST.Types
+import Protolude      hiding (intercalate, option, replace, toS, try)
-import Protolude            hiding (intercalate, option, replace, try)
+import Protolude.Conv (toS)
 
 pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
 pRequestSelect selStr =
@@ -229,7 +253,7 @@ pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgA
       a <- string "{"
       b <- many (noneOf "{}")
       c <- string "}"
-      toS <$> pure (a ++ b ++ c)
+      pure (toS $ a ++ b ++ c)
 
 pLogicPath :: Parser (EmbedPath, Text)
 pLogicPath = do
@@ -250,23 +274,3 @@ mapError = mapLeft translateError
         message = show $ errorPos e
         details = strip $ replace "\n" " " $ toS
            $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
-
--- Used for the config value "role-claim-key"
-pRoleClaimKey :: Text -> Either ApiRequestError JSPath
-pRoleClaimKey selStr =
-  mapError $ parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)
-
-pJSPath :: Parser JSPath
-pJSPath = toJSPath <$> (period *> pPath `sepBy` period <* eof)
-  where
-    toJSPath :: [(Text, Maybe Int)] -> JSPath
-    toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))
-    period = char '.' <?> "period (.)"
-    pPath :: Parser (Text, Maybe Int)
-    pPath = (,) <$> pJSPKey <*> optionMaybe pJSPIdx
-
-pJSPKey :: Parser Text
-pJSPKey = toS <$> many1 (alphaNum <|> oneOf "_$@") <|> pQuotedValue <?> "attribute name [a..z0..9_$@])"
-
-pJSPIdx :: Parser Int
-pJSPIdx = char '[' *> (read <$> many1 digit) <* char ']' <?> "array index [0..n]"

src/PostgREST/Request/Preferences.hs

@@ -0,0 +1,54 @@
+module PostgREST.Request.Preferences where
+
+import GHC.Show
+import Protolude
+
+
+data PreferResolution
+  = MergeDuplicates
+  | IgnoreDuplicates
+
+instance Show PreferResolution where
+  show MergeDuplicates  = "resolution=merge-duplicates"
+  show IgnoreDuplicates = "resolution=ignore-duplicates"
+
+-- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2
+data PreferRepresentation
+  = Full        -- ^ Return the body plus the Location header(in case of POST).
+  | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
+  | None        -- ^ Return nothing from the mutated data.
+  deriving Eq
+
+instance Show PreferRepresentation where
+  show Full        = "return=representation"
+  show None        = "return=minimal"
+  show HeadersOnly = "return=headers-only"
+
+data PreferParameters
+  = SingleObject    -- ^ Pass all parameters as a single json object to a stored procedure
+  | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure
+  deriving Eq
+
+instance Show PreferParameters where
+  show SingleObject    = "params=single-object"
+  show MultipleObjects = "params=multiple-objects"
+
+data PreferCount
+  = ExactCount     -- ^ exact count(slower)
+  | PlannedCount   -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
+  | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
+  deriving Eq
+
+instance Show PreferCount where
+  show ExactCount     = "count=exact"
+  show PlannedCount   = "count=planned"
+  show EstimatedCount = "count=estimated"
+
+data PreferTransaction
+  = Commit   -- Commit transaction - the default.
+  | Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
+  deriving Eq
+
+instance Show PreferTransaction where
+  show Commit   = "tx=commit"
+  show Rollback = "tx=rollback"

src/PostgREST/Request/Types.hs

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

src/PostgREST/Statements.hs

@@ -1,179 +0,0 @@
-{-|
-Module      : PostgREST.Statements
-Description : PostgREST single SQL statements.
-
-This module constructs single SQL statements that can be parametrized and prepared.
-
-- It consumes the SqlQuery types generated by the QueryBuilder module.
-- It generates the body format and some headers of the final HTTP response.
-
-TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718.
--}
-module PostgREST.Statements (
-    createWriteStatement
-  , createReadStatement
-  , callProcStatement
-  , createExplainStatement
-) where
-
-
-import           Control.Lens                    ((^?))
-import           Data.Aeson                      as JSON
-import qualified Data.Aeson.Lens                 as L
-import qualified Data.ByteString.Char8           as BS
-import           Data.Maybe
-import           Data.Text                       (unwords)
-import           Data.Text.Encoding              (encodeUtf8)
-import qualified Hasql.Decoders                  as HD
-import qualified Hasql.Encoders                  as HE
-import qualified Hasql.Statement                 as H
-import           PostgREST.Private.Common
-import           PostgREST.Private.QueryFragment
-import           PostgREST.Types
-import           Protolude                       hiding (cast,
-                                                  replace)
-import           Text.InterpolatedString.Perl6   (qc)
-
-{-| The generic query result format used by API responses. The location header
-    is represented as a list of strings containing variable bindings like
-    @"k1=eq.42"@, or the empty list if there is no location header.
--}
-type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString, Either Text [GucHeader])
-
-createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
-                        PreferRepresentation -> [Text] -> PgVersion ->
-                        H.Statement ByteString ResultsWithCount
-createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer =
-  unicodeStatement sql (param HE.unknown) decodeStandard True
- where
-  sql = [qc|
-      WITH
-      {sourceCTEName} AS ({mutateQuery})
-      SELECT
-        '' AS total_result_set,
-        pg_catalog.count(_postgrest_t) AS page_total,
-        {locF} AS header,
-        {bodyF} AS body,
-        {responseHeadersF pgVer} AS response_headers
-      FROM ({selectQuery}) _postgrest_t |]
-
-  locF =
-    if isInsert && rep `elem` [Full, HeadersOnly]
-      then unwords [
-        "CASE WHEN pg_catalog.count(_postgrest_t) = 1",
-          "THEN coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")",
-          "ELSE " <> noLocationF,
-        "END"]
-      else noLocationF
-
-  bodyF
-    | rep `elem` [None, HeadersOnly] = "''"
-    | asCsv = asCsvF
-    | wantSingle = asJsonSingleF
-    | otherwise = asJsonF
-
-  decodeStandard :: HD.Result ResultsWithCount
-  decodeStandard =
-   fromMaybe (Nothing, 0, [], mempty, Right []) <$> HD.rowMaybe standardRow
-
-createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->
-                       H.Statement () ResultsWithCount
-createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField pgVer =
-  unicodeStatement sql HE.noParams decodeStandard False
- where
-  sql = [qc|
-      WITH
-      {sourceCTEName} AS ({selectQuery})
-      {countCTEF}
-      SELECT
-        {countResultF} AS total_result_set,
-        pg_catalog.count(_postgrest_t) AS page_total,
-        {noLocationF} AS header,
-        {bodyF} AS body,
-        {responseHeadersF pgVer} AS response_headers
-      FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |]
-
-  (countCTEF, countResultF) = countF countQuery countTotal
-
-  bodyF
-    | asCsv = asCsvF
-    | isSingle = asJsonSingleF
-    | isJust binaryField = asBinaryF $ fromJust binaryField
-    | otherwise = asJsonF
-
-  decodeStandard :: HD.Result ResultsWithCount
-  decodeStandard =
-    HD.singleRow standardRow
-
-{-| Read and Write api requests use a similar response format which includes
-    various record counts and possible location header. This is the decoder
-    for that common type of query.
--}
-standardRow :: HD.Row ResultsWithCount
-standardRow = (,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
-                    <*> column header <*> column HD.bytea <*> column decodeGucHeaders
-  where
-    header = HD.array $ HD.dimension replicateM $ element HD.bytea
-
-type ProcResults = (Maybe Int64, Int64, ByteString, Either Text [GucHeader])
-
-callProcStatement :: Bool -> SqlQuery -> SqlQuery -> SqlQuery -> Bool ->
-                     Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion ->
-                     H.Statement ByteString ProcResults
-callProcStatement returnsScalar callProcQuery selectQuery countQuery countTotal isSingle asCsv asBinary multObjects binaryField pgVer =
-  unicodeStatement sql (param HE.unknown) decodeProc True
-  where
-    sql = [qc|
-      WITH {sourceCTEName} AS ({callProcQuery})
-      {countCTEF}
-      SELECT
-        {countResultF} AS total_result_set,
-        pg_catalog.count(_postgrest_t) AS page_total,
-        {bodyF} AS body,
-        {responseHeadersF pgVer} AS response_headers
-      FROM ({selectQuery}) _postgrest_t;|]
-
-    (countCTEF, countResultF) = countF countQuery countTotal
-
-    bodyF
-     | returnsScalar = scalarBodyF
-     | isSingle     = asJsonSingleF
-     | asCsv = asCsvF
-     | isJust binaryField = asBinaryF $ fromJust binaryField
-     | otherwise = asJsonF
-
-    scalarBodyF
-     | asBinary    = asBinaryF "pgrst_scalar"
-     | multObjects = "json_agg(_postgrest_t.pgrst_scalar)::character varying"
-     | otherwise   = "(json_agg(_postgrest_t.pgrst_scalar)->0)::character varying"
-
-    decodeProc :: HD.Result ProcResults
-    decodeProc =
-      fromMaybe (Just 0, 0, mempty, Right []) <$> HD.rowMaybe procRow
-      where
-        procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8
-                        <*> column HD.bytea <*> column decodeGucHeaders
-
-createExplainStatement :: SqlQuery -> H.Statement () (Maybe Int64)
-createExplainStatement countQuery =
-  unicodeStatement sql HE.noParams decodeExplain False
-  where
-    sql = [qc| EXPLAIN (FORMAT JSON) {countQuery} |]
-    -- |
-    -- An `EXPLAIN (FORMAT JSON) select * from items;` output looks like this:
-    -- [{
-    --   "Plan": {
-    --     "Node Type": "Seq Scan", "Parallel Aware": false, "Relation Name": "items",
-    --     "Alias": "items", "Startup Cost": 0.00, "Total Cost": 32.60,
-    --     "Plan Rows": 2260,"Plan Width": 8} }]
-    -- We only obtain the Plan Rows here.
-    decodeExplain :: HD.Result (Maybe Int64)
-    decodeExplain =
-      let row = HD.singleRow $ column HD.bytea in
-      (^? L.nth 0 . L.key "Plan" .  L.key "Plan Rows" . L._Integral) <$> row
-
-unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Statement a b
-unicodeStatement = H.Statement . encodeUtf8
-
-decodeGucHeaders :: HD.Value (Either Text [GucHeader])
-decodeGucHeaders = first toS . JSON.eitherDecode . toS <$> HD.bytea

src/PostgREST/Types.hs

@@ -1,537 +0,0 @@
-{-|
-Module      : PostgREST.Types
-Description : PostgREST common types and functions used by the rest of the modules
--}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-
-module PostgREST.Types where
-
-import Control.Lens.Getter (view)
-import Control.Lens.Tuple  (_1)
-
-import qualified Data.Aeson               as JSON
-import qualified Data.ByteString          as BS
-import qualified Data.ByteString.Internal as BS (c2w)
-import qualified Data.ByteString.Lazy     as BL
-import qualified Data.CaseInsensitive     as CI
-import qualified Data.HashMap.Strict      as M
-import qualified Data.Set                 as S
-import qualified GHC.Show
-
-import Network.HTTP.Types.Header (Header, hContentType)
-
-import Data.Tree
-
-import PostgREST.RangeQuery (NonnegRange)
-import Protolude
-
--- | Enumeration of currently supported response content types
-data ContentType = CTApplicationJSON | CTSingularJSON
-                 | CTTextCSV | CTTextPlain
-                 | CTOpenAPI | CTOctetStream
-                 | CTAny | CTOther ByteString deriving (Show, Eq)
-
--- | Convert from ContentType to a full HTTP Header
-toHeader :: ContentType -> Header
-toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
-
--- | Convert from ContentType to a ByteString representing the mime type
-toMime :: ContentType -> ByteString
-toMime CTApplicationJSON = "application/json"
-toMime CTTextCSV         = "text/csv"
-toMime CTTextPlain       = "text/plain"
-toMime CTOpenAPI         = "application/openapi+json"
-toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
-toMime CTOctetStream     = "application/octet-stream"
-toMime CTAny             = "*/*"
-toMime (CTOther ct)      = ct
-
--- | Convert from ByteString to ContentType. Warning: discards MIME parameters
-decodeContentType :: BS.ByteString -> ContentType
-decodeContentType ct = case BS.takeWhile (/= BS.c2w ';') ct of
-  "application/json"                  -> CTApplicationJSON
-  "text/csv"                          -> CTTextCSV
-  "text/plain"                        -> CTTextPlain
-  "application/openapi+json"          -> CTOpenAPI
-  "application/vnd.pgrst.object+json" -> CTSingularJSON
-  "application/vnd.pgrst.object"      -> CTSingularJSON
-  "application/octet-stream"          -> CTOctetStream
-  "*/*"                               -> CTAny
-  ct'                                 -> CTOther ct'
-
--- | A SQL query that can be executed independently
-type SqlQuery = Text
-
--- | A part of a SQL query that cannot be executed independently
-type SqlFragment = Text
-
-data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq
-instance Show PreferResolution where
-  show MergeDuplicates  = "resolution=merge-duplicates"
-  show IgnoreDuplicates = "resolution=ignore-duplicates"
-
--- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2
-data PreferRepresentation = Full        -- ^ Return the body plus the Location header(in case of POST).
-                          | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
-                          | None        -- ^ Return nothing from the mutated data.
-                          deriving Eq
-instance Show PreferRepresentation where
-  show Full        = "return=representation"
-  show None        = "return=minimal"
-  show HeadersOnly = mempty
-
-data PreferParameters
-  = SingleObject    -- ^ Pass all parameters as a single json object to a stored procedure
-  | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure
-  deriving Eq
-
-instance Show PreferParameters where
-  show SingleObject    = "params=single-object"
-  show MultipleObjects = "params=multiple-objects"
-
-data PreferCount
-  = ExactCount     -- ^ exact count(slower)
-  | PlannedCount   -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
-  | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
-  deriving Eq
-
-instance Show PreferCount where
-  show ExactCount     = "count=exact"
-  show PlannedCount   = "count=planned"
-  show EstimatedCount = "count=estimated"
-
-data DbStructure = DbStructure {
-  dbTables      :: [Table]
-, dbColumns     :: [Column]
-, dbRelations   :: [Relation]
-, dbPrimaryKeys :: [PrimaryKey]
-, dbProcs       :: ProcsMap
-, pgVersion     :: PgVersion
-} deriving (Show, Eq)
-
--- TODO Table could hold references to all its Columns
-tableCols :: DbStructure -> Schema -> TableName -> [Column]
-tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs
-
--- TODO Table could hold references to all its PrimaryKeys
-tablePKCols :: DbStructure -> Schema -> TableName -> [Text]
-tablePKCols dbs tSchema tName =  pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)
-
-data PgArg = PgArg {
-  pgaName :: Text
-, pgaType :: Text
-, pgaReq  :: Bool
-} deriving (Show, Eq, Ord)
-
-data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show, Ord)
-
-data RetType = Single PgType | SetOf PgType deriving (Eq, Show, Ord)
-
-data ProcVolatility = Volatile | Stable | Immutable
-  deriving (Eq, Show, Ord)
-
-data ProcDescription = ProcDescription {
-  pdSchema      :: Schema
-, pdName        :: Text
-, pdDescription :: Maybe Text
-, pdArgs        :: [PgArg]
-, pdReturnType  :: RetType
-, pdVolatility  :: ProcVolatility
-} deriving (Show, Eq)
-
--- Order by least number of args in the case of overloaded functions
-instance Ord ProcDescription where
-  ProcDescription schema1 name1 des1 args1 rt1 vol1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2
-    | schema1 == schema2 && name1 == name2 && length args1 < length args2  = LT
-    | schema2 == schema2 && name1 == name2 && length args1 > length args2  = GT
-    | otherwise = (schema1, name1, des1, args1, rt1, vol1) `compare` (schema2, name2, des2, args2, rt2, vol2)
-
--- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription).
--- | It uses a HashMap for a faster lookup.
-type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
-
-{-|
-  Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it.
-  An overloaded function can have a different volatility or even a different return type.
-  Ideally, handling overloaded functions should be left to pg itself. But we need to know certain proc attributes in advance.
--}
-findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> Maybe ProcDescription
-findProc qi payloadKeys paramsAsSingleObject allProcs =
-  case M.lookup qi allProcs of
-    Nothing     -> Nothing
-    Just [proc] -> Just proc           -- if it's not an overloaded function then immediately get the ProcDescription
-    Just procs  -> find matches procs  -- Handle overloaded functions case
-  where
-    matches proc =
-      if paramsAsSingleObject
-        -- if the arg is not of json type let the db give the err
-        then length (pdArgs proc) == 1
-        else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc)
-
-{-|
-  Search the procedure parameters by matching them with the specified keys.
-  If the key doesn't match a parameter, a parameter with a default type "text" is assumed.
--}
-specifiedProcArgs :: S.Set FieldName -> Maybe ProcDescription -> [PgArg]
-specifiedProcArgs keys proc =
-  let
-    args = maybe [] pdArgs proc
-  in
-  (\k -> fromMaybe (PgArg k "text" True) (find ((==) k . pgaName) args)) <$> S.toList keys
-
-procReturnsScalar :: ProcDescription -> Bool
-procReturnsScalar proc = case proc of
-  ProcDescription{pdReturnType = (Single (Scalar _))} -> True
-  _                                                   -> False
-
-procTableName :: ProcDescription -> Maybe TableName
-procTableName proc = case pdReturnType proc of
-  SetOf  (Composite qi) -> Just $ qiName qi
-  Single (Composite qi) -> Just $ qiName qi
-  _                     -> Nothing
-
-type Schema = Text
-type TableName = Text
-
-data Table = Table {
-  tableSchema      :: Schema
-, tableName        :: TableName
-, tableDescription :: Maybe Text
-, tableInsertable  :: Bool
-} deriving (Show, Ord)
-
-instance Eq Table where
-  Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
-
-tableQi :: Table -> QualifiedIdentifier
-tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n
-
-newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord)
-
-data Column =
-    Column {
-      colTable       :: Table
-    , colName        :: FieldName
-    , colDescription :: Maybe Text
-    , colPosition    :: Int32
-    , colNullable    :: Bool
-    , colType        :: Text
-    , colUpdatable   :: Bool
-    , colMaxLen      :: Maybe Int32
-    , colPrecision   :: Maybe Int32
-    , colDefault     :: Maybe Text
-    , colEnum        :: [Text]
-    , colFK          :: Maybe ForeignKey
-    } deriving (Show, Ord)
-
-instance Eq Column where
-  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
-
--- | The source table column a view column refers to
-type SourceColumn = (Column, ViewColumn)
-type ViewColumn = Column
-
-data PrimaryKey = PrimaryKey {
-    pkTable :: Table
-  , pkName  :: Text
-} deriving (Show, Eq)
-
-data OrderDirection = OrderAsc | OrderDesc deriving (Eq)
-instance Show OrderDirection where
-  show OrderAsc  = "ASC"
-  show OrderDesc = "DESC"
-
-data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq)
-instance Show OrderNulls where
-  show OrderNullsFirst = "NULLS FIRST"
-  show OrderNullsLast  = "NULLS LAST"
-
-data OrderTerm = OrderTerm {
-  otTerm      :: Field
-, otDirection :: Maybe OrderDirection
-, otNullOrder :: Maybe OrderNulls
-} deriving (Show, Eq)
-
-{-|
-  Represents a pg identifier with a prepended schema name "schema.table"
-  When qiSchema is "", the schema is defined by the pg search_path
--}
-data QualifiedIdentifier = QualifiedIdentifier {
-  qiSchema :: Schema
-, qiName   :: TableName
-} deriving (Show, Eq, Ord, Generic)
-instance Hashable QualifiedIdentifier
-
--- | The relationship [cardinality](https://en.wikipedia.org/wiki/Cardinality_(data_modeling)).
--- | TODO: missing one-to-one
-data Cardinality = O2M -- ^ one-to-many,  previously known as Parent
-                 | M2O -- ^ many-to-one,  previously known as Child
-                 | M2M -- ^ many-to-many, previously known as Many
-                 deriving Eq
-instance Show Cardinality where
-  show O2M = "o2m"
-  show M2O = "m2o"
-  show M2M = "m2m"
-
-type ConstraintName = Text
-
-{-|
-  "Relation"ship between two tables.
-  The order of the relColumns and relFColumns should be maintained to get the join conditions right.
-  TODO merge relColumns and relFColumns to a tuple or Data.Bimap
--}
-data Relation = Relation {
-  relTable      :: Table
-, relColumns    :: [Column]
-, relConstraint :: Maybe ConstraintName -- ^ Just on O2M/M2O, Nothing on M2M
-, relFTable     :: Table
-, relFColumns   :: [Column]
-, relType       :: Cardinality
-, relJunction   :: Maybe Junction -- ^ Junction for M2M Cardinality
-} deriving (Show, Eq)
-
--- | Junction table on an M2M relationship
-data Junction = Junction {
-  junTable       :: Table
-, junConstraint1 :: Maybe ConstraintName
-, junCols1       :: [Column]
-, junConstraint2 :: Maybe ConstraintName
-, junCols2       :: [Column]
-} deriving (Show, Eq)
-
-isSelfReference :: Relation -> Bool
-isSelfReference r = relTable r == relFTable r
-
-data PayloadJSON =
-  -- | Cached attributes of a JSON payload
-  ProcessedJSON {
-    -- | This is the raw ByteString that comes from the request body.
-    -- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding
-    -- had high memory usage, see #1005 for more details
-    pjRaw  :: BL.ByteString
-  , pjType :: PJType
-    -- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects
-  , pjKeys :: S.Set Text
-  }|
-  RawJSON {
-    pjRaw  :: BL.ByteString
-  } deriving (Show, Eq)
-
-data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq)
-
-data Proxy = Proxy {
-  proxyScheme :: Text
-, proxyHost   :: Text
-, proxyPort   :: Integer
-, proxyPath   :: Text
-} deriving (Show, Eq)
-
-type Operator = Text
-operators :: M.HashMap Operator SqlFragment
-operators = M.union (M.fromList [
-  ("eq", "="),
-  ("gte", ">="),
-  ("gt", ">"),
-  ("lte", "<="),
-  ("lt", "<"),
-  ("neq", "<>"),
-  ("like", "LIKE"),
-  ("ilike", "ILIKE"),
-  ("in", "IN"),
-  ("is", "IS"),
-  ("cs", "@>"),
-  ("cd", "<@"),
-  ("ov", "&&"),
-  ("sl", "<<"),
-  ("sr", ">>"),
-  ("nxr", "&<"),
-  ("nxl", "&>"),
-  ("adj", "-|-")]) ftsOperators
-
-ftsOperators :: M.HashMap Operator SqlFragment
-ftsOperators = M.fromList [
-  ("fts", "@@ to_tsquery"),
-  ("plfts", "@@ plainto_tsquery"),
-  ("phfts", "@@ phraseto_tsquery"),
-  ("wfts", "@@ websearch_to_tsquery")
-  ]
-
-data OpExpr = OpExpr Bool Operation deriving (Eq, Show)
-data Operation = Op Operator SingleVal |
-                 In ListVal |
-                 Fts Operator (Maybe Language) SingleVal deriving (Eq, Show)
-type Language = Text
-
--- | Represents a single value in a filter, e.g. id=eq.singleval
-type SingleVal = Text
--- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)
-type ListVal = [Text]
-
-data LogicOperator = And | Or deriving Eq
-instance Show LogicOperator where
-  show And = "AND"
-  show Or  = "OR"
-{-|
-  Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
-
-            And
-           /   \
-  name.eq.N     Or
-               /  \
-         id.eq.1   id.eq.2
--}
-data LogicTree = Expr Bool LogicOperator [LogicTree] | Stmnt Filter deriving (Show, Eq)
-
-type FieldName = Text
-{-|
-  Json path operations as specified in https://www.postgresql.org/docs/9.4/static/functions-json.html
--}
-type JsonPath = [JsonOperation]
--- | Represents the single arrow `->` or double arrow `->>` operators
-data JsonOperation = JArrow{jOp :: JsonOperand} | J2Arrow{jOp :: JsonOperand} deriving (Show, Eq)
--- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text because we reuse our escaping functons and let pg do the casting with '1'::int
-data JsonOperand = JKey{jVal :: Text} | JIdx{jVal :: Text} deriving (Show, Eq)
-
-type Field = (FieldName, JsonPath)
-type Alias = Text
-type Cast = Text
-type NodeName = Text
-
--- Rpc query param, only used for GET rpcs
-type RpcQParam = (Text, Text)
-
-{-|
-  Custom guc header, it's obtained by parsing the json in a:
-  `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
--}
-newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
-  deriving (Show, Eq)
-
-instance JSON.FromJSON GucHeader where
-  parseJSON (JSON.Object o) = case headMay (M.toList o) of
-    Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s)
-                            | otherwise     -> mzero
-    _ -> mzero
-  parseJSON _          = mzero
-
-unwrapGucHeader :: GucHeader -> Header
-unwrapGucHeader (GucHeader (k, v)) = (k, v)
-
--- | Add headers not already included to allow the user to override them instead of duplicating them
-addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
-addHeadersIfNotIncluded newHeaders initialHeaders =
-  filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
-  initialHeaders
-
-{-|
-  This type will hold information about which particular 'Relation' between two tables to choose when there are multiple ones.
-  Specifically, it will contain the name of the foreign key or the join table in many to many relations.
--}
-type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)
--- | Disambiguates an embedding operation when there's multiple relationships between two tables.
--- | Can be the name of a foreign key constraint, column name or the junction in an m2m relationship.
-type EmbedHint = Text
--- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]
-type EmbedPath = [Text]
-data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq)
-data JoinCondition = JoinCondition (QualifiedIdentifier, FieldName)
-                                   (QualifiedIdentifier, FieldName) deriving (Show, Eq)
-
-data ReadQuery = Select {
-    select         :: [SelectItem]
-  , from           :: QualifiedIdentifier
--- | A table alias is used in case of self joins
-  , fromAlias      :: Maybe Alias
--- | Only used for Many to Many joins. Parent and Child joins use explicit joins.
-  , implicitJoins  :: [QualifiedIdentifier]
-  , where_         :: [LogicTree]
-  , joinConditions :: [JoinCondition]
-  , order          :: [OrderTerm]
-  , range_         :: NonnegRange
-} deriving (Show, Eq)
-
-data MutateQuery =
-  Insert {
-    in_        :: QualifiedIdentifier
-  , insCols    :: S.Set FieldName
-  , onConflict :: Maybe (PreferResolution, [FieldName])
-  , where_     :: [LogicTree]
-  , returning  :: [FieldName]
-  }|
-  Update {
-    in_       :: QualifiedIdentifier
-  , updCols   :: S.Set FieldName
-  , where_    :: [LogicTree]
-  , returning :: [FieldName]
-  }|
-  Delete {
-    in_       :: QualifiedIdentifier
-  , where_    :: [LogicTree]
-  , returning :: [FieldName]
-  } deriving (Show, Eq)
-
-type ReadRequest = Tree ReadNode
-type MutateRequest = MutateQuery
-
-type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth))
-type Depth = Integer
-
--- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))
-fstFieldNames :: ReadRequest -> [FieldName]
-fstFieldNames (Node (sel, _) _) =
-  fst . view _1 <$> select sel
-
-data PgVersion = PgVersion {
-  pgvNum  :: Int32
-, pgvName :: Text
-} deriving (Eq, Show)
-
-instance Ord PgVersion where
-  (PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2
-
--- | Tells the minimum PostgreSQL version required by this version of PostgREST
-minimumPgVersion :: PgVersion
-minimumPgVersion = pgVersion94
-
-pgVersion94 :: PgVersion
-pgVersion94 = PgVersion 90400 "9.4"
-
-pgVersion95 :: PgVersion
-pgVersion95 = PgVersion 90500 "9.5"
-
-pgVersion96 :: PgVersion
-pgVersion96 = PgVersion 90600 "9.6"
-
-pgVersion100 :: PgVersion
-pgVersion100 = PgVersion 100000 "10"
-
-pgVersion109 :: PgVersion
-pgVersion109 = PgVersion 100009 "10.9"
-
-pgVersion110 :: PgVersion
-pgVersion110 = PgVersion 110000 "11.0"
-
-pgVersion112 :: PgVersion
-pgVersion112 = PgVersion 110002 "11.2"
-
-pgVersion114 :: PgVersion
-pgVersion114 = PgVersion 110004 "11.4"
-
-pgVersion121 :: PgVersion
-pgVersion121 = PgVersion 120001 "12.1"
-
-sourceCTEName :: SqlFragment
-sourceCTEName = "pg_source"
-
--- | full jspath, e.g. .property[0].attr.detail
-type JSPath = [JSPathExp]
--- | jspath expression, e.g. .property, .property[0] or ."property-dash"
-data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show)
-
--- | Current database connection status data ConnectionStatus
-data ConnectionStatus
-  = NotConnected
-  | Connected PgVersion
-  | FatalConnectionError Text
-  deriving (Eq, Show)

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,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+module PostgREST.Version
+  ( docsVersion
+  , prettyVersion
+  ) where
+
+import qualified Data.Text as T
+
+import Data.Version       (versionBranch)
+import Development.GitRev (gitHash)
+import Paths_postgrest    (version)
+
+import Protolude
+
+
+-- | User friendly version number
+prettyVersion :: Text
+prettyVersion =
+  T.intercalate "." (map show $ versionBranch version) <> gitRev
+  where
+    gitRev =
+      if $(gitHash) == "UNKNOWN"
+        then mempty
+        else " (" <> T.take 7 $(gitHash) <> ")"
+
+-- | Version number used in docs
+docsVersion :: Text
+docsVersion = "v" <> T.dropEnd 1 (T.dropWhileEnd (/= '.') prettyVersion)

src/PostgREST/Workers.hs

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

stack.yaml

@@ -1,20 +1,15 @@
-# stack is used for circleci and appveyor CI builds
+resolver: lts-18.2 # 2021-07-10, GHC 8.10.4
-resolver: lts-14.3
+
-ghc-options:
-  # -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
-  postgrest: -O2 -Werror -Wall -fwarn-identities
-             -fno-spec-constr -optP-Wno-nonportable-include-path
 nix:
-  packages: [pcre, pkgconfig, postgresql, zlib]
+  packages:
+    - pcre
+    - pkgconfig
+    - postgresql
+    - zlib
+  # disable pure by default so that the test enviroment can be passed
+  pure: false
 
-# needed by stylish haskell, this only runs on ci
 extra-deps:
-  - HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311
+  - hasql-dynamic-statements-0.3.1@sha256:c3a2c89c4a8b3711368dbd33f0ccfe46a493faa7efc2c85d3e354c56a01dfc48,2673
-  - HsYAML-aeson-0.2.0.0@sha256:04796abfc01cffded83f37a10e6edba4f0c0a15d45bef44fc5bb4313d9c87757,1791
+  - hasql-implicits-0.1.0.2@sha256:5d54e09cb779a209681b139fb3cc726bae75134557932156340cc0a56dd834a8,1361
-  - configurator-pg-0.2.0@sha256:08dcfadbe31e9e505d0bed1ab034105e1735141499734ad52d1c5ac980cde4a6,2939
+  - ptr-0.16.8.1@sha256:525219ec5f5da5c699725f7efcef91b00a7d44120fc019878b85c09440bf51d6,2686
-  - hspec-wai-0.10.1@sha256:56dd9ec1d56f47ef1946f71f7cbf070e4c285f718cac1b158400ae5e7172ef47,2290
-  - hspec-wai-json-0.10.1@sha256:67b405c38f0a9e2771480c8d3ecd8aeb8d8776a35d3b2906cb1b76c9538617e4,1629

stack.yaml.lock

@@ -5,43 +5,29 @@
 
 packages:
 - completed:
-    hackage: HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311
+    hackage: hasql-dynamic-statements-0.3.1@sha256:c3a2c89c4a8b3711368dbd33f0ccfe46a493faa7efc2c85d3e354c56a01dfc48,2673
     pantry-tree:
-      size: 1340
+      size: 641
-      sha256: 21f61bf9cad31674126b106071dd9b852e408796aeffc90eec1792f784107eff
+      sha256: b1b9a6a26ec765e5fe29f9a670a5c9ec7067ea00dee8491f0819284ff0201b6f
   original:
-    hackage: HsYAML-0.2.1.0@sha256:e4677daeba57f7a1e9a709a1f3022fe937336c91513e893166bd1f023f530d68,5311
+    hackage: hasql-dynamic-statements-0.3.1@sha256:c3a2c89c4a8b3711368dbd33f0ccfe46a493faa7efc2c85d3e354c56a01dfc48,2673
 - completed:
-    hackage: HsYAML-aeson-0.2.0.0@sha256:04796abfc01cffded83f37a10e6edba4f0c0a15d45bef44fc5bb4313d9c87757,1791
+    hackage: hasql-implicits-0.1.0.2@sha256:5d54e09cb779a209681b139fb3cc726bae75134557932156340cc0a56dd834a8,1361
     pantry-tree:
-      size: 234
+      size: 310
-      sha256: 67cc9ba17c79e71d3abdb465a3ee2825477856fff3b8b7d543cbbbefdae9a9d9
+      sha256: 2f00d1467d0e226b966c2cd7bac433c8948e2f7bbdf8a44936029f66fc20b5f3
   original:
-    hackage: HsYAML-aeson-0.2.0.0@sha256:04796abfc01cffded83f37a10e6edba4f0c0a15d45bef44fc5bb4313d9c87757,1791
+    hackage: hasql-implicits-0.1.0.2@sha256:5d54e09cb779a209681b139fb3cc726bae75134557932156340cc0a56dd834a8,1361
 - completed:
-    hackage: configurator-pg-0.2.0@sha256:08dcfadbe31e9e505d0bed1ab034105e1735141499734ad52d1c5ac980cde4a6,2939
+    hackage: ptr-0.16.8.1@sha256:525219ec5f5da5c699725f7efcef91b00a7d44120fc019878b85c09440bf51d6,2686
     pantry-tree:
-      size: 1748
+      size: 1089
-      sha256: 760eb12ee3d81b95b68ee10d5d85171b117826f44242b2749d48791efad6c891
+      sha256: d2b8440a738719ef8430ec38fe33b129e3940e4ccf2c016a727a1110a43656bb
   original:
-    hackage: configurator-pg-0.2.0@sha256:08dcfadbe31e9e505d0bed1ab034105e1735141499734ad52d1c5ac980cde4a6,2939
+    hackage: ptr-0.16.8.1@sha256:525219ec5f5da5c699725f7efcef91b00a7d44120fc019878b85c09440bf51d6,2686
-- completed:
-    hackage: hspec-wai-0.10.1@sha256:56dd9ec1d56f47ef1946f71f7cbf070e4c285f718cac1b158400ae5e7172ef47,2290
-    pantry-tree:
-      size: 809
-      sha256: 17af1c2e709cd84bfda066b9ebb04cdde7f92660c51a1f7401a1e9f766524e93
-  original:
-    hackage: hspec-wai-0.10.1@sha256:56dd9ec1d56f47ef1946f71f7cbf070e4c285f718cac1b158400ae5e7172ef47,2290
-- completed:
-    hackage: hspec-wai-json-0.10.1@sha256:67b405c38f0a9e2771480c8d3ecd8aeb8d8776a35d3b2906cb1b76c9538617e4,1629
-    pantry-tree:
-      size: 349
-      sha256: fb9e89b79cde3276baa484c860c6b9eeebdbc1a5c43301293351a25bc4c08e87
-  original:
-    hackage: hspec-wai-json-0.10.1@sha256:67b405c38f0a9e2771480c8d3ecd8aeb8d8776a35d3b2906cb1b76c9538617e4,1629
 snapshots:
 - completed:
-    size: 523878
+    size: 585392
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/3.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/2.yaml
-    sha256: 470c46c27746a48c7c50f829efc0cf00112787a7804ee4ac7a27754658f6d92c
+    sha256: 7abb45c0cc5eb349448b66d8753655542d45d387ad26970419282eab3d860724
-  original: lts-14.3
+  original: lts-18.2