Bump version (#963)

Docker may pass in an empty string, in which case use the default value

.circleci/config.yml

@@ -0,0 +1,188 @@
+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:
+    machine: true
+    steps:
+      - checkout
+      - restore_cache:
+          keys:
+          - v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
+      - run:
+          name: install stack & dependencies
+          command: |
+            curl -L https://github.com/commercialhaskell/stack/releases/download/v1.1.2/stack-1.1.2-linux-x86_64.tar.gz | tar zx -C /tmp
+            sudo mv /tmp/stack-1.1.2-linux-x86_64/stack /usr/bin
+            sudo apt-get update
+            sudo apt-get install libgmp-dev
+            sudo apt-get install --only-upgrade binutils
+            stack setup
+            rm -rf $(stack path --dist-dir) $(stack path --local-install-root)
+            stack install hlint packdeps cabal-install
+      - run:
+          name: build src and tests
+          command: |
+            stack build --fast -j1
+            stack build --fast --test --no-run-tests
+      - run:
+          name: run tests
+          command: |
+            sudo service postgresql start
+            POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://circleci@localhost" postgrest_test) stack test
+            test/io-tests.sh
+      - run:
+          name: run linter
+          command: git ls-files | grep '\.l\?hs$' | xargs stack exec -- hlint -X QuasiQuotes -X NoPatternSynonyms "$@"
+      - run:
+          name: extra checks
+          command: |
+            stack exec -- cabal update
+            stack exec --no-ghc-package-path -- cabal install --only-d --dry-run
+            stack exec -- packdeps *.cabal || true
+            stack exec -- cabal check
+            stack haddock --no-haddock-deps
+            stack sdist
+      - save_cache:
+          paths:
+            - "~/.stack"
+            - ".stack-work"
+          key: v1-stack-dependencies-{{ checksum "postgrest.cabal" }}-{{ checksum "stack.yaml" }}
+
+  centos6:
+    <<: *build-distro-bin
+
+  centos7:
+    <<: *build-distro-bin
+
+  ubuntu:
+    <<: *build-distro-bin
+
+  ubuntui386:
+    <<: *build-distro-bin
+
+  release:
+    docker:
+      - image: circleci/golang:1.8
+    steps:
+      - attach_workspace:
+          at: /tmp/workspace
+      - checkout
+      - run:
+          name: add body and tars to github release
+          command: |
+            go get -u github.com/tcnksm/ghr
+            START=$(echo $CIRCLE_TAG | cut -c2-)
+            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
+          command: |
+            docker build --build-arg POSTGREST_VERSION=$CIRCLE_TAG -t postgrest ./docker/
+            docker login -u $DOCKER_USER -p $DOCKER_PASS
+            docker tag postgrest postgrest/postgrest:$CIRCLE_TAG
+            docker push postgrest/postgrest:$CIRCLE_TAG
+            docker tag postgrest postgrest/postgrest:latest
+            docker push postgrest/postgrest:latest
+
+workflows:
+  version: 2
+  build-test-release:
+    jobs:
+      - build-test:
+          filters:
+            tags:
+              only: /v[0-9]+(\.[0-9]+)*/
+      - centos6:
+          requires:
+            - build-test
+          filters:
+            tags:
+              only: /v[0-9]+(\.[0-9]+)*/
+            branches:
+              ignore: /.*/
+      - centos7:
+          requires:
+            - build-test
+          filters:
+            tags:
+              only: /v[0-9]+(\.[0-9]+)*/
+            branches:
+              ignore: /.*/
+      - ubuntu:
+          requires:
+            - build-test
+          filters:
+            tags:
+              only: /v[0-9]+(\.[0-9]+)*/
+            branches:
+              ignore: /.*/
+      - ubuntui386:
+          requires:
+            - build-test
+          filters:
+            tags:
+              only: /v[0-9]+(\.[0-9]+)*/
+            branches:
+              ignore: /.*/
+      - release:
+          requires:
+            - centos6
+            - centos7
+            - ubuntu
+            - ubuntui386
+          filters:
+            tags:
+              only: /v[0-9]+(\.[0-9]+)*/

.gitattributes

@@ -0,0 +1 @@
+/CHANGELOG.md merge=union

.gitignore

@@ -1,3 +1,4 @@
+.DS_Store
 db
 dist
 .cabal-sandbox
@@ -5,3 +6,9 @@ cabal.sandbox.config
 hscope.out
 codex.tags
 .anvil
+.stack-work*
+tags
+site
+*~
+*#*
+.#*

.stylish-haskell.yaml

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

.travis.yml

@@ -0,0 +1,64 @@
+language: generic
+
+sudo: false
+
+os:
+- osx
+
+cache:
+  timeout: 1000
+  directories:
+    - $HOME/.stack
+    - $HOME/.local/bin
+
+before_install:
+- mkdir -p "$HOME/.local/bin"
+- export PATH="$PATH:$HOME/.local/bin"
+
+install:
+- |
+  if test -f "$HOME/.local/bin/stack"
+    then
+      echo 'Stack is already installed.'
+    else
+      echo "Installing Stack..."
+      travis_retry curl -L https://www.stackage.org/stack/osx-x86_64 > stack.tar.gz
+      gunzip stack.tar.gz
+      tar -x -f stack.tar --strip-components 1
+      mv stack "$HOME/.local/bin/"
+      rm stack.tar
+  fi
+- |
+  if test -f "$HOME/.local/bin/ghr"
+  then
+    echo 'ghr is already installed.'
+  else
+    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
+    unzip ghr.zip -d "$HOME/.local/bin"
+    rm ghr.zip
+  fi
+
+script:
+- gtimeout 1800 stack build --no-terminal --only-snapshot --install-ghc || true
+- |
+  if test ! "$TRAVIS_TAG"
+  then
+    echo 'No tag pushed. Skipping build.'
+  else
+    stack build --no-terminal --copy-bins --local-bin-path .
+  fi
+- |
+  if test ! "$TRAVIS_TAG"
+  then
+    echo 'No tag pushed. Skipping release.'
+  else
+    OWNER="$(echo "$TRAVIS_REPO_SLUG" | cut -f1 -d/)"
+    REPO="$(echo "$TRAVIS_REPO_SLUG" | cut -f2 -d/)"
+    START=$(echo $TRAVIS_TAG | cut -c2-)
+    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

CHANGELOG.md

@@ -3,6 +3,249 @@
 All notable changes to this project will be documented in this file.
 This project adheres to [Semantic Versioning](http://semver.org/).
 
+## Unreleased
+
+### Added
+
+### Fixed
+
+## [0.4.3.0] - 2017-09-06
+
+### Added
+
+- #567, Support more JWT signing algorithms, including RSA - @begriffs
+- #889, Allow more than two conditions in a single and/or - @steve-chavez
+- #883, Binary output support for RPC - @steve-chavez
+- #885, Postgres COMMENTs on SCHEMA/TABLE/COLUMN are used for OpenAPI - @ldesgoui
+- #907, Ability to embed using a specific relation when there are multiple between tables - @ruslantalpa
+- #930, Split table comment on newline to get OpenAPI operation summary and description - @daurnimator
+- #938, Support for range operators - @russelldavies
+
+### Fixed
+
+- #877, Base64 secret read from a file ending with a newline - @eric-brechemier
+- #896, Boolean env var interpolation in config file - @begriffs
+- #885, OpenAPI repetition reduced by using more definitions- @ldesgoui
+- #924, Improve relations initialization time - @9too
+- #927, Treat blank pre-request as missing - @begriffs
+
+### Changed
+
+- #938, Deprecate symbol operators with mnemonic names. - @russelldavies
+
+## [0.4.2.0] - 2017-06-11
+
+### Added
+
+- #742, Add connection retrying on startup and SIGHUP - @steve-chavez
+- #652, Add and/or params for complex boolean logic - @steve-chavez
+- #808, Env var interpolation in config file (helps Docker) - @begriffs
+- #878 - CSV output support for RPC - @begriffs
+
+### Fixed
+
+- #822, Treat blank string JWT secret as no secret - @begriffs
+
+## [0.4.1.0] - 2017-04-25
+
+### Added
+- Allow requesting binary output on GET - @steve-chavez
+- Accept clients requesting `Content-Type: application/json` from / - @feynmanliang
+- #493, Updating with empty JSON object makes zero updates @koulakis
+- Make HTTP headers and cookies available as GUCs #800 - @ruslantalpa
+- #701, Ability to quote values on IN filters - @steve-chavez
+- #641, Allow IN filter to have no values - @steve-chavez
+
+### Fixed
+- #827, Avoid Warp reaper, extend socket timeout to 1 hour - @majorcode
+- #791, malformed nested JSON error - @diogob
+- Resource embedding in views referencing tables in public schema - @fab1an
+- #777, Empty body is allowed when calling a non-parameterized RPC - @koulakis
+- #831, Fix proc resource embedding issue with search_path - @steve-chavez
+- #547, Use read-only transaction for stable/immutable RPC - @begriffs
+
+## [0.4.0.0] - 2017-01-19
+
+### Added
+- Allow test database to be on another host - @dsimunic
+- `Prefer: params=single-object` to treat payload as single json argument in RPC - @dsimunic
+- Ability to generate an OpenAPI spec - @mainx07, @hudayou, @ruslantalpa, @begriffs
+- Ability to generate an OpenAPI spec behind a proxy - @hudayou
+- Ability to set addresses to listen on - @hudayou
+- Filtering, shaping and embedding with &select for the /rpc path - @ruslantalpa
+- Output names of used-defined types (instead of 'USER-DEFINED') - @martingms
+- Implement support for singular representation responses for POST/PATCH requests - @ehamberg
+- Include RPC endpoints in OpenAPI output - @begriffs, @LogvinovLeon
+- Custom request validation with `--pre-request` argument - @begriffs
+- Ability to order by jsonb keys - @steve-chavez
+- Ability to specify offset for a deeper level - @ruslantalpa
+- Ability to use binary base64 encoded secrets - @TrevorBasinger
+
+### Fixed
+- Do not apply limit to parent items - @ruslantalpa
+- Fix bug in relation detection when selecting parents two levels up by using the name of the FK - @ruslantalpa
+- Customize content negotiation per route - @begriffs
+- Allow using nulls order without explicit order direction - @steve-chavez
+- Fatal error on postgres unsupported version, format supported version in error message - @steve-chavez
+- Prevent database memory cosumption by prepared statements caches - @ruslantalpa
+- Use specific columns in the RETURNING section - @ruslantalpa
+- Fix columns alias for RETURNING - @steve-chavez
+
+### Changed
+- Replace `Prefer: plurality=singular` with `Accept: application/vnd.pgrst.object` - @begriffs
+- Standardize arrays in responses for `Prefer: return=representation` - @begriffs
+- Calling unknown RPC gives 404, not 400 - @begriffs
+- Use HTTP 400 for raise\_exception - @begriffs
+- Remove non-OpenAPI schema description - @begriffs
+- Use comma rather than semicolon to separate Prefer header values - @begriffs
+- Omit total query count by default - @begriffs
+- No more reserved `jwt_claims` return type - @begriffs
+- HTTP 401 rather than 400 for expired JWT - @begriffs
+- Remove default JWT secret - @begriffs
+- Use GUC request.jwt.claim.foo rather than postgrest.claims.foo - @begriffs
+- Use config file rather than command line arguments - @begriffs
+
+## [0.3.2.0] - 2016-06-10
+
+### Added
+- Reload database schema on SIGHUP - @begriffs
+- Support "-" in column names - @ruslantalpa
+- Support column/node renaming `alias:column` - @ruslantalpa
+- Accept posts from HTML forms - @begriffs
+- Ability to order embedded entities - @ruslantalpa
+- Ability to paginate using &limit and &offset parameters - @ruslantalpa
+- Ability to apply limits to embedded entities and enforce --max-rows on all levels - @ruslantalpa, @begriffs
+- Add allow response header in OPTIONS - @begriffs
+
+### Fixed
+- Return 401 or 403 for access denied rather than 404 - @begriffs
+- Omit Content-Type header for empty body - @begriffs
+- Prevent role from being changed twice - @begriffs
+- Use read-only transaction for read requests - @ruslantalpa
+- Include entities from the same parent table using two different foreign keys - @ruslantalpa
+- Ensure that Location header in 201 response is URL-encoded - @league
+- Fix garbage collector CPU leak - @ruslantalpa et al.
+- Return deleted items when return=representation header is sent - @ruslantalpa
+- Use table default values for empty object inserts - @begriffs
+
+## [0.3.1.1] - 2016-03-28
+
+### Fixed
+- Preserve unicode values in insert,update,rpc (regression) - @begriffs
+- Prevent duplicate call to stored procs (regression) - @begriffs
+- Allow SQL functions to generate registered JWT claims - @begriffs
+- Terminate gracefully on SIGTERM (for use in Docker) - @recmo
+- Relation detection fix for views that depend on multiple tables - @ruslantalpa
+- Avoid count on plurality=singular and allow multiple Prefer values - @ruslantalpa
+
+## [0.3.1.0] - 2016-02-28
+
+### Fixed
+- Prevent query error from infecting later connection - @begriffs, @ruslantalpa, @nikita-volkov, @jwiegley
+
+### Added
+- Applies range headers to RPC calls - @diogob
+
+## [0.3.0.4] - 2016-02-12
+
+### Fixed
+- Improved usage screen - @begriffs
+- Reject non-POSTs to rpc endpoints - @begriffs
+- Throw an error for OPTIONS on nonexistent tables - @calebmer
+- Remove deadlock on simultaneous contentious updates - @ruslantalpa, @begriffs
+
+## [0.3.0.3] - 2016-01-08
+
+### Fixed
+- Fix bug in many-many relation detection - @ruslantalpa
+- Inconsistent escaping of table names in read queries - @calebmer
+
+## [0.3.0.2] - 2015-12-16
+
+### Fixed
+- Miscalculation of time used for expiring tokens - @calebmer
+- Remove bcrypt dependency to fix Windows build - @begriffs
+- Detect relations event when authenticator does not have rights to intermediate tables - @ruslantalpa
+- Ensure db connections released on sigint - @begriffs
+- Fix #396 include records with missing parents - @ruslantalpa
+- `pgFmtIdent` always quotes #388 - @calebmer
+- Default schema, changed from `"1"` to `public` - @calebmer
+- #414 revert to separate count query - @ruslantalpa
+- Fix #399, allow inserting in tables with no select privileges using "Prefer: representation=minimal" - @ruslantalpa
+
+### Added
+- Allow order by computed columns - @diogob
+- Set max rows in response with --max-rows - @begriffs
+- Selection by column name (can detect if `_id` is not included) - @calebmer
+
+## [0.3.0.1] - 2015-11-27
+
+### Fixed
+- Filter columns on embedded parent items - @ruslantalpa
+
+## [0.3.0.0] - 2015-11-24
+
+### Fixed
+- Use reasonable amount of memory during bulk inserts - @begriffs
+
+### Added
+- Ensure JWT expires - @calebmer
+- Postgres connection string argument - @calebmer
+- Encode JWT for procs that return type `jwt_claims` - @diogob
+- Full text operators `@>`,`<@` - @ruslantalpa
+- Shaping of the response body (filter columns, embed relations) with &select parameter for POST/PATCH - @ruslantalpa
+- Detect relationships between public views and private tables - @calebmer
+- `Prefer: plurality=singular` for selecting single objects - @calebmer
+
+### Removed
+- API versioning feature - @calebmer
+- `--db-x` command line arguments - @calebmer
+- Secure flag - @calebmer
+- PUT request handling - @ruslantalpa
+
+### Changed
+- Embed foreign keys with {} rather than () - @begriffs
+- Remove version number from binary filename in release - @begriffs
+
+## [0.2.12.1] - 2015-11-12
+
+### Fixed
+- Correct order for -> and ->> in a json path - @ruslantalpa
+- Return empty array instead of 500 when a set returning function returns an empty result set - @diogob
+
+## [0.2.12.0] - 2015-10-25
+
+### Added
+- Embed associations, e.g. `/film?select=*,director(*)` - @ruslantalpa
+- Filter columns, e.g. `?select=col1,col2` - @ruslantalpa
+- Does not execute the count total if header "Prefer: count=none" - @diogob
+
+### Fixed
+- Tolerate a missing role in user creation - @calebmer
+- Avoid unnecessary text re-encoding - @ruslantalpa
+
+## [0.2.11.1] - 2015-09-01
+
+### Fixed
+- Accepts `*/*` in Accept header - @diogob
+
+## [0.2.11.0] - 2015-08-28
+### Added
+- Negate any filter in a uniform way, e.g. `?col=not.eq=foo` - @diogob
+- Call stored procedures
+- Filter NOT IN values, e.g. `?col=notin.1,2,3` - @rall
+- CSV responses to GET requests with `Accept: text/csv` - @diogob
+- Debian init scripts - @mkhon
+- Allow filters by computed columns - @diogob
+
+### Fixed
+- Reset user role on error
+- Compatible with Stack
+- Add materialized views to results in GET / - @diogob
+- Indicate insertable=true for views that are insertable through triggers - @diogob
+- Builds under GHC 7.10
+- Allow the use of columns named "count" in relations queried - @diogob
+
 ## [0.2.10.0] - 2015-06-03
 ### Added
 - Full text search, eg `/foo?text_vector=@@.bar`

CONTRIBUTING.md

@@ -27,6 +27,14 @@ your contributions.
 * Provide steps to reproduce the issue, including your OS version and
   the specific database schema that you are using.
 
+* Please include SQL logs for issues involving runtime problems. To obtain logs first
+  [enable logging all statements](http://www.microhowto.info/howto/log_all_queries_to_a_postgresql_server.html),
+  then [find your logs](http://blog.endpoint.com/2014/11/dear-postgresql-where-are-my-logs.html).
+
+* If your database schema has changed while the PostgREST server is running,
+  send the server a `SIGHUP` signal or restart it to ensure the schema cache
+  is not stale. This sometimes fixes apparent bugs.
+
 ## Code
 
 ### Haskell Conventions
@@ -39,12 +47,23 @@ your contributions.
   committers. Continuous integration will check this as well on every
   pull request.
 
+* For help building the Haskell code on your computer check out the [building from
+source](https://postgrest.com/en/stable/install.html#build-from-source)
+wiki page.
+
 ## Maintenance
 
 ### Schedule
 
 Currently I (@begriffs) am the sole maintainer, and while I am
 overjoyed to help resolve issues I also have to balance this with
-my other obligations.  I check and respond to github issues **once
-per week** (on Mondays). So if you don't get a response right away
-don't worry, I will definitely get to it.
+my other obligations.  If you don't get a response right away
+don't worry, I will definitely get to it. Also you can join the
+Gitter [chat room](https://gitter.im/begriffs/postgrest) to
+discuss issues you are having.
+
+## Running Tests
+
+For instructions on running tests, see the official docs hosted here:
+
+https://postgrest.com/en/stable/install.html#postgrest-test-suite

README.md

@@ -1,50 +1,35 @@
 ![Logo](static/logo.png "Logo")
 
-[![Build Status](https://circleci.com/gh/begriffs/postgrest.png?circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2)](https://circleci.com/gh/begriffs/postgrest/tree/master)
+[![Build Status](https://circleci.com/gh/begriffs/postgrest.png?style=shield&circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2)](https://circleci.com/gh/begriffs/postgrest/tree/master)
 <a href="https://heroku.com/deploy?template=https://github.com/begriffs/postgrest">
-  <img src="static/heroku.png" alt="Deploy">
+  <img src="https://img.shields.io/badge/%E2%86%91_Deploy_to-Heroku-7056bf.svg" alt="Deploy">
 </a>
+[![Join the chat at https://gitter.im/begriffs/postgrest](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%92-brightgreen.svg)](https://gitter.im/begriffs/postgrest)
+[![Docs](https://img.shields.io/badge/docs-latest-brightgreen.svg?style=flat)](http://postgrest.com)
 
 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.
 
-### Demo [postgrest.herokuapp.com](https://postgrest.herokuapp.com) | Watch [Video](http://begriffs.com/posts/2014-12-30-intro-to-postgrest.html) | [GUI Demo](http://marmelab.com/ng-admin-postgrest)
-
-Try making requests to the live demo server with an HTTP client
-such as [postman](http://www.getpostman.com/). The structure of the
-demo database is defined by
-[begriffs/postgrest-example](https://github.com/begriffs/postgrest-example).
-You can use it as inspiration for test-driven server migrations in
-your own projects.
-
 ### Usage
 
-Download the binary ([latest release](https://github.com/begriffs/postgrest/releases/latest)) and invoke like so:
+1. Download the binary ([latest release](https://github.com/begriffs/postgrest/releases/latest))
+   for your platform.
+2. Invoke for help:
 
-```bash
-postgrest  --db-host localhost  --db-port 5432     \
-           --db-name my_db      --db-user postgres \
-           --db-pass foobar     --db-pool 200      \
-           --anonymous postgres --port 3000        \
-           --v1schema public
-```
-
-In production include the `--secure` option which redirects all
-requests to HTTPS. Note that PostgREST does not handle the SSL
-internally and must be put behind another server that does (such
-as nginx or the Heroku load balancer).
+    ```bash
+    postgrest --help
+    ```
 
 ### Performance
 
-TLDR; subsecond response times for up to 2000 requests/sec on Heroku free tier. ([see the load test](https://github.com/begriffs/postgrest/wiki/Performance-and-Scaling))
-
-If you're used to servers written in interpreted languages (or named
-after precious gems), prepare to be pleasantly surprised by PostgREST
-performance.
+TLDR; subsecond response times for up to 2000 requests/sec on Heroku
+free tier. If you're used to servers written in interpreted languages
+(or named after precious gems), prepare to be pleasantly surprised by
+PostgREST performance.
 
 Three factors contribute to the speed. First the server is written
-in [Haskell](https://new-www.haskell.org/) using the
+in [Haskell](https://www.haskell.org/) using the
 [Warp](http://www.yesodweb.com/blog/2011/03/preliminary-warp-cross-language-benchmarks)
 HTTP server (aka a compiled language with lightweight threads).
 Next it delegates as much calculation as possible to the database
@@ -60,67 +45,54 @@ Finally it uses the database efficiently with the
 [Hasql](https://nikita-volkov.github.io/hasql-benchmarks/) library
 by
 
-* Reusing prepared statements
 * Keeping a pool of db connections
-* Using the Postgres binary protocol
+* Using the PostgreSQL binary protocol
 * Being stateless to allow horizontal scaling
 
-Ultimately the server (when load balanced) is constrained by database
-performance. This may make it inappropriate for very large traffic
-load. To learn more about scaling with Heroku and Amazon RDS see
-the [performance guide](https://github.com/begriffs/postgrest/wiki/Performance-and-Scaling).
-
 Other optimizations are possible, and some are outlined in the
 [Future Features](#future-features).
 
 ### Security
 
-PostgREST handles authentication (HTTP Basic over SSL or [JSON Web
-Tokens](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions#json-web-tokens))
-and delegates authorization to the role information defined in the
-database. This ensures there is a single declarative source of truth
-for security.  When dealing with the database the server assumes
-the identity of the currently authenticated user, and for the
-duration of the connection cannot do anything the user themselves
-couldn't.
+PostgREST [handles
+authentication](http://postgrest.com/en/stable/auth.html) (via JSON Web
+Tokens) and delegates authorization to the role information defined in
+the database. This ensures there is a single declarative source of truth
+for security.  When dealing with the database the server assumes the
+identity of the currently authenticated user, and for the duration of
+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.
 
-Postgres 9.5 will soon support true [row-level
-security](http://michael.otacoo.com/postgresql-2/postgres-9-5-feature-highlight-row-level-security/).
-In the meantime what isn't yet implemented can be simulated with
-triggers and security-barrier views. Because the possible queries
-to the database are limited to certain templates using
+PostgreSQL 9.5 supports true [row-level
+security](http://www.postgresql.org/docs/9.5/static/ddl-rowsecurity.html).
+In previous versions it can be simulated with triggers and
+security-barrier views. Because the possible queries to the database
+are limited to certain templates using
 [leakproof](http://blog.2ndquadrant.com/how-do-postgresql-security_barrier-views-work/)
 functions, the trigger workaround does not compromise row-level
 security.
 
-For example security patterns see the [security
-guide](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions).
-
 ### Versioning
 
 A robust long-lived API needs the freedom to exist in multiple
-versions. PostgREST supports versioning through HTTP content
-negotiation. Requests for a certain version translate into switching
-which database schema to search for tables. PostgreSQL schema search
-paths allow tables from earlier versions to be reused verbatim in
-later versions.
+versions. PostgREST does versioning through database schemas. This
+allows you to expose tables and views without making the app brittle.
+Underlying tables can be superseded and hidden behind public facing
+views.
 
-To learn more, see the [guide to versioning](https://github.com/begriffs/postgrest/wiki/API-Versioning).
+### Self-documentation
 
-### Self-documention
+PostgREST uses the [OpenAPI](https://openapis.org/) standard to
+generate up-to-date documentation for APIs. You can use a tool like
+[Swagger-UI](https://github.com/swagger-api/swagger-ui) to render
+interactive documentation for demo requests against the live API server.
 
-Rather than writing and maintaining separate docs yourself let the
-API explain its own affordances using HTTP. All PostgREST endpoints
-respond to the OPTIONS verb and explain what they support as well
-as the data format of their JSON payload.
-
-The number of rows returned by an endpoint is reported by - and
-limited with - range headers. More about
+This project uses HTTP to communicate other metadata as well.  For
+instance the number of rows returned by an endpoint is reported by -
+and limited with - range headers. More about
 [that](http://begriffs.com/posts/2014-03-06-beyond-http-header-links.html).
 
-There are more opportunities for self-documentation listed in [Future
-Features](#future-features).
-
 ### Data Integrity
 
 Rather than relying on an Object Relational Mapper and custom
@@ -129,40 +101,18 @@ directly into your database. Hence no application can corrupt your
 data (including your API server).
 
 The PostgREST exposes HTTP interface with safeguards to prevent
-surprises, such as enforcing idempotent PUT requests, and
+surprises, such as enforcing idempotent PUT requests.
 
-See examples of [Postgres
+See examples of [PostgreSQL
 constraints](http://www.tutorialspoint.com/postgresql/postgresql_constraints.htm)
-and the [guide to routing](https://github.com/begriffs/postgrest/wiki/Routing).
-
-### Future Features
-
-* Watching endpoint changes with sockets and Postgres pubsub
-* Specifying per-view HTTP caching
-* Inferring good default caching policies from the Postgres stats collector
-* Generating mock data for test clients
-* Maintaining separate connection pools per role to avoid "set/reset
-  role" performance penalty
-* Describe more relationships with Link headers
-* Depending on accept headers, render OPTIONS as [RAML](http://raml.org/) or a
-  relational diagram
-* Add two-legged auth with OAuth 1.0a(?)
-* ... the other [issues](https://github.com/begriffs/postgrest/issues)
-
-### Guides
-
-* [Routing](https://github.com/begriffs/postgrest/wiki/Routing)
-* [Versioning](https://github.com/begriffs/postgrest/wiki/API-Versioning)
-* [Performance](https://github.com/begriffs/postgrest/wiki/Performance-and-Scaling)
-* [Security](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions)
-* [Tutorial](http://blog.jonharrington.org/postgrest-introduction/) (external)
+and the [API guide](http://postgrest.com/en/stable/api.html).
 
 ### Thanks
 
-* [Adam Baker](https://github.com/adambaker) for code
-  contributions and many fundamental design discussions
-* [Nikita Volkov](https://github.com/nikita-volkov) for writing the
-  wonderful [Hasql](https://github.com/nikita-volkov/hasql) library
-  and helping me use it
-* [Mikey Casalaina](https://github.com/casalaina) for the cool logo
-* [Jonathan Harrington](https://github.com/prio) for writing a nice tutorial
+I'm grateful to the generous project
+[contributors](https://github.com/begriffs/postgrest/graphs/contributors)
+who have improved PostgREST immensely with their code and good
+judgement.  See more details in the
+[changelog](https://github.com/begriffs/postgrest/blob/master/CHANGELOG.md).
+
+The cool logo came from [Mikey Casalaina](https://github.com/casalaina).

app.json

@@ -10,37 +10,46 @@
     },
     "POSTGREST_VER": {
       "description": "Version of PostgREST to deploy",
-      "value": "0.2.10.0"
+      "value": "0.4.3.0"
     },
-    "DB_NAME": {
-      "description": "Database name",
+    "DB_URI": {
+      "description": "Database connection string",
       "required": true
     },
-    "AUTH_ROLE": {
-      "description": "Database role to use checking client authentication",
+    "DB_SCHEMA": {
+      "description": "The database schema to expose to REST clients. Tables, views and stored procedures in this schema will get API endpoints",
+      "required": true,
+      "value": "public"
+    },
+    "DB_ANON_ROLE": {
+      "description": "The database role to use when executing commands on behalf of unauthenticated clients",
       "required": true
     },
-    "AUTH_PASS": {
-      "description": "Authentication password",
-      "required": false
-    },
-    "ANONYMOUS_ROLE": {
-      "description": "Database role for non-authenticated requests",
-      "required": true
-    },
-    "DB_HOST": {
-      "description": "Database server hostname",
-      "required": true
-    },
-    "DB_PORT": {
-      "description": "Database server port",
-      "required": false,
-      "value": "5432"
-    },
     "DB_POOL": {
-      "description": "Maximum number of connections in database pool",
+      "description": "Number of connections to keep open in PostgREST’s database pool",
       "required": false,
       "value": "10"
+    },
+    "SERVER_PROXY_URI": {
+      "description": "Overrides the base URL used within the OpenAPI self-documentation hosted at the API root path",
+      "required": false
+    },
+    "JWT_SECRET": {
+      "description": "The secret used to decode JWT tokens clients provide for authentication",
+      "required": false
+    },
+    "SECRET_IS_BASE64": {
+      "description": "When this is set to true, the value derived from jwt-secret will be treated as a base64 encoded secret",
+      "required": false,
+      "value": "false"
+    },
+    "MAX_ROWS": {
+      "description": "A hard limit to the number of rows PostgREST will fetch from a view, table, or stored procedure",
+      "required": false
+    },
+    "PRE_REQUEST": {
+      "description": "A schema-qualified stored procedure name to call right after switching roles for a client request",
+      "required": false
     }
   }
 }

appveyor.yml

@@ -0,0 +1,38 @@
+platform: x64
+
+cache:
+- "c:\\sr"
+- .stack-work
+
+environment:
+  global:
+    STACK_ROOT: "c:\\sr"
+    GOPATH: c:\gopath
+
+test: off
+
+skip_non_tags: true
+
+skip_branch_with_pr: true
+
+branches:
+  only:
+    - master
+
+install:
+- set PATH=C:\Program Files\PostgreSQL\9.6\bin\;%PATH%
+- curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-x86_64
+- 7z x stack.zip stack.exe
+- set PATH=%GOPATH%\bin;c:\go\bin;%PATH%
+- go get -u github.com/tcnksm/ghr
+
+build_script:
+- stack setup --no-terminal > nul
+- stack build --copy-bins --local-bin-path .
+
+artifacts:
+- path: postgrest.exe
+
+deploy_script:
+- 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,/$(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"

circle.yml

@@ -1,16 +0,0 @@
-machine:
-  pre:
-    - createuser --superuser --no-password postgrest_test
-    - createdb -O postgrest_test -U ubuntu postgrest_test
-  ghc:
-    version: 7.8.3
-dependencies:
-  override:
-    - cabal update
-    - cabal sandbox init
-    - cabal install --upgrade-dependencies --constraint="template-haskell installed" --dependencies-only --enable-tests
-    - cabal configure --enable-tests -f ci
-test:
-  post:
-    - cabal exec hlint -- -X QuasiQuotes src/**/*.hs test/**/*.hs
-    - cabal exec packdeps postgrest.cabal

docker/Dockerfile

@@ -0,0 +1,43 @@
+FROM debian:jessie
+
+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/begriffs/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_SERVER_HOST=*4 \
+    PGRST_SERVER_PORT=3000 \
+    PGRST_SERVER_PROXY_URL= \
+    PGRST_JWT_SECRET= \
+    PGRST_SECRET_IS_BASE64=false \
+    PGRST_MAX_ROWS= \
+    PGRST_PRE_REQUEST=
+
+# PostgREST reads /etc/postgrest.conf so map the configuration
+# file in when you run this container
+CMD exec postgrest /etc/postgrest.conf
+
+EXPOSE 3000

docker/config.conf

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

docker/distro_release/Dockerfile.centos6

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

docker/distro_release/Dockerfile.centos7

@@ -0,0 +1,18 @@
+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/9.3/redhat/rhel-7-x86_64/pgdg-centos93-9.3-2.noarch.rpm
+RUN yum -y install postgresql93-devel
+RUN yum clean all
+RUN curl -sSL https://get.haskellstack.org/ | sh
+
+ENV PATH $PATH:/usr/pgsql-9.3/bin
+
+# To disable warning when building
+ENV PATH $PATH:/root/.local/bin
+
+RUN mkdir /source
+WORKDIR /source
+
+ENTRYPOINT ["stack"]

docker/distro_release/Dockerfile.ubuntu

@@ -0,0 +1,18 @@
+FROM ubuntu:16.04
+
+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

@@ -0,0 +1,18 @@
+FROM 32bit/ubuntu:16.04
+
+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

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

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

main/Main.hs

@@ -0,0 +1,281 @@
+{-# LANGUAGE CPP #-}
+
+module Main where
+
+import           PostgREST.App            (postgrest)
+import           PostgREST.Config         (AppConfig (..),
+                                           PgVersion (..),
+                                           minimumPgVersion,
+                                           prettyVersion, readOptions)
+import           PostgREST.DbStructure    (getDbStructure)
+import           PostgREST.Error          (encodeError)
+import           PostgREST.OpenAPI        (isMalformedProxyUri)
+import           PostgREST.Types          (DbStructure, Schema)
+import           Protolude hiding         (replace, hPutStrLn)
+
+import           Control.Retry            (RetryStatus, capDelay,
+                                           exponentialBackoff,
+                                           retrying, rsPreviousDelay)
+import           Data.ByteString.Base64   (decode)
+import           Data.IORef               (IORef, atomicWriteIORef,
+                                           newIORef, readIORef)
+import           Data.String              (IsString (..))
+import           Data.Text                (pack, replace, stripPrefix, strip)
+import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
+import           Data.Text.IO             (hPutStrLn, readFile)
+import qualified Hasql.Decoders           as HD
+import qualified Hasql.Encoders           as HE
+import qualified Hasql.Pool               as P
+import qualified Hasql.Query              as H
+import qualified Hasql.Session            as H
+import           Network.Wai.Handler.Warp (defaultSettings,
+                                           runSettings, setHost,
+                                           setPort, setServerName,
+                                           setTimeout)
+import           System.IO                (BufferMode (..),
+                                           hSetBuffering)
+#ifndef mingw32_HOST_OS
+import           System.Posix.Signals
+#endif
+
+{-|
+	Used by connectionWorker to know if it should throw an error and kill the
+  main thread.
+-}
+isServerVersionSupported :: H.Session Bool
+isServerVersionSupported = do
+  ver <- H.query () pgVersion
+  return $ ver >= pgvNum minimumPgVersion
+ where
+  pgVersion =
+    H.statement "SELECT current_setting('server_version_num')::integer"
+      HE.unit (HD.singleRow $ HD.value HD.int4) False
+
+{-|
+  The purpose of this worker is to fill the refDbStructure created in 'main'
+  with the 'DbStructure' returned from calling 'getDbStructure'. This method
+  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 'isServerVersionSupported' returns false
+  -> P.Pool   -- ^ The PostgreSQL connection pool
+  -> Schema   -- ^ Schema PostgREST is serving up
+  -> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure'
+  -> IORef Bool                -- ^ Used as a binary Semaphore
+  -> IO ()
+connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
+  isWorkerOn <- readIORef refIsWorkerOn
+  unless isWorkerOn $ do
+    atomicWriteIORef refIsWorkerOn True
+    void $ forkIO work
+  where
+    work = do
+      atomicWriteIORef refDbStructure Nothing
+      putStrLn ("Attempting to connect to the database..." :: Text)
+      connected <- connectingSucceeded pool
+      when connected $ do
+        result <- P.use pool $ do
+          supported <- isServerVersionSupported
+          unless supported $ liftIO $ do
+            hPutStrLn stderr
+              ("Cannot run in this PostgreSQL version, PostgREST needs at least "
+              <> pgvName minimumPgVersion)
+            killThread mainTid
+          dbStructure <- getDbStructure schema
+          liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
+        case result of
+          Left e -> do
+            putStrLn ("Failed to query the database. Retrying." :: Text)
+            hPutStrLn stderr (toS $ encodeError e)
+            work
+          Right _ -> do
+            atomicWriteIORef refIsWorkerOn False
+            putStrLn ("Connection successful" :: Text)
+
+
+{-|
+  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.
+-}
+connectingSucceeded :: P.Pool -> IO Bool
+connectingSucceeded pool =
+  retrying (capDelay 32000000 $ exponentialBackoff 1000000)
+           shouldRetry
+           (const $ P.release pool >> isConnectionSuccessful)
+  where
+    isConnectionSuccessful :: IO Bool
+    isConnectionSuccessful = do
+      testConn <- P.use pool $ H.sql "SELECT 1"
+      case testConn of
+        Left e -> hPutStrLn stderr (toS $ encodeError e) >> pure False
+        _ -> pure True
+    shouldRetry :: RetryStatus -> Bool -> IO Bool
+    shouldRetry rs isConnSucc = do
+      delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000
+      itShould <- pure $ not isConnSucc
+      when itShould $
+        putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
+      return itShould
+
+{-|
+  This is where everything starts.
+-}
+main :: IO ()
+main = do
+  --
+  -- LineBuffering: the entire output buffer is flushed whenever a newline is
+  -- output, the buffer overflows, a hFlush is issued or the handle is closed
+  --
+  -- NoBuffering: output is written immediately and never stored in the buffer
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stdin LineBuffering
+  hSetBuffering stderr NoBuffering
+  --
+  -- readOptions builds the 'AppConfig' from the config file specified on the
+  -- command line
+  conf <- loadSecretFile =<< readOptions
+  let host = configHost conf
+      port = configPort conf
+      proxy = configProxyUri conf
+      pgSettings = toS (configDatabase conf) -- is the db-uri
+      appSettings =
+        setHost ((fromString . toS) host) -- Warp settings
+        . setPort port
+        . setServerName (toS $ "postgrest/" <> prettyVersion)
+        . setTimeout 3600 $
+        defaultSettings
+  --
+  -- Checks that the provided proxy uri is formated correctly,
+  -- does not test if it works here.
+  when (isMalformedProxyUri $ toS <$> proxy) $
+    panic
+      "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
+  putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)
+  --
+  -- create connection pool with the provided settings, returns either
+  -- a 'Connection' or a 'ConnectionError'. Does not throw.
+  pool <- P.acquire (configPool conf, 10, 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
+    (configSchema conf)
+    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 sigHUP (
+    Catch $ connectionWorker
+              mainTid
+              pool
+              (configSchema conf)
+              refDbStructure
+              refIsWorkerOn
+    ) Nothing
+#endif
+
+  --
+  -- run the postgrest application
+  runSettings appSettings $
+    postgrest
+      conf
+      refDbStructure
+      pool
+      (connectionWorker
+         mainTid
+         pool
+         (configSchema conf)
+         refDbStructure
+         refIsWorkerOn)
+
+{-|
+  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 secret
+        Just filename -> readFile (toS filename)
+    --
+    -- Turns the Base64url encoded JWT into Base64
+    transformString :: Bool -> Text -> IO ByteString
+    transformString False t = return . encodeUtf8 $ t
+    transformString True t =
+      case decode (encodeUtf8 $ strip $ replaceUrlChars 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 "." "="

postgrest.cabal

@@ -2,7 +2,7 @@ name:                  postgrest
 description:           Reads the schema of a PostgreSQL database and creates RESTful routes
                        for the tables and views, supporting all HTTP verbs that security
                        permits.
-version:               0.2.10.0
+version:               0.4.3.0
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
@@ -22,130 +22,138 @@ Flag CI
   Default:     False
 
 executable postgrest
-  main-is:             PostgREST/Main.hs
-  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
+  main-is:             Main.hs
+  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
+  ghc-options:
+    -threaded
+    -rtsopts
+    "-with-rtsopts=-N -I2"
   default-language:    Haskell2010
-  build-depends:       base >=4.6 && <5
+  build-depends:       base
+                     , hasql
+                     , hasql-pool
                      , postgrest
-                     , hasql == 0.7.3.1, hasql-backend == 0.4.1
-                     , hasql-postgres == 0.10.3.1
-                     , warp >= 3.0.2, wai >= 3.0.1
-                     , wai-extra, wai-cors
-                     , wai-middleware-static >= 0.6.0
-                     , HTTP, convertible, http-types
-                     , case-insensitive
-                     , scientific, time
-                     , aeson, network >= 2.6
-                     , bytestring, text, split, string-conversions
-                     , stringsearch
-                     , containers, unordered-containers
-                     , optparse-applicative == 0.11.*
-                     , regex-base, regex-tdfa
-                     , regex-tdfa-text
-                     , Ranged-sets
-                     , transformers, MissingH
-                     , bcrypt >= 0.0.6, base64-string
-                     , network-uri >= 2.6
-                     , resource-pool
-                     , blaze-builder
-                     , vector
-                     , mtl
-                     , cassava
-                     , jwt
-  hs-source-dirs:      src
+                     , protolude
+                     , text
+                     , warp
+                     , bytestring
+                     , base64-bytestring
+                     , retry
+  if !os(windows)
+    build-depends:     unix
+
+  hs-source-dirs:      main
 
 library
-  if flag(ci)
-    ghc-options:       -Wall -W -Werror
-  else
-    ghc-options:       -Wall -W -O2
-
   default-language:    Haskell2010
-  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
-  build-depends:       base >=4.6 && <5
-                     , hasql == 0.7.3.1, hasql-backend == 0.4.1
-                     , hasql-postgres == 0.10.3.1
-                     , warp >= 3.0.2, wai >= 3.0.1
-                     , wai-extra, wai-cors
-                     , wai-middleware-static >= 0.6.0
-                     , HTTP, convertible, http-types
+  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
+  build-depends:       aeson
+                     , ansi-wl-pprint
+                     , base >= 4.8 && < 6
+                     , base64-bytestring
+                     , bytestring
                      , case-insensitive
-                     , scientific, time
-                     , aeson, network >= 2.6
-                     , bytestring, text, split, string-conversions
-                     , stringsearch
-                     , containers, unordered-containers
-                     , optparse-applicative == 0.11.*
-                     , regex-base, regex-tdfa
-                     , regex-tdfa-text
-                     , Ranged-sets
-                     , transformers, MissingH
-                     , bcrypt >= 0.0.6, base64-string
-                     , network-uri >= 2.6
-                     , resource-pool
-                     , blaze-builder
-                     , vector
-                     , mtl
                      , cassava
-                     , jwt
-  Exposed-Modules:     PostgREST.App
+                     , configurator-ng == 0.0.0.1
+                     , containers
+                     , contravariant
+                     , either
+                     , hasql
+                     , hasql-pool == 0.4.1
+                     , hasql-transaction == 0.5
+                     , heredoc
+                     , HTTP
+                     , http-types
+                     , insert-ordered-containers
+                     , interpolatedstring-perl6
+                     , jose
+                     , lens
+                     , lens-aeson
+                     , network-uri
+                     , optparse-applicative >= 0.13 && < 0.15
+                     , parsec
+                     , protolude >= 0.2
+                     , Ranged-sets == 0.3.0
+                     , regex-tdfa
+                     , safe
+                     , scientific
+                     , swagger2
+                     , text
+                     , unordered-containers
+                     , vector
+                     , wai
+                     , wai-cors
+                     , wai-extra
+                     , wai-middleware-static
+                     , cookie
+
+  Other-Modules:       Paths_postgrest
+  Exposed-Modules:     PostgREST.ApiRequest
+                     , PostgREST.App
                      , PostgREST.Auth
                      , PostgREST.Config
+                     , PostgREST.DbStructure
+                     , PostgREST.DbRequestBuilder
                      , PostgREST.Error
                      , PostgREST.Middleware
-                     , PostgREST.PgQuery
-                     , PostgREST.PgStructure
+                     , PostgREST.OpenAPI
+                     , PostgREST.Parsers
+                     , PostgREST.QueryBuilder
                      , PostgREST.RangeQuery
+                     , PostgREST.Types
   hs-source-dirs:      src
 
 Test-Suite spec
   Type:                exitcode-stdio-1.0
   Default-Language:    Haskell2010
-  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
-  Hs-Source-Dirs:      test, src
-  if flag(ci)
-    ghc-options:       -Wall -W -Werror
-  else
-    ghc-options:       -Wall -W -O2
+  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  Hs-Source-Dirs:      test
   Main-Is:             Main.hs
-  Other-Modules:       PostgREST.App
-                     , PostgREST.Auth
-                     , PostgREST.Config
-                     , PostgREST.Error
-                     , PostgREST.Middleware
-                     , PostgREST.PgQuery
-                     , PostgREST.PgStructure
-                     , PostgREST.RangeQuery
-                     , Spec
+  Other-Modules:       Feature.AuthSpec
+                     , Feature.AsymmetricJwtSpec
+                     , Feature.BinaryJwtSecretSpec
+                     , Feature.ConcurrentSpec
+                     , Feature.CorsSpec
+                     , Feature.DeleteSpec
+                     , Feature.InsertSpec
+                     , Feature.NoJwtSpec
+                     , Feature.ProxySpec
+                     , Feature.QueryLimitedSpec
+                     , Feature.QuerySpec
+                     , Feature.RangeSpec
+                     , Feature.SingularSpec
+                     , Feature.StructureSpec
+                     , Feature.UnicodeSpec
+                     , Feature.AndOrParamsSpec
                      , SpecHelper
-  Build-Depends:       base, hspec >= 2.1.2, QuickCheck
-                     , hspec-wai >= 0.5.0, hspec-wai-json
-                     , hasql == 0.7.3.1, hasql-backend == 0.4.1
-                     , hasql-postgres == 0.10.3.1
-                     , warp, wai
-                     , packdeps, hlint
-                     , HTTP, convertible
+                     , TestTypes
+  Build-Depends:       aeson
+                     , aeson-qq
+                     , async
+                     , base
+                     , bytestring
+                     , base64-bytestring
                      , case-insensitive
-                     , wai-extra, wai-cors, containers
-                     , wai-middleware-static
-                     , http-types, scientific, time
-                     , bytestring, aeson, network
-                     , text, optparse-applicative
-                     , stringsearch
-                     , unordered-containers
-                     , regex-base
-                     , string-conversions
-                     , http-media, regex-tdfa
-                     , regex-tdfa-text
-                     , Ranged-sets
-                     , transformers, MissingH, split
-                     , bcrypt, base64-string
-                     , network-uri
-                     , resource-pool
-                     , blaze-builder
-                     , vector
-                     , mtl
                      , cassava
-                     , process
+                     , containers
+                     , contravariant
+                     , hasql
+                     , hasql-pool
                      , heredoc
-                     , jwt
+                     , hjsonpointer
+                     , hjsonschema == 1.5.0.1
+                     , hspec
+                     , hspec-wai >= 0.7.0
+                     , hspec-wai-json
+                     , http-types
+                     , lens
+                     , lens-aeson
+                     , monad-control
+                     , postgrest
+                     , process
+                     , protolude
+                     , regex-tdfa
+                     , transformers-base
+                     , wai
+                     , wai-extra

scripts/release_s3.sh

@@ -1,6 +1,6 @@
 export POSTGREST_VER=`grep ^version /app/postgrest.cabal | sed -En 's/.*\s+([0-9\.]+)/\1/p'`
 
-curl -L http://softlayer-ams.dl.sourceforge.net/project/s3tools/s3cmd/1.5.0-alpha1/s3cmd-1.5.0-alpha1.tar.gz | tar zx
+curl -L http://sourceforge.net/projects/s3tools/files/s3cmd/1.5.0-alpha1/s3cmd-1.5.0-alpha1.tar.gz | tar zx
 
 cp /app/dist/build/postgrest/postgrest postgrest-${POSTGREST_VER}
 tar cJf postgrest-${POSTGREST_VER}.tar.xz postgrest-${POSTGREST_VER}

src/PostgREST/ApiRequest.hs

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

src/PostgREST/App.hs

@@ -1,315 +1,364 @@
-{-# LANGUAGE FlexibleContexts #-}
-module PostgREST.App (app, sqlError, isSqlError) where
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
-import Control.Monad (join)
-import Control.Arrow ((***), second)
-import Control.Applicative
+module PostgREST.App (
+  postgrest
+) where
 
-import Data.Text hiding (map)
-import Data.Maybe (fromMaybe, mapMaybe)
-import Text.Regex.TDFA ((=~))
-import Data.Ord (comparing)
-import Data.Ranged.Ranges (emptyRange)
-import qualified Data.HashMap.Strict as M
-import Data.String.Conversions (cs)
-import Data.CaseInsensitive (original)
-import Data.List (sortBy)
-import Data.Functor.Identity
-import qualified Data.Set as S
-import qualified Data.ByteString.Lazy as BL
-import qualified Blaze.ByteString.Builder as BB
-import qualified Data.Csv as CSV
+import           Control.Applicative
+import qualified Data.ByteString.Char8     as BS
+import           Data.Maybe
+import           Data.IORef                (IORef, readIORef)
+import           Data.Text                 (intercalate)
 
-import Network.HTTP.Types.Status
-import Network.HTTP.Types.Header
-import Network.HTTP.Types.URI (parseSimpleQuery)
-import Network.HTTP.Base (urlEncodeVars)
-import Network.Wai
-import Network.Wai.Internal (Response(..))
+import qualified Hasql.Pool                 as P
+import qualified Hasql.Transaction          as HT
+import qualified Hasql.Transaction.Sessions as HT
 
-import Data.Aeson
-import Data.Monoid
-import qualified Data.Vector as V
-import qualified Hasql as H
-import qualified Hasql.Backend as B
-import qualified Hasql.Postgres as P
+import           Network.HTTP.Types.Header
+import           Network.HTTP.Types.Status
+import           Network.HTTP.Types.URI    (renderSimpleQuery)
+import           Network.Wai
+import           Network.Wai.Middleware.RequestLogger (logStdout)
 
-import PostgREST.Config (AppConfig(..))
-import PostgREST.Auth
-import PostgREST.PgQuery
-import PostgREST.RangeQuery
-import PostgREST.PgStructure
+import qualified Data.Vector               as V
+import qualified Hasql.Transaction         as H
 
-import Prelude
+import qualified Data.HashMap.Strict       as M
 
-app :: AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
-app conf reqBody req =
-  case (path, verb) of
-    ([], _) -> do
-      body <- encode <$> tables (cs schema)
-      return $ responseLBS status200 [jsonH] $ cs body
+import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
+                                        , Action(..), Target(..)
+                                        , PreferRepresentation (..)
+                                        , mutuallyAgreeable
+                                        , userApiRequest
+                                        )
+import           PostgREST.Auth            (jwtClaims, containsRole, parseJWK)
+import           PostgREST.Config          (AppConfig (..))
+import           PostgREST.DbStructure
+import           PostgREST.DbRequestBuilder( readRequest
+                                           , mutateRequest
+                                           , fieldNames
+                                           )
+import           PostgREST.Error           ( simpleError, pgError
+                                           , apiRequestError
+                                           , singularityError, binaryFieldError
+                                           , connectionLostError
+                                           )
+import           PostgREST.RangeQuery      (allRange, rangeOffset)
+import           PostgREST.Middleware
+import           PostgREST.QueryBuilder ( callProc
+                                        , requestToQuery
+                                        , requestToCountQuery
+                                        , createReadStatement
+                                        , createWriteStatement
+                                        , ResultsWithCount
+                                        )
+import           PostgREST.Types
+import           PostgREST.OpenAPI
 
-    ([table], "OPTIONS") -> do
-      let t = QualifiedTable schema (cs table)
-      cols <- columns t
-      pkey <- map cs <$> primaryKeyColumns t
-      return $ responseLBS status200 [jsonH, allOrigins]
-        $ encode (TableOptions cols pkey)
+import           Data.Function (id)
+import           Protolude              hiding (intercalate, Proxy)
+import           Safe                   (headMay)
 
-    ([table], "GET") ->
-      if range == Just emptyRange
-      then return $ responseLBS status416 [] "HTTP Range error"
-      else do
-        let qt = QualifiedTable schema (cs table)
-        let select = B.Stmt "select " V.empty True <>
-                  parentheticT (
-                    whereT qq $ countRows qt
-                  ) <> commaq <> (
-                  asJsonWithCount
-                  . limitT range
-                  . orderT (orderParse qq)
-                  . whereT qq
-                  $ selectStar qt
-                )
-        row <- H.maybeEx select
-        let (tableTotal, queryTotal, body) =
-              fromMaybe (0, 0, Just "" :: Maybe Text) row
-            from = fromMaybe 0 $ rangeOffset <$> range
-            to = from+queryTotal-1
-            contentRange = contentRangeH from to tableTotal
-            status = rangeStatus from to tableTotal
-            canonical = urlEncodeVars
-                          . sortBy (comparing fst)
-                          . map (join (***) cs)
-                          . parseSimpleQuery
-                          $ rawQueryString req
-        return $ responseLBS status
-          [jsonH, contentRange,
-            ("Content-Location",
-             "/" <> cs table <>
-                if Prelude.null canonical then "" else "?" <> cs canonical
-            )
-          ] (cs $ fromMaybe "[]" body)
+postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO () -> Application
+postgrest conf refDbStructure pool worker =
+  let middle = (if configQuiet conf then id else logStdout) . defaultMiddle
+      jwtSecret = parseJWK <$> configJwtSecret conf in
 
-    (["postgrest", "users"], "POST") -> do
-      let user = decode reqBody :: Maybe AuthUser
+  middle $ \ req respond -> do
+    body <- strictRequestBody req
+    maybeDbStructure <- readIORef refDbStructure
+    case maybeDbStructure of
+      Nothing -> respond connectionLostError
+      Just dbStructure -> do
+        response <- case userApiRequest (configSchema conf) req body of
+          Left err -> return $ apiRequestError err
+          Right apiRequest -> do
+            eClaims <- jwtClaims jwtSecret (toS $ iJWT apiRequest)
 
-      case user of
-        Nothing -> return $ responseLBS status400 [jsonH] $
-          encode . object $ [("message", String "Failed to parse user.")]
-        Just u -> do
-          _ <- addUser (cs $ userId u)
-            (cs $ userPass u) (cs $ userRole u)
-          return $ responseLBS status201
-            [ jsonH
-            , (hLocation, "/postgrest/users?id=eq." <> cs (userId u))
-            ] ""
+            let authed = containsRole eClaims
+                handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
+                txMode = transactionMode dbStructure
+                  (iTarget apiRequest) (iAction apiRequest)
+            response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
+            return $ either (pgError authed) identity response
+        when (isResponse503 response) worker
+        respond response
 
-    (["postgrest", "tokens"], "POST") ->
-      case jwtSecret of
-        "secret" -> return $ responseLBS status500 [jsonH] $
-          encode . object $ [("message", String "JWT Secret is set as \"secret\" which is an unsafe default.")]
-        _ -> do
-          let user = decode reqBody :: Maybe AuthUser
+isResponse503 :: Response -> Bool
+isResponse503 resp = statusCode (responseStatus resp) == 503
 
-          case user of
-            Nothing -> return $ responseLBS status400 [jsonH] $
-              encode . object $ [("message", String "Failed to parse user.")]
-            Just u -> do
-              setRole authenticator
-              login <- signInRole (cs $ userId u)
-                              (cs $ userPass u)
-              case login of
-                LoginSuccess role uid ->
-                  return $ responseLBS status201 [ jsonH ] $
-                    encode . object $ [("token", String $ tokenJWT jwtSecret uid role)]
-                _  -> return $ responseLBS status401 [jsonH] $
-                  encode . object $ [("message", String "Failed authentication.")]
+transactionMode :: DbStructure -> Target -> Action -> H.Mode
+transactionMode structure target action =
+  case action of
+    ActionRead -> HT.Read
+    ActionInfo -> HT.Read
+    ActionInspect -> HT.Read
+    ActionInvoke ->
+      let proc =
+            case target of
+              (TargetProc qi) -> M.lookup (qiName qi) $
+                                   dbProcs structure
+              _               -> Nothing
+          v = fromMaybe Volatile $ pdVolatility <$> proc in
+      if v == Stable || v == Immutable
+         then HT.Read
+         else HT.Write
+    _ -> HT.Write
 
-    ([table], "POST") -> do
-      let qt = QualifiedTable schema (cs table)
-          echoRequested = lookup "Prefer" hdrs == Just "return=representation"
-          parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
-          parsed = if lookup "Content-Type" hdrs == Just "text/csv"
-                    then do
-                      rows <- CSV.decode CSV.NoHeader reqBody
-                      if V.null rows then Left "CSV requires header"
-                        else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))
-                    else eitherDecode reqBody >>= \val ->
-                      case val of
-                        Object obj -> Right .  second V.singleton .  V.unzip .  V.fromList $
-                          M.toList obj
-                        _ -> Left "Expecting single JSON object or CSV rows"
-      case parsed of
-        Left err -> return $ responseLBS status400 [] $
-          encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]
-        Right toBeInserted -> do
-          rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
-          let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
-          primaryKeys <- primaryKeyColumns qt
-          let responses = flip map inserted $ \obj -> do
-                let primaries =
-                      if Prelude.null primaryKeys
-                        then obj
-                        else M.filterWithKey (const . (`elem` primaryKeys)) obj
-                let params = urlEncodeVars
-                      $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
-                      $ sortBy (comparing fst) $ M.toList primaries
-                responseLBS status201
-                  [ jsonH
-                  , (hLocation, "/" <> cs table <> "?" <> cs params)
-                  ] $ if echoRequested then encode obj else ""
-          return $ multipart status201 responses
+app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
+app dbStructure conf apiRequest =
+  case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of
+    Left errorResponse -> return errorResponse
+    Right contentType ->
+      case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
 
-    ([table], "PUT") ->
-      handleJsonObj reqBody $ \obj -> do
-        let qt = QualifiedTable schema (cs table)
-        primaryKeys <- primaryKeyColumns qt
-        let specifiedKeys = map (cs . fst) qq
-        if S.fromList primaryKeys /= S.fromList specifiedKeys
-          then return $ responseLBS status405 []
-               "You must speficy all and only primary keys as params"
-          else do
-            tableCols <- map (cs . colName) <$> columns qt
-            let cols = map cs $ M.keys obj
-            if S.fromList tableCols == S.fromList cols
-              then do
-                let vals = M.elems obj
-                H.unitEx $ iffNotT
-                        (whereT qq $ update qt cols vals)
-                        (insertSelect qt cols vals)
-                return $ responseLBS status204 [ jsonH ] ""
+        (ActionRead, TargetIdent qi, Nothing) ->
+          let partsField = (,) <$> readSqlParts
+                <*> (binaryField contentType =<< fldNames) in
+          case partsField of
+            Left errorResponse -> return errorResponse
+            Right ((q, cq), bField) -> do
+              let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount
+                                            (contentType == CTTextCSV) bField
+              row <- H.query () stm
+              let (tableTotal, queryTotal, _ , body) = row
+                  (status, contentRange) = rangeHeader queryTotal tableTotal
+                  canonical = iCanonicalQS apiRequest
+              return $
+                if contentType == CTSingularJSON && queryTotal /= 1
+                  then singularityError (toInteger queryTotal)
+                  else responseLBS status
+                    [toHeader contentType, contentRange,
+                      ("Content-Location",
+                        "/" <> toS (qiName qi) <>
+                          if BS.null canonical then "" else "?" <> toS canonical
+                      )
+                    ] (toS body)
 
-              else return $ if Prelude.null tableCols
-                then responseLBS status404 [] ""
-                else responseLBS status400 []
-                   "You must specify all columns in PUT request"
+        (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->
+          case mutateSqlParts of
+            Left errorResponse -> return errorResponse
+            Right (sq, mq) -> do
+              let isSingle = (==1) $ V.length rows
+              if contentType == CTSingularJSON
+                 && not isSingle
+                 && iPreferRepresentation apiRequest == Full
+                then return $ singularityError (toInteger $ V.length rows)
+                else do
+                  let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
+                      stm = createWriteStatement sq mq
+                        (contentType == CTSingularJSON) isSingle
+                        (contentType == CTTextCSV) (iPreferRepresentation apiRequest)
+                        pKeys
+                  row <- H.query payload stm
+                  let (_, _, fs, body) = extractQueryResult row
+                      headers = catMaybes [
+                          if null fs
+                            then Nothing
+                            else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
+                        , if iPreferRepresentation apiRequest == Full
+                            then Just $ toHeader contentType
+                            else Nothing
+                        , Just . contentRangeH 1 0 $
+                            toInteger <$> if shouldCount then Just (V.length rows) else Nothing
+                        ]
 
-    ([table], "PATCH") ->
-      handleJsonObj reqBody $ \obj -> do
-        let qt = QualifiedTable schema (cs table)
-            up = returningStarT
-               . whereT qq
-               $ update qt (map cs $ M.keys obj) (M.elems obj)
-            patch = withT up "t" $ B.Stmt
-              "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying"
-              V.empty True
+                  return . responseLBS status201 headers $
+                    if iPreferRepresentation apiRequest == Full
+                      then toS body else ""
 
-        row <- H.maybeEx patch
-        let (queryTotal, body) =
-              fromMaybe (0 :: Int, Just "" :: Maybe Text) row
-            r = contentRangeH 0 (queryTotal-1) queryTotal
-            echoRequested = lookup "Prefer" hdrs == Just "return=representation"
-            s = case () of _ | queryTotal == 0 -> status404
-                             | echoRequested -> status200
-                             | otherwise -> status204
-        return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
+        (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON rows)) ->
+          case (mutateSqlParts, null <$> rows V.!? 0, iPreferRepresentation apiRequest == Full) of
+            (Left errorResponse, _, _) -> return errorResponse
+            (_, Just True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"
+            (_, Just True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""
+            (Right (sq, mq), _, _) -> do
+              let stm = createWriteStatement sq mq
+                    (contentType == CTSingularJSON) False (contentType == CTTextCSV)
+                    (iPreferRepresentation apiRequest) []
+              row <- H.query payload stm
+              let (_, queryTotal, _, body) = extractQueryResult row
+              if contentType == CTSingularJSON
+                 && queryTotal /= 1
+                 && iPreferRepresentation apiRequest == Full
+                then do
+                  HT.condemn
+                  return $ singularityError (toInteger queryTotal)
+                else do
+                  let r = contentRangeH 0 (toInteger $ queryTotal-1)
+                            (toInteger <$> if shouldCount then Just queryTotal else Nothing)
+                      s = if iPreferRepresentation apiRequest == Full
+                            then status200
+                            else status204
+                  return $ if iPreferRepresentation apiRequest == Full
+                    then responseLBS s [toHeader contentType, r] (toS body)
+                    else responseLBS s [r] ""
 
-    ([table], "DELETE") -> do
-      let qt = QualifiedTable schema (cs table)
-      let del = countT
-            . returningStarT
-            . whereT qq
-            $ deleteFrom qt
-      row <- H.maybeEx del
-      let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row
-      return $ if deletedCount == 0
-         then responseLBS status404 [] ""
-         else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] ""
+        (ActionDelete, TargetIdent _, Nothing) ->
+          case mutateSqlParts of
+            Left errorResponse -> return errorResponse
+            Right (sq, mq) -> do
+              let emptyPayload = PayloadJSON V.empty
+                  stm = createWriteStatement sq mq
+                    (contentType == CTSingularJSON) False
+                    (contentType == CTTextCSV)
+                    (iPreferRepresentation apiRequest) []
+              row <- H.query emptyPayload stm
+              let (_, queryTotal, _, body) = extractQueryResult row
+                  r = contentRangeH 1 0 $
+                        toInteger <$> if shouldCount then Just queryTotal else Nothing
+              if contentType == CTSingularJSON
+                 && queryTotal /= 1
+                 && iPreferRepresentation apiRequest == Full
+                then do
+                  HT.condemn
+                  return $ singularityError (toInteger queryTotal)
+                else
+                  return $ if iPreferRepresentation apiRequest == Full
+                    then responseLBS status200 [toHeader contentType, r] (toS body)
+                    else responseLBS status204 [r] ""
 
-    (_, _) ->
-      return $ responseLBS status404 [] ""
+        (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
+          let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
+          case mTable of
+            Nothing -> return notFound
+            Just table ->
+              let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
+              return $ responseLBS status200 [allOrigins, acceptH] ""
 
+        (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->
+          let proc = M.lookup (qiName qi) allProcs
+              returnsScalar = case proc of
+                Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True
+                _ -> False
+              rpcBinaryField = if returnsScalar
+                                 then Right Nothing
+                                 else binaryField contentType =<< fldNames
+              partsField = (,) <$> readSqlParts <*> rpcBinaryField in
+          case partsField of
+            Left errorResponse -> return errorResponse
+            Right ((q, cq), bField) -> do
+              let p = V.head payload
+                  singular = contentType == CTSingularJSON
+                  paramsAsSingleObject = iPreferSingleObjectParameter apiRequest
+              row <- H.query () $
+                callProc qi p returnsScalar q cq topLevelRange shouldCount
+                         singular paramsAsSingleObject
+                         (contentType == CTTextCSV)
+                         (contentType == CTOctetStream) bField
+              let (tableTotal, queryTotal, body) =
+                    fromMaybe (Just 0, 0, "[]") row
+                  (status, contentRange) = rangeHeader queryTotal tableTotal
+              if singular && queryTotal /= 1
+                then do
+                  HT.condemn
+                  return $ singularityError (toInteger queryTotal)
+                else return $ responseLBS status [toHeader contentType, contentRange] (toS body)
+
+        (ActionInspect, TargetRoot, Nothing) -> do
+          let host = configHost conf
+              port = toInteger $ configPort conf
+              proxy = pickProxy $ toS <$> configProxyUri conf
+              uri Nothing = ("http", host, port, "/")
+              uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
+              uri' = uri proxy
+              encodeApi ti sd = encodeOpenAPI (M.elems allProcs) (toTableInfo ti) uri' sd (dbPrimaryKeys dbStructure)
+          body <- encodeApi <$> H.query schema accessibleTables <*> H.query schema schemaDescription
+          return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body
+
+        _ -> return notFound
+
+    where
+      toTableInfo :: [Table] -> [(Table, [Column], [Text])]
+      toTableInfo = map (\t ->
+        let tSchema = tableSchema t
+            tTable = tableName t
+            cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
+            pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
+        in (t, cols, pkeys))
+      notFound = responseLBS status404 [] ""
+      filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
+      filterCol :: Schema -> TableName -> Column -> Bool
+      filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
+      allPrKeys = dbPrimaryKeys dbStructure
+      allProcs = dbProcs dbStructure
+      allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
+      shouldCount = iPreferCount apiRequest
+      schema = toS $ configSchema conf
+      topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
+      rangeHeader queryTotal tableTotal =
+        let lower = rangeOffset topLevelRange
+            upper = lower + toInteger queryTotal - 1
+            contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
+            status = rangeStatus lower upper (toInteger <$> tableTotal)
+        in (status, contentRange)
+
+      readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) allProcs apiRequest
+      fldNames = fieldNames <$> readReq
+      readDbRequest = DbRead <$> readReq
+      mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< fldNames)
+      selectQuery = requestToQuery schema False <$> readDbRequest
+      mutateQuery = requestToQuery schema False <$> mutateDbRequest
+      countQuery = requestToCountQuery schema <$> readDbRequest
+      readSqlParts = (,) <$> selectQuery <*> countQuery
+      mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
+
+responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
+responseContentTypeOrError accepts action = serves contentTypesForRequest accepts
   where
-    path   = pathInfo req
-    verb   = requestMethod req
-    qq     = queryString req
-    hdrs   = requestHeaders req
-    schema = requestedSchema (cs $ configV1Schema conf) hdrs
-    authenticator = cs $ configDbUser conf
-    jwtSecret = cs $ configJwtSecret conf
-    range  = rangeRequested hdrs
-    allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
+    contentTypesForRequest =
+      case action of
+        ActionRead ->    [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
+        ActionCreate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
+        ActionUpdate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
+        ActionDelete ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
+        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
+        ActionInspect -> [CTOpenAPI, CTApplicationJSON]
+        ActionInfo ->    [CTTextCSV]
+    serves sProduces cAccepts =
+      case mutuallyAgreeable sProduces cAccepts of
+        Nothing -> do
+          let failed = intercalate ", " $ map (toS . toMime) cAccepts
+          Left $ simpleError status415 [] $
+            "None of these Content-Types are available: " <> failed
+        Just ct -> Right ct
 
-sqlError :: t
-sqlError = undefined
+binaryField :: ContentType -> [FieldName] -> Either Response (Maybe FieldName)
+binaryField CTOctetStream fldNames =
+  if length fldNames == 1 && fieldName /= Just "*"
+    then Right fieldName
+    else Left binaryFieldError
+  where
+    fieldName = headMay fldNames
+binaryField _ _ = Right Nothing
 
-isSqlError :: t
-isSqlError = undefined
+splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
+splitKeyValue kv = (k, BS.tail v)
+  where (k, v) = BS.break (== '=') kv
 
-rangeStatus :: Int -> Int -> Int -> Status
-rangeStatus from to total
-  | from > total            = status416
-  | (1 + to - from) < total = status206
+renderLocationFields :: [BS.ByteString] -> BS.ByteString
+renderLocationFields fields =
+  renderSimpleQuery True $ map splitKeyValue fields
+
+rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
+rangeStatus _ _ Nothing = status200
+rangeStatus lower upper (Just total)
+  | lower > total            = status416
+  | (1 + upper - lower) < total = status206
   | otherwise               = status200
 
-contentRangeH :: Int -> Int -> Int -> Header
-contentRangeH from to total =
-  ("Content-Range",
-    if total == 0 || from > total
-    then "*/" <> cs (show total)
-    else cs (show from)  <> "-"
-       <> cs (show to)    <> "/"
-       <> cs (show total)
-  )
+contentRangeH :: Integer -> Integer -> Maybe Integer -> Header
+contentRangeH lower upper total =
+    ("Content-Range", headerValue)
+    where
+      headerValue   = rangeString <> "/" <> totalString
+      rangeString
+        | totalNotZero && fromInRange = show lower <> "-" <> show upper
+        | otherwise = "*"
+      totalString   = fromMaybe "*" (show <$> total)
+      totalNotZero  = fromMaybe True ((/=) 0 <$> total)
+      fromInRange   = lower <= upper
 
-requestedSchema :: Text -> RequestHeaders -> Text
-requestedSchema v1schema hdrs =
-  case verStr of
-       Just [[_, ver]] -> if ver == "1" then v1schema else ver
-       _ -> v1schema
-
-  where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
-        accept = cs <$> lookup hAccept hdrs :: Maybe Text
-        verStr = (=~ verRegex) <$> accept :: Maybe [[Text]]
-
-jsonH :: Header
-jsonH = (hContentType, "application/json")
-
-handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
-              -> H.Tx P.Postgres s Response
-handleJsonObj reqBody handler = do
-  let p = eitherDecode reqBody
-  case p of
-    Left err ->
-      return $ responseLBS status400 [jsonH] jErr
-      where
-        jErr = encode . object $
-          [("message", String $ "Failed to parse JSON payload. " <> cs err)]
-    Right (Object o) -> handler o
-    Right _ ->
-      return $ responseLBS status400 [jsonH] jErr
-      where
-        jErr = encode . object $
-          [("message", String "Expecting a JSON object")]
-
-parseCsvCell :: BL.ByteString -> Value
-parseCsvCell s = if s == "NULL" then Null else String $ cs s
-
-multipart :: Status -> [Response] -> Response
-multipart _ [] = responseLBS status204 [] ""
-multipart _ [r] = r
-multipart s rs =
-  responseLBS s [(hContentType, "multipart/mixed; boundary=\"postgrest_boundary\"")] $
-    BL.intercalate "\n--postgrest_boundary\n" (map renderResponseBody rs)
-
-  where
-    renderHeader :: Header -> BL.ByteString
-    renderHeader (k, v) = cs (original k) <> ": " <> cs v
-
-    renderResponseBody :: Response -> BL.ByteString
-    renderResponseBody (ResponseBuilder _ headers b) =
-      BL.intercalate "\n" (map renderHeader headers)
-        <> "\n\n" <> BB.toLazyByteString b
-    renderResponseBody _ = error
-      "Unable to create multipart response from non-ResponseBuilder"
-
-data TableOptions = TableOptions {
-  tblOptcolumns :: [Column]
-, tblOptpkey :: [Text]
-}
-
-instance ToJSON TableOptions where
-  toJSON t = object [
-      "columns" .= tblOptcolumns t
-    , "pkey"   .= tblOptpkey t ]
+extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
+extractQueryResult = fromMaybe (Nothing, 0, [], "")

src/PostgREST/Auth.hs

@@ -1,104 +1,92 @@
-{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}
-module PostgREST.Auth where
+{-# LANGUAGE FlexibleContexts #-}
+{-|
+Module      : PostgREST.Auth
+Description : PostgREST authorization functions.
 
-import Data.Aeson
-import Control.Monad (mzero)
-import Control.Applicative
-import Crypto.BCrypt
-import Data.Text
-import Data.Monoid
-import Data.Map
-import qualified Data.Vector as V
-import qualified Hasql as H
-import qualified Hasql.Backend as B
-import qualified Hasql.Postgres as P
-import qualified Web.JWT as JWT
-import Data.String.Conversions (cs)
-import PostgREST.PgQuery (pgFmtLit)
+This module provides functions to deal with the JWT authorization (http://jwt.io).
+It also can be used to define other authorization functions,
+in the future Oauth, LDAP and similar integrations can be coded here.
 
-import Prelude
+Authentication should always be implemented in an external service.
+In the test suite there is an example of simple login function that can be used for a
+very simple authentication system inside the PostgreSQL database.
+-}
+module PostgREST.Auth (
+    containsRole
+  , jwtClaims
+  , JWTAttempt(..)
+  , parseJWK
+  ) where
 
-import System.IO.Unsafe
+import           Protolude        hiding ((&))
+import           Control.Lens
+import           Data.Aeson              (Value (..), decode, toJSON)
+import qualified Data.ByteString.Lazy    as BL
+import qualified Data.HashMap.Strict     as M
 
-data AuthUser = AuthUser {
-    userId :: String
-  , userPass :: String
-  , userRole :: String
-  } deriving (Show)
+import           Crypto.JOSE.Compact
+import           Crypto.JOSE.JWK
+import           Crypto.JOSE.JWS
+import           Crypto.JOSE.Types
+import           Crypto.JWT
 
-instance FromJSON AuthUser where
-  parseJSON (Object v) = AuthUser <$>
-                         v .: "id" <*>
-                         v .: "pass" <*>
-                         v .:? "role" .!= ""
-  parseJSON _ = mzero
+{-|
+  Possible situations encountered with client JWTs
+-}
+data JWTAttempt = JWTInvalid JWTError
+                | JWTMissingSecret
+                | JWTClaims (M.HashMap Text Value)
+                deriving (Eq, Show)
 
-instance ToJSON AuthUser where
-  toJSON u = object [
-      "id" .= userId u
-    , "pass" .= userPass u
-    , "role" .= userRole u ]
+{-|
+  Receives the JWT secret (from config) and a JWT and returns a map
+  of JWT claims.
+-}
+jwtClaims :: Maybe JWK -> BL.ByteString -> IO JWTAttempt
+jwtClaims _ "" = return $ JWTClaims M.empty
+jwtClaims secret payload =
+  case secret of
+    Nothing -> return JWTMissingSecret
+    Just jwk -> do
+      let validation = defaultJWTValidationSettings
+      eJwt <- runExceptT $ do
+        jwt <- decodeCompact payload
+        validateJWSJWT validation jwk jwt
+        return jwt
+      return $ case eJwt of
+        Left e -> JWTInvalid e
+        Right jwt -> JWTClaims . claims2map . jwtClaimsSet $ jwt
 
-type DbRole = Text
-type UserId = Text
+{-|
+  Whether a response from jwtClaims contains a role claim
+-}
+containsRole :: JWTAttempt -> Bool
+containsRole (JWTClaims claims) = M.member "role" claims
+containsRole _ = False
 
-data LoginAttempt =
-    NoCredentials
-  | MalformedAuth
-  | LoginFailed
-  | LoginSuccess DbRole UserId
-  deriving (Eq, Show)
+{-|
+  Internal helper used to turn JWT ClaimSet into something
+  easier to work with
+-}
+claims2map :: ClaimsSet -> M.HashMap Text Value
+claims2map = val2map . toJSON
+ where
+  val2map (Object o) = o
+  val2map _ = M.empty
 
-checkPass :: Text -> Text -> Bool
-checkPass = (. cs) . validatePassword . cs
+parseJWK :: ByteString -> JWK
+parseJWK str =
+  fromMaybe (hs256jwk str) (decode (toS str) :: Maybe JWK)
 
-setRole :: Text -> H.Tx P.Postgres s ()
-setRole role = H.unitEx $ B.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True
-
-resetRole :: H.Tx P.Postgres s ()
-resetRole = H.unitEx [H.stmt|reset role|]
-
-setUserId :: Text -> H.Tx P.Postgres s ()
-setUserId uid = if uid /= "" then
-  H.unitEx $ B.Stmt ("set user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True
-else
-  resetUserId
-
-resetUserId :: H.Tx P.Postgres s ()
-resetUserId = H.unitEx [H.stmt|reset user_vars.user_id|]
-
-addUser :: Text -> Text -> Text -> H.Tx P.Postgres s ()
-addUser identity pass role = do
-  let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
-  H.unitEx $
-    [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
-      identity (cs hashed :: Text) role
-
-signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt
-signInRole user pass = do
-  u <- H.maybeEx $ [H.stmt|select id, pass, rolname from postgrest.auth where id = ?|] user
-  return $ maybe LoginFailed (\r ->
-      let (uid, hashed, role) = r in
-      if checkPass hashed pass
-         then LoginSuccess role uid
-         else LoginFailed
-    ) u
-
-signInWithJWT :: Text -> Text -> LoginAttempt
-signInWithJWT secret input = case maybeRole of
-    Just (Just (String role)) -> case maybeUserId of
-      Just (Just (String uid)) -> LoginSuccess (cs role) (cs uid)
-      _   -> LoginFailed
-    _   -> LoginFailed
-  where 
-    maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value)
-    maybeUserId = (Data.Map.lookup "id" <$> claims) ::Maybe (Maybe Value)
-    claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded
-    decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input
-    
-tokenJWT :: Text -> Text -> Text -> Text
-tokenJWT secret uid role = JWT.encodeSigned JWT.HS256 (JWT.secret secret) claimsSet
-  where
-    claimsSet = JWT.def {
-      JWT.unregisteredClaims = Data.Map.fromList [("id", String uid), ("role", String role)]
-    }
+{-|
+  Internal helper to generate HMAC-SHA256. When the jwt key in the
+  config file is a simple string rather than a JWK object, we'll
+  apply this function to it.
+-}
+hs256jwk :: ByteString -> JWK
+hs256jwk key =
+  fromKeyMaterial km
+    & jwkUse .~ Just Sig
+    & jwkAlg .~ (Just $ JWSAlg HS256)
+ where
+  km = OctKeyMaterial (OctKeyParameters Oct (Base64Octets key))

src/PostgREST/Config.hs

@@ -1,64 +1,196 @@
-module PostgREST.Config where
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-|
+Module      : PostgREST.Config
+Description : Manages PostgREST configuration options.
 
-import Network.Wai
-import Control.Applicative
-import Data.Text (strip)
-import qualified Data.CaseInsensitive as CI
-import qualified Data.ByteString.Char8 as BS
-import Data.String.Conversions (cs)
-import Options.Applicative hiding (columns)
-import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
-import Prelude
+This module provides a helper function to read the command line
+arguments using the optparse-applicative and the AppConfig type to store
+them.  It also can be used to define other middleware configuration that
+may be delegated to some sort of external configuration.
 
+It currently includes a hardcoded CORS policy but this could easly be
+turned in configurable behaviour if needed.
+
+Other hardcoded options such as the minimum version number also belong here.
+-}
+module PostgREST.Config ( prettyVersion
+                        , readOptions
+                        , corsPolicy
+                        , minimumPgVersion
+                        , PgVersion (..)
+                        , AppConfig (..)
+                        )
+       where
+
+import           System.IO.Error             (IOError)
+import           Control.Applicative
+import qualified Data.ByteString             as B
+import qualified Data.ByteString.Char8       as BS
+import qualified Data.CaseInsensitive        as CI
+import qualified Data.Configurator           as C
+import qualified Data.Configurator.Parser    as C
+import           Data.Configurator.Types     (Value(..))
+import           Data.List                   (lookup)
+import           Data.Monoid
+import           Data.Scientific             (floatingOrInteger)
+import           Data.Text                   (strip, intercalate, lines)
+import           Data.Text.Encoding          (encodeUtf8)
+import           Data.Text.IO                (hPutStrLn)
+import           Data.Version                (versionBranch)
+import           Network.Wai
+import           Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
+import           Options.Applicative hiding  (str)
+import           Paths_postgrest             (version)
+import           System.IO                   (hPrint)
+import           Text.Heredoc
+import           Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>))
+import qualified Text.PrettyPrint.ANSI.Leijen as L
+import           Protolude hiding            (intercalate, (<>), hPutStrLn)
+
+-- | Config file settings for the server
 data AppConfig = AppConfig {
-    configDbName :: String
-  , configDbPort :: Int
-  , configDbUser :: String
-  , configDbPass :: String
-  , configDbHost :: String
+    configDatabase          :: Text
+  , configAnonRole          :: Text
+  , configProxyUri          :: Maybe Text
+  , configSchema            :: Text
+  , configHost              :: Text
+  , configPort              :: Int
 
-  , configPort  :: Int
-  , configAnonRole :: String
-  , configSecure :: Bool
-  , configPool :: Int
-  , configV1Schema :: String
-  
-  , configJwtSecret :: String
+  , configJwtSecret         :: Maybe B.ByteString
+  , configJwtSecretIsBase64 :: Bool
+
+  , configPool              :: Int
+  , configMaxRows           :: Maybe Integer
+  , configReqCheck          :: Maybe Text
+  , configQuiet             :: Bool
   }
 
-argParser :: Parser AppConfig
-argParser = AppConfig
-  <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database")
-  <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault)
-  <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role")
-  <*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role")
-  <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault)
-
-  <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault)
-  <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE" <> help "postgres role to use for non-authenticated requests")
-  <*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS")
-  <*> option auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault)
-  <*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault)
-  <*> strOption (long "jwt-secret" <> metavar "SECRET" <> value "secret" <> help "Secret used to encrypt and decrypt JWT tokens)" <> showDefault)
-
 defaultCorsPolicy :: CorsResourcePolicy
 defaultCorsPolicy =  CorsResourcePolicy Nothing
-  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
+  ["GET", "POST", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
   (Just $ 60*60*24) False False True
 
+-- | CORS policy to be used in by Wai Cors middleware
 corsPolicy :: Request -> Maybe CorsResourcePolicy
 corsPolicy req = case lookup "origin" headers of
   Just origin -> Just defaultCorsPolicy {
       corsOrigins = Just ([origin], True)
     , corsRequestHeaders = "Authentication":accHeaders
     , corsExposedHeaders = Just [
-          "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
-        , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
-        ]
+        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
+      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
+      ]
     }
   Nothing -> Nothing
   where
     headers = requestHeaders req
     accHeaders = case lookup "access-control-request-headers" headers of
-      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
+      Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs
       Nothing -> []
+
+-- | User friendly version number
+prettyVersion :: Text
+prettyVersion = intercalate "." $ map show $ versionBranch version
+
+-- | Function to read and parse options from the command line
+readOptions :: IO AppConfig
+readOptions = do
+  -- First read the config file path from command line
+  cfgPath <- customExecParser parserPrefs opts
+  -- Now read the actual config file
+  conf <- catch
+    (C.readConfig =<< C.load [C.Required cfgPath])
+    configNotfoundHint
+
+  let (mAppConf, errs) = flip C.runParserA conf $
+        AppConfig <$>
+            C.key "db-uri"
+          <*> C.key "db-anon-role"
+          <*> C.key "server-proxy-uri"
+          <*> C.key "db-schema"
+          <*> (fromMaybe "*4" . mfilter (/= "") <$> C.key "server-host")
+          <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port")
+          <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret")
+          <*> (fromMaybe False . join . fmap coerceBool <$> C.key "secret-is-base64")
+          <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool")
+          <*> (join . fmap coerceInt <$> C.key "max-rows")
+          <*> (mfilter (/= "") <$> C.key "pre-request")
+          <*> pure False
+
+  case mAppConf of
+    Nothing -> do
+      forM_ errs $ hPrint stderr
+      exitFailure
+    Just appConf ->
+      return appConf
+
+ where
+  coerceInt :: (Read i, Integral i) => Value -> Maybe i
+  coerceInt (Number x) = rightToMaybe $ floatingOrInteger x
+  coerceInt (String x) = readMaybe $ toS x
+  coerceInt _ = Nothing
+
+  coerceBool ::  Value -> Maybe Bool
+  coerceBool (Bool b) = Just b
+  coerceBool (String x) = readMaybe $ toS x
+  coerceBool _ = Nothing
+
+  opts = info (helper <*> pathParser) $
+           fullDesc
+           <> progDesc (
+               "PostgREST "
+               <> toS prettyVersion
+               <> " / create a REST API to an existing Postgres database"
+             )
+           <> footerDoc (Just $
+               text "Example Config File:"
+               L.<> nest 2 (hardline L.<> exampleCfg)
+             )
+
+  parserPrefs = prefs showHelpOnError
+
+  configNotfoundHint :: IOError -> IO a
+  configNotfoundHint e = do
+    hPutStrLn stderr $
+      "Cannot open config file:\n\t" <> show e
+    exitFailure
+
+  exampleCfg :: Doc
+  exampleCfg = vsep . map (text . toS) . lines $
+    [str|db-uri = "postgres://user:pass@localhost:5432/dbname"
+        |db-schema = "public"
+        |db-anon-role = "postgres"
+        |db-pool = 10
+        |
+        |server-host = "*4"
+        |server-port = 3000
+        |
+        |## base url for swagger output
+        |# server-proxy-uri = ""
+        |
+        |## choose a secret to enable JWT auth
+        |## (use "@filename" to load from separate file)
+        |# jwt-secret = "foo"
+        |# secret-is-base64 = false
+        |
+        |## limit rows in response
+        |# max-rows = 1000
+        |
+        |## stored proc to exec immediately after auth
+        |# pre-request = "stored_proc_name"
+        |]
+
+pathParser :: Parser FilePath
+pathParser =
+  strArgument $
+    metavar "FILENAME" <>
+    help "Path to configuration file"
+
+data PgVersion = PgVersion {
+  pgvNum  :: Int32
+, pgvName :: Text
+}
+
+-- | Tells the minimum PostgreSQL version required by this version of PostgREST
+minimumPgVersion :: PgVersion
+minimumPgVersion = PgVersion 90300 "9.3"

src/PostgREST/DbRequestBuilder.hs

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

src/PostgREST/DbStructure.hs

@@ -0,0 +1,700 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+module PostgREST.DbStructure (
+  getDbStructure
+, accessibleTables
+, schemaDescription
+) where
+
+import qualified Hasql.Decoders                as HD
+import qualified Hasql.Encoders                as HE
+import qualified Hasql.Query                   as H
+
+import           Control.Applicative
+import qualified Data.HashMap.Strict           as M
+import           Data.List                     (elemIndex)
+import           Data.Maybe                    (fromJust)
+import           Data.Text                     (split, strip,
+                                                breakOn, dropAround)
+import qualified Data.Text                     as T
+import qualified Hasql.Session                 as H
+import           PostgREST.Types
+import           Text.InterpolatedString.Perl6 (q)
+
+import           GHC.Exts                      (groupWith)
+import           Protolude
+import           Unsafe (unsafeHead)
+
+getDbStructure :: Schema -> H.Session DbStructure
+getDbStructure schema = do
+  tabs <- H.query () allTables
+  cols <- H.query () $ allColumns tabs
+  syns <- H.query () $ allSynonyms cols
+  rels <- H.query () $ allRelations tabs cols
+  keys <- H.query () $ allPrimaryKeys tabs
+  procs <- H.query schema accessibleProcs
+
+  let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels
+      cols' = addForeignKeys rels' cols
+      keys' = synonymousPrimaryKeys syns keys
+
+  return DbStructure {
+      dbTables = tabs
+    , dbColumns = cols'
+    , dbRelations = rels'
+    , dbPrimaryKeys = keys'
+    , dbProcs = procs
+    }
+
+decodeTables :: HD.Result [Table]
+decodeTables =
+  HD.rowsList tblRow
+ where
+  tblRow = Table <$> HD.value HD.text
+                 <*> HD.value HD.text
+                 <*> HD.nullableValue HD.text
+                 <*> HD.value HD.bool
+
+decodeColumns :: [Table] -> HD.Result [Column]
+decodeColumns tables =
+  mapMaybe (columnFromRow tables) <$> HD.rowsList colRow
+ where
+  colRow =
+    (,,,,,,,,,,,)
+      <$> HD.value HD.text <*> HD.value HD.text
+      <*> HD.value HD.text <*> HD.nullableValue HD.text
+      <*> HD.value HD.int4 <*> HD.value HD.bool
+      <*> HD.value HD.text <*> HD.value HD.bool
+      <*> HD.nullableValue HD.int4
+      <*> HD.nullableValue HD.int4
+      <*> HD.nullableValue HD.text
+      <*> HD.nullableValue HD.text
+
+decodeRelations :: [Table] -> [Column] -> HD.Result [Relation]
+decodeRelations tables cols =
+  mapMaybe (relationFromRow tables cols) <$> HD.rowsList relRow
+ where
+  relRow = (,,,,,)
+    <$> HD.value HD.text
+    <*> HD.value HD.text
+    <*> HD.value (HD.array (HD.arrayDimension replicateM (HD.arrayValue HD.text)))
+    <*> HD.value HD.text
+    <*> HD.value HD.text
+    <*> HD.value (HD.array (HD.arrayDimension replicateM (HD.arrayValue HD.text)))
+
+decodePks :: [Table] -> HD.Result [PrimaryKey]
+decodePks tables =
+  mapMaybe (pkFromRow tables) <$> HD.rowsList pkRow
+ where
+  pkRow = (,,) <$> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text
+
+decodeSynonyms :: [Column] -> HD.Result [(Column,Column)]
+decodeSynonyms cols =
+  mapMaybe (synonymFromRow cols) <$> HD.rowsList synRow
+ where
+  synRow = (,,,,,)
+    <$> HD.value HD.text <*> HD.value HD.text
+    <*> HD.value HD.text <*> HD.value HD.text
+    <*> HD.value HD.text <*> HD.value HD.text
+
+accessibleProcs :: H.Query Schema (M.HashMap Text ProcDescription)
+accessibleProcs =
+  H.statement sql (HE.value HE.text)
+    (M.fromList . map addName <$>
+      HD.rowsList (
+        ProcDescription <$> HD.value HD.text
+                        <*> HD.nullableValue HD.text
+                        <*> (parseArgs <$> HD.value HD.text)
+                        <*> (parseRetType <$>
+                            HD.value HD.text <*>
+                            HD.value HD.text <*>
+                            HD.value HD.bool <*>
+                            HD.value HD.char)
+                        <*> (parseVolatility <$>
+                            HD.value HD.char)
+      )
+    ) True
+ where
+  addName :: ProcDescription -> (Text, ProcDescription)
+  addName pd = (pdName pd, pd)
+
+  parseArgs :: Text -> [PgArg]
+  parseArgs = mapMaybe (parseArg . strip) . split (==',')
+
+  parseArg :: Text -> Maybe PgArg
+  parseArg a =
+    let (body, def) = breakOn " DEFAULT " a
+        (name, typ) = breakOn " " body in
+    if T.null typ
+       then Nothing
+       else Just $
+         PgArg (dropAround (== '"') name) (strip typ) (T.null def)
+
+  parseRetType :: Text -> Text -> Bool -> Char -> RetType
+  parseRetType schema name isSetOf typ
+    | isSetOf   = SetOf pgType
+    | otherwise = Single pgType
+    where
+      qi = QualifiedIdentifier schema name
+      pgType = case typ of
+        'c' -> Composite qi
+        'p' -> if name == "record" -- Only pg pseudo type that is a row type is 'record'
+                 then Composite qi
+                 else Scalar qi
+        _   -> Scalar qi -- 'b'ase, 'd'omain, 'e'num, 'r'ange
+
+  parseVolatility :: Char -> ProcVolatility
+  parseVolatility 'i' = Immutable
+  parseVolatility 's' = Stable
+  parseVolatility 'v' = Volatile
+  parseVolatility _   = Volatile -- should not happen, but be pessimistic
+
+  sql = [q|
+  SELECT p.proname as "proc_name",
+         d.description as "proc_description",
+         pg_get_function_arguments(p.oid) as "args",
+         tn.nspname as "rettype_schema",
+         coalesce(comp.relname, t.typname) as "rettype_name",
+         p.proretset as "rettype_is_setof",
+         t.typtype as "rettype_typ",
+         p.provolatile
+  FROM pg_proc p
+    JOIN pg_namespace pn ON pn.oid = p.pronamespace
+    JOIN pg_type t ON t.oid = p.prorettype
+    JOIN pg_namespace tn ON tn.oid = t.typnamespace
+    LEFT JOIN pg_class comp ON comp.oid = t.typrelid
+    LEFT JOIN pg_catalog.pg_description as d on d.objoid = p.oid
+  WHERE  pn.nspname = $1|]
+
+schemaDescription :: H.Query Schema (Maybe Text)
+schemaDescription =
+    H.statement sql (HE.value HE.text) (HD.singleRow $ HD.nullableValue HD.text) True
+  where
+    sql = [q|
+      select
+        description
+      from
+        pg_catalog.pg_namespace n
+        left join pg_catalog.pg_description d on d.objoid = n.oid
+      where
+        n.nspname = $1 |]
+
+accessibleTables :: H.Query Schema [Table]
+accessibleTables =
+  H.statement sql (HE.value HE.text) decodeTables True
+ where
+  sql = [q|
+    select
+      n.nspname as table_schema,
+      relname as table_name,
+      d.description as table_description,
+      c.relkind = 'r' or (c.relkind IN ('v', 'f')) and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8
+      or (exists (
+         select 1
+         from pg_trigger
+         where pg_trigger.tgrelid = c.oid and (pg_trigger.tgtype::integer & 69) = 69)
+      ) as insertable
+    from
+      pg_class c
+      join pg_namespace n on n.oid = c.relnamespace
+      left join pg_catalog.pg_description as d on d.objoid = c.oid and d.objsubid = 0
+    where
+      c.relkind in ('v', 'r', 'm')
+      and n.nspname = $1
+      and (
+        pg_has_role(c.relowner, 'USAGE'::text)
+        or has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text)
+        or has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text)
+      )
+    order by relname |]
+
+synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]]
+synonymousColumns allSyns cols = synCols'
+  where
+    syns = case headMay cols of
+            Just firstCol -> sort $ filter ((== colTable firstCol) . colTable . fst) allSyns
+            Nothing -> []
+    synCols  = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols
+    synCols' = (filter sameTable . filter matchLength) synCols
+    matchLength cs = length cols == length cs
+    sameTable (c:cs) = all (\cc -> colTable c == colTable cc) (c:cs)
+    sameTable [] = False
+
+addForeignKeys :: [Relation] -> [Column] -> [Column]
+addForeignKeys rels = map addFk
+  where
+    addFk col = col { colFK = fk col }
+    fk col = join $ relToFk col <$> find (lookupFn col) rels
+    lookupFn :: Column -> Relation -> Bool
+    lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child
+    relToFk col Relation{relColumns=cols, relFColumns=colsF} = do
+      pos <- elemIndex col cols
+      colF <- atMay colsF pos
+      return $ ForeignKey colF
+
+addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation]
+addSynonymousRelations _ [] = []
+addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynonymousRelations syns rels
+  where
+    synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs})
+    synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs})
+    synRels cols mapFn = map (\cs -> mapFn (colTable $ unsafeHead cs) cs) $ synonymousColumns syns cols
+
+addParentRelations :: [Relation] -> [Relation]
+addParentRelations [] = []
+addParentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : addParentRelations rels
+
+addManyToManyRelations :: [Relation] -> [Relation]
+addManyToManyRelations rels = rels ++ addMirrorRelation (mapMaybe link2Relation links)
+  where
+    links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels
+    groupFn :: Relation -> Text
+    groupFn Relation{relTable=Table{tableSchema=s, tableName=t}} = s<>"_"<>t
+    -- Reference : https://wiki.haskell.org/99_questions/Solutions/26
+    combinations :: Int -> [a] -> [[a]]
+    combinations 0 _  = [ [] ]
+    combinations n xs = [ y:ys | y:xs' <- tails xs
+                               , ys <- combinations (n-1) xs']
+    addMirrorRelation [] = []
+    addMirrorRelation (rel@(Relation t c ft fc _ lt lc1 lc2):rels') = Relation ft fc t c Many lt lc2 lc1 : rel : addMirrorRelation rels'
+    link2Relation [
+      Relation{relTable=lt, relColumns=lc1, relFTable=t,  relFColumns=c},
+      Relation{             relColumns=lc2, relFTable=ft, relFColumns=fc}
+      ]
+      | lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation t c ft fc Many (Just lt) (Just lc1) (Just lc2)
+      | otherwise = Nothing
+    link2Relation _ = Nothing
+
+raiseRelations :: Schema -> [(Column,Column)] -> [Relation] -> [Relation]
+raiseRelations schema syns = map raiseRel
+  where
+    raiseRel rel
+      | tableSchema table == schema = rel
+      | isJust newCols = rel{relFTable=fromJust newTable,relFColumns=fromJust newCols}
+      | otherwise = rel
+      where
+        cols = relFColumns rel
+        table = relFTable rel
+        newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . unsafeHead) (synonymousColumns syns cols)
+        newTable = (colTable . unsafeHead) <$> newCols
+
+synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey]
+synonymousPrimaryKeys _ [] = []
+synonymousPrimaryKeys syns (key:keys) = key : newKeys ++ synonymousPrimaryKeys syns keys
+  where
+    keySyns = filter ((\c -> colTable c == pkTable key && colName c == pkName key) . fst) syns
+    newKeys = map ((\c -> PrimaryKey{pkTable=colTable c,pkName=colName c}) . snd) keySyns
+
+allTables :: H.Query () [Table]
+allTables =
+  H.statement sql HE.unit decodeTables True
+ where
+  sql = [q|
+    SELECT
+      n.nspname AS table_schema,
+      c.relname AS table_name,
+      NULL AS table_description,
+      c.relkind = 'r' OR (c.relkind IN ('v','f'))
+      AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8
+      OR (EXISTS
+        ( SELECT 1
+          FROM pg_trigger
+          WHERE pg_trigger.tgrelid = c.oid
+          AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable
+    FROM pg_class c
+    JOIN pg_namespace n ON n.oid = c.relnamespace
+    WHERE c.relkind IN ('v','r','m')
+      AND n.nspname NOT IN ('pg_catalog', 'information_schema')
+    GROUP BY table_schema, table_name, insertable
+    ORDER BY table_schema, table_name |]
+
+allColumns :: [Table] -> H.Query () [Column]
+allColumns tabs =
+  H.statement sql HE.unit (decodeColumns tabs) True
+ where
+  sql = [q|
+    SELECT DISTINCT
+        info.table_schema AS schema,
+        info.table_name AS table_name,
+        info.column_name AS name,
+        info.description AS description,
+        info.ordinal_position AS position,
+        info.is_nullable::boolean AS nullable,
+        info.data_type AS col_type,
+        info.is_updatable::boolean AS updatable,
+        info.character_maximum_length AS max_len,
+        info.numeric_precision AS precision,
+        info.column_default AS default_value,
+        array_to_string(enum_info.vals, ',') AS enum
+    FROM (
+        /*
+        -- CTE based on information_schema.columns to remove the owner filter
+        */
+        WITH columns AS (
+            SELECT current_database()::information_schema.sql_identifier AS table_catalog,
+                nc.nspname::information_schema.sql_identifier AS table_schema,
+                c.relname::information_schema.sql_identifier AS table_name,
+                a.attname::information_schema.sql_identifier AS column_name,
+                d.description::information_schema.sql_identifier AS description,
+                a.attnum::information_schema.cardinal_number AS ordinal_position,
+                pg_get_expr(ad.adbin, ad.adrelid)::information_schema.character_data AS column_default,
+                    CASE
+                        WHEN a.attnotnull OR t.typtype = 'd'::"char" AND t.typnotnull THEN 'NO'::text
+                        ELSE 'YES'::text
+                    END::information_schema.yes_or_no AS is_nullable,
+                    CASE
+                        WHEN t.typtype = 'd'::"char" THEN
+                        CASE
+                            WHEN bt.typelem <> 0::oid AND bt.typlen = (-1) THEN 'ARRAY'::text
+                            WHEN nbt.nspname = 'pg_catalog'::name THEN format_type(t.typbasetype, NULL::integer)
+                            ELSE format_type(a.atttypid, a.atttypmod)
+                        END
+                        ELSE
+                        CASE
+                            WHEN t.typelem <> 0::oid AND t.typlen = (-1) THEN 'ARRAY'::text
+                            WHEN nt.nspname = 'pg_catalog'::name THEN format_type(a.atttypid, NULL::integer)
+                            ELSE format_type(a.atttypid, a.atttypmod)
+                        END
+                    END::information_schema.character_data AS data_type,
+                information_schema._pg_char_max_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_maximum_length,
+                information_schema._pg_char_octet_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_octet_length,
+                information_schema._pg_numeric_precision(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_precision,
+                information_schema._pg_numeric_precision_radix(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_precision_radix,
+                information_schema._pg_numeric_scale(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS numeric_scale,
+                information_schema._pg_datetime_precision(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS datetime_precision,
+                information_schema._pg_interval_type(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.character_data AS interval_type,
+                NULL::integer::information_schema.cardinal_number AS interval_precision,
+                NULL::character varying::information_schema.sql_identifier AS character_set_catalog,
+                NULL::character varying::information_schema.sql_identifier AS character_set_schema,
+                NULL::character varying::information_schema.sql_identifier AS character_set_name,
+                    CASE
+                        WHEN nco.nspname IS NOT NULL THEN current_database()
+                        ELSE NULL::name
+                    END::information_schema.sql_identifier AS collation_catalog,
+                nco.nspname::information_schema.sql_identifier AS collation_schema,
+                co.collname::information_schema.sql_identifier AS collation_name,
+                    CASE
+                        WHEN t.typtype = 'd'::"char" THEN current_database()
+                        ELSE NULL::name
+                    END::information_schema.sql_identifier AS domain_catalog,
+                    CASE
+                        WHEN t.typtype = 'd'::"char" THEN nt.nspname
+                        ELSE NULL::name
+                    END::information_schema.sql_identifier AS domain_schema,
+                    CASE
+                        WHEN t.typtype = 'd'::"char" THEN t.typname
+                        ELSE NULL::name
+                    END::information_schema.sql_identifier AS domain_name,
+                current_database()::information_schema.sql_identifier AS udt_catalog,
+                COALESCE(nbt.nspname, nt.nspname)::information_schema.sql_identifier AS udt_schema,
+                COALESCE(bt.typname, t.typname)::information_schema.sql_identifier AS udt_name,
+                NULL::character varying::information_schema.sql_identifier AS scope_catalog,
+                NULL::character varying::information_schema.sql_identifier AS scope_schema,
+                NULL::character varying::information_schema.sql_identifier AS scope_name,
+                NULL::integer::information_schema.cardinal_number AS maximum_cardinality,
+                a.attnum::information_schema.sql_identifier AS dtd_identifier,
+                'NO'::character varying::information_schema.yes_or_no AS is_self_referencing,
+                'NO'::character varying::information_schema.yes_or_no AS is_identity,
+                NULL::character varying::information_schema.character_data AS identity_generation,
+                NULL::character varying::information_schema.character_data AS identity_start,
+                NULL::character varying::information_schema.character_data AS identity_increment,
+                NULL::character varying::information_schema.character_data AS identity_maximum,
+                NULL::character varying::information_schema.character_data AS identity_minimum,
+                NULL::character varying::information_schema.yes_or_no AS identity_cycle,
+                'NEVER'::character varying::information_schema.character_data AS is_generated,
+                NULL::character varying::information_schema.character_data AS generation_expression,
+                CASE
+                    WHEN c.relkind = 'r'::"char" OR (c.relkind = ANY (ARRAY['v'::"char", 'f'::"char"])) AND pg_column_is_updatable(c.oid::regclass, a.attnum, false) THEN 'YES'::text
+                    ELSE 'NO'::text
+                END::information_schema.yes_or_no AS is_updatable
+            FROM pg_attribute a
+               LEFT JOIN pg_catalog.pg_description AS d ON d.objoid = a.attrelid and d.objsubid = a.attnum
+               LEFT JOIN pg_attrdef ad ON a.attrelid = ad.adrelid AND a.attnum = ad.adnum
+               JOIN (pg_class c
+               JOIN pg_namespace nc ON c.relnamespace = nc.oid) ON a.attrelid = c.oid
+               JOIN (pg_type t
+               JOIN pg_namespace nt ON t.typnamespace = nt.oid) ON a.atttypid = t.oid
+               LEFT JOIN (pg_type bt
+               JOIN pg_namespace nbt ON bt.typnamespace = nbt.oid) ON t.typtype = 'd'::"char" AND t.typbasetype = bt.oid
+               LEFT JOIN (pg_collation co
+               JOIN pg_namespace nco ON co.collnamespace = nco.oid) ON a.attcollation = co.oid AND (nco.nspname <> 'pg_catalog'::name OR co.collname <> 'default'::name)
+            WHERE NOT pg_is_other_temp_schema(nc.oid) AND a.attnum > 0 AND NOT a.attisdropped AND (c.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"]))
+              /*--AND (pg_has_role(c.relowner, 'USAGE'::text) OR has_column_privilege(c.oid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/
+        )
+        SELECT
+            table_schema,
+            table_name,
+            column_name,
+            description,
+            ordinal_position,
+            is_nullable,
+            data_type,
+            is_updatable,
+            character_maximum_length,
+            numeric_precision,
+            column_default,
+            udt_name
+        /*-- FROM information_schema.columns*/
+        FROM columns
+        WHERE table_schema NOT IN ('pg_catalog', 'information_schema')
+    ) AS info
+    LEFT OUTER JOIN (
+        SELECT
+            n.nspname AS s,
+            t.typname AS n,
+            array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals
+        FROM pg_type t
+        JOIN pg_enum e ON t.oid = e.enumtypid
+        JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace
+        GROUP BY s,n
+    ) AS enum_info ON (info.udt_name = enum_info.n)
+    ORDER BY schema, position |]
+
+columnFromRow :: [Table] ->
+                 (Text,        Text,        Text,
+                  Maybe Text,  Int32,       Bool,
+                  Text,        Bool,        Maybe Int32,
+                  Maybe Int32, Maybe Text,  Maybe Text)
+                 -> Maybe Column
+columnFromRow tabs (s, t, n, desc, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table
+  where
+    buildColumn tbl = Column tbl n desc pos nul typ u l p d (parseEnum e) Nothing
+    table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
+    parseEnum :: Maybe Text -> [Text]
+    parseEnum str = fromMaybe [] $ split (==',') <$> str
+
+allRelations :: [Table] -> [Column] -> H.Query () [Relation]
+allRelations tabs cols =
+  H.statement sql HE.unit (decodeRelations tabs cols) True
+ where
+  sql = [q|
+    SELECT ns1.nspname AS table_schema,
+           tab.relname AS table_name,
+           column_info.cols AS columns,
+           ns2.nspname AS foreign_table_schema,
+           other.relname AS foreign_table_name,
+           column_info.refs AS foreign_columns
+    FROM pg_constraint,
+       LATERAL (SELECT array_agg(cols.attname) AS cols,
+                       array_agg(cols.attnum)  AS nums,
+                       array_agg(refs.attname) AS refs
+                  FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,
+                       LATERAL (SELECT * FROM pg_attribute
+                                 WHERE attrelid = conrelid AND attnum = col)
+                            AS cols,
+                       LATERAL (SELECT * FROM pg_attribute
+                                 WHERE attrelid = confrelid AND attnum = ref)
+                            AS refs)
+            AS column_info,
+       LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = connamespace) AS ns1,
+       LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
+       LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other,
+       LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2
+    WHERE confrelid != 0
+    ORDER BY (conrelid, column_info.nums) |]
+
+relationFromRow :: [Table] -> [Column] -> (Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation
+relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) =
+  Relation <$> table <*> cols <*> tableF <*> colsF <*> pure Child <*> pure Nothing <*> pure Nothing <*> pure Nothing
+  where
+    findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs
+    findCol s t c = find (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col == c) allCols
+    table  = findTable rs rt
+    tableF = findTable frs frt
+    cols  = mapM (findCol rs rt) rcs
+    colsF = mapM (findCol frs frt) frcs
+
+allPrimaryKeys :: [Table] -> H.Query () [PrimaryKey]
+allPrimaryKeys tabs =
+  H.statement sql HE.unit (decodePks tabs) True
+ where
+  sql = [q|
+    /*
+    -- CTE to replace information_schema.table_constraints to remove owner limit
+    */
+    WITH tc AS (
+        SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,
+            nc.nspname::information_schema.sql_identifier AS constraint_schema,
+            c.conname::information_schema.sql_identifier AS constraint_name,
+            current_database()::information_schema.sql_identifier AS table_catalog,
+            nr.nspname::information_schema.sql_identifier AS table_schema,
+            r.relname::information_schema.sql_identifier AS table_name,
+                CASE c.contype
+                    WHEN 'c'::"char" THEN 'CHECK'::text
+                    WHEN 'f'::"char" THEN 'FOREIGN KEY'::text
+                    WHEN 'p'::"char" THEN 'PRIMARY KEY'::text
+                    WHEN 'u'::"char" THEN 'UNIQUE'::text
+                    ELSE NULL::text
+                END::information_schema.character_data AS constraint_type,
+                CASE
+                    WHEN c.condeferrable THEN 'YES'::text
+                    ELSE 'NO'::text
+                END::information_schema.yes_or_no AS is_deferrable,
+                CASE
+                    WHEN c.condeferred THEN 'YES'::text
+                    ELSE 'NO'::text
+                END::information_schema.yes_or_no AS initially_deferred
+        FROM pg_namespace nc,
+            pg_namespace nr,
+            pg_constraint c,
+            pg_class r
+        WHERE nc.oid = c.connamespace AND nr.oid = r.relnamespace AND c.conrelid = r.oid AND (c.contype <> ALL (ARRAY['t'::"char", 'x'::"char"])) AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)
+        /*--AND (pg_has_role(r.relowner, 'USAGE'::text) OR has_table_privilege(r.oid, 'INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR has_any_column_privilege(r.oid, 'INSERT, UPDATE, REFERENCES'::text))*/
+        UNION ALL
+        SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,
+            nr.nspname::information_schema.sql_identifier AS constraint_schema,
+            (((((nr.oid::text || '_'::text) || r.oid::text) || '_'::text) || a.attnum::text) || '_not_null'::text)::information_schema.sql_identifier AS constraint_name,
+            current_database()::information_schema.sql_identifier AS table_catalog,
+            nr.nspname::information_schema.sql_identifier AS table_schema,
+            r.relname::information_schema.sql_identifier AS table_name,
+            'CHECK'::character varying::information_schema.character_data AS constraint_type,
+            'NO'::character varying::information_schema.yes_or_no AS is_deferrable,
+            'NO'::character varying::information_schema.yes_or_no AS initially_deferred
+        FROM pg_namespace nr,
+            pg_class r,
+            pg_attribute a
+        WHERE nr.oid = r.relnamespace AND r.oid = a.attrelid AND a.attnotnull AND a.attnum > 0 AND NOT a.attisdropped AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)
+        /*--AND (pg_has_role(r.relowner, 'USAGE'::text) OR has_table_privilege(r.oid, 'INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR has_any_column_privilege(r.oid, 'INSERT, UPDATE, REFERENCES'::text))*/
+    ),
+    /*
+    -- CTE to replace information_schema.key_column_usage to remove owner limit
+    */
+    kc AS (
+        SELECT current_database()::information_schema.sql_identifier AS constraint_catalog,
+            ss.nc_nspname::information_schema.sql_identifier AS constraint_schema,
+            ss.conname::information_schema.sql_identifier AS constraint_name,
+            current_database()::information_schema.sql_identifier AS table_catalog,
+            ss.nr_nspname::information_schema.sql_identifier AS table_schema,
+            ss.relname::information_schema.sql_identifier AS table_name,
+            a.attname::information_schema.sql_identifier AS column_name,
+            (ss.x).n::information_schema.cardinal_number AS ordinal_position,
+                CASE
+                    WHEN ss.contype = 'f'::"char" THEN information_schema._pg_index_position(ss.conindid, ss.confkey[(ss.x).n])
+                    ELSE NULL::integer
+                END::information_schema.cardinal_number AS position_in_unique_constraint
+        FROM pg_attribute a,
+            ( SELECT r.oid AS roid,
+                r.relname,
+                r.relowner,
+                nc.nspname AS nc_nspname,
+                nr.nspname AS nr_nspname,
+                c.oid AS coid,
+                c.conname,
+                c.contype,
+                c.conindid,
+                c.confkey,
+                c.confrelid,
+                information_schema._pg_expandarray(c.conkey) AS x
+               FROM pg_namespace nr,
+                pg_class r,
+                pg_namespace nc,
+                pg_constraint c
+              WHERE nr.oid = r.relnamespace AND r.oid = c.conrelid AND nc.oid = c.connamespace AND (c.contype = ANY (ARRAY['p'::"char", 'u'::"char", 'f'::"char"])) AND r.relkind = 'r'::"char" AND NOT pg_is_other_temp_schema(nr.oid)) ss
+        WHERE ss.roid = a.attrelid AND a.attnum = (ss.x).x AND NOT a.attisdropped
+        /*--AND (pg_has_role(ss.relowner, 'USAGE'::text) OR has_column_privilege(ss.roid, a.attnum, 'SELECT, INSERT, UPDATE, REFERENCES'::text))*/
+    )
+    SELECT
+        kc.table_schema,
+        kc.table_name,
+        kc.column_name
+    FROM
+        /*
+        --information_schema.table_constraints tc,
+        --information_schema.key_column_usage kc
+        */
+        tc, kc
+    WHERE
+        tc.constraint_type = 'PRIMARY KEY' AND
+        kc.table_name = tc.table_name AND
+        kc.table_schema = tc.table_schema AND
+        kc.constraint_name = tc.constraint_name AND
+        kc.table_schema NOT IN ('pg_catalog', 'information_schema') |]
+
+pkFromRow :: [Table] -> (Schema, Text, Text) -> Maybe PrimaryKey
+pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n
+  where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
+
+allSynonyms :: [Column] -> H.Query () [(Column,Column)]
+allSynonyms cols =
+  H.statement sql HE.unit (decodeSynonyms cols) True
+ where
+  -- query explanation at https://gist.github.com/ruslantalpa/2eab8c930a65e8043d8f
+  sql = [q|
+    with view_columns as (
+        select
+            c.oid as view_oid,
+            a.attname::information_schema.sql_identifier as column_name
+        from pg_attribute a
+        join pg_class c on a.attrelid = c.oid
+        join pg_namespace nc on c.relnamespace = nc.oid
+        where
+            not pg_is_other_temp_schema(nc.oid)
+            and a.attnum > 0
+            and not a.attisdropped
+            and (c.relkind = 'v'::"char")
+            and nc.nspname not in ('information_schema', 'pg_catalog')
+    ),
+    view_column_usage as (
+        select distinct
+            v.oid as view_oid,
+            nv.nspname::information_schema.sql_identifier as view_schema,
+            v.relname::information_schema.sql_identifier as view_name,
+            nt.nspname::information_schema.sql_identifier as table_schema,
+            t.relname::information_schema.sql_identifier as table_name,
+            a.attname::information_schema.sql_identifier as column_name,
+            pg_get_viewdef(v.oid)::information_schema.character_data as view_definition
+        from pg_namespace nv
+        join pg_class v on nv.oid = v.relnamespace
+        join pg_depend dv on v.oid = dv.refobjid
+        join pg_depend dt on dv.objid = dt.objid
+        join pg_class t on dt.refobjid = t.oid
+        join pg_namespace nt on t.relnamespace = nt.oid
+        join pg_attribute a on t.oid = a.attrelid and dt.refobjsubid = a.attnum
+
+        where
+            nv.nspname not in ('information_schema', 'pg_catalog')
+            and v.relkind = 'v'::"char"
+            and dv.refclassid = 'pg_class'::regclass::oid
+            and dv.classid = 'pg_rewrite'::regclass::oid
+            and dv.deptype = 'i'::"char"
+            and dv.refobjid <> dt.refobjid
+            and dt.classid = 'pg_rewrite'::regclass::oid
+            and dt.refclassid = 'pg_class'::regclass::oid
+            and (t.relkind = any (array['r'::"char", 'v'::"char", 'f'::"char"]))
+    ),
+    candidates as (
+        select
+            vcu.*,
+            (
+                select case when match is not null then coalesce(match[8], match[7], match[4]) end
+                from regexp_matches(
+                    CONCAT('SELECT ', SPLIT_PART(vcu.view_definition, 'SELECT', 2)),
+                    CONCAT('SELECT.*?((',vcu.table_name,')|(\w+))\.(', vcu.column_name, ')(\s+AS\s+("([^"]+)"|([^, \n\t]+)))?.*?FROM.*?(',vcu.table_schema,'\.|)(\2|',vcu.table_name,'\s+(as\s)?\3)'),
+                    'nsi'
+                ) match
+            ) as view_column_name
+        from view_column_usage as vcu
+    )
+    select
+        c.table_schema,
+        c.table_name,
+        c.column_name as table_column_name,
+        c.view_schema,
+        c.view_name,
+        c.view_column_name
+    from view_columns as vc, candidates as c
+    where
+        vc.view_oid = c.view_oid
+        and vc.column_name = c.view_column_name
+    order by c.view_schema, c.view_name, c.table_name, c.view_column_name
+    |]
+
+synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column)
+synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
+  where
+    col1 = findCol s1 t1 c1
+    col2 = findCol s2 t2 c2
+    findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols

src/PostgREST/Error.hs

@@ -1,53 +1,151 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
-module PostgREST.Error (PgError, errResponse) where
+module PostgREST.Error (
+  apiRequestError
+, pgError
+, simpleError
+, singularityError
+, binaryFieldError
+, connectionLostError
+, encodeError
+) where
 
-import qualified Hasql as H
-import qualified Hasql.Postgres as P
+import           Protolude
+import           Data.Aeson                ((.=))
+import qualified Data.Aeson                as JSON
+import           Data.Text                 (unwords)
+import qualified Hasql.Pool                as P
+import qualified Hasql.Session             as H
+import           Network.HTTP.Types.Header
 import qualified Network.HTTP.Types.Status as HT
-import qualified Data.Aeson as JSON
-import qualified Data.Text as T
-import Data.Aeson ((.=))
-import Data.String.Conversions (cs)
-import Data.String.Utils(replace)
-import Network.Wai(Response, responseLBS)
-import Network.HTTP.Types.Header
+import           Network.Wai               (Response, responseLBS)
+import           PostgREST.Types
 
-type PgError = H.SessionError P.Postgres
+apiRequestError :: ApiRequestError -> Response
+apiRequestError err =
+  errorResponse status
+    [toHeader CTApplicationJSON] err
+  where
+    status =
+      case err of
+        ActionInappropriate -> HT.status405
+        UnsupportedVerb -> HT.status405
+        InvalidBody _ -> HT.status400
+        ParseRequestError _ _ -> HT.status400
+        NoRelationBetween _ _ -> HT.status400
+        InvalidRange -> HT.status416
+        UnknownRelation -> HT.status404
 
-errResponse :: PgError -> Response
-errResponse e = responseLBS (httpStatus e)
-  [(hContentType, "application/json")] (JSON.encode e)
+simpleError :: HT.Status -> [Header] -> Text -> Response
+simpleError status hdrs message =
+  errorResponse status (toHeader CTApplicationJSON : hdrs) $
+    JSON.object ["message" .= message]
 
-instance JSON.ToJSON PgError where
-  toJSON (H.TxError (P.ErroneousResult c m d h)) = JSON.object [
-    "code" .= (cs c::T.Text),
-    "message" .= (cs m::T.Text),
-    "details" .= (fmap cs d::Maybe T.Text),
-    "hint" .= (fmap cs h::Maybe T.Text)]
-  toJSON (H.TxError (P.NoResult d)) = JSON.object [
-    "message" .= ("No response from server"::T.Text),
-    "details" .= (fmap cs d::Maybe T.Text)]
-  toJSON (H.TxError (P.UnexpectedResult m)) = JSON.object ["message" .= m]
-  toJSON (H.TxError P.NotInTransaction) = JSON.object [
-    "message" .= ("Not in transaction"::T.Text)]
-  toJSON (H.CxError (P.CantConnect d)) = JSON.object [
-    "message" .= ("Can't connect to the database"::T.Text),
-    "details" .= (fmap cs d::Maybe T.Text)]
-  toJSON (H.CxError (P.UnsupportedVersion v)) = JSON.object [
-    "message" .= ("Postgres version "++version++" is not supported") ]
-      where version = replace "0" "." (show v)
-  toJSON (H.ResultError m) = JSON.object ["message" .= m]
+errorResponse :: JSON.ToJSON a => HT.Status -> [Header] -> a -> Response
+errorResponse status hdrs e =
+  responseLBS status hdrs $ encodeError e
 
-httpStatus :: PgError -> HT.Status
-httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =
-  let code = cs codeBS in
-  case code of
+pgError :: Bool -> P.UsageError -> Response
+pgError authed e =
+  let status = httpStatus authed e
+      jsonType = toHeader CTApplicationJSON
+      wwwAuth = ("WWW-Authenticate", "Bearer")
+      hdrs = if status == HT.status401
+                then [jsonType, wwwAuth]
+                else [jsonType] in
+  responseLBS status hdrs (encodeError e)
+
+singularityError :: Integer -> Response
+singularityError numRows =
+  responseLBS HT.status406
+    [toHeader CTSingularJSON]
+    $ toS . formatGeneralError
+      "JSON object requested, multiple (or no) rows returned"
+      $ unwords
+        [ "Results contain", show numRows, "rows,"
+        , toS (toMime CTSingularJSON), "requires 1 row"
+        ]
+  where
+    formatGeneralError :: Text -> Text -> Text
+    formatGeneralError message details = toS . JSON.encode $
+      JSON.object ["message" .= message, "details" .= details]
+
+
+binaryFieldError :: Response
+binaryFieldError =
+  simpleError HT.status406 [] (toS (toMime CTOctetStream) <>
+  " requested but a single column was not selected")
+
+connectionLostError :: Response
+connectionLostError =
+  simpleError HT.status503 [] "Database connection lost, retrying the connection."
+
+encodeError :: JSON.ToJSON a => a -> LByteString
+encodeError = JSON.encode
+
+instance JSON.ToJSON ApiRequestError where
+  toJSON (ParseRequestError message details) = JSON.object [
+    "message" .= message, "details" .= details]
+  toJSON ActionInappropriate = JSON.object [
+    "message" .= ("Bad Request" :: Text)]
+  toJSON (InvalidBody errorMessage) = JSON.object [
+    "message" .= (toS errorMessage :: Text)]
+  toJSON InvalidRange = JSON.object [
+    "message" .= ("HTTP Range error" :: Text)]
+  toJSON UnknownRelation = JSON.object [
+    "message" .= ("Unknown relation" :: Text)]
+  toJSON (NoRelationBetween parent child) = JSON.object [
+    "message" .= ("Could not find foreign keys between these entities, No relation found between " <> parent <> " and " <> child :: Text)]
+  toJSON UnsupportedVerb = JSON.object [
+    "message" .= ("Unsupported HTTP verb" :: Text)]
+
+instance JSON.ToJSON P.UsageError where
+  toJSON (P.ConnectionError e) = JSON.object [
+    "code" .= ("" :: Text),
+    "message" .= ("Database connection error" :: Text),
+    "details" .= (toS $ fromMaybe "" e :: Text)]
+  toJSON (P.SessionError e) = JSON.toJSON e -- H.Error
+
+instance JSON.ToJSON H.Error where
+  toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [
+    "code" .= (toS c::Text),
+    "message" .= (toS m::Text),
+    "details" .= (fmap toS d::Maybe Text),
+    "hint" .= (fmap toS h::Maybe Text)]
+  toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [
+    "message" .= (m::Text)]
+  toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [
+    "message" .= ("Row error: end of input"::Text),
+    "details" .=
+      ("Attempt to parse more columns than there are in the result"::Text),
+    "details" .= (("Row number " <> show i)::Text)]
+  toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [
+    "message" .= ("Row error: unexpected null"::Text),
+    "details" .= ("Attempt to parse a NULL as some value."::Text),
+    "details" .= (("Row number " <> show i)::Text)]
+  toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [
+    "message" .= ("Row error: Wrong value parser used"::Text),
+    "details" .= d,
+    "details" .= (("Row number " <> show i)::Text)]
+  toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [
+    "message" .= ("Unexpected amount of rows"::Text),
+    "details" .= i]
+  toJSON (H.ClientError d) = JSON.object [
+    "message" .= ("Database client error"::Text),
+    "details" .= (fmap toS d::Maybe Text)]
+
+httpStatus :: Bool -> P.UsageError -> HT.Status
+httpStatus _ (P.ConnectionError _) = HT.status503
+httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
+  case toS c of
     '0':'8':_ -> HT.status503 -- pg connection err
     '0':'9':_ -> HT.status500 -- triggered action exception
     '0':'L':_ -> HT.status403 -- invalid grantor
     '0':'P':_ -> HT.status403 -- invalid role specification
+    "23503"   -> HT.status409 -- foreign_key_violation
+    "23505"   -> HT.status409 -- unique_violation
     '2':'5':_ -> HT.status500 -- invalid tx state
     '2':'8':_ -> HT.status403 -- invalid auth specification
     '2':'D':_ -> HT.status500 -- invalid tx termination
@@ -62,10 +160,12 @@ httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =
     '5':'8':_ -> HT.status500 -- system error
     'F':'0':_ -> HT.status500 -- conf file error
     'H':'V':_ -> HT.status500 -- foreign data wrapper error
+    "P0001"   -> HT.status400 -- default code for "raise"
     'P':'0':_ -> HT.status500 -- PL/pgSQL Error
     'X':'X':_ -> HT.status500 -- internal Error
-    "42P01" -> HT.status404 -- undefined table
-    "42501" -> HT.status404 -- insufficient privilege
-    _ -> HT.status400
-httpStatus (H.TxError (P.NoResult _)) = HT.status503
-httpStatus _ = HT.status500
+    "42883"   -> HT.status404 -- undefined function
+    "42P01"   -> HT.status404 -- undefined table
+    "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
+    _         -> HT.status400
+httpStatus _ (P.SessionError (H.ResultError _)) = HT.status500
+httpStatus _ (P.SessionError (H.ClientError _)) = HT.status503

src/PostgREST/Main.hs

@@ -1,71 +0,0 @@
-module Main where
-
-import Paths_postgrest (version)
-
-import PostgREST.App
-import PostgREST.Middleware
-import PostgREST.Error(errResponse)
-
-import Control.Monad (unless)
-import Control.Monad.IO.Class (liftIO)
-import Data.String.Conversions (cs)
-import Network.Wai (strictRequestBody)
-import Network.Wai.Middleware.Cors (cors)
-import Network.Wai.Handler.Warp hiding (Connection)
-import Network.Wai.Middleware.Gzip (gzip, def)
-import Network.Wai.Middleware.Static (staticPolicy, only)
-import Network.Wai.Middleware.RequestLogger (logStdout)
-import Data.List (intercalate)
-import Data.Version (versionBranch)
-import qualified Hasql as H
-import qualified Hasql.Postgres as P
-import Options.Applicative hiding (columns)
-
-import PostgREST.Config (AppConfig(..), argParser, corsPolicy)
-
-main :: IO ()
-main = do
-  let opts = info (helper <*> argParser) $
-                fullDesc
-                <> progDesc (
-                    "PostgREST "
-                    <> prettyVersion
-                    <> " / create a REST API to an existing Postgres database"
-                )
-      parserPrefs = prefs showHelpOnError
-  conf <- customExecParser parserPrefs opts
-  let port = configPort conf
-
-  unless (configSecure conf) $
-    putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
-  unless ("secret" /= configJwtSecret conf) $
-    putStrLn "WARNING, running in insecure mode, JWT secret is the default value"
-  Prelude.putStrLn $ "Listening on port " ++
-    (show $ configPort conf :: String)
-
-  let pgSettings = P.ParamSettings (cs $ configDbHost conf)
-                     (fromIntegral $ configDbPort conf)
-                     (cs $ configDbUser conf)
-                     (cs $ configDbPass conf)
-                     (cs $ configDbName conf)
-      appSettings = setPort port
-                  . setServerName (cs $ "postgrest/" <> prettyVersion)
-                  $ defaultSettings
-      middle = logStdout
-        . (if configSecure conf then redirectInsecure else id)
-        . gzip def . cors corsPolicy
-        . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
-
-  poolSettings <- maybe (fail "Improper session settings") return $
-                H.poolSettings (fromIntegral $ configPool conf) 30
-  pool :: H.Pool P.Postgres
-          <- H.acquirePool pgSettings poolSettings
-
-  runSettings appSettings $ middle $ \req respond -> do
-    body <- strictRequestBody req
-    resOrError <- liftIO $ H.session pool $ H.tx Nothing $
-      authenticated conf (app conf body) req
-    either (respond . errResponse) respond resOrError
-
-  where
-    prettyVersion = intercalate "." $ map show $ versionBranch version

src/PostgREST/Middleware.hs

@@ -1,86 +1,61 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module PostgREST.Middleware where
 
-import Data.Maybe (fromMaybe)
-import Data.Monoid
-import Data.Text
--- import Data.Pool(withResource, Pool)
+import           Crypto.JWT
+import           Data.Aeson                    (Value (..))
+import qualified Data.HashMap.Strict           as M
+import qualified Hasql.Transaction             as H
 
-import qualified Hasql as H
-import qualified Hasql.Postgres as P
-import Data.String.Conversions(cs)
+import           Network.HTTP.Types.Status     (unauthorized401, status500)
+import           Network.Wai                   (Application, Response)
+import           Network.Wai.Middleware.Cors   (cors)
+import           Network.Wai.Middleware.Gzip   (def, gzip)
+import           Network.Wai.Middleware.Static (only, staticPolicy)
 
-import Network.HTTP.Types.Header (hLocation, hAuthorization)
-import Network.HTTP.Types (RequestHeaders)
-import Network.HTTP.Types.Status (status400, status401, status301)
-import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
-                   rawQueryString, isSecure, Request(..), Response)
-import Network.URI (URI(..), parseURI)
+import           PostgREST.ApiRequest          (ApiRequest(..))
+import           PostgREST.Auth                (JWTAttempt(..))
+import           PostgREST.Config              (AppConfig (..), corsPolicy)
+import           PostgREST.Error               (simpleError)
+import           PostgREST.QueryBuilder        (pgFmtLit, unquoted, pgFmtEnvVar)
 
-import PostgREST.Config (AppConfig(..))
-import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, resetRole, setUserId, resetUserId)
-import Codec.Binary.Base64.String (decode)
+import           Protolude                     hiding (concat, null)
 
-import Prelude
+runWithClaims :: AppConfig -> JWTAttempt ->
+                 (ApiRequest -> H.Transaction Response) ->
+                 ApiRequest -> H.Transaction Response
+runWithClaims conf eClaims app req =
+  case eClaims of
+    JWTInvalid JWTExpired -> return $ unauthed "JWT expired"
+    JWTInvalid e -> return $ unauthed $ show e
+    JWTMissingSecret -> return $ simpleError status500 [] "Server lacks JWT secret"
+    JWTClaims claims -> do
+      H.sql $ toS.mconcat $ setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql
+      mapM_ H.sql customReqCheck
+      app req
+      where
+        headersSql = map (pgFmtEnvVar "request.header.") $ iHeaders req
+        cookiesSql = map (pgFmtEnvVar "request.cookie.") $ iCookies req
+        claimsSql = map (pgFmtEnvVar "request.jwt.claim.") [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]
+        setRoleSql = maybeToList $
+          (\r -> "set local role " <> r <> ";") . toS . pgFmtLit . unquoted <$> M.lookup "role" claimsWithRole
+        -- role claim defaults to anon if not specified in jwt
+        claimsWithRole = M.union claims (M.singleton "role" anon)
+        anon = String . toS $ configAnonRole conf
+        customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
+  where
+    unauthed message = simpleError
+      unauthorized401
+      [( "WWW-Authenticate"
+        , "Bearer error=\"invalid_token\", " <>
+          "error_description=" <> show message
+      )]
+      message
 
-authenticated :: forall s. AppConfig ->
-                 (Request -> H.Tx P.Postgres s Response) ->
-                 Request -> H.Tx P.Postgres s Response
-authenticated conf app req = do
-  attempt <- httpRequesterRole (requestHeaders req)
-  case attempt of
-    MalformedAuth ->
-      return $ responseLBS status400 [] "Malformed basic auth header"
-    LoginFailed ->
-      return $ responseLBS status401 [] "Invalid username or password"
-    LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app req
-    NoCredentials         -> if anon /= currentRole then runInRole anon "" else app req
-
- where
-   jwtSecret = cs $ configJwtSecret conf
-   currentRole = cs $ configDbUser conf
-   anon = cs $ configAnonRole conf
-   httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt
-   httpRequesterRole hdrs = do
-    let auth = fromMaybe "" $ lookup hAuthorization hdrs
-    case split (==' ') (cs auth) of
-      ("Basic" : b64 : _) ->
-        case split (==':') (cs . decode . cs $ b64) of
-          (u:p:_) -> signInRole u p
-          _ -> return MalformedAuth
-      ("Bearer" : jwt : _) ->
-        return $ signInWithJWT jwtSecret jwt
-      _ -> return NoCredentials
-
-   runInRole :: Text -> Text -> H.Tx P.Postgres s Response
-   runInRole r uid = do
-     setUserId uid
-     setRole r
-     res <- app req
-     resetRole
-     resetUserId
-     return res
-
-
-redirectInsecure :: Application -> Application
-redirectInsecure app req respond = do
-  let hdrs = requestHeaders req
-      host = lookup "host" hdrs
-      uriM = parseURI . cs =<< mconcat [
-        Just "https://",
-        host,
-        Just $ rawPathInfo req,
-        Just $ rawQueryString req]
-      isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"
-
-  if not (isSecure req || isHerokuSecure)
-    then case uriM of
-              Just uri ->
-                respond $ responseLBS status301 [
-                    (hLocation, cs . show $ uri { uriScheme = "https:" })
-                  ] ""
-              Nothing ->
-                respond $ responseLBS status400 [] "SSL is required"
-    else app req respond
+defaultMiddle :: Application -> Application
+defaultMiddle =
+    gzip def
+  . cors corsPolicy
+  . staticPolicy (only [("favicon.ico", "static/favicon.ico")])

src/PostgREST/OpenAPI.hs

@@ -0,0 +1,360 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module PostgREST.OpenAPI (
+  encodeOpenAPI
+  , isMalformedProxyUri
+  , pickProxy
+  ) where
+
+import           Control.Arrow               ((&&&))
+import           Control.Lens
+import           Data.Aeson                  (decode, encode)
+import           Data.HashMap.Strict.InsOrd  (InsOrdHashMap, fromList)
+import           Data.Maybe                  (fromJust)
+import qualified Data.Set                    as Set
+import           Data.String                 (IsString (..))
+import           Data.Text                   (unpack, pack, init, tail, toLower, intercalate, append, dropWhile, breakOn)
+import           Network.URI                 (parseURI, isAbsoluteURI,
+                                              URI (..), URIAuth (..))
+
+import           Protolude hiding              ((&), Proxy, get, intercalate, dropWhile)
+
+import           Data.Swagger
+
+import           PostgREST.ApiRequest        (ContentType(..))
+import           PostgREST.Config            (prettyVersion)
+import           PostgREST.Types             (Table(..), Column(..), PgArg(..), ForeignKey(..),
+                                              PrimaryKey(..), Proxy(..), ProcDescription(..), toMime)
+
+makeMimeList :: [ContentType] -> MimeList
+makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
+
+toSwaggerType :: Text -> SwaggerType t
+toSwaggerType "text"      = SwaggerString
+toSwaggerType "integer"   = SwaggerInteger
+toSwaggerType "boolean"   = SwaggerBoolean
+toSwaggerType "numeric"   = SwaggerNumber
+toSwaggerType _           = SwaggerString
+
+makeTableDef :: [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)
+makeTableDef pks (t, cs, _) =
+  let tn = tableName t in
+      (tn, (mempty :: Schema)
+        & description .~ tableDescription t
+        & type_ .~ SwaggerObject
+        & properties .~ fromList (map (makeProperty pks) cs))
+
+makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema)
+makeProperty pks c = (colName c, Inline s)
+  where
+    e = if null $ colEnum c then Nothing else decode $ encode $ colEnum c
+    fk ForeignKey{fkCol=Column{colTable=Table{tableName=a}, colName=b}} =
+      intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]
+    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
+      ]
+    d =
+      if length n > 1 then
+        Just $ append (fromMaybe "" ((`append` "\n\n") <$> colDescription c)) (intercalate "\n" n)
+      else
+        colDescription c
+    s =
+      (mempty :: Schema)
+        & default_ .~ (decode . toS =<< colDefault c)
+        & description .~ d
+        & enum_ .~ e
+        & format ?~ colType c
+        & maxLength .~ (fromIntegral <$> colMaxLen c)
+        & type_ .~ toSwaggerType (colType c)
+
+makeProcSchema :: ProcDescription -> Schema
+makeProcSchema pd =
+  (mempty :: Schema)
+  & description .~ pdDescription pd
+  & type_ .~ SwaggerObject
+  & properties .~ fromList (map makeProcProperty (pdArgs pd))
+  & required .~ map pgaName (filter pgaReq (pdArgs pd))
+
+makeProcProperty :: PgArg -> (Text, Referenced Schema)
+makeProcProperty (PgArg n t _) = (n, Inline s)
+  where
+    s = (mempty :: Schema)
+          & type_ .~ toSwaggerType t
+          & format ?~ t
+
+makePreferParam :: [Text] -> Param
+makePreferParam ts =
+  (mempty :: Param)
+  & name        .~ "Prefer"
+  & description ?~ "Preference"
+  & required    ?~ False
+  & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+    & in_ .~ ParamHeader
+    & type_ .~ SwaggerString
+    & enum_ .~ decode (encode ts))
+
+makeProcParam :: ProcDescription -> [Referenced Param]
+makeProcParam pd =
+  [ Inline $ (mempty :: Param)
+    & name     .~ "args"
+    & required ?~ True
+    & schema   .~ (ParamBody $ Inline $ makeProcSchema pd)
+  , Ref $ Reference "preferParams"
+  ]
+
+makeParamDefs :: [(Table, [Column], [Text])] -> [(Text, Param)]
+makeParamDefs ti =
+  [ ("preferParams", makePreferParam ["params=single-object"])
+  , ("preferReturn", makePreferParam ["return=representation", "return=minimal", "return=none"])
+  , ("preferCount", makePreferParam ["count=none"])
+  , ("select", (mempty :: Param)
+      & name        .~ "select"
+      & description ?~ "Filtering Columns"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ .~ SwaggerString))
+  , ("order", (mempty :: Param)
+      & name        .~ "order"
+      & description ?~ "Ordering"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ .~ SwaggerString))
+  , ("range", (mempty :: Param)
+      & name        .~ "Range"
+      & description ?~ "Limiting and Pagination"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamHeader
+        & type_ .~ SwaggerString))
+  , ("rangeUnit", (mempty :: Param)
+      & name        .~ "Range-Unit"
+      & description ?~ "Limiting and Pagination"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamHeader
+        & type_ .~ SwaggerString
+        & default_ .~ decode "\"items\""))
+  , ("offset", (mempty :: Param)
+      & name        .~ "offset"
+      & description ?~ "Limiting and Pagination"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ .~ SwaggerString))
+  , ("limit", (mempty :: Param)
+      & name        .~ "limit"
+      & description ?~ "Limiting and Pagination"
+      & required    ?~ False
+      & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+        & in_ .~ ParamQuery
+        & type_ .~ SwaggerString))
+  ]
+  <> concat [ makeObjectBody (tableName t) : makeRowFilters (tableName t) cs
+            | (t, cs, _) <- ti
+            ]
+
+makeObjectBody :: Text -> (Text, Param)
+makeObjectBody tn =
+  ("body." <> tn, (mempty :: Param)
+     & name .~ tn
+     & description ?~ tn
+     & required ?~ False
+     & schema .~ ParamBody (Ref (Reference tn)))
+
+makeRowFilter :: Text -> Column -> (Text, Param)
+makeRowFilter tn c =
+  (intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)
+    & name .~ colName c
+    & description .~ colDescription c
+    & required ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamQuery
+      & type_ .~ SwaggerString
+      & format ?~ colType c))
+
+makeRowFilters :: Text -> [Column] -> [(Text, Param)]
+makeRowFilters tn = map (makeRowFilter tn)
+
+makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
+makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
+  where
+    -- Use first line of table description as summary; rest as description (if present)
+    -- We strip leading newlines from description so that users can include a blank line between summary and description
+    (tSum, tDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $
+                    breakOn "\n" <$> tableDescription t
+    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"])
+      & at 206 ?~ "Partial Content"
+      & at 200 ?~ Inline ((mempty :: Response)
+        & description .~ "OK"
+        & schema ?~ (Ref $ Reference $ tableName t)
+        )
+    postOp = tOp
+      & parameters .~ map ref ["body." <> tn, "preferReturn"]
+      & at 201 ?~ "Created"
+    patchOp = tOp
+      & parameters .~ map ref (rs <> ["body." <> tn, "preferReturn"])
+      & at 204 ?~ "No Content"
+    deletOp = tOp
+      & parameters .~ map 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 ]
+    ref = Ref . Reference
+
+makeProcPathItem :: ProcDescription -> (FilePath, PathItem)
+makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
+  where
+    postOp = (mempty :: Operation)
+      & description .~ pdDescription pd
+      & parameters .~ makeProcParam pd
+      & tags .~ Set.fromList ["(rpc) " <> pdName pd]
+      & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON]
+      & at 200 ?~ "OK"
+    pe = (mempty :: PathItem) & post ?~ postOp
+
+makeRootPathItem :: (FilePath, PathItem)
+makeRootPathItem = ("/", p)
+  where
+    getOp = (mempty :: Operation)
+      & tags .~ Set.fromList ["Introspection"]
+      & summary ?~ "OpenAPI description (this document)"
+      & produces ?~ makeMimeList [CTOpenAPI, CTApplicationJSON]
+      & at 200 ?~ "OK"
+    pr = (mempty :: PathItem) & get ?~ getOp
+    p = pr
+
+makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
+makePathItems pds ti = fromList $ makeRootPathItem :
+  map makePathItem ti ++ map makeProcPathItem pds
+
+escapeHostName :: Text -> Text
+escapeHostName "*"  = "0.0.0.0"
+escapeHostName "*4" = "0.0.0.0"
+escapeHostName "!4" = "0.0.0.0"
+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 pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
+  & basePath ?~ unpack b
+  & schemes ?~ [s']
+  & info .~ ((mempty :: Info)
+      & version .~ prettyVersion
+      & title .~ "PostgREST API"
+      & description ?~ d)
+  & externalDocs ?~ ((mempty :: ExternalDocs)
+    & description ?~ "PostgREST Documentation"
+    & url .~ URL "https://postgrest.com/en/latest/api.html")
+  & host .~ h'
+  & definitions .~ fromList (map (makeTableDef 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))
+      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
+  | otherwise = Just Proxy {
+    proxyScheme = scheme
+  , proxyHost = host'
+  , proxyPort = port''
+  , proxyPath = path'
+  }
+ where
+   uri = toURI $ fromJust proxy
+   scheme = init $ toLower $ pack $ uriScheme uri
+   path URI {uriPath = ""} =  "/"
+   path URI {uriPath = p} = p
+   path' = pack $ path uri
+   authority = fromJust $ uriAuthority uri
+   host' = pack $ uriRegName authority
+   port' = uriPort authority
+   readPort = fromMaybe 80 . readMaybe
+   port'' :: Integer
+   port'' = case (port', scheme) of
+             ("", "http") -> 80
+             ("", "https") -> 443
+             _ -> readPort $ unpack $ tail $ pack port'
+
+isUriValid:: URI -> Bool
+isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]
+
+fAnd :: [a -> Bool] -> a -> Bool
+fAnd fs x = all ($x) fs
+
+isSchemeValid :: URI -> Bool
+isSchemeValid URI {uriScheme = s}
+  | toLower (pack s) == "https:" = True
+  | toLower (pack s) == "http:" = True
+  | otherwise = False
+
+isQueryValid :: URI -> Bool
+isQueryValid URI {uriQuery = ""} = True
+isQueryValid _ = False
+
+isAuthorityValid :: URI -> Bool
+isAuthorityValid URI {uriAuthority = a}
+  | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a
+  | otherwise = False
+
+isUserInfoValid :: URIAuth -> Bool
+isUserInfoValid URIAuth {uriUserInfo = ""} = True
+isUserInfoValid _ = False
+
+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/Parsers.hs

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

src/PostgREST/PgQuery.hs

@@ -1,292 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module PostgREST.PgQuery where
-
-import PostgREST.RangeQuery
-
-import qualified Hasql as H
-import qualified Hasql.Postgres as P
-import qualified Hasql.Backend as B
-
-import qualified Data.Text as T
-import Text.Regex.TDFA ( (=~) )
-import Text.Regex.TDFA.Text ()
-import qualified Network.HTTP.Types.URI as Net
-import qualified Data.ByteString.Char8 as BS
-import Data.Monoid
-import Data.Vector (empty)
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Functor
-import Control.Monad (join)
-import Data.String.Conversions (cs)
-import qualified Data.Aeson as JSON
-import qualified Data.List as L
-import qualified Data.Vector as V
-import Data.Scientific (isInteger, formatScientific, FPFormat(..))
-
-import Prelude
-
-type PStmt = H.Stmt P.Postgres
-instance Monoid PStmt where
-  mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =
-    B.Stmt (query <> query') (params <> params') (prep && prep')
-  mempty = B.Stmt "" empty True
-type StatementT = PStmt -> PStmt
-
-data QualifiedTable = QualifiedTable {
-  qtSchema :: T.Text
-, qtName   :: T.Text
-} deriving (Show)
-
-data OrderTerm = OrderTerm {
-  otTerm :: T.Text
-, otDirection :: BS.ByteString
-, otNullOrder :: Maybe BS.ByteString
-}
-
-limitT :: Maybe NonnegRange -> StatementT
-limitT r q =
-  q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
-  where
-    limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
-    offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
-
-whereT :: Net.Query -> StatementT
-whereT params q =
- if L.null cols
-   then q
-   else q <> B.Stmt " where " empty True <> conjunction
- where
-   cols = [ col | col <- params, fst col `notElem` ["order"] ]
-   conjunction = mconcat $ L.intersperse andq (map wherePred cols)
-
-withT :: PStmt -> T.Text -> StatementT
-withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
-  B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq <> " from " <> v)
-    (ep <> wp)
-    (epre && wpre)
-
-orderT :: [OrderTerm] -> StatementT
-orderT ts q =
-  if L.null ts
-    then q
-    else q <> B.Stmt " order by " empty True <> clause
-  where
-   clause = mconcat $ L.intersperse commaq (map queryTerm ts)
-   queryTerm :: OrderTerm -> PStmt
-   queryTerm t = B.Stmt
-                   (" " <> cs (pgFmtIdent $ otTerm t) <> " "
-                        <> cs (otDirection t)         <> " "
-                        <> maybe "" cs (otNullOrder t) <> " ")
-                   empty True
-
-parentheticT :: StatementT
-parentheticT s =
-  s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }
-
-iffNotT :: PStmt -> StatementT
-iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
-  B.Stmt
-    ("WITH aaa AS (" <> aq <> " returning *) " <>
-      bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
-    (ap <> bp)
-    (apre && bpre)
-
-countT :: StatementT
-countT s =
-  s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" }
-
-countRows :: QualifiedTable -> PStmt
-countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True
-
-asJsonWithCount :: StatementT
-asJsonWithCount s = s { B.stmtTemplate =
-     "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("
-  <> B.stmtTemplate s <> ") t" }
-
-asJsonRow :: StatementT
-asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
-
-selectStar :: QualifiedTable -> PStmt
-selectStar t = B.Stmt ("select * from " <> fromQt t) empty True
-
-returningStarT :: StatementT
-returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
-
-deleteFrom :: QualifiedTable -> PStmt
-deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True
-
-insertInto :: QualifiedTable
-              -> V.Vector T.Text
-              -> V.Vector (V.Vector JSON.Value)
-              -> PStmt
-insertInto t cols vals
-  | V.null cols = B.Stmt ("insert into " <> fromQt t <> " default values returning *") empty True
-  | otherwise   = B.Stmt
-    ("insert into " <> fromQt t <> " (" <>
-      T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <>
-      ") values "
-      <> T.intercalate ", "
-        (V.toList $ V.map (\v -> "("
-            <> T.intercalate ", " (V.toList $ V.map insertableValue v)
-            <> ")"
-          ) vals
-        )
-      <> " returning row_to_json(" <> fromQt t <> ".*)")
-    empty True
-
-insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
-insertSelect t [] _ = B.Stmt
-  ("insert into " <> fromQt t <> " default values returning *") empty True
-insertSelect t cols vals = B.Stmt
-  ("insert into " <> fromQt t <> " ("
-    <> T.intercalate ", " (map pgFmtIdent cols)
-    <> ") select "
-    <> T.intercalate ", " (map insertableValue vals))
-  empty True
-
-update :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
-update t cols vals = B.Stmt
-  ("update " <> fromQt t <> " set ("
-    <> T.intercalate ", " (map pgFmtIdent cols)
-    <> ") = ("
-    <> T.intercalate ", " (map insertableValue vals)
-    <> ")")
-  empty True
-
-wherePred :: Net.QueryItem -> PStmt
-wherePred (col, predicate) =
-  B.Stmt (" " <> pgFmtJsonbPath (cs col) <> " " <> op <> " " <>
-      if opCode `elem` ["is","isnot"] then whiteList value
-                                 else cs sqlValue)
-      empty True
-
-  where
-    opCode:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
-    value = T.intercalate "." rest
-    whiteList val = fromMaybe (cs (pgFmtLit val) <> "::unknown ")
-                              (L.find ((==) . T.toLower $ val)
-                                      ["null","true","false"])
-    star c = if c == '*' then '%' else c
-    unknownLiteral = (<> "::unknown ") . pgFmtLit
-
-    sqlValue = case opCode of
-            "like" -> unknownLiteral $ T.map star value
-            "ilike" -> unknownLiteral $ T.map star value
-            "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
-            "@@" -> "to_tsquery(" <> unknownLiteral value <> ") "
-            _    -> unknownLiteral value
-
-    op = case opCode of
-         "eq"  -> "="
-         "gt"  -> ">"
-         "lt"  -> "<"
-         "gte" -> ">="
-         "lte" -> "<="
-         "neq" -> "<>"
-         "like"-> "like"
-         "ilike"-> "ilike"
-         "in"  -> "in"
-         "is"    -> "is"
-         "isnot" -> "is not"
-         "@@" -> "@@"
-         _     -> "="
-
-orderParse :: Net.Query -> [OrderTerm]
-orderParse q =
-  mapMaybe orderParseTerm . T.split (==',') $ cs order
-  where
-    order = fromMaybe "" $ join (lookup "order" q)
-
-orderParseTerm :: T.Text -> Maybe OrderTerm
-orderParseTerm s =
-  case T.split (=='.') s of
-       (c:d:nls) ->
-         if d `elem` ["asc", "desc"]
-            then Just $ OrderTerm c
-              ( if d == "asc" then "asc" else "desc" )
-              ( case nls of
-                  [n] -> if | n == "nullsfirst" -> Just "nulls first"
-                            | n == "nullslast"  -> Just "nulls last"
-                            | otherwise -> Nothing
-                  _   -> Nothing
-              )
-            else Nothing
-       _ -> Nothing
-
-commaq :: PStmt
-commaq  = B.Stmt ", " empty True
-
-andq :: PStmt
-andq = B.Stmt " and " empty True
-
-data JsonbPath =
-    ColIdentifier T.Text
-  | KeyIdentifier T.Text
-  | SingleArrow JsonbPath JsonbPath
-  | DoubleArrow JsonbPath JsonbPath
-  deriving (Show)
-
-parseJsonbPath :: T.Text -> Maybe JsonbPath
-parseJsonbPath p =
-  case T.splitOn "->>" p of
-    [a,b] ->
-      let i:is = T.splitOn "->" a in
-      Just $ DoubleArrow
-        (foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is))
-        (KeyIdentifier b)
-    _ -> Nothing
-
-pgFmtJsonbPath :: T.Text -> T.Text
-pgFmtJsonbPath p =
-  pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)
-  where
-    pgFmtJsonbPath' (ColIdentifier i) = pgFmtIdent i
-    pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i
-    pgFmtJsonbPath' (SingleArrow a b) =
-      pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b
-    pgFmtJsonbPath' (DoubleArrow a b) =
-      pgFmtJsonbPath' a <> "->>" <> pgFmtJsonbPath' b
-
-pgFmtIdent :: T.Text -> T.Text
-pgFmtIdent x =
-  let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in
-  if escaped =~ danger
-    then "\"" <> escaped <> "\""
-    else escaped
-
-  where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: T.Text
-
-pgFmtLit :: T.Text -> T.Text
-pgFmtLit x =
-  let trimmed = trimNullChars x
-      escaped = "'" <> T.replace "'" "''" trimmed <> "'"
-      slashed = T.replace "\\" "\\\\" escaped in
-  cs $ if escaped =~ ("\\\\" :: T.Text)
-    then "E" <> slashed
-    else slashed
-
-trimNullChars :: T.Text -> T.Text
-trimNullChars = T.takeWhile (/= '\x0')
-
-fromQt :: QualifiedTable -> T.Text
-fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
-
-unquoted :: JSON.Value -> T.Text
-unquoted (JSON.String t) = t
-unquoted (JSON.Number n) =
-  cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
-unquoted (JSON.Bool b) = cs . show $ b
-unquoted v = cs $ JSON.encode v
-
-insertableText :: T.Text -> T.Text
-insertableText = (<> "::unknown") . pgFmtLit
-
-insertableValue :: JSON.Value -> T.Text
-insertableValue JSON.Null = "null"
-insertableValue v = insertableText $ unquoted v
-
-paramFilter :: JSON.Value -> T.Text
-paramFilter JSON.Null = "is.null"
-paramFilter v = "eq." <> unquoted v

src/PostgREST/PgStructure.hs

@@ -1,175 +0,0 @@
-{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances,
-             MultiParamTypeClasses, ScopedTypeVariables,
-             FlexibleContexts #-}
-module PostgREST.PgStructure where
-
-import PostgREST.PgQuery (QualifiedTable(..))
-import Data.Text hiding (foldl, map, zipWith, concat)
-import Data.Aeson
-import Data.Functor.Identity
-import Data.String.Conversions (cs)
-import Data.Maybe (fromMaybe)
-import Control.Applicative
-
-import qualified Data.Map as Map
-
-import qualified Hasql as H
-import qualified Hasql.Postgres as P
-
-import Prelude
-
-foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)
-foreignKeys table = do
-  r <- H.listEx $ [H.stmt|
-      select kcu.column_name, ccu.table_name AS foreign_table_name,
-        ccu.column_name AS foreign_column_name
-      from information_schema.table_constraints AS tc
-        join information_schema.key_column_usage AS kcu
-          on tc.constraint_name = kcu.constraint_name
-        join information_schema.constraint_column_usage AS ccu
-          on ccu.constraint_name = tc.constraint_name
-      where constraint_type = 'FOREIGN KEY'
-        and tc.table_name=? and tc.table_schema = ?
-        order by kcu.column_name
-    |] (qtName table) (qtSchema table)
-
-  return $ foldl addKey Map.empty r
-  where
-    addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey
-    addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m
-
-
-tables :: Text -> H.Tx P.Postgres s [Table]
-tables schema = do
-  rows <- H.listEx $
-    [H.stmt|
-      select table_schema, table_name,
-             is_insertable_into
-        from information_schema.tables
-       where table_schema = ?
-       order by table_name
-    |] schema
-  return $ map tableFromRow rows
-
-
-columns :: QualifiedTable -> H.Tx P.Postgres s [Column]
-columns table = do
-  cols <- H.listEx $ [H.stmt|
-      select info.table_schema as schema, info.table_name as table_name,
-             info.column_name as name, info.ordinal_position as position,
-             info.is_nullable as nullable, info.data_type as col_type,
-             info.is_updatable as updatable,
-             info.character_maximum_length as max_len,
-             info.numeric_precision as precision,
-             info.column_default as default_value,
-             array_to_string(enum_info.vals, ',') as enum
-         from (
-           select table_schema, table_name, column_name, ordinal_position,
-                  is_nullable, data_type, is_updatable,
-                  character_maximum_length, numeric_precision,
-                  column_default, udt_name
-             from information_schema.columns
-            where table_schema = ? and table_name = ?
-         ) as info
-         left outer join (
-           select n.nspname as s,
-                  t.typname as n,
-                  array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals
-           from pg_type t
-              join pg_enum e on t.oid = e.enumtypid
-              join pg_catalog.pg_namespace n ON n.oid = t.typnamespace
-           group by s, n
-         ) as enum_info
-         on (info.udt_name = enum_info.n)
-      order by position |]
-    (qtSchema table) (qtName table)
-
-  fks <- foreignKeys table
-  return $ map (addFK fks . columnFromRow) cols
-
-  where
-    addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks }
-
-
-primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text]
-primaryKeyColumns table = do
-  r <- H.listEx $ [H.stmt|
-    select kc.column_name
-      from
-        information_schema.table_constraints tc,
-        information_schema.key_column_usage kc
-    where
-      tc.constraint_type = 'PRIMARY KEY'
-      and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema
-      and kc.constraint_name = tc.constraint_name
-      and kc.table_schema = ?
-      and kc.table_name  = ? |] (qtSchema table) (qtName table)
-  return $ map runIdentity r
-
-
-toBool :: Text -> Bool
-toBool = (== "YES")
-
-data Table = Table {
-  tableSchema :: Text
-, tableName :: Text
-, tableInsertable :: Bool
-} deriving (Show)
-
-data ForeignKey = ForeignKey {
-  fkTable::Text, fkCol::Text
-} deriving (Eq, Show)
-
-data Column = Column {
-  colSchema :: Text
-, colTable :: Text
-, colName :: Text
-, colPosition :: Int
-, colNullable :: Bool
-, colType :: Text
-, colUpdatable :: Bool
-, colMaxLen :: Maybe Int
-, colPrecision :: Maybe Int
-, colDefault :: Maybe Text
-, colEnum :: [Text]
-, colFK :: Maybe ForeignKey
-} deriving (Show)
-
-tableFromRow :: (Text, Text, Text) -> Table
-tableFromRow (s, n, i) = Table s n (toBool i)
-
-columnFromRow :: (Text,       Text,      Text,
-                  Int,        Text,      Text,
-                  Text,       Maybe Int, Maybe Int,
-                  Maybe Text, Maybe Text)
-              -> Column
-columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
-  Column s t n pos (toBool nul) typ (toBool u) l p d (parseEnum e) Nothing
-
-  where
-    parseEnum :: Maybe Text -> [Text]
-    parseEnum str = fromMaybe [] $ split (==',') <$> str
-
-
-instance ToJSON Column where
-  toJSON c = object [
-      "schema"    .= colSchema c
-    , "name"      .= colName c
-    , "position"  .= colPosition c
-    , "nullable"  .= colNullable c
-    , "type"      .= colType c
-    , "updatable" .= colUpdatable c
-    , "maxLen"    .= colMaxLen c
-    , "precision" .= colPrecision c
-    , "references".= colFK c
-    , "default"   .= colDefault c
-    , "enum"      .= colEnum c ]
-
-instance ToJSON ForeignKey where
-  toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
-
-instance ToJSON Table where
-  toJSON v = object [
-      "schema"     .= tableSchema v
-    , "name"       .= tableName v
-    , "insertable" .= tableInsertable v ]

src/PostgREST/QueryBuilder.hs

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

src/PostgREST/RangeQuery.hs

@@ -3,58 +3,69 @@ module PostgREST.RangeQuery (
 , rangeRequested
 , rangeLimit
 , rangeOffset
+, restrictRange
+, rangeGeq
+, allRange
 , NonnegRange
 ) where
 
-import Control.Applicative
-import Network.HTTP.Types.Header
 
-import qualified Data.ByteString.Char8 as BS
+import           Control.Applicative
+import           Network.HTTP.Types.Header
 
-import Data.Ranged.Boundaries
-import Data.Ranged.Ranges
+import qualified Data.ByteString.Char8     as BS
+import           Data.Ranged.Boundaries
+import           Data.Ranged.Ranges
 
-import Data.String.Conversions (cs)
-import Text.Regex.TDFA ((=~))
-import Text.Read (readMaybe)
+import           Text.Regex.TDFA           ((=~))
 
-import Data.Maybe (fromMaybe, listToMaybe)
+import Data.List (lookup)
 
-import Prelude
+import           Protolude
 
-type NonnegRange = Range Int
+type NonnegRange = Range Integer
 
-rangeParse :: BS.ByteString -> Maybe NonnegRange
+rangeParse :: BS.ByteString -> NonnegRange
 rangeParse range = do
   let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString
 
-  parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]])
+  case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of
+    Just parsedRange ->
+      let [_, mLower, mUpper] = readMaybe . toS <$> parsedRange
+          lower         = fromMaybe emptyRange   (rangeGeq <$> mLower)
+          upper         = fromMaybe allRange (rangeLeq <$> mUpper) in
+      rangeIntersection lower upper
+    Nothing -> allRange
 
-  let [_, from, to] = readMaybe . cs <$> parsedRange
-  let lower = fromMaybe emptyRange   (rangeGeq <$> from)
-  let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to)
+rangeRequested :: RequestHeaders -> NonnegRange
+rangeRequested headers = fromMaybe allRange $
+  rangeParse <$> lookup hRange headers
 
-  return $ rangeIntersection lower upper
+restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange
+restrictRange Nothing r = r
+restrictRange (Just limit) r =
+   rangeIntersection r $
+     Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)
 
-rangeRequested :: RequestHeaders -> Maybe NonnegRange
-rangeRequested = (rangeParse =<<) . lookup hRange
-
-rangeLimit :: NonnegRange -> Maybe Int
+rangeLimit :: NonnegRange -> Maybe Integer
 rangeLimit range =
-  case [rangeLower range, rangeUpper range]
-    of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)
-       _ -> Nothing
+  case [rangeLower range, rangeUpper range] of
+    [BoundaryBelow lower, BoundaryAbove upper] -> Just (1 + upper - lower)
+    _ -> Nothing
 
-rangeOffset :: NonnegRange -> Int
+rangeOffset :: NonnegRange -> Integer
 rangeOffset range =
-  case rangeLower range
-    of BoundaryBelow from -> from
-       _ -> error "range without lower bound" -- should never happen
+  case rangeLower range of
+    BoundaryBelow lower -> lower
+    _ -> panic "range without lower bound" -- should never happen
 
-rangeGeq :: Int -> NonnegRange
+rangeGeq :: Integer -> NonnegRange
 rangeGeq n =
   Range (BoundaryBelow n) BoundaryAboveAll
 
-rangeLeq :: Int -> NonnegRange
+allRange :: NonnegRange
+allRange = rangeGeq 0
+
+rangeLeq :: Integer -> NonnegRange
 rangeLeq n =
   Range BoundaryBelowAll (BoundaryAbove n)

src/PostgREST/Types.hs

@@ -0,0 +1,239 @@
+{-# LANGUAGE DuplicateRecordFields    #-}
+module PostgREST.Types where
+import           Protolude
+import qualified GHC.Show
+import           Data.Aeson
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.HashMap.Strict  as M
+import           Data.Tree
+import qualified Data.Vector          as V
+import           PostgREST.RangeQuery (NonnegRange)
+import           Network.HTTP.Types.Header (hContentType, Header)
+
+-- | Enumeration of currently supported response content types
+data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
+                 | CTSingularJSON | CTOctetStream
+                 | CTAny | CTOther ByteString deriving Eq
+
+data ApiRequestError = ActionInappropriate
+                     | InvalidBody ByteString
+                     | InvalidRange
+                     | ParseRequestError Text Text
+                     | UnknownRelation
+                     | NoRelationBetween Text Text
+                     | UnsupportedVerb
+                     deriving (Show, Eq)
+
+data DbStructure = DbStructure {
+  dbTables      :: [Table]
+, dbColumns     :: [Column]
+, dbRelations   :: [Relation]
+, dbPrimaryKeys :: [PrimaryKey]
+, dbProcs       :: M.HashMap Text ProcDescription
+} deriving (Show, Eq)
+
+data PgArg = PgArg {
+  pgaName :: Text
+, pgaType :: Text
+, pgaReq  :: Bool
+} deriving (Show, Eq)
+
+data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show)
+
+data RetType = Single PgType | SetOf PgType deriving (Eq, Show)
+
+data ProcVolatility = Volatile | Stable | Immutable
+  deriving (Eq, Show)
+
+data ProcDescription = ProcDescription {
+  pdName        :: Text
+, pdDescription :: Maybe Text
+, pdArgs        :: [PgArg]
+, pdReturnType  :: RetType
+, pdVolatility  :: ProcVolatility
+} deriving (Show, Eq)
+
+type Schema = Text
+type TableName = Text
+type SqlQuery = Text
+type SqlFragment = Text
+type RequestBody = BL.ByteString
+
+data Table = Table {
+  tableSchema      :: Schema
+, tableName        :: TableName
+, tableDescription :: Maybe Text
+, tableInsertable  :: Bool
+} deriving (Show, Ord)
+
+newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord)
+
+data Column =
+    Column {
+      colTable       :: Table
+    , colName        :: Text
+    , 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)
+
+type Synonym = (Column,Column)
+
+data PrimaryKey = PrimaryKey {
+    pkTable :: Table
+  , pkName  :: Text
+} deriving (Show, Eq)
+
+data OrderDirection = OrderAsc | OrderDesc deriving (Eq)
+instance Show OrderDirection where
+  show OrderAsc  = "asc"
+  show OrderDesc = "desc"
+
+data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq)
+instance Show OrderNulls where
+  show OrderNullsFirst = "nulls first"
+  show OrderNullsLast  = "nulls last"
+
+data OrderTerm = OrderTerm {
+  otTerm      :: Field
+, otDirection :: Maybe OrderDirection
+, otNullOrder :: Maybe OrderNulls
+} deriving (Show, Eq)
+
+data QualifiedIdentifier = QualifiedIdentifier {
+  qiSchema :: Schema
+, qiName   :: TableName
+} deriving (Show, Eq)
+
+
+data RelationType = Child | Parent | Many | Root deriving (Show, Eq)
+
+{-|
+  The name 'Relation' here is used with the meaning
+  "What is the relation between the current node and the parent node".
+  It has nothing to do with PostgreSQL referring to tables/views as relations.
+-}
+data Relation = Relation {
+  relTable    :: Table
+, relColumns  :: [Column]
+, relFTable   :: Table
+, relFColumns :: [Column]
+, relType     :: RelationType
+, relLTable   :: Maybe Table
+, relLCols1   :: Maybe [Column]
+, relLCols2   :: Maybe [Column]
+} deriving (Show, Eq)
+
+-- | An array of JSON objects that has been verified to have
+-- the same keys in every object
+newtype PayloadJSON = PayloadJSON (V.Vector Object)
+  deriving (Show, Eq)
+
+unPayloadJSON :: PayloadJSON -> V.Vector Object
+unPayloadJSON (PayloadJSON objs) = objs
+
+data Proxy = Proxy {
+  proxyScheme     :: Text
+, proxyHost       :: Text
+, proxyPort       :: Integer
+, proxyPath       :: Text
+} deriving (Show, Eq)
+
+type Operator = Text
+operators :: M.HashMap Operator SqlFragment
+operators = M.fromList [
+  ("eq", "="),
+  ("gte", ">="),
+  ("gt", ">"),
+  ("lte", "<="),
+  ("lt", "<"),
+  ("neq", "<>"),
+  ("like", "LIKE"),
+  ("ilike", "ILIKE"),
+  ("in", "IN"),
+  ("notin", "NOT IN"),
+  ("isnot", "IS NOT"),
+  ("is", "IS"),
+  ("fts", "@@"),
+  ("cs", "@>"),
+  ("cd", "<@"),
+  ("ov", "&&"),
+  ("sl", "<<"),
+  ("sr", ">>"),
+  ("nxr", "&<"),
+  ("nxl", "&>"),
+  ("adj", "-|-"),
+  -- TODO: these are deprecated and should be removed in v0.5.0.0
+  ("@@", "@@"),
+  ("@>", "@>"),
+  ("<@", "<@")]
+data Operation = Operation{ hasNot::Bool, expr::(Operator, Operand) } deriving (Eq, Show)
+data Operand = VText Text | VTextL [Text] | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
+
+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
+type JsonPath = [Text]
+type Field = (FieldName, Maybe JsonPath)
+type Alias = Text
+type Cast = Text
+type NodeName = Text
+
+{-|
+  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 RelationDetail = Text
+type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe RelationDetail)
+-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]
+type EmbedPath = [Text]
+data Filter = Filter { field::Field, operation::Operation } deriving (Show, Eq)
+
+data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
+data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }
+                 | Delete { in_::TableName, where_::[LogicTree], returning::[FieldName] }
+                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[LogicTree], returning::[FieldName] } deriving (Show, Eq)
+type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail))
+type ReadRequest = Tree ReadNode
+type MutateRequest = MutateQuery
+data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
+
+instance Eq Table where
+  Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
+
+instance Eq Column where
+  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
+
+-- | Convert from ContentType to a full HTTP Header
+toHeader :: ContentType -> Header
+toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
+
+-- | Convert from ContentType to a ByteString representing the mime type
+toMime :: ContentType -> ByteString
+toMime CTApplicationJSON = "application/json"
+toMime CTTextCSV         = "text/csv"
+toMime CTOpenAPI         = "application/openapi+json"
+toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
+toMime CTOctetStream     = "application/octet-stream"
+toMime CTAny             = "*/*"
+toMime (CTOther ct)      = ct

stack.yaml

@@ -0,0 +1,14 @@
+resolver: lts-9.0
+extra-deps:
+  - configurator-ng-0.0.0.1
+  - critbit-0.2.0.0
+  - hasql-pool-0.4.1
+  - hjsonpointer-1.1.1
+  - hjsonschema-1.5.0.1
+  - jose-0.5.0.3
+  - Ranged-sets-0.3.0
+  - protolude-0.2
+ghc-options:
+  postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints
+nix:
+  packages: [postgresql, zlib]

test/Dockerfile.test

@@ -0,0 +1,13 @@
+FROM debian:jessie
+
+ENV PATH /root/.local/bin:$PATH
+
+RUN apt-get update \
+    && apt-get install -y wget libpq-dev pkg-config libpcre3 libpcre3-dev \
+       postgresql-client debconf locales \
+    && apt-get clean && rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/* \
+    && echo 'en_US.UTF-8 UTF-8' > /etc/locale.gen \
+    && locale-gen \
+    && echo 'export LC_ALL=en_US.UTF-8' >> /etc/profile \
+    && wget -qO- https://get.haskellstack.org/ | sh
+

test/Feature/AndOrParamsSpec.hs

@@ -0,0 +1,231 @@
+module Feature.AndOrParamsSpec where
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+import Network.HTTP.Types
+
+import Network.Wai (Application)
+
+import SpecHelper
+import Protolude hiding (get)
+
+
+spec :: SpecWith Application
+spec =
+  describe "and/or params used for complex boolean logic" $ do
+    context "used with GET" $ do
+      context "or param" $ do
+        it "can do simple logic" $
+          get "/entities?or=(id.eq.1,id.eq.2)&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can negate simple logic" $
+          get "/entities?not.or=(id.eq.1,id.eq.2)&select=id" `shouldRespondWith`
+            [json|[{ "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can be combined with traditional filters" $
+          get "/entities?or=(id.eq.1,id.eq.2)&name=eq.entity 1&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
+
+      context "embedded levels" $ do
+        it "can do logic on the second level" $
+          get "/entities?child_entities.or=(id.eq.1,name.eq.child entity 2)&select=id,child_entities{id}" `shouldRespondWith`
+            [json|[
+              {"id": 1, "child_entities": [ { "id": 1 }, { "id": 2 } ] }, { "id": 2, "child_entities": []},
+              {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []}
+            ]|] { matchHeaders = [matchContentTypeJson] }
+        it "can do logic on the third level" $
+          get "/entities?child_entities.grandchild_entities.or=(id.eq.1,id.eq.2)&select=id,child_entities{id,grandchild_entities{id}}" `shouldRespondWith`
+            [json|[
+              {"id": 1, "child_entities": [ { "id": 1, "grandchild_entities": [ { "id": 1 }, { "id": 2 } ]}, { "id": 2, "grandchild_entities": []}]},
+              {"id": 2, "child_entities": [ { "id": 3, "grandchild_entities": []} ]},
+              {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []}
+            ]|] { matchHeaders = [matchContentTypeJson] }
+
+      context "and/or params combined" $ do
+        it "can be nested inside the same expression" $
+          get "/entities?or=(and(name.eq.entity 2,id.eq.2),and(name.eq.entity 1,id.eq.1))&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can be negated while nested" $
+          get "/entities?or=(not.and(name.eq.entity 2,id.eq.2),not.and(name.eq.entity 1,id.eq.1))&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can be combined unnested" $
+          get "/entities?and=(id.eq.1,name.eq.entity 1)&or=(id.eq.1,id.eq.2)&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
+
+      context "operators inside and/or" $ do
+        it "can handle eq and neq" $
+          get "/entities?and=(id.eq.1,id.neq.2))&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can handle lt and gt" $
+          get "/entities?or=(id.lt.2,id.gt.3)&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can handle lte and gte" $
+          get "/entities?or=(id.lte.2,id.gte.3)&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can handle like and ilike" $
+          get "/entities?or=(name.like.*1,name.ilike.*ENTITY 2)&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can handle in" $
+          get "/entities?or=(id.in.(1,2),id.in.(3,4))&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can handle is" $
+          get "/entities?and=(name.is.null,arr.is.null)&select=id" `shouldRespondWith`
+            [json|[{ "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can handle fts" $ do
+          get "/entities?or=(text_search_vector.fts.bar,text_search_vector.fts.baz)&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+          -- TODO: remove in 0.5.0 as deprecated
+          get "/entities?or=(text_search_vector.@@.bar,text_search_vector.@@.baz)&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "can handle cs and cd" $ do
+          get "/entities?or=(arr.cs.{1,2,3},arr.cd.{1})&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 },{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }
+          -- TODO: remove in 0.5.0 as deprecated
+          get "/entities?or=(arr.@>.{1,2,3},arr.<@.{1})&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 },{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }
+
+        it "can handle range operators" $ do
+          get "/ranges?range=eq.[1,3]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=neq.[1,3]&select=id" `shouldRespondWith`
+            [json|[{ "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=lt.[1,10]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=gt.[8,11]&select=id" `shouldRespondWith`
+            [json|[{ "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=lte.[1,3]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=gte.[2,3]&select=id" `shouldRespondWith`
+            [json|[{ "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=cs.[1,2]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=cd.[1,6]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=ov.[0,4]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=sl.[9,10]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=sr.[3,4]&select=id" `shouldRespondWith`
+            [json|[{ "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=nxr.[4,7]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=nxl.[4,7]&select=id" `shouldRespondWith`
+            [json|[{ "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+          get "/ranges?range=adj.(3,10]&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }
+
+        context "operators with not" $ do
+          it "eq, cs, like can be negated" $ do
+            get "/entities?and=(arr.not.cs.{1,2,3},and(id.not.eq.2,name.not.like.*3))&select=id" `shouldRespondWith`
+              [json|[{ "id": 1}]|] { matchHeaders = [matchContentTypeJson] }
+            -- TODO: remove in 0.5.0 as deprecated
+            get "/entities?and=(arr.not.@>.{1,2,3},and(id.not.eq.2,name.not.like.*3))&select=id" `shouldRespondWith`
+              [json|[{ "id": 1}]|] { matchHeaders = [matchContentTypeJson] }
+          it "in, is, fts can be negated" $ do
+            get "/entities?and=(id.not.in.(1,3),and(name.not.is.null,text_search_vector.not.fts.foo))&select=id" `shouldRespondWith`
+              [json|[{ "id": 2}]|] { matchHeaders = [matchContentTypeJson] }
+            -- TODO: remove in 0.5.0 as deprecated
+            get "/entities?and=(id.not.in.(1,3),and(name.not.is.null,text_search_vector.not.@@.foo))&select=id" `shouldRespondWith`
+              [json|[{ "id": 2}]|] { matchHeaders = [matchContentTypeJson] }
+          it "lt, gte, cd can be negated" $ do
+            get "/entities?and=(arr.not.cd.{1},or(id.not.lt.1,id.not.gte.3))&select=id" `shouldRespondWith`
+              [json|[{"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }
+            -- TODO: remove in 0.5.0 as deprecated
+            get "/entities?and=(arr.not.<@.{1},or(id.not.lt.1,id.not.gte.3))&select=id" `shouldRespondWith`
+              [json|[{"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }
+          it "gt, lte, ilike can be negated" $
+            get "/entities?and=(name.not.ilike.*ITY2,or(id.not.gt.4,id.not.lte.1))&select=id" `shouldRespondWith`
+              [json|[{"id": 1}, {"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }
+
+      context "and/or params with quotes" $ do
+        it "eq can have quotes" $
+          get "/grandchild_entities?or=(name.eq.\"(grandchild,entity,4)\",name.eq.\"(grandchild,entity,5)\")&select=id" `shouldRespondWith`
+            [json|[{ "id": 4 }, { "id": 5 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "like and ilike can have quotes" $
+          get "/grandchild_entities?or=(name.like.\"*ity,4*\",name.ilike.\"*ITY,5)\")&select=id" `shouldRespondWith`
+            [json|[{ "id": 4 }, { "id": 5 }]|] { matchHeaders = [matchContentTypeJson] }
+        it "in can have quotes" $
+          get "/grandchild_entities?or=(id.in.(\"1\",\"2\"),id.in.(\"3\",\"4\"))&select=id" `shouldRespondWith`
+            [json|[{ "id": 1 }, { "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }
+
+      it "allows whitespace" $
+        get "/entities?and=( and ( id.in.( 1, 2, 3 ) , id.eq.3 ) , or ( id.eq.2 , id.eq.3 ) )&select=id" `shouldRespondWith`
+          [json|[{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }
+
+      context "multiple and/or conditions" $ do
+        it "cannot have zero conditions" $
+          get "/entities?or=()" `shouldRespondWith`
+            [json|{
+              "details": "unexpected \")\" expecting field name (* or [a..z0..9_]), negation operator (not) or logic operator (and, or)",
+              "message": "\"failed to parse logic tree (())\" (line 1, column 4)"
+            }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }
+        it "can have a single condition" $ do
+          get "/entities?or=(id.eq.1)&select=id" `shouldRespondWith`
+            [json|[{"id":1}]|] { matchHeaders = [matchContentTypeJson] }
+          get "/entities?and=(id.eq.1)&select=id" `shouldRespondWith`
+            [json|[{"id":1}]|] { matchHeaders = [matchContentTypeJson] }
+        it "can have three conditions" $ do
+          get "/grandchild_entities?or=(id.eq.1, id.eq.2, id.eq.3)&select=id" `shouldRespondWith`
+            [json|[{"id":1}, {"id":2}, {"id":3}]|] { matchHeaders = [matchContentTypeJson] }
+          get "/grandchild_entities?and=(id.in.(1,2), id.in.(3,1), id.in.(1,4))&select=id" `shouldRespondWith`
+            [json|[{"id":1}]|] { matchHeaders = [matchContentTypeJson] }
+        it "can have four conditions combining and/or" $ do
+          get "/grandchild_entities?or=( id.eq.1, id.eq.2, and(id.in.(1,3), id.in.(2,3)), id.eq.4 )&select=id" `shouldRespondWith`
+            [json|[{"id":1}, {"id":2}, {"id":3}, {"id":4}]|] { matchHeaders = [matchContentTypeJson] }
+          get "/grandchild_entities?and=( id.eq.1, not.or(id.eq.2, id.eq.3), id.in.(1,4), or(id.eq.1, id.eq.4) )&select=id" `shouldRespondWith`
+            [json|[{"id":1}]|] { matchHeaders = [matchContentTypeJson] }
+
+    context "used with POST" $
+      it "includes related data with filters" $
+        request methodPost "/child_entities?entities.or=(id.eq.2,id.eq.3)&select=id,entities{id}"
+          [("Prefer", "return=representation")]
+          [json|[{"id":4,"name":"entity 4","parent_id":1},
+                 {"id":5,"name":"entity 5","parent_id":2},
+                 {"id":6,"name":"entity 6","parent_id":3}]|] `shouldRespondWith`
+          [json|[{"id": 4, "entities":null}, {"id": 5, "entities": {"id": 2}}, {"id": 6, "entities": {"id": 3}}]|]
+          { matchStatus = 201, matchHeaders = [matchContentTypeJson] }
+
+    context "used with PATCH" $
+      it "succeeds when using and/or params" $
+        request methodPatch "/grandchild_entities?or=(id.eq.1,id.eq.2)&select=id,name"
+          [("Prefer", "return=representation")]
+          [json|{ name : "updated grandchild entity"}|] `shouldRespondWith`
+          [json|[{ "id": 1, "name" : "updated grandchild entity"},{ "id": 2, "name" : "updated grandchild entity"}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+    context "used with DELETE" $
+      it "succeeds when using and/or params" $
+        request methodDelete "/grandchild_entities?or=(id.eq.1,id.eq.2)&select=id,name"
+          [("Prefer", "return=representation")] "" `shouldRespondWith`
+          [json|[{ "id": 1, "name" : "updated grandchild entity"},{ "id": 2, "name" : "updated grandchild entity"}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+    it "can query columns that begin with and/or reserved words" $
+      get "/grandchild_entities?or=(and_starting_col.eq.smth, or_starting_col.eq.smth)" `shouldRespondWith` 200
+
+    it "can query jsonb columns" $
+      get "/grandchild_entities?or=(jsonb_col->a->>b.eq.foo, jsonb_col->>b.eq.bar)&select=id" `shouldRespondWith`
+        [json|[{id: 4}, {id: 5}]|] { matchStatus = 200, matchHeaders = [matchContentTypeJson] }
+
+    it "fails when using IN without () and provides meaningful error message" $
+      get "/entities?or=(id.in.1,2,id.eq.3)" `shouldRespondWith`
+        [json|{
+          "details": "unexpected \"1\" expecting \"(\"",
+          "message": "\"failed to parse logic tree ((id.in.1,2,id.eq.3))\" (line 1, column 10)"
+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }
+
+    it "fails on malformed query params and provides meaningful error message" $ do
+      get "/entities?or=)(" `shouldRespondWith`
+        [json|{
+          "details": "unexpected \")\" expecting \"(\"",
+          "message": "\"failed to parse logic tree ()()\" (line 1, column 3)"
+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }
+      get "/entities?and=(ord(id.eq.1,id.eq.1),id.eq.2)" `shouldRespondWith`
+        [json|{
+          "details": "unexpected \"d\" expecting \"(\"",
+          "message": "\"failed to parse logic tree ((ord(id.eq.1,id.eq.1),id.eq.2))\" (line 1, column 7)"
+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }
+      get "/entities?or=(id.eq.1,not.xor(id.eq.2,id.eq.3))" `shouldRespondWith`
+        [json|{
+          "details": "unexpected \"x\" expecting logic operator (and, or)",
+          "message": "\"failed to parse logic tree ((id.eq.1,not.xor(id.eq.2,id.eq.3)))\" (line 1, column 16)"
+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }

test/Feature/AsymmetricJwtSpec.hs

@@ -0,0 +1,21 @@
+module Feature.AsymmetricJwtSpec where
+
+-- {{{ Imports
+import Test.Hspec
+import Test.Hspec.Wai
+import Network.HTTP.Types
+
+import SpecHelper
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+-- }}}
+
+spec :: SpecWith Application
+spec = describe "server started with asymmetric JWK" $
+
+  -- this test will stop working 9999999999s after the UNIX EPOCH
+  it "succeeds with jwt token signed with an asymmetric key" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJSUzI1NiJ9.eyJyb2xlIjogInBvc3RncmVzdF90ZXN0X2F1dGhvciJ9Cg.CBOYWDvqgAR0YYnZnyDGTQi6AJLc2Pds6_eV3YuBG6I36mj_h05eLhkEKNEDA5ZteMzCiY83P60rC_xtxVd7B6vo3BeF5uoanPS3rrbuHzKPwzsrgrD_CqvEuJ4n7Q9epkQiLsNkcexneENZDRqFjbwZx3DrXiCWwlK3Ytr5NAIGxmy0od-0xNpb2U1nXQyO_Q3mumWFViRt4tmFn_3goDHNKG3Ha_AzImfUNvHnWL78kAc4rbn15vLtWXD8PwtSnZaB4lY4V6RfsaW937srQsmRetvytM1i_bHBnjkjQLAqGbXPyItjtlXPs0uGNBadE8-wgkLtfmSCC4v2DjUthw"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200

test/Feature/AuthSpec.hs

@@ -1,54 +1,144 @@
 module Feature.AuthSpec where
 
 -- {{{ Imports
+import Text.Heredoc
 import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 
 import SpecHelper
+import Network.Wai (Application)
+
+import Protolude hiding (get)
 -- }}}
 
-spec :: Spec
-spec = beforeAll
-  (clearTable "postgrest.auth") . afterAll_ (clearTable "postgrest.auth")
-  $ around withApp
-  $ describe "authorization" $ do
+spec :: SpecWith Application
+spec = describe "authorization" $ do
+  let single = ("Accept","application/vnd.pgrst.object+json")
 
-  it "hides tables that anonymous does not own" $
-    get "/authors_only" `shouldRespondWith` 404
+  it "denies access to tables that anonymous does not own" $
+    get "/authors_only" `shouldRespondWith` [json| {
+          "hint":null,
+          "details":null,
+          "code":"42501",
+          "message":"permission denied for relation authors_only"} |]
+      { matchStatus = 401
+      , matchHeaders = ["WWW-Authenticate" <:> "Bearer"]
+      }
 
-  it "indicates login failure (BasicAuth)" $ do
-    let auth = authHeaderBasic "postgrest_test_author" "fakefake"
+  it "denies access to tables that postgrest_test_author does not own" $
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" in
+    request methodGet "/private_table" [auth] ""
+      `shouldRespondWith` [json| {
+          "hint":null,
+          "details":null,
+          "code":"42501",
+          "message":"permission denied for relation private_table"} |]
+      { matchStatus = 403
+      , matchHeaders = []
+      }
+
+  it "returns jwt functions as jwt tokens" $
+    request methodPost "/rpc/login" [single]
+      [json| { "id": "jdoe", "pass": "1234" } |]
+      `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xuYW1lIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.KO-0PGp_rU-utcDBP6qwdd-Th2Fk-ICVt01I7QtTDWs"} |]
+        { matchStatus = 200
+        , matchHeaders = [matchContentTypeSingular]
+        }
+
+  it "sql functions can encode custom and standard claims" $
+    request methodPost  "/rpc/jwt_test" [single] "{}"
+      `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpc3MiOiJqb2UiLCJzdWIiOiJmdW4iLCJhdWQiOiJldmVyeW9uZSIsImV4cCI6MTMwMDgxOTM4MCwibmJmIjoxMzAwODE5MzgwLCJpYXQiOjEzMDA4MTkzODAsImp0aSI6ImZvbyIsInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdCIsImh0dHA6Ly9wb3N0Z3Jlc3QuY29tL2ZvbyI6dHJ1ZX0.G2REtPnOQMUrVRDA9OnkPJTd8R0tf4wdYOlauh1E2Ek"} |]
+        { matchStatus = 200
+        , matchHeaders = [matchContentTypeSingular]
+        }
+
+  it "sql functions can read custom and standard claims variables" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwfQ.V5fEpXfpb7feqwVqlcDleFdKu86bdwU2cBRT4fcMhXg"
+    request methodPost "/rpc/reveal_big_jwt" [auth] "{}"
+      `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|]
+
+  it "allows users with permissions to see their tables" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200
+
+  it "works with tokens which have extra fields" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIiwia2V5MSI6InZhbHVlMSIsImtleTIiOiJ2YWx1ZTIiLCJrZXkzIjoidmFsdWUzIiwiYSI6MSwiYiI6MiwiYyI6M30.b0eglDKYEmGi-hCvD-ddSqFl7vnDO5qkUaviaHXm3es"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200
+
+  -- this test will stop working 9999999999s after the UNIX EPOCH
+  it "succeeds with an unexpired token" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200
+
+  it "fails with an expired token" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjE0NDY2NzgxNDksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.f8__E6VQwYcDqwHmr9PG03uaZn8Zh1b0vbJ9DYS0AdM"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` [json| {"message":"JWT expired"} |]
+        { matchStatus = 401
+        , matchHeaders = [
+            "WWW-Authenticate" <:>
+            "Bearer error=\"invalid_token\", error_description=\"JWT expired\""
+          ]
+        }
+
+  it "hides tables from users with invalid JWT" $ do
+    let auth = authHeaderJWT "ey9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` [json| {"message":"JWSError (CompactDecodeError \"expected 3 parts, got 2\")"} |]
+        { matchStatus = 401
+        , matchHeaders = [
+            "WWW-Authenticate" <:>
+            "Bearer error=\"invalid_token\", error_description=\"JWSError (CompactDecodeError \\\"expected 3 parts, got 2\\\")\""
+          ]
+        }
+
+  it "should fail when jwt contains no claims" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.CUIP5V9thWsGGFsFyGijSZf1fJMfarLHI9CEJL-TGNk"
     request methodGet "/authors_only" [auth] ""
       `shouldRespondWith` 401
 
-  it "allows users with permissions to see their tables (BasicAuth)" $ do
-    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    let auth = authHeaderBasic "jdoe" "1234"
+  it "hides tables from users with JWT that contain no claims about role" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.RVlZDaSyKbFPvxUf3V_NQXybfRB4dlBIkAUQXVXLUAI"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 401
+
+  it "recovers after 401 error with logged in user" $ do
+    _ <- post "/authors_only" [json| { "owner": "jdoe", "secret": "test content" } |]
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0"
+    _ <- request methodPost "/rpc/problem" [auth] ""
     request methodGet "/authors_only" [auth] ""
       `shouldRespondWith` 200
-      
-  it "allows users to login (JWT)" $ do
-    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    post "/postgrest/tokens" [json| { "id":"jdoe", "pass": "1234" } |] 
-      `shouldRespondWith` ResponseMatcher {
-          matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |]
-        , matchStatus = 201
-        , matchHeaders = ["Content-Type" <:> "application/json"]
-        }
-      
-  it "indicates login failure (JWT)" $ do
-    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    post "/postgrest/tokens" [json| { "id":"jdoe", "pass": "NOPE" } |] 
-      `shouldRespondWith` ResponseMatcher {
-          matchBody = Just [json| {"message":"Failed authentication."} |]
-        , matchStatus = 401
-        , matchHeaders = ["Content-Type" <:> "application/json"]
-        }
 
-  it "allows users with permissions to see their tables (JWT)" $ do
-    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
-    request methodGet "/authors_only" [auth] ""
-      `shouldRespondWith` 200
+  describe "custom pre-request proc acting on id claim" $ do
+
+    it "able to switch to postgrest_test_author role (id=1)" $
+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6MX0.gKw7qI50i9hMrSJW8BlTpdMEVmMXJYxlAqueGqpa_mE" in
+      request methodPost "/rpc/get_current_user" [auth]
+        [json| {} |]
+         `shouldRespondWith` [str|"postgrest_test_author"|]
+          { matchStatus = 200
+          , matchHeaders = []
+          }
+
+    it "able to switch to postgrest_test_default_role (id=2)" $
+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Mn0.nwzjMI0YLvVGJQTeoCPEBsK983b__gxdpLXisBNaO2A" in
+      request methodPost "/rpc/get_current_user" [auth]
+        [json| {} |]
+         `shouldRespondWith` [str|"postgrest_test_default_role"|]
+          { matchStatus = 200
+          , matchHeaders = []
+          }
+
+    it "raises error (id=3)" $
+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6M30.OGxEJAf60NKZiTn-tIb2jy4rqKs_ZruLGWZ40TjrJsM" in
+      request methodPost "/rpc/get_current_user" [auth]
+        [json| {} |]
+         `shouldRespondWith` [str|{"hint":"Please contact administrator","details":null,"code":"P0001","message":"Disabled ID --> 3"}|]
+          { matchStatus = 400
+          , matchHeaders = []
+          }

test/Feature/BinaryJwtSecretSpec.hs

@@ -0,0 +1,21 @@
+module Feature.BinaryJwtSecretSpec where
+
+-- {{{ Imports
+import Test.Hspec
+import Test.Hspec.Wai
+import Network.HTTP.Types
+
+import SpecHelper
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+-- }}}
+
+spec :: SpecWith Application
+spec = describe "server started with binary JWT secret" $
+
+  -- this test will stop working 9999999999s after the UNIX EPOCH
+  it "succeeds with jwt token encoded with a binary secret" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200

test/Feature/ConcurrentSpec.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Feature.ConcurrentSpec where
+
+import Control.Monad (void)
+import Control.Monad.Base
+
+import Control.Monad.Trans.Control
+import Control.Concurrent.Async (mapConcurrently)
+
+import Test.Hspec hiding (pendingWith)
+import Test.Hspec.Wai.Internal
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+import Network.Wai.Test (Session)
+
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec =
+  describe "Queryiny in parallel" $
+    it "should not raise 'transaction in progress' error" $
+      raceTest 10 $
+        get "/fakefake"
+          `shouldRespondWith` [json|
+              { "hint": null,
+                "details":null,
+                "code":"42P01",
+                "message":"relation \"test.fakefake\" does not exist"
+              } |]
+          { matchStatus  = 404
+          , matchHeaders = []
+          }
+
+raceTest :: Int -> WaiExpectation -> WaiExpectation
+raceTest times = liftBaseDiscard go
+ where
+  go test = void $ mapConcurrently (const test) [1..times]
+
+instance MonadBaseControl IO WaiSession where
+  type StM WaiSession a = StM Session a
+  liftBaseWith f = WaiSession $
+    liftBaseWith $ \runInBase ->
+      f $ \k -> runInBase (unWaiSession k)
+  restoreM = WaiSession . restoreM
+  {-# INLINE liftBaseWith #-}
+  {-# INLINE restoreM #-}
+
+instance MonadBase IO WaiSession where
+  liftBase = liftIO

test/Feature/CorsSpec.hs

@@ -9,10 +9,14 @@ import qualified Data.ByteString.Lazy as BL
 import SpecHelper
 
 import Network.HTTP.Types
+import Network.Wai (Application)
+
+import Protolude hiding (get)
 -- }}}
 
-spec :: Spec
-spec = around withApp $ describe "CORS" $ do
+spec :: SpecWith Application
+spec =
+  describe "CORS" $ do
     let preflightHeaders = [
           ("Accept", "*/*"),
           ("Origin", "http://example.com"),
@@ -22,7 +26,7 @@ spec = around withApp $ describe "CORS" $ do
           ("Host", "localhost:3000"),
           ("User-Agent", "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.9; rv:32.0) Gecko/20100101 Firefox/32.0"),
           ("Origin", "http://localhost:8000"),
-          ("Accept", "text/plain, */*; q=0.01"),
+          ("Accept", "text/csv, */*; q=0.01"),
           ("Accept-Language", "en-US,en;q=0.5"),
           ("Accept-Encoding", "gzip, deflate"),
           ("Referer", "http://localhost:8000/"),
@@ -41,7 +45,7 @@ spec = around withApp $ describe "CORS" $ do
             "true"
           respHeaders `shouldSatisfy` matchHeader
             "Access-Control-Allow-Methods"
-            "GET, POST, PUT, PATCH, DELETE, OPTIONS, HEAD"
+            "GET, POST, PATCH, DELETE, OPTIONS, HEAD"
           respHeaders `shouldSatisfy` matchHeader
             "Access-Control-Allow-Headers"
             "Authentication, Foo, Bar, Accept, Accept-Language, Content-Language"
@@ -67,4 +71,4 @@ spec = around withApp $ describe "CORS" $ do
         liftIO $ do
           simpleHeaders r `shouldSatisfy` matchHeader
             "Access-Control-Allow-Origin" "\\*"
-          simpleBody r `shouldSatisfy` not . BL.null
+          simpleBody r `shouldSatisfy` BL.null

test/Feature/DeleteSpec.hs

@@ -2,35 +2,62 @@ module Feature.DeleteSpec where
 
 import Test.Hspec
 import Test.Hspec.Wai
-import SpecHelper
+import Text.Heredoc
 
 import Network.HTTP.Types
+import Network.Wai (Application)
 
-spec :: Spec
-spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items")
-  . around withApp $
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec =
   describe "Deleting" $ do
     context "existing record" $ do
       it "succeeds with 204 and deletion count" $
         request methodDelete "/items?id=eq.1" [] ""
-          `shouldRespondWith` ResponseMatcher {
-            matchBody    = Nothing
-          , matchStatus  = 204
+          `shouldRespondWith` ""
+          { matchStatus  = 204
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+      it "returns the deleted item and count if requested" $
+        request methodDelete "/items?id=eq.2" [("Prefer", "return=representation"), ("Prefer", "count=exact")] ""
+          `shouldRespondWith` [str|[{"id":2}]|]
+          { matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "*/1"]
           }
+      it "returns the deleted item and shapes the response" $
+        request methodDelete "/complex_items?id=eq.2&select=id,name" [("Prefer", "return=representation")] ""
+          `shouldRespondWith` [str|[{"id":2,"name":"Two"}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+      it "can rename and cast the selected columns" $
+        request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] ""
+          `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|]
+      it "can embed (parent) entities" $
+        request methodDelete "/tasks?id=eq.8&select=id,name,project{id}" [("Prefer", "return=representation")] ""
+          `shouldRespondWith` [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
 
       it "actually clears items ouf the db" $ do
         _ <- request methodDelete "/items?id=lt.15" [] ""
         get "/items"
-          `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just "[{\"id\":15}]"
-          , matchStatus  = 200
-          , matchHeaders = ["Content-Range" <:> "0-0/1"]
+          `shouldRespondWith` [str|[{"id":15}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-0/*"]
           }
 
-    context "known route, unknown record" $
-      it "fails with 404" $
-        request methodDelete "/items?id=eq.101" [] "" `shouldRespondWith` 404
+    context "known route, no records matched" $
+      it "includes [] body if return=rep" $
+        request methodDelete "/items?id=eq.101"
+          [("Prefer", "return=representation")] ""
+          `shouldRespondWith` "[]"
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
 
     context "totally unknown route" $
       it "fails with 404" $

test/Feature/InsertSpec.hs

@@ -1,37 +1,88 @@
 module Feature.InsertSpec where
 
-import Test.Hspec
+import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
+import Test.Hspec.Wai.Matcher (bodyEquals)
 import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus))
 
 import SpecHelper
 
 import qualified Data.Aeson as JSON
+import Data.List (lookup)
 import Data.Maybe (fromJust)
 import Text.Heredoc
 import Network.HTTP.Types.Header
 import Network.HTTP.Types
-import Control.Monad (replicateM_)
+import Control.Monad (replicateM_, void)
 
 import TestTypes(IncPK(..), CompoundPK(..))
+import Network.Wai (Application)
 
-spec :: Spec
-spec = afterAll_ resetDb $ around withApp $ do
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec = do
   describe "Posting new record" $ do
-    after_ (clearTable "menagerie") . it "accepts disparate json types" $ do
-      p <- post "/menagerie"
-        [json| {
-          "integer": 13, "double": 3.14159, "varchar": "testing!"
-        , "boolean": false, "date": "1900-01-01", "money": "$3.99"
-        , "enum": "foo"
-        } |]
-      liftIO $ do
-        simpleBody p `shouldBe` ""
-        simpleStatus p `shouldBe` created201
+    context "disparate json types" $ do
+      it "accepts disparate json types" $ do
+        p <- post "/menagerie"
+          [json| {
+            "integer": 13, "double": 3.14159, "varchar": "testing!"
+          , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+          , "enum": "foo"
+          } |]
+        liftIO $ do
+          simpleBody p `shouldBe` ""
+          simpleStatus p `shouldBe` created201
+          -- should not have content type set when body is empty
+          lookup hContentType (simpleHeaders p) `shouldBe` Nothing
+
+      it "filters columns in result using &select" $
+        request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]
+          [json| [{
+            "integer": 14, "double": 3.14159, "varchar": "testing!"
+          , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+          , "enum": "foo"
+          }] |] `shouldRespondWith` [str|[{"integer":14,"varchar":"testing!"}]|]
+          { matchStatus  = 201
+          , matchHeaders = [matchContentTypeJson]
+          }
+
+    context "requesting full representation" $ do
+      it "includes related data after insert" $
+        request methodPost "/projects?select=id,name,clients{id,name}"
+                [("Prefer", "return=representation"), ("Prefer", "count=exact")]
+          [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` [str|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|]
+          { matchStatus  = 201
+          , matchHeaders = [ matchContentTypeJson
+                           , "Location" <:> "/projects?id=eq.6"
+                           , "Content-Range" <:> "*/1" ]
+          }
+
+      it "can rename and cast the selected columns" $
+        request methodPost "/projects?select=pId:id::text,pName:name,cId:client_id::text"
+                [("Prefer", "return=representation")]
+          [str|{"id":7,"name":"New Project","client_id":2}|] `shouldRespondWith`
+          [str|[{"pId":"7","pName":"New Project","cId":"2"}]|]
+          { matchStatus  = 201
+          , matchHeaders = [ matchContentTypeJson
+                           , "Location" <:> "/projects?id=eq.7"
+                           , "Content-Range" <:> "*/*" ]
+          }
+
+    context "from an html form" $
+      it "accepts disparate json types" $ do
+        p <- request methodPost "/menagerie"
+               [("Content-Type", "application/x-www-form-urlencoded")]
+               ("integer=7&double=2.71828&varchar=forms+are+fun&" <>
+                "boolean=false&date=1900-01-01&money=$3.99&enum=foo")
+        liftIO $ do
+          simpleBody p `shouldBe` ""
+          simpleStatus p `shouldBe` created201
 
     context "with no pk supplied" $ do
-      context "into a table with auto-incrementing pk" . after_ (clearTable "auto_incrementing_pk") $
+      context "into a table with auto-incrementing pk" $
         it "succeeds with 201 and link" $ do
           p <- post "/auto_incrementing_pk" [json| { "non_nullable_string":"not null"} |]
           liftIO $ do
@@ -46,11 +97,13 @@ spec = afterAll_ resetDb $ around withApp $ do
             incNullableStr record `shouldBe` Nothing
 
       context "into a table with simple pk" $
-        it "fails with 400 and error" $
-          post "/simple_pk" [json| { "extra":"foo"} |]
-            `shouldRespondWith` 400
+        it "fails with 400 and error" $ do
+          p <- post "/simple_pk" [json| { "extra":"foo"} |]
+          liftIO $ do
+            simpleStatus p `shouldBe` badRequest400
+            isErrorFormat (simpleBody p) `shouldBe` True
 
-      context "into a table with no pk" . after_ (clearTable "no_pk") $ do
+      context "into a table with no pk" $ do
         it "succeeds with 201 and a link including all fields" $ do
           p <- post "/no_pk" [json| { "a":"foo", "b":"bar" } |]
           liftIO $ do
@@ -63,169 +116,205 @@ spec = afterAll_ resetDb $ around withApp $ do
                        [("Prefer", "return=representation")]
                        [json| { "a":"bar", "b":"baz" } |]
           liftIO $ do
-            simpleBody p `shouldBe` [json| { "a":"bar", "b":"baz" } |]
+            simpleBody p `shouldBe` [json| [{ "a":"bar", "b":"baz" }] |]
             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz"
             simpleStatus p `shouldBe` created201
 
+        it "returns empty array when no items inserted, and return=rep" $ do
+          p <- request methodPost "/no_pk"
+                       [("Prefer", "return=representation")]
+                       [json| [] |]
+          liftIO $ do
+            simpleBody p `shouldBe` [json| [] |]
+            simpleStatus p `shouldBe` created201
+
+        it "can insert in tables with no select privileges" $ do
+          p <- request methodPost "/insertonly"
+                       [("Prefer", "return=minimal")]
+                       [json| { "v":"some value" } |]
+          liftIO $ do
+            simpleBody p `shouldBe` ""
+            simpleStatus p `shouldBe` created201
+
+
         it "can post nulls" $ do
           p <- request methodPost "/no_pk"
                        [("Prefer", "return=representation")]
                        [json| { "a":null, "b":"foo" } |]
           liftIO $ do
-            simpleBody p `shouldBe` [json| { "a":null, "b":"foo" } |]
+            simpleBody p `shouldBe` [json| [{ "a":null, "b":"foo" }] |]
             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=is.null&b=eq.foo"
             simpleStatus p `shouldBe` created201
 
-    context "with compound pk supplied" . after_ (clearTable "compound_pk") $
-      it "builds response location header appropriately" $
-        post "/compound_pk" [json| { "k1":12, "k2":42 } |]
-          `shouldRespondWith` ResponseMatcher {
-            matchBody    = Nothing,
-            matchStatus  = 201,
-            matchHeaders = ["Location" <:> "/compound_pk?k1=eq.12&k2=eq.42"]
-          }
+    context "with compound pk supplied" $
+      it "builds response location header appropriately" $ do
+        let inserted    = [json| { "k1":12, "k2":"Rock & R+ll" } |]
+            expectedObj = CompoundPK 12 "Rock & R+ll" Nothing
+            expectedLoc = "/compound_pk?k1=eq.12&k2=eq.Rock%20%26%20R%2Bll"
+        p <- request methodPost "/compound_pk"
+                     [("Prefer", "return=representation")]
+                     inserted
+        liftIO $ do
+          JSON.decode (simpleBody p) `shouldBe` Just [expectedObj]
+          simpleStatus p `shouldBe` created201
+          lookup hLocation (simpleHeaders p) `shouldBe` Just expectedLoc
+
+        r <- get expectedLoc
+        liftIO $ do
+          JSON.decode (simpleBody r) `shouldBe` Just [expectedObj]
+          simpleStatus r `shouldBe` ok200
+
+    context "with bulk insert" $
+      it "returns 201 but no location header" $ do
+        let bulkData = [json| [ {"k1":21, "k2":"hello world"}
+                              , {"k1":22, "k2":"bye for now"}]
+                            |]
+        p <- request methodPost "/compound_pk" [] bulkData
+        liftIO $ do
+          simpleStatus p `shouldBe` created201
+          lookup hLocation (simpleHeaders p) `shouldBe` Nothing
 
     context "with invalid json payload" $
-      it "fails with 400 and error" $
-        post "/simple_pk" "}{ x = 2"
-          `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [json| {"message":"Failed to parse JSON payload. Failed reading: satisfy"} |]
-          , matchStatus  = 400
+      it "fails with 400 and error" $ do
+        p <- post "/simple_pk" "}{ x = 2"
+        liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "with valid json payload" $
+      it "succeeds and returns 201 created" $
+        post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] `shouldRespondWith` 201
+
+    context "attempting to insert a row with the same primary key" $
+      it "fails returning a 409 Conflict" $
+        post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] `shouldRespondWith` 409
+
+    context "attempting to insert a row with conflicting unique constraint" $
+      it "fails returning a 409 Conflict" $
+        post "/withUnique"  [json| { "uni":"nodup", "extra":"e2" } |] `shouldRespondWith` 409
+
+    context "jsonb" $ do
+      it "serializes nested object" $ do
+        let inserted = [json| { "data": { "foo":"bar" } } |]
+            location = "/json?data=eq.%7B%22foo%22%3A%22bar%22%7D"
+        request methodPost "/json"
+                     [("Prefer", "return=representation")]
+                     inserted
+          `shouldRespondWith` [str|[{"data":{"foo":"bar"}}]|]
+          { matchStatus  = 201
+          , matchHeaders = ["Location" <:> location]
+          }
+
+      it "serializes nested array" $ do
+        let inserted = [json| { "data": [1,2,3] } |]
+            location = "/json?data=eq.%5B1%2C2%2C3%5D"
+        request methodPost "/json"
+                     [("Prefer", "return=representation")]
+                     inserted
+          `shouldRespondWith` [str|[{"data":[1,2,3]}]|]
+          { matchStatus  = 201
+          , matchHeaders = ["Location" <:> location]
+          }
+
+    context "empty object" $
+      it "successfully populates table with all-default columns" $
+        post "/items" "{}" `shouldRespondWith` ""
+          { matchStatus  = 201
+          , matchHeaders = []
+          }
+    context "table with limited privileges" $ do
+      it "succeeds if correct select is applied" $
+        request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")]
+          [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` [str|[{"article_id":2,"user_id":1}]|]
+          { matchStatus  = 201
+          , matchHeaders = []
+          }
+      it "fails if more columns are selected" $
+        request methodPost "/limited_article_stars?select=article_id,user_id,created_at" [("Prefer", "return=representation")]
+          [json| {"article_id": 2, "user_id": 2} |] `shouldRespondWith`
+          [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]
+          { matchStatus  = 401
+          , matchHeaders = []
+          }
+      it "fails if select is not specified" $
+        request methodPost "/limited_article_stars" [("Prefer", "return=representation")]
+          [json| {"article_id": 3, "user_id": 1} |] `shouldRespondWith` [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]
+          { matchStatus  = 401
           , matchHeaders = []
           }
 
-    context "jsonb" . after_ (clearTable "json") $ do
-      it "serializes nested object" $ do
-        let inserted = [json| { "data": { "foo":"bar" } } |]
-        p <- request methodPost "json" [("Prefer", "return=representation")] inserted
-        liftIO $ do
-          simpleBody p `shouldBe` inserted
-          simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%7B%22foo%22%3A%22bar%22%7D"
-          simpleStatus p `shouldBe` created201
-      it "serializes nested array" $ do
-        let inserted = [json| { "data": [1,2,3] } |]
-        p <- request methodPost "json" [("Prefer", "return=representation")] inserted
-        liftIO $ do
-          simpleBody p `shouldBe` inserted
-          simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%5B1%2C2%2C3%5D"
-          simpleStatus p `shouldBe` created201
-
   describe "CSV insert" $ do
 
-    after_ (clearTable "menagerie") . context "disparate csv types" $
+    context "disparate csv types" $
       it "succeeds with multipart response" $ do
-        p <- request methodPost "/menagerie" [("Content-Type", "text/csv")]
-               [str|integer,double,varchar,boolean,date,money,enum
-                   |13,3.14159,testing!,false,1900-01-01,$3.99,foo
-                   |12,0.1,a string,true,1929-10-01,12,bar
-                   |]
-        liftIO $ do
-          simpleBody p `shouldBe` "Content-Type: application/json\nLocation: /menagerie?integer=eq.13\n\n\n--postgrest_boundary\nContent-Type: application/json\nLocation: /menagerie?integer=eq.12\n\n"
-          simpleStatus p `shouldBe` created201
+        pendingWith "Decide on what to do with CSV insert"
+        let inserted = [str|integer,double,varchar,boolean,date,money,enum
+            |13,3.14159,testing!,false,1900-01-01,$3.99,foo
+            |12,0.1,a string,true,1929-10-01,12,bar
+            |]
+        request methodPost "/menagerie" [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")] inserted
+           `shouldRespondWith` ResponseMatcher
+           { matchStatus  = 201
+           , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
+           , matchBody = bodyEquals inserted
+           }
 
-    after_ (clearTable "no_pk") . context "requesting full representation" $ do
+    context "requesting full representation" $ do
       it "returns full details of inserted record" $
         request methodPost "/no_pk"
-                     [("Content-Type", "text/csv"), ("Prefer", "return=representation")]
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"),  ("Prefer", "return=representation")]
                      "a,b\nbar,baz"
-          `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [json| { "a":"bar", "b":"baz" } |]
-          , matchStatus  = 201
-          , matchHeaders = ["Content-Type" <:> "application/json",
+          `shouldRespondWith` "a,b\nbar,baz"
+          { matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",
                             "Location" <:> "/no_pk?a=eq.bar&b=eq.baz"]
           }
 
       it "can post nulls" $
         request methodPost "/no_pk"
-                     [("Content-Type", "text/csv"), ("Prefer", "return=representation")]
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
                      "a,b\nNULL,foo"
-          `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [json| { "a":null, "b":"foo" } |]
-          , matchStatus  = 201
-          , matchHeaders = ["Content-Type" <:> "application/json",
+          `shouldRespondWith` "a,b\n,foo"
+          { matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",
                             "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
           }
 
-    after_ (clearTable "no_pk") . context "with wrong number of columns" $ do
+      it "only returns the requested column header with its associated data" $
+        request methodPost "/projects?select=id"
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
+                     "id,name,client_id\n8,Xenix,1\n9,Windows NT,1"
+          `shouldRespondWith` "id\n8\n9"
+          { matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",
+                            "Content-Range" <:> "*/*"]
+          }
+
+    context "with wrong number of columns" $
       it "fails for too few" $ do
         p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
-        liftIO $ simpleStatus p `shouldBe` badRequest400
-      it "fails for too many" $ do
-        p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz,bat,bad"
-        liftIO $ simpleStatus p `shouldBe` badRequest400
+        liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
+          isErrorFormat (simpleBody p) `shouldBe` True
 
-  describe "Putting record" $ do
+    context "with unicode values" $
+      it "succeeds and returns usable location header" $ do
+        let payload = [json| { "a":"圍棋", "b":"￥" } |]
+        p <- request methodPost "/no_pk"
+                     [("Prefer", "return=representation")]
+                     payload
+        liftIO $ do
+          simpleBody p `shouldBe` "["<>payload<>"]"
+          simpleStatus p `shouldBe` created201
 
-    context "to unkonwn uri" $
-      it "gives a 404" $
-        request methodPut "/fake" []
-          [json| { "real": false } |]
-            `shouldRespondWith` 404
+        let Just location = lookup hLocation $ simpleHeaders p
+        r <- get location
+        liftIO $ simpleBody r `shouldBe` "["<>payload<>"]"
 
-    context "to a known uri" $ do
-      context "without a fully-specified primary key" $
-        it "is not an allowed operation" $
-          request methodPut "/compound_pk?k1=eq.12" []
-            [json| { "k1":12, "k2":42 } |]
-              `shouldRespondWith` 405
-
-      context "with a fully-specified primary key" $ do
-
-        context "not specifying every column in the table" $
-          it "is rejected for lack of idempotence" $
-            request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
-              [json| { "k1":12, "k2":42 } |]
-                `shouldRespondWith` 400
-
-        context "specifying every column in the table" . after_ (clearTable "compound_pk") $ do
-          it "can create a new record" $ do
-            p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
-                 [json| { "k1":12, "k2":42, "extra":3 } |]
-            liftIO $ do
-              simpleBody p `shouldBe` ""
-              simpleStatus p `shouldBe` status204
-
-            r <- get "/compound_pk?k1=eq.12&k2=eq.42"
-            let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK])
-            liftIO $ do
-              length rows `shouldBe` 1
-              let record = head rows
-              compoundK1 record `shouldBe` 12
-              compoundK2 record `shouldBe` 42
-              compoundExtra record `shouldBe` Just 3
-
-          it "can update an existing record" $ do
-            _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
-                 [json| { "k1":12, "k2":42, "extra":4 } |]
-            _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
-                 [json| { "k1":12, "k2":42, "extra":5 } |]
-
-            r <- get "/compound_pk?k1=eq.12&k2=eq.42"
-            let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK])
-            liftIO $ do
-              length rows `shouldBe` 1
-              let record = head rows
-              compoundExtra record `shouldBe` Just 5
-
-      context "with an auto-incrementing primary key" . after_ (clearTable "auto_incrementing_pk") $
-
-        it "succeeds with 204" $
-          request methodPut "/auto_incrementing_pk?id=eq.1" []
-               [json| {
-                 "id":1,
-                 "nullable_string":"hi",
-                 "non_nullable_string":"bye",
-                 "inserted_at": "2020-11-11"
-               } |]
-            `shouldRespondWith` ResponseMatcher {
-              matchBody    = Nothing,
-              matchStatus  = 204,
-              matchHeaders = []
-            }
 
   describe "Patching record" $ do
 
-    context "to unkonwn uri" $
+    context "to unknown uri" $
       it "gives a 404" $
         request methodPatch "/fake" []
           [json| { "real": false } |]
@@ -233,26 +322,48 @@ spec = afterAll_ resetDb $ around withApp $ do
 
     context "on an empty table" $
       it "indicates no records found to update" $
-        request methodPatch "/simple_pk" []
+        request methodPatch "/empty_table" []
           [json| { "extra":20 } |]
-            `shouldRespondWith` 404
+          `shouldRespondWith` ""
+          { matchStatus  = 204,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
 
-    context "in a nonempty table" . before_ (clearTable "items" >> createItems 15) .
-      after_ (clearTable "items") $ do
+    context "in a nonempty table" $ do
       it "can update a single item" $ do
         g <- get "/items?id=eq.42"
         liftIO $ simpleHeaders g
-          `shouldSatisfy` matchHeader "Content-Range" "\\*/0"
-        request methodPatch "/items?id=eq.1" []
-          [json| { "id":42 } |]
-            `shouldRespondWith` ResponseMatcher {
-              matchBody    = Nothing,
-              matchStatus  = 204,
-              matchHeaders = ["Content-Range" <:> "0-0/1"]
-            }
+          `shouldSatisfy` matchHeader "Content-Range" "\\*/\\*"
+        p <- request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |]
+        pure p `shouldRespondWith` ""
+          { matchStatus  = 204,
+            matchHeaders = ["Content-Range" <:> "0-0/*"]
+          }
+        liftIO $ lookup hContentType (simpleHeaders p) `shouldBe` Nothing
+
+        -- check it really got updated
         g' <- get "/items?id=eq.42"
         liftIO $ simpleHeaders g'
-          `shouldSatisfy` matchHeader "Content-Range" "0-0/1"
+          `shouldSatisfy` matchHeader "Content-Range" "0-0/\\*"
+        -- put value back for other tests
+        void $ request methodPatch "/items?id=eq.42" [] [json| { "id":2 } |]
+
+      it "returns empty array when no rows updated and return=rep" $
+        request methodPatch "/items?id=eq.999999"
+          [("Prefer", "return=representation")] [json| { "id":999999 } |]
+          `shouldRespondWith` "[]"
+          {
+            matchStatus  = 200,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+      it "returns updated object as array when return=rep" $
+        request methodPatch "/items?id=eq.2"
+          [("Prefer", "return=representation")] [json| { "id":2 } |]
+          `shouldRespondWith` [str|[{"id":2}]|]
+          { matchStatus  = 200,
+            matchHeaders = ["Content-Range" <:> "0-0/*"]
+          }
 
       it "can update multiple items" $ do
         replicateM_ 10 $ post "/auto_incrementing_pk"
@@ -264,7 +375,34 @@ spec = afterAll_ resetDb $ around withApp $ do
           [json| { non_nullable_string: "c" } |]
         g <- get "/auto_incrementing_pk?non_nullable_string=eq.c"
         liftIO $ simpleHeaders g
-          `shouldSatisfy` matchHeader "Content-Range" "0-9/10"
+          `shouldSatisfy` matchHeader "Content-Range" "0-9/\\*"
+
+      it "can set a column to NULL" $ do
+        _ <- post "/no_pk" [json| { a: "keepme", b: "nullme" } |]
+        _ <- request methodPatch "/no_pk?b=eq.nullme" [] [json| { b: null } |]
+        get "/no_pk?a=eq.keepme" `shouldRespondWith`
+          [json| [{ a: "keepme", b: null }] |]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "can set a json column to escaped value" $ do
+        _ <- post "/json" [json| { data: {"escaped":"bar"} } |]
+        request methodPatch "/json?data->>escaped=eq.bar"
+                     [("Prefer", "return=representation")]
+                     [json| { "data": { "escaped":" \"bar" } } |]
+          `shouldRespondWith` [json| [{ "data": { "escaped":" \"bar" } }] |]
+          { matchStatus  = 200
+          , matchHeaders = []
+          }
+
+      it "can update based on a computed column" $
+        request methodPatch
+          "/items?always_true=eq.false"
+          [("Prefer", "return=representation")]
+          [json| { id: 100 } |]
+          `shouldRespondWith` "[]"
+          { matchStatus  = 200,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
 
       it "can provide a representation" $ do
         _ <- post "/items"
@@ -274,23 +412,60 @@ spec = afterAll_ resetDb $ around withApp $ do
           [("Prefer", "return=representation")]
           [json| { id: 99 } |]
           `shouldRespondWith` [json| [{id:99}] |]
+          { matchHeaders = [matchContentTypeJson] }
+        -- put value back for other tests
+        void $ request methodPatch "/items?id=eq.99" [] [json| { "id":1 } |]
+
+      it "makes no updates and returns 204, when patching with an empty json object" $ do
+        request methodPatch "/items" [] [json| {} |]
+          `shouldRespondWith` ""
+          {
+            matchStatus  = 204,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+        g <- get "/items"
+        liftIO $ simpleBody g `shouldBe` [json| [{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}] |]
+
+      it "makes no updates and and returns 200, when patching with an empty json object and return=rep" $ do
+        request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |]
+          `shouldRespondWith` "[]"
+          {
+            matchStatus  = 200,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+        g <- get "/items"
+        liftIO $ simpleBody g `shouldBe` [json| [{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}] |]
+
+    context "with unicode values" $
+      it "succeeds and returns values intact" $ do
+        void $ request methodPost "/no_pk" []
+          [json| { "a":"patchme", "b":"patchme" } |]
+        let payload = [json| { "a":"圍棋", "b":"￥" } |]
+        p <- request methodPatch "/no_pk?a=eq.patchme&b=eq.patchme"
+          [("Prefer", "return=representation")] payload
+        liftIO $ do
+          simpleBody p `shouldBe` "["<>payload<>"]"
+          simpleStatus p `shouldBe` ok200
 
   describe "Row level permission" $
     it "set user_id when inserting rows" $ do
+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0"
       _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
       _ <- post "/postgrest/users" [json| { "id":"jroe", "pass": "1234", "role": "postgrest_test_author" } |]
 
       p1 <- request methodPost "/authors_only"
-        [ authHeaderBasic "jdoe" "1234", ("Prefer", "return=representation") ]
+        [ auth, ("Prefer", "return=representation") ]
         [json| { "secret": "nyancat" } |]
       liftIO $ do
-          simpleBody p1 `shouldBe` [json| { "owner":"jdoe", "secret":"nyancat" } |]
-          simpleStatus p1 `shouldBe` created201
+        simpleBody p1 `shouldBe` [str|[{"owner":"jdoe","secret":"nyancat"}]|]
+        simpleStatus p1 `shouldBe` created201
 
       p2 <- request methodPost "/authors_only"
         -- jwt token for jroe
-        [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.YuF_VfmyIxWyuceT7crnNKEprIYXsJAyXid3rjPjIow", ("Prefer", "return=representation") ]
+        [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.2e7mx0U4uDcInlbJVOBGlrRufwqWLINDIEDC1vS0nw8", ("Prefer", "return=representation") ]
         [json| { "secret": "lolcat", "owner": "hacker" } |]
       liftIO $ do
-          simpleBody p2 `shouldBe` [json| { "owner":"jroe", "secret":"lolcat" } |]
-          simpleStatus p2 `shouldBe` created201
+        simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|]
+        simpleStatus p2 `shouldBe` created201

test/Feature/NoJwtSpec.hs

@@ -0,0 +1,25 @@
+module Feature.NoJwtSpec where
+
+-- {{{ Imports
+import Test.Hspec
+import Test.Hspec.Wai
+import Network.HTTP.Types
+
+import SpecHelper
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+-- }}}
+
+spec :: SpecWith Application
+spec = describe "server started without JWT secret" $ do
+
+  -- this test will stop working 9999999999s after the UNIX EPOCH
+  it "responds with error on attempted auth" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 500
+
+  it "behaves normally when user does not attempt auth" $
+    request methodGet "/items" [] ""
+      `shouldRespondWith` 200

test/Feature/ProxySpec.hs

@@ -0,0 +1,15 @@
+module Feature.ProxySpec where
+
+import Test.Hspec hiding (pendingWith)
+
+import SpecHelper
+
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec =
+  describe "GET / with proxy" $
+    it "returns a valid openapi spec with proxy" $
+      validateOpenApiResponse [("Accept", "application/openapi+json")]

test/Feature/QueryLimitedSpec.hs

@@ -0,0 +1,44 @@
+module Feature.QueryLimitedSpec where
+
+import Test.Hspec hiding (pendingWith)
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+import Network.HTTP.Types
+import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus))
+import Text.Heredoc
+import SpecHelper
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec =
+  describe "Requesting many items with server limits enabled" $ do
+    it "restricts results" $
+      get "/items"
+        `shouldRespondWith` [json| [{"id":1},{"id":2}] |]
+        { matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/*"]
+        }
+
+    it "respects additional client limiting" $ do
+      r <- request methodGet  "/items"
+                   (rangeHdrs $ ByteRangeFromTo 0 0) ""
+      liftIO $ do
+        simpleHeaders r `shouldSatisfy`
+          matchHeader "Content-Range" "0-0/*"
+        simpleStatus r `shouldBe` ok200
+
+    it "limit works on all levels" $
+      get "/users?select=id,tasks{id}&order=id.asc&tasks.order=id.asc"
+        `shouldRespondWith` [str|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|]
+        { matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/*"]
+        }
+
+    it "limit is not applied to parent embeds" $
+      get "/tasks?select=id,project{id}&id=gt.5"
+        `shouldRespondWith` [str|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|]
+        { matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/*"]
+        }

test/Feature/QuerySpec.hs

@@ -1,22 +1,29 @@
 module Feature.QuerySpec where
 
-import Test.Hspec
+import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
-import Network.Wai.Test (SResponse(simpleHeaders))
+import Network.HTTP.Types
+import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus,simpleBody))
+import qualified Data.ByteString.Lazy as BL (empty)
 
 import SpecHelper
+import Text.Heredoc
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec = do
+
+  describe "Querying a table with a column called count" $
+    it "should not confuse count column with pg_catalog.count aggregate" $
+      get "/has_count_column" `shouldRespondWith` 200
+
+  describe "Querying a table with a column called t" $
+    it "should not conflict with internal postgrest table alias" $
+      get "/clashing_column?select=t" `shouldRespondWith` 200
 
-spec :: Spec
-spec =
-  beforeAll (clearTable "items" >> createItems 15)
-   . beforeAll (
-       clearTable "no_pk" >>
-       createNulls 2 >>
-       createLikableStrings >>
-       createJsonData)
-   . afterAll_ (clearTable "items" >> clearTable "no_pk" >> clearTable "simple_pk")
-   . around withApp $ do
   describe "Querying a nonexistent table" $
     it "causes a 404" $
       get "/faketable" `shouldRespondWith` 404
@@ -24,97 +31,439 @@ spec =
   describe "Filtering response" $ do
     it "matches with equality" $
       get "/items?id=eq.5"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just [json| [{"id":5}] |]
-        , matchStatus  = 200
-        , matchHeaders = ["Content-Range" <:> "0-0/1"]
-        }
+        `shouldRespondWith` [json| [{"id":5}] |]
+        { matchHeaders = ["Content-Range" <:> "0-0/*"] }
+
+    it "matches with equality using not operator" $
+      get "/items?id=not.eq.5"
+        `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
+        { matchHeaders = ["Content-Range" <:> "0-13/*"] }
+
+    it "matches with more than one condition using not operator" $
+      get "/simple_pk?k=like.*yx&extra=not.eq.u" `shouldRespondWith` "[]"
+
+    it "matches with inequality using not operator" $ do
+      get "/items?id=not.lt.14&order=id.asc"
+        `shouldRespondWith` [json| [{"id":14},{"id":15}] |]
+        { matchHeaders = ["Content-Range" <:> "0-1/*"] }
+      get "/items?id=not.gt.2&order=id.asc"
+        `shouldRespondWith` [json| [{"id":1},{"id":2}] |]
+        { matchHeaders = ["Content-Range" <:> "0-1/*"] }
 
     it "matches items IN" $
       get "/items?id=in.1,3,5"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just [json| [{"id":1},{"id":3},{"id":5}] |]
-        , matchStatus  = 200
-        , matchHeaders = ["Content-Range" <:> "0-2/3"]
-        }
+        `shouldRespondWith` [json| [{"id":1},{"id":3},{"id":5}] |]
+        { matchHeaders = ["Content-Range" <:> "0-2/*"] }
 
-    it "matches nulls" $
+    it "matches items NOT IN" $
+      get "/items?id=notin.2,4,6,7,8,9,10,11,12,13,14,15"
+        `shouldRespondWith` [json| [{"id":1},{"id":3},{"id":5}] |]
+        { matchHeaders = ["Content-Range" <:> "0-2/*"] }
+
+    it "matches items NOT IN using not operator" $
+      get "/items?id=not.in.2,4,6,7,8,9,10,11,12,13,14,15"
+        `shouldRespondWith` [json| [{"id":1},{"id":3},{"id":5}] |]
+        { matchHeaders = ["Content-Range" <:> "0-2/*"] }
+
+    it "matches nulls using not operator" $
+      get "/no_pk?a=not.is.null" `shouldRespondWith`
+        [json| [{"a":"1","b":"0"},{"a":"2","b":"0"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "matches nulls in varchar and numeric fields alike" $ do
       get "/no_pk?a=is.null" `shouldRespondWith`
         [json| [{"a": null, "b": null}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+      get "/nullable_integer?a=is.null" `shouldRespondWith` [str|[{"a":null}]|]
 
     it "matches with like" $ do
       get "/simple_pk?k=like.*yx" `shouldRespondWith`
-        "[{\"k\":\"xyyx\",\"extra\":\"u\"}]"
+        [str|[{"k":"xyyx","extra":"u"}]|]
       get "/simple_pk?k=like.xy*" `shouldRespondWith`
-        "[{\"k\":\"xyyx\",\"extra\":\"u\"}]"
+        [str|[{"k":"xyyx","extra":"u"}]|]
       get "/simple_pk?k=like.*YY*" `shouldRespondWith`
-        "[{\"k\":\"xYYx\",\"extra\":\"v\"}]"
+        [str|[{"k":"xYYx","extra":"v"}]|]
+
+    it "matches with like using not operator" $
+      get "/simple_pk?k=not.like.*yx" `shouldRespondWith`
+        [str|[{"k":"xYYx","extra":"v"}]|]
 
     it "matches with ilike" $ do
       get "/simple_pk?k=ilike.xy*&order=extra.asc" `shouldRespondWith`
-        "[{\"k\":\"xyyx\",\"extra\":\"u\"},{\"k\":\"xYYx\",\"extra\":\"v\"}]"
+        [str|[{"k":"xyyx","extra":"u"},{"k":"xYYx","extra":"v"}]|]
       get "/simple_pk?k=ilike.*YY*&order=extra.asc" `shouldRespondWith`
-        "[{\"k\":\"xyyx\",\"extra\":\"u\"},{\"k\":\"xYYx\",\"extra\":\"v\"}]"
+        [str|[{"k":"xyyx","extra":"u"},{"k":"xYYx","extra":"v"}]|]
+
+    it "matches with ilike using not operator" $
+      get "/simple_pk?k=not.ilike.xy*&order=extra.asc" `shouldRespondWith` "[]"
+
+    it "matches with tsearch fts" $ do
+      get "/tsearch?text_search_vector=fts.impossible" `shouldRespondWith`
+        [json| [{"text_search_vector": "'fun':5 'imposs':9 'kind':3" }] |]
+        { matchHeaders = [matchContentTypeJson] }
+      get "/tsearch?text_search_vector=fts.possible" `shouldRespondWith`
+        [json| [{"text_search_vector": "'also':2 'fun':3 'possibl':8" }] |]
+        { matchHeaders = [matchContentTypeJson] }
+      -- TODO: remove in 0.5.0 as deprecated
+      get "/tsearch?text_search_vector=@@.impossible" `shouldRespondWith`
+        [json| [{"text_search_vector": "'fun':5 'imposs':9 'kind':3" }] |]
+        { matchHeaders = [matchContentTypeJson] }
+      get "/tsearch?text_search_vector=@@.possible" `shouldRespondWith`
+        [json| [{"text_search_vector": "'also':2 'fun':3 'possibl':8" }] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "matches with tsearch fts using not operator" $ do
+      get "/tsearch?text_search_vector=not.fts.impossible" `shouldRespondWith`
+        [json| [{"text_search_vector": "'also':2 'fun':3 'possibl':8" }] |]
+        { matchHeaders = [matchContentTypeJson] }
+      -- TODO: remove in 0.5.0 as deprecated
+      get "/tsearch?text_search_vector=not.@@.impossible" `shouldRespondWith`
+        [json| [{"text_search_vector": "'also':2 'fun':3 'possibl':8" }] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "matches with computed column" $
+      get "/items?always_true=eq.true&order=id.asc" `shouldRespondWith`
+        [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "order by computed column" $
+      get "/items?order=anti_id.desc" `shouldRespondWith`
+        [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "matches filtering nested items 2" $
+      get "/clients?select=id,projects{id,tasks2{id,name}}&projects.tasks.name=like.Design*"
+        `shouldRespondWith` [json| {"message":"Could not find foreign keys between these entities, No relation found between projects and tasks2"}|]
+        { matchStatus  = 400
+        , matchHeaders = [matchContentTypeJson]
+        }
+
+    it "matches filtering nested items" $
+      get "/clients?select=id,projects{id,tasks{id,name}}&projects.tasks.name=like.Design*" `shouldRespondWith`
+        [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1,"name":"Design w7"}]},{"id":2,"tasks":[{"id":3,"name":"Design w10"}]}]},{"id":2,"projects":[{"id":3,"tasks":[{"id":5,"name":"Design IOS"}]},{"id":4,"tasks":[{"id":7,"name":"Design OSX"}]}]}]|]
+
+    it "matches with cs operator" $ do
+      get "/complex_items?select=id&arr_data=cs.{2}" `shouldRespondWith`
+        [str|[{"id":2},{"id":3}]|]
+      -- TODO: remove in 0.5.0 as deprecated
+      get "/complex_items?select=id&arr_data=@>.{2}" `shouldRespondWith`
+        [str|[{"id":2},{"id":3}]|]
+
+    it "matches with cd operator" $ do
+      get "/complex_items?select=id&arr_data=cd.{1,2,4}" `shouldRespondWith`
+        [str|[{"id":1},{"id":2}]|]
+      -- TODO: remove in 0.5.0 as deprecated
+      get "/complex_items?select=id&arr_data=<@.{1,2,4}" `shouldRespondWith`
+        [str|[{"id":1},{"id":2}]|]
+
+
+  describe "Shaping response with select parameter" $ do
+
+    it "selectStar works in absense of parameter" $
+      get "/complex_items?id=eq.3" `shouldRespondWith`
+        [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|]
+
+    it "dash `-` in column names is accepted" $
+      get "/complex_items?id=eq.3&select=id,field-with_sep" `shouldRespondWith`
+        [str|[{"id":3,"field-with_sep":1}]|]
+
+    it "one simple column" $
+      get "/complex_items?select=id" `shouldRespondWith`
+        [json| [{"id":1},{"id":2},{"id":3}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "rename simple column" $
+      get "/complex_items?id=eq.1&select=myId:id" `shouldRespondWith`
+        [json| [{"myId":1}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+
+    it "one simple column with casting (text)" $
+      get "/complex_items?select=id::text" `shouldRespondWith`
+        [json| [{"id":"1"},{"id":"2"},{"id":"3"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "rename simple column with casting" $
+      get "/complex_items?id=eq.1&select=myId:id::text" `shouldRespondWith`
+        [json| [{"myId":"1"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "json column" $
+      get "/complex_items?id=eq.1&select=settings" `shouldRespondWith`
+        [json| [{"settings":{"foo":{"int":1,"bar":"baz"}}}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "json subfield one level with casting (json)" $
+      get "/complex_items?id=eq.1&select=settings->>foo::json" `shouldRespondWith`
+        [json| [{"foo":{"int":1,"bar":"baz"}}] |] -- the value of foo here is of type "text"
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "rename json subfield one level with casting (json)" $
+      get "/complex_items?id=eq.1&select=myFoo:settings->>foo::json" `shouldRespondWith`
+        [json| [{"myFoo":{"int":1,"bar":"baz"}}] |] -- the value of foo here is of type "text"
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "fails on bad casting (data of the wrong format)" $
+      get "/complex_items?select=settings->foo->>bar::integer"
+        `shouldRespondWith` [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"baz\""} |]
+        { matchStatus  = 400
+        , matchHeaders = []
+        }
+
+    it "fails on bad casting (wrong cast type)" $
+      get "/complex_items?select=id::fakecolumntype"
+        `shouldRespondWith` [json| {"hint":null,"details":null,"code":"42704","message":"type \"fakecolumntype\" does not exist"} |]
+        { matchStatus  = 400
+        , matchHeaders = []
+        }
+
+
+    it "json subfield two levels (string)" $
+      get "/complex_items?id=eq.1&select=settings->foo->>bar" `shouldRespondWith`
+        [json| [{"bar":"baz"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "rename json subfield two levels (string)" $
+      get "/complex_items?id=eq.1&select=myBar:settings->foo->>bar" `shouldRespondWith`
+        [json| [{"myBar":"baz"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+
+    it "json subfield two levels with casting (int)" $
+      get "/complex_items?id=eq.1&select=settings->foo->>int::integer" `shouldRespondWith`
+        [json| [{"int":1}] |] -- the value in the db is an int, but here we expect a string for now
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "rename json subfield two levels with casting (int)" $
+      get "/complex_items?id=eq.1&select=myInt:settings->foo->>int::integer" `shouldRespondWith`
+        [json| [{"myInt":1}] |] -- the value in the db is an int, but here we expect a string for now
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "requesting parents and children" $
+      get "/projects?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
+
+    it "embed data with two fk pointing to the same table" $
+      get "/orders?id=eq.1&select=id, name, billing_address_id{id}, shipping_address_id{id}" `shouldRespondWith`
+        [str|[{"id":1,"name":"order 1","billing_address_id":{"id":1},"shipping_address_id":{"id":2}}]|]
+
+
+    it "requesting parents and children while renaming them" $
+      get "/projects?id=eq.1&select=myId:id, name, project_client:client_id{*}, project_tasks:tasks{id, name}" `shouldRespondWith`
+        [str|[{"myId":1,"name":"Windows 7","project_client":{"id":1,"name":"Microsoft"},"project_tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
+
+    it "requesting parents two levels up while using FK to specify the link" $
+      get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith`
+        [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]
+
+    it "requesting parents two levels up while using FK to specify the link (with rename)" $
+      get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith`
+        [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]
+
+
+    it "requesting parents and filtering parent columns" $
+      get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|]
+
+    it "rows with missing parents are included" $
+      get "/projects?id=in.1,5&select=id,clients{id}" `shouldRespondWith`
+        [str|[{"id":1,"clients":{"id":1}},{"id":5,"clients":null}]|]
+
+    it "rows with no children return [] instead of null" $
+      get "/projects?id=in.5&select=id,tasks{id}" `shouldRespondWith`
+        [str|[{"id":5,"tasks":[]}]|]
+
+    it "requesting children 2 levels" $
+      get "/clients?id=eq.1&select=id,projects{id,tasks{id}}" `shouldRespondWith`
+        [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|]
+
+    it "requesting children 2 levels (with relation path fixed)" $
+      get "/clients?id=eq.1&select=id,projects:projects.client_id{id,tasks{id}}" `shouldRespondWith`
+        [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|]
+
+    it "requesting many<->many relation" $
+      get "/tasks?select=id,users{id}" `shouldRespondWith`
+        [str|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|]
+
+    it "requesting many<->many relation (with relation path fixed)" $
+      get "/tasks?select=id,users:users.users_tasks{id}" `shouldRespondWith`
+        [str|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|]
+
+    it "requesting many<->many relation with rename" $
+      get "/tasks?id=eq.1&select=id,theUsers:users{id}" `shouldRespondWith`
+        [str|[{"id":1,"theUsers":[{"id":1},{"id":3}]}]|]
+
+
+    it "requesting many<->many relation reverse" $
+      get "/users?select=id,tasks{id}" `shouldRespondWith`
+        [str|[{"id":1,"tasks":[{"id":1},{"id":2},{"id":3},{"id":4}]},{"id":2,"tasks":[{"id":5},{"id":6},{"id":7}]},{"id":3,"tasks":[{"id":1},{"id":5}]}]|]
+
+    it "requesting parents and children on views" $
+      get "/projects_view?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
+
+    it "requesting parents and children on views with renamed keys" $
+      get "/projects_view_alt?t_id=eq.1&select=t_id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
+        [str|[{"t_id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
+
+
+    it "requesting children with composite key" $
+      get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments{content}" `shouldRespondWith`
+        [str|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|]
+
+    it "detect relations in views from exposed schema that are based on tables in private schema and have columns renames" $
+      get "/articles?id=eq.1&select=id,articleStars{users{*}}" `shouldRespondWith`
+        [str|[{"id":1,"articleStars":[{"users":{"id":1,"name":"Angela Martin"}},{"users":{"id":2,"name":"Michael Scott"}},{"users":{"id":3,"name":"Dwight Schrute"}}]}]|]
+
+    it "can select by column name" $
+      get "/projects?id=in.1,3&select=id,name,client_id,client_id{id,name}" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","client_id":1,"client_id":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client_id":{"id":2,"name":"Apple"}}]|]
+
+    it "can select by column name sans id" $
+      get "/projects?id=in.1,3&select=id,name,client_id,client{id,name}" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|]
+
+    it "can detect fk relations through views to tables in the public schema" $
+      get "/consumers_view?select=*,orders_view{*}" `shouldRespondWith` 200
 
-    it "matches with tsearch @@" $
-      get "/tsearch?text_search_vector=@@.foo" `shouldRespondWith`
-        "[{\"text_search_vector\":\"'bar':2 'foo':1\"}]"
 
   describe "ordering response" $ do
     it "by a column asc" $
       get "/items?id=lte.2&order=id.asc"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just [json| [{"id":1},{"id":2}] |]
-        , matchStatus  = 200
-        , matchHeaders = ["Content-Range" <:> "0-1/2"]
+        `shouldRespondWith` [json| [{"id":1},{"id":2}] |]
+        { matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/*"]
         }
     it "by a column desc" $
       get "/items?id=lte.2&order=id.desc"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just [json| [{"id":2},{"id":1}] |]
-        , matchStatus  = 200
-        , matchHeaders = ["Content-Range" <:> "0-1/2"]
+        `shouldRespondWith` [json| [{"id":2},{"id":1}] |]
+        { matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/*"]
+        }
+
+    it "by a column with nulls first" $
+      get "/no_pk?order=a.nullsfirst"
+        `shouldRespondWith` [json| [{"a":null,"b":null},
+                              {"a":"1","b":"0"},
+                              {"a":"2","b":"0"}
+                              ] |]
+        { matchStatus = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/*"]
         }
 
     it "by a column asc with nulls last" $
       get "/no_pk?order=a.asc.nullslast"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody = Just [json| [{"a":"1","b":"0"},
+        `shouldRespondWith` [json| [{"a":"1","b":"0"},
                               {"a":"2","b":"0"},
                               {"a":null,"b":null}] |]
-        , matchStatus = 200
-        , matchHeaders = ["Content-Range" <:> "0-2/3"]
+        { matchStatus = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/*"]
         }
 
     it "by a column desc with nulls first" $
       get "/no_pk?order=a.desc.nullsfirst"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody = Just [json| [{"a":null,"b":null},
+        `shouldRespondWith` [json| [{"a":null,"b":null},
                               {"a":"2","b":"0"},
                               {"a":"1","b":"0"}] |]
-        , matchStatus = 200
-        , matchHeaders = ["Content-Range" <:> "0-2/3"]
+        { matchStatus = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/*"]
         }
 
     it "by a column desc with nulls last" $
       get "/no_pk?order=a.desc.nullslast"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody = Just [json| [{"a":"2","b":"0"},
+        `shouldRespondWith` [json| [{"a":"2","b":"0"},
                               {"a":"1","b":"0"},
                               {"a":null,"b":null}] |]
-        , matchStatus = 200
-        , matchHeaders = ["Content-Range" <:> "0-2/3"]
+        { matchStatus = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/*"]
         }
 
+    it "by a json column property asc" $
+      get "/json?order=data->>id.asc" `shouldRespondWith`
+        [json| [{"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}, {"data": {"id": 3}}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "by a json column with two level property nulls first" $
+      get "/json?order=data->foo->>bar.nullsfirst" `shouldRespondWith`
+        [json| [{"data": {"id": 3}}, {"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
     it "without other constraints" $
-      get "/items?order=asc.id" `shouldRespondWith` 200
+      get "/items?order=id.asc" `shouldRespondWith` 200
+
+    it "ordering embeded entities" $
+      get "/projects?id=eq.1&select=id, name, tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|]
+
+    it "ordering embeded entities with alias" $
+      get "/projects?id=eq.1&select=id, name, the_tasks:tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","the_tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|]
+
+    it "ordering embeded entities, two levels" $
+      get "/projects?id=eq.1&select=id, name, tasks{id, name, users{id, name}}&tasks.order=name.asc&tasks.users.order=name.desc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7","users":[{"id":1,"name":"Angela Martin"}]},{"id":1,"name":"Design w7","users":[{"id":3,"name":"Dwight Schrute"},{"id":1,"name":"Angela Martin"}]}]}]|]
+
+    it "ordering embeded parents does not break things" $
+      get "/projects?id=eq.1&select=id, name, clients{id, name}&clients.order=name.asc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"}}]|]
+
+    it "ordering embeded parents does not break things when using ducktape names" $
+      get "/projects?id=eq.1&select=id, name, client{id, name}&client.order=name.asc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}]|]
+
+
+
+  describe "Accept headers" $ do
+    it "should respond an unknown accept type with 415" $
+      request methodGet "/simple_pk"
+              (acceptHdrs "text/unknowntype") ""
+        `shouldRespondWith` 415
+
+    it "should respond correctly to */* in accept header" $
+      request methodGet "/simple_pk"
+              (acceptHdrs "*/*") ""
+        `shouldRespondWith` 200
+
+    it "*/* should rescue an unknown type" $
+      request methodGet "/simple_pk"
+              (acceptHdrs "text/unknowntype, */*") ""
+        `shouldRespondWith` 200
+
+    it "specific available preference should override */*" $ do
+      r <- request methodGet "/simple_pk"
+              (acceptHdrs "text/csv, */*") ""
+      liftIO $ do
+        let respHeaders = simpleHeaders r
+        respHeaders `shouldSatisfy` matchHeader
+          "Content-Type" "text/csv; charset=utf-8"
+
+    it "honors client preference even when opposite of server preference" $ do
+      r <- request methodGet "/simple_pk"
+              (acceptHdrs "text/csv, application/json") ""
+      liftIO $ do
+        let respHeaders = simpleHeaders r
+        respHeaders `shouldSatisfy` matchHeader
+          "Content-Type" "text/csv; charset=utf-8"
+
+    it "should respond correctly to multiple types in accept header" $
+      request methodGet "/simple_pk"
+              (acceptHdrs "text/unknowntype, text/csv") ""
+        `shouldRespondWith` 200
+
+    it "should respond with CSV to 'text/csv' request" $
+      request methodGet "/simple_pk"
+              (acceptHdrs "text/csv; version=1") ""
+        `shouldRespondWith` "k,extra\nxyyx,u\nxYYx,v"
+        { matchStatus  = 200
+        , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
+        }
 
   describe "Canonical location" $ do
     it "Sets Content-Location with alphabetized params" $
       get "/no_pk?b=eq.1&a=eq.1"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just "[]"
-        , matchStatus  = 200
+        `shouldRespondWith` "[]"
+        { matchStatus  = 200
         , matchHeaders = ["Content-Location" <:> "/no_pk?a=eq.1&b=eq.1"]
         }
 
@@ -125,9 +474,445 @@ spec =
         respHeaders `shouldSatisfy` matchHeader
           "Content-Location" "/simple_pk"
 
-  describe "jsonb" $
+  describe "jsonb" $ do
     it "can filter by properties inside json column" $ do
       get "/json?data->foo->>bar=eq.baz" `shouldRespondWith`
-        [json| [{"data": {"foo": {"bar": "baz"}}}] |]
+        [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |]
+        { matchHeaders = [matchContentTypeJson] }
       get "/json?data->foo->>bar=eq.fake" `shouldRespondWith`
         [json| [] |]
+        { matchHeaders = [matchContentTypeJson] }
+    it "can filter by properties inside json column using not" $
+      get "/json?data->foo->>bar=not.eq.baz" `shouldRespondWith`
+        [json| [] |]
+        { matchHeaders = [matchContentTypeJson] }
+    it "can filter by properties inside json column using ->>" $
+      get "/json?data->>id=eq.1" `shouldRespondWith`
+        [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+  describe "remote procedure call" $ do
+    context "a proc that returns a set" $ do
+      it "returns paginated results" $
+        request methodPost "/rpc/getitemrange"
+                (rangeHdrs (ByteRangeFromTo 0 0))  [json| { "min": 2, "max": 4 } |]
+           `shouldRespondWith` [json| [{"id":3}] |]
+            { matchStatus = 200
+            , matchHeaders = ["Content-Range" <:> "0-0/*"]
+            }
+
+      it "includes total count if requested" $
+        request methodPost "/rpc/getitemrange"
+                (rangeHdrsWithCount (ByteRangeFromTo 0 0))
+                [json| { "min": 2, "max": 4 } |]
+           `shouldRespondWith` [json| [{"id":3}] |]
+            { matchStatus = 206 -- it now knows the response is partial
+            , matchHeaders = ["Content-Range" <:> "0-0/2"]
+            }
+
+      it "returns proper json" $
+        post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`
+          [json| [ {"id": 3}, {"id":4} ] |]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns CSV" $
+        request methodPost "/rpc/getitemrange"
+                (acceptHdrs "text/csv")
+                [json| { "min": 2, "max": 4 } |]
+           `shouldRespondWith` "id\n3\n4"
+            { matchStatus = 200
+            , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
+            }
+
+    context "unknown function" $
+      it "returns 404" $
+        post "/rpc/fakefunc" [json| {} |] `shouldRespondWith` 404
+
+    context "shaping the response returned by a proc" $ do
+      it "returns a project" $
+        post "/rpc/getproject" [json| { "id": 1} |] `shouldRespondWith`
+          [str|[{"id":1,"name":"Windows 7","client_id":1}]|]
+
+      it "can filter proc results" $
+        post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id" [json| {} |] `shouldRespondWith`
+          [json|[{"id":2},{"id":3},{"id":4}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "can limit proc results" $
+        post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id?limit=2&offset=1" [json| {} |]
+          `shouldRespondWith` [json|[{"id":3},{"id":4}]|]
+             { matchStatus = 200
+             , matchHeaders = ["Content-Range" <:> "1-2/*"]
+             }
+
+      it "select works on the first level" $
+        post "/rpc/getproject?select=id,name" [json| { "id": 1} |] `shouldRespondWith`
+          [str|[{"id":1,"name":"Windows 7"}]|]
+
+    context "foreign entities embedding" $ do
+      it "can embed if related tables are in the exposed schema" $
+        post "/rpc/getproject?select=id,name,client{id},tasks{id}" [json| { "id": 1} |] `shouldRespondWith`
+          [str|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|]
+
+      it "cannot embed if the related table is not in the exposed schema" $
+        post "/rpc/single_article?select=*,article_stars{*}" [json|{ "id": 1}|]
+          `shouldRespondWith` 400
+
+      it "can embed if the related tables are in a hidden schema but exposed as views" $
+        post "/rpc/single_article?select=id,articleStars{userId}" [json|{ "id": 2}|]
+          `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+    context "a proc that returns an empty rowset" $
+      it "returns empty json array" $
+        post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith`
+          [json| [] |]
+          { matchHeaders = [matchContentTypeJson] }
+
+    context "proc return types" $ do
+      context "returns text" $ do
+        it "returns proper json" $
+          post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith`
+            [json|"Hello, world"|]
+            { matchHeaders = [matchContentTypeJson] }
+
+        it "can handle unicode" $
+          post "/rpc/sayhello" [json| { "name": "￥" } |] `shouldRespondWith`
+            [json|"Hello, ￥"|]
+            { matchHeaders = [matchContentTypeJson] }
+
+      it "returns array" $
+        post "/rpc/ret_array" [json|{}|] `shouldRespondWith`
+          [json|[1, 2, 3]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns setof integers" $
+        post "/rpc/ret_setof_integers" [json|{}|] `shouldRespondWith`
+          [json|[{ "ret_setof_integers": 1 },
+                 { "ret_setof_integers": 2 },
+                 { "ret_setof_integers": 3 }]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns enum value" $
+        post "/rpc/ret_enum" [json|{ "val": "foo" }|] `shouldRespondWith`
+          [json|"foo"|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns domain value" $
+        post "/rpc/ret_domain" [json|{ "val": "8" }|] `shouldRespondWith`
+          [json|8|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns range" $
+        post "/rpc/ret_range" [json|{ "low": 10, "up": 20 }|] `shouldRespondWith`
+          [json|"[10,20)"|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns row of scalars" $
+        post "/rpc/ret_scalars" [json|{}|] `shouldRespondWith`
+          [json|[{"a":"scalars", "b":"foo", "c":1, "d":"[10,20)"}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns composite type in exposed schema" $
+        post "/rpc/ret_point_2d" [json|{}|] `shouldRespondWith`
+          [json|[{"x": 10, "y": 5}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "cannot return composite type in hidden schema" $
+        post "/rpc/ret_point_3d" [json|{}|] `shouldRespondWith` 401
+
+      it "returns single row from table" $
+        post "/rpc/single_article?select=id" [json|{"id": 2}|] `shouldRespondWith`
+          [json|[{"id": 2}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "returns null for void" $
+        post "/rpc/ret_void" [json|{}|] `shouldRespondWith`
+          [json|null|]
+          { matchHeaders = [matchContentTypeJson] }
+
+    context "improper input" $ do
+      it "rejects unknown content type even if payload is good" $
+        request methodPost "/rpc/sayhello"
+          (acceptHdrs "audio/mpeg3") [json| { "name": "world" } |]
+            `shouldRespondWith` 415
+      it "rejects malformed json payload" $ do
+        p <- request methodPost "/rpc/sayhello"
+          (acceptHdrs "application/json") "sdfsdf"
+        liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
+          isErrorFormat (simpleBody p) `shouldBe` True
+      it "treats simple plpgsql raise as invalid input" $ do
+        p <- post "/rpc/problem" "{}"
+        liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "unsupported verbs" $ do
+      it "DELETE fails" $
+        request methodDelete "/rpc/sayhello" [] ""
+          `shouldRespondWith` 405
+      it "PATCH fails" $
+        request methodPatch "/rpc/sayhello" [] ""
+          `shouldRespondWith` 405
+      it "OPTIONS fails" $
+        -- TODO: should return info about the function
+        request methodOptions "/rpc/sayhello" [] ""
+          `shouldRespondWith` 405
+      it "GET fails with 405 on unknown procs" $
+        -- TODO: should this be 404?
+        get "/rpc/fake" `shouldRespondWith` 405
+      it "GET with 405 on known procs" $
+        get "/rpc/sayhello" `shouldRespondWith` 405
+
+    it "executes the proc exactly once per request" $ do
+      post "/rpc/callcounter" [json| {} |] `shouldRespondWith`
+        [json|1|]
+        { matchHeaders = [matchContentTypeJson] }
+      post "/rpc/callcounter" [json| {} |] `shouldRespondWith`
+        [json|2|]
+        { matchHeaders = [matchContentTypeJson] }
+
+    context "expects a single json object" $ do
+      it "does not expand posted json into parameters" $
+        request methodPost "/rpc/singlejsonparam"
+          [("Prefer","params=single-object")] [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] `shouldRespondWith`
+          [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "accepts parameters from an html form" $
+        request methodPost "/rpc/singlejsonparam"
+          [("Prefer","params=single-object"),("Content-Type", "application/x-www-form-urlencoded")]
+          ("integer=7&double=2.71828&varchar=forms+are+fun&" <>
+           "boolean=false&date=1900-01-01&money=$3.99&enum=foo") `shouldRespondWith`
+          [json| { "integer": "7", "double": "2.71828", "varchar" : "forms are fun"
+                 , "boolean":"false", "date":"1900-01-01", "money":"$3.99", "enum":"foo" } |]
+                 { matchHeaders = [matchContentTypeJson] }
+
+    context "a proc that receives no parameters" $
+      it "interprets empty string as empty json object on a post request" $
+        post "/rpc/noparamsproc" BL.empty `shouldRespondWith`
+          [json| "Return value of no parameters procedure." |]
+          { matchHeaders = [matchContentTypeJson] }
+
+    it "returns proper output when having the same return col name as the proc name" $
+      post "/rpc/test" [json|{}|] `shouldRespondWith`
+        [json|[{"test":"hello","value":1}]|] { matchHeaders = [matchContentTypeJson] }
+
+  describe "weird requests" $ do
+    it "can query as normal" $ do
+      get "/Escap3e;" `shouldRespondWith`
+        [json| [{"so6meIdColumn":1},{"so6meIdColumn":2},{"so6meIdColumn":3},{"so6meIdColumn":4},{"so6meIdColumn":5}] |]
+        { matchHeaders = [matchContentTypeJson] }
+      get "/ghostBusters" `shouldRespondWith`
+        [json| [{"escapeId":1},{"escapeId":3},{"escapeId":5}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "fails if an operator is not given" $
+      get "/ghostBusters?id=0" `shouldRespondWith` [json| {"details":"unexpected \"0\" expecting \"not\" or operator (eq, gt, ...)","message":"\"failed to parse filter (0)\" (line 1, column 1)"} |]
+        { matchStatus  = 400
+        , matchHeaders = [matchContentTypeJson]
+        }
+
+    it "will embed a collection" $
+      get "/Escap3e;?select=ghostBusters{*}" `shouldRespondWith`
+        [json| [{"ghostBusters":[{"escapeId":1}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":3}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":5}]}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "will embed using a column" $
+      get "/ghostBusters?select=escapeId{*}" `shouldRespondWith`
+        [json| [{"escapeId":{"so6meIdColumn":1}},{"escapeId":{"so6meIdColumn":3}},{"escapeId":{"so6meIdColumn":5}}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+  describe "binary output" $ do
+    context "on GET" $ do
+      it "can query if a single column is selected" $
+        request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") ""
+          `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"
+          { matchStatus = 200
+          , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]
+          }
+
+      it "fails if a single column is not selected" $ do
+        request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") ""
+          `shouldRespondWith` 406
+        request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") ""
+          `shouldRespondWith` 406
+        request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") ""
+          `shouldRespondWith` 406
+
+      it "concatenates results if more than one row is returned" $
+        request methodGet "/images_base64?select=img&name=in.A.png,B.png" (acceptHdrs "application/octet-stream") ""
+          `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="
+          { matchStatus = 200
+          , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]
+          }
+
+    context "on RPC" $ do
+      context "Proc that returns scalar" $
+        it "can query without selecting column" $
+          request methodPost "/rpc/ret_base64_bin" (acceptHdrs "application/octet-stream") ""
+            `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"
+            { matchStatus = 200
+            , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]
+            }
+
+      context "Proc that returns rows" $ do
+        it "can query if a single column is selected" $
+          request methodPost "/rpc/ret_rows_with_base64_bin?select=img" (acceptHdrs "application/octet-stream") ""
+            `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="
+            { matchStatus = 200
+            , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]
+            }
+
+        it "fails if a single column is not selected" $
+          request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") ""
+            `shouldRespondWith` 406
+
+  describe "HTTP request env vars" $ do
+    it "custom header is set" $
+      request methodPost "/rpc/get_guc_value"
+                [("Custom-Header", "test")]
+          [json| { "name": "request.header.custom-header" } |]
+          `shouldRespondWith`
+          [str|"test"|]
+          { matchStatus  = 200
+          , matchHeaders = [ matchContentTypeJson ]
+          }
+    it "standard header is set" $
+      request methodPost "/rpc/get_guc_value"
+                [("Origin", "http://example.com")]
+          [json| { "name": "request.header.origin" } |]
+          `shouldRespondWith`
+          [str|"http://example.com"|]
+          { matchStatus  = 200
+          , matchHeaders = [ matchContentTypeJson ]
+          }
+    it "current role is available as GUC claim" $
+      request methodPost "/rpc/get_guc_value" []
+          [json| { "name": "request.jwt.claim.role" } |]
+          `shouldRespondWith`
+          [str|"postgrest_test_anonymous"|]
+          { matchStatus  = 200
+          , matchHeaders = [ matchContentTypeJson ]
+          }
+    it "single cookie ends up as claims" $
+      request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue")]
+        [json| {"name":"request.cookie.acookie"} |]
+          `shouldRespondWith`
+          [str|"cookievalue"|]
+          { matchStatus = 200
+          , matchHeaders = []
+          }
+
+    it "multiple cookies ends up as claims" $
+      request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue;secondcookie=anothervalue")]
+        [json| {"name":"request.cookie.secondcookie"} |]
+          `shouldRespondWith`
+          [str|"anothervalue"|]
+          { matchStatus = 200
+          , matchHeaders = []
+          }
+
+  describe "values with quotes in IN and NOTIN operators" $ do
+    it "succeeds when only quoted values are present" $ do
+      get "/w_or_wo_comma_names?name=in.\"Hebdon, John\"" `shouldRespondWith`
+        [json| [{"name":"Hebdon, John"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+      get "/w_or_wo_comma_names?name=in.\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\"" `shouldRespondWith`
+        [json| [{"name":"Hebdon, John"},{"name":"Williams, Mary"},{"name":"Smith, Joseph"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+      get "/w_or_wo_comma_names?name=notin.\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\"" `shouldRespondWith`
+        [json| [{"name":"David White"},{"name":"Larry Thompson"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+      get "/w_or_wo_comma_names?name=not.in.\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\"" `shouldRespondWith`
+        [json| [{"name":"David White"},{"name":"Larry Thompson"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "succeeds w/ and w/o quoted values" $ do
+      get "/w_or_wo_comma_names?name=in.David White,\"Hebdon, John\"" `shouldRespondWith`
+        [json| [{"name":"Hebdon, John"},{"name":"David White"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+      get "/w_or_wo_comma_names?name=not.in.\"Hebdon, John\",Larry Thompson,\"Smith, Joseph\"" `shouldRespondWith`
+        [json| [{"name":"Williams, Mary"},{"name":"David White"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+      get "/w_or_wo_comma_names?name=notin.\"Hebdon, John\",David White,\"Williams, Mary\",Larry Thompson" `shouldRespondWith`
+        [json| [{"name":"Smith, Joseph"}] |]
+        { matchHeaders = [matchContentTypeJson] }
+
+    it "checks well formed quoted values" $ do
+      get "/w_or_wo_comma_names?name=in.\"\"Hebdon, John\"" `shouldRespondWith`
+        [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      get "/w_or_wo_comma_names?name=in.\"\"Hebdon, John\"\"Mary" `shouldRespondWith`
+        [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      get "/w_or_wo_comma_names?name=in.Williams\"Hebdon, John\"" `shouldRespondWith`
+        [json| [] |] { matchHeaders = [matchContentTypeJson] }
+
+  describe "IN and NOT IN empty set" $ do
+    context "returns an empty result for IN when no value is present" $ do
+      it "works for integer" $
+        get "/items_with_different_col_types?int_data=in." `shouldRespondWith`
+          [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      it "works for text" $
+        get "/items_with_different_col_types?text_data=in." `shouldRespondWith`
+          [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      it "works for bool" $
+        get "/items_with_different_col_types?bool_data=in." `shouldRespondWith`
+          [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      it "works for bytea" $
+        get "/items_with_different_col_types?bin_data=in." `shouldRespondWith`
+          [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      it "works for char" $
+        get "/items_with_different_col_types?char_data=in." `shouldRespondWith`
+          [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      it "works for date" $
+        get "/items_with_different_col_types?date_data=in." `shouldRespondWith`
+          [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      it "works for real" $
+        get "/items_with_different_col_types?real_data=in." `shouldRespondWith`
+          [json| [] |] { matchHeaders = [matchContentTypeJson] }
+      it "works for time" $
+        get "/items_with_different_col_types?time_data=in." `shouldRespondWith`
+          [json| [] |] { matchHeaders = [matchContentTypeJson] }
+
+    it "returns all results for notin when no value is present" $
+      get "/items_with_different_col_types?int_data=notin.&select=int_data" `shouldRespondWith`
+        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }
+
+    it "returns all results for not.in when no value is present" $
+      get "/items_with_different_col_types?int_data=not.in.&select=int_data" `shouldRespondWith`
+        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }
+
+    it "returns an empty result ignoring spaces" $
+      get "/items_with_different_col_types?int_data=in.    " `shouldRespondWith`
+        [json| [] |] { matchHeaders = [matchContentTypeJson] }
+
+    it "only returns an empty result set if the in value is empty" $
+      get "/items_with_different_col_types?int_data=in. ,3,4" `shouldRespondWith` 400
+
+    it "returns empty result when the in value is empty between parentheses" $
+      get "/items_with_different_col_types?int_data=in.()" `shouldRespondWith`
+        [json| [] |] { matchHeaders = [matchContentTypeJson] }
+
+    it "returns all results when the notin value is empty between parentheses" $ do
+      get "/items_with_different_col_types?int_data=notin.()&select=int_data" `shouldRespondWith`
+        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }
+      get "/items_with_different_col_types?int_data=not.in.()&select=int_data" `shouldRespondWith`
+        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }
+
+  describe "Transition to url safe characters" $ do
+    context "top level in operator" $ do
+      it "works with parentheses" $
+        get "/entities?id=in.(1,2,3)&select=id" `shouldRespondWith`
+          [json| [{"id": 1}, {"id": 2}, {"id": 3}] |] { matchHeaders = [matchContentTypeJson] }
+      it "works without parentheses" $
+        get "/entities?id=in.1,2,3&select=id" `shouldRespondWith`
+          [json| [{"id": 1}, {"id": 2}, {"id": 3}] |] { matchHeaders = [matchContentTypeJson] }
+
+    context "select query param" $ do
+      it "works with parentheses" $
+        get "/entities?id=eq.2&select=id,child_entities(id)" `shouldRespondWith`
+          [json| [{"id": 2, "child_entities": [{"id": 3}]}] |] { matchHeaders = [matchContentTypeJson] }
+      it "works with brackets" $
+        get "/entities?id=eq.2&select=id,child_entities{id}" `shouldRespondWith`
+          [json| [{"id": 2, "child_entities": [{"id": 3}]}] |] { matchHeaders = [matchContentTypeJson] }

test/Feature/RangeSpec.hs

@@ -2,21 +2,169 @@ module Feature.RangeSpec where
 
 import Test.Hspec
 import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
 
+import qualified Data.ByteString.Lazy         as BL
+
 import SpecHelper
+import Text.Heredoc
+import Network.Wai (Application)
+
+import Protolude hiding (get)
+
+defaultRange :: BL.ByteString
+defaultRange = [json| { "min": 0, "max": 15 } |]
+
+emptyRange :: BL.ByteString
+emptyRange = [json| { "min": 2, "max": 2 } |]
+
+spec :: SpecWith Application
+spec = do
+  describe "POST /rpc/getitemrange" $ do
+    context "without range headers" $ do
+      context "with response under server size limit" $
+        it "returns whole range with status 200" $
+           post "/rpc/getitemrange" defaultRange `shouldRespondWith` 200
+
+      context "when I don't want the count" $ do
+        it "returns range Content-Range with */* for empty range" $
+          request methodPost "/rpc/getitemrange" [] emptyRange
+            `shouldRespondWith` [json| [] |] {matchHeaders = ["Content-Range" <:> "*/*"]}
+
+        it "returns range Content-Range with range/*" $
+          request methodPost "/rpc/getitemrange" [] defaultRange
+            `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
+            { matchHeaders = ["Content-Range" <:> "0-14/*"] }
+
+    context "with range headers" $ do
+
+      context "of acceptable range" $ do
+        it "succeeds with partial content" $ do
+          r <- request methodPost  "/rpc/getitemrange"
+                       (rangeHdrs $ ByteRangeFromTo 0 1) defaultRange
+          liftIO $ do
+            simpleHeaders r `shouldSatisfy`
+              matchHeader "Content-Range" "0-1/*"
+            simpleStatus r `shouldBe` ok200
+
+        it "understands open-ended ranges" $
+          request methodPost "/rpc/getitemrange"
+                  (rangeHdrs $ ByteRangeFrom 0) defaultRange
+            `shouldRespondWith` 200
+
+        it "returns an empty body when there are no results" $
+          request methodPost "/rpc/getitemrange"
+                  (rangeHdrs $ ByteRangeFromTo 0 1) emptyRange
+            `shouldRespondWith` "[]"
+            { matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "*/*"]
+            }
+
+        it "allows one-item requests" $ do
+          r <- request methodPost  "/rpc/getitemrange"
+                       (rangeHdrs $ ByteRangeFromTo 0 0) defaultRange
+          liftIO $ do
+            simpleHeaders r `shouldSatisfy`
+              matchHeader "Content-Range" "0-0/*"
+            simpleStatus r `shouldBe` ok200
+
+        it "handles ranges beyond collection length via truncation" $ do
+          r <- request methodPost  "/rpc/getitemrange"
+                       (rangeHdrs $ ByteRangeFromTo 10 100) defaultRange
+          liftIO $ do
+            simpleHeaders r `shouldSatisfy`
+              matchHeader "Content-Range" "10-14/*"
+            simpleStatus r `shouldBe` ok200
+
+      context "of invalid range" $ do
+        it "fails with 416 for offside range" $
+          request methodPost  "/rpc/getitemrange"
+                  (rangeHdrs $ ByteRangeFromTo 1 0) emptyRange
+            `shouldRespondWith` 416
+
+        it "refuses a range with nonzero start when there are no items" $
+          request methodPost "/rpc/getitemrange"
+                  (rangeHdrsWithCount $ ByteRangeFromTo 1 2) emptyRange
+            `shouldRespondWith` "[]"
+            { matchStatus  = 416
+            , matchHeaders = ["Content-Range" <:> "*/0"]
+            }
+
+        it "refuses a range requesting start past last item" $
+          request methodPost "/rpc/getitemrange"
+                  (rangeHdrsWithCount $ ByteRangeFromTo 100 199) defaultRange
+            `shouldRespondWith` "[]"
+            { matchStatus  = 416
+            , matchHeaders = ["Content-Range" <:> "*/15"]
+            }
 
-spec :: Spec
-spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items")
-  . around withApp $
   describe "GET /items" $ do
-
-    context "without range headers" $
+    context "without range headers" $ do
       context "with response under server size limit" $
         it "returns whole range with status 200" $
           get "/items" `shouldRespondWith` 200
 
+      context "when I don't want the count" $ do
+        it "returns range Content-Range with /*" $
+          request methodGet "/menagerie"
+                  [("Prefer", "count=none")] ""
+            `shouldRespondWith` "[]"
+            { matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "*/*"]
+            }
+
+        it "returns range Content-Range with range/*" $
+          request methodGet "/items?order=id"
+                  [("Prefer", "count=none")] ""
+            `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
+            { matchHeaders = ["Content-Range" <:> "0-14/*"] }
+
+        it "returns range Content-Range with range/* even using other filters" $
+          request methodGet "/items?id=eq.1&order=id"
+                  [("Prefer", "count=none")] ""
+            `shouldRespondWith` [json| [{"id":1}] |]
+            { matchHeaders = ["Content-Range" <:> "0-0/*"] }
+
+    context "with limit/offset parameters" $ do
+      it "no parameters return everything" $
+        get "/items?select=id&order=id.asc"
+          `shouldRespondWith`
+          [str|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-14/*"]
+          }
+      it "top level limit with parameter" $
+        get "/items?select=id&order=id.asc&limit=3"
+          `shouldRespondWith` [str|[{"id":1},{"id":2},{"id":3}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-2/*"]
+          }
+      it "headers override get parameters" $
+        request methodGet  "/items?select=id&order=id.asc&limit=3"
+                     (rangeHdrs $ ByteRangeFromTo 0 1) ""
+          `shouldRespondWith` [str|[{"id":1},{"id":2}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-1/*"]
+          }
+
+      it "limit works on all levels" $
+        get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=2&projects.tasks.order=id.asc&projects.tasks.limit=1"
+          `shouldRespondWith`
+          [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1}]},{"id":2,"tasks":[{"id":3}]}]}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-0/*"]
+          }
+
+
+      it "limit and offset works on first level" $
+        get "/items?select=id&order=id.asc&limit=3&offset=2"
+          `shouldRespondWith` [str|[{"id":3},{"id":4},{"id":5}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "2-4/*"]
+          }
+
     context "with range headers" $ do
 
       context "of acceptable range" $ do
@@ -25,8 +173,8 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
                        (rangeHdrs $ ByteRangeFromTo 0 1) ""
           liftIO $ do
             simpleHeaders r `shouldSatisfy`
-              matchHeader "Content-Range" "0-1/15"
-            simpleStatus r `shouldBe` partialContent206
+              matchHeader "Content-Range" "0-1/*"
+            simpleStatus r `shouldBe` ok200
 
         it "understands open-ended ranges" $
           request methodGet "/items"
@@ -36,10 +184,9 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
         it "returns an empty body when there are no results" $
           request methodGet "/menagerie"
                   (rangeHdrs $ ByteRangeFromTo 0 1) ""
-            `shouldRespondWith` ResponseMatcher {
-              matchBody    = Just "[]"
-            , matchStatus  = 200
-            , matchHeaders = ["Content-Range" <:> "*/0"]
+            `shouldRespondWith` "[]"
+            { matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "*/*"]
             }
 
         it "allows one-item requests" $ do
@@ -47,16 +194,16 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
                        (rangeHdrs $ ByteRangeFromTo 0 0) ""
           liftIO $ do
             simpleHeaders r `shouldSatisfy`
-              matchHeader "Content-Range" "0-0/15"
-            simpleStatus r `shouldBe` partialContent206
+              matchHeader "Content-Range" "0-0/*"
+            simpleStatus r `shouldBe` ok200
 
         it "handles ranges beyond collection length via truncation" $ do
           r <- request methodGet  "/items"
                        (rangeHdrs $ ByteRangeFromTo 10 100) ""
           liftIO $ do
             simpleHeaders r `shouldSatisfy`
-              matchHeader "Content-Range" "10-14/15"
-            simpleStatus r `shouldBe` partialContent206
+              matchHeader "Content-Range" "10-14/*"
+            simpleStatus r `shouldBe` ok200
 
       context "of invalid range" $ do
         it "fails with 416 for offside range" $
@@ -66,18 +213,16 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
 
         it "refuses a range with nonzero start when there are no items" $
           request methodGet "/menagerie"
-                  (rangeHdrs $ ByteRangeFromTo 1 2) ""
-            `shouldRespondWith` ResponseMatcher {
-              matchBody    = Nothing
-            , matchStatus  = 416
+                  (rangeHdrsWithCount $ ByteRangeFromTo 1 2) ""
+            `shouldRespondWith` "[]"
+            { matchStatus  = 416
             , matchHeaders = ["Content-Range" <:> "*/0"]
             }
 
         it "refuses a range requesting start past last item" $
           request methodGet "/items"
-                  (rangeHdrs $ ByteRangeFromTo 100 199) ""
-            `shouldRespondWith` ResponseMatcher {
-              matchBody    = Nothing
-            , matchStatus  = 416
+                  (rangeHdrsWithCount $ ByteRangeFromTo 100 199) ""
+            `shouldRespondWith` "[]"
+            { matchStatus  = 416
             , matchHeaders = ["Content-Range" <:> "*/15"]
             }

test/Feature/SingularSpec.hs

@@ -0,0 +1,193 @@
+module Feature.SingularSpec where
+
+import Text.Heredoc
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+import Network.HTTP.Types
+import Network.Wai.Test (SResponse(..))
+
+import Network.Wai (Application)
+
+import SpecHelper
+import Protolude hiding (get)
+
+
+spec :: SpecWith Application
+spec =
+  describe "Requesting singular json object" $ do
+    let pgrstObj = "application/vnd.pgrst.object+json"
+        singular = ("Accept", pgrstObj)
+
+    context "with GET request" $ do
+      it "fails for zero rows" $
+        request methodGet  "/items?id=gt.0&id=lt.0" [singular] ""
+          `shouldRespondWith` 406
+
+      it "will select an existing object" $ do
+        request methodGet "/items?id=eq.5" [singular] ""
+          `shouldRespondWith` [str|{"id":5}|]
+        -- also test without the +json suffix
+        request methodGet "/items?id=eq.5"
+          [("Accept", "application/vnd.pgrst.object")] ""
+          `shouldRespondWith` [str|{"id":5}|]
+
+      it "can combine multiple prefer values" $
+        request methodGet "/items?id=eq.5" [singular, ("Prefer","count=none")] ""
+          `shouldRespondWith` [str|{"id":5}|]
+
+      it "can shape plurality singular object routes" $
+        request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [singular] ""
+          `shouldRespondWith`
+            [str|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|]
+
+    context "when updating rows" $ do
+
+      it "works for one row" $ do
+        _ <- post "/addresses" [json| { id: 97, address: "A Street" } |]
+        request methodPatch
+          "/addresses?id=eq.97"
+          [("Prefer", "return=representation"), singular]
+          [json| { address: "B Street" } |]
+          `shouldRespondWith`
+            [str|{"id":97,"address":"B Street"}|]
+
+      it "raises an error for multiple rows" $ do
+        _ <- post "/addresses" [json| { id: 98, address: "xxx" } |]
+        _ <- post "/addresses" [json| { id: 99, address: "yyy" } |]
+        p <- request methodPatch
+          "/addresses?id=gt.0"
+          [("Prefer", "return=representation"), singular]
+          [json| { address: "zzz" } |]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+        -- the rows should not be updated, either
+        get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|]
+
+      it "raises an error for zero rows" $ do
+        p <- request methodPatch  "/items?id=gt.0&id=lt.0"
+          [("Prefer", "return=representation"), singular] [json|{"id":1}|]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "when creating rows" $ do
+
+      it "works for one row" $ do
+        p <- request methodPost
+          "/addresses"
+          [("Prefer", "return=representation"), singular]
+          [json| [ { id: 100, address: "xxx" } ] |]
+        liftIO $ simpleBody p `shouldBe` [str|{"id":100,"address":"xxx"}|]
+
+      it "works for one row even with return=minimal" $ do
+        request methodPost "/addresses"
+          [("Prefer", "return=minimal"), singular]
+          [json| [ { id: 101, address: "xxx" } ] |]
+          `shouldRespondWith` ""
+          { matchStatus  = 201
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+        -- and the element should exist
+        get "/addresses?id=eq.101"
+          `shouldRespondWith` [str|[{"id":101,"address":"xxx"}]|]
+          { matchStatus  = 200
+          , matchHeaders = []
+          }
+
+      it "raises an error when attempting to create multiple entities" $ do
+        p <- request methodPost
+          "/addresses"
+          [("Prefer", "return=representation"), singular]
+          [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]
+        liftIO $ simpleStatus p `shouldBe` notAcceptable406
+
+        -- the rows should not exist, either
+        get "/addresses?id=eq.200" `shouldRespondWith` "[]"
+
+      it "return=minimal allows request to create multiple elements" $
+        request methodPost "/addresses"
+          [("Prefer", "return=minimal"), singular]
+          [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]
+          `shouldRespondWith` ""
+          { matchStatus  = 201
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+      it "raises an error when creating zero entities" $ do
+        p <- request methodPost
+          "/addresses"
+          [("Prefer", "return=representation"), singular]
+          [json| [ ] |]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "when deleting rows" $ do
+
+      it "works for one row" $ do
+        p <- request methodDelete
+          "/items?id=eq.11"
+          [("Prefer", "return=representation"), singular] ""
+        liftIO $ simpleBody p `shouldBe` [str|{"id":11}|]
+
+      it "raises an error when attempting to delete multiple entities" $ do
+        let firstItems = "/items?id=gt.0&id=lt.11"
+        request methodDelete firstItems
+          [("Prefer", "return=representation"), singular] ""
+          `shouldRespondWith` 406
+
+        get firstItems
+          `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10}] |]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-9/*"]
+          }
+
+      it "raises an error when deleting zero entities" $ do
+        p <- request methodDelete "/items?id=lt.0"
+          [("Prefer", "return=representation"), singular] ""
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "when calling a stored proc" $ do
+
+      it "fails for zero rows" $ do
+        p <- request methodPost "/rpc/getproject"
+          [singular] [json|{ "id": 9999999}|]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+      -- this one may be controversial, should vnd.pgrst.object include
+      -- the likes of 2 and "hello?"
+      it "succeeds for scalar result" $
+        request methodPost "/rpc/sayhello"
+          [singular] [json|{ "name": "world"}|]
+          `shouldRespondWith` 200
+
+      it "returns a single object for json proc" $
+        request methodPost "/rpc/getproject"
+          [singular] [json|{ "id": 1}|] `shouldRespondWith`
+          [str|{"id":1,"name":"Windows 7","client_id":1}|]
+
+      it "fails for multiple rows" $ do
+        p <- request methodPost "/rpc/getallprojects" [singular] "{}"
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+      it "executes the proc exactly once per request" $ do
+        request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]
+          `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]
+        p <- request methodPost "/rpc/setprojects" [singular]
+          [json| {"id_l": 1, "id_h": 2, "name": "changed"} |]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+        -- should not actually have executed the function
+        request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]
+          `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]

test/Feature/StructureSpec.hs

@@ -2,189 +2,176 @@ module Feature.StructureSpec where
 
 import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
-import Test.Hspec.Wai.JSON
+import Network.HTTP.Types
+
+import Control.Lens ((^?))
+import Data.Aeson.Lens
+import Data.Aeson.QQ
 
 import SpecHelper
 
-import Network.HTTP.Types
+import Network.Wai (Application)
+import Network.Wai.Test (SResponse(..))
 
-spec :: Spec
-spec = around withApp $ do
-  describe "GET /" $ do
-    it "lists views in schema" $
-      request methodGet "/" [] ""
-        `shouldRespondWith` [json| [
-          {"schema":"1","name":"auto_incrementing_pk","insertable":true}
-        , {"schema":"1","name":"compound_pk","insertable":true}
-        , {"schema":"1","name":"has_fk","insertable":true}
-        , {"schema":"1","name":"items","insertable":true}
-        , {"schema":"1","name":"json","insertable":true}
-        , {"schema":"1","name":"menagerie","insertable":true}
-        , {"schema":"1","name":"no_pk","insertable":true}
-        , {"schema":"1","name":"simple_pk","insertable":true}
-        , {"schema":"1","name":"tsearch","insertable":true}
-        ] |]
-        {matchStatus = 200}
+import Protolude hiding (get)
 
-    it "lists only views user has permission to see" $ do
-      _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-      let auth = authHeaderBasic "jdoe" "1234"
+spec :: SpecWith Application
+spec = do
 
-      request methodGet "/" [auth] ""
-        `shouldRespondWith` [json| [
-            {"schema":"1","name":"authors_only","insertable":true}
-        ] |]
-        {matchStatus = 200}
+  describe "OpenAPI" $ do
+    it "root path returns a valid openapi spec" $
+      validateOpenApiResponse [("Accept", "application/openapi+json")]
 
+    it "should respond to openapi request on none root path with 415" $
+      request methodGet "/items"
+              (acceptHdrs "application/openapi+json") ""
+        `shouldRespondWith` 415
 
-  describe "Table info" $ do
-    it "is available with OPTIONS verb" $
-      request methodOptions "/menagerie" [] "" `shouldRespondWith`
-      [json|
-      {
-        "pkey":["integer"],
-        "columns":[
-          {
-            "default": null,
-            "precision": 32,
-            "updatable": true,
-            "schema": "1",
-            "name": "integer",
-            "type": "integer",
-            "maxLen": null,
-            "enum": [],
-            "nullable": false,
-            "position": 1,
-            "references": null,
-            "default": null
-          }, {
-            "default": null,
-            "precision": 53,
-            "updatable": true,
-            "schema": "1",
-            "name": "double",
-            "type": "double precision",
-            "maxLen": null,
-            "enum": [],
-            "nullable": false,
-            "references": null,
-            "position": 2
-          }, {
-            "default": null,
-            "precision": null,
-            "updatable": true,
-            "schema": "1",
-            "name": "varchar",
-            "type": "character varying",
-            "maxLen": null,
-            "enum": [],
-            "nullable": false,
-            "position": 3,
-            "references": null,
-            "default": null
-          }, {
-            "default": null,
-            "precision": null,
-            "updatable": true,
-            "schema": "1",
-            "name": "boolean",
-            "type": "boolean",
-            "maxLen": null,
-            "enum": [],
-            "nullable": false,
-            "references": null,
-            "position": 4
-          }, {
-            "default": null,
-            "precision": null,
-            "updatable": true,
-            "schema": "1",
-            "name": "date",
-            "type": "date",
-            "maxLen": null,
-            "enum": [],
-            "nullable": false,
-            "references": null,
-            "position": 5
-          }, {
-            "default": null,
-            "precision": null,
-            "updatable": true,
-            "schema": "1",
-            "name": "money",
-            "type": "money",
-            "maxLen": null,
-            "enum": [],
-            "nullable": false,
-            "position": 6,
-            "references": null,
-            "default": null
-          }, {
-            "default": null,
-            "precision": null,
-            "updatable": true,
-            "schema": "1",
-            "name": "enum",
-            "type": "USER-DEFINED",
-            "maxLen": null,
-            "enum": [
-              "foo",
-              "bar"
-            ],
-            "nullable": false,
-            "position": 7,
-            "references": null,
-            "default": null
-          }
-        ]
-      }
-      |]
+    describe "table" $
 
-    it "includes foreign key data" $ do
-      pendingWith "have to resolve issue #107"
+      it "includes paths to tables" $ do
+        r <- simpleBody <$> get "/"
 
-      request methodOptions "/has_fk" [] ""
-        `shouldRespondWith` [json|
-      {
-        "pkey": ["id"],
-        "columns":[
-          {
-            "default": "nextval('\"1\".has_fk_id_seq'::regclass)",
-            "precision": 64,
-            "updatable": true,
-            "schema": "1",
-            "name": "id",
-            "type": "bigint",
-            "maxLen": null,
-            "nullable": false,
-            "position": 1,
-            "enum": [],
-            "references": null
-          }, {
-            "default": null,
-            "precision": 32,
-            "updatable": true,
-            "schema": "1",
-            "name": "auto_inc_fk",
-            "type": "integer",
-            "maxLen": null,
-            "nullable": true,
-            "position": 2,
-            "enum": [],
-            "references": {"table": "auto_incrementing_pk", "column": "id"}
-          }, {
-            "default": null,
-            "precision": null,
-            "updatable": true,
-            "schema": "1",
-            "name": "simple_fk",
-            "type": "character varying",
-            "maxLen": 255,
-            "nullable": true,
-            "position": 3,
-            "enum": [],
-            "references": {"table": "simple_pk", "column": "k"}
-          }
-        ]
-      }
-      |]
+        let method s = key "paths" . key "/child_entities" . key s
+            childGetSummary = r ^? method "get" . key "summary"
+            childGetDescription = r ^? method "get" . key "description"
+            getParameters = r ^? method "get" . key "parameters"
+            postResponse = r ^? method "post" . key "responses" . key "201" . key "description"
+            patchResponse = r ^? method "patch" . key "responses" . key "204" . key "description"
+            deleteResponse = r ^? method "delete" . key "responses" . key "204" . key "description"
+
+        let grandChildGet s = key "paths" . key "/grandchild_entities" . key "get" . key s
+            grandChildGetSummary = r ^? grandChildGet "summary"
+            grandChildGetDescription = r ^? grandChildGet "description"
+
+        liftIO $ do
+
+          childGetSummary `shouldBe` Just "child_entities comment"
+
+          childGetDescription `shouldBe` Nothing
+
+          grandChildGetSummary `shouldBe` Just "grandchild_entities summary"
+
+          grandChildGetDescription `shouldBe` Just "grandchild_entities description\nthat spans\nmultiple lines"
+
+          getParameters `shouldBe` Just
+            [aesonQQ|
+              [
+                { "$ref": "#/parameters/rowFilter.child_entities.id" },
+                { "$ref": "#/parameters/rowFilter.child_entities.name" },
+                { "$ref": "#/parameters/rowFilter.child_entities.parent_id" },
+                { "$ref": "#/parameters/select" },
+                { "$ref": "#/parameters/order" },
+                { "$ref": "#/parameters/range" },
+                { "$ref": "#/parameters/rangeUnit" },
+                { "$ref": "#/parameters/offset" },
+                { "$ref": "#/parameters/limit" },
+                { "$ref": "#/parameters/preferCount" }
+              ]
+            |]
+
+          postResponse `shouldBe` Just "Created"
+
+          patchResponse `shouldBe` Just "No Content"
+
+          deleteResponse `shouldBe` Just "No Content"
+
+    it "includes definitions to tables" $ do
+        r <- simpleBody <$> get "/"
+
+        let def = r ^? key "definitions" . key "child_entities"
+
+        liftIO $
+
+          def `shouldBe` Just
+            [aesonQQ|
+              {
+                "type": "object",
+                "description": "child_entities comment",
+                "properties": {
+                  "id": {
+                    "description": "child_entities id comment\n\nNote:\nThis is a Primary Key.<pk/>",
+                    "format": "integer",
+                    "type": "integer"
+                  },
+                  "name": {
+                    "description": "child_entities name comment",
+                    "format": "text",
+                    "type": "string"
+                  },
+                  "parent_id": {
+                    "description": "Note:\nThis is a Foreign Key to `entities.id`.<fk table='entities' column='id'/>",
+                    "format": "integer",
+                    "type": "integer"
+                  }
+                }
+              }
+            |]
+
+    describe "RPC" $
+
+      it "includes body schema for arguments" $ do
+        r <- simpleBody <$> get "/"
+        let args = r ^? key "paths" . key "/rpc/varied_arguments"
+                      . key "post"  . key "parameters"
+                      . nth 0       . key "schema"
+
+        liftIO $
+          args `shouldBe` Just
+            [aesonQQ|
+              {
+                "required": [
+                  "double",
+                  "varchar",
+                  "boolean",
+                  "date",
+                  "money",
+                  "enum"
+                ],
+                "properties": {
+                  "double": {
+                    "format": "double precision",
+                    "type": "string"
+                  },
+                  "varchar": {
+                    "format": "character varying",
+                    "type": "string"
+                  },
+                  "boolean": {
+                    "format": "boolean",
+                    "type": "boolean"
+                  },
+                  "date": {
+                    "format": "date",
+                    "type": "string"
+                  },
+                  "money": {
+                    "format": "money",
+                    "type": "string"
+                  },
+                  "enum": {
+                    "format": "test.enum_menagerie_type",
+                    "type": "string"
+                  },
+                  "integer": {
+                    "format": "integer",
+                    "type": "integer"
+                  }
+                },
+                "type": "object"
+              }
+            |]
+
+  describe "Allow header" $ do
+
+    it "includes read/write verbs for writeable table" $ do
+      r <- request methodOptions "/items" [] ""
+      liftIO $
+        simpleHeaders r `shouldSatisfy`
+          matchHeader "Allow" "GET,POST,PATCH,DELETE"
+
+    it "includes read verbs for read-only table" $ do
+      r <- request methodOptions "/has_count_column" [] ""
+      liftIO $
+        simpleHeaders r `shouldSatisfy`
+          matchHeader "Allow" "GET"

test/Feature/UnicodeSpec.hs

@@ -0,0 +1,25 @@
+module Feature.UnicodeSpec where
+
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+import Network.Wai (Application)
+import Control.Monad (void)
+
+import SpecHelper
+
+import Protolude hiding (get)
+
+spec :: SpecWith Application
+spec =
+  describe "Reading and writing to unicode schema and table names" $
+    it "Can read and write values" $ do
+      get "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"
+        `shouldRespondWith` "[]"
+
+      void $ post "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"
+        [json| { "هویت": 1 } |]
+
+      get "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF"
+        `shouldRespondWith` [json| [{ "هویت": 1 }] |]
+        { matchHeaders = [matchContentTypeJson] }

test/Main.hs

@@ -2,7 +2,88 @@ module Main where
 
 import Test.Hspec
 import SpecHelper
-import Spec
+
+import qualified Hasql.Pool as P
+
+import PostgREST.DbStructure (getDbStructure)
+import PostgREST.App (postgrest)
+import Data.Function (id)
+import Data.IORef
+
+import qualified Feature.AuthSpec
+import qualified Feature.AsymmetricJwtSpec
+import qualified Feature.BinaryJwtSecretSpec
+import qualified Feature.ConcurrentSpec
+import qualified Feature.CorsSpec
+import qualified Feature.DeleteSpec
+import qualified Feature.InsertSpec
+import qualified Feature.NoJwtSpec
+import qualified Feature.QueryLimitedSpec
+import qualified Feature.QuerySpec
+import qualified Feature.RangeSpec
+import qualified Feature.StructureSpec
+import qualified Feature.SingularSpec
+import qualified Feature.UnicodeSpec
+import qualified Feature.ProxySpec
+import qualified Feature.AndOrParamsSpec
+
+import Protolude
 
 main :: IO ()
-main = resetDb >> hspec spec
+main = do
+  testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test"
+  setupDb testDbConn
+
+  pool <- P.acquire (3, 10, toS testDbConn)
+
+  result <- P.use pool $ getDbStructure "test"
+  refDbStructure <- newIORef $ Just $ either (panic.show) id result
+  let withApp      = return $ postgrest (testCfg testDbConn)          refDbStructure pool $ pure ()
+      ltdApp       = return $ postgrest (testLtdRowsCfg testDbConn)   refDbStructure pool $ pure ()
+      unicodeApp   = return $ postgrest (testUnicodeCfg testDbConn)   refDbStructure pool $ pure ()
+      proxyApp     = return $ postgrest (testProxyCfg testDbConn)     refDbStructure pool $ pure ()
+      noJwtApp     = return $ postgrest (testCfgNoJWT testDbConn)     refDbStructure pool $ pure ()
+      binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool $ pure ()
+      asymJwkApp   = return $ postgrest (testCfgAsymJWK testDbConn)   refDbStructure pool $ pure ()
+
+  let reset = resetDb testDbConn
+  hspec $ do
+    mapM_ (beforeAll_ reset . before withApp) specs
+
+    -- this test runs with a different server flag
+    beforeAll_ reset . before ltdApp $
+      describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec
+
+    -- this test runs with a different schema
+    beforeAll_ reset . before unicodeApp $
+      describe "Feature.UnicodeSpec" Feature.UnicodeSpec.spec
+
+    -- this test runs with a proxy
+    beforeAll_ reset . before proxyApp $
+      describe "Feature.ProxySpec" Feature.ProxySpec.spec
+
+    -- this test runs without a JWT secret
+    beforeAll_ reset . before noJwtApp $
+      describe "Feature.NoJwtSpec" Feature.NoJwtSpec.spec
+
+    -- this test runs with a binary JWT secret
+    beforeAll_ reset . before binaryJwtApp $
+      describe "Feature.BinaryJwtSecretSpec" Feature.BinaryJwtSecretSpec.spec
+
+    -- this test runs with asymmetric JWK
+    beforeAll_ reset . before asymJwkApp $
+      describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec
+
+ where
+  specs = map (uncurry describe) [
+      ("Feature.AuthSpec"         , Feature.AuthSpec.spec)
+    , ("Feature.ConcurrentSpec"   , Feature.ConcurrentSpec.spec)
+    , ("Feature.CorsSpec"         , Feature.CorsSpec.spec)
+    , ("Feature.DeleteSpec"       , Feature.DeleteSpec.spec)
+    , ("Feature.InsertSpec"       , Feature.InsertSpec.spec)
+    , ("Feature.QuerySpec"        , Feature.QuerySpec.spec)
+    , ("Feature.RangeSpec"        , Feature.RangeSpec.spec)
+    , ("Feature.SingularSpec"     , Feature.SingularSpec.spec)
+    , ("Feature.StructureSpec"    , Feature.StructureSpec.spec)
+    , ("Feature.AndOrParamsSpec"  , Feature.AndOrParamsSpec.spec)
+    ]

test/Spec.hs

@@ -1 +0,0 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}

test/SpecHelper.hs

@@ -1,146 +1,154 @@
 module SpecHelper where
 
-import Network.Wai
-import Test.Hspec
-import Test.Hspec.Wai
-
-import Hasql as H
-import Hasql.Backend as B
-import Hasql.Postgres as P
-
-import Data.String.Conversions (cs)
-import Data.Monoid
-import Data.Text hiding (map)
-import qualified Data.Vector as V
 import Control.Monad (void)
 
-import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
-                                  hRange, hAuthorization)
-import Codec.Binary.Base64.String (encode)
+import qualified System.IO.Error as E
+import System.Environment (getEnv)
+
+import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient)
 import Data.CaseInsensitive (CI(..))
-import Data.Maybe (fromMaybe)
+import qualified Data.Set as S
+import qualified Data.Map.Strict as M
+import Data.List (lookup)
 import Text.Regex.TDFA ((=~))
 import qualified Data.ByteString.Char8 as BS
-import Network.Wai.Middleware.Cors (cors)
-import System.Process (readProcess)
+import qualified Data.ByteString.Lazy as BL
+import           System.Process (readProcess)
+import           Text.Heredoc
 
-import qualified Data.Aeson.Types as J
+import PostgREST.Config (AppConfig(..))
 
-import PostgREST.App (app)
-import PostgREST.Config (AppConfig(..), corsPolicy)
-import PostgREST.Middleware
-import PostgREST.Error(errResponse)
+import Test.Hspec hiding (pendingWith)
+import Test.Hspec.Wai
 
-isLeft :: Either a b -> Bool
-isLeft (Left _ ) = True
-isLeft _ = False
+import Network.HTTP.Types
+import Network.Wai.Test (SResponse(simpleStatus, simpleHeaders, simpleBody))
 
-cfg :: AppConfig
-cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1" "safe"
+import Data.Maybe (fromJust)
+import Data.Aeson (decode, Value(..))
+import qualified JSONSchema.Draft4 as D4
 
-testPoolOpts :: PoolSettings
-testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
+import Protolude
 
-pgSettings :: P.Settings
-pgSettings = P.ParamSettings (cs $ configDbHost cfg)
-                             (fromIntegral $ configDbPort cfg)
-                             (cs $ configDbUser cfg)
-                             (cs $ configDbPass cfg)
-                             (cs $ configDbName cfg)
+matchContentTypeJson :: MatchHeader
+matchContentTypeJson = "Content-Type" <:> "application/json; charset=utf-8"
 
-withApp :: ActionWith Application -> IO ()
-withApp perform = do
-  pool :: H.Pool P.Postgres
-    <- H.acquirePool pgSettings testPoolOpts
+matchContentTypeSingular :: MatchHeader
+matchContentTypeSingular = "Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"
 
-  perform $ middle $ \req resp -> do
-    body <- strictRequestBody req
-    result <- liftIO $ H.session pool $ H.tx Nothing
-      $ authenticated cfg (app cfg body) req
-    either (resp . errResponse) resp result
+validateOpenApiResponse :: [Header] -> WaiSession ()
+validateOpenApiResponse headers = do
+  r <- request methodGet "/" headers ""
+  liftIO $
+    let respStatus = simpleStatus r in
+    respStatus `shouldSatisfy`
+      \s -> s == Status { statusCode = 200, statusMessage="OK" }
+  liftIO $
+    let respHeaders = simpleHeaders r in
+    respHeaders `shouldSatisfy`
+      \hs -> ("Content-Type", "application/openapi+json; charset=utf-8") `elem` hs
+  liftIO $
+    let respBody = simpleBody r
+        schema :: D4.Schema
+        schema = D4.emptySchema { D4._schemaRef = Just "openapi.json" }
+        schemaContext :: D4.SchemaWithURI D4.Schema
+        schemaContext = D4.SchemaWithURI
+          { D4._swSchema = schema
+          , D4._swURI    = Just "test/fixtures/openapi.json"
+          }
+       in
+       D4.fetchFilesystemAndValidate schemaContext ((fromJust . decode) respBody) `shouldReturn` Right ()
 
-  where middle = cors corsPolicy
+getEnvVarWithDefault :: Text -> Text -> IO Text
+getEnvVarWithDefault var def = do
+  varValue <- getEnv (toS var) `E.catchIOError` const (return $ toS def)
+  return $ toS varValue
 
+_baseCfg :: AppConfig
+_baseCfg =  -- Connection Settings
+  AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000
+            -- Jwt settings
+            (Just $ encodeUtf8 "reallyreallyreallyreallyverysafe") False
+            -- Connection Modifiers
+            10 Nothing (Just "test.switch_role")
+            -- Debug Settings
+            True
 
-resetDb :: IO ()
-resetDb = do
-  pool :: H.Pool P.Postgres
-    <- H.acquirePool pgSettings testPoolOpts
-  void . liftIO $ H.session pool $
-    H.tx Nothing $ do
-      H.unitEx [H.stmt| drop schema if exists "1" cascade |]
-      H.unitEx [H.stmt| drop schema if exists private cascade |]
-      H.unitEx [H.stmt| drop schema if exists postgrest cascade |]
+testCfg :: Text -> AppConfig
+testCfg testDbConn = _baseCfg { configDatabase = testDbConn }
 
-  loadFixture "roles"
-  loadFixture "schema"
+testCfgNoJWT :: Text -> AppConfig
+testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing }
 
+testUnicodeCfg :: Text -> AppConfig
+testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchema = "تست" }
 
-loadFixture :: FilePath -> IO()
-loadFixture name =
-  void $ readProcess "psql" ["-U", "postgrest_test", "-d", "postgrest_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []
+testLtdRowsCfg :: Text -> AppConfig
+testLtdRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 }
 
+testProxyCfg :: Text -> AppConfig
+testProxyCfg testDbConn = (testCfg testDbConn) { configProxyUri = Just "https://postgrest.com/openapi.json" }
+
+testCfgBinaryJWT :: Text -> AppConfig
+testCfgBinaryJWT testDbConn = (testCfg testDbConn) {
+    configJwtSecret = Just . B64.decodeLenient $
+      "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU="
+  }
+
+testCfgAsymJWK :: Text -> AppConfig
+testCfgAsymJWK testDbConn = (testCfg testDbConn) {
+    configJwtSecret = Just $ encodeUtf8
+      [str|{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}|]
+  }
+
+setupDb :: Text -> IO ()
+setupDb dbConn = do
+  loadFixture dbConn "database"
+  loadFixture dbConn "roles"
+  loadFixture dbConn "schema"
+  loadFixture dbConn "jwt"
+  loadFixture dbConn "privileges"
+  resetDb dbConn
+
+resetDb :: Text -> IO ()
+resetDb dbConn = loadFixture dbConn "data"
+
+loadFixture :: Text -> FilePath -> IO()
+loadFixture dbConn name =
+  void $ readProcess "psql" [toS dbConn, "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []
 
 rangeHdrs :: ByteRange -> [Header]
 rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]
 
+rangeHdrsWithCount :: ByteRange -> [Header]
+rangeHdrsWithCount r = ("Prefer", "count=exact") : rangeHdrs r
+
+acceptHdrs :: BS.ByteString -> [Header]
+acceptHdrs mime = [(hAccept, mime)]
+
 rangeUnit :: Header
 rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items")
 
-matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool
+matchHeader :: CI BS.ByteString -> BS.ByteString -> [Header] -> Bool
 matchHeader name valRegex headers =
   maybe False (=~ valRegex) $ lookup name headers
 
-authHeaderBasic :: String -> String -> Header
+authHeaderBasic :: BS.ByteString -> BS.ByteString -> Header
 authHeaderBasic u p =
-  (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
-  
-authHeaderJWT :: String -> Header
+  (hAuthorization, "Basic " <> (toS . B64.encode . toS $ u <> ":" <> p))
+
+authHeaderJWT :: BS.ByteString -> Header
 authHeaderJWT token =
-  (hAuthorization, cs $ "Bearer " ++ token)
+  (hAuthorization, "Bearer " <> token)
 
-testPool :: IO(H.Pool P.Postgres)
-testPool = H.acquirePool pgSettings testPoolOpts
-
-clearTable :: Text -> IO ()
-clearTable table = do
-  pool <- testPool
-  void . liftIO $ H.session pool $ H.tx Nothing $
-    H.unitEx $ B.Stmt ("delete from \"1\"."<>table) V.empty True
-
-createItems :: Int -> IO ()
-createItems n = do
-  pool <- testPool
-  void . liftIO $ H.session pool $ H.tx Nothing txn
-  where
-    txn = mapM_ H.unitEx stmts
-    stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n]
-
-createNulls :: Int -> IO ()
-createNulls n = do
-  pool <- testPool
-  void . liftIO $ H.session pool $ H.tx Nothing txn
-  where
-    txn = mapM_ H.unitEx (stmt':stmts)
-    stmt' = [H.stmt|insert into "1".no_pk (a,b) values (null,null)|]
-    stmts = map [H.stmt|insert into "1".no_pk (a,b) values (?,0)|] [1..n]
-
-createLikableStrings :: IO ()
-createLikableStrings = do
-  pool <- testPool
-  void . liftIO $ H.session pool $ H.tx Nothing $ do
-    H.unitEx $ insertSimplePk "xyyx" "u"
-    H.unitEx $ insertSimplePk "xYYx" "v"
-  where
-    insertSimplePk :: Text -> Text -> H.Stmt P.Postgres
-    insertSimplePk = [H.stmt|insert into "1".simple_pk (k, extra) values (?,?)|]
-
-createJsonData :: IO ()
-createJsonData = do
-  pool <- testPool
-  void . liftIO $ H.session pool $ H.tx Nothing $
-    H.unitEx $
-      [H.stmt|
-        insert into "1".json (data) values (?)
-      |]
-      (J.object [("foo", J.object [("bar", J.String "baz")])])
+-- | Tests whether the text can be parsed as a json object comtaining
+-- the key "message", and optional keys "details", "hint", "code",
+-- and no extraneous keys
+isErrorFormat :: BL.ByteString -> Bool
+isErrorFormat s =
+  "message" `S.member` keys &&
+    S.null (S.difference keys validKeys)
+ where
+  obj = decode s :: Maybe (M.Map Text Value)
+  keys = fromMaybe S.empty (M.keysSet <$> obj)
+  validKeys = S.fromList ["message", "details", "hint", "code"]

test/TestTypes.hs

@@ -1,23 +1,18 @@
 module TestTypes (
   IncPK(..)
 , CompoundPK(..)
--- , incFromList
--- , compoundFromList
 ) where
 
 import qualified Data.Aeson as JSON
 import Data.Aeson ((.:))
--- import Data.Maybe (fromJust)
-import Control.Applicative
-import Control.Monad (mzero)
 
-import Prelude
+import Protolude
 
 data IncPK = IncPK {
   incId :: Int
-, incNullableStr :: Maybe String
-, incStr :: String
-, incInsert :: String
+, incNullableStr :: Maybe Text
+, incStr :: Text
+, incInsert :: Text
 } deriving (Eq, Show)
 
 instance JSON.FromJSON IncPK where
@@ -28,18 +23,11 @@ instance JSON.FromJSON IncPK where
     r .: "inserted_at"
   parseJSON _ = mzero
 
--- incFromList :: [(String, SqlValue)] -> IncPK
--- incFromList row = IncPK
---   (fromSql . fromJust $ lookup "id" row)
---   (fromSql . fromJust $ lookup "nullable_string" row)
---   (fromSql . fromJust $ lookup "non_nullable_string" row)
---   (fromSql . fromJust $ lookup "inserted_at" row)
-
 data CompoundPK = CompoundPK {
   compoundK1 :: Int
-, compoundK2 :: Int
+, compoundK2 :: Text
 , compoundExtra :: Maybe Int
-}
+} deriving (Eq, Show)
 
 instance JSON.FromJSON CompoundPK where
   parseJSON (JSON.Object r) = CompoundPK <$>
@@ -47,9 +35,3 @@ instance JSON.FromJSON CompoundPK where
     r .: "k2" <*>
     r .: "extra"
   parseJSON _ = mzero
-
--- compoundFromList :: [(String, SqlValue)] -> CompoundPK
--- compoundFromList row = CompoundPK
---   (fromSql . fromJust $ lookup "k1" row)
---   (fromSql . fromJust $ lookup "k2" row)
---   (fromSql . fromJust $ lookup "extra" row)

test/Unit/DbStructureSpec.hx

@@ -1,7 +1,7 @@
-module Unit.PgStructureSpec where
+module Unit.DbStructureSpec where
 
 import Test.Hspec
-import PgStructure (Table(..), tables, Column(..), columns, ForeignKey(..),
+import DbStructure (Table(..), tables, Column(..), columns, ForeignKey(..),
   foreignKeys)
 
 import Database.HDBC (quickQuery)
@@ -12,25 +12,25 @@ spec :: Spec
 spec = around dbWithSchema $ beforeWith setRole $ do
   describe "tables" $
     it "shows all the tables" $ \conn -> do
-      ts <- tables "1" conn
+      ts <- tables "test" conn
       map tableName ts `shouldBe` ["authors_only","auto_incrementing_pk",
-        "compound_pk","has_fk","items","menagerie","no_pk", "simple_pk"]
+        "compound_pk","has_fk","insertable_view_with_join","items","menagerie","no_pk", "simple_pk"]
 
   describe "columns" $ do
     it "responds with each column for the table" $ \conn -> do
-      cs <- columns "1" "auto_incrementing_pk" conn
+      cs <- columns "test" "auto_incrementing_pk" conn
       map colName cs `shouldBe` ["id","nullable_string","non_nullable_string",
         "inserted_at"]
 
     it "includes foreign key data" $ \conn -> do
-      cs <- columns "1" "has_fk" conn
+      cs <- columns "test" "has_fk" conn
       map colFK cs `shouldBe` [Nothing,
         Just $ ForeignKey "auto_incrementing_pk" "id",
         Just $ ForeignKey "simple_pk" "k"]
 
   describe "foreignKeys" $
     it "has a description of the foreign key columns" $ \conn ->
-      foreignKeys "1" "has_fk" conn `shouldReturn` M.fromList [
+      foreignKeys "test" "has_fk" conn `shouldReturn` M.fromList [
         ("auto_inc_fk", ForeignKey {fkTable="auto_incrementing_pk", fkCol="id"}),
         ("simple_fk", ForeignKey { fkTable="simple_pk", fkCol="k"})]
 

test/Unit/PgQuerySpec.hx

@@ -32,7 +32,7 @@ spec = around dbWithSchema $ do
   describe "insert" $
     describe "with an auto-increment key" $ do
       it "inserts and responds with a full object description" $ \conn -> do
-        r <- insert "1" "auto_incrementing_pk" (SqlRow [
+        r <- insert "test" "auto_incrementing_pk" (SqlRow [
             ("non_nullable_string", toSql ("a string"::String))]) conn
         let returnRow = incFromList . toList $ r
         incStr returnRow `shouldBe` "a string"
@@ -43,24 +43,24 @@ spec = around dbWithSchema $ do
         [returnRow] `shouldBe` map incFromList tRows
 
       it "throws an exception if the PK is not unique" $ \conn -> do
-        r <- insert "1" "auto_incrementing_pk" (SqlRow [
+        r <- insert "test" "auto_incrementing_pk" (SqlRow [
             ("non_nullable_string", toSql ("a string"::String))]) conn
         let row = SqlRow .  map (Control.Arrow.first cs) . toList $ r
-        insert "1" "auto_incrementing_pk" row conn `shouldThrow` \e ->
+        insert "test" "auto_incrementing_pk" row conn `shouldThrow` \e ->
           seState e == "23505" -- uniqueness violation code
 
       it "throws an exception if a required value is missing" $ \conn ->
-        insert "1" "auto_incrementing_pk" (SqlRow [
+        insert "test" "auto_incrementing_pk" (SqlRow [
           ("nullable_string", toSql ("a string"::String))]) conn
           `shouldThrow` \e -> seState e == "23502"
 
       it "generates a default values query if no data is provided" $ \c -> do
-        r <- insert "1" "items" (SqlRow []) c
+        r <- insert "test" "items" (SqlRow []) c
         let [row] = toList r
         quickALQuery c "select * from \"1\".items where id = ?" [snd row]
           `shouldReturn` [[row]]
 
-  let {user = "jdoe"; pass = "secret"; role = "test_default_role"}
+  let {user = "jdoe"; pass = "secret"; role = "postgrest_test_default_role"}
   describe "addUser" $ do
     it "adds a correct user to the right table" $ \conn -> do
       addUser user pass role conn

test/create_test_db

@@ -0,0 +1,60 @@
+#! /bin/bash
+if [ -z "$1" ]
+  then
+    echo "Please supply the connection uri for the user with create database privileges"
+    exit -1
+fi
+
+if [ -z "$2" ]
+  then
+    echo "Please supply the test database name"
+    exit -1
+fi
+if [[ $1 != postgres://* ]]
+then
+  echo "Please use a valid connection URI (https://www.postgresql.org/docs/current/static/libpq-connect.html#AEN45347)"
+  exit -1
+fi
+
+BASEPATH=$( cd $(dirname $0) ; pwd -P )
+URI="$1"
+#Extract host and port--we need this to form the new connection string
+HOST_PORT=$(echo $URI | cut -d'/' -f3 | cut -d'@' -f2 )
+DB=$2
+# Specify the username of choice, or let the script create a random unique user by appending the database name
+TEST_USER_NAME=postgrest_test_authenticator
+# New password will get assigned only if the user does not already exist
+# Otherwise make sure to provide the correct password for the existing user
+TEST_USER_PASS=$(cat /dev/urandom | env LC_CTYPE=C tr -dc 'a-zA-Z0-9' | fold -w 16 | head -n 1)
+
+PGOPTIONS='-c client_min_messages=WARNING' psql "$URI" -Xq >/dev/null -c 'select rolcreatedb from pg_authid where rolname = current_user;' 2>/dev/null
+if [ $? -ne 0 ]; then
+  echo "ERROR: Please specify the user with 'Create DB' permissions, and ensure that the default database for the username exists."
+  exit 1
+fi
+
+# plpgsql does not like psql variables, easier to pull this part off with bash variables
+PGOPTIONS='-c client_min_messages=WARNING' psql "$URI" -Xq >/dev/null <<EOF
+SELECT pg_terminate_backend(pg_stat_activity.pid)
+FROM pg_stat_activity
+WHERE pg_stat_activity.datname = '$DB'
+  AND pid <> pg_backend_pid();
+
+DROP DATABASE IF EXISTS $DB;
+DROP ROLE IF EXISTS $TEST_USER_NAME;
+CREATE USER $TEST_USER_NAME WITH SUPERUSER LOGIN NOINHERIT PASSWORD '$TEST_USER_PASS' CREATEROLE;
+CREATE DATABASE $DB OWNER $TEST_USER_NAME;
+\\connect $DB
+ALTER SCHEMA public OWNER TO $TEST_USER_NAME;
+EOF
+
+#Remove database path from the connection uri--prevents setting up the new database name with PGDATABASE
+URI=$(echo $URI | cut -d'/' -f1-3)
+
+PGDATABASE=$DB PGOPTIONS='-c client_min_messages=WARNING' psql "$URI" --set=db=$DB -Xq <<EOF
+  CREATE EXTENSION IF NOT EXISTS pgcrypto;
+  ALTER DATABASE ${DB} SET request.jwt.claim.id = '-1';
+EOF
+
+# Create a new connection string to use with the test runner
+echo 'postgres://'${TEST_USER_NAME}':'$TEST_USER_PASS'@'$HOST_PORT'/'$DB

test/destroy_test_db

@@ -0,0 +1,65 @@
+#! /bin/bash
+if [ -z "$1" ]
+  then
+    echo "Please supply the connection uri for the user with create database privileges"
+    exit -1
+fi
+
+if [ -z "$2" ]
+  then
+    echo "Please supply the test database name"
+    exit -1
+fi
+if [[ $1 != postgres://* ]]
+then
+  echo "Please use a valid connection URI (https://www.postgresql.org/docs/current/static/libpq-connect.html#AEN45347)"
+  exit -1
+fi
+
+BASEPATH=$( cd $(dirname $0) ; pwd -P )
+URI="$1"
+DB=$2
+
+PGOPTIONS='-c client_min_messages=WARNING' psql "$URI" -Xq >/dev/null -c 'select rolcreatedb from pg_authid where rolname = current_user;' 2>/dev/null
+if [ $? -ne 0 ]; then
+  echo "ERROR: Please specify the user with 'Create DB' permissions, and ensure that the default database for the username exists."
+  exit 1
+fi
+
+# plpgsql does not like psql variables, easier to pull this part off with bash variables
+PGOPTIONS='-c client_min_messages=WARNING' psql "$URI" -Xq >/dev/null <<EOF
+SELECT pg_terminate_backend(pg_stat_activity.pid)
+FROM pg_stat_activity
+WHERE pg_stat_activity.datname = '$DB'
+  AND pid <> pg_backend_pid();
+
+drop database if exists "$DB";
+
+-- Find all test users that were members of role 'postgrest_test_author'--that way we don't have to know the 
+-- test user name (in case it was auto-generated).
+DO \$\$
+DECLARE
+    mem text;
+BEGIN
+    FOR mem IN 
+      SELECT pg_get_userbyid(member)
+      FROM pg_roles r 
+      JOIN pg_auth_members m
+      ON m.roleid = r.oid 
+      WHERE rolname = 'postgrest_test_author' 
+    LOOP
+      EXECUTE 'drop role '|| mem || ';';
+    END LOOP;
+END \$\$;
+
+DO \$\$
+DECLARE
+    r text;
+BEGIN
+    FOR r IN 
+      VALUES('postgrest_test_author'),('postgrest_test_anonymous'),('postgrest_test_default_role')
+    LOOP    
+      EXECUTE 'drop role if exists '|| r || ';';
+    END LOOP;
+END \$\$;
+EOF

test/fixtures/data.sql

@@ -0,0 +1,326 @@
+--
+-- PostgreSQL database dump
+--
+
+-- Dumped from database version 9.5beta1
+-- Dumped by pg_dump version 9.5beta1
+
+SET statement_timeout = 0;
+SET lock_timeout = 0;
+SET client_encoding = 'UTF8';
+SET standard_conforming_strings = on;
+SET check_function_bodies = false;
+SET client_min_messages = warning;
+
+SET search_path = postgrest, pg_catalog;
+
+--
+-- Data for Name: auth; Type: TABLE DATA; Schema: postgrest; Owner: -
+--
+
+TRUNCATE TABLE auth CASCADE;
+INSERT INTO auth VALUES ('jdoe', 'postgrest_test_author', '1234                                                        ');
+
+
+SET search_path = private, pg_catalog;
+
+--
+-- Data for Name: articles; Type: TABLE DATA; Schema: private; Owner: -
+--
+
+TRUNCATE TABLE articles CASCADE;
+INSERT INTO articles VALUES (1, 'No… It''s a thing; it''s like a plan, but with more greatness.', 'diogo');
+INSERT INTO articles VALUES (2, 'Stop talking, brain thinking. Hush.', 'diogo');
+INSERT INTO articles VALUES (3, 'It''s a fez. I wear a fez now. Fezes are cool.', 'diogo');
+
+
+SET search_path = test, pg_catalog;
+
+--
+-- Data for Name: users; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE users CASCADE;
+INSERT INTO users VALUES (1, 'Angela Martin');
+INSERT INTO users VALUES (2, 'Michael Scott');
+INSERT INTO users VALUES (3, 'Dwight Schrute');
+
+
+SET search_path = private, pg_catalog;
+
+--
+-- Data for Name: article_stars; Type: TABLE DATA; Schema: private; Owner: -
+--
+
+TRUNCATE TABLE article_stars CASCADE;
+INSERT INTO article_stars VALUES (1, 1, '2015-12-08 04:22:57.472738');
+INSERT INTO article_stars VALUES (1, 2, '2015-12-08 04:22:57.472738');
+INSERT INTO article_stars VALUES (2, 3, '2015-12-08 04:22:57.472738');
+INSERT INTO article_stars VALUES (3, 2, '2015-12-08 04:22:57.472738');
+INSERT INTO article_stars VALUES (1, 3, '2015-12-08 04:22:57.472738');
+
+
+SET search_path = test, pg_catalog;
+
+--
+-- Data for Name: authors_only; Type: TABLE DATA; Schema: test; Owner: -
+--
+TRUNCATE TABLE authors_only CASCADE;
+
+
+--
+-- Data for Name: auto_incrementing_pk; Type: TABLE DATA; Schema: test; Owner: -
+--
+TRUNCATE TABLE auto_incrementing_pk CASCADE;
+
+
+--
+-- Name: auto_incrementing_pk_id_seq; Type: SEQUENCE SET; Schema: test; Owner: -
+--
+
+SELECT pg_catalog.setval('auto_incrementing_pk_id_seq', 1, true);
+
+
+--
+-- Data for Name: clients; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE clients CASCADE;
+INSERT INTO clients VALUES (1, 'Microsoft');
+INSERT INTO clients VALUES (2, 'Apple');
+
+
+--
+-- Data for Name: projects; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE projects CASCADE;
+INSERT INTO projects VALUES (1, 'Windows 7', 1);
+INSERT INTO projects VALUES (2, 'Windows 10', 1);
+INSERT INTO projects VALUES (3, 'IOS', 2);
+INSERT INTO projects VALUES (4, 'OSX', 2);
+INSERT INTO projects VALUES (5, 'Orphan', NULL);
+
+
+--
+-- Data for Name: tasks; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE tasks CASCADE;
+INSERT INTO tasks VALUES (1, 'Design w7', 1);
+INSERT INTO tasks VALUES (2, 'Code w7', 1);
+INSERT INTO tasks VALUES (3, 'Design w10', 2);
+INSERT INTO tasks VALUES (4, 'Code w10', 2);
+INSERT INTO tasks VALUES (5, 'Design IOS', 3);
+INSERT INTO tasks VALUES (6, 'Code IOS', 3);
+INSERT INTO tasks VALUES (7, 'Design OSX', 4);
+INSERT INTO tasks VALUES (8, 'Code OSX', 4);
+
+
+--
+-- Data for Name: users_tasks; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE users_tasks CASCADE;
+INSERT INTO users_tasks VALUES (1, 1);
+INSERT INTO users_tasks VALUES (1, 2);
+INSERT INTO users_tasks VALUES (1, 3);
+INSERT INTO users_tasks VALUES (1, 4);
+INSERT INTO users_tasks VALUES (2, 5);
+INSERT INTO users_tasks VALUES (2, 6);
+INSERT INTO users_tasks VALUES (2, 7);
+INSERT INTO users_tasks VALUES (3, 1);
+INSERT INTO users_tasks VALUES (3, 5);
+
+
+--
+-- Data for Name: comments; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE comments CASCADE;
+INSERT INTO comments VALUES (1, 1, 2, 6, 'Needs to be delivered ASAP');
+
+
+--
+-- Data for Name: complex_items; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE complex_items CASCADE;
+INSERT INTO complex_items VALUES (1, 'One', '{"foo":{"int":1,"bar":"baz"}}', '{1}');
+INSERT INTO complex_items VALUES (2, 'Two', '{"foo":{"int":1,"bar":"baz"}}', '{1,2}');
+INSERT INTO complex_items VALUES (3, 'Three', '{"foo":{"int":1,"bar":"baz"}}', '{1,2,3}');
+
+
+--
+-- Data for Name: compound_pk; Type: TABLE DATA; Schema: test; Owner: -
+--
+TRUNCATE TABLE compound_pk CASCADE;
+
+
+--
+-- Data for Name: simple_pk; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE simple_pk CASCADE;
+INSERT INTO simple_pk VALUES ('xyyx', 'u');
+INSERT INTO simple_pk VALUES ('xYYx', 'v');
+
+--
+-- Data for Name: has_fk; Type: TABLE DATA; Schema: test; Owner: -
+--
+TRUNCATE TABLE has_fk CASCADE;
+
+
+--
+-- Name: has_fk_id_seq; Type: SEQUENCE SET; Schema: test; Owner: -
+--
+
+SELECT pg_catalog.setval('has_fk_id_seq', 1, false);
+
+
+--
+-- Data for Name: items; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE items CASCADE;
+INSERT INTO items VALUES (1);
+INSERT INTO items VALUES (2);
+INSERT INTO items VALUES (3);
+INSERT INTO items VALUES (4);
+INSERT INTO items VALUES (5);
+INSERT INTO items VALUES (6);
+INSERT INTO items VALUES (7);
+INSERT INTO items VALUES (8);
+INSERT INTO items VALUES (9);
+INSERT INTO items VALUES (10);
+INSERT INTO items VALUES (11);
+INSERT INTO items VALUES (12);
+INSERT INTO items VALUES (13);
+INSERT INTO items VALUES (14);
+INSERT INTO items VALUES (15);
+
+
+--
+-- Name: items_id_seq; Type: SEQUENCE SET; Schema: test; Owner: -
+--
+
+SELECT pg_catalog.setval('items_id_seq', 15, true);
+
+
+--
+-- Data for Name: json; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE json CASCADE;
+INSERT INTO json VALUES ('{"foo":{"bar":"baz"},"id":1}');
+INSERT INTO json VALUES ('{"id":3}');
+INSERT INTO json VALUES ('{"id":0}');
+
+
+--
+-- Data for Name: menagerie; Type: TABLE DATA; Schema: test; Owner: -
+--
+TRUNCATE TABLE menagerie CASCADE;
+
+
+--
+-- Data for Name: no_pk; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE no_pk CASCADE;
+INSERT INTO no_pk VALUES (NULL, NULL);
+INSERT INTO no_pk VALUES ('1', '0');
+INSERT INTO no_pk VALUES ('2', '0');
+
+
+--
+-- Data for Name: nullable_integer; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE nullable_integer CASCADE;
+INSERT INTO nullable_integer VALUES (NULL);
+
+
+--
+-- Data for Name: tsearch; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE tsearch CASCADE;
+INSERT INTO tsearch VALUES (to_tsvector('It''s kind of fun to do the impossible'));
+INSERT INTO tsearch VALUES (to_tsvector('But also fun to do what is possible'));
+
+
+--
+-- Data for Name: users_projects; Type: TABLE DATA; Schema: test; Owner: -
+--
+
+TRUNCATE TABLE users_projects CASCADE;
+INSERT INTO users_projects VALUES (1, 1);
+INSERT INTO users_projects VALUES (1, 2);
+INSERT INTO users_projects VALUES (2, 3);
+INSERT INTO users_projects VALUES (2, 4);
+INSERT INTO users_projects VALUES (3, 1);
+INSERT INTO users_projects VALUES (3, 3);
+
+TRUNCATE TABLE "Escap3e;" CASCADE;
+INSERT INTO "Escap3e;" VALUES (1), (2), (3), (4), (5);
+
+TRUNCATE TABLE "ghostBusters" CASCADE;
+INSERT INTO "ghostBusters" VALUES (1), (3), (5);
+
+TRUNCATE TABLE "withUnique" CASCADE;
+INSERT INTO "withUnique" VALUES ('nodup', 'blah');
+
+
+
+TRUNCATE TABLE addresses CASCADE;
+INSERT INTO addresses VALUES (1, 'address 1');
+INSERT INTO addresses VALUES (2, 'address 2');
+INSERT INTO addresses VALUES (3, 'address 3');
+INSERT INTO addresses VALUES (4, 'address 4');
+
+TRUNCATE TABLE orders CASCADE;
+INSERT INTO orders VALUES (1, 'order 1', 1, 2);
+INSERT INTO orders VALUES (2, 'order 2', 3, 4);
+
+TRUNCATE TABLE images CASCADE;
+INSERT INTO images(name, img) VALUES ('A.png', decode('iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC', 'base64'));
+INSERT INTO images(name, img) VALUES ('B.png', decode('iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII=', 'base64'));
+
+TRUNCATE TABLE w_or_wo_comma_names CASCADE;
+INSERT INTO w_or_wo_comma_names VALUES ('Hebdon, John');
+INSERT INTO w_or_wo_comma_names VALUES ('Williams, Mary');
+INSERT INTO w_or_wo_comma_names VALUES ('Smith, Joseph');
+INSERT INTO w_or_wo_comma_names VALUES ('David White');
+INSERT INTO w_or_wo_comma_names VALUES ('Larry Thompson');
+
+TRUNCATE TABLE items_with_different_col_types CASCADE;
+INSERT INTO items_with_different_col_types VALUES (1, null, null, null, null, null, null, null);
+
+TRUNCATE TABLE entities CASCADE;
+INSERT INTO entities VALUES (1, 'entity 1', '{1}', '''bar'':2 ''foo'':1');
+INSERT INTO entities VALUES (2, 'entity 2', '{1,2}', '''baz'':1 ''qux'':2');
+INSERT INTO entities VALUES (3, 'entity 3', '{1,2,3}', null);
+INSERT INTO entities VALUES (4, null, null, null);
+
+TRUNCATE TABLE child_entities CASCADE;
+INSERT INTO child_entities VALUES (1, 'child entity 1', 1);
+INSERT INTO child_entities VALUES (2, 'child entity 2', 1);
+INSERT INTO child_entities VALUES (3, 'child entity 3', 2);
+
+TRUNCATE TABLE grandchild_entities CASCADE;
+INSERT INTO grandchild_entities VALUES (1, 'grandchild entity 1', 1, null, null, null);
+INSERT INTO grandchild_entities VALUES (2, 'grandchild entity 2', 1, null, null, null);
+INSERT INTO grandchild_entities VALUES (3, 'grandchild entity 3', 2, null, null, null);
+INSERT INTO grandchild_entities VALUES (4, '(grandchild,entity,4)', 2, null, null, '{"a": {"b":"foo"}}');
+INSERT INTO grandchild_entities VALUES (5, '(grandchild,entity,5)', 2, null, null, '{"b":"bar"}');
+
+TRUNCATE TABLE ranges CASCADE;
+INSERT INTO ranges VALUES (1, '[1,3]');
+INSERT INTO ranges VALUES (2, '[3,6]');
+INSERT INTO ranges VALUES (3, '[6,9]');
+INSERT INTO ranges VALUES (4, '[9,12]');
+
+--
+-- PostgreSQL database dump complete
+--

test/fixtures/database.sql

@@ -0,0 +1,3 @@
+set client_min_messages to warning;
+DROP SCHEMA IF EXISTS test, private, postgrest, jwt, public, تست CASCADE;
+DROP TYPE IF EXISTS jwt_token CASCADE;

test/fixtures/draft04.json

@@ -0,0 +1,151 @@
+{
+    "id": "draft04.json",
+    "$schema": "draft04.json",
+    "description": "Core schema meta-schema",
+    "definitions": {
+        "schemaArray": {
+            "type": "array",
+            "minItems": 1,
+            "items": { "$ref": "#" }
+        },
+        "positiveInteger": {
+            "type": "integer",
+            "minimum": 0
+        },
+        "positiveIntegerDefault0": {
+            "allOf": [ { "$ref": "#/definitions/positiveInteger" }, { "default": 0 } ]
+        },
+        "simpleTypes": {
+            "enum": [ "array", "boolean", "integer", "null", "number", "object", "string" ]
+        },
+        "stringArray": {
+            "type": "array",
+            "items": { "type": "string" },
+            "minItems": 1,
+            "uniqueItems": true
+        }
+    },
+    "type": "object",
+    "properties": {
+        "id": {
+            "type": "string",
+            "format": "uri"
+        },
+        "$schema": {
+            "type": "string",
+            "format": "uri"
+        },
+        "title": {
+            "type": "string"
+        },
+        "description": {
+            "type": "string"
+        },
+        "default": {},
+        "multipleOf": {
+            "type": "number",
+            "minimum": 0,
+            "exclusiveMinimum": true
+        },
+        "maximum": {
+            "type": "number"
+        },
+        "exclusiveMaximum": {
+            "type": "boolean",
+            "default": false
+        },
+        "minimum": {
+            "type": "number"
+        },
+        "exclusiveMinimum": {
+            "type": "boolean",
+            "default": false
+        },
+        "maxLength": { "$ref": "#/definitions/positiveInteger" },
+        "minLength": { "$ref": "#/definitions/positiveIntegerDefault0" },
+        "pattern": {
+            "type": "string",
+            "format": "regex"
+        },
+        "additionalItems": {
+            "anyOf": [
+                { "type": "boolean" },
+                { "$ref": "#" }
+            ],
+            "default": {}
+        },
+        "items": {
+            "anyOf": [
+                { "$ref": "#" },
+                { "$ref": "#/definitions/schemaArray" }
+            ],
+            "default": {}
+        },
+        "maxItems": { "$ref": "#/definitions/positiveInteger" },
+        "minItems": { "$ref": "#/definitions/positiveIntegerDefault0" },
+        "uniqueItems": {
+            "type": "boolean",
+            "default": false
+        },
+        "maxProperties": { "$ref": "#/definitions/positiveInteger" },
+        "minProperties": { "$ref": "#/definitions/positiveIntegerDefault0" },
+        "required": { "$ref": "#/definitions/stringArray" },
+        "additionalProperties": {
+            "anyOf": [
+                { "type": "boolean" },
+                { "$ref": "#" }
+            ],
+            "default": {}
+        },
+        "definitions": {
+            "type": "object",
+            "additionalProperties": { "$ref": "#" },
+            "default": {}
+        },
+        "properties": {
+            "type": "object",
+            "additionalProperties": { "$ref": "#" },
+            "default": {}
+        },
+        "patternProperties": {
+            "type": "object",
+            "additionalProperties": { "$ref": "#" },
+            "default": {}
+        },
+        "dependencies": {
+            "type": "object",
+            "additionalProperties": {
+                "anyOf": [
+                    { "$ref": "#" },
+                    { "$ref": "#/definitions/stringArray" }
+                ]
+            }
+        },
+        "enum": {
+            "type": "array",
+            "minItems": 1,
+            "uniqueItems": true
+        },
+        "type": {
+            "anyOf": [
+                { "$ref": "#/definitions/simpleTypes" },
+                {
+                    "type": "array",
+                    "items": { "$ref": "#/definitions/simpleTypes" },
+                    "minItems": 1,
+                    "uniqueItems": true
+                }
+            ]
+        },
+        "format": { "type": "string" },
+        "allOf": { "$ref": "#/definitions/schemaArray" },
+        "anyOf": { "$ref": "#/definitions/schemaArray" },
+        "oneOf": { "$ref": "#/definitions/schemaArray" },
+        "not": { "$ref": "#" }
+    },
+    "dependencies": {
+        "exclusiveMaximum": [ "maximum" ],
+        "exclusiveMinimum": [ "minimum" ]
+    },
+    "default": {}
+}

test/fixtures/jwt.sql

@@ -0,0 +1,65 @@
+-- From michelp/pgjwt commit c02bbd3
+BEGIN;
+set client_min_messages to warning;
+DROP SCHEMA IF EXISTS jwt CASCADE;
+CREATE SCHEMA jwt;
+
+
+CREATE OR REPLACE FUNCTION jwt.url_encode(data bytea) RETURNS text LANGUAGE sql AS $$
+    SELECT translate(encode(data, 'base64'), E'+/=\n', '-_');
+$$;
+
+
+CREATE OR REPLACE FUNCTION jwt.url_decode(data text) RETURNS bytea LANGUAGE sql AS $$
+WITH t AS (SELECT translate(data, '-_', '+/')),
+     rem AS (SELECT length((SELECT * FROM t)) % 4) -- compute padding size
+    SELECT decode(
+        (SELECT * FROM t) ||
+        CASE WHEN (SELECT * FROM rem) > 0
+           THEN repeat('=', (4 - (SELECT * FROM rem)))
+           ELSE '' END,
+    'base64');
+$$;
+
+
+CREATE OR REPLACE FUNCTION jwt.algorithm_sign(signables text, secret text, algorithm text)
+RETURNS text LANGUAGE sql AS $$
+WITH
+  alg AS (
+    SELECT CASE
+      WHEN algorithm = 'HS256' THEN 'sha256'
+      WHEN algorithm = 'HS384' THEN 'sha384'
+      WHEN algorithm = 'HS512' THEN 'sha512'
+      ELSE '' END)  -- hmac throws error
+SELECT jwt.url_encode(hmac(signables, secret, (select * FROM alg)));
+$$;
+
+
+CREATE OR REPLACE FUNCTION jwt.sign(payload json, secret text, algorithm text DEFAULT 'HS256')
+RETURNS text LANGUAGE sql AS $$
+WITH
+  header AS (
+    SELECT jwt.url_encode(convert_to('{"alg":"' || algorithm || '","typ":"JWT"}', 'utf8'))
+    ),
+  payload AS (
+    SELECT jwt.url_encode(convert_to(payload::text, 'utf8'))
+    ),
+  signables AS (
+    SELECT (SELECT * FROM header) || '.' || (SELECT * FROM payload)
+    )
+SELECT
+    (SELECT * FROM signables)
+    || '.' ||
+    jwt.algorithm_sign((SELECT * FROM signables), secret, algorithm);
+$$;
+
+
+CREATE OR REPLACE FUNCTION jwt.verify(token text, secret text, algorithm text DEFAULT 'HS256')
+RETURNS table(header json, payload json, valid boolean) LANGUAGE sql AS $$
+  SELECT
+    convert_from(jwt.url_decode(r[1]), 'utf8')::json AS header,
+    convert_from(jwt.url_decode(r[2]), 'utf8')::json AS payload,
+    r[3] = jwt.algorithm_sign(r[1] || '.' || r[2], secret, algorithm) AS valid
+  FROM regexp_split_to_array(token, '\.') r;
+$$;
+COMMIT;

test/fixtures/privileges.sql

@@ -0,0 +1,76 @@
+-- Privileges for anonymous
+GRANT USAGE ON SCHEMA
+      postgrest
+    , test
+    , jwt
+    , public
+    , "تست"
+TO postgrest_test_anonymous;
+
+-- Schema test objects
+SET search_path = test, "تست", pg_catalog;
+
+GRANT ALL ON TABLE
+    items
+    , "articleStars"
+    , articles
+    , auto_incrementing_pk
+    , clients
+    , comments
+    , complex_items
+    , compound_pk
+    , empty_table
+    , has_count_column
+    , has_fk
+    , insertable_view_with_join
+    , json
+    , materialized_view
+    , menagerie
+    , no_pk
+    , nullable_integer
+    , projects
+    , projects_view
+    , projects_view_alt
+    , simple_pk
+    , tasks
+    , filtered_tasks
+    , tsearch
+    , users
+    , users_projects
+    , users_tasks
+    , "Escap3e;"
+    , "ghostBusters"
+    , "withUnique"
+    , "clashing_column"
+    , "موارد"
+    , addresses
+    , orders
+    , public.public_consumers
+    , public.public_orders
+    , consumers_view
+    , orders_view
+    , images
+    , images_base64
+    , w_or_wo_comma_names
+    , items_with_different_col_types
+    , entities
+    , child_entities
+    , grandchild_entities
+    , ranges
+TO postgrest_test_anonymous;
+
+GRANT INSERT ON TABLE insertonly TO postgrest_test_anonymous;
+
+GRANT USAGE ON SEQUENCE
+      auto_incrementing_pk_id_seq
+    , items_id_seq
+    , callcounter_count
+TO postgrest_test_anonymous;
+
+-- Privileges for non anonymous users
+GRANT USAGE ON SCHEMA test TO postgrest_test_author;
+GRANT ALL ON TABLE authors_only TO postgrest_test_author;
+
+GRANT SELECT (article_id, user_id) ON TABLE limited_article_stars TO postgrest_test_anonymous;
+GRANT INSERT (article_id, user_id) ON TABLE limited_article_stars TO postgrest_test_anonymous;
+GRANT UPDATE (article_id, user_id) ON TABLE limited_article_stars TO postgrest_test_anonymous;

test/fixtures/roles.sql

@@ -1,16 +1,7 @@
-create function pg_temp.create_role_if_not_exists(rolename name, opts character varying) RETURNS text
-  LANGUAGE plpgsql
-  AS $$
-BEGIN
-  IF NOT EXISTS (SELECT * FROM pg_roles WHERE rolname = rolename) THEN
-    EXECUTE format('CREATE ROLE %I %s', rolename, opts);
-    RETURN 'CREATE ROLE';
-  ELSE
-    RETURN format('ROLE ''%I'' ALREADY EXISTS', rolename);
-  END IF;
-END;
-$$;
+\set AUTHENTICATOR current_user
+DROP ROLE IF EXISTS postgrest_test_anonymous, postgrest_test_default_role, postgrest_test_author;
+CREATE ROLE postgrest_test_anonymous;
+CREATE ROLE postgrest_test_default_role;
+CREATE ROLE postgrest_test_author;
 
-select pg_temp.create_role_if_not_exists('postgrest_anonymous', 'with nologin') as a
-     , pg_temp.create_role_if_not_exists('test_default_role', 'with nologin') as b
-     , pg_temp.create_role_if_not_exists('postgrest_test_author', 'with nologin') into temp shh;
+GRANT postgrest_test_anonymous, postgrest_test_default_role, postgrest_test_author TO :USER;

test/io-tests.sh

@@ -0,0 +1,111 @@
+#!/bin/sh
+# Run unit tests for Input/Ouput of PostgREST seen as a black box
+# with test output in Test Anything Protocol format.
+#
+# References:
+#   [1] Test Anything Protocol
+#   https://testanything.org/
+#
+#   [2] TAP Specification
+#   https://testanything.org/tap-specification.html
+#
+#   [3] List of TCP and UDP port numbers
+#   https://en.wikipedia.org/wiki/List_of_TCP_and_UDP_port_numbers
+#
+cd "$(dirname "$0")"
+cd io-tests
+
+# Port for Test PostgREST Server (must match config)
+pgrPort=49421 # in range 49152–65535: for private or temporary use
+
+# TAP utilities
+currentTest=1
+failedTests=0
+bailOut(){ echo "Bail out! $1"; exit 1; }
+result(){ echo "$1 $currentTest $2"; currentTest=$(( $currentTest + 1 )); }
+todo(){ result 'ok' "# TODO: $*"; }
+skip(){ result 'ok' "# SKIP: $*"; }
+ok(){ result 'ok' "- $1"; }
+ko(){ result 'not ok' "- $1"; failedTests=$(( $failedTests + 1 )); }
+comment(){ echo "# $1"; }
+
+# Utilities to start/stop test PostgREST server running in the background
+pgrStart(){ stack exec -- postgrest "$1" >/dev/null & pgrPID="$!"; }
+pgrStartRead(){ stack exec -- postgrest "$1" >/dev/null < "$2" & pgrPID="$!"; }
+pgrStarted(){ kill -0 "$pgrPID" 2>/dev/null; }
+pgrStop(){ kill "$pgrPID" 2>/dev/null; }
+pgrStopAll(){ pkill -f "$(stack path --local-install-root)/bin/postgrest"; }
+
+# Utilities to send HTTP requests to the PostgREST server
+rootStatus(){
+  curl -s -o /dev/null -w '%{http_code}' "http://localhost:$pgrPort/"
+}
+authorsStatus(){
+  curl -s -o /dev/null -w '%{http_code}' \
+    -H "Authorization: Bearer $( cat "$1" )" \
+    "http://localhost:$pgrPort/authors_only"
+}
+
+# Start and End of Unit Tests
+setUp(){ pgrStopAll; }
+cleanUp(){ pgrStopAll; }
+
+# Unit Test Templates
+readSecretFromFile(){
+  case "$1" in
+    *.b64)
+      pgrConfig="base64-secret-from-file.config";;
+    *)
+      pgrConfig="secret-from-file.config";;
+  esac
+  pgrStartRead "./configs/$pgrConfig" "./secrets/$1"
+  while pgrStarted && test "$( rootStatus )" -ne 200
+  do
+    # wait for the server to start
+    sleep 0.1 \
+    || sleep 1 # fallback: subsecond sleep is not standard and may fail
+  done
+  if pgrStarted
+  then
+    authorsJwt="./secrets/${1%.*}.jwt"
+    httpStatus="$( authorsStatus "$authorsJwt" )"
+    if test "$httpStatus" -eq 200
+    then
+      ok "authentication with $2 secret read from a file"
+    else
+      ko "failed to authenticate using JWT for $2 secret: $httpStatus"
+    fi
+  else
+    ko "failed to read $2 secret from a file"
+  fi
+  pgrStop
+}
+
+# PRE: curl must be available
+test -n "$(command -v curl)" || bailOut 'curl is not available'
+
+# PRE: postgres must be running
+psql -l 1>/dev/null 2>/dev/null || bailOut 'postgres is not running'
+
+setUp
+
+totalTests=12
+echo "1..$totalTests"
+
+readSecretFromFile word.noeol 'simple (no EOL)'
+skip readSecretFromFile word.txt 'simple'
+readSecretFromFile ascii.noeol 'ASCII (no EOL)'
+skip readSecretFromFile ascii.txt 'ASCII'
+readSecretFromFile utf8.noeol 'UTF-8 (no EOL)'
+skip readSecretFromFile utf8.txt 'UTF-8'
+skip readSecretFromFile binary.noeol 'binary'
+skip readSecretFromFile binary.eol 'binary (+EOL)'
+
+readSecretFromFile word.b64 'Base64 (simple)'
+readSecretFromFile ascii.b64 'Base64 (ASCII)'
+readSecretFromFile utf8.b64 'Base64 (UTF-8)'
+readSecretFromFile binary.b64 'Base64 (binary)'
+
+cleanUp
+
+exit $failedTests

test/io-tests/configs/base64-secret-from-file.config

@@ -0,0 +1,10 @@
+db-uri = "postgres:///postgrest_test"
+db-schema = "test"
+db-anon-role = "postgrest_test_anonymous"
+db-pool = 1
+server-host = "*4"
+server-port = 49421
+
+# Read secret from a file: /dev/stdin (alias for standard input)
+jwt-secret = "@/dev/stdin"
+secret-is-base64 = true

test/io-tests/configs/secret-from-file.config

@@ -0,0 +1,10 @@
+db-uri = "postgres:///postgrest_test"
+db-schema = "test"
+db-anon-role = "postgrest_test_anonymous"
+db-pool = 1
+server-host = "*4"
+server-port = 49421
+
+# Read secret from a file: /dev/stdin (alias for standard input)
+jwt-secret = "@/dev/stdin"
+secret-is-base64 = false

test/io-tests/secrets/ascii.b64

@@ -0,0 +1 @@
+QUJDCkVhc3kgYXMKMTIzCk9yIHNpbXBsZSBhcwpEbyByZSBtaQ==

test/io-tests/secrets/ascii.jwt

@@ -0,0 +1 @@
+eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.p__cvqgrtteKUhxrJwTwqxeuFmlEm3hEj1mk7yO15M4

test/io-tests/secrets/ascii.noeol

@@ -0,0 +1,5 @@
+ABC
+Easy as
+123
+Or simple as
+Do re mi

test/io-tests/secrets/ascii.txt

@@ -0,0 +1,5 @@
+ABC
+Easy as
+123
+Or simple as
+Do re mi

test/io-tests/secrets/binary.b64

@@ -0,0 +1 @@
+RTwSHLM0/PWM2YCOyBiyChMQQamZLTZGrXdzGk61o5A=

test/io-tests/secrets/binary.eol

@@ -0,0 +1,2 @@
+E<³4üõŒÙ€ŽÈ²
+A©™-6F­wsNµ£�

test/io-tests/secrets/binary.jwt

@@ -0,0 +1 @@
+eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.zyXYJKXgVYaWqMYgUXMk4zqXSU5cwA_vK2z9_5lRlqA

test/io-tests/secrets/binary.noeol

@@ -0,0 +1,2 @@
+E<³4üõŒÙ€ŽÈ²
+A©™-6F­wsNµ£�

test/io-tests/secrets/utf8.b64

@@ -0,0 +1 @@
+4pqg77iPIOKaoO+4jiBVbmljb2RlIOKYoO+4jyDimKA=

test/io-tests/secrets/utf8.jwt

@@ -0,0 +1 @@
+eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.VFfaoJohnDeJMA-awM6Y7blbOjXDNwmtx48Z-0bIKrE

test/io-tests/secrets/utf8.noeol

@@ -0,0 +1 @@
+⚠️ ⚠︎ Unicode ☠️ ☠

test/io-tests/secrets/utf8.txt

@@ -0,0 +1 @@
+⚠️ ⚠︎ Unicode ☠️ ☠

test/io-tests/secrets/word.b64

@@ -0,0 +1 @@
+QUJDRWFzeUFzT25lVHdvVGhyZWVPclNpbXBsZUFzRG9SZU1p

test/io-tests/secrets/word.jwt

@@ -0,0 +1 @@
+eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.1oyYyosD3_z4YzBE1DB-Pxf7wC0SCuZ2u1zLzPYU_nQ

test/io-tests/secrets/word.noeol

@@ -0,0 +1 @@
+ABCEasyAsOneTwoThreeOrSimpleAsDoReMi

test/io-tests/secrets/word.txt

@@ -0,0 +1 @@
+ABCEasyAsOneTwoThreeOrSimpleAsDoReMi