Bump version

Dockerfile: Clean up to save space (#891 )
Running postgrest requires the libpq library runtime, not the -dev package. Make sure that tools that are used to download and extract the postgrest package do not remain installed in the image.
2017-06-11 17:14:19 -05:00 · 2017-06-11 15:06:58 -05:00 · 2017-06-08 09:10:29 -05:00 · 2017-05-27 00:07:23 -05:00 · 2017-05-24 22:50:09 -05:00 · 2017-05-24 21:37:22 -05:00
70 changed files with 9966 additions and 2256 deletions
@@ -0,0 +1 @@
 /CHANGELOG.md merge=union
@@ -1,3 +1,4 @@
 .DS_Store
 db
 dist
 .cabal-sandbox
@@ -5,3 +6,9 @@ cabal.sandbox.config
 hscope.out
 codex.tags
 .anvil
 .stack-work*
 tags
 site
 *~
 *#*
 .#*
@@ -0,0 +1,270 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 This project adheres to [Semantic Versioning](http://semver.org/).
 ## Unreleased
 ### Fixed
 ## [0.4.2.0] - 2017-06-11
 ### Added
 - #742, Add connection retrying on startup and SIGHUP - @steve-chavez
 - #652, Add and/or params for complex boolean logic - @steve-chavez
 - #808, Env var interpolation in config file (helps Docker) - @begriffs
 - #878 - CSV output support for RPC - @begriffs
 ### Fixed
 - #822, Treat blank string JWT secret as no secret - @begriffs
 ## [0.4.1.0] - 2017-04-25
 ### Added
 - Allow requesting binary output on GET - @steve-chavez
 - Accept clients requesting `Content-Type: application/json` from / - @feynmanliang
 - #493, Updating with empty JSON object makes zero updates @koulakis
 - Make HTTP headers and cookies available as GUCs #800 - @ruslantalpa
 - #701, Ability to quote values on IN filters - @steve-chavez
 - #641, Allow IN filter to have no values - @steve-chavez
 ### Fixed
 - #827, Avoid Warp reaper, extend socket timeout to 1 hour - @majorcode
 - #791, malformed nested JSON error - @diogob
 - Resource embedding in views referencing tables in public schema - @fab1an
 - #777, Empty body is allowed when calling a non-parameterized RPC - @koulakis
 - #831, Fix proc resource embedding issue with search_path - @steve-chavez
 - #547, Use read-only transaction for stable/immutable RPC - @begriffs
 ## [0.4.0.0] - 2017-01-19
 ### Added
 - Allow test database to be on another host - @dsimunic
 - `Prefer: params=single-object` to treat payload as single json argument in RPC - @dsimunic
 - Ability to generate an OpenAPI spec - @mainx07, @hudayou, @ruslantalpa, @begriffs
 - Ability to generate an OpenAPI spec behind a proxy - @hudayou
 - Ability to set addresses to listen on - @hudayou
 - Filtering, shaping and embedding with &select for the /rpc path - @ruslantalpa
 - Output names of used-defined types (instead of 'USER-DEFINED') - @martingms
 - Implement support for singular representation responses for POST/PATCH requests - @ehamberg
 - Include RPC endpoints in OpenAPI output - @begriffs, @LogvinovLeon
 - Custom request validation with `--pre-request` argument - @begriffs
 - Ability to order by jsonb keys - @steve-chavez
 - Ability to specify offset for a deeper level - @ruslantalpa
 - Ability to use binary base64 encoded secrets - @TrevorBasinger
 ### Fixed
 - Do not apply limit to parent items - @ruslantalpa
 - Fix bug in relation detection when selecting parents two levels up by using the name of the FK - @ruslantalpa
 - Customize content negotiation per route - @begriffs
 - Allow using nulls order without explicit order direction - @steve-chavez
 - Fatal error on postgres unsupported version, format supported version in error message - @steve-chavez
 - Prevent database memory cosumption by prepared statements caches - @ruslantalpa
 - Use specific columns in the RETURNING section - @ruslantalpa
 - Fix columns alias for RETURNING - @steve-chavez
 ### Changed
 - Replace `Prefer: plurality=singular` with `Accept: application/vnd.pgrst.object` - @begriffs
 - Standardize arrays in responses for `Prefer: return=representation` - @begriffs
 - Calling unknown RPC gives 404, not 400 - @begriffs
 - Use HTTP 400 for raise\_exception - @begriffs
 - Remove non-OpenAPI schema description - @begriffs
 - Use comma rather than semicolon to separate Prefer header values - @begriffs
 - Omit total query count by default - @begriffs
 - No more reserved `jwt_claims` return type - @begriffs
 - HTTP 401 rather than 400 for expired JWT - @begriffs
 - Remove default JWT secret - @begriffs
 - Use GUC request.jwt.claim.foo rather than postgrest.claims.foo - @begriffs
 - Use config file rather than command line arguments - @begriffs
 ## [0.3.2.0] - 2016-06-10
 ### Added
 - Reload database schema on SIGHUP - @begriffs
 - Support "-" in column names - @ruslantalpa
 - Support column/node renaming `alias:column` - @ruslantalpa
 - Accept posts from HTML forms - @begriffs
 - Ability to order embedded entities - @ruslantalpa
 - Ability to paginate using &limit and &offset parameters - @ruslantalpa
 - Ability to apply limits to embedded entities and enforce --max-rows on all levels - @ruslantalpa, @begriffs
 - Add allow response header in OPTIONS - @begriffs
 ### Fixed
 - Return 401 or 403 for access denied rather than 404 - @begriffs
 - Omit Content-Type header for empty body - @begriffs
 - Prevent role from being changed twice - @begriffs
 - Use read-only transaction for read requests - @ruslantalpa
 - Include entities from the same parent table using two different foreign keys - @ruslantalpa
 - Ensure that Location header in 201 response is URL-encoded - @league
 - Fix garbage collector CPU leak - @ruslantalpa et al.
 - Return deleted items when return=representation header is sent - @ruslantalpa
 - Use table default values for empty object inserts - @begriffs
 ## [0.3.1.1] - 2016-03-28
 ### Fixed
 - Preserve unicode values in insert,update,rpc (regression) - @begriffs
 - Prevent duplicate call to stored procs (regression) - @begriffs
 - Allow SQL functions to generate registered JWT claims - @begriffs
 - Terminate gracefully on SIGTERM (for use in Docker) - @recmo
 - Relation detection fix for views that depend on multiple tables - @ruslantalpa
 - Avoid count on plurality=singular and allow multiple Prefer values - @ruslantalpa
 ## [0.3.1.0] - 2016-02-28
 ### Fixed
 - Prevent query error from infecting later connection - @begriffs, @ruslantalpa, @nikita-volkov, @jwiegley
 ### Added
 - Applies range headers to RPC calls - @diogob
 ## [0.3.0.4] - 2016-02-12
 ### Fixed
 - Improved usage screen - @begriffs
 - Reject non-POSTs to rpc endpoints - @begriffs
 - Throw an error for OPTIONS on nonexistent tables - @calebmer
 - Remove deadlock on simultaneous contentious updates - @ruslantalpa, @begriffs
 ## [0.3.0.3] - 2016-01-08
 ### Fixed
 - Fix bug in many-many relation detection - @ruslantalpa
 - Inconsistent escaping of table names in read queries - @calebmer
 ## [0.3.0.2] - 2015-12-16
 ### Fixed
 - Miscalculation of time used for expiring tokens - @calebmer
 - Remove bcrypt dependency to fix Windows build - @begriffs
 - Detect relations event when authenticator does not have rights to intermediate tables - @ruslantalpa
 - Ensure db connections released on sigint - @begriffs
 - Fix #396 include records with missing parents - @ruslantalpa
 - `pgFmtIdent` always quotes #388 - @calebmer
 - Default schema, changed from `"1"` to `public` - @calebmer
 - #414 revert to separate count query - @ruslantalpa
 - Fix #399, allow inserting in tables with no select privileges using "Prefer: representation=minimal" - @ruslantalpa
 ### Added
 - Allow order by computed columns - @diogob
 - Set max rows in response with --max-rows - @begriffs
 - Selection by column name (can detect if `_id` is not included) - @calebmer
 ## [0.3.0.1] - 2015-11-27
 ### Fixed
 - Filter columns on embedded parent items - @ruslantalpa
 ## [0.3.0.0] - 2015-11-24
 ### Fixed
 - Use reasonable amount of memory during bulk inserts - @begriffs
 ### Added
 - Ensure JWT expires - @calebmer
 - Postgres connection string argument - @calebmer
 - Encode JWT for procs that return type `jwt_claims` - @diogob
 - Full text operators `@>`,`<@` - @ruslantalpa
 - Shaping of the response body (filter columns, embed relations) with &select parameter for POST/PATCH - @ruslantalpa
 - Detect relationships between public views and private tables - @calebmer
 - `Prefer: plurality=singular` for selecting single objects - @calebmer
 ### Removed
 - API versioning feature - @calebmer
 - `--db-x` command line arguments - @calebmer
 - Secure flag - @calebmer
 - PUT request handling - @ruslantalpa
 ### Changed
 - Embed foreign keys with {} rather than () - @begriffs
 - Remove version number from binary filename in release - @begriffs
 ## [0.2.12.1] - 2015-11-12
 ### Fixed
 - Correct order for -> and ->> in a json path - @ruslantalpa
 - Return empty array instead of 500 when a set returning function returns an empty result set - @diogob
 ## [0.2.12.0] - 2015-10-25
 ### Added
 - Embed associations, e.g. `/film?select=*,director(*)` - @ruslantalpa
 - Filter columns, e.g. `?select=col1,col2` - @ruslantalpa
 - Does not execute the count total if header "Prefer: count=none" - @diogob
 ### Fixed
 - Tolerate a missing role in user creation - @calebmer
 - Avoid unnecessary text re-encoding - @ruslantalpa
 ## [0.2.11.1] - 2015-09-01
 ### Fixed
 - Accepts `*/*` in Accept header - @diogob
 ## [0.2.11.0] - 2015-08-28
 ### Added
 - Negate any filter in a uniform way, e.g. `?col=not.eq=foo` - @diogob
 - Call stored procedures
 - Filter NOT IN values, e.g. `?col=notin.1,2,3` - @rall
 - CSV responses to GET requests with `Accept: text/csv` - @diogob
 - Debian init scripts - @mkhon
 - Allow filters by computed columns - @diogob
 ### Fixed
 - Reset user role on error
 - Compatible with Stack
 - Add materialized views to results in GET / - @diogob
 - Indicate insertable=true for views that are insertable through triggers - @diogob
 - Builds under GHC 7.10
 - Allow the use of columns named "count" in relations queried - @diogob
 ## [0.2.10.0] - 2015-06-03
 ### Added
 - Full text search, eg `/foo?text_vector=@@.bar`
 - Include auth id as well as db role to views (for row-level security)
 ## [0.2.9.1] - 2015-05-20
 ### Fixed
 - Put -Werror behind a cabal flag (for CI) so Hackage accepts package
 ## [0.2.9.0] - 2015-05-20
 ### Added
 - Return range headers in PATCH
 - Return PATCHed resources if header "Prefer: return=representation"
 - Allow nested objects and arrays in JSON post for jsonb columns
 - JSON Web Tokens - [Federico Rampazzo](https://github.com/framp)
 - Expose PostgREST as a Haskell package
 ### Fixed
 - Return 404 if no records updated by PATCH
 ## [0.2.8.0] - 2015-04-17
 ### Added
 - Option to specify nulls first or last, eg `/people?order=age.desc.nullsfirst`
 - Filter nulls, `?col=is.null` and `?col=isnot.null`
 - Filter within jsonb, `?col->a->>b=eq.c`
 - Accept CSV in post body for bulk inserts
 ### Fixed
 - Allow NULL values in posts
 - Show full command line usage on param errors
 ## [0.2.7.0] - 2015-03-03
 ### Added
 - Server response logging
 - Filter IN values, e.g. `?col=in.1,2,3`
 - Return POSTed resource if header "Prefer: return=representation"
 - Allow override of default (v1) schema
 ## [0.2.6.0] - 2015-02-18
 ### Added
 - A changelog
 - Filter by substring match, e.g. `?col=like.*hello*` (or ilike for
  case insensitivity).
 - Access-Control-Expose-Headers for CORS
 ### Fixed
 - Make filter position match docs, e.g. `?order=col.asc` rather
  than `?order=asc.col`.
@@ -0,0 +1,69 @@
 # Contributing to PostgREST
 **First:** if you're unsure or afraid of _anything_, just ask or
 submit the issue or pull request anyways. You won't be yelled at
 for giving your best effort. The worst that can happen is that
 you'll be politely asked to change something. We appreciate any
 sort of contributions, and don't want a wall of rules to get in the
 way of that.
 However, for those individuals who want a bit more guidance on the
 best way to contribute to the project, read on. This document will
 cover what we're looking for. By addressing all the points we're
 looking for, it raises the chances we can quickly merge or address
 your contributions.
 ## Issues
 ### Reporting an Issue
 * Make sure you test against the latest released version. It is possible
  we already fixed the bug you're experiencing.
 * Also check the `CHANGELOG.md` to see if any unreleased changes affect
  the issue. The very newest changes can take a little while to be released
  as a new official version.
 * 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
 * All contributions must pass the tests before being merged. When
  you create a pull request your code will automatically be tested.
 * All code must also pass [hlint](http://community.haskell.org/~ndm/hlint/)
  with no warnings. This helps enforce a uniform style for all
  committers. Continuous integration will check this as well on every
  pull request.
 * For help building the Haskell code on your computer check out the [building from
 source](https://postgrest.com/en/stable/install.html#build-from-source)
 wiki page.
 ## Maintenance
 ### Schedule
 Currently I (@begriffs) am the sole maintainer, and while I am
 overjoyed to help resolve issues I also have to balance this with
 my other obligations.  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
@@ -1,45 +1,35 @@
 ![Logo](static/logo.png "Logo")
-[![Build Status](https://circleci.com/gh/begriffs/postgrest.png?circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2)](https://circleci.com/gh/begriffs/postgrest/tree/master)
+[![Build Status](https://circleci.com/gh/begriffs/postgrest.png?style=shield&circle-token=f723c01686abf0364de1e2eaae5aff1f68bd3ff2)](https://circleci.com/gh/begriffs/postgrest/tree/master)
 <a href="https://heroku.com/deploy?template=https://github.com/begriffs/postgrest">
-  <img src="static/heroku.png" alt="Deploy">
+  <img src="https://img.shields.io/badge/%E2%86%91_Deploy_to-Heroku-7056bf.svg" alt="Deploy">
 </a>
 [![Join the chat at https://gitter.im/begriffs/postgrest](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%92-brightgreen.svg)](https://gitter.im/begriffs/postgrest)
 [![Docs](https://img.shields.io/badge/docs-latest-brightgreen.svg?style=flat)](http://postgrest.com)
 PostgREST serves a fully RESTful API from any existing PostgreSQL
 database. It provides a cleaner, more standards-compliant, faster
 API than you are likely to write from scratch.
 ### Demo [postgrest.herokuapp.com](https://postgrest.herokuapp.com) | Watch [Video](https://begriffs.com/posts/2014-12-30-intro-to-postgrest.html)
 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 ([OS X](http://bin.begriffs.com/dbapi/osx/postgrest-0.2.5.1.tar.xz) /  [Ubuntu](http://bin.begriffs.com/dbapi/heroku/postgrest-0.2.5.1.tar.xz)) 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
+    ```bash
-postgrest  --db-host localhost  --db-port 5432     \
+    postgrest --help
-           --db-name my_db      --db-user postgres \
+    ```
           --db-pass foobar     --db-pool 200      \
           --anonymous postgres --secure           \
           --port 3000
 ```
 ### 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))
+TLDR; subsecond response times for up to 2000 requests/sec on Heroku
-
+free tier. If you're used to servers written in interpreted languages
-If you're used to servers written in interpreted languages (or named
+(or named after precious gems), prepare to be pleasantly surprised by
-after precious gems), prepare to be pleasantly surprised by PostgREST
+PostgREST performance.
 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
@@ -55,65 +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) and delegates
+PostgREST [handles
-authorization to the role information defined in the database. This
+authentication](http://postgrest.com/en/stable/auth.html) (via JSON Web
-ensures there is a single declarative source of truth for security.
+Tokens) and delegates authorization to the role information defined in
-When dealing with the database the server assumes the identity of
+the database. This ensures there is a single declarative source of truth
-the currently authenticated user, and for the duration of the
+for security.  When dealing with the database the server assumes the
-connection cannot do anything the user themselves couldn't.
+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
+PostgreSQL 9.5 supports true [row-level
-security](http://michael.otacoo.com/postgresql-2/postgres-9-5-feature-highlight-row-level-security/).
+security](http://www.postgresql.org/docs/9.5/static/ddl-rowsecurity.html).
-In the meantime what isn't yet implemented can be simulated with
+In previous versions it can be simulated with triggers and
-triggers and security-barrier views. Because the possible queries
+security-barrier views. Because the possible queries to the database
-to the database are limited to certain templates using
+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
+versions. PostgREST does versioning through database schemas. This
-negotiation. Requests for a certain version translate into switching
+allows you to expose tables and views without making the app brittle.
-which database schema to search for tables. PostgreSQL schema search
+Underlying tables can be superseded and hidden behind public facing
-paths allow tables from earlier versions to be reused verbatim in
+views.
 later versions.
-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
+This project uses HTTP to communicate other metadata as well.  For
-API explain its own affordances using HTTP. All PostgREST endpoints
+instance the number of rows returned by an endpoint is reported by -
-respond to the OPTIONS verb and explain what they support as well
+and limited with - range headers. More about
 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
 [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
@@ -122,38 +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).
+and the [API guide](http://postgrest.com/en/stable/api.html).
 ### 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)
 ### Thanks
-* [Adam Baker](https://github.com/adambaker) for code
+I'm grateful to the generous project
-  contributions and many fundamental design discussions
+[contributors](https://github.com/begriffs/postgrest/graphs/contributors)
-* [Nikita Volkov](https://github.com/nikita-volkov) for writing the
+who have improved PostgREST immensely with their code and good
-  wonderful [Hasql](https://github.com/nikita-volkov/hasql) library
+judgement.  See more details in the
-  and helping me use it
+[changelog](https://github.com/begriffs/postgrest/blob/master/CHANGELOG.md).
-* [Mikey Casalaina](https://github.com/casalaina) for the cool logo
+
 The cool logo came from [Mikey Casalaina](https://github.com/casalaina).
@@ -10,37 +10,46 @@
    },
    "POSTGREST_VER": {
      "description": "Version of PostgREST to deploy",
-      "value": "0.2.5.1"
+      "value": "0.4.2.0"
    },
-    "DB_NAME": {
+    "DB_URI": {
-      "description": "Database name",
+      "description": "Database connection string",
      "required": true
    },
-    "AUTH_ROLE": {
+    "DB_SCHEMA": {
-      "description": "Database role to use checking client authentication",
+      "description": "The database schema to expose to REST clients. Tables, views and stored procedures in this schema will get API endpoints",
      "required": true,
      "value": "public"
    },
    "DB_ANON_ROLE": {
      "description": "The database role to use when executing commands on behalf of unauthenticated clients",
      "required": true
    },
    "AUTH_PASS": {
      "description": "Authentication password",
      "required": false
    },
    "ANONYMOUS_ROLE": {
      "description": "Database role for non-authenticated requests",
      "required": true
    },
    "DB_HOST": {
      "description": "Database server hostname",
      "required": true
    },
    "DB_PORT": {
      "description": "Database server port",
      "required": false,
      "value": "5432"
    },
    "DB_POOL": {
-      "description": "Maximum number of connections in database pool",
+      "description": "Number of connections to keep open in PostgREST’s database pool",
      "required": false,
      "value": "10"
    },
    "SERVER_PROXY_URI": {
      "description": "Overrides the base URL used within the OpenAPI self-documentation hosted at the API root path",
      "required": false
    },
    "JWT_SECRET": {
      "description": "The secret used to decode JWT tokens clients provide for authentication",
      "required": false
    },
    "SECRET_IS_BASE64": {
      "description": "When this is set to true, the value derived from jwt-secret will be treated as a base64 encoded secret",
      "required": false,
      "value": "false"
    },
    "MAX_ROWS": {
      "description": "A hard limit to the number of rows PostgREST will fetch from a view, table, or stored procedure",
      "required": false
    },
    "PRE_REQUEST": {
      "description": "A schema-qualified stored procedure name to call right after switching roles for a client request",
      "required": false
    }
  }
 }
@@ -1,6 +1,25 @@
-machine:
+dependencies:
  cache_directories:
    - "~/.stack"
    - ".stack-work"
  pre:
-    - createuser --superuser --no-password postgrest_test
+    - 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
-    - createdb -O postgrest_test -U ubuntu postgrest_test
+    - sudo mv /tmp/stack-1.1.2-linux-x86_64/stack /usr/bin
-  ghc:
+    - sudo apt-get update; sudo apt-get install --only-upgrade binutils
-    version: 7.8.3
+  override:
    - stack setup
    - rm -fr $(stack path --dist-dir) $(stack path --local-install-root)
    - stack install hlint packdeps cabal-install
    - stack build --fast
    - stack build --fast --test --no-run-tests
 test:
  override:
    - POSTGREST_TEST_CONNECTION=$(test/create_test_db "postgres://ubuntu@localhost" postgrest_test) stack test
    - git ls-files | grep '\.l\?hs$' | xargs stack exec -- hlint -X QuasiQuotes -X NoPatternSynonyms "$@"
    - stack exec -- cabal update
    - stack exec --no-ghc-package-path -- cabal install --only-d --dry-run
    - stack exec -- packdeps *.cabal || true
    - stack exec -- cabal check
    - stack haddock --no-haddock-deps
    - stack sdist
@@ -0,0 +1,42 @@
 FROM debian:jessie
 # Install libpq5
 RUN apt-get -qq update && \
    apt-get -qq install -y --no-install-recommends libpq5 && \
    apt-get -qq clean && \
    rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/*
 # Install postgrest
 RUN POSTGREST_VERSION="0.4.2.0" \
    BUILD_DEPS="curl ca-certificates xz-utils" && \
    apt-get -qq update && \
    apt-get -qq install -y --no-install-recommends $BUILD_DEPS && \
    cd /tmp && \
    curl -SLO https://github.com/begriffs/postgrest/releases/download/v${POSTGREST_VERSION}/postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
    tar -xJvf postgrest-${POSTGREST_VERSION}-ubuntu.tar.xz && \
    mv postgrest /usr/local/bin/postgrest && \
    cd / && \
    apt-get -qq purge --auto-remove -y $BUILD_DEPS && \
    apt-get -qq clean && \
    rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/*
 COPY postgrest.conf /etc/postgrest.conf
 ENV PGRST_DB_URI= \
    PGRST_DB_SCHEMA=public \
    PGRST_DB_ANON_ROLE= \
    PGRST_DB_POOL=100 \
    PGRST_SERVER_HOST=*4 \
    PGRST_SERVER_PORT=3000 \
    PGRST_SERVER_PROXY_URL= \
    PGRST_JWT_SECRET= \
    PGRST_SECRET_IS_BASE64=false \
    PGRST_MAX_ROWS= \
    PGRST_PRE_REQUEST=
 # PostgREST reads /etc/postgrest.conf so map the configuration
 # file in when you run this container
 CMD exec postgrest /etc/postgrest.conf
 EXPOSE 3000
@@ -0,0 +1,3 @@
 db-uri = "postgres://app_user:password@postgres:5432/app_db"
 db-schema = "public"
 db-anon-role = "app_user"
@@ -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
@@ -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-url = "$(PGRST_SERVER_PROXY_URL)"
 jwt-secret = "$(PGRST_JWT_SECRET)"
 secret-is-base64 = "$(PGRST_SECRET_IS_BASE64)"
 max-rows = "$(PGRST_MAX_ROWS)"
 pre-request = "$(PGRST_PRE_REQUEST)"
@@ -0,0 +1,181 @@
 {-# LANGUAGE CPP #-}
 module Main where
 import           Protolude
 import           PostgREST.App
 import           PostgREST.Config                     (AppConfig (..),
                                                       PgVersion (..),
                                                       minimumPgVersion,
                                                       prettyVersion,
                                                       readOptions)
 import           PostgREST.Error                      (encodeError)
 import           PostgREST.OpenAPI                    (isMalformedProxyUri)
 import           PostgREST.DbStructure
 import           PostgREST.Types                      (DbStructure, Schema)
 import           Control.AutoUpdate
 import           Control.Retry
 import           Data.ByteString.Base64               (decode)
 import           Data.String                          (IsString (..))
 import           Data.Text                            (stripPrefix, pack, replace)
 import           Data.Text.Encoding                   (encodeUtf8, decodeUtf8)
 import           Data.Text.IO                         (hPutStrLn, readFile)
 import           Data.Time.Clock.POSIX                (getPOSIXTime)
 import qualified Hasql.Query                          as H
 import qualified Hasql.Session                        as H
 import qualified Hasql.Decoders                       as HD
 import qualified Hasql.Encoders                       as HE
 import qualified Hasql.Pool                           as P
 import           Network.Wai.Handler.Warp
 import           System.IO                            (BufferMode (..),
                                                       hSetBuffering)
 import           Data.IORef
 #ifndef mingw32_HOST_OS
 import           System.Posix.Signals
 #endif
 isServerVersionSupported :: H.Session Bool
 isServerVersionSupported = do
  ver <- H.query () pgVersion
  return $ ver >= pgvNum minimumPgVersion
 where
  pgVersion =
    H.statement "SELECT current_setting('server_version_num')::integer"
      HE.unit (HD.singleRow $ HD.value HD.int4) False
 {-|
  Background thread that does the following :
  1. Tries to connect to pg server and will keep trying until success.
  2. Checks if the pg version is supported and if it's not it kills the main program.
  3. Obtains the dbStructure.
  4. If 2 or 3 fail to give their result it means the connection is down so it goes back to 1,
     otherwise it finishes his work successfully.
 -}
 connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IORef Bool -> IO ()
 connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
  isWorkerOn <- readIORef refIsWorkerOn
  unless isWorkerOn $ do
    atomicWriteIORef refIsWorkerOn True
    void $ forkIO work
  where
    work = do
      atomicWriteIORef refDbStructure Nothing
      putStrLn ("Attempting to connect to the database..." :: Text)
      connected <- connectingSucceeded pool
      when connected $ do
        result <- P.use pool $ do
          supported <- isServerVersionSupported
          unless supported $ liftIO $ do
            hPutStrLn stderr
              ("Cannot run in this PostgreSQL version, PostgREST needs at least "
              <> pgvName minimumPgVersion)
            killThread mainTid
          dbStructure <- getDbStructure schema
          liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
        case result of
          Left e -> do
            putStrLn ("Failed to query the database. Retrying." :: Text)
            hPutStrLn stderr (toS $ encodeError e)
            work
          Right _ -> do
            atomicWriteIORef refIsWorkerOn False
            putStrLn ("Connection successful" :: Text)
 -- | Connect to pg server if it fails retry with capped exponential backoff until success
 connectingSucceeded :: P.Pool -> IO Bool
 connectingSucceeded pool =
  retrying (capDelay 32000000 $ exponentialBackoff 1000000)
           shouldRetry
           (const $ P.release pool >> isConnectionSuccessful)
  where
    isConnectionSuccessful :: IO Bool
    isConnectionSuccessful = do
      testConn <- P.use pool $ H.sql "SELECT 1"
      case testConn of
        Left e -> hPutStrLn stderr (toS $ encodeError e) >> pure False
        _ -> pure True
    shouldRetry :: RetryStatus -> Bool -> IO Bool
    shouldRetry rs isConnSucc = do
      delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000
      itShould <- pure $ not isConnSucc
      when itShould $
        putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
      return itShould
 main :: IO ()
 main = do
  hSetBuffering stdout LineBuffering
  hSetBuffering stdin  LineBuffering
  hSetBuffering stderr NoBuffering
  conf <- loadSecretFile =<< readOptions
  let host = configHost conf
      port = configPort conf
      proxy = configProxyUri conf
      pgSettings = toS (configDatabase conf)
      appSettings = setHost ((fromString . toS) host)
                  . setPort port
                  . setServerName (toS $ "postgrest/" <> prettyVersion)
                  . setTimeout 3600
                  $ defaultSettings
  when (isMalformedProxyUri $ toS <$> proxy) $ panic
    "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
  putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)
  pool <- P.acquire (configPool conf, 10, pgSettings)
  refDbStructure <- newIORef Nothing
  -- Helper ref to make sure just one connectionWorker can run at a time
  refIsWorkerOn <- newIORef False
  mainTid <- myThreadId
  connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn
 #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
  -- ask for the OS time at most once per second
  getTime <- mkAutoUpdate
    defaultUpdateSettings { updateAction = getPOSIXTime }
  runSettings appSettings $ postgrest conf refDbStructure pool getTime
    (connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn)
 loadSecretFile :: AppConfig -> IO AppConfig
 loadSecretFile conf = extractAndTransform mSecret
  where
    mSecret   = decodeUtf8 <$> configJwtSecret conf
    isB64     = configJwtSecretIsBase64 conf
    extractAndTransform :: Maybe Text -> IO AppConfig
    extractAndTransform Nothing  = return conf
    extractAndTransform (Just s) =
      fmap setSecret $ transformString isB64 =<<
        case stripPrefix "@" s of
            Nothing       -> return s
            Just filename -> readFile (toS filename)
    transformString :: Bool -> Text -> IO ByteString
    transformString False t = return . encodeUtf8 $ t
    transformString True  t =
      case decode (encodeUtf8 $ replaceUrlChars t) of
        Left errMsg -> panic $ pack errMsg
        Right bs    -> return bs
    setSecret bs = conf { configJwtSecret = Just bs }
    replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
@@ -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.5.2
+version:               0.4.2.0
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
@@ -12,91 +12,151 @@ maintainer:            cred+github@begriffs.com
 category:              Web
 build-type:            Simple
 cabal-version:         >=1.10
 source-repository head
  type: git
  location: git://github.com/begriffs/postgrest.git
 Flag CI
  Description: No warnings allowed in continuous integration
  Manual:      True
  Default:     False
 executable postgrest
  main-is:             Main.hs
-  ghc-options:         -Wall -W -O2
+  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
  ghc-options:
    -threaded
    -rtsopts
    "-with-rtsopts=-N -I2"
  default-language:    Haskell2010
-  default-extensions:  OverloadedStrings, ScopedTypeVariables
+  build-depends:       auto-update
-  other-extensions:    QuasiQuotes
+                     , base
-  build-depends:       base >=4.6 && <5
+                     , hasql
-                     , hasql == 0.7.*, hasql-backend
+                     , hasql-pool
-                     , hasql-postgres == 0.10.*
+                     , postgrest
-                     , warp >= 3.0.2, wai >= 3.0.1
+                     , protolude
-                     , wai-extra, wai-cors
+                     , text
-                     , wai-middleware-static >= 0.6.0
+                     , time
-                     , HTTP, convertible, http-types
+                     , warp
                     , bytestring
                     , base64-bytestring
                     , retry
  if !os(windows)
    build-depends:     unix
  hs-source-dirs:      main
 library
  default-language:    Haskell2010
  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
  build-depends:       aeson
                     , ansi-wl-pprint
                     , base >= 4.8 && < 6
                     , bytestring
                     , case-insensitive
-                     , scientific, time
+                     , cassava
-                     , aeson, network >= 2.6
+                     , configurator-ng == 0.0.0.1
-                     , bytestring, text, split, string-conversions
+                     , containers
-                     , stringsearch
+                     , contravariant
-                     , containers, unordered-containers
+                     , either
-                     , optparse-applicative >= 0.9.1 && < 0.10
+                     , hasql
-                     , regex-base, regex-tdfa
+                     , hasql-pool == 0.4.1
-                     , regex-tdfa-text
+                     , hasql-transaction == 0.5
-                     , Ranged-sets
+                     , heredoc
-                     , transformers, MissingH
+                     , HTTP
-                     , bcrypt, base64-string
+                     , http-types
-                     , network-uri >= 2.6
+                     , insert-ordered-containers
-                     , resource-pool
+                     , interpolatedstring-perl6
-                     , blaze-builder
+                     , jwt
                     , lens
                     , lens-aeson
                     , network-uri
                     , optparse-applicative >= 0.13 && < 0.14
                     , parsec
                     , protolude
                     , Ranged-sets == 0.3.0
                     , regex-tdfa
                     , safe
                     , scientific
                     , swagger2
                     , text
                     , time
                     , unordered-containers
                     , vector
-                     , mtl
+                     , wai
-  Other-Modules:       App
+                     , wai-cors
-                     , Auth
+                     , wai-extra
-                     , Config
+                     , wai-middleware-static
-                     , Error
+                     , cookie
-                     , Middleware
+
-                     , PgQuery
+  Other-Modules:       Paths_postgrest
-                     , PgStructure
+  Exposed-Modules:     PostgREST.ApiRequest
-                     , RangeQuery
+                     , PostgREST.App
-                     , Types
+                     , PostgREST.Auth
                     , PostgREST.Config
                     , PostgREST.DbStructure
                     , PostgREST.DbRequestBuilder
                     , PostgREST.Error
                     , PostgREST.Middleware
                     , PostgREST.OpenAPI
                     , PostgREST.Parsers
                     , PostgREST.QueryBuilder
                     , PostgREST.RangeQuery
                     , PostgREST.Types
  hs-source-dirs:      src
 Test-Suite spec
  Type:                exitcode-stdio-1.0
  Default-Language:    Haskell2010
-  default-extensions:  OverloadedStrings, ScopedTypeVariables
+  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude
-  other-extensions:    QuasiQuotes
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
-  Hs-Source-Dirs:      test, src
+  Hs-Source-Dirs:      test
  ghc-options:         -Wall -W -Werror
  Main-Is:             Main.hs
-  Other-Modules:       App
+  Other-Modules:       Feature.AuthSpec
-                     , Auth
+                     , Feature.BinaryJwtSecretSpec
-                     , Config
+                     , Feature.ConcurrentSpec
-                     , Error
+                     , Feature.CorsSpec
-                     , Middleware
+                     , Feature.DeleteSpec
-                     , PgQuery
+                     , Feature.InsertSpec
-                     , PgStructure
+                     , Feature.NoJwtSpec
-                     , RangeQuery
+                     , Feature.ProxySpec
-                     , Types
+                     , Feature.QueryLimitedSpec
-                     , Spec
+                     , Feature.QuerySpec
                     , Feature.RangeSpec
                     , Feature.SingularSpec
                     , Feature.StructureSpec
                     , Feature.UnicodeSpec
                     , Feature.AndOrParamsSpec
                     , SpecHelper
-  Build-Depends:       base, hspec >= 2.1.2, QuickCheck
+                     , TestTypes
-                     , hspec-wai >= 0.5.0, hspec-wai-json
+  Build-Depends:       aeson
-                     , hasql == 0.7.*, hasql-backend
+                     , aeson-qq
-                     , hasql-postgres == 0.10.*
+                     , async
-                     , warp >= 3.0.2, wai >= 3.0.1
+                     , auto-update
-                     , HTTP, convertible
+                     , base
                     , bytestring
                     , base64-bytestring
                     , case-insensitive
-                     , wai-extra, wai-cors, containers
+                     , cassava
-                     , wai-middleware-static >= 0.6.0
+                     , containers
-                     , http-types, scientific, time
+                     , contravariant
-                     , bytestring, aeson, network >= 2.6
+                     , hasql
-                     , text, optparse-applicative
+                     , hasql-pool
-                     , stringsearch
+                     , heredoc
-                     , unordered-containers
+                     , hjsonpointer
-                     , regex-base
+                     , hjsonschema
-                     , string-conversions
+                     , hspec
-                     , http-media, regex-tdfa
+                     , hspec-wai >= 0.7.0
-                     , regex-tdfa-text
+                     , hspec-wai-json
-                     , Ranged-sets
+                     , http-types
-                     , transformers, MissingH, split
+                     , lens
-                     , bcrypt, base64-string
+                     , lens-aeson
-                     , network-uri >= 2.6
+                     , monad-control
-                     , resource-pool
+                     , postgrest
                     , blaze-builder
                     , vector
                     , mtl
                     , process
                     , protolude
                     , regex-tdfa
                     , time
                     , transformers-base
                     , wai
                     , wai-extra
@@ -1,6 +1,6 @@
 export POSTGREST_VER=`grep ^version /app/postgrest.cabal | sed -En 's/.*\s+([0-9\.]+)/\1/p'`
-curl -L http://softlayer-ams.dl.sourceforge.net/project/s3tools/s3cmd/1.5.0-alpha1/s3cmd-1.5.0-alpha1.tar.gz | tar zx
+curl -L http://sourceforge.net/projects/s3tools/files/s3cmd/1.5.0-alpha1/s3cmd-1.5.0-alpha1.tar.gz | tar zx
 cp /app/dist/build/postgrest/postgrest postgrest-${POSTGREST_VER}
 tar cJf postgrest-${POSTGREST_VER}.tar.xz postgrest-${POSTGREST_VER}
@@ -1,238 +0,0 @@
 {-# LANGUAGE FlexibleContexts #-}
 module App (app, sqlError, isSqlError) where
 import Control.Monad (join)
 import Control.Arrow ((***))
 import Control.Applicative
 import Data.Text hiding (map)
 import Data.Maybe (fromMaybe)
 import Text.Regex.TDFA ((=~))
 import Data.Ord (comparing)
 import Data.Ranged.Ranges (emptyRange)
 import Data.HashMap.Strict (keys, elems, filterWithKey, toList)
 import Data.String.Conversions (cs)
 import Data.List (sortBy)
 import Data.Functor.Identity
 import qualified Data.Set as S
 import qualified Data.ByteString.Lazy as BL
 import Network.HTTP.Types.Status
 import Network.HTTP.Types.Header
 import Network.HTTP.Types.URI (parseSimpleQuery)
 import Network.HTTP.Base (urlEncodeVars)
 import Network.Wai
 import 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 Auth
 import PgQuery
 import RangeQuery
 import PgStructure
 app :: BL.ByteString -> Request -> H.Tx P.Postgres s Response
 app reqBody req =
  case (path, verb) of
    ([], _) -> do
      body <- encode <$> tables (cs schema)
      return $ responseLBS status200 [jsonH] $ cs body
    ([table], "OPTIONS") -> do
      let t = QualifiedTable schema (cs table)
      cols <- columns t
      pkey <- map cs <$> primaryKeyColumns t
      return $ responseLBS status200 [jsonH, allOrigins]
        $ encode (TableOptions cols pkey)
    ([table], "GET") ->
      if range == Just emptyRange
      then return $ responseLBS status416 [] "HTTP Range error"
      else do
        let qt = QualifiedTable schema (cs table)
        let select = B.Stmt "select " V.empty True <>
                  parentheticT (
                    whereT qq $ countRows qt
                  ) <> commaq <> (
                  asJsonWithCount
                  . limitT range
                  . orderT (orderParse qq)
                  . whereT qq
                  $ selectStar qt
                )
        row <- H.maybeEx select
        let (tableTotal, queryTotal, body) =
              fromMaybe (0, 0, Just "" :: Maybe Text) row
            from = fromMaybe 0 $ rangeOffset <$> range
            to = from+queryTotal-1
            contentRange = contentRangeH from to tableTotal
            status = rangeStatus from to tableTotal
            canonical = urlEncodeVars
                          . sortBy (comparing fst)
                          . map (join (***) cs)
                          . parseSimpleQuery
                          $ rawQueryString req
        return $ responseLBS status
          [jsonH, contentRange,
            ("Content-Location",
             "/" <> cs table <>
                if Prelude.null canonical then "" else "?" <> cs canonical
            )
          ] (cs $ fromMaybe "[]" body)
    (["postgrest", "users"], "POST") -> do
      let user = decode reqBody :: Maybe AuthUser
      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))
            ] ""
    ([table], "POST") ->
      handleJsonObj reqBody $ \obj -> do
        let qt = QualifiedTable schema (cs table)
            query = insertInto qt (map cs $ keys obj) (elems obj)
        row <- H.maybeEx query
        let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row
            Just inserted = decode (cs insertedJson) :: Maybe Object
        primaryKeys <- map cs <$> primaryKeyColumns qt
        let primaries = if Prelude.null primaryKeys
            then inserted
            else filterWithKey (const . (`elem` primaryKeys)) inserted
        let params = urlEncodeVars
              $ map (\t -> (cs $ fst t, "eq." <> cs (unquoted $ snd t)))
              $ sortBy (comparing fst) $ toList primaries
        return $ responseLBS status201
          [ jsonH
          , (hLocation, "/" <> cs table <> "?" <> cs params)
          ] ""
    ([table], "PUT") ->
      handleJsonObj reqBody $ \obj -> do
        let qt = QualifiedTable schema (cs table)
        primaryKeys <- primaryKeyColumns qt
        let specifiedKeys = map (cs . fst) qq
        if S.fromList primaryKeys /= S.fromList specifiedKeys
          then return $ responseLBS status405 []
               "You must speficy all and only primary keys as params"
          else do
            tableCols <- map (cs . colName) <$> columns qt
            let cols = map cs $ keys obj
            if S.fromList tableCols == S.fromList cols
              then do
                let vals = elems obj
                H.unitEx $ iffNotT
                        (whereT qq $ update qt cols vals)
                        (insertSelect qt cols vals)
                return $ responseLBS status204 [ jsonH ] ""
              else return $ if Prelude.null tableCols
                then responseLBS status404 [] ""
                else responseLBS status400 []
                   "You must specify all columns in PUT request"
    ([table], "PATCH") ->
      handleJsonObj reqBody $ \obj -> do
        let qt = QualifiedTable schema (cs table)
        H.unitEx
          $ whereT qq
          $ update qt (map cs $ keys obj) (elems obj)
        return $ responseLBS status204 [ jsonH ] ""
    ([table], "DELETE") -> do
      let qt = QualifiedTable schema (cs table)
      let del = countT
            . returningStarT
            . whereT qq
            $ deleteFrom qt
      row <- H.maybeEx del
      let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row
      return $ if deletedCount == 0
         then responseLBS status404 [] ""
         else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] ""
    (_, _) ->
      return $ responseLBS status404 [] ""
  where
    path   = pathInfo req
    verb   = requestMethod req
    qq     = queryString req
    hdrs   = requestHeaders req
    schema = requestedSchema hdrs
    range  = rangeRequested hdrs
    allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
 sqlError :: t
 sqlError = undefined
 isSqlError :: t
 isSqlError = undefined
 rangeStatus :: Int -> Int -> Int -> Status
 rangeStatus from to total
  | from > total            = status416
  | (1 + to - from) < total = status206
  | otherwise               = status200
 contentRangeH :: Int -> Int -> Int -> Header
 contentRangeH from to total =
  ("Content-Range",
    if total == 0 || from > total
    then "*/" <> cs (show total)
    else cs (show from)  <> "-"
       <> cs (show to)    <> "/"
       <> cs (show total)
  )
 requestedSchema :: RequestHeaders -> Text
 requestedSchema hdrs =
  case verStr of
       Just [[_, ver]] -> ver
       _ -> "1"
  where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
        accept = cs <$> lookup hAccept hdrs :: Maybe Text
        verStr = (=~ verRegex) <$> accept :: Maybe [[Text]]
 jsonH :: Header
 jsonH = (hContentType, "application/json")
 handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
              -> H.Tx P.Postgres s Response
 handleJsonObj reqBody handler = do
  let p = eitherDecode reqBody
  case p of
    Left err ->
      return $ responseLBS status400 [jsonH] jErr
      where
        jErr = encode . object $
          [("message", String $ "Failed to parse JSON payload. " <> cs err)]
    Right (Object o) -> handler o
    Right _ ->
      return $ responseLBS status400 [jsonH] jErr
      where
        jErr = encode . object $
          [("message", String "Expecting a JSON object")]
 data TableOptions = TableOptions {
  tblOptcolumns :: [Column]
 , tblOptpkey :: [Text]
 }
 instance ToJSON TableOptions where
  toJSON t = object [
      "columns" .= tblOptcolumns t
    , "pkey"   .= tblOptpkey t ]
@@ -1,71 +0,0 @@
 {-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}
 module Auth where
 import Data.Aeson
 import Control.Monad (mzero)
 import Control.Applicative ( (<*>), (<$>) )
 import Crypto.BCrypt
 import Data.Text
 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 Data.String.Conversions (cs)
 import PgQuery (pgFmtLit)
 import System.IO.Unsafe
 data AuthUser = AuthUser {
    userId :: String
  , userPass :: String
  , userRole :: String
  } deriving (Show)
 instance FromJSON AuthUser where
  parseJSON (Object v) = AuthUser <$>
                         v .: "id" <*>
                         v .: "pass" <*>
                         v .: "role"
  parseJSON _ = mzero
 instance ToJSON AuthUser where
  toJSON u = object [
      "id" .= userId u
    , "pass" .= userPass u
    , "role" .= userRole u ]
 type DbRole = Text
 data LoginAttempt =
    NoCredentials
  | MalformedAuth
  | LoginFailed
  | LoginSuccess DbRole
  deriving (Eq, Show)
 checkPass :: Text -> Text -> Bool
 checkPass = (. cs) . validatePassword . cs
 setRole :: Text -> H.Tx P.Postgres s ()
 setRole role = H.unitEx $ B.Stmt ("set role " <> cs (pgFmtLit role)) V.empty True
 resetRole :: H.Tx P.Postgres s ()
 resetRole = H.unitEx [H.stmt|reset role|]
 addUser :: Text -> Text -> Text -> H.Tx P.Postgres s ()
 addUser identity pass role = do
  let Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
  H.unitEx $
    [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
      identity (cs hashed :: Text) role
 signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt
 signInRole user pass = do
  u <- H.maybeEx $ [H.stmt|select pass, rolname from postgrest.auth where id = ?|] user
  return $ maybe LoginFailed (\r ->
      let (hashed, role) = r in
      if checkPass hashed pass
         then LoginSuccess role
         else LoginFailed
    ) u
@@ -1,54 +0,0 @@
 module Config where
 import Network.Wai
 import Control.Applicative
 import Data.Text (strip)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.ByteString.Char8 as BS
 import Data.String.Conversions (cs)
 import Options.Applicative hiding (columns)
 import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
 data AppConfig = AppConfig {
    configDbName :: String
  , configDbPort :: Int
  , configDbUser :: String
  , configDbPass :: String
  , configDbHost :: String
  , configPort  :: Int
  , configAnonRole :: String
  , configSecure :: Bool
  , configPool :: Int
  }
 argParser :: Parser AppConfig
 argParser = AppConfig
  <$> strOption (long "db-name" <> short 'd'                     <> help "name of database")
  <*> option    (long "db-port" <> short 'P' <> value 5432        <> help "postgres server port")
  <*> strOption (long "db-user" <> short 'U'                     <> help "postgres authenticator role")
  <*> strOption (long "db-pass"             <> value ""          <> help "password for authenticator role")
  <*> strOption (long "db-host" <> short 'h' <> value "localhost" <> help "postgres server hostname")
  <*> option    (long "port" <> short 'p' <> value 3000 <> help "port number on which to run HTTP server")
  <*> strOption (long "anonymous" <> short 'a' <> help "postgres role to use for non-authenticated requests")
  <*> switch    (long "secure" <> short 's' <> help "Redirect all requests to HTTPS")
  <*> option    (long "db-pool" <> value 10 <> help "Max connections in database pool")
 defaultCorsPolicy :: CorsResourcePolicy
 defaultCorsPolicy =  CorsResourcePolicy Nothing
  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
  (Just $ 60*60*24) False False True
 corsPolicy :: Request -> Maybe CorsResourcePolicy
 corsPolicy req = case lookup "origin" headers of
  Just origin -> Just defaultCorsPolicy {
      corsOrigins = Just ([origin], True)
    , corsRequestHeaders = "Authentication":accHeaders
    }
  Nothing -> Nothing
  where
    headers = requestHeaders req
    accHeaders = case lookup "access-control-request-headers" headers of
      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs
      Nothing -> []
@@ -1,71 +0,0 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
 module Error (PgError, errResponse) where
 import qualified Hasql as H
 import qualified Hasql.Postgres as P
 import qualified Network.HTTP.Types.Status as HT
 import qualified Data.Aeson as JSON
 import qualified Data.Text as T
 import Data.Aeson ((.=))
 import Data.String.Conversions (cs)
 import Data.String.Utils(replace)
 import Network.Wai(Response, responseLBS)
 import Network.HTTP.Types.Header
 type PgError = H.SessionError P.Postgres
 errResponse :: PgError -> Response
 errResponse e = responseLBS (httpStatus e)
  [(hContentType, "application/json")] (JSON.encode e)
 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]
 httpStatus :: PgError -> HT.Status
 httpStatus (H.TxError (P.ErroneousResult codeBS _ _ _)) =
  let code = cs codeBS in
  case code 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
    '2':'5':_ -> HT.status500 -- invalid tx state
    '2':'8':_ -> HT.status403 -- invalid auth specification
    '2':'D':_ -> HT.status500 -- invalid tx termination
    '3':'8':_ -> HT.status500 -- external routine exception
    '3':'9':_ -> HT.status500 -- external routine invocation
    '3':'B':_ -> HT.status500 -- savepoint exception
    '4':'0':_ -> HT.status500 -- tx rollback
    '5':'3':_ -> HT.status503 -- insufficient resources
    '5':'4':_ -> HT.status413 -- too complex
    '5':'5':_ -> HT.status500 -- obj not on prereq state
    '5':'7':_ -> HT.status500 -- operator intervention
    '5':'8':_ -> HT.status500 -- system error
    'F':'0':_ -> HT.status500 -- conf file error
    'H':'V':_ -> HT.status500 -- foreign data wrapper error
    '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
@@ -1,63 +0,0 @@
 module Main where
 import Paths_postgrest (version)
 import App
 import Middleware
 import Error(errResponse)
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
 import Data.String.Conversions (cs)
 import Network.Wai (strictRequestBody)
 import Network.Wai.Middleware.Cors (cors)
 import Network.Wai.Handler.Warp hiding (Connection)
 import Network.Wai.Middleware.Gzip (gzip, def)
 import Network.Wai.Middleware.Static (staticPolicy, only)
 import Data.List (intercalate)
 import Data.Version (versionBranch)
 import qualified Hasql as H
 import qualified Hasql.Postgres as P
 import Options.Applicative hiding (columns)
 import Config (AppConfig(..), argParser, corsPolicy)
 main :: IO ()
 main = do
  conf <- execParser (info (helper <*> argParser) describe)
  let port = configPort conf
  unless (configSecure conf) $
    putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
  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 =
        (if configSecure conf then redirectInsecure else id)
        . gzip def . cors corsPolicy
        . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
      anonRole = cs $ configAnonRole conf
      currRole = cs $ configDbUser conf
  poolSettings <- maybe (fail "Improper session settings") return $
                H.poolSettings (fromIntegral $ configPool conf) 30
  pool :: H.Pool P.Postgres
          <- H.acquirePool pgSettings poolSettings
  runSettings appSettings $ middle $ \req respond -> do
    body <- strictRequestBody req
    resOrError <- liftIO $ H.session pool $ H.tx Nothing $
      authenticated currRole anonRole (app body) req
    either (respond . errResponse) respond resOrError
  where
    describe = progDesc "create a REST API to an existing Postgres database"
    prettyVersion = intercalate "." $ map show $ versionBranch version
@@ -1,76 +0,0 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Middleware where
 import Data.Maybe (fromMaybe)
 import Data.Monoid (mconcat)
 import Data.Text
 -- import Data.Pool(withResource, Pool)
 import qualified Hasql as H
 import qualified Hasql.Postgres as P
 import Data.String.Conversions(cs)
 import Network.HTTP.Types.Header (hLocation, hAuthorization)
 import Network.HTTP.Types (RequestHeaders)
 import Network.HTTP.Types.Status (status400, status401, status301)
 import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
                   rawQueryString, isSecure, Request(..), Response)
 import Network.URI (URI(..), parseURI)
 import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 authenticated :: forall s. Text -> Text ->
                 (Request -> H.Tx P.Postgres s Response) ->
                 Request -> H.Tx P.Postgres s Response
 authenticated currentRole anon 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 -> if role /= currentRole then runInRole role else app req
    NoCredentials ->     if anon /= currentRole then runInRole anon else app req
 where
   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
      _ -> return NoCredentials
   runInRole :: Text -> H.Tx P.Postgres s Response
   runInRole r = do
     setRole r
     res <- app req
     resetRole
     return res
 redirectInsecure :: Application -> Application
 redirectInsecure app req respond = do
  let hdrs = requestHeaders req
      host = lookup "host" hdrs
      uriM = parseURI . cs =<< mconcat [
        Just "https://",
        host,
        Just $ rawPathInfo req,
        Just $ rawQueryString req]
      isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"
  if not (isSecure req || isHerokuSecure)
    then case uriM of
              Just uri ->
                respond $ responseLBS status301 [
                    (hLocation, cs . show $ uri { uriScheme = "https:" })
                  ] ""
              Nothing ->
                respond $ responseLBS status400 [] "SSL is required"
    else app req respond
@@ -1,207 +0,0 @@
 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module PgQuery where
 import RangeQuery
 import qualified Hasql as H
 import qualified Hasql.Postgres as P
 import qualified Hasql.Backend as B
 import Data.Text hiding (map, empty)
 import Text.Regex.TDFA ( (=~) )
 import Text.Regex.TDFA.Text ()
 import qualified Network.HTTP.Types.URI as Net
 import qualified Data.ByteString.Char8 as BS
 import Data.Monoid
 import Data.Vector (empty)
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Functor ( (<$>) )
 import Control.Monad (join)
 import Data.String.Conversions (cs)
 import qualified Data.Aeson as JSON
 import qualified Data.List as L
 import Data.Scientific (isInteger, formatScientific, FPFormat(..))
 type PStmt = H.Stmt P.Postgres
 instance Monoid PStmt where
  mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =
    B.Stmt (query <> query') (params <> params') (prep && prep')
  mempty = B.Stmt "" empty True
 type StatementT = PStmt -> PStmt
 data QualifiedTable = QualifiedTable {
  qtSchema :: Text
 , qtName   :: Text
 } deriving (Show)
 data OrderTerm = OrderTerm {
  otTerm :: Text
 , otDirection :: BS.ByteString
 }
 limitT :: Maybe NonnegRange -> StatementT
 limitT r q =
  q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
  where
    limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
    offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
 whereT :: Net.Query -> StatementT
 whereT params q =
 if L.null cols
   then q
   else q <> B.Stmt " where " empty True <> conjunction
 where
   cols = [ col | col <- params, fst col `notElem` ["order"] ]
   conjunction = mconcat $ L.intersperse andq (map wherePred cols)
 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)         <> " ")
                   empty True
 parentheticT :: StatementT
 parentheticT s =
  s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }
 iffNotT :: PStmt -> StatementT
 iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
  B.Stmt
    ("WITH aaa AS (" <> aq <> " returning *) " <>
      bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
    (ap <> bp)
    (apre && bpre)
 countT :: StatementT
 countT s =
  s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT count(1) FROM qqq" }
 countRows :: QualifiedTable -> PStmt
 countRows t = B.Stmt ("select count(1) from " <> fromQt t) empty True
 asJsonWithCount :: StatementT
 asJsonWithCount s = s { B.stmtTemplate =
     "count(t), array_to_json(array_agg(row_to_json(t)))::character varying from ("
  <> B.stmtTemplate s <> ") t" }
 asJsonRow :: StatementT
 asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
 selectStar :: QualifiedTable -> PStmt
 selectStar t = B.Stmt ("select * from " <> fromQt t) empty True
 returningStarT :: StatementT
 returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
 deleteFrom :: QualifiedTable -> PStmt
 deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True
 insertInto :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
 insertInto t [] _ = B.Stmt
  ("insert into " <> fromQt t <> " default values returning *") empty True
 insertInto t cols vals = B.Stmt
  ("insert into " <> fromQt t <> " (" <>
    intercalate ", " (map pgFmtIdent cols) <>
    ") values ("
    <> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
    <> ") returning row_to_json(" <> fromQt t <> ".*)")
  empty True
 insertSelect :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
 insertSelect t [] _ = B.Stmt
  ("insert into " <> fromQt t <> " default values returning *") empty True
 insertSelect t cols vals = B.Stmt
  ("insert into " <> fromQt t <> " ("
    <> intercalate ", " (map pgFmtIdent cols)
    <> ") select "
    <> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals))
  empty True
 update :: QualifiedTable -> [Text] -> [JSON.Value] -> PStmt
 update t cols vals = B.Stmt
  ("update " <> fromQt t <> " set ("
    <> intercalate ", " (map pgFmtIdent cols)
    <> ") = ("
    <> intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
    <> ")")
  empty True
 wherePred :: Net.QueryItem -> PStmt
 wherePred (col, predicate) = B.Stmt
  (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs (pgFmtLit value) <> "::unknown ")
  empty True
  where
    opCode:rest = split (=='.') $ cs $ fromMaybe "." predicate
    value = intercalate "." rest
    op = case opCode of
         "eq"  -> "="
         "gt"  -> ">"
         "lt"  -> "<"
         "gte" -> ">="
         "lte" -> "<="
         "neq" -> "<>"
         _     -> "="
 orderParse :: Net.Query -> [OrderTerm]
 orderParse q =
  mapMaybe orderParseTerm . split (==',') $ cs order
  where
    order = fromMaybe "" $ join (lookup "order" q)
 orderParseTerm :: Text -> Maybe OrderTerm
 orderParseTerm s =
  case split (=='.') s of
       [d,c] ->
         if d `elem` ["asc", "desc"]
            then Just $ OrderTerm c $
              if d == "asc" then "asc" else "desc"
            else Nothing
       _ -> Nothing
 commaq :: PStmt
 commaq  = B.Stmt ", " empty True
 andq :: PStmt
 andq = B.Stmt " and " empty True
 pgFmtIdent :: Text -> Text
 pgFmtIdent x =
  let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in
  if escaped =~ danger
    then "\"" <> escaped <> "\""
    else escaped
  where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: Text
 pgFmtLit :: Text -> Text
 pgFmtLit x =
  let trimmed = trimNullChars x
      escaped = "'" <> replace "'" "''" trimmed <> "'"
      slashed = replace "\\" "\\\\" escaped in
  cs $ if escaped =~ ("\\\\" :: Text)
    then "E" <> slashed
    else slashed
 trimNullChars :: Text -> Text
 trimNullChars = Data.Text.takeWhile (/= '\x0')
 fromQt :: QualifiedTable -> Text
 fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
 unquoted :: JSON.Value -> 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 _ = ""
@@ -1,172 +0,0 @@
 {-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances,
             MultiParamTypeClasses, ScopedTypeVariables #-}
 module PgStructure where
 import PgQuery (QualifiedTable(..))
 import Data.Text hiding (foldl, map, zipWith, concat)
 import Data.Aeson
 import Data.Functor.Identity
 import Data.String.Conversions (cs)
 import Data.Maybe (fromMaybe)
 import Control.Applicative ( (<$>) )
 import qualified Data.Map as Map
 import qualified Hasql as H
 import qualified Hasql.Postgres as P
 foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)
 foreignKeys table = do
  r <- H.listEx $ [H.stmt|
      select kcu.column_name, ccu.table_name AS foreign_table_name,
        ccu.column_name AS foreign_column_name
      from information_schema.table_constraints AS tc
        join information_schema.key_column_usage AS kcu
          on tc.constraint_name = kcu.constraint_name
        join information_schema.constraint_column_usage AS ccu
          on ccu.constraint_name = tc.constraint_name
      where constraint_type = 'FOREIGN KEY'
        and tc.table_name=? and tc.table_schema = ?
        order by kcu.column_name
    |] (qtName table) (qtSchema table)
  return $ foldl addKey Map.empty r
  where
    addKey :: Map.Map Text ForeignKey -> (Text, Text, Text) -> Map.Map Text ForeignKey
    addKey m (col, ftab, fcol) = Map.insert col (ForeignKey ftab fcol) m
 tables :: Text -> H.Tx P.Postgres s [Table]
 tables schema = do
  rows <- H.listEx $
    [H.stmt|
      select table_schema, table_name,
             is_insertable_into
        from information_schema.tables
       where table_schema = ?
       order by table_name
    |] schema
  return $ map tableFromRow rows
 columns :: QualifiedTable -> H.Tx P.Postgres s [Column]
 columns table = do
  cols <- H.listEx $ [H.stmt|
      select info.table_schema as schema, info.table_name as table_name,
             info.column_name as name, info.ordinal_position as position,
             info.is_nullable as nullable, info.data_type as col_type,
             info.is_updatable as updatable,
             info.character_maximum_length as max_len,
             info.numeric_precision as precision,
             info.column_default as default_value,
             array_to_string(enum_info.vals, ',') as enum
         from (
           select table_schema, table_name, column_name, ordinal_position,
                  is_nullable, data_type, is_updatable,
                  character_maximum_length, numeric_precision,
                  column_default, udt_name
             from information_schema.columns
            where table_schema = ? and table_name = ?
         ) as info
         left outer join (
           select n.nspname as s,
                  t.typname as n,
                  array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals
           from pg_type t
              join pg_enum e on t.oid = e.enumtypid
              join pg_catalog.pg_namespace n ON n.oid = t.typnamespace
           group by s, n
         ) as enum_info
         on (info.udt_name = enum_info.n)
      order by position |]
    (qtSchema table) (qtName table)
  fks <- foreignKeys table
  return $ map (addFK fks . columnFromRow) cols
  where
    addFK fks col = col { colFK = Map.lookup (cs . colName $ col) fks }
 primaryKeyColumns :: QualifiedTable -> H.Tx P.Postgres s [Text]
 primaryKeyColumns table = do
  r <- H.listEx $ [H.stmt|
    select kc.column_name
      from
        information_schema.table_constraints tc,
        information_schema.key_column_usage kc
    where
      tc.constraint_type = 'PRIMARY KEY'
      and kc.table_name = tc.table_name and kc.table_schema = tc.table_schema
      and kc.constraint_name = tc.constraint_name
      and kc.table_schema = ?
      and kc.table_name  = ? |] (qtSchema table) (qtName table)
  return $ map runIdentity r
 toBool :: Text -> Bool
 toBool = (== "YES")
 data Table = Table {
  tableSchema :: Text
 , tableName :: Text
 , tableInsertable :: Bool
 } deriving (Show)
 data ForeignKey = ForeignKey {
  fkTable::Text, fkCol::Text
 } deriving (Eq, Show)
 data Column = Column {
  colSchema :: Text
 , colTable :: Text
 , colName :: Text
 , colPosition :: Int
 , colNullable :: Bool
 , colType :: Text
 , colUpdatable :: Bool
 , colMaxLen :: Maybe Int
 , colPrecision :: Maybe Int
 , colDefault :: Maybe Text
 , colEnum :: [Text]
 , colFK :: Maybe ForeignKey
 } deriving (Show)
 tableFromRow :: (Text, Text, Text) -> Table
 tableFromRow (s, n, i) = Table s n (toBool i)
 columnFromRow :: (Text,       Text,      Text,
                  Int,        Text,      Text,
                  Text,       Maybe Int, Maybe Int,
                  Maybe Text, Maybe Text)
              -> Column
 columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
  Column s t n pos (toBool nul) typ (toBool u) l p d (parseEnum e) Nothing
  where
    parseEnum :: Maybe Text -> [Text]
    parseEnum str = fromMaybe [] $ split (==',') <$> str
 instance ToJSON Column where
  toJSON c = object [
      "schema"    .= colSchema c
    , "name"      .= colName c
    , "position"  .= colPosition c
    , "nullable"  .= colNullable c
    , "type"      .= colType c
    , "updatable" .= colUpdatable c
    , "maxLen"    .= colMaxLen c
    , "precision" .= colPrecision c
    , "references".= colFK c
    , "default"   .= colDefault c
    , "enum"      .= colEnum c ]
 instance ToJSON ForeignKey where
  toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
 instance ToJSON Table where
  toJSON v = object [
      "schema"     .= tableSchema v
    , "name"       .= tableName v
    , "insertable" .= tableInsertable v ]
@@ -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
@@ -0,0 +1,357 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 --module PostgREST.App where
 module PostgREST.App (
  postgrest
 ) where
 import           Control.Applicative
 import qualified Data.ByteString.Char8     as BS
 import           Data.Maybe
 import           Data.IORef                (IORef, readIORef)
 import           Data.Text                 (intercalate)
 import           Data.Time.Clock.POSIX     (POSIXTime)
 import qualified Hasql.Pool                 as P
 import qualified Hasql.Transaction          as HT
 import qualified Hasql.Transaction.Sessions as HT
 import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
 import           Network.HTTP.Types.URI    (renderSimpleQuery)
 import           Network.Wai
 import           Network.Wai.Middleware.RequestLogger (logStdout)
 import           Web.JWT                   (binarySecret)
 import qualified Data.Vector               as V
 import qualified Hasql.Transaction         as H
 import qualified Data.HashMap.Strict       as M
 import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
                                        , Action(..), Target(..)
                                        , PreferRepresentation (..)
                                        , mutuallyAgreeable
                                        , userApiRequest
                                        )
 import           PostgREST.Auth            (jwtClaims, containsRole)
 import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.DbStructure
 import           PostgREST.DbRequestBuilder( readRequest
                                           , mutateRequest
                                           , fieldNames
                                           )
 import           PostgREST.Error           ( simpleError, pgError
                                           , apiRequestError
                                           , singularityError, binaryFieldError
                                           , connectionLostError
                                           )
 import           PostgREST.RangeQuery      (allRange, rangeOffset)
 import           PostgREST.Middleware
 import           PostgREST.QueryBuilder ( callProc
                                        , requestToQuery
                                        , requestToCountQuery
                                        , createReadStatement
                                        , createWriteStatement
                                        , ResultsWithCount
                                        )
 import           PostgREST.Types
 import           PostgREST.OpenAPI
 import           Data.Function (id)
 import           Protolude              hiding (intercalate, Proxy)
 import           Safe                   (headMay)
 postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO POSIXTime ->
             IO () -> Application
 postgrest conf refDbStructure pool getTime worker =
  let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in
  middle $ \ req respond -> do
    time <- getTime
    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
            let jwtSecret = binarySecret <$> configJwtSecret conf
                eClaims = jwtClaims jwtSecret (iJWT apiRequest) time
                authed = containsRole eClaims
                handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
                txMode = transactionMode dbStructure
                  (iTarget apiRequest) (iAction apiRequest)
            response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
            return $ either (pgError authed) identity response
        when (isResponse503 response) worker
        respond response
 isResponse503 :: Response -> Bool
 isResponse503 resp = statusCode (responseStatus resp) == 503
 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
 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)
        (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
                        ]
                  return . responseLBS status201 headers $
                    if iPreferRepresentation apiRequest == Full
                      then toS body else ""
        (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON rows)) ->
          case (mutateSqlParts, null <$> rows V.!? 0, iPreferRepresentation apiRequest == Full) of
            (Left errorResponse, _, _) -> return errorResponse
            (_, Just True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"
            (_, Just True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""
            (Right (sq, mq), _, _) -> do
              let stm = createWriteStatement sq mq
                    (contentType == CTSingularJSON) False (contentType == CTTextCSV)
                    (iPreferRepresentation apiRequest) []
              row <- H.query payload stm
              let (_, queryTotal, _, body) = extractQueryResult row
              if contentType == CTSingularJSON
                 && queryTotal /= 1
                 && iPreferRepresentation apiRequest == Full
                then do
                  HT.condemn
                  return $ singularityError (toInteger queryTotal)
                else do
                  let r = contentRangeH 0 (toInteger $ queryTotal-1)
                            (toInteger <$> if shouldCount then Just queryTotal else Nothing)
                      s = if iPreferRepresentation apiRequest == Full
                            then status200
                            else status204
                  return $ if iPreferRepresentation apiRequest == Full
                    then responseLBS s [toHeader contentType, r] (toS body)
                    else responseLBS s [r] ""
        (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] ""
        (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
          let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
          case mTable of
            Nothing -> return notFound
            Just table ->
              let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
              return $ responseLBS status200 [allOrigins, acceptH] ""
        (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->
          case readSqlParts of
            Left errorResponse -> return errorResponse
            Right (q, cq) -> do
              let p = V.head payload
                  singular = contentType == CTSingularJSON
                  paramsAsSingleObject = iPreferSingleObjectParameter apiRequest
              row <- H.query () $
                callProc qi p q cq topLevelRange shouldCount singular
                         paramsAsSingleObject (contentType == CTTextCSV)
              let (tableTotal, queryTotal, body) =
                    fromMaybe (Just 0, 0, "[]") row
                  (status, contentRange) = rangeHeader queryTotal tableTotal
              if singular && queryTotal /= 1
                then do
                  HT.condemn
                  return $ singularityError (toInteger queryTotal)
                else return $ responseLBS status [toHeader contentType, contentRange] (toS body)
        (ActionInspect, TargetRoot, Nothing) -> do
          let host = configHost conf
              port = toInteger $ configPort conf
              proxy = pickProxy $ toS <$> configProxyUri conf
              uri Nothing = ("http", host, port, "/")
              uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
              uri' = uri proxy
              encodeApi ti = encodeOpenAPI (M.elems $ dbProcs dbStructure) ti uri'
          body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
          return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body
        _ -> return notFound
    where
      toTableInfo :: [Table] -> [(Table, [Column], [Text])]
      toTableInfo = map (\t ->
        let tSchema = tableSchema t
            tTable = tableName t
            cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
            pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
        in (t, cols, pkeys))
      notFound = responseLBS status404 [] ""
      filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
      filterCol :: Schema -> TableName -> Column -> Bool
      filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
      allPrKeys = dbPrimaryKeys dbStructure
      allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
      shouldCount = iPreferCount apiRequest
      schema = toS $ configSchema conf
      topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
      rangeHeader queryTotal tableTotal =
        let lower = rangeOffset topLevelRange
            upper = lower + toInteger queryTotal - 1
            contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
            status = rangeStatus lower upper (toInteger <$> tableTotal)
        in (status, contentRange)
      readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) (dbProcs dbStructure) apiRequest
      fldNames = fieldNames <$> readReq
      readDbRequest = DbRead <$> readReq
      mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< fldNames)
      selectQuery = requestToQuery schema False <$> readDbRequest
      mutateQuery = requestToQuery schema False <$> mutateDbRequest
      countQuery = requestToCountQuery schema <$> readDbRequest
      readSqlParts = (,) <$> selectQuery <*> countQuery
      mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
 responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
 responseContentTypeOrError accepts action = serves contentTypesForRequest accepts
  where
    contentTypesForRequest =
      case action of
        ActionRead ->    [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
        ActionCreate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
        ActionUpdate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
        ActionDelete ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
        ActionInspect -> [CTOpenAPI, CTApplicationJSON]
        ActionInfo ->    [CTTextCSV]
    serves sProduces cAccepts =
      case mutuallyAgreeable sProduces cAccepts of
        Nothing -> do
          let failed = intercalate ", " $ map (toS . toMime) cAccepts
          Left $ simpleError status415 $
            "None of these Content-Types are available: " <> failed
        Just ct -> Right ct
 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
 splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
 splitKeyValue kv = (k, BS.tail v)
  where (k, v) = BS.break (== '=') kv
 renderLocationFields :: [BS.ByteString] -> BS.ByteString
 renderLocationFields fields =
  renderSimpleQuery True $ map splitKeyValue fields
 rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
 rangeStatus _ _ Nothing = status200
 rangeStatus lower upper (Just total)
  | lower > total            = status416
  | (1 + upper - lower) < total = status206
  | otherwise               = status200
 contentRangeH :: Integer -> Integer -> Maybe Integer -> Header
 contentRangeH lower upper total =
    ("Content-Range", headerValue)
    where
      headerValue   = rangeString <> "/" <> totalString
      rangeString
        | totalNotZero && fromInRange = show lower <> "-" <> show upper
        | otherwise = "*"
      totalString   = fromMaybe "*" (show <$> total)
      totalNotZero  = fromMaybe True ((/=) 0 <$> total)
      fromInRange   = lower <= upper
 extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
 extractQueryResult = fromMaybe (Nothing, 0, [], "")
@@ -0,0 +1,80 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-|
 Module      : PostgREST.Auth
 Description : PostgREST authorization functions.
 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.
 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
  , tokenJWT
  , JWTAttempt(..)
  ) where
 import           Protolude
 import           Control.Lens
 import           Data.Aeson              (Value (..), parseJSON, toJSON)
 import           Data.Aeson.Lens
 import           Data.Aeson.Types        (parseMaybe, emptyObject, emptyArray)
 import qualified Data.Vector             as V
 import qualified Data.HashMap.Strict     as M
 import           Data.Maybe              (fromJust)
 import           Data.Time.Clock         (NominalDiffTime)
 import qualified Web.JWT                 as JWT
 {-|
  Possible situations encountered with client JWTs
 -}
 data JWTAttempt = JWTExpired
                | JWTInvalid
                | JWTMissingSecret
                | JWTClaims (M.HashMap Text Value)
                deriving Eq
 {-|
  Receives the JWT secret (from config) and a JWT and returns a map
  of JWT claims.
 -}
 jwtClaims :: Maybe JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt
 jwtClaims _ "" _ = JWTClaims M.empty
 jwtClaims secret jwt time =
  case secret of
    Nothing -> JWTMissingSecret
    Just s ->
      let mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature s jwt in
      case isExpired <$> mClaims of
        Just True -> JWTExpired
        Nothing -> JWTInvalid
        Just False -> JWTClaims $ value2map $ fromJust mClaims
 where
  isExpired claims =
    let mExp = claims ^? key "exp" . _Integer
    in fromMaybe False $ (<= time) . fromInteger <$> mExp
  value2map (Object o) = o
  value2map _          = M.empty
 {-|
  Receives the JWT secret (from config) and a JWT and a JSON value
  and returns a signed JWT.
 -}
 tokenJWT :: JWT.Secret -> Value -> Text
 tokenJWT secret (Array arr) =
  let obj = if V.null arr then emptyObject else V.head arr
      jcs = parseMaybe parseJSON obj :: Maybe JWT.JWTClaimsSet in
  JWT.encodeSigned JWT.HS256 secret $ fromMaybe JWT.def jcs
 tokenJWT secret _ = tokenJWT secret emptyArray
 {-|
  Whether a response from jwtClaims contains a role claim
 -}
 containsRole :: JWTAttempt -> Bool
 containsRole (JWTClaims claims) = M.member "role" claims
 containsRole _ = False
@@ -0,0 +1,191 @@
 {-# 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.
 It currently includes a hardcoded CORS policy but this could easly be
 turned in configurable behaviour if needed.
 Other hardcoded options such as the minimum version number also belong here.
 -}
 module PostgREST.Config ( prettyVersion
                        , readOptions
                        , corsPolicy
                        , minimumPgVersion
                        , PgVersion (..)
                        , AppConfig (..)
                        )
       where
 import           System.IO.Error             (IOError)
 import           Control.Applicative
 import qualified Data.ByteString             as B
 import qualified Data.ByteString.Char8       as BS
 import qualified Data.CaseInsensitive        as CI
 import qualified Data.Configurator           as C
 import qualified Data.Configurator.Parser    as C
 import           Data.Configurator.Types     (Value(..))
 import           Data.List                   (lookup)
 import           Data.Monoid
 import           Data.Scientific             (floatingOrInteger)
 import           Data.Text                   (strip, intercalate, lines)
 import           Data.Text.Encoding          (encodeUtf8)
 import           Data.Text.IO                (hPutStrLn)
 import           Data.Version                (versionBranch)
 import           Network.Wai
 import           Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
 import           Options.Applicative hiding  (str)
 import           Paths_postgrest             (version)
 import           System.IO                   (hPrint)
 import           Text.Heredoc
 import           Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>))
 import qualified Text.PrettyPrint.ANSI.Leijen as L
 import           Protolude hiding            (intercalate, (<>))
 -- | Config file settings for the server
 data AppConfig = AppConfig {
    configDatabase          :: Text
  , configAnonRole          :: Text
  , configProxyUri          :: Maybe Text
  , configSchema            :: Text
  , configHost              :: Text
  , configPort              :: Int
  , configJwtSecret         :: Maybe B.ByteString
  , configJwtSecretIsBase64 :: Bool
  , configPool              :: Int
  , configMaxRows           :: Maybe Integer
  , configReqCheck          :: Maybe Text
  , configQuiet             :: Bool
  }
 defaultCorsPolicy :: CorsResourcePolicy
 defaultCorsPolicy =  CorsResourcePolicy Nothing
  ["GET", "POST", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
  (Just $ 60*60*24) False False True
 -- | CORS policy to be used in by Wai Cors middleware
 corsPolicy :: Request -> Maybe CorsResourcePolicy
 corsPolicy req = case lookup "origin" headers of
  Just origin -> Just defaultCorsPolicy {
      corsOrigins = Just ([origin], True)
    , corsRequestHeaders = "Authentication":accHeaders
    , corsExposedHeaders = Just [
        "Content-Encoding", "Content-Location", "Content-Range", "Content-Type"
      , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit"
      ]
    }
  Nothing -> Nothing
  where
    headers = requestHeaders req
    accHeaders = case lookup "access-control-request-headers" headers of
      Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs
      Nothing -> []
 -- | User friendly version number
 prettyVersion :: Text
 prettyVersion = intercalate "." $ map show $ versionBranch version
 -- | Function to read and parse options from the command line
 readOptions :: IO AppConfig
 readOptions = do
  -- First read the config file path from command line
  cfgPath <- customExecParser parserPrefs opts
  -- Now read the actual config file
  conf <- catch
    (C.readConfig =<< C.load [C.Required cfgPath])
    configNotfoundHint
  let (mAppConf, errs) = flip C.runParserA conf $
        AppConfig <$>
            C.key "db-uri"
          <*> C.key "db-anon-role"
          <*> C.key "server-proxy-uri"
          <*> C.key "db-schema"
          <*> (fromMaybe "*4" <$> C.key "server-host")
          <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port")
          <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret")
          <*> (fromMaybe False <$> C.key "secret-is-base64")
          <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool")
          <*> (join . fmap coerceInt <$> C.key "max-rows")
          <*> C.key "pre-request"
          <*> pure False
  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
  opts = info (helper <*> pathParser) $
           fullDesc
           <> progDesc (
               "PostgREST "
               <> toS prettyVersion
               <> " / create a REST API to an existing Postgres database"
             )
           <> footerDoc (Just $
               text "Example Config File:"
               L.<> nest 2 (hardline L.<> exampleCfg)
             )
  parserPrefs = prefs showHelpOnError
  configNotfoundHint :: IOError -> IO a
  configNotfoundHint e = do
    hPutStrLn stderr $
      "Cannot open config file:\n\t" <> show e
    exitFailure
  exampleCfg :: Doc
  exampleCfg = vsep . map (text . toS) . lines $
    [str|db-uri = "postgres://user:pass@localhost:5432/dbname"
        |db-schema = "public"
        |db-anon-role = "postgres"
        |db-pool = 10
        |
        |server-host = "*4"
        |server-port = 3000
        |
        |## base url for swagger output
        |# server-proxy-uri = ""
        |
        |## choose a secret to enable JWT auth
        |## (use "@filename" to load from separate file)
        |# jwt-secret = "foo"
        |# secret-is-base64 = false
        |
        |## limit rows in response
        |# max-rows = 1000
        |
        |## stored proc to exec immediately after auth
        |# pre-request = "stored_proc_name"
        |]
 pathParser :: Parser FilePath
 pathParser =
  strArgument $
    metavar "FILENAME" <>
    help "Path to configuration file"
 data PgVersion = PgVersion {
  pgvNum  :: Int32
 , pgvName :: Text
 }
 -- | Tells the minimum PostgreSQL version required by this version of PostgREST
 minimumPgVersion :: PgVersion
 minimumPgVersion = PgVersion 90300 "9.3"
@@ -0,0 +1,286 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE DuplicateRecordFields    #-}
 module PostgREST.DbRequestBuilder (
  readRequest
 , mutateRequest
 , fieldNames
 ) where
 import           Control.Applicative
 import           Control.Arrow             ((***))
 import           Control.Lens.Getter       (view)
 import           Control.Lens.Tuple        (_1)
 import qualified Data.ByteString.Char8     as BS
 import           Data.List                 (delete)
 import           Data.Maybe                (fromJust)
 import           Data.Text                 (isInfixOf)
 import           Data.Tree
 import           Data.Either.Combinators   (mapLeft)
 import           Network.Wai
 import           Data.Foldable (foldr1)
 import qualified Data.HashMap.Strict       as M
 import           PostgREST.ApiRequest   ( ApiRequest(..)
                                        , PreferRepresentation(..)
                                        , Action(..), Target(..)
                                        , PreferRepresentation (..)
                                        )
 import           PostgREST.Error           (apiRequestError)
 import           PostgREST.Parsers
 import           PostgREST.RangeQuery      (NonnegRange, restrictRange)
 import           PostgREST.QueryBuilder (getJoinConditions, sourceCTEName)
 import           PostgREST.Types
 import           Protolude                hiding (from, dropWhile, drop)
 import           Text.Regex.TDFA         ((=~))
 import           Unsafe                  (unsafeHead)
 readRequest :: Maybe Integer -> [Relation] -> M.HashMap Text ProcDescription -> ApiRequest -> Either Response ReadRequest
 readRequest maxRows allRels allProcs apiRequest  =
  mapLeft apiRequestError $
  treeRestrictRange maxRows =<<
  augumentRequestWithJoin schema relations =<<
  parseReadRequest
  where
    (schema, rootTableName) = fromJust $ -- Make it safe
      let target = iTarget apiRequest in
      case target of
        (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
        (TargetProc  (QualifiedIdentifier s proc) ) -> Just (s, tName)
          where
            retType = pdReturnType <$> M.lookup proc allProcs
            tName = case retType of
              Just (SetOf (Composite qi)) -> qiName qi
              Just (Single (Composite qi)) -> qiName qi
              _ -> proc
        _ -> Nothing
    action :: Action
    action = iAction apiRequest
    parseReadRequest :: Either ApiRequestError ReadRequest
    parseReadRequest = addFiltersOrdersRanges apiRequest <*>
      pRequestSelect rootName selStr
      where
        selStr = iSelect apiRequest
        rootName = if action == ActionRead
          then rootTableName
          else sourceCTEName
    relations :: [Relation]
    relations = case action of
      ActionCreate -> fakeSourceRelations ++ allRels
      ActionUpdate -> fakeSourceRelations ++ allRels
      ActionDelete -> fakeSourceRelations ++ allRels
      ActionInvoke -> fakeSourceRelations ++ allRels
      _       -> allRels
      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
 treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
 treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
  where
    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
 augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either ApiRequestError ReadRequest
 augumentRequestWithJoin schema allRels request =
  addRelations schema allRels Nothing request
  >>= addJoinConditions schema
 addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
 addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) =
  case parentNode of
    (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) ->
      Node <$> readNode' <*> forest'
      where
        forest' = updateForest $ hush node'
        node' = Node <$> readNode' <*> pure forest
        readNode' = addRel readNode <$> rel
        rel :: Either ApiRequestError Relation
        rel = note (NoRelationBetween parentNodeTable name)
            $ findRelation schema name parentNodeTable
            where
              findRelation s nodeTableName parentNodeTableName =
                find (\r ->
                  s == tableSchema (relTable r) && -- match schema for relation table
                  s == tableSchema (relFTable r) && -- match schema for relation foriegn table
                  (
                    -- (request)        => projects { ..., clients{...} }
                    -- will match
                    -- (relation type)  => parent
                    -- (entity)         => clients  {id}
                    -- (foriegn entity) => projects {client_id}
                    (
                      nodeTableName == tableName (relTable r) && -- match relation table name
                      parentNodeTableName == tableName (relFTable r) -- match relation foreign table name
                    ) ||
                    -- (request)        => projects { ..., client_id{...} }
                    -- will match
                    -- (relation type)  => parent
                    -- (entity)         => clients  {id}
                    -- (foriegn entity) => projects {client_id}
                    (
                      parentNodeTableName == tableName (relFTable r) &&
                      length (relFColumns r) == 1 &&
                      nodeTableName `colMatches` (colName . unsafeHead . relFColumns) r
                    )
                    -- (request)        => project_id { ..., client_id{...} }
                    -- will match
                    -- (relation type)  => parent
                    -- (entity)         => clients  {id}
                    -- (foriegn entity) => projects {client_id}
                    -- this case works becasue before reaching this place
                    -- addRelation will turn project_id to project so the above condition will match
                  )
                ) allRelations
                where n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString)
        addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
        addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a))
          where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query')
    _ -> n' <$> updateForest (Just (n' forest))
      where
        n' = Node (query, (name, Just r, alias))
        t = Table schema name True -- !!! TODO find another way to get the table from the query
        r = Relation t [] t [] Root Nothing Nothing Nothing
  where
    updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
    updateForest n = mapM (addRelations schema allRelations n) forest
 addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest
 addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
  case r of
    Just Relation{relType=Root} -> Node nn  <$> updatedForest -- this is the root node
    Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest
    Just Relation{relType=Parent} -> Node nn <$> updatedForest
    Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->
      Node (qq, (n, r, a)) <$> updatedForest
      where
         query' = addCond query (getJoinConditions rel)
         qq = query'{from=tableName linkTable : from query'}
    _ -> Left UnknownRelation
  where
    updatedForest = mapM (addJoinConditions schema) forest
    addCond query' con = query'{flt_=con ++ flt_ query'}
 addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest)
 addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
    flip (foldr addFilter) <$> filters,
    flip (foldr addOrder) <$> orders,
    flip (foldr addRange) <$> ranges,
    flip (foldr addLogicTree) <$> logicForest
  ]
  {-
  The esence of what is going on above is that we are composing tree functions
  of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context
  -}
  where
    filters :: Either ApiRequestError [(EmbedPath, Filter)]
    filters = mapM pRequestFilter flts
    logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)]
    logicForest = mapM pRequestLogicTree logFrst
    action = iAction apiRequest
    -- there can be no filters on the root table when we are doing insert/update/delete
    (flts, logFrst)
      | action == ActionRead || action == ActionInvoke = (iFilters apiRequest, iLogic apiRequest)
      | otherwise = join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
    orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]
    orders = mapM pRequestOrder $ iOrder apiRequest
    ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]
    ranges = mapM pRequestRange $ M.toList $ iRange apiRequest
 addFilterToNode :: Filter -> ReadRequest -> ReadRequest
 addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f
 addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest
 addFilter = addProperty addFilterToNode
 addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest
 addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f
 addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest
 addOrder = addProperty addOrderToNode
 addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest
 addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f
 addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest
 addRange = addProperty addRangeToNode
 addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest
 addLogicTreeToNode t (Node (q@Select{logic=l},i) f) = Node (q{logic=t:l}::ReadQuery, i) f
 addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest
 addLogicTree = addProperty addLogicTreeToNode
 addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest
 addProperty f ([], a) n = f a n
 addProperty f (path, a) (Node rn forest) =
  case targetNode of
    Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path
    Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest)
  where
    targetNodeName:remainingPath = path
    (targetNode,restForest) = splitForest targetNodeName forest
    splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode)
    splitForest name forst =
      case maybeNode of
        Nothing -> (Nothing,forest)
        Just node -> (Just node, delete node forest)
      where
        maybeNode :: Maybe ReadRequest
        maybeNode = find fnd forst
          where
            fnd :: ReadRequest -> Bool
            fnd (Node (_,(n,_,_)) _) = n == name
 -- in a relation where one of the tables mathces "TableName"
 -- replace the name to that table with pg_source
 -- this "fake" relations is needed so that in a mutate query
 -- we can look a the "returning *" part which is wrapped with a "with"
 -- as just another table that has relations with other tables
 toSourceRelation :: TableName -> Relation -> Maybe Relation
 toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
  | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}
  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}
  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}
  | otherwise = Nothing
 mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest
 mutateRequest apiRequest fldNames = mapLeft apiRequestError $
  case action of
    ActionCreate -> Right $ Insert rootTableName payload returnings
    ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> logic_ <*> pure returnings
    ActionDelete -> Delete rootTableName <$> filters <*> logic_ <*> pure returnings
    _        -> Left UnsupportedVerb
  where
    action = iAction apiRequest
    payload = fromJust $ iPayload apiRequest
    rootTableName = -- TODO: Make it safe
      let target = iTarget apiRequest in
      case target of
        (TargetIdent (QualifiedIdentifier _ t) ) -> t
        _ -> undefined
    returnings = if iPreferRepresentation apiRequest == None then [] else fldNames
    filters = map snd <$> mapM pRequestFilter mutateFilters
    logic_ = map snd <$> mapM pRequestLogicTree logicFilters
    -- update/delete filters can be only on the root table
    mutateFilters = onlyRoot $ iFilters apiRequest
    logicFilters = onlyRoot $ iLogic apiRequest
    onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
 fieldNames :: ReadRequest -> [FieldName]
 fieldNames (Node (sel, _) forest) =
  map (fst . view _1) (select sel) ++ map colName fks
  where
    fks = concatMap (fromMaybe [] . f) forest
    f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _)) _) = Just cols
    f _ = Nothing
@@ -0,0 +1,668 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeSynonymInstances  #-}
 module PostgREST.DbStructure (
  getDbStructure
 , accessibleTables
 ) 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.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.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
                        <*> (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' -> Pseudo name
        _   -> 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",
         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
  WHERE  pn.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,
      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 = $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
    combinations k ns = filter ((k==).length) (subsequences ns)
    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,
      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.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,
                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_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,
            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,
                  Int32,      Bool,        Text,
                  Bool,       Maybe Int32, Maybe Int32,
                  Maybe Text, Maybe Text)
                 -> Maybe Column
 columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table
  where
    buildColumn tbl = Column tbl n 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
@@ -0,0 +1,167 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 module PostgREST.Error (
  apiRequestError
 , pgError
 , simpleError
 , singularityError
 , binaryFieldError
 , connectionLostError
 , encodeError
 ) where
 import           Protolude
 import           Data.Aeson                ((.=))
 import qualified Data.Aeson                as JSON
 import           Data.Text                 (unwords)
 import qualified Hasql.Pool                as P
 import qualified Hasql.Session             as H
 import qualified Network.HTTP.Types.Status as HT
 import           Network.Wai               (Response, responseLBS)
 import           PostgREST.Types
 apiRequestError :: ApiRequestError -> Response
 apiRequestError err = errorResponse status err
  where
    status =
      case err of
        ActionInappropriate -> HT.status405
        UnsupportedVerb -> HT.status405
        InvalidBody _ -> HT.status400
        ParseRequestError _ _ -> HT.status400
        NoRelationBetween _ _ -> HT.status400
        InvalidRange -> HT.status416
        UnknownRelation -> HT.status404
 simpleError :: HT.Status -> Text -> Response
 simpleError status message =
  errorResponse status $ JSON.object ["message" .= message]
 errorResponse :: JSON.ToJSON a => HT.Status -> a -> Response
 errorResponse status e =
  responseLBS status [toHeader CTApplicationJSON] $ encodeError e
 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
    '3':'8':_ -> HT.status500 -- external routine exception
    '3':'9':_ -> HT.status500 -- external routine invocation
    '3':'B':_ -> HT.status500 -- savepoint exception
    '4':'0':_ -> HT.status500 -- tx rollback
    '5':'3':_ -> HT.status503 -- insufficient resources
    '5':'4':_ -> HT.status413 -- too complex
    '5':'5':_ -> HT.status500 -- obj not on prereq state
    '5':'7':_ -> HT.status500 -- operator intervention
    '5':'8':_ -> HT.status500 -- system error
    'F':'0':_ -> HT.status500 -- conf file error
    'H':'V':_ -> HT.status500 -- foreign data wrapper error
    "P0001"   -> HT.status400 -- default code for "raise"
    'P':'0':_ -> HT.status500 -- PL/pgSQL Error
    'X':'X':_ -> HT.status500 -- internal Error
    "42883"   -> HT.status404 -- undefined function
    "42P01"   -> HT.status404 -- undefined table
    "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
    _         -> HT.status400
 httpStatus _ (P.SessionError (H.ResultError _)) = HT.status500
 httpStatus _ (P.SessionError (H.ClientError _)) = HT.status503
@@ -0,0 +1,63 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
 module PostgREST.Middleware where
 import           Data.Aeson                    (Value (..))
 import qualified Data.HashMap.Strict           as M
 import qualified Hasql.Transaction             as H
 import           Network.HTTP.Types.Status     (unauthorized401, status500)
 import           Network.Wai                   (Application, Response,
                                                responseLBS)
 import           Network.Wai.Middleware.Cors   (cors)
 import           Network.Wai.Middleware.Gzip   (def, gzip)
 import           Network.Wai.Middleware.Static (only, staticPolicy)
 import           PostgREST.ApiRequest          (ApiRequest(..))
 import           PostgREST.Auth                (JWTAttempt(..))
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 import           PostgREST.Error               (simpleError)
 import           PostgREST.Types               (ContentType (..), toHeader)
 import           PostgREST.QueryBuilder        (pgFmtLit, unquoted, pgFmtEnvVar)
 import           Protolude                     hiding (concat, null)
 runWithClaims :: AppConfig -> JWTAttempt ->
                 (ApiRequest -> H.Transaction Response) ->
                 ApiRequest -> H.Transaction Response
 runWithClaims conf eClaims app req =
  case eClaims of
    JWTExpired -> return $ unauthed "JWT expired"
    JWTInvalid -> return $ unauthed "JWT invalid"
    JWTMissingSecret -> return $ simpleError status500 "Server lacks JWT secret"
    JWTClaims claims -> do
      H.sql $ toS.mconcat $ setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql
      mapM_ H.sql customReqCheck
      app req
      where
        headersSql = map (pgFmtEnvVar "request.header.") $ iHeaders req
        cookiesSql = map (pgFmtEnvVar "request.cookie.") $ iCookies req
        claimsSql = map (pgFmtEnvVar "request.jwt.claim.") [(c,unquoted v) | (c,v) <- M.toList claimsWithRole]
        setRoleSql = maybeToList $
          (\r -> "set local role " <> r <> ";") . toS . pgFmtLit . unquoted <$> M.lookup "role" claimsWithRole
        -- role claim defaults to anon if not specified in jwt
        claimsWithRole = M.union claims (M.singleton "role" anon)
        anon = String . toS $ configAnonRole conf
        customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
  where
    unauthed message = responseLBS unauthorized401
      [ toHeader CTApplicationJSON
      , ( "WWW-Authenticate"
        , "Bearer error=\"invalid_token\", " <>
          "error_description=\"" <> message <> "\""
        )
      ]
      (toS $ "{\"message\":\""<>message<>"\"}")
 defaultMiddle :: Application -> Application
 defaultMiddle =
    gzip def
  . cors corsPolicy
  . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
@@ -0,0 +1,357 @@
 {-# LANGUAGE OverloadedStrings #-}
 module PostgREST.OpenAPI (
  encodeOpenAPI
  , isMalformedProxyUri
  , pickProxy
  ) where
 import           Control.Lens
 import           Data.Aeson                  (decode, encode)
 import qualified Data.HashMap.Strict         as M
 import           Data.HashMap.Strict.InsOrd  (InsOrdHashMap, fromList)
 import           Data.Maybe                  (fromJust)
 import qualified Data.Set                    as Set
 import           Data.String                 (IsString (..))
 import           Data.Text                   (unpack, pack, concat, intercalate, init, tail, toLower)
 import           Network.URI                 (parseURI, isAbsoluteURI,
                                              URI (..), URIAuth (..))
 import           Protolude hiding              (concat, (&), Proxy, get, intercalate)
 import           Data.Swagger
 import           PostgREST.ApiRequest        (ContentType(..))
 import           PostgREST.Config            (prettyVersion)
 import           PostgREST.Types             (Table(..), Column(..), PgArg(..),
                                              Proxy(..), ProcDescription(..), toMime, operators)
 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 :: (Table, [Column], [Text]) -> (Text, Schema)
 makeTableDef (t, cs, _) =
  let tn = tableName t in
      (tn, (mempty :: Schema)
        & type_ .~ SwaggerObject
        & properties .~ fromList (map makeProperty cs))
 makeProperty :: Column -> (Text, Referenced Schema)
 makeProperty c = (colName c, Inline u)
  where
    r = mempty :: Schema
    s = if null $ colEnum c
           then r
           else r & enum_ .~ decode (encode (colEnum c))
    t = s & type_ .~ toSwaggerType (colType c)
    u = t & format ?~ colType c
 makeProcDef :: ProcDescription -> (Text, Schema)
 makeProcDef pd = ("(rpc) " <> pdName pd, s)
  where
    s = (mempty :: Schema)
          & type_ .~ SwaggerObject
          & properties .~ fromList (map makeProcProperty (pdArgs pd))
          & required .~ map pgaName (filter pgaReq (pdArgs pd))
 makeProcProperty :: PgArg -> (Text, Referenced Schema)
 makeProcProperty (PgArg n t _) = (n, Inline s)
  where
    s = (mempty :: Schema)
          & type_ .~ toSwaggerType t
          & format ?~ t
 makeOperatorPattern :: Text
 makeOperatorPattern =
  intercalate "|"
  [ concat ["^", x, y, "[.]"] |
    x <- ["not[.]", ""],
    y <- M.keys operators ]
 makeRowFilter :: Column -> Param
 makeRowFilter c =
  (mempty :: Param)
  & name .~ colName c
  & required ?~ False
  & schema .~ ParamOther ((mempty :: ParamOtherSchema)
    & in_ .~ ParamQuery
    & type_ .~ SwaggerString
    & format ?~ colType c
    & pattern ?~ makeOperatorPattern)
 makeRowFilters :: [Column] -> [Param]
 makeRowFilters = map makeRowFilter
 makeOrderItems :: [Column] -> [Text]
 makeOrderItems cs =
  [ concat [x, y, z] |
    x <- map colName cs,
    y <- [".asc", ".desc", ""],
    z <- [".nullsfirst", ".nulllast", ""]
  ]
 makeRangeParams :: [Param]
 makeRangeParams =
  [ (mempty :: Param)
    & name        .~ "Range"
    & description ?~ "Limiting and Pagination"
    & required    ?~ False
    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
      & in_ .~ ParamHeader
      & type_ .~ SwaggerString)
  , (mempty :: Param)
    & name        .~ "Range-Unit"
    & description ?~ "Limiting and Pagination"
    & required    ?~ False
    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
      & in_ .~ ParamHeader
      & type_ .~ SwaggerString
      & default_ .~ decode "\"items\"")
  , (mempty :: Param)
    & name        .~ "offset"
    & description ?~ "Limiting and Pagination"
    & required    ?~ False
    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
      & in_ .~ ParamQuery
      & type_ .~ SwaggerString)
  , (mempty :: Param)
    & name        .~ "limit"
    & description ?~ "Limiting and Pagination"
    & required    ?~ False
    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
      & in_ .~ ParamQuery
      & type_ .~ SwaggerString)
  ]
 makePreferParam :: [Text] -> Param
 makePreferParam ts =
  (mempty :: Param)
  & name        .~ "Prefer"
  & description ?~ "Preference"
  & required    ?~ False
  & schema .~ ParamOther ((mempty :: ParamOtherSchema)
    & in_ .~ ParamHeader
    & type_ .~ SwaggerString
    & enum_ .~ decode (encode ts))
 makeSelectParam :: Param
 makeSelectParam =
  (mempty :: Param)
    & name        .~ "select"
    & description ?~ "Filtering Columns"
    & required    ?~ False
    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
      & in_ .~ ParamQuery
      & type_ .~ SwaggerString)
 makeGetParams :: [Column] -> [Param]
 makeGetParams [] =
  makeRangeParams ++
  [ makeSelectParam
  , makePreferParam ["count=none"]
  ]
 makeGetParams cs =
  makeRangeParams ++
  [ makeSelectParam
  , (mempty :: Param)
    & name        .~ "order"
    & description ?~ "Ordering"
    & required    ?~ False
    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
      & in_ .~ ParamQuery
      & type_ .~ SwaggerString
      & enum_ .~ decode (encode $ makeOrderItems cs))
  , makePreferParam ["count=none"]
  ]
 makePostParams :: Text -> [Param]
 makePostParams tn =
  [ makePreferParam ["return=representation",
                     "return=minimal", "return=none"]
  , (mempty :: Param)
    & name        .~ "body"
    & description ?~ tn
    & required    ?~ False
    & schema .~ ParamBody (Ref (Reference tn))
  ]
 makeProcParam :: Text -> [Param]
 makeProcParam refName =
  [ makePreferParam ["params=single-object"]
  , (mempty :: Param)
    & name     .~ "args"
    & required ?~ True
    & schema   .~ ParamBody (Ref (Reference refName))
  ]
 makeDeleteParams :: [Param]
 makeDeleteParams =
  [ makePreferParam ["return=representation", "return=minimal", "return=none"] ]
 makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
 makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
  where
    tOp = (mempty :: Operation)
      & tags .~ Set.fromList [tn]
      & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
      & at 200 ?~ "OK"
    getOp = tOp
      & parameters .~ map Inline (makeGetParams cs ++ rs)
      & at 206 ?~ "Partial Content"
    postOp = tOp
      & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
      & parameters .~ map Inline (makePostParams tn)
      & at 201 ?~ "Created"
    patchOp = tOp
      & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
      & parameters .~ map Inline (makePostParams tn ++ rs)
      & at 204 ?~ "No Content"
    deletOp = tOp
      & parameters .~ map Inline (makeDeleteParams ++ rs)
    pr = (mempty :: PathItem) & get ?~ getOp
    pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp
    p False = pr
    p True  = pw
    rs = makeRowFilters cs
    tn = tableName t
 makeProcPathItem :: ProcDescription -> (FilePath, PathItem)
 makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
  where
    postOp = (mempty :: Operation)
      & parameters .~ map Inline (makeProcParam $ "(rpc) " <> pdName 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 ["/"]
      & 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) -> Swagger
 postgrestSpec pds ti (s, h, p, b) = (mempty :: Swagger)
  & basePath ?~ unpack b
  & schemes ?~ [s']
  & info .~ ((mempty :: Info)
      & version .~ prettyVersion
      & title .~ "PostgREST API"
      & description ?~ "This is a dynamic API generated by PostgREST")
  & host .~ h'
  & definitions .~ fromList (map makeTableDef ti <> map makeProcDef pds)
  & paths .~ makePathItems pds ti
    where
      s' = if s == "http" then Http else Https
      h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))
 encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> LByteString
 encodeOpenAPI pds ti uri = encode $ postgrestSpec pds ti uri
 {-|
  Test whether a proxy uri is malformed or not.
  A valid proxy uri should be an absolute uri without query and user info,
  only http(s) schemes are valid, port number range is 1-65535.
  For example
  http://postgrest.com/openapi.json
  https://postgrest.com:8080/openapi.json
 -}
 isMalformedProxyUri :: Maybe Text -> Bool
 isMalformedProxyUri Nothing =  False
 isMalformedProxyUri (Just uri)
  | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri
  | otherwise = True
 toURI :: Text -> URI
 toURI uri = fromJust $ parseURI (toS uri)
 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
@@ -0,0 +1,221 @@
 module PostgREST.Parsers where
 import           Protolude                     hiding (try, intercalate)
 import           Control.Monad                 ((>>))
 import           Data.Foldable                 (foldl1)
 import qualified Data.HashMap.Strict           as M
 import           Data.Text                     (intercalate, replace, strip)
 import           Data.List                     (init, last)
 import           Data.Tree
 import           Data.Either.Combinators       (mapLeft)
 import           PostgREST.RangeQuery          (NonnegRange,allRange)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
 import           Text.Parsec.Error
 pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest
 pRequestSelect rootName selStr =
  mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
 pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter)
 pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
  where
    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
    oper = parse (pOperation pVText pVTextL) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
    path = fst <$> treePath
    fld = snd <$> treePath
 pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm])
 pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
  where
    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
    path = fst <$> treePath
    ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
 pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange)
 pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
  where
    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
    path = fst <$> treePath
 pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree)
 pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
  where
    path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k
    embedPath = fst <$> path
    op = snd <$> path
    -- Concat op and v to make pLogicTree argument regular, in the form of "op(.,.)"
    logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v)
 ws :: Parser Text
 ws = toS <$> many (oneOf " \t")
 lexeme :: Parser a -> Parser a
 lexeme p = ws *> p <* ws
 pReadRequest :: Text -> Parser ReadRequest
 pReadRequest rootNodeName = do
  fieldTree <- pFieldForest
  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree
  where
    readQuery = Select [] [rootNodeName] [] [] Nothing allRange
    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
    treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =
      case fldForest of
        [] -> Node (q {select=fld:select q}, i) rForest
        _  -> Node (q, i) newForest
          where
            newForest =
              foldr treeEntry (Node (Select [] [fn] [] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest
 pTreePath :: Parser (EmbedPath, Field)
 pTreePath = do
  p <- pFieldName `sepBy1` pDelimiter
  jp <- optionMaybe pJsonPath
  return (init p, (last p, jp))
 pFieldForest :: Parser [Tree SelectItem]
 pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
 pFieldTree :: Parser (Tree SelectItem)
 pFieldTree =  try (Node <$> pSimpleSelect <*> between (char '{') (char '}') pFieldForest)
          <|> try (Node <$> pSimpleSelect <*> between (char '(') (char ')') pFieldForest)
          <|> Node <$> pSelect <*> pure []
 pStar :: Parser Text
 pStar = toS <$> (string "*" *> pure ("*"::ByteString))
 pFieldName :: Parser Text
 pFieldName = do
  matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"
  return $ intercalate "-" $ map toS matches
  where
    isDash :: GenParser Char st ()
    isDash = try ( char '-' >> notFollowedBy (char '>') )
    dash :: Parser Char
    dash = isDash *> pure '-'
 pJsonPathStep :: Parser Text
 pJsonPathStep = toS <$> try (string "->" *> pFieldName)
 pJsonPath :: Parser [Text]
 pJsonPath = (<>) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) )
 pField :: Parser Field
 pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath
 aliasSeparator :: Parser ()
 aliasSeparator = char ':' >> notFollowedBy (char ':')
 pSimpleSelect :: Parser SelectItem
 pSimpleSelect = lexeme $ try ( do
    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
    fld <- pField
    return (fld, Nothing, alias)
  )
 pSelect :: Parser SelectItem
 pSelect = lexeme $
  try (
    do
      alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
      fld <- pField
      cast' <- optionMaybe (string "::" *> many letter)
      return (fld, toS <$> cast', alias)
  )
  <|> do
    s <- pStar
    return ((s, Nothing), Nothing, Nothing)
 pOperation :: Parser Operand -> Parser Operand -> Parser Operation
 pOperation parserVText parserVTextL = try ( string "not" *> pDelimiter *> (Operation True <$> pExpr)) <|> Operation False <$> pExpr
  where
    pExpr :: Parser (Operator, Operand)
    pExpr =
          ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys notInOps)) <*> parserVText)
      <|> ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys inOps)) <*> parserVTextL)
      <?> "operator (eq, gt, ...)"
    inOps = M.filterWithKey (const . flip elem ["in", "notin"]) operators
    notInOps = M.difference operators inOps
 pVText :: Parser Operand
 pVText = VText . toS <$> many anyChar
 pVTextL :: Parser Operand
 pVTextL =     VTextL <$> try (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))
          <|> VTextL <$> lexeme pVTextLElement `sepBy1` char ','
 pVTextLElement :: Parser Text
 pVTextLElement = try pQuotedValue <|> (toS <$> many (noneOf ",)"))
 pQuotedValue :: Parser Text
 pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",)"))
 pDelimiter :: Parser Char
 pDelimiter = char '.' <?> "delimiter (.)"
 pOrder :: Parser [OrderTerm]
 pOrder = lexeme pOrderTerm `sepBy` char ','
 pOrderTerm :: Parser OrderTerm
 pOrderTerm =
  try ( do
    c <- pField
    d <- optionMaybe (try $ pDelimiter *> (
               try(string "asc" *> pure OrderAsc)
           <|> try(string "desc" *> pure OrderDesc)
         ))
    nls <- optionMaybe (pDelimiter *> (
                 try(string "nullslast" *> pure OrderNullsLast)
             <|> try(string "nullsfirst" *> pure OrderNullsFirst)
           ))
    return $ OrderTerm c d nls
  )
  <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing
 pLogicTree :: Parser LogicTree
 pLogicTree = Stmnt <$> try pLogicFilter
             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree) <*> (lexeme (char ',') *> pLogicTree <* lexeme (char ')'))
  where
    pLogicFilter :: Parser Filter
    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOperation pLogicVText pLogicVTextL
    pNot :: Parser Bool
    pNot = try (string "not" *> pDelimiter *> pure True) 
           <|> pure False
           <?> "negation operator (not)"
    pLogicOp :: Parser LogicOperator
    pLogicOp = try (string "and"  *> pure And)
               <|> string "or" *> pure Or
               <?> "logic operator (and, or)"
 pLogicVText :: Parser Operand
 pLogicVText = VText <$> (try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)")))
  where
    pPgArray :: Parser Text
    pPgArray =  do
      a <- string "{"
      b <- many (noneOf "{}")
      c <- string "}"
      toS <$> pure (a ++ b ++ c)
 pLogicVTextL :: Parser Operand
 pLogicVTextL = VTextL <$> (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))
 pLogicPath :: Parser (EmbedPath, Text)
 pLogicPath = do
  path <- pFieldName `sepBy1` pDelimiter
  let op = last path
      notOp = "not." <> op
  return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)
 mapError :: Either ParseError a -> Either ApiRequestError a
 mapError = mapLeft translateError
  where
    translateError e =
      ParseRequestError message details
      where
        message = show $ errorPos e
        details = strip $ replace "\n" " " $ toS
           $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
@@ -0,0 +1,473 @@
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE TupleSections        #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-|
 Module      : PostgREST.QueryBuilder
 Description : PostgREST SQL generating functions.
 This module provides functions to consume data types that
 represent database objects (e.g. Relation, Schema, SqlQuery)
 and produces SQL Statements.
 Any function that outputs a SQL fragment should be in this module.
 -}
 module PostgREST.QueryBuilder (
    callProc
  , createReadStatement
  , createWriteStatement
  , getJoinConditions
  , pgFmtIdent
  , pgFmtLit
  , requestToQuery
  , requestToCountQuery
  , sourceCTEName
  , unquoted
  , ResultsWithCount
  , pgFmtEnvVar
  ) where
 import qualified Hasql.Query             as H
 import qualified Hasql.Encoders          as HE
 import qualified Hasql.Decoders          as HD
 import qualified Data.Aeson              as JSON
 import           PostgREST.RangeQuery    (NonnegRange, rangeLimit, rangeOffset, allRange)
 import           Data.Functor.Contravariant (contramap)
 import qualified Data.HashMap.Strict     as HM
 import           Data.Maybe
 import           Data.Text               (intercalate, unwords, replace, isInfixOf, toLower)
 import qualified Data.Text as T          (map, takeWhile, null)
 import qualified Data.Text.Encoding as T
 import           Data.Tree               (Tree(..))
 import qualified Data.Vector as V
 import           PostgREST.Types
 import           Text.InterpolatedString.Perl6 (qc)
 import qualified Data.ByteString.Char8   as BS
 import           Data.Scientific         ( FPFormat (..)
                                         , formatScientific
                                         , isInteger
                                         )
 import           Protolude hiding        (from, intercalate, ord, cast)
 import           PostgREST.ApiRequest    (PreferRepresentation (..))
 {-| The generic query result format used by API responses. The location header
    is represented as a list of strings containing variable bindings like
    @"k1=eq.42"@, or the empty list if there is no location header.
 -}
 type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString)
 standardRow :: HD.Row ResultsWithCount
 standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
                    <*> HD.value header <*> HD.value HD.bytea
  where
    header = HD.array $ HD.arrayDimension replicateM $ HD.arrayValue HD.bytea
 noLocationF :: Text
 noLocationF = "array[]::text[]"
 {-| Read and Write api requests use a similar response format which includes
    various record counts and possible location header. This is the decoder
    for that common type of query.
 -}
 decodeStandard :: HD.Result ResultsWithCount
 decodeStandard =
  HD.singleRow standardRow
 decodeStandardMay :: HD.Result (Maybe ResultsWithCount)
 decodeStandardMay =
  HD.maybeRow standardRow
 {-| JSON and CSV payloads from the client are given to us as
    PayloadJSON (objects who all have the same keys),
    and we turn this into an old fasioned JSON array
 -}
 encodeUniformObjs :: HE.Params PayloadJSON
 encodeUniformObjs =
  contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json)
 createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName ->
                       H.Query () ResultsWithCount
 createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =
  unicodeStatement sql HE.unit decodeStandard False
 where
  sql = [qc|
      WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}
      FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |]
  countResultF = if countTotal then "("<>countQuery<>")" else "null"
  cols = intercalate ", " [
      countResultF <> " AS total_result_set",
      "pg_catalog.count(_postgrest_t) AS page_total",
      noLocationF <> " AS header",
      bodyF <> " AS body"
    ]
  bodyF
    | asCsv = asCsvF
    | isSingle = asJsonSingleF
    | isJust binaryField = asBinaryF $ fromJust binaryField
    | otherwise = asJsonF
 createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
                        PreferRepresentation -> [Text] ->
                        H.Query PayloadJSON (Maybe ResultsWithCount)
 createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys =
  unicodeStatement sql encodeUniformObjs decodeStandardMay True
 where
  sql = case rep of
    None -> [qc|
      WITH {sourceCTEName} AS ({mutateQuery})
      SELECT '', 0, {noLocationF}, '' |]
    HeadersOnly -> [qc|
      WITH {sourceCTEName} AS ({mutateQuery})
      SELECT {cols}
      FROM (SELECT 1 FROM {sourceCTEName}) _postgrest_t |]
    Full -> [qc|
      WITH {sourceCTEName} AS ({mutateQuery})
      SELECT {cols}
      FROM ({selectQuery}) _postgrest_t |]
  cols = intercalate ", " [
      "'' AS total_result_set", -- when updateing it does not make sense
      "pg_catalog.count(_postgrest_t) AS page_total",
      if wantHdrs
         then locationF pKeys
         else noLocationF <> " AS header",
      if rep == Full
         then bodyF <> " AS body"
         else "''"
    ]
  bodyF
    | asCsv = asCsvF
    | wantSingle = asJsonSingleF
    | otherwise = asJsonF
 type ProcResults = (Maybe Int64, Int64, ByteString)
 callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange ->
  Bool -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults)
 callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson asCsv =
  unicodeStatement sql HE.unit decodeProc True
  where
    sql = [qc|
            WITH {sourceCTEName} AS ({_callSql})
            SELECT
              {countResultF} AS total_result_set,
              pg_catalog.count(_postgrest_t) AS page_total,
              case
                when pg_catalog.count(*) > 1 then
                  {bodyF}
                else
                  coalesce(((array_agg(row_to_json(_postgrest_t)))[1]->{_procName})::character varying, {bodyF})
              end as body
            FROM ({selectQuery}) _postgrest_t;
          |]
          -- FROM (select * from {sourceCTEName} {limitF range}) t;
    countResultF = if countTotal then "("<>countQuery<>")" else "null::bigint" :: Text
    _args = if paramsAsJson
                then insertableValueWithType "json" $ JSON.Object params
                else intercalate "," $ map _assignment (HM.toList params)
    _procName = pgFmtLit $ qiName qi
    _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
    _callSql = [qc|select * from {fromQi qi}({_args}) |] :: Text
    _countExpr = if countTotal
                   then [qc|(select pg_catalog.count(*) from {sourceCTEName})|]
                   else "null::bigint" :: Text
    decodeProc = HD.maybeRow procRow
    procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
                   <*> HD.value HD.bytea
    bodyF
     | isSingle = asJsonSingleF
     | asCsv = asCsvF
     | otherwise = asJsonF
 pgFmtIdent :: SqlFragment -> SqlFragment
 pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""
 pgFmtLit :: SqlFragment -> SqlFragment
 pgFmtLit x =
 let trimmed = trimNullChars x
     escaped = "'" <> replace "'" "''" trimmed <> "'"
     slashed = replace "\\" "\\\\" escaped in
 if "\\" `isInfixOf` escaped
   then "E" <> slashed
   else slashed
 requestToCountQuery :: Schema -> DbRequest -> SqlQuery
 requestToCountQuery _ (DbMutate _) = undefined
 requestToCountQuery schema (DbRead (Node (Select _ _ conditions logic_ _ _, (mainTbl, _, _)) _)) =
 unwords [
   "SELECT pg_catalog.count(*)",
   "FROM ", fromQi qi,
    -- logic_ doesn't not need localFilter filtering because it doesn't have VForeignKey vals
    ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) localConditions ++ map (pgFmtLogicTree qi) logic_))
      `emptyOnFalse` (null conditions && null logic_)
   ]
 where
   qi = removeSourceCTESchema schema mainTbl
   localFilter :: Filter -> Bool
   localFilter Filter{operation=Operation{expr=(_, val)}} = case val of
    VText _ -> True
    VTextL _ -> True
    VForeignKey _ _ -> False
   localConditions = filter localFilter conditions
 requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery
 requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions logic_ ord range, (nodeName, maybeRelation, _)) forest)) =
  query
  where
    mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)
    qi = removeSourceCTESchema schema mainTbl
    toQi = removeSourceCTESchema schema
    query = unwords [
      "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
      "FROM ", intercalate ", " (map (fromQi . toQi) tbls),
      unwords joins,
      ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))
        `emptyOnFalse` (null conditions && null logic_),
      orderF (fromMaybe [] ord),
      if isParent then "" else limitF range
      ]
    orderF ts =
        if null ts
            then ""
            else "ORDER BY " <> clause
        where
            clause = intercalate "," (map queryTerm ts)
            queryTerm :: OrderTerm -> Text
            queryTerm t = " "
                <> toS (pgFmtField qi $ otTerm t) <> " "
                <> maybe "" show (otDirection t) <> " "
                <> maybe "" show (otNullOrder t) <> " "
    (joins, selects) = foldr getQueryParts ([],[]) forest
    getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
    getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s)
      where
        sel = "COALESCE(("
           <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
           <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
           <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
           where subquery = requestToQuery schema False (DbRead (Node n forst))
    getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (joi:j,sel:s)
      where
        node_name = fromMaybe name alias
        local_table_name = table <> "_" <> node_name
        replaceTableName localTableName (Filter a (Operation b (c, VForeignKey (QualifiedIdentifier "" _) d))) = Filter a (Operation b (c, VForeignKey (QualifiedIdentifier "" localTableName) d))
        replaceTableName _ x = x
        sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name
        joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name  <>
              " ON " <> intercalate " AND " ( map (pgFmtFilter qi . replaceTableName local_table_name) (getJoinConditions r) )
          where subquery = requestToQuery schema True (DbRead (Node n forst))
    getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s)
      where
        sel = "COALESCE (("
           <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
           <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
           <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
           where subquery = requestToQuery schema False (DbRead (Node n forst))
    --the following is just to remove the warning
    --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
    --posible relations are Child Parent Many
    getQueryParts _ _ = undefined
 requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) =
  insInto <> vals <> ret
  where qi = QualifiedIdentifier schema mainTbl
        cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
        colsString = intercalate ", " cols
        insInto = unwords [ "INSERT INTO" , fromQi qi,
            if T.null colsString then "" else "(" <> colsString <> ")"
          ]
        vals = unwords $
          if T.null colsString
            then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"]
            else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"]
        ret = if null returnings
                  then ""
                  else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)]
 requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions logic_ returnings)) =
  case rows V.!? 0 of
    Just obj ->
      let assignments = map
            (\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in
      unwords [
        "UPDATE ", fromQi qi,
        " SET " <> intercalate "," assignments <> " ",
        ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))
          `emptyOnFalse` (null conditions && null logic_),
        ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
        ]
    Nothing -> undefined
  where
    qi = QualifiedIdentifier schema mainTbl
 requestToQuery schema _ (DbMutate (Delete mainTbl conditions logic_ returnings)) =
  query
  where
    qi = QualifiedIdentifier schema mainTbl
    query = unwords [
      "DELETE FROM ", fromQi qi,
      ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))
        `emptyOnFalse` (null conditions && null logic_),
      ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
      ]
 sourceCTEName :: SqlFragment
 sourceCTEName = "pg_source"
 removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
 removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl
 unquoted :: JSON.Value -> Text
 unquoted (JSON.String t) = t
 unquoted (JSON.Number n) =
  toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
 unquoted (JSON.Bool b) = show b
 unquoted v = toS $ JSON.encode v
 -- private functions
 asCsvF :: SqlFragment
 asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
  where
    asCsvHeaderF =
      "(SELECT coalesce(string_agg(a.k, ','), '')" <>
      "  FROM (" <>
      "    SELECT json_object_keys(r)::TEXT as k" <>
      "    FROM ( " <>
      "      SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <>
      "    ) s" <>
      "  ) a" <>
      ")"
    asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"
 asJsonF :: SqlFragment
 asJsonF = "coalesce(array_to_json(array_agg(row_to_json(_postgrest_t))), '[]')::character varying"
 asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
 asJsonSingleF = "coalesce(string_agg(row_to_json(_postgrest_t)::text, ','), '')::character varying "
 asBinaryF :: FieldName -> SqlFragment
 asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
 locationF :: [Text] -> SqlFragment
 locationF pKeys =
    "(" <>
    " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceCTEName <> " as ss  limit 1)" <>
    " SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))" <>
    " FROM s, json_each_text(s.r) AS json_data" <>
    (
      if null pKeys
      then ""
      else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')"
    ) <> ")"
 limitF :: NonnegRange -> SqlFragment
 limitF r  = if r == allRange
  then ""
  else "LIMIT " <> limit <> " OFFSET " <> offset
  where
    limit  = maybe "ALL" show $ rangeLimit r
    offset = show $ rangeOffset r
 fromQi :: QualifiedIdentifier -> SqlFragment
 fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
  where
    n = qiName t
    s = qiSchema t
 getJoinConditions :: Relation -> [Filter]
 getJoinConditions (Relation t cols ft fcs typ lt lc1 lc2) =
  case typ of
    Child  -> zipWith (toFilter tN ftN) cols fcs
    Parent -> zipWith (toFilter tN ftN) cols fcs
    Many   -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2)
    Root   -> undefined --error "undefined getJoinConditions"
  where
    s = if typ == Parent then "" else tableSchema t
    tN = tableName t
    ftN = tableName ft
    ltN = fromMaybe "" (tableName <$> lt)
    toFilter :: Text -> Text -> Column -> Column -> Filter
    toFilter tb ftb c fc = Filter (colName c, Nothing) (Operation False ("=", VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})))
 unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Query a b
 unicodeStatement = H.statement . T.encodeUtf8
 emptyOnFalse :: Text -> Bool -> Text
 emptyOnFalse val cond = if cond then "" else val
 insertableValue :: JSON.Value -> SqlFragment
 insertableValue JSON.Null = "null"
 insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v
 insertableValueWithType :: Text -> JSON.Value -> SqlFragment
 insertableValueWithType t v =
  pgFmtLit (unquoted v) <> "::" <> t
 pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment
 pgFmtColumn table "*" = fromQi table <> ".*"
 pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
 pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment
 pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp
 pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment
 pgFmtSelectItem table (f@(_, jp), Nothing, alias) = pgFmtField table f <> pgFmtAs jp alias
 pgFmtSelectItem table (f@(_, jp), Just cast, alias) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs jp alias
 pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment
 pgFmtFilter table (Filter fld (Operation hasNot_ ex)) = notOp <> " " <> case ex of
   (op, VText val) -> pgFmtFieldOp op <> " " <> case op of
     "like"  -> unknownLiteral (T.map star val)
     "ilike" -> unknownLiteral (T.map star val)
     "@@"    -> "to_tsquery(" <> unknownLiteral val <> ") "
     "is"    -> whiteList val
     "isnot" -> whiteList val
     _       -> unknownLiteral val
   (op, VTextL vals) -> pgFmtIn op vals -- in and notin
   (op, VForeignKey fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName})) ->
     pgFmtField fQi fld <> " " <> sqlOperator op <> " " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName
 where
   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
   sqlOperator o = HM.lookupDefault "=" o operators
   notOp = if hasNot_ then "NOT" else ""
   star c = if c == '*' then '%' else c
   unknownLiteral = (<> "::unknown ") . pgFmtLit
   whiteList :: Text -> SqlFragment
   whiteList v = fromMaybe
     (toS (pgFmtLit v) <> "::unknown ")
     (find ((==) . toLower $ v) ["null","true","false"])
   pgFmtIn :: Operator -> [Text] -> SqlFragment
   pgFmtIn op vals =
    -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"
    let emptyValForIn o = (if "not" `isInfixOf` o then "NOT " else "") -- handle case of "notin" operator
                          <> pgFmtField table fld <> " = any('{}') " in
    case T.null <$> headMay vals of
      Just isNull -> if isNull && length vals == 1
                        then emptyValForIn op
                        else pgFmtFieldOp op <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "
      Nothing -> emptyValForIn op
 pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment
 pgFmtLogicTree qi (Expr hasNot_ op lt rt) = notOp <> " (" <> pgFmtLogicTree qi lt <> " " <> show op <> " " <> pgFmtLogicTree qi rt <> ")"
  where notOp =  if hasNot_ then "NOT" else ""
 pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
 pgFmtJsonPath :: Maybe JsonPath -> SqlFragment
 pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
 pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )
 pgFmtJsonPath _ = ""
 pgFmtAs :: Maybe JsonPath -> Maybe Alias -> SqlFragment
 pgFmtAs Nothing Nothing = ""
 pgFmtAs (Just xx) Nothing = case lastMay xx of
  Just alias -> " AS " <> pgFmtIdent alias
  Nothing -> ""
 pgFmtAs _ (Just alias) = " AS " <> pgFmtIdent alias
 pgFmtEnvVar :: Text -> (Text, Text) -> SqlFragment
 pgFmtEnvVar prefix (k, v) =
  "set local " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";"
 trimNullChars :: Text -> Text
 trimNullChars = T.takeWhile (/= '\x0')
@@ -0,0 +1,71 @@
 module PostgREST.RangeQuery (
  rangeParse
 , rangeRequested
 , rangeLimit
 , rangeOffset
 , restrictRange
 , rangeGeq
 , allRange
 , NonnegRange
 ) where
 import           Control.Applicative
 import           Network.HTTP.Types.Header
 import qualified Data.ByteString.Char8     as BS
 import           Data.Ranged.Boundaries
 import           Data.Ranged.Ranges
 import           Text.Regex.TDFA           ((=~))
 import Data.List (lookup)
 import           Protolude
 type NonnegRange = Range Integer
 rangeParse :: BS.ByteString -> NonnegRange
 rangeParse range = do
  let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString
  case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of
    Just parsedRange ->
      let [_, mLower, mUpper] = readMaybe . toS <$> parsedRange
          lower         = fromMaybe emptyRange   (rangeGeq <$> mLower)
          upper         = fromMaybe allRange (rangeLeq <$> mUpper) in
      rangeIntersection lower upper
    Nothing -> allRange
 rangeRequested :: RequestHeaders -> NonnegRange
 rangeRequested headers = fromMaybe allRange $
  rangeParse <$> lookup hRange headers
 restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange
 restrictRange Nothing r = r
 restrictRange (Just limit) r =
   rangeIntersection r $
     Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)
 rangeLimit :: NonnegRange -> Maybe Integer
 rangeLimit range =
  case [rangeLower range, rangeUpper range] of
    [BoundaryBelow lower, BoundaryAbove upper] -> Just (1 + upper - lower)
    _ -> Nothing
 rangeOffset :: NonnegRange -> Integer
 rangeOffset range =
  case rangeLower range of
    BoundaryBelow lower -> lower
    _ -> panic "range without lower bound" -- should never happen
 rangeGeq :: Integer -> NonnegRange
 rangeGeq n =
  Range (BoundaryBelow n) BoundaryAboveAll
 allRange :: NonnegRange
 allRange = rangeGeq 0
 rangeLeq :: Integer -> NonnegRange
 rangeLeq n =
  Range BoundaryBelowAll (BoundaryAbove n)
@@ -0,0 +1,245 @@
 {-# LANGUAGE DuplicateRecordFields    #-}
 module PostgREST.Types where
 import           Protolude
 import qualified GHC.Show
 import           Data.Aeson
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict  as M
 import           Data.Tree
 import qualified Data.Vector          as V
 import           PostgREST.RangeQuery (NonnegRange)
 import           Network.HTTP.Types.Header (hContentType, Header)
 -- | Enumeration of currently supported response content types
 data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
                 | CTSingularJSON | CTOctetStream
                 | CTAny | CTOther ByteString deriving Eq
 data ApiRequestError = ActionInappropriate
                     | InvalidBody ByteString
                     | InvalidRange
                     | ParseRequestError Text Text
                     | UnknownRelation
                     | NoRelationBetween Text Text
                     | UnsupportedVerb
                     deriving (Show, Eq)
 data DbStructure = DbStructure {
  dbTables      :: [Table]
 , dbColumns     :: [Column]
 , dbRelations   :: [Relation]
 , dbPrimaryKeys :: [PrimaryKey]
 , dbProcs       :: M.HashMap Text ProcDescription
 } deriving (Show, Eq)
 data PgArg = PgArg {
  pgaName :: Text
 , pgaType :: Text
 , pgaReq  :: Bool
 } deriving (Show, Eq)
 data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier | Pseudo Text deriving (Eq, Show)
 data RetType = Single PgType | SetOf PgType deriving (Eq, Show)
 data ProcVolatility = Volatile | Stable | Immutable
  deriving (Eq, Show)
 data ProcDescription = ProcDescription {
  pdName       :: Text
 , pdArgs       :: [PgArg]
 , pdReturnType :: RetType
 , pdVolatility :: ProcVolatility
 } deriving (Show, Eq)
 type Schema = Text
 type TableName = Text
 type SqlQuery = Text
 type SqlFragment = Text
 type RequestBody = BL.ByteString
 data Table = Table {
  tableSchema     :: Schema
 , tableName       :: TableName
 , tableInsertable :: Bool
 } deriving (Show, Ord)
 newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord)
 data Column =
    Column {
      colTable     :: Table
    , colName      :: Text
    , colPosition  :: Int32
    , colNullable  :: Bool
    , colType      :: Text
    , colUpdatable :: Bool
    , colMaxLen    :: Maybe Int32
    , colPrecision :: Maybe Int32
    , colDefault   :: Maybe Text
    , colEnum      :: [Text]
    , colFK        :: Maybe ForeignKey
    } deriving (Show, Ord)
 type Synonym = (Column,Column)
 data PrimaryKey = PrimaryKey {
    pkTable :: Table
  , pkName  :: Text
 } deriving (Show, Eq)
 data OrderDirection = OrderAsc | OrderDesc deriving (Eq)
 instance Show OrderDirection where
  show OrderAsc  = "asc"
  show OrderDesc = "desc"
 data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq)
 instance Show OrderNulls where
  show OrderNullsFirst = "nulls first"
  show OrderNullsLast  = "nulls last"
 data OrderTerm = OrderTerm {
  otTerm      :: Field
 , otDirection :: Maybe OrderDirection
 , otNullOrder :: Maybe OrderNulls
 } deriving (Show, Eq)
 data QualifiedIdentifier = QualifiedIdentifier {
  qiSchema :: Schema
 , qiName   :: TableName
 } deriving (Show, Eq)
 data RelationType = Child | Parent | Many | Root deriving (Show, Eq)
 data Relation = Relation {
  relTable    :: Table
 , relColumns  :: [Column]
 , relFTable   :: Table
 , relFColumns :: [Column]
 , relType     :: RelationType
 , relLTable   :: Maybe Table
 , relLCols1   :: Maybe [Column]
 , relLCols2   :: Maybe [Column]
 } deriving (Show, Eq)
 -- | An array of JSON objects that has been verified to have
 -- the same keys in every object
 newtype PayloadJSON = PayloadJSON (V.Vector Object)
  deriving (Show, Eq)
 unPayloadJSON :: PayloadJSON -> V.Vector Object
 unPayloadJSON (PayloadJSON objs) = objs
 data Proxy = Proxy {
  proxyScheme     :: Text
 , proxyHost       :: Text
 , proxyPort       :: Integer
 , proxyPath       :: Text
 } deriving (Show, Eq)
 type Operator = Text
 operators :: M.HashMap Operator SqlFragment
 operators = M.fromList [
  ("eq", "="),
  ("gte", ">="),
  ("gt", ">"),
  ("lte", "<="),
  ("lt", "<"),
  ("neq", "<>"),
  ("like", "LIKE"),
  ("ilike", "ILIKE"),
  ("in", "IN"),
  ("notin", "NOT IN"),
  ("isnot", "IS NOT"),
  ("is", "IS"),
  ("@@", "@@"),
  ("@>", "@>"),
  ("<@", "<@")]
 data Operation = Operation{ hasNot::Bool, expr::(Operator, Operand) } deriving (Eq, Show)
 data Operand = VText Text | VTextL [Text] | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
 data LogicOperator = And | Or deriving Eq
 instance Show LogicOperator where
  show And  = "AND"
  show Or = "OR"
 {-|
  Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
            And
           /   \
  name.eq.N     Or
               /  \
         id.eq.1   id.eq.2
 -}
 data LogicTree = Expr Bool LogicOperator LogicTree LogicTree | Stmnt Filter deriving (Show, Eq)
 type FieldName = Text
 type JsonPath = [Text]
 type Field = (FieldName, Maybe JsonPath)
 type Alias = Text
 type Cast = Text
 type NodeName = Text
 type SelectItem = (Field, Maybe Cast, Maybe Alias)
 -- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]
 type EmbedPath = [Text]
 data Filter = Filter { field::Field, operation::Operation } deriving (Show, Eq)
 data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], logic::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
 data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }
                 | Delete { in_::TableName, where_::[Filter], logic::[LogicTree], returning::[FieldName] }
                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], logic::[LogicTree], returning::[FieldName] } deriving (Show, Eq)
 type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
 type ReadRequest = Tree ReadNode
 type MutateRequest = MutateQuery
 data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
 instance ToJSON Column where
  toJSON c = object [
      "schema"    .= tableSchema t
    , "name"      .= colName c
    , "position"  .= colPosition c
    , "nullable"  .= colNullable c
    , "type"      .= colType c
    , "updatable" .= colUpdatable c
    , "maxLen"    .= colMaxLen c
    , "precision" .= colPrecision c
    , "references".= colFK c
    , "default"   .= colDefault c
    , "enum"      .= colEnum c ]
    where
      t = colTable c
 instance ToJSON ForeignKey where
  toJSON fk = object [
      "schema" .= tableSchema t
    , "table"  .= tableName t
    , "column" .= colName c ]
    where
      c = fkCol fk
      t = colTable c
 instance ToJSON Table where
  toJSON v = object [
      "schema"     .= tableSchema v
    , "name"       .= tableName v
    , "insertable" .= tableInsertable v ]
 instance Eq Table where
  Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
 instance Eq Column where
  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
 -- | Convert from ContentType to a full HTTP Header
 toHeader :: ContentType -> Header
 toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
 -- | Convert from ContentType to a ByteString representing the mime type
 toMime :: ContentType -> ByteString
 toMime CTApplicationJSON = "application/json"
 toMime CTTextCSV         = "text/csv"
 toMime CTOpenAPI         = "application/openapi+json"
 toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
 toMime CTOctetStream     = "application/octet-stream"
 toMime CTAny             = "*/*"
 toMime (CTOther ct)      = ct
@@ -1,58 +0,0 @@
 module RangeQuery (
  rangeParse
 , rangeRequested
 , rangeLimit
 , rangeOffset
 , NonnegRange
 ) where
 import Control.Applicative
 import Network.HTTP.Types.Header
 import qualified Data.ByteString.Char8 as BS
 import Data.Ranged.Boundaries
 import Data.Ranged.Ranges
 import Data.String.Conversions (cs)
 import Text.Regex.TDFA ((=~))
 import Text.Read (readMaybe)
 import Data.Maybe (fromMaybe, listToMaybe)
 type NonnegRange = Range Int
 rangeParse :: BS.ByteString -> Maybe NonnegRange
 rangeParse range = do
  let rangeRegex = "^([0-9]+)-([0-9]*)$" :: BS.ByteString
  parsedRange <- listToMaybe (range =~ rangeRegex :: [[BS.ByteString]])
  let [_, from, to] = readMaybe . cs <$> parsedRange
  let lower = fromMaybe emptyRange   (rangeGeq <$> from)
  let upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to)
  return $ rangeIntersection lower upper
 rangeRequested :: RequestHeaders -> Maybe NonnegRange
 rangeRequested = (rangeParse =<<) . lookup hRange
 rangeLimit :: NonnegRange -> Maybe Int
 rangeLimit range =
  case [rangeLower range, rangeUpper range]
    of [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)
       _ -> Nothing
 rangeOffset :: NonnegRange -> Int
 rangeOffset range =
  case rangeLower range
    of BoundaryBelow from -> from
       _ -> error "range without lower bound" -- should never happen
 rangeGeq :: Int -> NonnegRange
 rangeGeq n =
  Range (BoundaryBelow n) BoundaryAboveAll
 rangeLeq :: Int -> NonnegRange
 rangeLeq n =
  Range BoundaryBelowAll (BoundaryAbove n)
@@ -1,57 +0,0 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Types where
 import qualified Data.Aeson as JSON
 import Data.Aeson.Types (Parser)
 import Data.Scientific (floatingOrInteger)
 import Data.HashMap.Strict (foldlWithKey')
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8)
 import Data.Time.Calendar (showGregorian)
 import Control.Monad (mzero)
 instance JSON.FromJSON SqlValue where
  parseJSON (JSON.Number n)    = return $ either toSql iToSql (floatingOrInteger n :: Either Double Int)
  parseJSON (JSON.String s)    = return $ toSql s
  parseJSON (JSON.Bool   b)    = return $ toSql b
  parseJSON JSON.Null          = return SqlNull
  parseJSON (JSON.Object o)    = return . toSql $ JSON.encode o
  parseJSON (JSON.Array  a)    = return . toSql $ JSON.encode a
 instance JSON.ToJSON SqlValue where
  toJSON (SqlString s)         = JSON.toJSON s
  toJSON (SqlByteString s)     = JSON.toJSON $ decodeUtf8 s
  toJSON (SqlWord32 w)         = JSON.toJSON w
  toJSON (SqlWord64 w)         = JSON.toJSON w
  toJSON (SqlInt32 i)          = JSON.toJSON i
  toJSON (SqlInt64 i)          = JSON.toJSON i
  toJSON (SqlInteger i)        = JSON.toJSON i
  toJSON (SqlChar c)           = JSON.toJSON c
  toJSON (SqlBool b)           = JSON.toJSON b
  toJSON (SqlDouble n)         = JSON.toJSON n
  toJSON (SqlRational n)       = JSON.toJSON n
  toJSON (SqlLocalDate d)      = JSON.toJSON $ showGregorian d
  toJSON (SqlLocalTimeOfDay t) = JSON.toJSON $ show t
  toJSON (SqlLocalTime t)      = JSON.toJSON $ show t
  toJSON SqlNull               = JSON.Null
  toJSON x                     = JSON.toJSON $ show x
 newtype SqlRow = SqlRow {getRow :: [(Text, SqlValue)] } deriving (Show)
 sqlRowColumns :: SqlRow -> [Text]
 sqlRowColumns = map fst . getRow
 sqlRowValues :: SqlRow -> [SqlValue]
 sqlRowValues = map snd . getRow
 instance JSON.FromJSON SqlRow where
  parseJSON (JSON.Object m) = foldlWithKey' add (return $ SqlRow []) m
    where
      add :: Parser SqlRow -> Text -> JSON.Value -> Parser SqlRow
      add parser k v = do
        SqlRow l <- parser
        sqlV <- JSON.parseJSON v
        return . SqlRow $ (k, sqlV) : l
  parseJSON _ = mzero
@@ -0,0 +1,10 @@
 resolver: lts-8.5
 extra-deps:
  - Ranged-sets-0.3.0
  - hasql-pool-0.4.1
  - configurator-ng-0.0.0.1
  - critbit-0.2.0.0
 ghc-options:
  postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints
 nix:
  packages: [postgresql, zlib]
@@ -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
@@ -0,0 +1,172 @@
 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 @@" $
          get "/entities?or=(text_search_vector.@@.bar,text_search_vector.@@.baz)&select=id" `shouldRespondWith`
            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }
        it "can handle @> and <@" $
          get "/entities?or=(arr.@>.{1,2,3},arr.<@.{1})&select=id" `shouldRespondWith`
            [json|[{ "id": 1 },{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }
        context "operators with not" $ do
          it "eq, @>, like can be negated" $
            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, @@ can be negated" $
            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, <@ can be negated" $
            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 "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 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] }
      get "/entities?or=)(" `shouldRespondWith`
        [json|{
          "details": "unexpected \")\" expecting \"(\"",
          "message": "\"failed to parse logic tree ()()\" (line 1, column 3)"
        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }
      get "/entities?or=(id.eq.1)" `shouldRespondWith`
        [json|{
          "details": "unexpected \")\" expecting \",\"",
          "message": "\"failed to parse logic tree ((id.eq.1))\" (line 1, column 11)"
        }|] { 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] }
@@ -1,31 +1,144 @@
 {-# LANGUAGE QuasiQuotes #-}
 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 :: SpecWith Application
-spec = beforeAll
+spec = describe "authorization" $ do
-  (clearTable "postgrest.auth") . afterAll_ (clearTable "postgrest.auth")
+  let single = ("Accept","application/vnd.pgrst.object+json")
  $ around withApp
  $ describe "authorization" $ do
-  it "hides tables that anonymous does not own" $
+  it "denies access to tables that anonymous does not own" $
-    get "/authors_only" `shouldRespondWith` 404
+    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" $ do
+  it "denies access to tables that postgrest_test_author does not own" $
-    let auth = authHeader "postgrest_test_author" "fakefake"
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" 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.P2G9EVSVI22MWxXWFuhEYd9BZerLS1WDlqzdqplM15s"} |]
        { matchStatus = 200
        , matchHeaders = [matchContentTypeSingular]
        }
  it "sql functions can encode custom and standard claims" $
    request methodPost  "/rpc/jwt_test" [single] "{}"
      `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpc3MiOiJqb2UiLCJzdWIiOiJmdW4iLCJhdWQiOiJldmVyeW9uZSIsImV4cCI6MTMwMDgxOTM4MCwibmJmIjoxMzAwODE5MzgwLCJpYXQiOjEzMDA4MTkzODAsImp0aSI6ImZvbyIsInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdCIsImh0dHA6Ly9wb3N0Z3Jlc3QuY29tL2ZvbyI6dHJ1ZX0.IHF16ZSU6XTbOnUWO8CCpUn2fJwt8P00rlYVyXQjpWc"} |]
        { matchStatus = 200
        , matchHeaders = [matchContentTypeSingular]
        }
  it "sql functions can read custom and standard claims variables" $ do
    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwLCJhdWQiOiJldmVyeW9uZSJ9.AQmCA7CMScvfaDRMqRPeUY6eNf--69gpW-kxaWfq9X0"
    request methodPost "/rpc/reveal_big_jwt" [auth] "{}"
      `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","aud":"everyone","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.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
    request methodGet "/authors_only" [auth] ""
      `shouldRespondWith` 200
  it "works with tokens which have extra fields" $ do
    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIiwia2V5MSI6InZhbHVlMSIsImtleTIiOiJ2YWx1ZTIiLCJrZXkzIjoidmFsdWUzIiwiYSI6MSwiYiI6MiwiYyI6M30.GfydCh-F4wnM379xs0n1zUgalwJIsb6YoBapCo8HlFk"
    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.QaPPLWTuyydMu_q7H4noMT7Lk6P4muet1OpJXF6ofhc"
    request methodGet "/authors_only" [auth] ""
      `shouldRespondWith` 200
  it "fails with an expired token" $ do
    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjE0NDY2NzgxNDksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.enk_qZ_u6gZsXY4R8bREKB_HNExRpM0lIWSLktk9JJQ"
    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":"JWT invalid"} |]
        { matchStatus = 401
        , matchHeaders = [
            "WWW-Authenticate" <:>
            "Bearer error=\"invalid_token\", error_description=\"JWT invalid\""
          ]
        }
  it "should fail when jwt contains no claims" $ do
    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.lu-rG8aSCiw-aOlN0IxpRGz5r7Jwq7K9r3tuMPUpytI"
    request methodGet "/authors_only" [auth] ""
      `shouldRespondWith` 401
-  it "allows users with permissions to see their tables" $ do
+  it "hides tables from users with JWT that contain no claims about role" $ do
-    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.Jneso9X519Vh0z7i9PbXIu7W1HEoq9RRw9BBbyQKFCQ"
-    let auth = authHeader "jdoe" "1234"
+    request methodGet "/authors_only" [auth] ""
      `shouldRespondWith` 401
  it "recovers after 401 error with logged in user" $ do
    _ <- post "/authors_only" [json| { "owner": "jdoe", "secret": "test content" } |]
    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
    _ <- request methodPost "/rpc/problem" [auth] ""
    request methodGet "/authors_only" [auth] ""
      `shouldRespondWith` 200
  describe "custom pre-request proc acting on id claim" $ do
    it "able to switch to postgrest_test_author role (id=1)" $
      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6MX0.mI2HNoOum6xM3sc4oHLxU4yLv-_WV5W1kqBfY_wEvLw" in
      request methodPost "/rpc/get_current_user" [auth]
        [json| {} |]
         `shouldRespondWith` [str|"postgrest_test_author"|]
          { matchStatus = 200
          , matchHeaders = []
          }
    it "able to switch to postgrest_test_default_role (id=2)" $
      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Mn0.W7jLsG-zswM91AJkCvZeIMHrnz7_6ceY2jnscVl3Yhk" 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.15Gy8PezQhJIaHYDJVLa-Gmz9T3sJnW66EKAYIsXc7c" 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 = []
          }
@@ -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.l_EcSRWeNtL4OKUTIplrHyioNrff9Rd0MV7RXNCxCyk"
    request methodGet "/authors_only" [auth] ""
      `shouldRespondWith` 200
@@ -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
@@ -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 :: SpecWith Application
-spec = around withApp $ describe "CORS" $ do
+spec =
  describe "CORS" $ do
    let preflightHeaders = [
          ("Accept", "*/*"),
          ("Origin", "http://example.com"),
@@ -22,7 +26,7 @@ spec = around withApp $ describe "CORS" $ do
          ("Host", "localhost:3000"),
          ("User-Agent", "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.9; rv:32.0) Gecko/20100101 Firefox/32.0"),
          ("Origin", "http://localhost:8000"),
-          ("Accept", "text/plain, */*; q=0.01"),
+          ("Accept", "text/csv, */*; q=0.01"),
          ("Accept-Language", "en-US,en;q=0.5"),
          ("Accept-Encoding", "gzip, deflate"),
          ("Referer", "http://localhost:8000/"),
@@ -41,7 +45,7 @@ spec = around withApp $ describe "CORS" $ do
            "true"
          respHeaders `shouldSatisfy` matchHeader
            "Access-Control-Allow-Methods"
-            "GET, POST, PUT, PATCH, DELETE, OPTIONS, HEAD"
+            "GET, POST, PATCH, DELETE, OPTIONS, HEAD"
          respHeaders `shouldSatisfy` matchHeader
            "Access-Control-Allow-Headers"
            "Authentication, Foo, Bar, Accept, Accept-Language, Content-Language"
@@ -53,10 +57,18 @@ spec = around withApp $ describe "CORS" $ do
        r <- request methodOptions "/" preflightHeaders ""
        liftIO $ simpleBody r `shouldBe` ""
    describe "regular request" $
      it "exposes necesssary response headers" $ do
        r <- request methodGet "/items" [("Origin", "http://example.com")] ""
        liftIO $ simpleHeaders r `shouldSatisfy` matchHeader
          "Access-Control-Expose-Headers"
          "Content-Encoding, Content-Location, Content-Range, Content-Type, \
            \Date, Location, Server, Transfer-Encoding, Range-Unit"
    describe "postflight request" $
      it "allows INFO body through even with CORS request headers present" $ do
        r <- request methodOptions "/items" normalCors ""
        liftIO $ do
          simpleHeaders r `shouldSatisfy` matchHeader
            "Access-Control-Allow-Origin" "\\*"
-          simpleBody r `shouldSatisfy` not . BL.null
+          simpleBody r `shouldSatisfy` BL.null
@@ -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
+import Protolude hiding (get)
-spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items")
+
-  . around withApp $
+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 {
+          `shouldRespondWith` ""
-            matchBody    = Nothing
+          { matchStatus  = 204
-          , 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 {
+          `shouldRespondWith` [str|[{"id":15}]|]
-            matchBody    = Just "[{\"id\":15}]"
+          { matchStatus  = 200
-          , matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-0/*"]
          , matchHeaders = ["Content-Range" <:> "0-0/1"]
          }
-    context "known route, unknown record" $
+    context "known route, no records matched" $
-      it "fails with 404" $
+      it "includes [] body if return=rep" $
-        request methodDelete "/items?id=eq.101" [] "" `shouldRespondWith` 404
+        request methodDelete "/items?id=eq.101"
          [("Prefer", "return=representation")] ""
          `shouldRespondWith` "[]"
          { matchStatus  = 200
          , matchHeaders = ["Content-Range" <:> "*/*"]
          }
    context "totally unknown route" $
      it "fails with 404" $
@@ -1,37 +1,88 @@
 {-# LANGUAGE QuasiQuotes #-}
 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
+import Protolude hiding (get)
-spec = afterAll_ resetDb $ around withApp $ do
+
 spec :: SpecWith Application
 spec = do
  describe "Posting new record" $ do
-    after_ (clearTable "menagerie") . it "accepts disparate json types" $ do
+    context "disparate json types" $ do
-      p <- post "/menagerie"
+      it "accepts disparate json types" $ do
-        [json| {
+        p <- post "/menagerie"
-          "integer": 13, "double": 3.14159, "varchar": "testing!"
+          [json| {
-        , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+            "integer": 13, "double": 3.14159, "varchar": "testing!"
-        , "enum": "foo"
+          , "boolean": false, "date": "1900-01-01", "money": "$3.99"
-        } |]
+          , "enum": "foo"
-      liftIO $ do
+          } |]
-        simpleBody p `shouldBe` ""
+        liftIO $ do
-        simpleStatus p `shouldBe` created201
+          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" $
+        it "fails with 400 and error" $ do
-          post "/simple_pk" [json| { "extra":"foo"} |]
+          p <- post "/simple_pk" [json| { "extra":"foo"} |]
-            `shouldRespondWith` 400
+          liftIO $ do
            simpleStatus p `shouldBe` badRequest400
            isErrorFormat (simpleBody p) `shouldBe` True
-      context "into a table with no pk" . after_ (clearTable "no_pk") $
+      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
@@ -58,119 +111,259 @@ spec = afterAll_ resetDb $ around withApp $ do
            simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.foo&b=eq.bar"
            simpleStatus p `shouldBe` created201
-    context "with compound pk supplied" . after_ (clearTable "compound_pk") $
+        it "returns full details of inserted record if asked" $ do
-      it "builds response location header appropriately" $
+          p <- request methodPost "/no_pk"
-        post "/compound_pk" [json| { "k1":12, "k2":42 } |]
+                       [("Prefer", "return=representation")]
-          `shouldRespondWith` ResponseMatcher {
+                       [json| { "a":"bar", "b":"baz" } |]
-            matchBody    = Nothing,
+          liftIO $ do
-            matchStatus  = 201,
+            simpleBody p `shouldBe` [json| [{ "a":"bar", "b":"baz" }] |]
-            matchHeaders = ["Location" <:> "/compound_pk?k1=eq.12&k2=eq.42"]
+            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" }] |]
            simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=is.null&b=eq.foo"
            simpleStatus p `shouldBe` created201
    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" $
+      it "fails with 400 and error" $ do
-        post "/simple_pk" "}{ x = 2"
+        p <- post "/simple_pk" "}{ x = 2"
-          `shouldRespondWith` ResponseMatcher {
+        liftIO $ do
-            matchBody    = Just [json| {"message":"Failed to parse JSON payload. Failed reading: satisfy"} |]
+          simpleStatus p `shouldBe` badRequest400
-          , matchStatus  = 400
+          isErrorFormat (simpleBody p) `shouldBe` True
    context "with valid json payload" $
      it "succeeds and returns 201 created" $
        post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] `shouldRespondWith` 201
    context "attempting to insert a row with the same primary key" $
      it "fails returning a 409 Conflict" $
        post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] `shouldRespondWith` 409
    context "attempting to insert a row with conflicting unique constraint" $
      it "fails returning a 409 Conflict" $
        post "/withUnique"  [json| { "uni":"nodup", "extra":"e2" } |] `shouldRespondWith` 409
    context "jsonb" $ do
      it "serializes nested object" $ do
        let inserted = [json| { "data": { "foo":"bar" } } |]
            location = "/json?data=eq.%7B%22foo%22%3A%22bar%22%7D"
        request methodPost "/json"
                     [("Prefer", "return=representation")]
                     inserted
          `shouldRespondWith` [str|[{"data":{"foo":"bar"}}]|]
          { matchStatus  = 201
          , matchHeaders = ["Location" <:> location]
          }
      it "serializes nested array" $ do
        let inserted = [json| { "data": [1,2,3] } |]
            location = "/json?data=eq.%5B1%2C2%2C3%5D"
        request methodPost "/json"
                     [("Prefer", "return=representation")]
                     inserted
          `shouldRespondWith` [str|[{"data":[1,2,3]}]|]
          { matchStatus  = 201
          , matchHeaders = ["Location" <:> location]
          }
    context "empty object" $
      it "successfully populates table with all-default columns" $
        post "/items" "{}" `shouldRespondWith` ""
          { matchStatus  = 201
          , matchHeaders = []
          }
    context "table with limited privileges" $ do
      it "succeeds if correct select is applied" $
        request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")]
          [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` [str|[{"article_id":2,"user_id":1}]|]
          { matchStatus  = 201
          , matchHeaders = []
          }
      it "fails if more columns are selected" $
        request methodPost "/limited_article_stars?select=article_id,user_id,created_at" [("Prefer", "return=representation")]
          [json| {"article_id": 2, "user_id": 2} |] `shouldRespondWith`
          [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]
          { matchStatus  = 401
          , matchHeaders = []
          }
      it "fails if select is not specified" $
        request methodPost "/limited_article_stars" [("Prefer", "return=representation")]
          [json| {"article_id": 3, "user_id": 1} |] `shouldRespondWith` [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]
          { matchStatus  = 401
          , matchHeaders = []
          }
-  describe "Putting record" $ do
+  describe "CSV insert" $ do
-    context "to unkonwn uri" $
+    context "disparate csv types" $
-      it "gives a 404" $
+      it "succeeds with multipart response" $ do
-        request methodPut "/fake" []
+        pendingWith "Decide on what to do with CSV insert"
-          [json| { "real": false } |]
+        let inserted = [str|integer,double,varchar,boolean,date,money,enum
-            `shouldRespondWith` 404
+            |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
           }
-    context "to a known uri" $ do
+    context "requesting full representation" $ do
-      context "without a fully-specified primary key" $
+      it "returns full details of inserted record" $
-        it "is not an allowed operation" $
+        request methodPost "/no_pk"
-          request methodPut "/compound_pk?k1=eq.12" []
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"),  ("Prefer", "return=representation")]
-            [json| { "k1":12, "k2":42 } |]
+                     "a,b\nbar,baz"
-              `shouldRespondWith` 405
+          `shouldRespondWith` "a,b\nbar,baz"
          { matchStatus  = 201
          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",
                            "Location" <:> "/no_pk?a=eq.bar&b=eq.baz"]
          }
-      context "with a fully-specified primary key" $ do
+      it "can post nulls" $
        request methodPost "/no_pk"
                     [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
                     "a,b\nNULL,foo"
          `shouldRespondWith` "a,b\n,foo"
          { matchStatus  = 201
          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",
                            "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
          }
-        context "not specifying every column in the table" $
+      it "only returns the requested column header with its associated data" $
-          it "is rejected for lack of idempotence" $
+        request methodPost "/projects?select=id"
-            request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
-              [json| { "k1":12, "k2":42 } |]
+                     "id,name,client_id\n8,Xenix,1\n9,Windows NT,1"
-                `shouldRespondWith` 400
+          `shouldRespondWith` "id\n8\n9"
          { matchStatus  = 201
          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",
                            "Content-Range" <:> "*/*"]
          }
-        context "specifying every column in the table" . after_ (clearTable "compound_pk") $ do
+    context "with wrong number of columns" $
-          it "can create a new record" $ do
+      it "fails for too few" $ do
-            p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
+        p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
-                 [json| { "k1":12, "k2":42, "extra":3 } |]
+        liftIO $ do
-            liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
-              simpleBody p `shouldBe` ""
+          isErrorFormat (simpleBody p) `shouldBe` True
              simpleStatus p `shouldBe` status204
-            r <- get "/compound_pk?k1=eq.12&k2=eq.42"
+    context "with unicode values" $
-            let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK])
+      it "succeeds and returns usable location header" $ do
-            liftIO $ do
+        let payload = [json| { "a":"圍棋", "b":"￥" } |]
-              length rows `shouldBe` 1
+        p <- request methodPost "/no_pk"
-              let record = head rows
+                     [("Prefer", "return=representation")]
-              compoundK1 record `shouldBe` 12
+                     payload
-              compoundK2 record `shouldBe` 42
+        liftIO $ do
-              compoundExtra record `shouldBe` Just 3
+          simpleBody p `shouldBe` "["<>payload<>"]"
          simpleStatus p `shouldBe` created201
-          it "can update an existing record" $ do
+        let Just location = lookup hLocation $ simpleHeaders p
-            _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
+        r <- get location
-                 [json| { "k1":12, "k2":42, "extra":4 } |]
+        liftIO $ simpleBody r `shouldBe` "["<>payload<>"]"
            _ <- 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 } |]
            `shouldRespondWith` 404
    context "on an empty table" $
-      it "succeeds with no effect" $
+      it "indicates no records found to update" $
-        request methodPatch "/simple_pk" []
+        request methodPatch "/empty_table" []
          [json| { "extra":20 } |]
-            `shouldRespondWith` 204
+          `shouldRespondWith` ""
          { matchStatus  = 204,
            matchHeaders = ["Content-Range" <:> "*/*"]
          }
-    context "in a nonempty table" . before_ (clearTable "items" >> createItems 15) .
+    context "in a nonempty table" $ do
      after_ (clearTable "items") $ do
      it "can update a single item" $ do
        g <- get "/items?id=eq.42"
        liftIO $ simpleHeaders g
-          `shouldSatisfy` matchHeader "Content-Range" "\\*/0"
+          `shouldSatisfy` matchHeader "Content-Range" "\\*/\\*"
-        request methodPatch "/items?id=eq.1" []
+        p <- request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |]
-          [json| { "id":42 } |]
+        pure p `shouldRespondWith` ""
-            `shouldRespondWith` 204
+          { 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"
@@ -182,4 +375,97 @@ spec = afterAll_ resetDb $ around withApp $ do
          [json| { non_nullable_string: "c" } |]
        g <- get "/auto_incrementing_pk?non_nullable_string=eq.c"
        liftIO $ simpleHeaders g
-          `shouldSatisfy` matchHeader "Content-Range" "0-9/10"
+          `shouldSatisfy` matchHeader "Content-Range" "0-9/\\*"
      it "can set a column to NULL" $ do
        _ <- post "/no_pk" [json| { a: "keepme", b: "nullme" } |]
        _ <- request methodPatch "/no_pk?b=eq.nullme" [] [json| { b: null } |]
        get "/no_pk?a=eq.keepme" `shouldRespondWith`
          [json| [{ a: "keepme", b: null }] |]
          { matchHeaders = [matchContentTypeJson] }
      it "can set a json column to escaped value" $ do
        _ <- post "/json" [json| { data: {"escaped":"bar"} } |]
        request methodPatch "/json?data->>escaped=eq.bar"
                     [("Prefer", "return=representation")]
                     [json| { "data": { "escaped":" \"bar" } } |]
          `shouldRespondWith` [json| [{ "data": { "escaped":" \"bar" } }] |]
          { matchStatus  = 200
          , matchHeaders = []
          }
      it "can update based on a computed column" $
        request methodPatch
          "/items?always_true=eq.false"
          [("Prefer", "return=representation")]
          [json| { id: 100 } |]
          `shouldRespondWith` "[]"
          { matchStatus  = 200,
            matchHeaders = ["Content-Range" <:> "*/*"]
          }
      it "can provide a representation" $ do
        _ <- post "/items"
          [json| { id: 1 } |]
        request methodPatch
          "/items?id=eq.1"
          [("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.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
      _ <- 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"
        [ auth, ("Prefer", "return=representation") ]
        [json| { "secret": "nyancat" } |]
      liftIO $ do
        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") ]
        [json| { "secret": "lolcat", "owner": "hacker" } |]
      liftIO $ do
        simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|]
        simpleStatus p2 `shouldBe` created201
@@ -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.QaPPLWTuyydMu_q7H4noMT7Lk6P4muet1OpJXF6ofhc"
    request methodGet "/authors_only" [auth] ""
      `shouldRespondWith` 500
  it "behaves normally when user does not attempt auth" $
    request methodGet "/items" [] ""
      `shouldRespondWith` 200
@@ -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")]
@@ -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/*"]
        }
@@ -1,60 +1,851 @@
 module Feature.QuerySpec where
-import Test.Hspec
+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,simpleBody))
 import qualified Data.ByteString.Lazy as BL (empty)
 import SpecHelper
 import Text.Heredoc
 import Network.Wai (Application)
 import Protolude hiding (get)
 spec :: SpecWith Application
 spec = do
  describe "Querying a table with a column called count" $
    it "should not confuse count column with pg_catalog.count aggregate" $
      get "/has_count_column" `shouldRespondWith` 200
  describe "Querying a table with a column called t" $
    it "should not conflict with internal postgrest table alias" $
      get "/clashing_column?select=t" `shouldRespondWith` 200
 spec :: Spec
 spec = beforeAll (clearTable "items" >> createItems 15)
  . afterAll_ (clearTable "items") . around withApp $ do
  describe "Querying a nonexistent table" $
    it "causes a 404" $
      get "/faketable" `shouldRespondWith` 404
-  describe "Filtering response" $
+  describe "Filtering response" $ do
-    context "column equality" $
+    it "matches with equality" $
      get "/items?id=eq.5"
        `shouldRespondWith` [json| [{"id":5}] |]
        { matchHeaders = ["Content-Range" <:> "0-0/*"] }
    it "matches with equality using not operator" $
      get "/items?id=not.eq.5"
        `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
        { matchHeaders = ["Content-Range" <:> "0-13/*"] }
    it "matches with more than one condition using not operator" $
      get "/simple_pk?k=like.*yx&extra=not.eq.u" `shouldRespondWith` "[]"
    it "matches with inequality using not operator" $ do
      get "/items?id=not.lt.14&order=id.asc"
        `shouldRespondWith` [json| [{"id":14},{"id":15}] |]
        { matchHeaders = ["Content-Range" <:> "0-1/*"] }
      get "/items?id=not.gt.2&order=id.asc"
        `shouldRespondWith` [json| [{"id":1},{"id":2}] |]
        { matchHeaders = ["Content-Range" <:> "0-1/*"] }
    it "matches items IN" $
      get "/items?id=in.1,3,5"
        `shouldRespondWith` [json| [{"id":1},{"id":3},{"id":5}] |]
        { matchHeaders = ["Content-Range" <:> "0-2/*"] }
    it "matches items NOT IN" $
      get "/items?id=notin.2,4,6,7,8,9,10,11,12,13,14,15"
        `shouldRespondWith` [json| [{"id":1},{"id":3},{"id":5}] |]
        { matchHeaders = ["Content-Range" <:> "0-2/*"] }
    it "matches items NOT IN using not operator" $
      get "/items?id=not.in.2,4,6,7,8,9,10,11,12,13,14,15"
        `shouldRespondWith` [json| [{"id":1},{"id":3},{"id":5}] |]
        { matchHeaders = ["Content-Range" <:> "0-2/*"] }
    it "matches nulls using not operator" $
      get "/no_pk?a=not.is.null" `shouldRespondWith`
        [json| [{"a":"1","b":"0"},{"a":"2","b":"0"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "matches nulls in varchar and numeric fields alike" $ do
      get "/no_pk?a=is.null" `shouldRespondWith`
        [json| [{"a": null, "b": null}] |]
        { matchHeaders = [matchContentTypeJson] }
      get "/nullable_integer?a=is.null" `shouldRespondWith` [str|[{"a":null}]|]
    it "matches with like" $ do
      get "/simple_pk?k=like.*yx" `shouldRespondWith`
        [str|[{"k":"xyyx","extra":"u"}]|]
      get "/simple_pk?k=like.xy*" `shouldRespondWith`
        [str|[{"k":"xyyx","extra":"u"}]|]
      get "/simple_pk?k=like.*YY*" `shouldRespondWith`
        [str|[{"k":"xYYx","extra":"v"}]|]
    it "matches with like using not operator" $
      get "/simple_pk?k=not.like.*yx" `shouldRespondWith`
        [str|[{"k":"xYYx","extra":"v"}]|]
    it "matches with ilike" $ do
      get "/simple_pk?k=ilike.xy*&order=extra.asc" `shouldRespondWith`
        [str|[{"k":"xyyx","extra":"u"},{"k":"xYYx","extra":"v"}]|]
      get "/simple_pk?k=ilike.*YY*&order=extra.asc" `shouldRespondWith`
        [str|[{"k":"xyyx","extra":"u"},{"k":"xYYx","extra":"v"}]|]
    it "matches with ilike using not operator" $
      get "/simple_pk?k=not.ilike.xy*&order=extra.asc" `shouldRespondWith` "[]"
    it "matches with tsearch @@" $
      get "/tsearch?text_search_vector=@@.foo" `shouldRespondWith`
        [json| [{"text_search_vector":"'bar':2 'foo':1"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "matches with tsearch @@ using not operator" $
      get "/tsearch?text_search_vector=not.@@.foo" `shouldRespondWith`
        [json| [{"text_search_vector":"'baz':1 'qux':2"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "matches with computed column" $
      get "/items?always_true=eq.true&order=id.asc" `shouldRespondWith`
        [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "order by computed column" $
      get "/items?order=anti_id.desc" `shouldRespondWith`
        [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "matches filtering nested items 2" $
      get "/clients?select=id,projects{id,tasks2{id,name}}&projects.tasks.name=like.Design*"
        `shouldRespondWith` [json| {"message":"Could not find foreign keys between these entities, No relation found between projects and tasks2"}|]
        { matchStatus  = 400
        , matchHeaders = [matchContentTypeJson]
        }
    it "matches filtering nested items" $
      get "/clients?select=id,projects{id,tasks{id,name}}&projects.tasks.name=like.Design*" `shouldRespondWith`
        [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1,"name":"Design w7"}]},{"id":2,"tasks":[{"id":3,"name":"Design w10"}]}]},{"id":2,"projects":[{"id":3,"tasks":[{"id":5,"name":"Design IOS"}]},{"id":4,"tasks":[{"id":7,"name":"Design OSX"}]}]}]|]
    it "matches with @> operator" $
      get "/complex_items?select=id&arr_data=@>.{2}" `shouldRespondWith`
        [str|[{"id":2},{"id":3}]|]
    it "matches with <@ operator" $
      get "/complex_items?select=id&arr_data=<@.{1,2,4}" `shouldRespondWith`
        [str|[{"id":1},{"id":2}]|]
  describe "Shaping response with select parameter" $ do
    it "selectStar works in absense of parameter" $
      get "/complex_items?id=eq.3" `shouldRespondWith`
        [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|]
    it "dash `-` in column names is accepted" $
      get "/complex_items?id=eq.3&select=id,field-with_sep" `shouldRespondWith`
        [str|[{"id":3,"field-with_sep":1}]|]
    it "one simple column" $
      get "/complex_items?select=id" `shouldRespondWith`
        [json| [{"id":1},{"id":2},{"id":3}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "rename simple column" $
      get "/complex_items?id=eq.1&select=myId:id" `shouldRespondWith`
        [json| [{"myId":1}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "one simple column with casting (text)" $
      get "/complex_items?select=id::text" `shouldRespondWith`
        [json| [{"id":"1"},{"id":"2"},{"id":"3"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "rename simple column with casting" $
      get "/complex_items?id=eq.1&select=myId:id::text" `shouldRespondWith`
        [json| [{"myId":"1"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "json column" $
      get "/complex_items?id=eq.1&select=settings" `shouldRespondWith`
        [json| [{"settings":{"foo":{"int":1,"bar":"baz"}}}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "json subfield one level with casting (json)" $
      get "/complex_items?id=eq.1&select=settings->>foo::json" `shouldRespondWith`
        [json| [{"foo":{"int":1,"bar":"baz"}}] |] -- the value of foo here is of type "text"
        { matchHeaders = [matchContentTypeJson] }
    it "rename json subfield one level with casting (json)" $
      get "/complex_items?id=eq.1&select=myFoo:settings->>foo::json" `shouldRespondWith`
        [json| [{"myFoo":{"int":1,"bar":"baz"}}] |] -- the value of foo here is of type "text"
        { matchHeaders = [matchContentTypeJson] }
    it "fails on bad casting (data of the wrong format)" $
      get "/complex_items?select=settings->foo->>bar::integer"
        `shouldRespondWith` [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"baz\""} |]
        { matchStatus  = 400
        , matchHeaders = []
        }
    it "fails on bad casting (wrong cast type)" $
      get "/complex_items?select=id::fakecolumntype"
        `shouldRespondWith` [json| {"hint":null,"details":null,"code":"42704","message":"type \"fakecolumntype\" does not exist"} |]
        { matchStatus  = 400
        , matchHeaders = []
        }
    it "json subfield two levels (string)" $
      get "/complex_items?id=eq.1&select=settings->foo->>bar" `shouldRespondWith`
        [json| [{"bar":"baz"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "rename json subfield two levels (string)" $
      get "/complex_items?id=eq.1&select=myBar:settings->foo->>bar" `shouldRespondWith`
        [json| [{"myBar":"baz"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "json subfield two levels with casting (int)" $
      get "/complex_items?id=eq.1&select=settings->foo->>int::integer" `shouldRespondWith`
        [json| [{"int":1}] |] -- the value in the db is an int, but here we expect a string for now
        { matchHeaders = [matchContentTypeJson] }
    it "rename json subfield two levels with casting (int)" $
      get "/complex_items?id=eq.1&select=myInt:settings->foo->>int::integer" `shouldRespondWith`
        [json| [{"myInt":1}] |] -- the value in the db is an int, but here we expect a string for now
        { matchHeaders = [matchContentTypeJson] }
    it "requesting parents and children" $
      get "/projects?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
    it "embed data with two fk pointing to the same table" $
      get "/orders?id=eq.1&select=id, name, billing_address_id{id}, shipping_address_id{id}" `shouldRespondWith`
        [str|[{"id":1,"name":"order 1","billing_address_id":{"id":1},"shipping_address_id":{"id":2}}]|]
    it "requesting parents and children while renaming them" $
      get "/projects?id=eq.1&select=myId:id, name, project_client:client_id{*}, project_tasks:tasks{id, name}" `shouldRespondWith`
        [str|[{"myId":1,"name":"Windows 7","project_client":{"id":1,"name":"Microsoft"},"project_tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
    it "requesting parents two levels up while using FK to specify the link" $
      get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith`
        [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]
    it "requesting parents two levels up while using FK to specify the link (with rename)" $
      get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith`
        [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]
    it "requesting parents and filtering parent columns" $
      get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|]
    it "rows with missing parents are included" $
      get "/projects?id=in.1,5&select=id,clients{id}" `shouldRespondWith`
        [str|[{"id":1,"clients":{"id":1}},{"id":5,"clients":null}]|]
    it "rows with no children return [] instead of null" $
      get "/projects?id=in.5&select=id,tasks{id}" `shouldRespondWith`
        [str|[{"id":5,"tasks":[]}]|]
    it "requesting children 2 levels" $
      get "/clients?id=eq.1&select=id,projects{id,tasks{id}}" `shouldRespondWith`
        [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|]
    it "requesting many<->many relation" $
      get "/tasks?select=id,users{id}" `shouldRespondWith`
        [str|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|]
    it "requesting many<->many relation with rename" $
      get "/tasks?id=eq.1&select=id,theUsers:users{id}" `shouldRespondWith`
        [str|[{"id":1,"theUsers":[{"id":1},{"id":3}]}]|]
    it "requesting many<->many relation reverse" $
      get "/users?select=id,tasks{id}" `shouldRespondWith`
        [str|[{"id":1,"tasks":[{"id":1},{"id":2},{"id":3},{"id":4}]},{"id":2,"tasks":[{"id":5},{"id":6},{"id":7}]},{"id":3,"tasks":[{"id":1},{"id":5}]}]|]
    it "requesting parents and children on views" $
      get "/projects_view?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
    it "requesting parents and children on views with renamed keys" $
      get "/projects_view_alt?t_id=eq.1&select=t_id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
        [str|[{"t_id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
    it "requesting children with composite key" $
      get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments{content}" `shouldRespondWith`
        [str|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|]
    it "detect relations in views from exposed schema that are based on tables in private schema and have columns renames" $
      get "/articles?id=eq.1&select=id,articleStars{users{*}}" `shouldRespondWith`
        [str|[{"id":1,"articleStars":[{"users":{"id":1,"name":"Angela Martin"}},{"users":{"id":2,"name":"Michael Scott"}},{"users":{"id":3,"name":"Dwight Schrute"}}]}]|]
    it "can select by column name" $
      get "/projects?id=in.1,3&select=id,name,client_id,client_id{id,name}" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","client_id":1,"client_id":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client_id":{"id":2,"name":"Apple"}}]|]
    it "can select by column name sans id" $
      get "/projects?id=in.1,3&select=id,name,client_id,client{id,name}" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|]
    it "can detect fk relations through views to tables in the public schema" $
      get "/consumers_view?select=*,orders_view{*}" `shouldRespondWith` 200
      it "matches the predicate" $
        get "/items?id=eq.5"
          `shouldRespondWith` ResponseMatcher {
            matchBody    = Just "[{\"id\":5}]"
          , matchStatus  = 200
          , matchHeaders = ["Content-Range" <:> "0-0/1"]
          }
  describe "ordering response" $ do
    it "by a column asc" $
-      get "/items?id=lte.2&order=asc.id"
+      get "/items?id=lte.2&order=id.asc"
-        `shouldRespondWith` ResponseMatcher {
+        `shouldRespondWith` [json| [{"id":1},{"id":2}] |]
-          matchBody    = Just "[{\"id\":1},{\"id\":2}]"
+        { matchStatus  = 200
-        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/*"]
        , matchHeaders = ["Content-Range" <:> "0-1/2"]
        }
    it "by a column desc" $
-      get "/items?id=lte.2&order=desc.id"
+      get "/items?id=lte.2&order=id.desc"
-        `shouldRespondWith` ResponseMatcher {
+        `shouldRespondWith` [json| [{"id":2},{"id":1}] |]
-          matchBody    = Just "[{\"id\":2},{\"id\":1}]"
+        { matchStatus  = 200
-        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/*"]
        , matchHeaders = ["Content-Range" <:> "0-1/2"]
        }
    it "by a column with nulls first" $
      get "/no_pk?order=a.nullsfirst"
        `shouldRespondWith` [json| [{"a":null,"b":null},
                              {"a":"1","b":"0"},
                              {"a":"2","b":"0"}
                              ] |]
        { matchStatus = 200
        , matchHeaders = ["Content-Range" <:> "0-2/*"]
        }
    it "by a column asc with nulls last" $
      get "/no_pk?order=a.asc.nullslast"
        `shouldRespondWith` [json| [{"a":"1","b":"0"},
                              {"a":"2","b":"0"},
                              {"a":null,"b":null}] |]
        { matchStatus = 200
        , matchHeaders = ["Content-Range" <:> "0-2/*"]
        }
    it "by a column desc with nulls first" $
      get "/no_pk?order=a.desc.nullsfirst"
        `shouldRespondWith` [json| [{"a":null,"b":null},
                              {"a":"2","b":"0"},
                              {"a":"1","b":"0"}] |]
        { matchStatus = 200
        , matchHeaders = ["Content-Range" <:> "0-2/*"]
        }
    it "by a column desc with nulls last" $
      get "/no_pk?order=a.desc.nullslast"
        `shouldRespondWith` [json| [{"a":"2","b":"0"},
                              {"a":"1","b":"0"},
                              {"a":null,"b":null}] |]
        { matchStatus = 200
        , matchHeaders = ["Content-Range" <:> "0-2/*"]
        }
    it "by a json column property asc" $
      get "/json?order=data->>id.asc" `shouldRespondWith`
        [json| [{"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}, {"data": {"id": 3}}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "by a json column with two level property nulls first" $
      get "/json?order=data->foo->>bar.nullsfirst" `shouldRespondWith`
        [json| [{"data": {"id": 3}}, {"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "without other constraints" $
-      get "/items?order=asc.id" `shouldRespondWith` 200
+      get "/items?order=id.asc" `shouldRespondWith` 200
    it "ordering embeded entities" $
      get "/projects?id=eq.1&select=id, name, tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|]
    it "ordering embeded entities with alias" $
      get "/projects?id=eq.1&select=id, name, the_tasks:tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","the_tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|]
    it "ordering embeded entities, two levels" $
      get "/projects?id=eq.1&select=id, name, tasks{id, name, users{id, name}}&tasks.order=name.asc&tasks.users.order=name.desc" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7","users":[{"id":1,"name":"Angela Martin"}]},{"id":1,"name":"Design w7","users":[{"id":3,"name":"Dwight Schrute"},{"id":1,"name":"Angela Martin"}]}]}]|]
    it "ordering embeded parents does not break things" $
      get "/projects?id=eq.1&select=id, name, clients{id, name}&clients.order=name.asc" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"}}]|]
    it "ordering embeded parents does not break things when using ducktape names" $
      get "/projects?id=eq.1&select=id, name, client{id, name}&client.order=name.asc" `shouldRespondWith`
        [str|[{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}]|]
  describe "Accept headers" $ do
    it "should respond an unknown accept type with 415" $
      request methodGet "/simple_pk"
              (acceptHdrs "text/unknowntype") ""
        `shouldRespondWith` 415
    it "should respond correctly to */* in accept header" $
      request methodGet "/simple_pk"
              (acceptHdrs "*/*") ""
        `shouldRespondWith` 200
    it "*/* should rescue an unknown type" $
      request methodGet "/simple_pk"
              (acceptHdrs "text/unknowntype, */*") ""
        `shouldRespondWith` 200
    it "specific available preference should override */*" $ do
      r <- request methodGet "/simple_pk"
              (acceptHdrs "text/csv, */*") ""
      liftIO $ do
        let respHeaders = simpleHeaders r
        respHeaders `shouldSatisfy` matchHeader
          "Content-Type" "text/csv; charset=utf-8"
    it "honors client preference even when opposite of server preference" $ do
      r <- request methodGet "/simple_pk"
              (acceptHdrs "text/csv, application/json") ""
      liftIO $ do
        let respHeaders = simpleHeaders r
        respHeaders `shouldSatisfy` matchHeader
          "Content-Type" "text/csv; charset=utf-8"
    it "should respond correctly to multiple types in accept header" $
      request methodGet "/simple_pk"
              (acceptHdrs "text/unknowntype, text/csv") ""
        `shouldRespondWith` 200
    it "should respond with CSV to 'text/csv' request" $
      request methodGet "/simple_pk"
              (acceptHdrs "text/csv; version=1") ""
        `shouldRespondWith` "k,extra\nxyyx,u\nxYYx,v"
        { matchStatus  = 200
        , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
        }
  describe "Canonical location" $ do
    it "Sets Content-Location with alphabetized params" $
      get "/no_pk?b=eq.1&a=eq.1"
-        `shouldRespondWith` ResponseMatcher {
+        `shouldRespondWith` "[]"
-          matchBody    = Just "[]"
+        { matchStatus  = 200
        , matchStatus  = 200
        , matchHeaders = ["Content-Location" <:> "/no_pk?a=eq.1&b=eq.1"]
        }
-    it "Omits question mark when there are no params" $
+    it "Omits question mark when there are no params" $ do
-      get "/no_pk"
+      r <- get "/simple_pk"
-        `shouldRespondWith` ResponseMatcher {
+      liftIO $ do
-          matchBody    = Just "[]"
+        let respHeaders = simpleHeaders r
-        , matchStatus  = 200
+        respHeaders `shouldSatisfy` matchHeader
-        , matchHeaders = ["Content-Location" <:> "/no_pk"]
+          "Content-Location" "/simple_pk"
  describe "jsonb" $ do
    it "can filter by properties inside json column" $ do
      get "/json?data->foo->>bar=eq.baz" `shouldRespondWith`
        [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |]
        { matchHeaders = [matchContentTypeJson] }
      get "/json?data->foo->>bar=eq.fake" `shouldRespondWith`
        [json| [] |]
        { matchHeaders = [matchContentTypeJson] }
    it "can filter by properties inside json column using not" $
      get "/json?data->foo->>bar=not.eq.baz" `shouldRespondWith`
        [json| [] |]
        { matchHeaders = [matchContentTypeJson] }
    it "can filter by properties inside json column using ->>" $
      get "/json?data->>id=eq.1" `shouldRespondWith`
        [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |]
        { matchHeaders = [matchContentTypeJson] }
  describe "remote procedure call" $ do
    context "a proc that returns a set" $ do
      it "returns paginated results" $
        request methodPost "/rpc/getitemrange"
                (rangeHdrs (ByteRangeFromTo 0 0))  [json| { "min": 2, "max": 4 } |]
           `shouldRespondWith` [json| [{"id":3}] |]
            { matchStatus = 200
            , matchHeaders = ["Content-Range" <:> "0-0/*"]
            }
      it "includes total count if requested" $
        request methodPost "/rpc/getitemrange"
                (rangeHdrsWithCount (ByteRangeFromTo 0 0))
                [json| { "min": 2, "max": 4 } |]
           `shouldRespondWith` [json| [{"id":3}] |]
            { matchStatus = 206 -- it now knows the response is partial
            , matchHeaders = ["Content-Range" <:> "0-0/2"]
            }
      it "returns proper json" $
        post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`
          [json| [ {"id": 3}, {"id":4} ] |]
          { matchHeaders = [matchContentTypeJson] }
      it "returns CSV" $
        request methodPost "/rpc/getitemrange"
                (acceptHdrs "text/csv")
                [json| { "min": 2, "max": 4 } |]
           `shouldRespondWith` "id\n3\n4"
            { matchStatus = 200
            , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]
            }
    context "unknown function" $
      it "returns 404" $
        post "/rpc/fakefunc" [json| {} |] `shouldRespondWith` 404
    context "shaping the response returned by a proc" $ do
      it "returns a project" $
        post "/rpc/getproject" [json| { "id": 1} |] `shouldRespondWith`
          [str|[{"id":1,"name":"Windows 7","client_id":1}]|]
      it "can filter proc results" $
        post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id" [json| {} |] `shouldRespondWith`
          [json|[{"id":2},{"id":3},{"id":4}]|]
          { matchHeaders = [matchContentTypeJson] }
      it "can limit proc results" $
        post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id?limit=2&offset=1" [json| {} |]
          `shouldRespondWith` [json|[{"id":3},{"id":4}]|]
             { matchStatus = 200
             , matchHeaders = ["Content-Range" <:> "1-2/*"]
             }
      it "select works on the first level" $
        post "/rpc/getproject?select=id,name" [json| { "id": 1} |] `shouldRespondWith`
          [str|[{"id":1,"name":"Windows 7"}]|]
    context "foreign entities embedding" $ do
      it "can embed if related tables are in the exposed schema" $
        post "/rpc/getproject?select=id,name,client{id},tasks{id}" [json| { "id": 1} |] `shouldRespondWith`
          [str|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|]
      it "cannot embed if the related table is not in the exposed schema" $
        post "/rpc/single_article?select=*,article_stars{*}" [json|{ "id": 1}|]
          `shouldRespondWith` 400
      it "can embed if the related tables are in a hidden schema but exposed as views" $
        post "/rpc/single_article?select=id,articleStars{userId}" [json|{ "id": 2}|]
          `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|]
          { matchHeaders = [matchContentTypeJson] }
    context "a proc that returns an empty rowset" $
      it "returns empty json array" $
        post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith`
          [json| [] |]
          { matchHeaders = [matchContentTypeJson] }
    context "proc return types" $ do
      context "returns text" $ do
        it "returns proper json" $
          post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith`
            [json|"Hello, world"|]
            { matchHeaders = [matchContentTypeJson] }
        it "can handle unicode" $
          post "/rpc/sayhello" [json| { "name": "￥" } |] `shouldRespondWith`
            [json|"Hello, ￥"|]
            { matchHeaders = [matchContentTypeJson] }
      it "returns enum value" $
        post "/rpc/ret_enum" [json|{ "val": "foo" }|] `shouldRespondWith`
          [json|"foo"|]
          { matchHeaders = [matchContentTypeJson] }
      it "returns domain value" $
        post "/rpc/ret_domain" [json|{ "val": "8" }|] `shouldRespondWith`
          [json|8|]
          { matchHeaders = [matchContentTypeJson] }
      it "returns range" $
        post "/rpc/ret_range" [json|{ "low": 10, "up": 20 }|] `shouldRespondWith`
          [json|"[10,20)"|]
          { matchHeaders = [matchContentTypeJson] }
      it "returns row of scalars" $
        post "/rpc/ret_scalars" [json|{}|] `shouldRespondWith`
          [json|[{"a":"scalars", "b":"foo", "c":1, "d":"[10,20)"}]|]
          { matchHeaders = [matchContentTypeJson] }
      it "returns composite type in exposed schema" $
        post "/rpc/ret_point_2d" [json|{}|] `shouldRespondWith`
          [json|[{"x": 10, "y": 5}]|]
          { matchHeaders = [matchContentTypeJson] }
      it "cannot return composite type in hidden schema" $
        post "/rpc/ret_point_3d" [json|{}|] `shouldRespondWith` 401
      it "returns single row from table" $
        post "/rpc/single_article?select=id" [json|{"id": 2}|] `shouldRespondWith`
          [json|[{"id": 2}]|]
          { matchHeaders = [matchContentTypeJson] }
      it "returns null for void" $
        post "/rpc/ret_void" [json|{}|] `shouldRespondWith`
          [json|null|]
          { matchHeaders = [matchContentTypeJson] }
    context "improper input" $ do
      it "rejects unknown content type even if payload is good" $
        request methodPost "/rpc/sayhello"
          (acceptHdrs "audio/mpeg3") [json| { "name": "world" } |]
            `shouldRespondWith` 415
      it "rejects malformed json payload" $ do
        p <- request methodPost "/rpc/sayhello"
          (acceptHdrs "application/json") "sdfsdf"
        liftIO $ do
          simpleStatus p `shouldBe` badRequest400
          isErrorFormat (simpleBody p) `shouldBe` True
      it "treats simple plpgsql raise as invalid input" $ do
        p <- post "/rpc/problem" "{}"
        liftIO $ do
          simpleStatus p `shouldBe` badRequest400
          isErrorFormat (simpleBody p) `shouldBe` True
    context "unsupported verbs" $ do
      it "DELETE fails" $
        request methodDelete "/rpc/sayhello" [] ""
          `shouldRespondWith` 405
      it "PATCH fails" $
        request methodPatch "/rpc/sayhello" [] ""
          `shouldRespondWith` 405
      it "OPTIONS fails" $
        -- TODO: should return info about the function
        request methodOptions "/rpc/sayhello" [] ""
          `shouldRespondWith` 405
      it "GET fails with 405 on unknown procs" $
        -- TODO: should this be 404?
        get "/rpc/fake" `shouldRespondWith` 405
      it "GET with 405 on known procs" $
        get "/rpc/sayhello" `shouldRespondWith` 405
    it "executes the proc exactly once per request" $ do
      post "/rpc/callcounter" [json| {} |] `shouldRespondWith`
        [json|1|]
        { matchHeaders = [matchContentTypeJson] }
      post "/rpc/callcounter" [json| {} |] `shouldRespondWith`
        [json|2|]
        { matchHeaders = [matchContentTypeJson] }
    context "expects a single json object" $ do
      it "does not expand posted json into parameters" $
        request methodPost "/rpc/singlejsonparam"
          [("Prefer","params=single-object")] [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] `shouldRespondWith`
          [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |]
          { matchHeaders = [matchContentTypeJson] }
      it "accepts parameters from an html form" $
        request methodPost "/rpc/singlejsonparam"
          [("Prefer","params=single-object"),("Content-Type", "application/x-www-form-urlencoded")]
          ("integer=7&double=2.71828&varchar=forms+are+fun&" <>
           "boolean=false&date=1900-01-01&money=$3.99&enum=foo") `shouldRespondWith`
          [json| { "integer": "7", "double": "2.71828", "varchar" : "forms are fun"
                 , "boolean":"false", "date":"1900-01-01", "money":"$3.99", "enum":"foo" } |]
                 { matchHeaders = [matchContentTypeJson] }
    context "a proc that receives no parameters" $
      it "interprets empty string as empty json object on a post request" $
        post "/rpc/noparamsproc" BL.empty `shouldRespondWith`
          [json| "Return value of no parameters procedure." |]
          { matchHeaders = [matchContentTypeJson] }
  describe "weird requests" $ do
    it "can query as normal" $ do
      get "/Escap3e;" `shouldRespondWith`
        [json| [{"so6meIdColumn":1},{"so6meIdColumn":2},{"so6meIdColumn":3},{"so6meIdColumn":4},{"so6meIdColumn":5}] |]
        { matchHeaders = [matchContentTypeJson] }
      get "/ghostBusters" `shouldRespondWith`
        [json| [{"escapeId":1},{"escapeId":3},{"escapeId":5}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "fails if an operator is not given" $
      get "/ghostBusters?id=0" `shouldRespondWith` [json| {"details":"unexpected \"0\" expecting \"not\" or operator (eq, gt, ...)","message":"\"failed to parse filter (0)\" (line 1, column 1)"} |]
        { matchStatus  = 400
        , matchHeaders = [matchContentTypeJson]
        }
    it "will embed a collection" $
      get "/Escap3e;?select=ghostBusters{*}" `shouldRespondWith`
        [json| [{"ghostBusters":[{"escapeId":1}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":3}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":5}]}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "will embed using a column" $
      get "/ghostBusters?select=escapeId{*}" `shouldRespondWith`
        [json| [{"escapeId":{"so6meIdColumn":1}},{"escapeId":{"so6meIdColumn":3}},{"escapeId":{"so6meIdColumn":5}}] |]
        { matchHeaders = [matchContentTypeJson] }
  describe "binary output" $ do
    it "can query if a single column is selected" $
      request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") ""
        `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"
        { matchStatus = 200
        , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]
        }
    it "fails if a single column is not selected" $ do
      request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") ""
        `shouldRespondWith` 406
      request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") ""
        `shouldRespondWith` 406
      request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") ""
        `shouldRespondWith` 406
    it "concatenates results if more than one row is returned" $
      request methodGet "/images_base64?select=img&name=in.A.png,B.png" (acceptHdrs "application/octet-stream") ""
        `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="
        { matchStatus = 200
        , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]
        }
  describe "HTTP request env vars" $ do
    it "custom header is set" $
      request methodPost "/rpc/get_guc_value"
                [("Custom-Header", "test")]
          [json| { "name": "request.header.custom-header" } |]
          `shouldRespondWith`
          [str|"test"|]
          { matchStatus  = 200
          , matchHeaders = [ matchContentTypeJson ]
          }
    it "standard header is set" $
      request methodPost "/rpc/get_guc_value"
                [("Origin", "http://example.com")]
          [json| { "name": "request.header.origin" } |]
          `shouldRespondWith`
          [str|"http://example.com"|]
          { matchStatus  = 200
          , matchHeaders = [ matchContentTypeJson ]
          }
    it "current role is available as GUC claim" $
      request methodPost "/rpc/get_guc_value" []
          [json| { "name": "request.jwt.claim.role" } |]
          `shouldRespondWith`
          [str|"postgrest_test_anonymous"|]
          { matchStatus  = 200
          , matchHeaders = [ matchContentTypeJson ]
          }
    it "single cookie ends up as claims" $
      request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue")]
        [json| {"name":"request.cookie.acookie"} |]
          `shouldRespondWith`
          [str|"cookievalue"|]
          { matchStatus = 200
          , matchHeaders = []
          }
    it "multiple cookies ends up as claims" $
      request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue;secondcookie=anothervalue")]
        [json| {"name":"request.cookie.secondcookie"} |]
          `shouldRespondWith`
          [str|"anothervalue"|]
          { matchStatus = 200
          , matchHeaders = []
          }
  describe "values with quotes in IN and NOTIN operators" $ do
    it "succeeds when only quoted values are present" $ do
      get "/w_or_wo_comma_names?name=in.\"Hebdon, John\"" `shouldRespondWith`
        [json| [{"name":"Hebdon, John"}] |]
        { matchHeaders = [matchContentTypeJson] }
      get "/w_or_wo_comma_names?name=in.\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\"" `shouldRespondWith`
        [json| [{"name":"Hebdon, John"},{"name":"Williams, Mary"},{"name":"Smith, Joseph"}] |]
        { matchHeaders = [matchContentTypeJson] }
      get "/w_or_wo_comma_names?name=notin.\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\"" `shouldRespondWith`
        [json| [{"name":"David White"},{"name":"Larry Thompson"}] |]
        { matchHeaders = [matchContentTypeJson] }
      get "/w_or_wo_comma_names?name=not.in.\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\"" `shouldRespondWith`
        [json| [{"name":"David White"},{"name":"Larry Thompson"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "succeeds w/ and w/o quoted values" $ do
      get "/w_or_wo_comma_names?name=in.David White,\"Hebdon, John\"" `shouldRespondWith`
        [json| [{"name":"Hebdon, John"},{"name":"David White"}] |]
        { matchHeaders = [matchContentTypeJson] }
      get "/w_or_wo_comma_names?name=not.in.\"Hebdon, John\",Larry Thompson,\"Smith, Joseph\"" `shouldRespondWith`
        [json| [{"name":"Williams, Mary"},{"name":"David White"}] |]
        { matchHeaders = [matchContentTypeJson] }
      get "/w_or_wo_comma_names?name=notin.\"Hebdon, John\",David White,\"Williams, Mary\",Larry Thompson" `shouldRespondWith`
        [json| [{"name":"Smith, Joseph"}] |]
        { matchHeaders = [matchContentTypeJson] }
    it "checks well formed quoted values" $ do
      get "/w_or_wo_comma_names?name=in.\"\"Hebdon, John\"" `shouldRespondWith`
        [json| [] |] { matchHeaders = [matchContentTypeJson] }
      get "/w_or_wo_comma_names?name=in.\"\"Hebdon, John\"\"Mary" `shouldRespondWith`
        [json| [] |] { matchHeaders = [matchContentTypeJson] }
      get "/w_or_wo_comma_names?name=in.Williams\"Hebdon, John\"" `shouldRespondWith`
        [json| [] |] { matchHeaders = [matchContentTypeJson] }
  describe "IN and NOT IN empty set" $ do
    context "returns an empty result for IN when no value is present" $ do
      it "works for integer" $
        get "/items_with_different_col_types?int_data=in." `shouldRespondWith`
          [json| [] |] { matchHeaders = [matchContentTypeJson] }
      it "works for text" $
        get "/items_with_different_col_types?text_data=in." `shouldRespondWith`
          [json| [] |] { matchHeaders = [matchContentTypeJson] }
      it "works for bool" $
        get "/items_with_different_col_types?bool_data=in." `shouldRespondWith`
          [json| [] |] { matchHeaders = [matchContentTypeJson] }
      it "works for bytea" $
        get "/items_with_different_col_types?bin_data=in." `shouldRespondWith`
          [json| [] |] { matchHeaders = [matchContentTypeJson] }
      it "works for char" $
        get "/items_with_different_col_types?char_data=in." `shouldRespondWith`
          [json| [] |] { matchHeaders = [matchContentTypeJson] }
      it "works for date" $
        get "/items_with_different_col_types?date_data=in." `shouldRespondWith`
          [json| [] |] { matchHeaders = [matchContentTypeJson] }
      it "works for real" $
        get "/items_with_different_col_types?real_data=in." `shouldRespondWith`
          [json| [] |] { matchHeaders = [matchContentTypeJson] }
      it "works for time" $
        get "/items_with_different_col_types?time_data=in." `shouldRespondWith`
          [json| [] |] { matchHeaders = [matchContentTypeJson] }
    it "returns all results for notin when no value is present" $
      get "/items_with_different_col_types?int_data=notin.&select=int_data" `shouldRespondWith`
        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }
    it "returns all results for not.in when no value is present" $
      get "/items_with_different_col_types?int_data=not.in.&select=int_data" `shouldRespondWith`
        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }
    it "returns an empty result ignoring spaces" $
      get "/items_with_different_col_types?int_data=in.    " `shouldRespondWith`
        [json| [] |] { matchHeaders = [matchContentTypeJson] }
    it "only returns an empty result set if the in value is empty" $
      get "/items_with_different_col_types?int_data=in. ,3,4" `shouldRespondWith` 400
    it "returns empty result when the in value is empty between parentheses" $
      get "/items_with_different_col_types?int_data=in.()" `shouldRespondWith`
        [json| [] |] { matchHeaders = [matchContentTypeJson] }
    it "returns all results when the notin value is empty between parentheses" $ do
      get "/items_with_different_col_types?int_data=notin.()&select=int_data" `shouldRespondWith`
        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }
      get "/items_with_different_col_types?int_data=not.in.()&select=int_data" `shouldRespondWith`
        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }
  describe "Transition to url safe characters" $ do
    context "top level in operator" $ do
      it "works with parentheses" $
        get "/entities?id=in.(1,2,3)&select=id" `shouldRespondWith`
          [json| [{"id": 1}, {"id": 2}, {"id": 3}] |] { matchHeaders = [matchContentTypeJson] }
      it "works without parentheses" $
        get "/entities?id=in.1,2,3&select=id" `shouldRespondWith`
          [json| [{"id": 1}, {"id": 2}, {"id": 3}] |] { matchHeaders = [matchContentTypeJson] }
    context "select query param" $ do
      it "works with parentheses" $
        get "/entities?id=eq.2&select=id,child_entities(id)" `shouldRespondWith`
          [json| [{"id": 2, "child_entities": [{"id": 3}]}] |] { matchHeaders = [matchContentTypeJson] }
      it "works with brackets" $
        get "/entities?id=eq.2&select=id,child_entities{id}" `shouldRespondWith`
          [json| [{"id": 2, "child_entities": [{"id": 3}]}] |] { matchHeaders = [matchContentTypeJson] }
@@ -2,21 +2,169 @@ module Feature.RangeSpec where
 import Test.Hspec
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
 import qualified Data.ByteString.Lazy         as BL
 import SpecHelper
 import Text.Heredoc
 import Network.Wai (Application)
 import Protolude hiding (get)
 defaultRange :: BL.ByteString
 defaultRange = [json| { "min": 0, "max": 15 } |]
 emptyRange :: BL.ByteString
 emptyRange = [json| { "min": 2, "max": 2 } |]
 spec :: SpecWith Application
 spec = do
  describe "POST /rpc/getitemrange" $ do
    context "without range headers" $ do
      context "with response under server size limit" $
        it "returns whole range with status 200" $
           post "/rpc/getitemrange" defaultRange `shouldRespondWith` 200
      context "when I don't want the count" $ do
        it "returns range Content-Range with */* for empty range" $
          request methodPost "/rpc/getitemrange" [] emptyRange
            `shouldRespondWith` [json| [] |] {matchHeaders = ["Content-Range" <:> "*/*"]}
        it "returns range Content-Range with range/*" $
          request methodPost "/rpc/getitemrange" [] defaultRange
            `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
            { matchHeaders = ["Content-Range" <:> "0-14/*"] }
    context "with range headers" $ do
      context "of acceptable range" $ do
        it "succeeds with partial content" $ do
          r <- request methodPost  "/rpc/getitemrange"
                       (rangeHdrs $ ByteRangeFromTo 0 1) defaultRange
          liftIO $ do
            simpleHeaders r `shouldSatisfy`
              matchHeader "Content-Range" "0-1/*"
            simpleStatus r `shouldBe` ok200
        it "understands open-ended ranges" $
          request methodPost "/rpc/getitemrange"
                  (rangeHdrs $ ByteRangeFrom 0) defaultRange
            `shouldRespondWith` 200
        it "returns an empty body when there are no results" $
          request methodPost "/rpc/getitemrange"
                  (rangeHdrs $ ByteRangeFromTo 0 1) emptyRange
            `shouldRespondWith` "[]"
            { matchStatus  = 200
            , matchHeaders = ["Content-Range" <:> "*/*"]
            }
        it "allows one-item requests" $ do
          r <- request methodPost  "/rpc/getitemrange"
                       (rangeHdrs $ ByteRangeFromTo 0 0) defaultRange
          liftIO $ do
            simpleHeaders r `shouldSatisfy`
              matchHeader "Content-Range" "0-0/*"
            simpleStatus r `shouldBe` ok200
        it "handles ranges beyond collection length via truncation" $ do
          r <- request methodPost  "/rpc/getitemrange"
                       (rangeHdrs $ ByteRangeFromTo 10 100) defaultRange
          liftIO $ do
            simpleHeaders r `shouldSatisfy`
              matchHeader "Content-Range" "10-14/*"
            simpleStatus r `shouldBe` ok200
      context "of invalid range" $ do
        it "fails with 416 for offside range" $
          request methodPost  "/rpc/getitemrange"
                  (rangeHdrs $ ByteRangeFromTo 1 0) emptyRange
            `shouldRespondWith` 416
        it "refuses a range with nonzero start when there are no items" $
          request methodPost "/rpc/getitemrange"
                  (rangeHdrsWithCount $ ByteRangeFromTo 1 2) emptyRange
            `shouldRespondWith` "[]"
            { matchStatus  = 416
            , matchHeaders = ["Content-Range" <:> "*/0"]
            }
        it "refuses a range requesting start past last item" $
          request methodPost "/rpc/getitemrange"
                  (rangeHdrsWithCount $ ByteRangeFromTo 100 199) defaultRange
            `shouldRespondWith` "[]"
            { matchStatus  = 416
            , matchHeaders = ["Content-Range" <:> "*/15"]
            }
 spec :: Spec
 spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable "items")
  . around withApp $
  describe "GET /items" $ do
-
+    context "without range headers" $ do
    context "without range headers" $
      context "with response under server size limit" $
        it "returns whole range with status 200" $
          get "/items" `shouldRespondWith` 200
      context "when I don't want the count" $ do
        it "returns range Content-Range with /*" $
          request methodGet "/menagerie"
                  [("Prefer", "count=none")] ""
            `shouldRespondWith` "[]"
            { matchStatus  = 200
            , matchHeaders = ["Content-Range" <:> "*/*"]
            }
        it "returns range Content-Range with range/*" $
          request methodGet "/items?order=id"
                  [("Prefer", "count=none")] ""
            `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
            { matchHeaders = ["Content-Range" <:> "0-14/*"] }
        it "returns range Content-Range with range/* even using other filters" $
          request methodGet "/items?id=eq.1&order=id"
                  [("Prefer", "count=none")] ""
            `shouldRespondWith` [json| [{"id":1}] |]
            { matchHeaders = ["Content-Range" <:> "0-0/*"] }
    context "with limit/offset parameters" $ do
      it "no parameters return everything" $
        get "/items?select=id&order=id.asc"
          `shouldRespondWith`
          [str|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]
          { matchStatus  = 200
          , matchHeaders = ["Content-Range" <:> "0-14/*"]
          }
      it "top level limit with parameter" $
        get "/items?select=id&order=id.asc&limit=3"
          `shouldRespondWith` [str|[{"id":1},{"id":2},{"id":3}]|]
          { matchStatus  = 200
          , matchHeaders = ["Content-Range" <:> "0-2/*"]
          }
      it "headers override get parameters" $
        request methodGet  "/items?select=id&order=id.asc&limit=3"
                     (rangeHdrs $ ByteRangeFromTo 0 1) ""
          `shouldRespondWith` [str|[{"id":1},{"id":2}]|]
          { matchStatus  = 200
          , matchHeaders = ["Content-Range" <:> "0-1/*"]
          }
      it "limit works on all levels" $
        get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=2&projects.tasks.order=id.asc&projects.tasks.limit=1"
          `shouldRespondWith`
          [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1}]},{"id":2,"tasks":[{"id":3}]}]}]|]
          { matchStatus  = 200
          , matchHeaders = ["Content-Range" <:> "0-0/*"]
          }
      it "limit and offset works on first level" $
        get "/items?select=id&order=id.asc&limit=3&offset=2"
          `shouldRespondWith` [str|[{"id":3},{"id":4},{"id":5}]|]
          { matchStatus  = 200
          , matchHeaders = ["Content-Range" <:> "2-4/*"]
          }
    context "with range headers" $ do
      context "of acceptable range" $ do
@@ -25,8 +173,8 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
                       (rangeHdrs $ ByteRangeFromTo 0 1) ""
          liftIO $ do
            simpleHeaders r `shouldSatisfy`
-              matchHeader "Content-Range" "0-1/15"
+              matchHeader "Content-Range" "0-1/*"
-            simpleStatus r `shouldBe` partialContent206
+            simpleStatus r `shouldBe` ok200
        it "understands open-ended ranges" $
          request methodGet "/items"
@@ -36,10 +184,9 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
        it "returns an empty body when there are no results" $
          request methodGet "/menagerie"
                  (rangeHdrs $ ByteRangeFromTo 0 1) ""
-            `shouldRespondWith` ResponseMatcher {
+            `shouldRespondWith` "[]"
-              matchBody    = Just "[]"
+            { matchStatus  = 200
-            , matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "*/*"]
            , matchHeaders = ["Content-Range" <:> "*/0"]
            }
        it "allows one-item requests" $ do
@@ -47,16 +194,16 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
                       (rangeHdrs $ ByteRangeFromTo 0 0) ""
          liftIO $ do
            simpleHeaders r `shouldSatisfy`
-              matchHeader "Content-Range" "0-0/15"
+              matchHeader "Content-Range" "0-0/*"
-            simpleStatus r `shouldBe` partialContent206
+            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"
+              matchHeader "Content-Range" "10-14/*"
-            simpleStatus r `shouldBe` partialContent206
+            simpleStatus r `shouldBe` ok200
      context "of invalid range" $ do
        it "fails with 416 for offside range" $
@@ -66,18 +213,16 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
        it "refuses a range with nonzero start when there are no items" $
          request methodGet "/menagerie"
-                  (rangeHdrs $ ByteRangeFromTo 1 2) ""
+                  (rangeHdrsWithCount $ ByteRangeFromTo 1 2) ""
-            `shouldRespondWith` ResponseMatcher {
+            `shouldRespondWith` "[]"
-              matchBody    = Nothing
+            { matchStatus  = 416
            , matchStatus  = 416
            , matchHeaders = ["Content-Range" <:> "*/0"]
            }
        it "refuses a range requesting start past last item" $
          request methodGet "/items"
-                  (rangeHdrs $ ByteRangeFromTo 100 199) ""
+                  (rangeHdrsWithCount $ ByteRangeFromTo 100 199) ""
-            `shouldRespondWith` ResponseMatcher {
+            `shouldRespondWith` "[]"
-              matchBody    = Nothing
+            { matchStatus  = 416
            , matchStatus  = 416
            , matchHeaders = ["Content-Range" <:> "*/15"]
            }
@@ -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"}]|]
@@ -1,189 +1,99 @@
 {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
 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
+import Protolude hiding (get)
 spec = around withApp $ do
  describe "GET /" $ do
    it "lists views in schema" $
      request methodGet "/" [] ""
        `shouldRespondWith` [json| [
          {"schema":"1","name":"auto_incrementing_pk","insertable":true}
        , {"schema":"1","name":"compound_pk","insertable":true}
        , {"schema":"1","name":"has_fk","insertable":true}
        , {"schema":"1","name":"items","insertable":true}
        , {"schema":"1","name":"menagerie","insertable":true}
        , {"schema":"1","name":"no_pk","insertable":true}
        , {"schema":"1","name":"simple_pk","insertable":true}
        ] |]
        {matchStatus = 200}
-    it "lists only views user has permission to see" $ do
+spec :: SpecWith Application
-      _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
+spec = do
      let auth = authHeader "jdoe" "1234"
-      request methodGet "/" [auth] ""
+  describe "OpenAPI" $ do
-        `shouldRespondWith` [json| [
+    it "root path returns a valid openapi spec" $
-            {"schema":"1","name":"authors_only","insertable":true}
+      validateOpenApiResponse [("Accept", "application/openapi+json")]
        ] |]
        {matchStatus = 200}
    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
+    describe "RPC" $
    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
          }
        ]
      }
      |]
-    it "includes foreign key data" $ do
+      it "includes a representative function with parameters" $ do
-      pendingWith "have to resolve issue #107"
+        r <- simpleBody <$> get "/"
        let ref = r ^? key "paths" . key "/rpc/varied_arguments"
                     . key "post"  . key "parameters"
                     . nth 1       . key "schema"
                     . key "$ref"  . _String
            args = r ^? key "definitions" . key "(rpc) varied_arguments"
-      request methodOptions "/has_fk" [] ""
+        liftIO $ do
-        `shouldRespondWith` [json|
+          ref `shouldBe` Just "#/definitions/(rpc) varied_arguments"
-      {
+          args `shouldBe` Just
-        "pkey": ["id"],
+            [aesonQQ|
-        "columns":[
+              {
-          {
+                "required": [
-            "default": "nextval('\"1\".has_fk_id_seq'::regclass)",
+                  "double",
-            "precision": 64,
+                  "varchar",
-            "updatable": true,
+                  "boolean",
-            "schema": "1",
+                  "date",
-            "name": "id",
+                  "money",
-            "type": "bigint",
+                  "enum"
-            "maxLen": null,
+                ],
-            "nullable": false,
+                "properties": {
-            "position": 1,
+                  "double": {
-            "enum": [],
+                    "format": "double precision",
-            "references": null
+                    "type": "string"
-          }, {
+                  },
-            "default": null,
+                  "varchar": {
-            "precision": 32,
+                    "format": "character varying",
-            "updatable": true,
+                    "type": "string"
-            "schema": "1",
+                  },
-            "name": "auto_inc_fk",
+                  "boolean": {
-            "type": "integer",
+                    "format": "boolean",
-            "maxLen": null,
+                    "type": "boolean"
-            "nullable": true,
+                  },
-            "position": 2,
+                  "date": {
-            "enum": [],
+                    "format": "date",
-            "references": {"table": "auto_incrementing_pk", "column": "id"}
+                    "type": "string"
-          }, {
+                  },
-            "default": null,
+                  "money": {
-            "precision": null,
+                    "format": "money",
-            "updatable": true,
+                    "type": "string"
-            "schema": "1",
+                  },
-            "name": "simple_fk",
+                  "enum": {
-            "type": "character varying",
+                    "format": "test.enum_menagerie_type",
-            "maxLen": 255,
+                    "type": "string"
-            "nullable": true,
+                  },
-            "position": 3,
+                  "integer": {
-            "enum": [],
+                    "format": "integer",
-            "references": {"table": "simple_pk", "column": "k"}
+                    "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"
@@ -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] }
@@ -1,9 +1,89 @@
 {-# LANGUAGE QuasiQuotes #-}
 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 Control.AutoUpdate
 import Data.Function (id)
 import Data.IORef
 import Data.Time.Clock.POSIX   (getPOSIXTime)
 import qualified Feature.AuthSpec
 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)
  -- ask for the OS time at most once per second
  getTime <- mkAutoUpdate
    defaultUpdateSettings { updateAction = getPOSIXTime }
  result <- P.use pool $ getDbStructure "test"
  refDbStructure <- newIORef $ Just $ either (panic.show) id result
  let withApp      = return $ postgrest (testCfg testDbConn)          refDbStructure pool getTime $ pure ()
      ltdApp       = return $ postgrest (testLtdRowsCfg testDbConn)   refDbStructure pool getTime $ pure ()
      unicodeApp   = return $ postgrest (testUnicodeCfg testDbConn)   refDbStructure pool getTime $ pure ()
      proxyApp     = return $ postgrest (testProxyCfg testDbConn)     refDbStructure pool getTime $ pure ()
      noJwtApp     = return $ postgrest (testCfgNoJWT testDbConn)     refDbStructure pool getTime $ pure ()
      binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime $ 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
 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)
    ]
@@ -1 +0,0 @@
 {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
@@ -1,123 +1,146 @@
 {-# LANGUAGE QuasiQuotes, OverloadedStrings #-}
 module SpecHelper where
 import Network.Wai
 import Test.Hspec
 import Test.Hspec.Wai
 import Hasql as H
 import Hasql.Backend as H
 import Hasql.Postgres as H
 import Data.String.Conversions (cs)
 import Data.Monoid
 import Data.Text hiding (map)
 import qualified Data.Vector as V
 import Control.Monad (void)
-import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
+import qualified System.IO.Error as E
-                                  hRange, hAuthorization)
+import System.Environment (getEnv)
-import Codec.Binary.Base64.String (encode)
+
 import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient)
 import Data.CaseInsensitive (CI(..))
-import Data.Maybe (fromMaybe)
+import qualified Data.Set as S
 import qualified Data.Map.Strict as M
 import Data.List (lookup)
 import Text.Regex.TDFA ((=~))
 import qualified Data.ByteString.Char8 as BS
-import Network.Wai.Middleware.Cors (cors)
+import qualified Data.ByteString.Lazy as BL
 import System.Process (readProcess)
-import App (app)
+import PostgREST.Config (AppConfig(..))
 import Config (AppConfig(..), corsPolicy)
 import Middleware
 import Error(errResponse)
 -- import Auth (addUser)
-isLeft :: Either a b -> Bool
+import Test.Hspec hiding (pendingWith)
-isLeft (Left _ ) = True
+import Test.Hspec.Wai
 isLeft _ = False
-cfg :: AppConfig
+import Network.HTTP.Types
-cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10
+import Network.Wai.Test (SResponse(simpleStatus, simpleHeaders, simpleBody))
-testPoolOpts :: PoolSettings
+import Data.Maybe (fromJust)
-testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
+import Data.Aeson (decode, Value(..))
 import qualified JSONSchema.Draft4 as D4
-pgSettings :: H.Settings
+import Protolude
 pgSettings = H.ParamSettings (cs $ configDbHost cfg)
                             (fromIntegral $ configDbPort cfg)
                             (cs $ configDbUser cfg)
                             (cs $ configDbPass cfg)
                             (cs $ configDbName cfg)
-withApp :: ActionWith Application -> IO ()
+matchContentTypeJson :: MatchHeader
-withApp perform = do
+matchContentTypeJson = "Content-Type" <:> "application/json; charset=utf-8"
  let anonRole = cs $ configAnonRole cfg
      currRole = cs $ configDbUser cfg
  pool :: H.Pool H.Postgres
    <- H.acquirePool pgSettings testPoolOpts
-  perform $ middle $ \req resp -> do
+matchContentTypeSingular :: MatchHeader
-    body <- strictRequestBody req
+matchContentTypeSingular = "Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"
    result <- liftIO $ H.session pool $ H.tx Nothing
      $ authenticated currRole anonRole (app body) req
    either (resp . errResponse) resp result
-  where middle = cors corsPolicy
+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 ()
 getEnvVarWithDefault :: Text -> Text -> IO Text
 getEnvVarWithDefault var def = do
  varValue <- getEnv (toS var) `E.catchIOError` const (return $ toS def)
  return $ toS varValue
 _baseCfg :: AppConfig
 _baseCfg =  -- Connection Settings
  AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000
            -- Jwt settings
            (Just $ encodeUtf8 "safe") False
            -- Connection Modifiers
            10 Nothing (Just "test.switch_role")
            -- Debug Settings
            True
 testCfg :: Text -> AppConfig
 testCfg testDbConn = _baseCfg { configDatabase = testDbConn }
 testCfgNoJWT :: Text -> AppConfig
 testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing }
 testUnicodeCfg :: Text -> AppConfig
 testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchema = "تست" }
 testLtdRowsCfg :: Text -> AppConfig
 testLtdRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 }
 testProxyCfg :: Text -> AppConfig
 testProxyCfg testDbConn = (testCfg testDbConn) { configProxyUri = Just "https://postgrest.com/openapi.json" }
 testCfgBinaryJWT :: Text -> AppConfig
 testCfgBinaryJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Just secretBs }
  where secretBs = B64.decodeLenient "h2CGB1FoBd51aQooCS2g+UmRgYQfTPQ6v3+9ALbaqM4="
-resetDb :: IO ()
+setupDb :: Text -> IO ()
-resetDb = do
+setupDb dbConn = do
-  pool :: H.Pool H.Postgres
+  loadFixture dbConn "database"
-    <- H.acquirePool pgSettings testPoolOpts
+  loadFixture dbConn "roles"
-  void . liftIO $ H.session pool $
+  loadFixture dbConn "schema"
-    H.tx Nothing $ do
+  loadFixture dbConn "jwt"
-      H.unitEx [H.stmt| drop schema if exists "1" cascade |]
+  loadFixture dbConn "privileges"
-      H.unitEx [H.stmt| drop schema if exists private cascade |]
+  resetDb dbConn
      H.unitEx [H.stmt| drop schema if exists postgrest cascade |]
-  loadFixture "roles"
+resetDb :: Text -> IO ()
-  loadFixture "schema"
+resetDb dbConn = loadFixture dbConn "data"
 loadFixture :: FilePath -> IO()
 loadFixture name =
  void $ readProcess "psql" ["-U", "postgrest_test", "-d", "postgrest_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []
 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
-authHeader :: String -> String -> Header
+authHeaderBasic :: BS.ByteString -> BS.ByteString -> Header
-authHeader u p =
+authHeaderBasic u p =
-  (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
+  (hAuthorization, "Basic " <> (toS . B64.encode . toS $ u <> ":" <> p))
-clearTable :: Text -> IO ()
+authHeaderJWT :: BS.ByteString -> Header
-clearTable table = do
+authHeaderJWT token =
-  pool :: H.Pool H.Postgres
+  (hAuthorization, "Bearer " <> token)
    <- H.acquirePool pgSettings testPoolOpts
  void . liftIO $ H.session pool $ H.tx Nothing $
    H.unitEx $ H.Stmt ("delete from \"1\"."<>table) V.empty True
-createItems :: Int -> IO ()
+-- | Tests whether the text can be parsed as a json object comtaining
-createItems n = do
+-- the key "message", and optional keys "details", "hint", "code",
-  pool :: H.Pool H.Postgres
+-- and no extraneous keys
-    <- H.acquirePool pgSettings testPoolOpts
+isErrorFormat :: BL.ByteString -> Bool
-  void . liftIO $ H.session pool $ H.tx Nothing txn
+isErrorFormat s =
-  where
+  "message" `S.member` keys &&
-    txn = sequence_ $ map H.unitEx stmts
+    S.null (S.difference keys validKeys)
-    stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n]
+ where
-
+  obj = decode s :: Maybe (M.Map Text Value)
-- for hspec-wai
+  keys = fromMaybe S.empty (M.keysSet <$> obj)
-pending_ :: WaiSession ()
+  validKeys = S.fromList ["message", "details", "hint", "code"]
 pending_ = liftIO Test.Hspec.pending
 -- for hspec-wai
 pendingWith_ :: String -> WaiSession ()
 pendingWith_ = liftIO . Test.Hspec.pendingWith
@@ -1,21 +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 Protolude
 import Control.Monad (mzero)
 data IncPK = IncPK {
  incId :: Int
-, incNullableStr :: Maybe String
+, incNullableStr :: Maybe Text
-, incStr :: String
+, incStr :: Text
-, incInsert :: String
+, incInsert :: Text
 } deriving (Eq, Show)
 instance JSON.FromJSON IncPK where
@@ -26,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 <$>
@@ -45,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)
@@ -1,7 +1,7 @@
-module Unit.PgStructureSpec where
+module Unit.DbStructureSpec where
 import Test.Hspec
-import PgStructure (Table(..), tables, Column(..), columns, ForeignKey(..),
+import DbStructure (Table(..), tables, Column(..), columns, ForeignKey(..),
  foreignKeys)
 import Database.HDBC (quickQuery)
@@ -12,25 +12,25 @@ spec :: Spec
 spec = around dbWithSchema $ beforeWith setRole $ do
  describe "tables" $
    it "shows all the tables" $ \conn -> do
-      ts <- tables "1" conn
+      ts <- tables "test" conn
      map tableName ts `shouldBe` ["authors_only","auto_incrementing_pk",
-        "compound_pk","has_fk","items","menagerie","no_pk", "simple_pk"]
+        "compound_pk","has_fk","insertable_view_with_join","items","menagerie","no_pk", "simple_pk"]
  describe "columns" $ do
    it "responds with each column for the table" $ \conn -> do
-      cs <- columns "1" "auto_incrementing_pk" conn
+      cs <- columns "test" "auto_incrementing_pk" conn
      map colName cs `shouldBe` ["id","nullable_string","non_nullable_string",
        "inserted_at"]
    it "includes foreign key data" $ \conn -> do
-      cs <- columns "1" "has_fk" conn
+      cs <- columns "test" "has_fk" conn
      map colFK cs `shouldBe` [Nothing,
        Just $ ForeignKey "auto_incrementing_pk" "id",
        Just $ ForeignKey "simple_pk" "k"]
  describe "foreignKeys" $
    it "has a description of the foreign key columns" $ \conn ->
-      foreignKeys "1" "has_fk" conn `shouldReturn` M.fromList [
+      foreignKeys "test" "has_fk" conn `shouldReturn` M.fromList [
        ("auto_inc_fk", ForeignKey {fkTable="auto_incrementing_pk", fkCol="id"}),
        ("simple_fk", ForeignKey { fkTable="simple_pk", fkCol="k"})]
@@ -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
@@ -79,7 +79,7 @@ spec = around dbWithSchema $ do
    addUser user pass role conn
    return conn) $ do
    it "accepts correct credentials and return the role" $ \conn ->
-      signInRole user pass conn `shouldReturn` LoginSuccess role
+      signInRole user pass conn `shouldReturn` LoginSuccess role user
    it "returns nothing with bad creds" $ \conn -> do
      signInRole "not-a-user" pass conn `shouldReturn` LoginFailed
@@ -0,0 +1,58 @@
 #! /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 )
 #Remove database path from the connection uri--prevents setting up the new database name with PGDATABASE
 URI=$(echo $1 | cut -d'/' -f1-3)
 #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
 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
@@ -0,0 +1,66 @@
 #! /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 )
 #Remove database path from the connection uri
 URI=$(echo $1 | cut -d'/' -f1-3)
 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
@@ -0,0 +1,320 @@
 --
 -- 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 ('''bar'':2 ''foo'':1');
 INSERT INTO tsearch VALUES ('''baz'':1 ''qux'':2');
 --
 -- 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"}');
 --
 -- PostgreSQL database dump complete
 --
@@ -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;
@@ -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": {}
 }
@@ -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;
@@ -0,0 +1,75 @@
 -- 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
 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;
@@ -1,16 +1,7 @@
-create function pg_temp.create_role_if_not_exists(rolename name, opts character varying) RETURNS text
+\set AUTHENTICATOR current_user
-  LANGUAGE plpgsql
+DROP ROLE IF EXISTS postgrest_test_anonymous, postgrest_test_default_role, postgrest_test_author;
-  AS $$
+CREATE ROLE postgrest_test_anonymous;
-BEGIN
+CREATE ROLE postgrest_test_default_role;
-  IF NOT EXISTS (SELECT * FROM pg_roles WHERE rolname = rolename) THEN
+CREATE ROLE postgrest_test_author;
    EXECUTE format('CREATE ROLE %I %s', rolename, opts);
    RETURN 'CREATE ROLE';
  ELSE
    RETURN format('ROLE ''%I'' ALREADY EXISTS', rolename);
  END IF;
 END;
 $$;
-select pg_temp.create_role_if_not_exists('postgrest_anonymous', 'with nologin') as a
+GRANT postgrest_test_anonymous, postgrest_test_default_role, postgrest_test_author TO :USER;
     , 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;
		`@@ -1 +0,0 @@`
			`{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}`