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

@@ -6,6 +6,9 @@ cabal.sandbox.config
 hscope.out
 codex.tags
 .anvil
-.stack-work
+.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,216 @@
 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

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
@@ -40,7 +48,7 @@ your contributions.
   pull request.
 
 * For help building the Haskell code on your computer check out the [building from
-source](https://github.com/begriffs/postgrest/wiki/Building-from-source)
+source](https://postgrest.com/en/stable/install.html#build-from-source)
 wiki page.
 
 ## Maintenance
@@ -53,3 +61,9 @@ 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

@@ -5,47 +5,31 @@
   <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
@@ -61,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
@@ -130,48 +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)
-* [Heroku](https://github.com/begriffs/postgrest/wiki/Heroku)
+and the [API guide](http://postgrest.com/en/stable/api.html).
 
 ### Thanks
 
-* [Ruslan Talpa](https://github.com/ruslantalpa) for rewriting the
-  route parsing and query generation code to support resource embedding
-* [Adam Baker](https://github.com/adambaker) for code
-  contributions and many fundamental design discussions
-* [Diogo Biazus](https://github.com/diogob) for many improvements
-  and deep postgresql knowledge
-* [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](http://blog.jonharrington.org/postgrest-introduction/)
-* [Federico Rampazzo](https://github.com/framp) for suggesting and
-  implementing [JWT](http://jwt.io/) support
+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,47 +10,46 @@
     },
     "POSTGREST_VER": {
       "description": "Version of PostgREST to deploy",
-      "value": "0.2.12.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"
     },
-    "JWT_SECRET": {
-      "description": "Secret used to encrypt JSON Web Tokens",
-      "required": false,
-      "value": "secret"
+    "SERVER_PROXY_URI": {
+      "description": "Overrides the base URL used within the OpenAPI self-documentation hosted at the API root path",
+      "required": false
     },
-    "V1SCHEMA": {
-      "description": "DB schema selected whe no version (or version 1) requested",
+    "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": "1"
+      "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

debian/TODO-deps.md

@@ -1,52 +0,0 @@
-# TODO list to build debian "official" package
-
-  It feels for free to modify, fix or take some task or all. 
-  
-## debian/control
-
-* Fill description field
-* Add Vcs-Browser
-* Add Vcs-Git
-* Add Uploaders field
-
-## debian/copyright 
-
-* Add more contributers 
-
-## Dependencies packages
-
-Some libraries dependencies aren't Debian package. Below is the list was built by [cabal-debian](https://wiki.debian.org/Haskell/CollabMaint/GettingStarted). These libraries are necessary to build Postgrest the right way. 
-
-* libghc-base64-string-dev
-* libghc-base64-string-prof
-* libghc-bcrypt-dev
-* libghc-bcrypt-prof
-* libghc-hasql-dev
-* libghc-hasql-prof
-* libghc-hasql-backend-dev
-* libghc-hasql-backend-prof
-* libghc-hasql-postgres-dev
-* libghc-hasql-postgres-prof
-* libghc-string-conversions-dev
-* libghc-string-conversions-prof
-* libghc-wai-cors-dev
-* libghc-wai-cors-prof
-* libghc-wai-middleware-static-dev
-* libghc-wai-middleware-static-prof
-* libghc-hasql-dev
-* libghc-hasql-backend-dev
-* libghc-hasql-postgres-dev
-* libghc-heredoc-dev
-* libghc-hspec-wai-dev
-* libghc-hspec-wai-json-dev
-* libghc-http-media-dev
-* libghc-packdeps-dev
-* libghc-base64-string-doc
-* libghc-bcrypt-doc
-* libghc-hasql-doc
-* libghc-hasql-backend-doc
-* libghc-hasql-postgres-doc
-* libghc-string-conversions-doc
-* libghc-wai-cors-doc
-* libghc-wai-middleware-static-doc
-

debian/changelog

@@ -1,5 +0,0 @@
-haskell-postgrest (0.2.11.1-1) UNRELEASED; urgency=low
-
-  * Initial release
-
- -- Debian Haskell Group <pkg-haskell-maintainers@lists.alioth.debian.org>  Wed, 30 Sep 2015 18:52:46 +0000

debian/compat

@@ -1 +0,0 @@
-9

debian/control

@@ -1,196 +0,0 @@
-Source: haskell-postgrest
-Maintainer: Debian Haskell Group <pkg-haskell-maintainers@lists.alioth.debian.org>
-Priority: extra
-Section: haskell
-Build-Depends: debhelper (>= 9),
- haskell-devscripts (>= 0.8),
- cdbs,
- ghc,
- ghc-prof,
- libghc-http-dev,
- libghc-http-prof,
- libghc-missingh-dev,
- libghc-missingh-prof,
- libghc-ranged-sets-dev,
- libghc-ranged-sets-prof,
- libghc-aeson-dev,
- libghc-aeson-prof,
- libghc-base64-string-dev,
- libghc-base64-string-prof,
- libghc-bcrypt-dev,
- libghc-bcrypt-prof,
- libghc-blaze-builder-dev,
- libghc-blaze-builder-prof,
- libghc-case-insensitive-dev,
- libghc-case-insensitive-prof,
- libghc-cassava-dev,
- libghc-cassava-prof,
- libghc-convertible-dev,
- libghc-convertible-prof,
- libghc-hasql-dev,
- libghc-hasql-prof,
- libghc-hasql-backend-dev,
- libghc-hasql-backend-prof,
- libghc-hasql-postgres-dev,
- libghc-hasql-postgres-prof,
- libghc-http-types-dev,
- libghc-http-types-prof,
- libghc-jwt-dev,
- libghc-jwt-prof,
- libghc-mtl-dev,
- libghc-mtl-prof,
- libghc-network-dev,
- libghc-network-prof,
- libghc-network-uri-dev,
- libghc-network-uri-prof,
- libghc-optparse-applicative-dev,
- libghc-optparse-applicative-prof,
- libghc-regex-base-dev,
- libghc-regex-base-prof,
- libghc-regex-tdfa-dev,
- libghc-regex-tdfa-prof,
- libghc-resource-pool-dev,
- libghc-resource-pool-prof,
- libghc-scientific-dev,
- libghc-scientific-prof,
- libghc-split-dev,
- libghc-split-prof,
- libghc-string-conversions-dev,
- libghc-string-conversions-prof,
- libghc-stringsearch-dev,
- libghc-stringsearch-prof,
- libghc-text-dev,
- libghc-text-prof,
- libghc-unordered-containers-dev,
- libghc-unordered-containers-prof,
- libghc-vector-dev,
- libghc-vector-prof,
- libghc-wai-dev,
- libghc-wai-prof,
- libghc-wai-cors-dev,
- libghc-wai-cors-prof,
- libghc-wai-extra-dev,
- libghc-wai-extra-prof,
- libghc-wai-middleware-static-dev,
- libghc-wai-middleware-static-prof,
- libghc-warp-dev,
- libghc-warp-prof,
- libghc-aeson-dev (>= 0.8),
- libghc-bcrypt-dev (>= 0.0.6),
- libghc-hasql-dev (>= 0.7.3),
- libghc-hasql-dev (<< 0.8),
- libghc-hasql-backend-dev (>= 0.4.1),
- libghc-hasql-backend-dev (<< 0.5),
- libghc-hasql-postgres-dev (>= 0.10.4),
- libghc-hasql-postgres-dev (<< 0.11),
- libghc-network-dev (>= 2.6),
- libghc-network-uri-dev (>= 2.6),
- libghc-optparse-applicative-dev (>= 0.11),
- libghc-optparse-applicative-dev (<< 0.12),
- libghc-wai-dev (>= 3.0.1),
- libghc-wai-middleware-static-dev (>= 0.6.0),
- libghc-warp-dev (>= 3.0.2),
- libghc-quickcheck2-dev,
- libghc-heredoc-dev,
- libghc-hlint-dev,
- libghc-hspec-dev (>= 2.1),
- libghc-hspec-dev (<< 2.2),
- libghc-hspec-wai-dev,
- libghc-hspec-wai-json-dev,
- libghc-http-media-dev,
- libghc-packdeps-dev,
-Build-Depends-Indep: ghc-doc,
- libghc-http-doc,
- libghc-missingh-doc,
- libghc-ranged-sets-doc,
- libghc-aeson-doc,
- libghc-base64-string-doc,
- libghc-bcrypt-doc,
- libghc-blaze-builder-doc,
- libghc-case-insensitive-doc,
- libghc-cassava-doc,
- libghc-convertible-doc,
- libghc-hasql-doc,
- libghc-hasql-backend-doc,
- libghc-hasql-postgres-doc,
- libghc-http-types-doc,
- libghc-jwt-doc,
- libghc-mtl-doc,
- libghc-network-doc,
- libghc-network-uri-doc,
- libghc-optparse-applicative-doc,
- libghc-regex-base-doc,
- libghc-regex-tdfa-doc,
- libghc-resource-pool-doc,
- libghc-scientific-doc,
- libghc-split-doc,
- libghc-string-conversions-doc,
- libghc-stringsearch-doc,
- libghc-text-doc,
- libghc-unordered-containers-doc,
- libghc-vector-doc,
- libghc-wai-doc,
- libghc-wai-cors-doc,
- libghc-wai-extra-doc,
- libghc-wai-middleware-static-doc,
- libghc-warp-doc,
-Standards-Version: 3.9.6
-Homepage: https://github.com/begriffs/postgrest
-Description: REST API for any Postgres database
- Reads the schema of a PostgreSQL database and creates RESTful routes
- for the tables and views, supporting all HTTP verbs that security
- permits.
-
-Package: libghc-postgrest-dev
-Architecture: any
-Depends: ${haskell:Depends},
- ${misc:Depends},
- ${shlibs:Depends},
-Recommends: ${haskell:Recommends},
-Suggests: ${haskell:Suggests},
-Conflicts: ${haskell:Conflicts},
-Provides: ${haskell:Provides},
-Description: ${haskell:ShortDescription}${haskell:ShortBlurb}
- ${haskell:LongDescription}
- .
- ${haskell:Blurb}
-
-Package: libghc-postgrest-prof
-Architecture: any
-Depends: ${haskell:Depends},
- ${misc:Depends},
-Recommends: ${haskell:Recommends},
-Suggests: ${haskell:Suggests},
-Conflicts: ${haskell:Conflicts},
-Provides: ${haskell:Provides},
-Description: ${haskell:ShortDescription}${haskell:ShortBlurb}
- ${haskell:LongDescription}
- .
- ${haskell:Blurb}
-
-Package: libghc-postgrest-doc
-Architecture: all
-Section: doc
-Depends: ${haskell:Depends},
- ${misc:Depends},
-Recommends: ${haskell:Recommends},
-Suggests: ${haskell:Suggests},
-Conflicts: ${haskell:Conflicts},
-Description: ${haskell:ShortDescription}${haskell:ShortBlurb}
- ${haskell:LongDescription}
- .
- ${haskell:Blurb}
-
-Package: haskell-postgrest-utils
-Architecture: any
-Section: misc
-Depends: ${haskell:Depends},
- ${misc:Depends},
-Recommends: ${haskell:Recommends},
-Suggests: ${haskell:Suggests},
-Conflicts: ${haskell:Conflicts},
-Provides: ${haskell:Provides},
-Description: ${haskell:ShortDescription}${haskell:ShortBlurb}
- ${haskell:LongDescription}
- .
- ${haskell:Blurb}

debian/copyright

@@ -1,32 +0,0 @@
-Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
-Upstream-Name: postgrest
-Upstream-Contact: Joe Nelson <joe@begriffs.com>
-Source: https://hackage.haskell.org/package/postgrest
-
-Files: *
-Copyright: 2014-2015 Joe Nelson <joe@begriffs.com>
-License: Expat
-
-Files: debian/*
-Copyright: 2015 Fernando Ike <fike@midstorm.org>
-License: Expat
-
-License: Expat
- Permission is hereby granted, free of charge, to any person obtaining
- a copy of this software and associated documentation files (the
- "Software"), to deal in the Software without restriction, including
- without limitation the rights to use, copy, modify, merge, publish,
- distribute, sublicense, and/or sell copies of the Software, and to
- permit persons to whom the Software is furnished to do so, subject to
- the following conditions:
- .
- The above copyright notice and this permission notice shall be included
- in all copies or substantial portions of the Software.
- .
- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

debian/haskell-postgrest-utils.install

@@ -1 +0,0 @@
-dist-ghc/build/postgrest/postgrest usr/bin

debian/postgrest-wrapper

@@ -1,8 +0,0 @@
-#!/bin/sh
-d=$(dirname $0)
-if [ -f /etc/default/postgrest ]; then
-	. /etc/default/postgrest
-fi
-POSTGREST_LOG=${POSTGREST_LOG:-/var/log/postgrest/postgrest.log}
-
-exec $d/postgrest "$@" >>$POSTGREST_LOG 2>&1 &

debian/postgrest.default

@@ -1,23 +0,0 @@
-# run service as
-#POSTGREST_USER=postgrest
-
-# log file
-#POSTGREST_LOG=/var/log/postgrest/postgrest.log
-
-# database host
-#POSTGREST_DBHOST=localhost
-
-# database to use
-#POSTGREST_DBNAME=
-
-# database user
-#POSTGREST_DBUSER=postgres
-
-# database password
-#POSTGREST_DBPASS=
-
-# database pool
-#POSTGREST_DBPOOL=10
-
-# additional options
-#POSTGREST_OPTS=

debian/postgrest.init.d

@@ -1,78 +0,0 @@
-#!/bin/sh
-### BEGIN INIT INFO
-# Provides:          postgrest
-# Required-Start:    $local_fs $network postgresql
-# Required-Stop:     $local_fs $network 
-# Default-Start:     2 3 4 5
-# Default-Stop:      0 1 6
-# Description:       PostgreSQL REST API daemon
-### END INIT INFO
- 
-. /lib/lsb/init-functions
-if test -f /etc/default/postgrest; then
-    . /etc/default/postgrest
-fi
-POSTGREST=/usr/local/bin/postgrest
-POSTGREST_USER=${POSTGREST_USER:-postgrest}
-POSTGREST_DBNAME=${POSTGREST_DBNAME:-postgres}
-POSTGREST_DBUSER=${POSTGREST_DBUSER:-postgres}
-if [ -n "$POSTGREST_DBHOST" ]; then
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-host $POSTGREST_DBHOST"
-fi
-if [ -n "$POSTGREST_DBNAME" ]; then
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-name $POSTGREST_DBNAME"
-fi
-if [ -n "$POSTGREST_DBUSER" ]; then
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-user $POSTGREST_DBUSER"
-	POSTGREST_OPTS="$POSTGREST_OPTS --anonymous $POSTGREST_DBUSER"
-fi
-if [ -n "$POSTGREST_DBPASS" ]; then
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-pass $POSTGREST_DBPASS"
-fi
-if [ -n "$POSTGREST_DBPOOL" ]; then
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-pool $POSTGREST_DBPOOL"
-fi
-POSTGREST_OPTS="$POSTGREST_OPTS --v1schema public"
- 
-start()
-{
-	log_daemon_msg "Starting PostgreSQL REST API daemon" "postgrest" || true
-	if start-stop-daemon --start --quiet --oknodo --chuid ${POSTGREST_USER} --startas /usr/local/bin/postgrest-wrapper --exec $POSTGREST -- $POSTGREST_OPTS; then
-		log_end_msg 0 || true
-	else
-		log_end_msg 1 || true
-	fi
-}
- 
-stop()
-{
-	log_daemon_msg "Stopping PostgreSQL REST API daemon" "postgrest" || true
-	if start-stop-daemon --stop --quiet --oknodo --exec $POSTGREST; then
-		log_end_msg 0 || true
-	else
-		log_end_msg 1 || true
-	fi
-}
- 
-status()
-{
-	status_of_proc $POSTGREST postgrest && exit 0 || exit $?
-}
-
-case "$1" in
-start)
-	start
-	;;
-stop)
-	stop
-	;;
-restart)
-	stop
-	start
-	;;
-status)
-	status
-	;;
-*)
-	echo "Usage: $0 {start|stop|restart|status}"
-esac

debian/rules

@@ -1,10 +0,0 @@
-#!/usr/bin/make -f
-
-DEB_ENABLE_TESTS = yes
-DEB_CABAL_PACKAGE = postgrest
-DEB_DEFAULT_COMPILER = ghc
-
-include /usr/share/cdbs/1/rules/debhelper.mk
-include /usr/share/cdbs/1/class/hlibrary.mk
-
-build/haskell-postgrest-utils:: build-ghc-stamp

debian/source/format

@@ -1 +0,0 @@
-3.0 (quilt)

debian/watch

@@ -1,2 +0,0 @@
-version=3
-http://hackage.haskell.org/package/postgrest/distro-monitor .*-([0-9\.]+)\.(?:zip|tgz|tbz|txz|(?:tar\.(?:gz|bz2|xz)))

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)"

docs/CNAME

@@ -1 +0,0 @@
-postgrest.com

docs/admin/deployment.md

@@ -1,9 +0,0 @@
-## Deployment
-
-### Heroku
-
-#### Getting Started
-
-#### Using Amazon RDS
-
-### Debian

docs/admin/migration.md

@@ -1,9 +0,0 @@
-## Data Migration
-
-### Sqitch
-
-### Test-Driven Migrations
-
-#### Structural Tests
-
-#### Value Tests with pgTAP

docs/admin/performance.md

@@ -1,9 +0,0 @@
-## Performance
-
-### Benchmarks
-
-### Caching
-
-### Quality of Service
-
-### Tips

docs/admin/security.md

@@ -1,21 +0,0 @@
-## Security
-
-### SSL
-
-### Database Roles
-
-### JSON Web Tokens
-
-#### Issuing via sql procedures
-
-### Row-Level Security
-
-#### Simulated - PostgreSQL <9.5
-
-#### Real - PostgreSQL >=9.5
-
-### Building Auth on top of JWT
-
-#### Basic Auth
-
-#### Github Sign-in

docs/admin/versioning.md

@@ -1,9 +0,0 @@
-## API Versioning
-
-### Schema Search Path
-
-### Changing a Resource
-
-### Removing a Resource
-
-### Avoiding DB and Client Coupling

docs/api/reading.md

@@ -1,296 +0,0 @@
-## Requesting Information
-
-### Tables and Views
-
-* ✅ Cacheable, prefetchable
-* ✅ Idempotent
-
-The list of accessible tables and views is provided at
-
-```HTTP
-GET /
-```
-
-Every view and table accessible by the active db role is exposed
-in a one-level deep route. For instance the full contents of a table
-`people` is returned at
-
-```HTTP
-GET /people
-```
-
-There are no `deeply/nested/routes`. Each route provides `OPTIONS`,
-`GET`, `POST`, `PUT`, `PATCH`, and `DELETE` verbs depending entirely
-on database permissions.
-
-<div class="admonition note">
-  <p class="admonition-title">Design Consideration</p>
-
-  <p>Why not provide nested routes? Many APIs allow nesting to
-  retrieve related information, such as <code>/films/1/director</code>.
-  We offer a more flexible mechanism instead to embed related
-  information, including many-to-many relationships. This is covered
-  in the section about Embedding.</p>
-</div>
-
-### Stored Procedures
-
-* ❌ Cannot necessarily be cached or prefetched
-* ❌ Not necessarily idempotent
-
-Every stored procedure is accessible under the `/rpc` prefix. The
-API endpoint supports only POST which executes the function.
-
-```HTTP
-POST /rpc/proc_name
-```
-
-PostgREST supports calling procedures with [named
-arguments](http://www.postgresql.org/docs/9.4/static/sql-syntax-calling-funcs.html#SQL-SYNTAX-CALLING-FUNCS-NAMED).
-To do so include a JSON object in the request payload and each
-key/value of the object will become an argument.
-
-<div class="admonition note">
-  <p class="admonition-title">Design Consideration</p>
-
-  <p>Why the /rpc prefix? One reason is to avoid name collisions
-  between views and procedures. It also helps emphasize to API
-  consumers that these functions are not normal restful things.
-  The functions can have arbitrary and surprising behavior, not
-  the standard "post creates a resource" thing that users expect
-  from the other routes.</p>
-
-  <p>We considered allowing GET requests for functions that are
-  marked non-volatile but could not reconcile how to pass in
-  parameters. Query string arguments are reserved for shaping/filtering
-  the output, not providing input.</p>
-</div>
-
-
-
-### Filtering
-
-#### Filtering Rows
-
-You can filter result rows by adding conditions on columns, each
-condition a query string parameter.  For instance, to return people
-aged under 13 years old:
-
-```HTTP
-GET /people?age=lt.13
-```
-
-Adding multiple parameters conjoins the conditions:
-
-```HTTP
-GET /people?age=gte.18&student=is.true
-```
-
-These operators are available:
-
-abbreviation | meaning
------------- | -------
-eq           | equals
-gt           | greater than
-lt           | less than
-gte          | greater than or equal
-lte          | less than or equal
-like         | LIKE operator (use * in place of %)
-ilike        | ILIKE operator (use * in place of %)
-@@           | full-text search using to_tsquery
-is           | checking for exact equality (null,true,false)
-in           | one of a list of values e.g. `?a=in.1,2,3`
-not          | negates another operator, see below
-
-To negate any operator, prefix it with `not` like `?a=not.eq.2`.
-
-For more complicated filters (such as those involving condition 1
-*OR* condition 2) you will have to create a new view in the database.
-
-Filters may be applied to [computed
-columns](http://www.postgresql.org/docs/current/interactive/xfunc-sql.html#XFUNC-SQL-COMPOSITE-FUNCTIONS)
-as well as actual table/view columns, even though the computed
-columns will not appear in the output.
-
-#### Filtering Columns
-
-You can customize which columns are returned by using the `select`
-parameter:
-
-```HTTP
-GET /people?select=age,height,weight
-```
-
-To cast the column types, add a double colon
-
-```HTTP
-GET /people?select=age::text,height,weight
-```
-
-Not all type coercions are possible, and you will get an error
-describing any problems from selection or type casting.
-
-The `select` keyword is reserved. You thus cannot filter rows based
-on a column named select. Then again it is a reserved SQL keyword
-too, hence an unlikely column name.
-
-#### Inside JSONB
-
-PostgreSQL >=9.4.2 supports native JSON columns and can even index
-them by internal keys using the `jsonb` column type. PostgREST
-allows you to filter results by internal JSON object values. Use
-the single- and double-arrows to path into and obtain values, e.g.
-
-```HTTP
-GET /stuff?json_col->a->>b=eq.2
-```
-
-This query finds rows in `stuff` where `json_col->'a'->>'b'` is
-equal to 2 (or "2" -- it coerces as needed). The final arrow must
-be the double kind, `->>`, or else PostgREST will not attempt to
-look inside the JSON.
-
-### Ordering
-
-The reserved word `order` reorders the response rows.  It uses a
-comma-separated list of columns and directions:
-
-```HTTP
-GET /people?order=age.desc,height.asc
-```
-
-If no direction is specified it defaults to descending order:
-
-```HTTP
-GET /people?order=age
-```
-
-If you care where nulls are sorted, add `nullsfirst` or `nullslast`:
-
-```HTTP
-GET /people?order=age.nullsfirst
-```
-
-### Limiting and Pagination
-
-#### Pagination by Limit-Offset
-
-PostgREST uses HTTP range headers for limiting and describing the
-size of results. Every response contains the current range and total
-results:
-
-```
-Range-Unit: items
-Content-Range → 0-14/15
-```
-
-This means items zero through fourteen are returned out of a total
-of fifteen -- i.e. all of them. This information is available in
-every response and can help you render pagination controls on the
-client. This is a RFC7233-compliant solution that keeps the response
-JSON cleaner.
-
-The client can set the limit and offset of a request by setting the
-`Range` header. Translate the limit and offset into a range. To
-request the first five elements, include these request headers:
-
-```
-Range-Unit: items
-Range: 0-4
-```
-
-You can also use open-ended ranges for an offset with no limit:
-`Range: 10-`.
-
-#### Suppressing Counts
-
-Sometimes knowing the total row count of a query is unnecessary and
-only adds extra cost to the database query. So you can skip the
-count total using a ```Prefer``` header as:
-
-```
-Prefer: count=none
-```
-
-So the PostgREST response will be something like:
-
-```
-Range-Unit: items
-Content-Range → 0-14/*
-```
-
-### Embedding Foreign Entities
-
-Suppose you have a `projects` table which references `clients` through
-a foreign key called `client_id`. When listing projects through the
-API you can have it embed the client within each project response.
-For example,
-
-```HTTP
-GET /projects?id=eq.1&select=id, name, clients(*)
-```
-
-Notice this is the same `select` keyword which is used to choose
-which columns to include. When a column name is followed by parentheses
-that means to fetch the entire record and nest it. You include a
-list of columns inside the parens, or asterisk to request all
-columns.
-
-The embedding works for 1-N, N-1, and N-N relationships. That means
-you could also ask for a client and all their projects:
-
-```HTTP
-GET /clients?id=eq.42&select=id, name, projects(*)
-```
-
-### Response Format
-
-Query responses default to JSON but you can get them in CSV as well. Just make your request with the header
-
-```HTTP
-Accept: text/csv
-```
-
-### Singular vs Plural
-
-Many APIs distinguish plural and singular resources, e.g.`/stories`
-vs `/stories/1`. Why do we use `/stories?id=eq.1`? It is because a
-single resource is for us a row determined by a primary key, and
-primary keys can be *compound* (meaning defined across more than
-one column). The common urls come from a degenerate case of simple
-(and overwhelmingly numeric) primary keys often introduced automatically
-be Object Relational Mapping.
-
-For consistency's sake all these endpoints return a JSON array,
-`/stories`, `/stories?genre=eq.mystery`, `/stories?id=eq.1`. They
-are all filtering a bigger array. However you might want the
-last one to return a single JSON object, not an array with one
-element. There is currently an open issue to enable this.
-
-### Data Schema
-
-As well as issuing a `GET /` to obtain a list of the tables, views,
-and stored procedures available, you can get more information about
-any particular endpoint.
-
-```HTTP
-OPTIONS /my_view
-```
-
-This will include the row names, their types, primary key
-information, and foreign keys for the given table or view.
-
-<div class="admonition danger">
-    <p class="admonition-title">Deprecation Warning</p>
-
-    <p>Although we currently use the OPTIONS verb for this, some
-    people <a
-    href="https://www.mnot.net/blog/2012/10/29/NO_OPTIONS">argue</a> that
-    this is inappropriate. We are considering a <code>describedby</code>
-    header link instead.</p>
-</div>
-
-### CORS
-
-PostgREST sets highly permissive cross origin resource sharing.  It
-accepts Ajax requests from any domain.

docs/api/writing.md

@@ -1,131 +0,0 @@
-## Updating Data
-
-### Record Creation
-
-* ❌ Cannot be cached or prefetched
-* ❌ Not idempotent
-
-To create a row in a database table post a JSON object whose keys
-are the names of the columns you would like to create. Missing keys
-will be set to default values when applicable.
-
-```HTTP
-POST /table_name
-{ "col1": "value1", "col2": "value2" }
-```
-
-The response will include a `Location` header describing where to
-find the new object. If you would like to get the full object back
-in the response to your request, include the header `Prefer:
-return=representation`. That way you won't have to make another
-HTTP call to discover properties that may have been filled in on
-the server side.
-
-### Bulk Insertion
-
-* ❌ Cannot be cached or prefetched
-* ❌ Not idempotent
-
-While regular insertion uses JSON to encode the value, bulk insertion
-uses CSV. Simply post to a table route with `Content-Type: text/csv`
-and include the names of the columns as the first row. For instance
-
-```HTTP
-POST /people
-name,age,height
-J Doe,62,70
-Jonas,10,55
-```
-
-An empty field (`,,`) is coerced to an empty string and the reserved
-word `NULL` is mapped to the SQL null value. Note that there should
-be no spaces between the column names and commas.
-
-The server sends a multipart response for bulk insertions. Each part
-contains a Location header with URL of each created resource.
-
-```HTTP
-Content-Type: application/json
-Location: /festival?name=eq.Venice%20Film%20Festival
-
-
---postgrest_boundary
-Content-Type: application/json
-Location: /festival?name=eq.Cannes%20Film%20Festival
-```
-
-### Upsertion
-
-* ❌ Cannot be cached or prefetched
-* ✅ Idempotent
-
-To insert or update a single row use the `PUT` verb on a properly
-filtered table url:
-
-```HTTP
-PUT /table_name?primary_key=eq.foo
-{ "col1": "value1", "col2": "value2" }
-```
-
-The request must satisfy two things. First all columns must be
-specified (because a default value might be a changing value which
-would violate idempotence). Second the URL must match the URL you
-would use to get the value of the resource. This means that all
-primary key columns must be included in the filter (there are more
-than one when the primary key is compound).
-
-If you would like to get the full object back in the response to
-your request, include the header `Prefer: return=representation`.
-It will of match exactly the object you sent though.
-
-### Bulk Updates
-
-* ❌ Cannot be cached or prefetched
-* ❌ Not idempotent
-
-To change parts of a resource or resources use the `PATCH` verb.
-For instance, here is how to mark all young people as children.
-
-```HTTP
-PATCH /people?age=lt.13
-{
-  "person_type": "child"
-}
-```
-
-This affects any rows matched by the url param filters, overwrites
-any fields specified in in the payload JSON and leaves the other
-fields unaffected. Note that although the payload is not in the
-JSON patch format specified by
-[RFC6902](https://tools.ietf.org/html/rfc6902), HTTP does not specify
-which patch format to use. Our format is more pleasant, meant for
-basic field replacements, and not at all "incorrect."
-
-### Deletion
-
-* ❌ Cannot be cached or prefetched
-* ✅ Idempotent
-
-Simply use the `DELETE` verb. All recors that match your filter
-will be removed. For instance deleting inactive users:
-
-```HTTP
-DELETE /user?active=eq.false
-```
-
-### Protecting Dangerous Actions
-
-Notice that it is very easy to delete or update many records at
-once. In fact forgetting a filter will affect an entire table!
-
-
-<div class="admonition warning">
-    <p class="admonition-title">Invitation to Contribute</p>
-
-    <p>We would like to investigate nginx rules to guard dangerous
-    actions, perhaps requiring a confirmation header or query param
-    to perform the action.</p>
-
-    <p>You're invited to research this option and contribute to
-    this documentation.</p>
-</div>

docs/examples/start.md

@@ -1,346 +0,0 @@
-## Getting Started
-
-### Your First (simple) API
-
-Let's start with the simplest thing possible. We will expose some tables directly for reading and writing by anyone.
-
-Start by making a database
-
-```sh
-createdb demo1
-```
-
-We'll set it up with a film example (courtesy of [Jonathan Harrington](http://blog.jonharrington.org/postgrest-introduction/)). Copy the following into your clipboard:
-
-```sql
-BEGIN;
-
-CREATE TABLE director
-(
-  name text NOT NULL PRIMARY KEY
-);
-
-CREATE TABLE film
-(
-  id serial PRIMARY KEY,
-  title text NOT NULL,
-  year date NOT NULL,
-  director text,
-  rating real NOT NULL DEFAULT 0,
-  language text NOT NULL,
-  CONSTRAINT film_director_fkey FOREIGN KEY (director)
-      REFERENCES director (name) MATCH SIMPLE
-      ON UPDATE CASCADE ON DELETE CASCADE
-);
-
-CREATE TABLE festival
-(
-  name text NOT NULL PRIMARY KEY
-);
-
-CREATE TABLE competition
-(
-  id serial PRIMARY KEY,
-  name text NOT NULL,
-  festival text NOT NULL,
-  year date NOT NULL,
-
-  CONSTRAINT comp_festival_fkey FOREIGN KEY (festival)
-      REFERENCES festival (name) MATCH SIMPLE
-      ON UPDATE CASCADE ON DELETE CASCADE
-);
-
-CREATE TABLE film_nomination
-(
-  id serial PRIMARY KEY,
-  competition integer NOT NULL,
-  film integer NOT NULL,
-  won boolean NOT NULL DEFAULT true,
-
-  CONSTRAINT nomination_competition_fkey FOREIGN KEY (competition)
-     REFERENCES competition (id) MATCH SIMPLE
-     ON UPDATE NO ACTION ON DELETE NO ACTION,
-  CONSTRAINT nomination_film_fkey FOREIGN KEY (film)
-     REFERENCES film (id) MATCH SIMPLE
-     ON UPDATE CASCADE ON DELETE CASCADE
-);
-
-COMMIT;
-```
-
-Apply it to your new database by running
-
-```sh
-# On OS X
-pbpaste | psql demo1
-
-# Or Linux
-# xclip -selection clipboard -o | psql demo1
-```
-
-Start the PostgREST server and point it at the new database.
-
-```sh
-postgrest -d demo1 -U postgres -a postgres --v1schema public
-```
-
-<div class="admonition note">
-    <p class="admonition-title">Note about database users</p>
-
-    <p>If you installed PostgreSQL with Homebrew on Mac then the
-    database username may be your own login rather than
-    <code>postgres</code>.</p>
-</div>
-
-Let's use PostgREST to populate the database. Install a REST client such as [Postman](https://chrome.google.com/webstore/detail/postman/fhbjgbiflinjbdggehcddcbncdddomop?hl=en). Now let's insert some data as a bulk post in CSV format:
-
-```HTTP
-POST http://localhost:3000/festival
-Content-Type: text/csv
-
-name
-Venice Film Festival
-Cannes Film Festival
-```
-
-In Postman it will look like this
-
-![Festival bulk insert in postman](/img/post-festivals.png)
-
-Notice that the post type is `raw` and that `Content-Type: text/csv` set in the Headers tab. 
-
-Note that the server returns a multipart response with URL of each created resource.
-
-```HTTP
-Content-Type: application/json
-Location: /festival?name=eq.Venice%20Film%20Festival
-
-
---postgrest_boundary
-Content-Type: application/json
-Location: /festival?name=eq.Cannes%20Film%20Festival
-```
-
-If you send a GET request to `/festival` it should return
-
-```json
-[
-  {
-    "name": "Venice Film Festival"
-  },
-  {
-    "name": "Cannes Film Festival"
-  }
-]
-```
-
-Now that you've seen how to do a bulk insert, let's do some more and fully populate the database.
-
-Post the following to `/competition`:
-
-```csv
-name,festival,year
-Golden Lion,Venice Film Festival,2014-01-01
-Palme d'Or,Cannes Film Festival,2014-01-01
-```
-
-Now `/director`:
-
-```csv
-name
-Bertrand Bonello
-Atom Egoyan
-David Gordon Green
-Andrey Konchalovskiy
-Mario Martone
-Mike Leigh
-Roy Andersson
-Saverio Costanzo
-Alix Delaporte
-Jean-Pierre Dardenne
-Xiaoshuai Wang
-Kaan Müjdeci
-Tommy Lee Jones
-Nuri Bilge Ceylan
-Michel Hazanavicius
-Xavier Dolan
-Ramin Bahrani
-Alice Rohrwacher
-Andrew Niccol
-Rakhshan Bani-Etemad
-David Oelhoffen
-Bennett Miller
-David Cronenberg
-Shin'ya Tsukamoto
-Joshua Oppenheimer
-Olivier Assayas
-Jean-Luc Godard
-Alejandro González Iñárritu
-Benoît Jacquot
-Fatih Akin
-Francesco Munzi
-Ken Loach
-Abel Ferrara
-Xavier Beauvois
-Naomi Kawase
-```
-
-And `/film`:
-
-```csv
-title,year,director,rating,language
-Chuang ru zhe,2014-01-01,Xiaoshuai Wang,6.19999981,english
-The Look of Silence,2014-01-01,Joshua Oppenheimer,8.30000019,Indonesian
-Fires on the Plain,2014-01-01,Shin'ya Tsukamoto,5.80000019,Japanese
-Far from Men,2014-01-01,David Oelhoffen,7.5,english
-Good Kill,2014-01-01,Andrew Niccol,6.0999999,english
-Leopardi,2014-01-01,Mario Martone,6.9000001,english
-Sivas,2014-01-01,Kaan Müjdeci,7.69999981,english
-Black Souls,2014-01-01,Francesco Munzi,7.0999999,english
-Three Hearts,2014-01-01,Benoît Jacquot,5.80000019,French
-Pasolini,2014-01-01,Abel Ferrara,5.80000019,english
-Le dernier coup de marteau,2014-01-01,Alix Delaporte,6.5,english
-Manglehorn,2014-01-01,David Gordon Green,7.0999999,english
-Hungry Hearts,2014-01-01,Saverio Costanzo,6.4000001,English
-Belye nochi pochtalona Alekseya Tryapitsyna,2014-01-01,Andrey Konchalovskiy,6.9000001,Russian
-99 Homes,2014-01-01,Ramin Bahrani,7.30000019,english
-The Cut,2014-01-01,Fatih Akin,6,Armenian
-Birdman: Or (The Unexpected Virtue of Ignorance),2014-01-01,Alejandro González Iñárritu,8,English
-La rançon de la gloire,2014-01-01,Xavier Beauvois,5.69999981,French
-A Pigeon Sat on a Branch Reflecting on Existence,2014-01-01,Roy Andersson,7.19999981,english
-Tales,2014-01-01,Rakhshan Bani-Etemad,6.80000019,english
-The Wonders,2014-01-01,Alice Rohrwacher,6.80000019,Italian
-Foxcatcher,2014-01-01,Bennett Miller,7.19999981,English
-Mr. Turner,2014-01-01,Mike Leigh,7,English
-Jimmy's Hall,2014-01-01,Ken Loach,6.69999981,English
-The Homesman,2014-01-01,Tommy Lee Jones,6.5999999,English
-The Captive,2014-01-01,Atom Egoyan,5.9000001,english
-Goodbye to Language,2014-01-01,Jean-Luc Godard,6.19999981,French
-The Search,2014-01-01,Michel Hazanavicius,6.9000001,French
-Still the Water,2014-01-01,Naomi Kawase,6.9000001,Japanese
-Mommy,2014-01-01,Xavier Dolan,8.30000019,French
-"Two Days, One Night",2014-01-01,Jean-Pierre Dardenne,7.4000001,French
-Maps to the Stars,2014-01-01,David Cronenberg,6.4000001,English
-Saint Laurent,2014-01-01,Bertrand Bonello,6.5,French
-Clouds of Sils Maria,2014-01-01,Olivier Assayas,6.9000001,english
-Winter Sleep,2014-01-01,Nuri Bilge Ceylan,8.5,Turkish
-```
-
-Finally `/film_nomination`:
-
-```csv
-competition,film,won
-1,1,f
-1,2,f
-1,3,f
-1,4,f
-1,5,f
-1,6,f
-1,7,f
-1,8,f
-1,9,f
-1,10,f
-1,11,f
-1,12,f
-1,13,f
-1,14,f
-1,15,f
-1,16,f
-1,17,f
-1,18,f
-1,19,f
-1,20,f
-2,21,f
-2,22,f
-2,23,f
-2,24,f
-2,25,f
-2,26,f
-2,27,f
-2,28,f
-2,29,f
-2,30,f
-2,31,f
-2,32,f
-2,33,f
-2,34,f
-2,35,f
-```
-
-At this point nominations are fully specified but it's not a convenient interface for a rest client. Let's make a view they can use. Paste this into `psql demo1`.
-
-```sql
-create or replace view nomination as
-select comp.festival,  
-       comp.name as competition,
-       comp.year,
-       film.title,
-       film.director,
-       film.rating
- from film_nomination as nom
- left join film on nom.film = film.id
- left join competition as comp on nom.competition = comp.id
- order by comp.year desc, comp.festival, competition;
-```
-
-Time to try it out. Let's get the contents of the new view, ordered by film rating
-
-```
-GET http://localhost:3000/nomination?order=rating.desc
-```
-
-If you find it more human readable, add an `Accept: text/csv` header.
-
-### Releasing a New Version
-
-Suppose we want this endpoint to cater to those moviegoers with attention deficit disorder. In today's busy world we don't have time to read an extra couple words or compare nuanced reviews. In API version two we will truncate the names and round the ratings!
-
-Each version lives in a numbered schema, so let's make a schema for version two.
-
-```sql
-CREATE SCHEMA "2";
-GRANT USAGE ON SCHEMA "2" TO PUBLIC;
-ALTER DATABASE demo1 SET search_path = "2", "public";
-```
-
-To override the `films` endpoint create a view in the "2" schema with that name:
-
-```sql
-create or replace view "2".film as
-select id, substring(f.title from 1 for 10) as title,
-       year, director, round(f.rating) as rating, language
-from "public".film as f;
-```
-
-We select the desired version as part of content negotiation. Try this get request:
-
-```HTTP
-GET http://localhost:3000/film
-Accept: text/csv; version=2
-```
-
-Then try toggling the version string in the Accept header and watch the results change. Pretty good, now how about writing values? PostgreSQL's nice feature called auto-updatable views allows writes to pass through views. Sadly this view is not eligible because truncation and rounding cannot be uniquely reversed. If we attempt to post a new result it complains:
-
-```json
-{
-  "hint": null,
-  "details": "View columns that are not columns of their base relation are not updatable.",
-  "code": "0A000",
-  "message": "cannot insert into column \"title\" of view \"film\""
-}
-```
-
-This is a case where we need explicit triggers
-
-```sql
--- TODO - FIX THIS
-
--- CREATE OR REPLACE RULE insert_v2_films AS
---   ON INSERT TO "2".film
---   DO INSTEAD
---      INSERT INTO public.film (id, title, year, director, rating, language)
---      VALUES (NEW.id,     NEW.title,
---              NEW.year,   NEW.director,
---              NEW.rating, NEW.language)
---      RETURNING public.film.*;
-```

docs/index.md

@@ -1,68 +0,0 @@
-![PostgREST logo](img/logo.png)
-
-## Introduction
-
-PostgREST is a standalone web server that turns your database directly into a RESTful API. The structural constraints and permissions in the database determine the API endpoints and operations.
-
-This guide explains how to install the software and provides practical examples of its use. You'll learn how to build a fast, versioned, secure API and how to deploy it to production.
-
-The project has a friendly and growing community. Here are some ways to get help or get involved:
-
-* The project [chat room](https://gitter.im/begriffs/postgrest)
-* Report or search [issues](https://github.com/begriffs/postgrest/issues)
-
-### Motivation
-
-Using PostgREST is an alternative to manual CRUD programming. Custom API servers suffer problems. Writing business logic often duplicates, ignores or hobbles database structure. Object-relational mapping is a leaky abstraction leading to slow imperative code. The PostgREST philosophy establishes a single declarative source of truth: the data itself.
-
-#### Declarative Programming
-
-It's easier to ask Postgres to join data for you and let its query planner figure out the details than to loop through rows yourself. It's easier to assign permissions to db objects than to add guards in controllers. (This is especially true for cascading permissions in data dependencies.) It's easier set constraints than to litter code with sanity checks.
-
-#### Leakproof Abstraction
-
-There is no ORM involved. Creating new views happens in SQL with known performance implications. A database administrator can now create an API from scratch with no custom programming. 
-
-#### Embracing the Relational Model
-
-In 1970 E. F. Codd criticized the then-dominant hierarchical model of databases in his article <a href="https://www.seas.upenn.edu/~zives/03f/cis550/codd.pdf">A Relational Model of Data for Large Shared Data Banks</a>. Reading the article reveals a striking similarity between hierarchical databases and nested http routes. With PostgREST we attempt to use flexible filtering and embedding rather than nested routes.
-
-#### One Thing Well
-
-PostgREST has a focused scope. It works well with other tools like Nginx. This forces you to cleanly separate the data-centric CRUD operations from other concerns. Use a collection of sharp tools rather than building a big ball of mud.
-
-#### Shared Improvements
-
-As with any open source project, we all gain from features and fixes in the tool. It's more beneficial than improvements locked inextricably within custom codebases.
-
-### Myths
-
-#### You have to make tons of stored procs and triggers
-
-Modern PostgreSQL features like auto-updatable views and computed columns make this mostly unnecessary. Triggers do play a part, but generally not for irksome boilerplate. When they are required triggers are preferable to ad-hoc app code anyway, since the former work reliably for any codepath.
-
-#### Exposing the database destroys encapsulation
-
-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. The chapter about versioning shows how to do this.
-
-### Conventions
-
-This guide contains highlighted notes and tangential information interspersed with the text.
-
-<div class="admonition note">
-    <p class="admonition-title">Design Consideration</p>
-
-    <p>Contains history which informed the current design. Sometimes it discusses unavoidable tradeoffs or a point of theory.</p>
-</div>
-
-<div class="admonition warning">
-    <p class="admonition-title">Invitation to Contribute</p>
-
-    <p>Points out things we know we want to add or improve. They might give you ideas for ways to contribute to the project.</p>
-</div>
-
-<div class="admonition danger">
-    <p class="admonition-title">Deprecation Warning</p>
-
-    <p>Alerts you to features which will be removed in the next major (breaking) release.</p>
-</div>

docs/install/ecosystem.md

@@ -1,23 +0,0 @@
-## Ecosystem
-
-### Client-Side Libraries
-
-* [mithril.postgrest](https://github.com/catarse/mithril.postgrest) - Mithril plugin to create and authenticate requests
-* [lewisjared/postgrest-request](https://github.com/lewisjared/postgrest-request) - node interface to postgrest instances
-* [JarvusInnovations/jarvus-postgrest-apikit](https://github.com/JarvusInnovations/jarvus-postgrest-apikit) - Sencha framework package for binding models/stores/proxies to PostgREST tables
-
-### Extensions
-
-* [srid/spas](https://github.com/srid/spas) - allow file uploads and basic auth
-
-### Example Apps
-
-* [timwis/ext-postgrest-crud](https://github.com/timwis/ext-postgrest-crud) - browser-based spreadsheet
-* [srid/chronicle](https://github.com/srid/chronicle#deploying-to-heroku) - tracking a tree of personal memories
-* [begriffs/postgrest-example](https://github.com/begriffs/postgrest-example) - how to configure a db for use as an API
-* [marmelab/ng-admin-postgrest](https://github.com/marmelab/ng-admin-postgrest) - automatic database admin panel
-* [tyrchen/goodfilm](https://github.com/tyrchen/goodfilm) - example film api
-
-### In Production
-
-* [Catarse](https://www.catarse.me/)

docs/install/server.md

@@ -1,62 +0,0 @@
-## Installation
-
-### Installing from Pre-Built Release
-
-The [release page](https://github.com/begriffs/postgrest/releases/latest) has precompiled binaries for Mac OS X and 64-bit Ubuntu. Next extract the tarball and run the binary inside with no arguments to see usage instructions:
-
-```sh
-# Untar the release (available at https://github.com/begriffs/postgrest/releases/latest)
-
-$ tar zxf postgrest-0.2.12.0-osx.tar.xz
-
-# Try running it
-$ ./postgrest
-
-# You should see a usage help message
-```
-
-<div class="admonition warning">
-    <p class="admonition-title">Invitation to Contribute</p>
-
-    <p>I currently build the binaries manually for each version. We need to set up an automated build matrix for various architectures. It should support 32- and 64-bit versions of
-
-    <ul><li>Scientific Linux 6</li><li>CentOS</li><li>RHEL 6</li></ul>
-
-    Also it would be good to create packages for Homebrew, and apt.</p>
-</div>
-
-We'll learn the meaning of the command line flags later, but here is a minimal example of running the app. It does all operations as user `postgres`, including for unauthenticated requests.
-
-```sh
-$ ./postgrest -d dbname -U postgres --a postgres --v1schema public
-```
-
-### Building from Source
-
-When a prebuilt binary does not exist for your system you can build the project from source. You'll also need to do this if you want to help with development. [Stack](https://github.com/commercialhaskell/stack) makes it easy. It will install any necessary Haskell dependencies on your system.
-
-* [Install Stack](https://github.com/commercialhaskell/stack#how-to-install) for your platform
-* Build the project
-
-```bash
-git clone https://github.com/begriffs/postgrest.git
-cd postgrest
-stack build
-```
-
-* Run the server
-
-```bash
-stack exec postgrest -- arg1 arg2
-# ... your arguments after the double dashes
-```
-
-If you want to run the test suite, stack can do that too: `stack test`.
-
-### Installing PostgreSQL
-
-To use PostgREST you will need an underlying database. You can use something like Amazon [RDS](https://aws.amazon.com/rds/) but installing your own locally is cheaper and more convenient for development.
-
-* [Instructions for OS X](http://exponential.io/blog/2015/02/21/install-postgresql-on-mac-os-x-via-brew/)
-* [Instructions for Ubuntu 14.04](https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-14-04)
-

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 "." "="

mkdocs.yml

@@ -1,24 +0,0 @@
-site_name: PostgREST
-site_url: http://postgrest.com
-site_description: Building declarative APIs
-site_author: Joe Nelson
-site_favicon: favicon.ico
-
-repo_url: https://github.com/begriffs/postgrest
-
-pages:
-- Home: index.md
-- Install:
-  - The Server: install/server.md
-  - Ecosystem: install/ecosystem.md
-- API:
-  - Reading: api/reading.md
-  - Writing: api/writing.md
-- Admin:
-  - Security: admin/security.md
-  - Versioning: admin/versioning.md
-  - Migration: admin/migration.md
-  - Deployment: admin/deployment.md
-  - Performance: admin/performance.md
-- Examples:
-  - Getting Started: examples/start.md

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.12.0
+version:               0.4.3.0
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
@@ -22,146 +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 && < 0.8
-                     , hasql-backend >= 0.4.1 && < 0.5
-                     , hasql-postgres >= 0.10.4 && < 0.11
-                     , 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 >= 0.8, network >= 2.6
-                     , bytestring, text, split, string-conversions
-                     , stringsearch
-                     , containers, unordered-containers
-                     , optparse-applicative >= 0.11 && < 0.13
-                     , regex-base, regex-tdfa
-                     , Ranged-sets
-                     , transformers, MissingH
-                     , bcrypt >= 0.0.6, base64-string
-                     , network-uri >= 2.6
-                     , resource-pool
-                     , blaze-builder
-                     , vector
-                     , mtl
-                     , cassava
-                     , jwt
-                     , parsec
-                     , errors
-                     , bifunctors
-  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, hasql-backend
-                     , hasql-postgres
-                     , warp, wai
-                     , wai-extra, wai-cors
-                     , wai-middleware-static
-                     , 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
-                     , bytestring, text, split, string-conversions
-                     , stringsearch
-                     , containers, unordered-containers
-                     , optparse-applicative
-                     , regex-base, regex-tdfa
-                     , Ranged-sets
-                     , transformers, MissingH
-                     , bcrypt, base64-string
-                     , network-uri
-                     , resource-pool
-                     , blaze-builder
-                     , vector
-                     , mtl
                      , cassava
-                     , jwt
+                     , 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
-                     , errors
-                     , bifunctors
+                     , 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.App
-                     , PostgREST.Types
-                     , PostgREST.Parsers
-                     , PostgREST.QueryBuilder
+  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.Types
-                     , PostgREST.Parsers
-                     , PostgREST.QueryBuilder
-                     , 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
-                     , Paths_postgrest
-  Build-Depends:       base, hspec == 2.1.*, QuickCheck
-                     , hspec-wai, hspec-wai-json
-                     , hasql, hasql-backend
-                     , hasql-postgres
-                     , 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
-                     , 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
-                     , parsec
-                     , errors
-                     , bifunctors
+                     , 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

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,416 +1,364 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+
 module PostgREST.App (
-  app
-, sqlError
-, isSqlError
-, contentTypeForAccept
-, jsonH
-, requestedSchema
-, TableOptions(..)
+  postgrest
 ) where
 
-import qualified Blaze.ByteString.Builder  as BB
 import           Control.Applicative
-import           Control.Arrow             (second, (***))
-import           Control.Monad             (join)
-import           Data.Bifunctor            (first)
 import qualified Data.ByteString.Char8     as BS
-import qualified Data.ByteString.Lazy      as BL
-import           Data.CaseInsensitive      (original)
-import qualified Data.Csv                  as CSV
-import           Data.Functor.Identity
-import qualified Data.HashMap.Strict       as M
-import           Data.List                 (find, sortBy)
-import           Data.Maybe                (fromMaybe, isJust, isNothing,
-                                            mapMaybe)
-import           Data.Ord                  (comparing)
-import           Data.Ranged.Ranges        (emptyRange)
-import qualified Data.Set                  as S
-import           Data.String.Conversions   (cs)
-import           Data.Text                 (Text, replace, strip)
-import           Text.Regex.TDFA           ((=~))
+import           Data.Maybe
+import           Data.IORef                (IORef, readIORef)
+import           Data.Text                 (intercalate)
 
-import           Text.Parsec.Error
+import qualified Hasql.Pool                 as P
+import qualified Hasql.Transaction          as HT
+import qualified Hasql.Transaction.Sessions as HT
 
-import           Network.HTTP.Base         (urlEncodeVars)
 import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
-import           Network.HTTP.Types.URI    (parseSimpleQuery)
+import           Network.HTTP.Types.URI    (renderSimpleQuery)
 import           Network.Wai
-import           Network.Wai.Internal      (Response (..))
-import           Network.Wai.Parse         (parseHttpAccept)
+import           Network.Wai.Middleware.RequestLogger (logStdout)
 
-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 qualified Hasql.Transaction         as H
 
-import           PostgREST.Auth
+import qualified Data.HashMap.Strict       as M
+
+import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
+                                        , Action(..), Target(..)
+                                        , PreferRepresentation (..)
+                                        , mutuallyAgreeable
+                                        , userApiRequest
+                                        )
+import           PostgREST.Auth            (jwtClaims, containsRole, parseJWK)
 import           PostgREST.Config          (AppConfig (..))
-import           PostgREST.Parsers
-import           PostgREST.PgQuery
-import           PostgREST.PgStructure
-import           PostgREST.QueryBuilder
-import           PostgREST.RangeQuery
+import           PostgREST.DbStructure
+import           PostgREST.DbRequestBuilder( readRequest
+                                           , mutateRequest
+                                           , fieldNames
+                                           )
+import           PostgREST.Error           ( simpleError, pgError
+                                           , apiRequestError
+                                           , singularityError, binaryFieldError
+                                           , connectionLostError
+                                           )
+import           PostgREST.RangeQuery      (allRange, rangeOffset)
+import           PostgREST.Middleware
+import           PostgREST.QueryBuilder ( callProc
+                                        , requestToQuery
+                                        , requestToCountQuery
+                                        , createReadStatement
+                                        , createWriteStatement
+                                        , ResultsWithCount
+                                        )
 import           PostgREST.Types
+import           PostgREST.OpenAPI
 
-import           Prelude
+import           Data.Function (id)
+import           Protolude              hiding (intercalate, Proxy)
+import           Safe                   (headMay)
 
-app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response
-app dbstructure conf reqBody dbrole req =
-  case (path, verb) of
+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
 
-    ([], _) -> do
-      let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs
-      return $ responseLBS status200 [jsonH] $ cs body
+  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)
 
-    ([table], "OPTIONS") -> do
-      let cols = filter (filterCol schema table) allCols
-          pkeys = map pkName $ filter (filterPk schema table) allPrKeys
-          body = encode (TableOptions cols pkeys)
-      return $ responseLBS status200 [jsonH, allOrigins] $ cs body
+            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
 
-    ([table], "GET") ->
-      if range == Just emptyRange
-      then return $ responseLBS status416 [] "HTTP Range error"
-      else
-        case queries of
-          Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
-          Right (qs, cqs) -> do
-            let qt = qualify table
-                count = if hasPrefer "count=none"
-                      then countNone
-                      else cqs
-                q = B.Stmt "select " V.empty True <>
-                    parentheticT count
-                    <> commaq <> (
-                    bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
-                    . limitT range
-                    $ qs
-                  )
-            row <- H.maybeEx q
-            let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
-                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
-              [contentTypeH, contentRange,
-                ("Content-Location",
-                  "/" <> cs table <>
-                    if Prelude.null canonical then "" else "?" <> cs canonical
-                )
-              ] (fromMaybe "[]" body)
+isResponse503 :: Response -> Bool
+isResponse503 resp = statusCode (responseStatus resp) == 503
 
-        where
-            from = fromMaybe 0 $ rangeOffset <$> range
-            apiRequest = first formatParserError (parseGetRequest req)
-                     >>= first formatRelationError . addRelations schema allRels Nothing
-                     >>= addJoinConditions schema allCols
-                     where
-                       formatRelationError :: Text -> Text
-                       formatRelationError e = cs $ encode $ object [
-                         "mesage" .= ("could not find foreign keys between these entities"::String),
-                         "details" .= e]
-                       formatParserError :: ParseError -> Text
-                       formatParserError e = cs $ encode $ object [
-                         "message" .= message,
-                         "details" .= details]
-                         where
-                           message = show (errorPos e)
-                           details = strip $ replace "\n" " " $ cs
-                             $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
+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
 
-            query = requestToQuery schema <$> apiRequest
-            countQuery = requestToCountQuery schema <$> apiRequest
-            queries = (,) <$> query <*> countQuery
+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
 
+        (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)
 
-    (["postgrest", "users"], "POST") -> do
-      let user = decode reqBody :: Maybe AuthUser
+        (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
+                        ]
 
-      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))
-            ] ""
+                  return . responseLBS status201 headers $
+                    if iPreferRepresentation apiRequest == Full
+                      then toS body else ""
 
-    (["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
+        (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] ""
 
-          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.")]
+        (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] ""
 
-    ([table], "POST") -> do
-      let qt = qualify table
-          echoRequested = hasPrefer "return=representation"
-          parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
-          parsed = if lookupHeader "Content-Type" == Just csvMT
-            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
-              pKeys = map pkName $ filter (filterPk schema table) allPrKeys
-              responses = flip map inserted $ \obj -> do
-                let primaries =
-                      if Prelude.null pKeys
-                        then obj
-                        else M.filterWithKey (const . (`elem` pKeys)) 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
+        (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] ""
 
-    (["rpc", proc], "POST") -> do
-      let qi = QualifiedIdentifier schema (cs proc)
-      exists <- doesProcExist schema proc
-      if exists
-        then do
-          let call = B.Stmt "select " V.empty True <>
-                asJson (callProc qi $ fromMaybe M.empty (decode reqBody))
-          body :: Maybe (Identity Text) <- H.maybeEx call
-          return $ responseLBS status200 [jsonH]
-            (cs $ fromMaybe "[]" $ runIdentity <$> body)
-        else return $ responseLBS status404 [] ""
+        (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)
 
-      -- check that proc exists
-      -- check that arg names are all specified
-      -- select * from "1".proc(a := "foo"::undefined) where whereT limit limitT
+        (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
 
-    ([table], "PUT") ->
-      handleJsonObj reqBody $ \obj -> do
-        let qt = qualify table
-            pKeys = map pkName $ filter (filterPk schema table) allPrKeys
-            specifiedKeys = map (cs . fst) qq
-        if S.fromList pKeys /= S.fromList specifiedKeys
-          then return $ responseLBS status405 []
-            "You must speficy all and only primary keys as params"
-          else do
-            let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols
-                cols = map cs $ M.keys obj
-            if S.fromList tableCols == S.fromList cols
-              then do
-                let vals = M.elems obj
-                H.unitEx $ iffNotT
-                  (whereT qt qq $ update qt cols vals)
-                  (insertSelect qt cols vals)
-                return $ responseLBS status204 [ jsonH ] ""
+        _ -> return notFound
 
-              else return $ if Prelude.null tableCols
-                then responseLBS status404 [] ""
-                else responseLBS status400 []
-                  "You must specify all columns in PUT request"
+    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)
 
-    ([table], "PATCH") ->
-      handleJsonObj reqBody $ \obj -> do
-        let qt = qualify table
-            up = returningStarT
-              . whereT qt 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
-
-        row <- H.maybeEx patch
-        let (queryTotal, body) =
-              fromMaybe (0 :: Int, Just "" :: Maybe Text) row
-            r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
-            echoRequested = hasPrefer "return=representation"
-            s = case () of _ | queryTotal == 0 -> status404
-                             | echoRequested -> status200
-                             | otherwise -> status204
-        return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
-
-    ([table], "DELETE") -> do
-      let qt = qualify table
-          del = countT
-            . returningStarT
-            . whereT qt 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))] ""
-
-    (_, _) ->
-      return $ responseLBS status404 [] ""
+      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
-    allTabs = tables dbstructure
-    allRels = relations dbstructure
-    allCols = columns dbstructure
-    allPrKeys = primaryKeys dbstructure
-    filterCol sc table (Column{colSchema=s, colTable=t}) =  s==sc && table==t
-    filterCol _ _ _ =  False
-    filterPk sc table pk = sc == pkSchema pk && table == pkTable pk
+    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
 
-    filterTableAcl :: Text -> Table -> Bool
-    filterTableAcl r (Table{tableAcl=a}) = r `elem` a
-    path          = pathInfo req
-    verb          = requestMethod req
-    qq            = queryString req
-    qualify       = QualifiedIdentifier schema
-    hdrs          = requestHeaders req
-    lookupHeader  = flip lookup hdrs
-    hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs
-    accept        = lookupHeader hAccept
-    schema        = requestedSchema (cs $ configV1Schema conf) accept
-    authenticator = cs $ configDbUser conf
-    jwtSecret     = cs $ configJwtSecret conf
-    range         = rangeRequested hdrs
-    allOrigins    = ("Access-Control-Allow-Origin", "*") :: Header
-    contentType   = fromMaybe "application/json" $ contentTypeForAccept accept
-    contentTypeH  = (hContentType, contentType)
+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
 
-sqlError :: t
-sqlError = undefined
+splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
+splitKeyValue kv = (k, BS.tail v)
+  where (k, v) = BS.break (== '=') kv
 
-isSqlError :: t
-isSqlError = undefined
+renderLocationFields :: [BS.ByteString] -> BS.ByteString
+renderLocationFields fields =
+  renderSimpleQuery True $ map splitKeyValue fields
 
-rangeStatus :: Int -> Int -> Maybe Int -> Status
+rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
 rangeStatus _ _ Nothing = status200
-rangeStatus from to (Just total)
-  | from > total            = status416
-  | (1 + to - from) < total = status206
+rangeStatus lower upper (Just total)
+  | lower > total            = status416
+  | (1 + upper - lower) < total = status206
   | otherwise               = status200
 
-contentRangeH :: Int -> Int -> Maybe Int -> Header
-contentRangeH from to total =
-    ("Content-Range", cs headerValue)
+contentRangeH :: Integer -> Integer -> Maybe Integer -> Header
+contentRangeH lower upper total =
+    ("Content-Range", headerValue)
     where
       headerValue   = rangeString <> "/" <> totalString
       rangeString
-        | totalNotZero && fromInRange = show from <> "-" <> cs (show to)
+        | totalNotZero && fromInRange = show lower <> "-" <> show upper
         | otherwise = "*"
       totalString   = fromMaybe "*" (show <$> total)
       totalNotZero  = fromMaybe True ((/=) 0 <$> total)
-      fromInRange   = from <= to
+      fromInRange   = lower <= upper
 
-requestedSchema :: Text -> Maybe BS.ByteString -> Text
-requestedSchema v1schema accept =
-  case verStr of
-    Just [[_, ver]] -> if ver == "1" then v1schema else cs ver
-    _ -> v1schema
-
-  where
-    verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString
-    verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]]
-
-
-jsonMT :: BS.ByteString
-jsonMT = "application/json"
-
-csvMT :: BS.ByteString
-csvMT = "text/csv"
-
-allMT :: BS.ByteString
-allMT = "*/*"
-
-jsonH :: Header
-jsonH = (hContentType, jsonMT)
-
-contentTypeForAccept :: Maybe BS.ByteString -> Maybe BS.ByteString
-contentTypeForAccept accept
-  | isNothing accept || has allMT || has jsonMT = Just jsonMT
-  | has csvMT = Just csvMT
-  | otherwise = Nothing
-  where
-    Just acceptH = accept
-    findInAccept = flip find $ parseHttpAccept acceptH
-    has          = isJust . findInAccept . BS.isPrefixOf
-
-bodyForAccept :: BS.ByteString -> QualifiedIdentifier  -> StatementT
-bodyForAccept contentType table
-  | contentType == csvMT = asCsvWithCount table
-  | otherwise = asJsonWithCount -- defaults to 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 @@
-module PostgREST.Auth where
+{-# LANGUAGE FlexibleContexts #-}
+{-|
+Module      : PostgREST.Auth
+Description : PostgREST authorization functions.
 
-import           Control.Applicative
-import           Control.Monad           (mzero)
-import           Crypto.BCrypt
-import           Data.Aeson
-import           Data.Map
-import           Data.Monoid
-import           Data.String.Conversions (cs)
-import           Data.Text
-import           Data.Maybe (isNothing)
-import qualified Data.Vector             as V
-import qualified Hasql                   as H
-import qualified Hasql.Backend           as B
-import qualified Hasql.Postgres          as P
-import           PostgREST.PgQuery       (pgFmtLit)
-import           Prelude
-import qualified Web.JWT                 as JWT
+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           System.IO.Unsafe
+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
 
-data AuthUser = AuthUser {
-    userId   :: String
-  , userPass :: String
-  , userRole :: Maybe String
-  } deriving (Show)
+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
 
-instance FromJSON AuthUser where
-  parseJSON (Object v) = AuthUser <$>
-                         v .: "id" <*>
-                         v .: "pass" <*>
-                         v .:? "role"
-  parseJSON _ = mzero
+import           Crypto.JOSE.Compact
+import           Crypto.JOSE.JWK
+import           Crypto.JOSE.JWS
+import           Crypto.JOSE.Types
+import           Crypto.JWT
 
-instance ToJSON AuthUser where
-  toJSON u = object [
-      "id" .= userId u
-    , "pass" .= userPass u
-    , "role" .= userRole u ]
+{-|
+  Possible situations encountered with client JWTs
+-}
+data JWTAttempt = JWTInvalid JWTError
+                | JWTMissingSecret
+                | JWTClaims (M.HashMap Text Value)
+                deriving (Eq, Show)
 
-type DbRole = Text
-type UserId = Text
+{-|
+  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
 
-data LoginAttempt =
-    NoCredentials
-  | MalformedAuth
-  | LoginFailed
-  | LoginSuccess DbRole UserId
-  deriving (Eq, Show)
+{-|
+  Whether a response from jwtClaims contains a role claim
+-}
+containsRole :: JWTAttempt -> Bool
+containsRole (JWTClaims claims) = M.member "role" claims
+containsRole _ = False
 
-checkPass :: Text -> Text -> Bool
-checkPass = (. cs) . validatePassword . cs
+{-|
+  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
 
-setRole :: Text -> H.Tx P.Postgres s ()
-setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True
+parseJWK :: ByteString -> JWK
+parseJWK str =
+  fromMaybe (hs256jwk str) (decode (toS str) :: Maybe JWK)
 
-setUserId :: Text -> H.Tx P.Postgres s ()
-setUserId uid =
-  if uid /= ""
-    then H.unitEx $ B.Stmt ("set local 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 -> Maybe Text -> H.Tx P.Postgres s ()
-addUser identity pass role =
-  H.unitEx $
-    if isNothing role
-      then [H.stmt|insert into postgrest.auth (id, pass) values (?, ?)|]
-        identity hashedText
-      else [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
-        identity hashedText role
-  where Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
-        hashedText = cs hashed :: Text
-
-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,13 +1,15 @@
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {-|
 Module      : PostgREST.Config
 Description : Manages PostgREST configuration options.
 
-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.
+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.
+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.
 -}
@@ -15,57 +17,57 @@ 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           Data.List                   (intercalate)
-import           Data.String.Conversions     (cs)
-import           Data.Text                   (strip)
+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 (columns)
+import           Options.Applicative hiding  (str)
 import           Paths_postgrest             (version)
-import           Prelude
+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)
 
--- | Data type to store all command line options
+-- | 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
@@ -83,26 +85,112 @@ corsPolicy req = case lookup "origin" headers of
   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 :: String
+prettyVersion :: Text
 prettyVersion = intercalate "." $ map show $ versionBranch version
 
 -- | Function to read and parse options from the command line
 readOptions :: IO AppConfig
-readOptions = customExecParser parserPrefs opts
-  where
-    opts = info (helper <*> argParser) $
-                    fullDesc
-                    <> progDesc (
-                    "PostgREST "
-                    <> prettyVersion
-                    <> " / create a REST API to an existing Postgres database"
-                    )
-    parserPrefs = prefs showHelpOnError
+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 :: Integer
-minimumPgVersion = 90300
+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

@@ -2,54 +2,150 @@
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
-module PostgREST.Error (PgError, errResponse) where
-
+module PostgREST.Error (
+  apiRequestError
+, pgError
+, simpleError
+, singularityError
+, binaryFieldError
+, connectionLostError
+, encodeError
+) where
 
+import           Protolude
 import           Data.Aeson                ((.=))
 import qualified Data.Aeson                as JSON
-import           Data.String.Conversions   (cs)
-import           Data.String.Utils         (replace)
-import qualified Data.Text                 as T
-import qualified Hasql                     as H
-import qualified Hasql.Postgres            as P
+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           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
@@ -64,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,97 +0,0 @@
-module Main where
-
-
-import           PostgREST.PgStructure
-import           PostgREST.Types
-import           Network.Wai
-
-import           PostgREST.App
-import           PostgREST.Error                      (errResponse)
-import           PostgREST.Middleware
-
-import           Control.Monad                        (unless)
-import           Control.Monad.IO.Class               (liftIO)
-import           Data.Functor.Identity
-import           Data.Monoid                          ((<>))
-import           Data.String.Conversions              (cs)
-import           Data.Text                            (Text)
-import qualified Hasql                                as H
-import qualified Hasql.Postgres                       as P
-import           Network.Wai.Handler.Warp             hiding (Connection)
-import           Network.Wai.Middleware.RequestLogger (logStdout)
-
-import           System.IO                            (BufferMode (..),
-                                                       hSetBuffering, stderr,
-                                                       stdin, stdout)
-
-import           PostgREST.Config                     (AppConfig (..),
-                                                       prettyVersion,
-                                                       readOptions,
-                                                       minimumPgVersion)
-
-isServerVersionSupported :: H.Session P.Postgres IO Bool
-isServerVersionSupported = do
-  Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|]
-  return $ read (cs row) >= minimumPgVersion
-
-main :: IO ()
-main = do
-  hSetBuffering stdout LineBuffering
-  hSetBuffering stdin  LineBuffering
-  hSetBuffering stderr NoBuffering
-
-  conf <- readOptions
-  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 . defaultMiddle (configSecure conf)
-
-  poolSettings <- maybe (fail "Improper session settings") return $
-    H.poolSettings (fromIntegral $ configPool conf) 30
-  pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings
-
-  supportedOrError <- H.session pool isServerVersionSupported
-  either (fail . show)
-    (\supported ->
-      unless supported $
-        fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0"
-    ) supportedOrError
-
-  let txSettings = Just (H.ReadCommitted, Just True)
-  metadata <- H.session pool $ H.tx txSettings $ do
-    tabs <- allTables
-    rels <- allRelations
-    cols <- allColumns rels
-    keys <- allPrimaryKeys
-    return (tabs, rels, cols, keys)
-
-  dbstructure <- case metadata of
-    Left e -> fail $ show e
-    Right (tabs, rels, cols, keys) ->
-      return DbStructure {
-          tables=tabs
-        , columns=cols
-        , relations=rels
-        , primaryKeys=keys
-        }
-
-
-  runSettings appSettings $ middle $ \ req respond -> do
-    body <- strictRequestBody req
-    resOrError <- liftIO $ H.session pool $ H.tx txSettings $
-      authenticated conf (app dbstructure conf body) req
-    either (respond . errResponse) respond resOrError

src/PostgREST/Middleware.hs

@@ -1,105 +1,61 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module PostgREST.Middleware where
 
-import           Data.Maybe                    (fromMaybe, isNothing)
-import           Data.Monoid
-import           Data.Text
-import           Data.String.Conversions       (cs)
-import qualified Hasql                         as H
-import qualified Hasql.Postgres                as P
+import           Crypto.JWT
+import           Data.Aeson                    (Value (..))
+import qualified Data.HashMap.Strict           as M
+import qualified Hasql.Transaction             as H
 
-import           Network.HTTP.Types            (RequestHeaders)
-import           Network.HTTP.Types.Header     (hAccept, hAuthorization,
-                                                hLocation)
-import           Network.HTTP.Types.Status     (status301, status400, status401,
-                                                status415)
-import           Network.URI                   (URI (..), parseURI)
-import           Network.Wai                   (Application, Request (..),
-                                                Response, isSecure, rawPathInfo,
-                                                rawQueryString, requestHeaders,
-                                                responseLBS)
+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           Codec.Binary.Base64.String    (decode)
-import           PostgREST.App                 (contentTypeForAccept)
-import           PostgREST.Auth                (DbRole, LoginAttempt (..),
-                                                setRole, setUserId, signInRole,
-                                                signInWithJWT)
+import           PostgREST.ApiRequest          (ApiRequest(..))
+import           PostgREST.Auth                (JWTAttempt(..))
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
+import           PostgREST.Error               (simpleError)
+import           PostgREST.QueryBuilder        (pgFmtLit, unquoted, pgFmtEnvVar)
 
-import           Prelude
+import           Protolude                     hiding (concat, null)
 
-authenticated :: forall s. AppConfig ->
-                 (DbRole -> 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 currentRole req
-    NoCredentials         -> if anon /= currentRole then runInRole anon "" else app currentRole req
+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
 
- 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
-     app r req
-
-
-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
-
-unsupportedAccept :: Application -> Application
-unsupportedAccept app req respond = do
-  let
-    accept = lookup hAccept $ requestHeaders req
-  if isNothing $ contentTypeForAccept accept
-  then respond $ responseLBS status415 [] "Unsupported Accept header, try: application/json"
-  else app req respond
-
-defaultMiddle :: Bool -> Application -> Application
-defaultMiddle secure = (if secure then redirectInsecure else id)
-  . gzip def . cors corsPolicy
+defaultMiddle :: Application -> Application
+defaultMiddle =
+    gzip def
+  . cors corsPolicy
   . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
-  . unsupportedAccept

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

@@ -1,159 +1,223 @@
-module PostgREST.Parsers
-( parseGetRequest
-)
-where
+module PostgREST.Parsers where
 
-import           Control.Applicative hiding ((<$>))
---lines needed for ghc 7.8
-import           Data.Functor ((<$>))
-import           Data.Traversable (traverse)
-
-import           Control.Monad                 (join)
-import           Data.List                     (delete, find)
-import           Data.Maybe
-import           Data.Monoid
-import           Data.String.Conversions       (cs)
-import           Data.Text                     (Text)
+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           Network.Wai                   (Request, pathInfo, queryString)
+import           Data.Either.Combinators       (mapLeft)
+import           PostgREST.RangeQuery          (NonnegRange,allRange)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
-parseGetRequest :: Request -> Either ParseError ApiRequest
-parseGetRequest httpRequest =
-  foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
-  where
-    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
-    addOrder (Node r f) o = Node r{order=o} f
-    flts = mapM pRequestFilter whereFilters
-    rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
-    qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
-    orderStr = join $ lookup "order" qString
-    ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr
-    selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to *
-    whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ]
+import           Text.Parsec.Error
 
-pRequestSelect :: Text -> Parser ApiRequest
-pRequestSelect rootNodeName = do
-  fieldTree <- pFieldForest
-  return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree
-  where
-    treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest
-    treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) =
-      case fldForest of
-        [] -> Node (rNode {fields=fld:fields rNode}) rForest
-        _  -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest)
+pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest
+pRequestSelect rootName selStr =
+  mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
 
-pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
-pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
+pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter)
+pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
   where
-    treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k
-    opVal = parse pOpValueExp ("failed to parse filter (" ++ v ++ ")") v
+    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
-    op = fst <$> opVal
-    val = snd <$> opVal
 
-addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
-addFilter ([], flt) (Node rn@(Select {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest
-addFilter (path, flt) (Node rn forest) =
-  case targetNode of
-    Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
-    Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
+pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm])
+pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
   where
-    targetNodeName:remainingPath = path
-    (targetNode,restForest) = splitForest targetNodeName forest
-    splitForest name forst =
-      case maybeNode of
-        Nothing -> (Nothing,forest)
-        Just node -> (Just node, delete node forest)
-      where maybeNode = find ((name==).mainTable.rootLabel) forst
+    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 = cs <$> many (oneOf " \t")
+ws = toS <$> many (oneOf " \t")
 
 lexeme :: Parser a -> Parser a
 lexeme p = ws *> p <* ws
 
-pTreePath :: Parser (Path,Field)
+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 ( string "->" >>  pJsonPath)
-  let pp = map cs p
-      jpp = map cs <$> jp
-  return (init pp, (last pp, jpp))
-  where
-
+  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 <$> pSelect <*> ( char '(' *> pFieldForest <* char ')'))
-      <|>    Node <$> pSelect <*> pure []
+pFieldTree =  try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest)
+          <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest)
+          <|> Node <$> pFieldSelect <*> pure []
 
 pStar :: Parser Text
-pStar = cs <$> (string "*" *> pure ("*"::String))
+pStar = toS <$> (string "*" *> pure ("*"::ByteString))
+
 
 pFieldName :: Parser Text
-pFieldName =  cs <$> (many1 (letter <|> digit <|> oneOf "_")
-      <?> "field name (* or [a..z0..9_])")
+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 '-'
 
-pJsonPathDelimiter :: Parser Text
-pJsonPathDelimiter = cs <$> (try (string "->>") <|> string "->")
+
+pJsonPathStep :: Parser Text
+pJsonPathStep = toS <$> try (string "->" *> pFieldName)
 
 pJsonPath :: Parser [Text]
-pJsonPath = pFieldName `sepBy1` pJsonPathDelimiter
+pJsonPath = (<>) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) )
 
 pField :: Parser Field
-pField = lexeme $ (,) <$> pFieldName <*> optionMaybe ( pJsonPathDelimiter *>  pJsonPath)
+pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath
 
-pSelect :: Parser SelectItem
-pSelect = lexeme $
-  try ((,) <$> pField <*>((cs <$>) <$> optionMaybe (string "::" *> many letter)) )
+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)
+    return ((s, Nothing), Nothing, Nothing, Nothing)
 
-pOperator :: Parser Operator
-pOperator = cs <$> ( try (string "lte") -- has to be before lt
-     <|> try (string "lt")
-     <|> try (string "eq")
-     <|> try (string "gte") -- has to be before gh
-     <|> try (string "gt")
-     <|> try (string "lt")
-     <|> try (string "neq")
-     <|> try (string "like")
-     <|> try (string "ilike")
-     <|> try (string "in")
-     <|> try (string "notin")
-     <|> try (string "is" )
-     <|> try (string "isnot")
-     <|> try (string "@@")
-     <?> "operator (eq, gt, ...)"
-     )
+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
 
-pValue :: Parser FValue
-pValue = VText <$> (cs <$> many anyChar)
+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 (.)"
 
-pOperatiorWithNegation :: Parser Operator
-pOperatiorWithNegation = try ( (<>) <$> ( cs <$> string "not." ) <*>  pOperator) <|> pOperator
-
-pOpValueExp :: Parser (Operator, FValue)
-pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue)
-
 pOrder :: Parser [OrderTerm]
 pOrder = lexeme pOrderTerm `sepBy` char ','
 
 pOrderTerm :: Parser OrderTerm
 pOrderTerm =
   try ( do
-    c <- pFieldName
-    _ <- pDelimiter
-    d <- string "asc" <|> string "desc"
-    nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure ("nulls last"::String)) <|> try(string "nullsfirst" *> pure ("nulls first"::String))))
-    return $ OrderTerm (cs c) (cs d) (cs <$> nls)
+    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 <$> (cs <$> pFieldName) <*> pure "asc" <*> pure Nothing
+  <|> 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,306 +0,0 @@
-{-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE MultiWayIf           #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module PostgREST.PgQuery where
-
-
-import qualified Hasql                   as H
-import qualified Hasql.Backend           as B
-import qualified Hasql.Postgres          as P
-import           PostgREST.RangeQuery
-import           PostgREST.Types         (OrderTerm (..), QualifiedIdentifier(..))
-
-import           Control.Monad           (join)
-import qualified Data.Aeson              as JSON
-import qualified Data.ByteString.Char8   as BS
-import           Data.Functor
-import qualified Data.HashMap.Strict     as H
-import qualified Data.List               as L
-import           Data.Maybe              (fromMaybe)
-import           Data.Monoid
-import           Data.Scientific         (FPFormat (..), formatScientific,
-                                          isInteger)
-import           Data.String.Conversions (cs)
-import qualified Data.Text               as T
-import           Data.Vector             (empty)
-import qualified Data.Vector             as V
-import qualified Network.HTTP.Types.URI  as Net
-import           Text.Regex.TDFA         ((=~))
-
-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
-
-
-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 :: QualifiedIdentifier -> Net.Query -> StatementT
-whereT table 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","select"] ]
-    wherePredTable = wherePred table
-    conjunction = mconcat $ L.intersperse andq (map wherePredTable 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 pg_catalog.count(1) FROM qqq" }
-
-countRows :: QualifiedIdentifier  -> PStmt
-countRows t = B.Stmt ("select pg_catalog.count(1) from " <> fromQi t) empty True
-
-countNone :: PStmt
-countNone = B.Stmt "select null" empty True
-
-asCsvWithCount :: QualifiedIdentifier -> StatementT
-asCsvWithCount table = withCount . asCsv table
-
-asCsv :: QualifiedIdentifier -> StatementT
-asCsv table s = s {
-  B.stmtTemplate =
-    "(select string_agg(quote_ident(column_name::text), ',') from "
-    <> "(select column_name from information_schema.columns where quote_ident(table_schema) || '.' || table_name = '"
-    <> fromQi table <> "' order by ordinal_position) h) || '\r' || "
-    <> "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '') from ("
-    <> B.stmtTemplate s <> ") t" }
-
-asJsonWithCount :: StatementT
-asJsonWithCount = withCount . asJson
-
-asJson :: StatementT
-asJson s = s {
-  B.stmtTemplate =
-    "array_to_json(array_agg(row_to_json(t)))::character varying from ("
-    <> B.stmtTemplate s <> ") t" }
-
-withCount :: StatementT
-withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s }
-
-asJsonRow :: StatementT
-asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
-
-returningStarT :: StatementT
-returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
-
-deleteFrom :: QualifiedIdentifier -> PStmt
-deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True
-
-insertInto :: QualifiedIdentifier
-              -> V.Vector T.Text
-              -> V.Vector (V.Vector JSON.Value)
-              -> PStmt
-insertInto t cols vals
-  | V.null cols = B.Stmt ("insert into " <> fromQi t <> " default values returning *") empty True
-  | otherwise   = B.Stmt
-    ("insert into " <> fromQi 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(" <> fromQi t <> ".*)")
-    empty True
-
-insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
-insertSelect t [] _ = B.Stmt
-  ("insert into " <> fromQi t <> " default values returning *") empty True
-insertSelect t cols vals = B.Stmt
-  ("insert into " <> fromQi t <> " ("
-    <> T.intercalate ", " (map pgFmtIdent cols)
-    <> ") select "
-    <> T.intercalate ", " (map insertableValue vals))
-  empty True
-
-update :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
-update t cols vals = B.Stmt
-  ("update " <> fromQi t <> " set ("
-    <> T.intercalate ", " (map pgFmtIdent cols)
-    <> ") = ("
-    <> T.intercalate ", " (map insertableValue vals)
-    <> ")")
-  empty True
-
-callProc :: QualifiedIdentifier -> JSON.Object -> PStmt
-callProc qi params = do
-  let args = T.intercalate "," $ map assignment (H.toList params)
-  B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True
-  where
-    assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
-
-wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt
-wherePred table (col, predicate) =
-  B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <>
-      if opCode `elem` ["is","isnot"] then whiteList value
-                                 else cs sqlValue)
-      empty True
-
-  where
-    headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
-    hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
-    opCode        = hasNot (head rest) headPredicate
-    notOp         = hasNot headPredicate ""
-    value         = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
-    sqlValue = pgFmtValue opCode value
-    op = pgFmtOperator opCode
-
-
-whiteList :: T.Text -> T.Text
-whiteList val = fromMaybe
-  (cs (pgFmtLit val) <> "::unknown ")
-  (L.find ((==) . T.toLower $ val) ["null","true","false"])
-
-pgFmtValue :: T.Text -> T.Text -> T.Text
-pgFmtValue opCode value =
-  case opCode of
-    "like" -> unknownLiteral $ T.map star value
-    "ilike" -> unknownLiteral $ T.map star value
-    "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
-    "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
-    "@@" -> "to_tsquery(" <> unknownLiteral value <> ") "
-    _    -> unknownLiteral value
-  where
-    star c = if c == '*' then '%' else c
-    unknownLiteral = (<> "::unknown ") . pgFmtLit
-
-pgFmtOperator :: T.Text -> T.Text
-pgFmtOperator opCode =
-  case opCode of
-    "eq"  -> "="
-    "gt"  -> ">"
-    "lt"  -> "<"
-    "gte" -> ">="
-    "lte" -> "<="
-    "neq" -> "<>"
-    "like"-> "like"
-    "ilike"-> "ilike"
-    "in"  -> "in"
-    "notin" -> "not in"
-    "is"    -> "is"
-    "isnot" -> "is not"
-    "@@" -> "@@"
-    _     -> "="
-
-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 :: QualifiedIdentifier -> T.Text -> T.Text
-pgFmtJsonbPath table p =
-  pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)
-  where
-    pgFmtJsonbPath' (ColIdentifier i) = fromQi table <> "." <> 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 (cs escaped :: BS.ByteString) =~ danger
-    then "\"" <> escaped <> "\""
-    else escaped
-
-  where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString
-
-pgFmtLit :: T.Text -> T.Text
-pgFmtLit x =
-  let trimmed = trimNullChars x
-      escaped = "'" <> T.replace "'" "''" trimmed <> "'"
-      slashed = T.replace "\\" "\\\\" escaped in
-  if T.isInfixOf "\\\\" escaped
-    then "E" <> slashed
-    else slashed
-
-trimNullChars :: T.Text -> T.Text
-trimNullChars = T.takeWhile (/= '\x0')
-
-fromQi :: QualifiedIdentifier -> T.Text
-fromQi t = pgFmtIdent (qiSchema t) <> "." <> pgFmtIdent (qiName 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,264 +0,0 @@
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeSynonymInstances  #-}
-module PostgREST.PgStructure where
-
-import           Control.Applicative
-import           Control.Monad         (join)
-import           Data.Functor.Identity
-import           Data.List             (elemIndex, find)
-import           Data.Maybe            (fromMaybe, isJust, mapMaybe)
-import           Data.Monoid
-import           Data.Text             (Text, split)
-import qualified Hasql                 as H
-import qualified Hasql.Postgres        as P
-import           PostgREST.PgQuery     ()
-import           PostgREST.Types
-
-import           GHC.Exts              (groupWith)
-import           Prelude
-
-
-doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
-doesProcExist schema proc = do
-  row :: Maybe (Identity Int) <- H.maybeEx $ [H.stmt|
-      SELECT 1
-      FROM   pg_catalog.pg_namespace n
-      JOIN   pg_catalog.pg_proc p
-      ON     pronamespace = n.oid
-      WHERE  nspname = ?
-      AND    proname = ?
-    |] schema proc
-  return $ isJust row
-
-
-tableFromRow :: (Text, Text, Bool, Maybe Text) -> Table
-tableFromRow (s, n, i, a) = Table s n i (parseAcl a)
-  where
-    parseAcl :: Maybe Text -> [Text]
-    parseAcl str = fromMaybe [] $ split (==',') <$> str
-
-columnFromRow :: (Text,       Text,      Text,
-                  Int,        Bool,      Text,
-                  Bool,       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 nul typ u l p d (parseEnum e) Nothing
-
-  where
-    parseEnum :: Maybe Text -> [Text]
-    parseEnum str = fromMaybe [] $ split (==',') <$> str
-
-
-relationFromRow :: (Text, Text, [Text], Text, [Text]) -> Relation
-relationFromRow (s, t, cs, ft, fcs) = Relation s t cs ft fcs Child Nothing Nothing Nothing
-
-pkFromRow :: (Text, Text, Text) -> PrimaryKey
-pkFromRow (s, t, n) = PrimaryKey s t n
-
-
-addParentRelation :: Relation -> [Relation] -> [Relation]
-addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c Parent Nothing Nothing Nothing:rel:rels
-
-allTables :: H.Tx P.Postgres s [Table]
-allTables = do
-    rows <- H.listEx $ [H.stmt|
-      SELECT
-        n.nspname AS table_schema,
-        c.relname AS table_name,
-        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,
-        array_to_string(array_agg(r.rolname), ',') AS acl
-      FROM pg_class c
-      CROSS JOIN pg_roles r
-      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')
-        AND (
-          pg_has_role(r.rolname, c.relowner, 'USAGE'::text) OR
-          has_table_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR
-          has_any_column_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) )
-
-      GROUP BY table_schema, table_name, insertable
-      ORDER BY table_schema, table_name
-    |]
-    return $ map tableFromRow rows
-
-allRelations :: H.Tx P.Postgres s [Relation]
-allRelations = do
-  rels <- H.listEx $ [H.stmt|
-    WITH table_fk AS (
-        SELECT ns.nspname AS table_schema,
-               tab.relname AS table_name,
-               column_info.cols AS columns,
-               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 ns,
-           LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
-           LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other
-        WHERE confrelid != 0
-        ORDER BY (conrelid, column_info.nums)
-    )
-
-    SELECT * FROM table_fk
-    UNION
-    (
-        SELECT
-            vcu.table_schema,
-            vcu.view_name AS table_name,
-            array_agg(vcu.column_name::text) AS columns,
-            table_fk.foreign_table_name,
-            table_fk.foreign_columns
-        FROM information_schema.view_column_usage as vcu
-        JOIN table_fk ON
-            table_fk.table_schema = vcu.view_schema AND
-            table_fk.table_name = vcu.table_name AND
-            vcu.column_name = ANY (table_fk.columns)
-        WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
-        AND columns = table_fk.columns
-        GROUP BY vcu.table_schema, vcu.view_name, table_fk.foreign_table_name, table_fk.foreign_columns
-    )
-    UNION
-    (
-        SELECT
-            vcu.view_schema as table_schema,
-            table_fk.table_name,
-            table_fk.columns,
-            vcu.view_name as foreign_table_name,
-            array_agg(vcu.column_name::text) as foreign_columns
-        FROM information_schema.view_column_usage as vcu
-        JOIN table_fk ON
-            table_fk.table_schema = vcu.view_schema AND
-            table_fk.foreign_table_name = vcu.table_name AND
-            vcu.column_name = ANY (table_fk.foreign_columns)
-        WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
-            AND foreign_columns = table_fk.foreign_columns
-        GROUP BY vcu.view_schema, table_fk.table_name, vcu.view_name, table_fk.columns
-    )
-  |]
-  let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels
-  let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations
-  return $ simpleRelations ++ mapMaybe link2Relation links
-  where
-    groupFn :: Relation -> Text
-    groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t
-    link2Relation [
-      Relation{relSchema=sc, relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c},
-      Relation{                           relColumns=lc2, relFTable=ft, relFColumns=fc}
-      ] = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2)
-    link2Relation _ = Nothing
-
-allColumns :: [Relation] -> H.Tx P.Postgres s [Column]
-allColumns rels = 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::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 (
-          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 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
-  |]
-  return $ map (addFK . columnFromRow) cols
-
-  where
-    addFK col = col { colFK = fk col }
-    fk col = join $ relToFk (colName col) <$> find (lookupFn col) rels
-    lookupFn :: Column -> Relation -> Bool
-    lookupFn (Column{colSchema=cs, colTable=ct, colName=cn})  (Relation{relSchema=rs, relTable=rt, relColumns=rc, relType=rty}) =
-      cs==rs && ct==rt && cn `elem` rc && rty==Child
-    lookupFn _ _ = False
-    relToFk cName (Relation{relFTable=t, relColumns=cs, relFColumns=fcs}) = ForeignKey t <$> c
-      where
-        pos = elemIndex cName cs
-        c = (fcs !!) <$> pos
-
-allPrimaryKeys :: H.Tx P.Postgres s [PrimaryKey]
-allPrimaryKeys = do
-  pks <- H.listEx $ [H.stmt|
-    WITH table_pk AS (
-        SELECT
-            kc.table_schema,
-            kc.table_name,
-            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 NOT IN ('pg_catalog', 'information_schema')
-    )
-    SELECT table_schema,
-           table_name,
-           column_name
-    FROM table_pk
-    UNION (
-        SELECT
-            vcu.view_schema,
-            vcu.view_name,
-            vcu.column_name
-         FROM information_schema.view_column_usage AS vcu
-         JOIN
-            table_pk ON table_pk.table_schema = vcu.view_schema AND
-            table_pk.table_name = vcu.table_name AND
-            table_pk.column_name = vcu.column_name
-         WHERE vcu.view_schema NOT IN ('pg_catalog','information_schema')
-    )
-    |]
-  return $ map pkFromRow pks

src/PostgREST/QueryBuilder.hs

@@ -1,165 +1,472 @@
-module PostgREST.QueryBuilder
-where
+{-# 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.
 
-import           Control.Error
-import           Data.List         (find)
-import           Data.Monoid
-import           Data.Text         hiding (filter, find, foldr, head, last, map,
-                                    null, zipWith)
-import           Control.Applicative
-import           Data.Tree
-import           PostgREST.PgQuery (PStmt, fromQi,
-                                    orderT, pgFmtIdent, pgFmtLit, pgFmtOperator,
-                                    pgFmtValue, whiteList)
+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 qualified Data.Vector       as V (empty)
-import qualified Hasql.Backend     as B
+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 (..))
 
-findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation
-findRelation allRelations s t1 t2 =
-  find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations
+{-| 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)
 
-addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
-addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) =
-  case parentNode of
-    Nothing -> Node query{relation=Nothing} <$> updatedForest
-    (Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
-      where
-        rel = note ("no relation between " <> table <> " and " <> parentTable)
-            $  findRelation allRelations schema table parentTable
-           <|> findRelation allRelations schema parentTable table
-        addRel :: Query -> Relation -> Query
-        addRel q r = q{relation = Just r}
+standardRow :: HD.Row ResultsWithCount
+standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
+                    <*> HD.value header <*> HD.value HD.bytea
   where
-    updatedForest = mapM (addRelations schema allRelations (Just node)) forest
+    header = HD.array $ HD.arrayDimension replicateM $ HD.arrayValue HD.bytea
 
-getJoinConditions :: Relation -> [Filter]
-getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) =
-  case typ of
-    Child  -> zipWith (toFilter t ft) cs fcs
-    Parent -> zipWith (toFilter t ft) cs fcs
-    Many   -> zipWith (toFilter t (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" lt)) fcs (fromMaybe [] lc2)
-  where
-    toFilter :: Text -> Text -> FieldName -> FieldName -> Filter
-    toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc))
+noLocationF :: Text
+noLocationF = "array[]::text[]"
 
-addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest
-addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) =
-  case r of
-    Nothing -> Node updatedQuery  <$> updatedForest -- this is the root node
-    Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest
-    Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest
-    Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) ->
-      Node <$> pure qq <*> updatedForest
-      where
-         q = addCond updatedQuery (getJoinConditions rel)
-         qq = q{joinTables=linkTable:joinTables q}
-    _ -> Left "unknow relation"
-  where
-    -- add parentTable and parentJoinConditions to the query
-    updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions
-      where
-        parentJoinConditions = map (getJoinConditions.snd) parents
-        parentTables = map fst parents
-        parents = mapMaybe (getParents.rootLabel) forest
-        getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel)
-        getParents _ = Nothing
-    updatedForest = mapM (addJoinConditions schema allColumns) forest
-    addCond q con = q{filters=con ++ filters q}
+{-| 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
 
-requestToCountQuery :: Text -> ApiRequest -> PStmt
-requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) =
-  B.Stmt query V.empty True
+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
-    query = Data.Text.unwords [
-      "SELECT pg_catalog.count(1)",
-      "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions
+    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
       ]
-    emptyOnNull val x = if null x then "" else val
-    localConditions = filter fn conditions
-      where
-        fn  (Filter{value=VText _}) = True
-        fn  (Filter{value=VForeignKey _ _}) = False
+    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
 
-requestToQuery :: Text -> ApiRequest -> PStmt
-requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) =
-  orderT (fromMaybe [] ord)  query
-  where
-    query = B.Stmt qStr V.empty True
-    qStr = Data.Text.unwords [
-      ("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
-      "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
-      "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)),
-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions
-      ]
-    emptyOnNull val x = if null x then "" else val
-    (withs, selects) = foldr getQueryParts ([],[]) forest
-    getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text])
-    getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s)
+    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 = "("
-           <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
-           <> "FROM (" <> subquery <> ") " <> table
-           <> ") AS " <> table
-           where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
-
-    getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType=Parent}))}) forst) (w,s) = (wit:w,sel:s)
+        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
-        sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
-        wit = table <> " AS ( " <> subquery <> " )"
-          where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
-
-    getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s)
+        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 = "("
-           <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
-           <> "FROM (" <> subquery <> ") " <> table
-           <> ") AS " <> table
-           where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
-
-    -- the following is just to remove the warning
+        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 (Node (Select{relation=Nothing}) _) _ = undefined
-
-pgFmtCondition :: QualifiedIdentifier -> Filter -> Text
-pgFmtCondition table (Filter (col,jp) ops val) =
-  notOp <> " " <> sqlCol  <> " " <> pgFmtOperator opCode <> " " <>
-    if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue
+    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
-    headPredicate:rest = split (=='.') ops
-    hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
-    opCode      = hasNot (head rest) headPredicate
-    notOp       = hasNot headPredicate ""
-    sqlCol = case val of
-      VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp
-      VForeignKey qi _ -> pgFmtColumn qi col
-    sqlValue = valToStr val
-    getInner v = case v of
-      VText s -> s
-      _      -> ""
-    valToStr v = case v of
-      VText s -> pgFmtValue opCode s
-      VForeignKey (QualifiedIdentifier s _) (ForeignKey ft fc) -> pgFmtColumn (QualifiedIdentifier s ft) fc
+    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
+      ]
 
-pgFmtColumn :: QualifiedIdentifier -> Text -> Text
+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
 
-pgFmtJsonPath :: Maybe JsonPath -> Text
+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 _ = ""
 
-pgFmtTable :: Table -> Text
-pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n
+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
 
-pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text
-pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp
-pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp
+pgFmtEnvVar :: Text -> (Text, Text) -> SqlFragment
+pgFmtEnvVar prefix (k, v) =
+  "set local " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";"
 
-asJsonPath :: Maybe JsonPath -> Text
-asJsonPath Nothing = ""
-asJsonPath (Just xx) = " AS " <> last xx
+trimNullChars :: Text -> Text
+trimNullChars = T.takeWhile (/= '\x0')

src/PostgREST/RangeQuery.hs

@@ -3,59 +3,69 @@ module PostgREST.RangeQuery (
 , rangeRequested
 , rangeLimit
 , rangeOffset
+, restrictRange
+, rangeGeq
+, allRange
 , NonnegRange
 ) where
 
 
 import           Control.Applicative
 import           Network.HTTP.Types.Header
-import           PostgREST.Types           ()
 
 import qualified Data.ByteString.Char8     as BS
 import           Data.Ranged.Boundaries
 import           Data.Ranged.Ranges
 
-import           Data.String.Conversions   (cs)
-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)
+    [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
+    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

@@ -1,113 +1,239 @@
+{-# LANGUAGE DuplicateRecordFields    #-}
 module PostgREST.Types where
-import Data.Text
-import Data.Tree
-import qualified Data.ByteString.Char8 as BS
-import Data.Aeson
+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 {
-  tables :: [Table]
-, columns :: [Column]
-, relations :: [Relation]
-, primaryKeys :: [PrimaryKey]
-}
-
-
-data Table = Table {
-  tableSchema :: Text
-, tableName :: Text
-, tableInsertable :: Bool
-, tableAcl :: [Text]
-} deriving (Show)
-
-data ForeignKey = ForeignKey {
-  fkTable::Text, fkCol::Text
+  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 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
-} | Star {colSchema :: Text, colTable :: Text } deriving (Show)
+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 {
-  pkSchema::Text, pkTable::Text, pkName::Text
-}
+    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 :: Text
-, otDirection :: BS.ByteString
-, otNullOrder :: Maybe BS.ByteString
+  otTerm      :: Field
+, otDirection :: Maybe OrderDirection
+, otNullOrder :: Maybe OrderNulls
 } deriving (Show, Eq)
 
 data QualifiedIdentifier = QualifiedIdentifier {
-  qiSchema :: Text
-, qiName   :: Text
+  qiSchema :: Schema
+, qiName   :: TableName
 } deriving (Show, Eq)
 
 
-data RelationType = Child | Parent | Many 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 {
-  relSchema  :: Text
-, relTable   :: Text
-, relColumns  :: [Text]
-, relFTable  :: Text
-, relFColumns :: [Text]
-, relType    :: RelationType
-, relLTable  :: Maybe Text
-, relLCols1   :: Maybe [Text]
-, relLCols2   :: Maybe [Text]
+  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
-data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
+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 SelectItem = (Field, Maybe Cast)
-type Path = [Text]
-data Query = Select {
-  mainTable::Text
-, fields::[SelectItem]
-, joinTables::[Text]
-, filters::[Filter]
-, order::Maybe [OrderTerm]
-, relation::Maybe Relation
-} deriving (Show, Eq)
-data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
-type ApiRequest = Tree Query
+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)
 
-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 ]
+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 ToJSON ForeignKey where
-  toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
+instance Eq Table where
+  Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
 
-instance ToJSON Table where
-  toJSON v = object [
-      "schema"     .= tableSchema v
-    , "name"       .= tableName v
-    , "insertable" .= tableInsertable v ]
+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

@@ -1,7 +1,14 @@
-flags: {}
-packages:
-- '.'
-extra-deps: 
+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
-  - packdeps-0.4.1
-resolver: lts-3.10
+  - 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,72 +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` 200
+      `shouldRespondWith` 401
 
-  it "respects database constraints for role" $
-    post "/postgrest/users" [json| { "id": "ssmith", "pass": "1234", "role": "SUPER_ADMIN_TRUNCATE_POWERS" } |]
-      `shouldRespondWith` 400
-
-  it "does not send a value when no role is provided" $ do
-    post "/postgrest/users" [json| { "id": "bdeey", "pass": "1234" } |]
-      `shouldRespondWith` 201
-    let auth = authHeaderBasic "jdoe" "1234"
-    request methodGet "/authors_only" [auth] ""
-      `shouldRespondWith` 200
-
-  it "recovers after 400 error with logged in user" $ do
-    _ <- post "/postgrest/users" [json| { "id": "jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    let auth = authHeaderBasic "jdoe" "1234"
+  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"]
-        }
+  describe "custom pre-request proc acting on id claim" $ do
 
-  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 "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 "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
+    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"),
@@ -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,164 +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` 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 "jsonb" . after_ (clearTable "json") $ do
+    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" } } |]
-        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
+            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] } |]
-        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
+            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 = []
+          }
 
   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 } |]
@@ -228,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"
@@ -259,20 +375,35 @@ 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` 404
+          `shouldRespondWith` "[]"
+          { matchStatus  = 200,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
       it "can provide a representation" $ do
         _ <- post "/items"
           [json| { id: 1 } |]
@@ -281,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/RangeSpec.hs

@@ -6,13 +6,101 @@ 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" $ do
       context "with response under server size limit" $
         it "returns whole range with status 200" $
@@ -22,29 +110,60 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
         it "returns range Content-Range with /*" $
           request methodGet "/menagerie"
                   [("Prefer", "count=none")] ""
-            `shouldRespondWith` ResponseMatcher {
-              matchBody    = Just "[]"
-            , matchStatus  = 200
+            `shouldRespondWith` "[]"
+            { matchStatus  = 200
             , matchHeaders = ["Content-Range" <:> "*/*"]
             }
 
         it "returns range Content-Range with range/*" $
           request methodGet "/items?order=id"
                   [("Prefer", "count=none")] ""
-            `shouldRespondWith` ResponseMatcher {
-              matchBody    = Just [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
-            , matchStatus  = 200
-            , matchHeaders = ["Content-Range" <:> "0-14/*"]
-            }
+            `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` ResponseMatcher {
-              matchBody    = Just [json| [{"id":1}] |]
-            , matchStatus  = 200
-            , matchHeaders = ["Content-Range" <:> "0-0/*"]
-            }
+            `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
 
@@ -54,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"
@@ -65,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
@@ -76,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" $
@@ -95,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,298 +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":"clients","insertable":true}
-        , {"schema":"1","name":"comments","insertable":true}
-        , {"schema":"1","name":"complex_items","insertable":true}
-        , {"schema":"1","name":"compound_pk","insertable":true}
-        , {"schema":"1","name":"has_count_column","insertable":false}
-        , {"schema":"1","name":"has_fk","insertable":true}
-        , {"schema":"1","name":"insertable_view_with_join","insertable":true}
-        , {"schema":"1","name":"items","insertable":true}
-        , {"schema":"1","name":"json","insertable":true}
-        , {"schema":"1","name":"materialized_view","insertable":false}
-        , {"schema":"1","name":"menagerie","insertable":true}
-        , {"schema":"1","name":"no_pk","insertable":true}
-        , {"schema":"1","name":"nullable_integer","insertable":true}
-        , {"schema":"1","name":"projects","insertable":true}
-        , {"schema":"1","name":"projects_view","insertable":true}
-        , {"schema":"1","name":"simple_pk","insertable":true}
-        , {"schema":"1","name":"tasks","insertable":true}
-        , {"schema":"1","name":"tsearch","insertable":true}
-        , {"schema":"1","name":"users","insertable":true}
-        , {"schema":"1","name":"users_projects","insertable":true}
-        , {"schema":"1","name":"users_tasks","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 "it includes primary and foreign keys for views" $
-      request methodOptions "/insertable_view_with_join" [] "" `shouldRespondWith`
-      [json|
-      {
-         "pkey":[
-            "id"
-         ],
-         "columns":[
-            {
-               "references":null,
-               "default":null,
-               "precision":64,
-               "updatable":false,
-               "schema":"1",
-               "name":"id",
-               "type":"bigint",
-               "maxLen":null,
-               "enum":[],
-               "nullable":true,
-               "position":1
-            },
-            {
-               "references":{
-                  "column":"id",
-                  "table":"auto_incrementing_pk"
-               },
-               "default":null,
-               "precision":32,
-               "updatable":false,
-               "schema":"1",
-               "name":"auto_inc_fk",
-               "type":"integer",
-               "maxLen":null,
-               "enum":[],
-               "nullable":true,
-               "position":2
-            },
-            {
-               "references":{
-                  "column":"k",
-                  "table":"simple_pk"
-               },
-               "default":null,
-               "precision":null,
-               "updatable":false,
-               "schema":"1",
-               "name":"simple_fk",
-               "type":"character varying",
-               "maxLen":255,
-               "enum":[],
-               "nullable":true,
-               "position":3
-            },
-            {
-               "references":null,
-               "default":null,
-               "precision":null,
-               "updatable":false,
-               "schema":"1",
-               "name":"nullable_string",
-               "type":"character varying",
-               "maxLen":null,
-               "enum":[],
-               "nullable":true,
-               "position":4
-            },
-            {
-               "references":null,
-               "default":null,
-               "precision":null,
-               "updatable":false,
-               "schema":"1",
-               "name":"non_nullable_string",
-               "type":"character varying",
-               "maxLen":null,
-               "enum":[],
-               "nullable":true,
-               "position":5
-            },
-            {
-               "references":null,
-               "default":null,
-               "precision":null,
-               "updatable":false,
-               "schema":"1",
-               "name":"inserted_at",
-               "type":"timestamp with time zone",
-               "maxLen":null,
-               "enum":[],
-               "nullable":true,
-               "position":6
-            }
-         ]
-      }
-      |]
+      it "includes paths to tables" $ do
+        r <- simpleBody <$> get "/"
 
-    it "includes foreign key data" $ do
-      pendingWith "have to resolve issue #107"
+        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"
 
-      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 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,187 +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 Control.Applicative
 
-import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
-                                  hRange, hAuthorization, hAccept)
-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 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.App (app)
 import PostgREST.Config (AppConfig(..))
-import PostgREST.Middleware
-import PostgREST.Error(errResponse)
-import PostgREST.PgStructure
-import PostgREST.Types
 
-isLeft :: Either a b -> Bool
-isLeft (Left _ ) = True
-isLeft _ = False
+import Test.Hspec hiding (pendingWith)
+import Test.Hspec.Wai
 
-cfg :: AppConfig
-cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1" "safe"
+import Network.HTTP.Types
+import Network.Wai.Test (SResponse(simpleStatus, simpleHeaders, simpleBody))
 
-testPoolOpts :: PoolSettings
-testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
+import Data.Maybe (fromJust)
+import Data.Aeson (decode, Value(..))
+import qualified JSONSchema.Draft4 as D4
 
-pgSettings :: P.Settings
-pgSettings = P.ParamSettings (cs $ configDbHost cfg)
-                             (fromIntegral $ configDbPort cfg)
-                             (cs $ configDbUser cfg)
-                             (cs $ configDbPass cfg)
-                             (cs $ configDbName cfg)
+import Protolude
 
-withApp :: ActionWith Application -> IO ()
-withApp perform = do
-  pool :: H.Pool P.Postgres
-    <- H.acquirePool pgSettings testPoolOpts
+matchContentTypeJson :: MatchHeader
+matchContentTypeJson = "Content-Type" <:> "application/json; charset=utf-8"
 
-  let txSettings = Just (H.ReadCommitted, Just True)
-  metadata <- H.session pool $ H.tx txSettings $ do
-    tabs <- allTables
-    rels <- allRelations
-    cols <- allColumns rels
-    keys <- allPrimaryKeys
-    return (tabs, rels, cols, keys)
+matchContentTypeSingular :: MatchHeader
+matchContentTypeSingular = "Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"
 
-  dbstructure <- case metadata of
-    Left e -> fail $ show e
-    Right (tabs, rels, cols, keys) ->
-      return $ DbStructure {
-          tables=tabs
-        , columns=cols
-        , relations=rels
-        , primaryKeys=keys
-        }
+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 ()
 
-  perform $ middle $ \req resp -> do
-    body <- strictRequestBody req
-    result <- liftIO $ H.session pool $ H.tx txSettings
-      $ authenticated cfg (app dbstructure cfg body) req
-    either (resp . errResponse) resp result
+getEnvVarWithDefault :: Text -> Text -> IO Text
+getEnvVarWithDefault var def = do
+  varValue <- getEnv (toS var) `E.catchIOError` const (return $ toS def)
+  return $ toS varValue
 
-  where middle = defaultMiddle False
+_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
 
+testCfg :: Text -> AppConfig
+testCfg testDbConn = _baseCfg { configDatabase = testDbConn }
 
-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 |]
+testCfgNoJWT :: Text -> AppConfig
+testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing }
 
-  loadFixture "roles"
-  loadFixture "schema"
+testUnicodeCfg :: Text -> AppConfig
+testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchema = "تست" }
 
+testLtdRowsCfg :: Text -> AppConfig
+testLtdRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 }
 
-loadFixture :: FilePath -> IO()
-loadFixture name =
-  void $ readProcess "psql" ["-U", "postgrest_test", "-d", "postgrest_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []
+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))
+  (hAuthorization, "Basic " <> (toS . B64.encode . toS $ u <> ":" <> p))
 
-authHeaderJWT :: String -> Header
+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]
-
-createComplexItems :: IO ()
-createComplexItems = do
-  pool <- testPool
-  void . liftIO $ H.session pool $ H.tx Nothing txn
-  where
-    txn = mapM_ H.unitEx stmts
-    stmts = getZipList $ [H.stmt|insert into "1".complex_items (id, name, settings) values (?,?,?)|]
-        <$> ZipList ([1..3]::[Int])
-        <*> ZipList (["One", "Two", "Three"]::[Text])
-        <*> ZipList ([jobj,jobj,jobj])
-    jobj = (J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])])
-
-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]
-
-createNullInteger :: IO ()
-createNullInteger = do
-  pool <- testPool
-  void . liftIO $ H.session pool $ H.tx Nothing $
-    H.unitEx $ [H.stmt| insert into "1".nullable_integer (a) values (null) |]
-
-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","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