v0.3.0.1

bugfix + Disambiguate range selection when plurality=singular

.gitignore

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

CHANGELOG.md

@@ -3,6 +3,105 @@
 All notable changes to this project will be documented in this file.
 This project adheres to [Semantic Versioning](http://semver.org/).
 
+## [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

CONTRIBUTING.md

@@ -0,0 +1,55 @@
+# 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.
+
+## 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://github.com/begriffs/postgrest/wiki/Building-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.

README.md

@@ -1,15 +1,17 @@
 ![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)
 
 PostgREST serves a fully RESTful API from any existing PostgreSQL
 database. It provides a cleaner, more standards-compliant, faster
 API than you are likely to write from scratch.
 
-### Demo [postgrest.herokuapp.com](https://postgrest.herokuapp.com) | Watch [Video](http://begriffs.com/posts/2014-12-30-intro-to-postgrest.html)
+### Demo [postgrest.herokuapp.com](https://postgrest.herokuapp.com) | Read [Docs](http://postgrest.com/) | Watch [Video](http://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
@@ -18,33 +20,39 @@ demo database is defined by
 You can use it as inspiration for test-driven server migrations in
 your own projects.
 
+Also try other tools in the PostgREST
+[ecosystem](http://postgrest.com/install/ecosystem/) like the
+[ng-admin demo](http://marmelab.com/ng-admin-postgrest).
+
 ### Usage
 
-Download the binary ([OS X](http://bin.begriffs.com/dbapi/osx/postgrest-0.2.7.0.tar.xz) / [Linux](http://bin.begriffs.com/dbapi/heroku/postgrest-0.2.7.0.tar.xz)) and invoke like so:
+1. Download the binary ([latest release](https://github.com/begriffs/postgrest/releases/latest))
+   for your platform.
+2. Invoke like so:
 
-```bash
-postgrest  --db-host localhost  --db-port 5432     \
-           --db-name my_db      --db-user postgres \
-           --db-pass foobar     --db-pool 200      \
-           --anonymous postgres --port 3000        \
-           --v1schema public
-```
+    ```bash
+    postgrest postgres://postgres:foobar@localhost:5432/my_db \
+              --port 3000 \
+              --schema public \
+              --anonymous postgres \
+              --pool 200
+    ```
 
-In production include the `--secure` option which redirects all
-requests to HTTPS. Note that PostgREST does not handle the SSL
-internally and must be put behind another server that does (such
-as nginx or the Heroku load balancer).
+For more information on valid connection strings see the
+[PostgreSQL docs](http://www.postgresql.org/docs/9.4/static/libpq-connect.html#LIBPQ-CONNSTRING).
 
 ### 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. ([see the load
+test](http://postgrest.com/admin/performance/#benchmarks))
 
 If you're used to servers written in interpreted languages (or named
 after precious gems), prepare to be pleasantly surprised by PostgREST
 performance.
 
 Three factors contribute to the speed. First the server is written
-in [Haskell](https://new-www.haskell.org/) using the
+in [Haskell](https://www.haskell.org/) using the
 [Warp](http://www.yesodweb.com/blog/2011/03/preliminary-warp-cross-language-benchmarks)
 HTTP server (aka a compiled language with lightweight threads).
 Next it delegates as much calculation as possible to the database
@@ -62,58 +70,64 @@ 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).
+the [performance guide](http://postgrest.com/admin/performance/).
+Alternatively [CitusDB](https://www.citusdata.com/products/what-is-citusdb)
+supports Postgres clustering for higher performance.
 
 Other optimizations are possible, and some are outlined in the
 [Future Features](#future-features).
 
 ### Security
 
-PostgREST handles authentication (HTTP Basic over SSL) and delegates
-authorization to the role information defined in the database. This
-ensures there is a single declarative source of truth for security.
-When dealing with the database the server assumes the identity of
-the currently authenticated user, and for the duration of the
-connection cannot do anything the user themselves couldn't.
+PostgREST handles authentication (via [JSON Web
+Tokens](http://postgrest.com/admin/security/#json-web-tokens))
+and delegates authorization to the role information defined in the
+database. This ensures there is a single declarative source of truth
+for security.  When dealing with the database the server assumes
+the identity of the currently authenticated user, and for the
+duration of the connection cannot do anything the user themselves
+couldn't. Other forms of authentication can be built on top
+of the JWT primitive. See the docs for more information.
 
-Postgres 9.5 will soon support true [row-level
-security](http://michael.otacoo.com/postgresql-2/postgres-9-5-feature-highlight-row-level-security/).
-In the meantime what isn't yet implemented can be simulated with
-triggers and security-barrier views. Because the possible queries
-to the database are limited to certain templates using
+PostgreSQL 9.5 supports true [row-level
+security](http://www.postgresql.org/docs/9.5/static/ddl-rowsecurity.html).
+In previous versions it can be simulated with triggers and
+security-barrier views. Because the possible queries to the database
+are limited to certain templates using
 [leakproof](http://blog.2ndquadrant.com/how-do-postgresql-security_barrier-views-work/)
 functions, the trigger workaround does not compromise row-level
 security.
 
 For example security patterns see the [security
-guide](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions).
+guide](http://postgrest.com/admin/security/).
 
 ### Versioning
 
 A robust long-lived API needs the freedom to exist in multiple
-versions. PostgREST supports versioning through HTTP content
-negotiation. Requests for a certain version translate into switching
-which database schema to search for tables. PostgreSQL schema search
-paths allow tables from earlier versions to be reused verbatim in
-later versions.
-
-To learn more, see the [guide to versioning](https://github.com/begriffs/postgrest/wiki/API-Versioning).
+versions. PostgREST does versioning through database schemas. This
+allows you to expose tables and views without making the app brittle.
+Underlying tables can be superseded and hidden behind public facing
+views. You run an instance of PostgREST per schema and route requests
+among them with a reverse proxy such as [nginx](http://nginx.org).
+Learn more [here](http://postgrest.com/admin/versioning/).
 
 ### Self-documention
 
 Rather than writing and maintaining separate docs yourself let the
 API explain its own affordances using HTTP. All PostgREST endpoints
 respond to the OPTIONS verb and explain what they support as well
-as the data format of their JSON payload.
+as the data format of their JSON payload. RAML support is an upcoming
+feature.
 
-The number of rows returned by an endpoint is reported by - and
-limited with - range headers. More about
+The project uses HTTP itself to commicate other metadata. For
+instance the number of rows returned by an endpoint is reported by -
+and limited with - range headers. More about
 [that](http://begriffs.com/posts/2014-03-06-beyond-http-header-links.html).
 
 There are more opportunities for self-documentation listed in [Future
@@ -129,9 +143,9 @@ data (including your API server).
 The PostgREST exposes HTTP interface with safeguards to prevent
 surprises, such as enforcing idempotent PUT requests, and
 
-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 [guide to routing](http://postgrest.com/api/reading/).
 
 ### Future Features
 
@@ -144,21 +158,14 @@ and the [guide to routing](https://github.com/begriffs/postgrest/wiki/Routing).
 * 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
-  contributions and many fundamental design discussions
-* [Nikita Volkov](https://github.com/nikita-volkov) for writing the
-  wonderful [Hasql](https://github.com/nikita-volkov/hasql) library
-  and helping me use it
-* [Mikey Casalaina](https://github.com/casalaina) for the cool logo
+I'm grateful to the generous project
+[contributors](https://github.com/begriffs/postgrest/graphs/contributors)
+who have improved PostgREST immensely with their code and good
+judgement.  See more details in the
+[changelog](https://github.com/begriffs/postgrest/blob/master/CHANGELOG.md).
+
+The cool logo came from [Mikey Casalaina](https://github.com/casalaina).

app.json

@@ -10,7 +10,7 @@
     },
     "POSTGREST_VER": {
       "description": "Version of PostgREST to deploy",
-      "value": "0.2.7.0"
+      "value": "0.3.0.1"
     },
     "DB_NAME": {
       "description": "Database name",
@@ -41,6 +41,16 @@
       "description": "Maximum number of connections in database pool",
       "required": false,
       "value": "10"
+    },
+    "JWT_SECRET": {
+      "description": "Secret used to encrypt JSON Web Tokens",
+      "required": false,
+      "value": "secret"
+    },
+    "V1SCHEMA": {
+      "description": "DB schema selected whe no version (or version 1) requested",
+      "required": false,
+      "value": "1"
     }
   }
 }

circle.yml

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

debian/TODO-deps.md

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

debian/changelog

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

debian/compat

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

debian/control

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

debian/copyright

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

debian/haskell-postgrest-utils.install

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

debian/postgrest-wrapper

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

debian/postgrest.default

@@ -0,0 +1,29 @@
+# run service as
+#POSTGREST_USER=postgrest
+
+# log file
+#POSTGREST_LOG=/var/log/postgrest/postgrest.log
+
+# database host
+#POSTGREST_DBHOST=localhost
+
+# database host
+#POSTGREST_DBPORT=5432
+
+# database to use
+#POSTGREST_DBNAME=app
+
+# database user
+#POSTGREST_DBUSER=authenticator
+
+# database password
+#POSTGREST_DBPASS=
+
+# database pool
+#POSTGREST_POOL=10
+
+# jwt secret
+#POSTGREST_JWT_SECRET=secret
+
+# default schema
+#POSTGREST_SCHEMA=public

debian/postgrest.init.d

@@ -0,0 +1,99 @@
+#!/bin/sh
+### BEGIN INIT INFO
+# Provides:          postgrest
+# Required-Start:    $local_fs $network postgresql
+# Required-Stop:     $local_fs $network
+# Default-Start:     2 3 4 5
+# Default-Stop:      0 1 6
+# Description:       PostgreSQL REST API daemon
+### END INIT INFO
+
+. /lib/lsb/init-functions
+if test -f /etc/default/postgrest; then
+    . /etc/default/postgrest
+fi
+POSTGREST=/usr/local/bin/postgrest
+CONNECTION_STRING="postgres://"
+POSTGREST_OPTS=""
+POSTGREST_USER=${POSTGREST_USER:-postgrest}
+POSTGREST_PORT=${POSTGREST_PORT:-3000}
+POSTGREST_DBUSER=${POSTGREST_DBUSER:-authenticator}
+#POSTGREST_DBPASS=${POSTGREST_DBPASS:-authenticator}
+POSTGREST_DBHOST=${POSTGREST_DBHOST:-localhost}
+POSTGREST_DBPORT=${POSTGREST_DBPORT:-5432}
+POSTGREST_DBNAME=${POSTGREST_DBNAME:-app}
+POSTGREST_DBPOOL=${POSTGREST_DBPOOL:-10}
+POSTGREST_ANON=${POSTGREST_ANON:-anonymous}
+POSTGREST_JWT_SECRET=${POSTGREST_JWT_SECRET:-secret}
+POSTGREST_SCHEMA=${POSTGREST_SCHEMA:-public}
+
+CONNECTION_STRING="$CONNECTION_STRING$POSTGREST_DBUSER"
+if [ -n "$POSTGREST_DBPASS" ]; then
+	CONNECTION_STRING="$CONNECTION_STRING:$POSTGREST_DBPASS"
+fi
+CONNECTION_STRING="$CONNECTION_STRING@$POSTGREST_DBHOST:$POSTGREST_DBPORT/$POSTGREST_DBNAME"
+
+if [ -n "$POSTGREST_PORT" ]; then
+	POSTGREST_OPTS="$POSTGREST_OPTS --port $POSTGREST_PORT"
+fi
+
+if [ -n "$POSTGREST_POOL" ]; then
+	POSTGREST_OPTS="$POSTGREST_OPTS --pool $POSTGREST_POOL"
+fi
+if [ -n "$POSTGREST_JWT_SECRET" ]; then
+	#export POSTGREST_JWT_SECRET="$POSTGREST_JWT_SECRET"
+	POSTGREST_OPTS="$POSTGREST_OPTS --jwt-secret $POSTGREST_JWT_SECRET"
+fi
+if [ -n "$POSTGREST_SCHEMA" ]; then
+	POSTGREST_OPTS="$POSTGREST_OPTS --schema $POSTGREST_SCHEMA"
+fi
+if [ -n "$POSTGREST_ANON" ]; then
+	POSTGREST_OPTS="$POSTGREST_OPTS --anonymous $POSTGREST_ANON"
+fi
+
+#export CONNECTION_STRING="$CONNECTION_STRING"
+
+START_PARAMS="$CONNECTION_STRING $POSTGREST_OPTS"
+
+start()
+{
+	log_daemon_msg "Starting PostgreSQL REST API daemon" "postgrest" || true
+	if start-stop-daemon --start --quiet --oknodo --chuid ${POSTGREST_USER} --startas /usr/local/bin/postgrest-wrapper --exec $POSTGREST -- $START_PARAMS; then
+		log_end_msg 0 || true
+	else
+		log_end_msg 1 || true
+	fi
+}
+
+stop()
+{
+	log_daemon_msg "Stopping PostgreSQL REST API daemon" "postgrest" || true
+	if start-stop-daemon --stop --quiet --oknodo --exec $POSTGREST; then
+		log_end_msg 0 || true
+	else
+		log_end_msg 1 || true
+	fi
+}
+
+status()
+{
+	status_of_proc $POSTGREST postgrest && exit 0 || exit $?
+}
+
+case "$1" in
+start)
+	start
+	;;
+stop)
+	stop
+	;;
+restart)
+	stop
+	start
+	;;
+status)
+	status
+	;;
+*)
+	echo "Usage: $0 {start|stop|restart|status}"
+esac

debian/rules

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

debian/source/format

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

debian/watch

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

docs/CNAME

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

docs/admin/deployment.md

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

docs/admin/migration.md

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

docs/admin/performance.md

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

docs/admin/security.md

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

docs/admin/versioning.md

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

docs/api/reading.md

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

docs/api/writing.md

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

docs/examples/start.md

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

docs/index.md

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

docs/install/ecosystem.md

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

docs/install/server.md

@@ -0,0 +1,89 @@
+## Installation
+
+### Installing from Pre-Built Release
+
+The [release page](https://github.com/begriffs/postgrest/releases/latest) has precompiled binaries for Mac OS X and 64-bit Ubuntu. Next extract the tarball and run the binary inside with no arguments to see usage instructions:
+
+```sh
+# Untar the release (available at https://github.com/begriffs/postgrest/releases/latest)
+
+$ tar zxf postgrest-[version]-[platform].tar.xz
+
+# Try running it
+$ ./postgrest
+
+# You should see a usage help message
+```
+
+<div class="admonition warning">
+    <p class="admonition-title">Invitation to Contribute</p>
+
+    <p>I currently build the binaries manually for each version. We need to set up an automated build matrix for various architectures. It should support 32- and 64-bit versions of
+
+    <ul><li>Scientific Linux 6</li><li>CentOS</li><li>RHEL 6</li></ul>
+
+    Also it would be good to create a package for apt.</p>
+</div>
+
+We'll learn the meaning of the command line flags later, but here is a minimal example of running the app. It does all operations as user `postgres`, including for unauthenticated requests.
+
+```sh
+$ ./postgrest -d dbname -U postgres -a postgres --v1schema public
+```
+
+### Building from Source
+
+When a prebuilt binary does not exist for your system you can build the project from source. You'll also need to do this if you want to help with development. [Stack](https://github.com/commercialhaskell/stack) makes it easy. It will install any necessary Haskell dependencies on your system.
+
+* [Install Stack](https://github.com/commercialhaskell/stack#how-to-install) for your platform
+```bash
+#ubuntu example
+wget -q -O- https://s3.amazonaws.com/download.fpcomplete.com/ubuntu/fpco.key | sudo apt-key add -
+echo 'deb http://download.fpcomplete.com/ubuntu/trusty stable main'|sudo tee /etc/apt/sources.list.d/fpco.list
+sudo apt-get update && sudo apt-get install stack -y
+```
+* Build & install in one step
+
+```bash
+git clone https://github.com/begriffs/postgrest.git
+cd postgrest
+sudo stack install --install-ghc --local-bin-path /usr/local/bin
+```
+
+* Run the server
+
+```bash
+postgrest dbconnectionstring arg1 arg2
+```
+
+If you want to run the test suite, stack can do that too: `stack test`.
+
+### Install via Homebrew (Mac OS X)
+
+You can use the Homebrew package manager to install PostgREST on Mac
+
+```bash
+# Ensure brew is up to date
+brew update
+
+# Check for any problems with brew's setup
+brew doctor
+
+# Install the postgrest package
+brew install postgrest
+```
+
+This will automatically install PostgreSQL as a dependency (see the [Installing PostgreSQL](#installing-postgresql) section for setup instructions). The process tends to take around 15 minutes to install the package and its dependencies.
+
+After installation completes, the tool is added to your $PATH and can be used from anywhere with:
+
+```bash
+postgrest --help
+```
+
+### Installing PostgreSQL
+
+To use PostgREST you will need an underlying database. You can use something like Amazon [RDS](https://aws.amazon.com/rds/) but installing your own locally is cheaper and more convenient for development.
+
+* [Instructions for OS X](http://exponential.io/blog/2015/02/21/install-postgresql-on-mac-os-x-via-brew/)
+* [Instructions for Ubuntu 14.04](https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-14-04)

mkdocs.yml

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

postgrest.cabal

@@ -2,7 +2,7 @@ name:                  postgrest
 description:           Reads the schema of a PostgreSQL database and creates RESTful routes
                        for the tables and views, supporting all HTTP verbs that security
                        permits.
-version:               0.2.7.0
+version:               0.3.0.1
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
@@ -12,28 +12,42 @@ 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-language:    Haskell2010
+  if flag(ci)
+    ghc-options:       -Wall -W -Werror
+  else
+    ghc-options:       -Wall -W -O2
+
+  main-is:             PostgREST/Main.hs
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
-  build-depends:       base >=4.6 && <5
-                     , hasql == 0.7.*, hasql-backend
-                     , hasql-postgres == 0.10.*
+  default-language:    Haskell2010
+  build-depends:       base >= 4.8 && < 5
+                     , postgrest
+                     , hasql >= 0.7.3 && < 0.8
+                     , hasql-backend >= 0.4.1 && < 0.5
+                     , hasql-postgres >= 0.10.4 && < 0.11
                      , warp >= 3.0.2, wai >= 3.0.1
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
                      , HTTP, convertible, http-types
                      , case-insensitive
                      , scientific, time
-                     , aeson, network >= 2.6
+                     , aeson >= 0.8, network >= 2.6
+                     , aeson-pretty >= 0.7 && < 0.8
                      , bytestring, text, split, string-conversions
                      , stringsearch
                      , containers, unordered-containers
-                     , optparse-applicative == 0.11.*
+                     , optparse-applicative >= 0.11 && < 0.13
                      , regex-base, regex-tdfa
-                     , regex-tdfa-text
                      , Ranged-sets
                      , transformers, MissingH
                      , bcrypt >= 0.0.6, base64-string
@@ -42,15 +56,88 @@ executable postgrest
                      , blaze-builder
                      , vector
                      , mtl
-  Other-Modules:       App
-                     , Auth
-                     , Config
-                     , Error
-                     , Middleware
-                     , PgQuery
-                     , PgStructure
-                     , RangeQuery
-                     , Types
+                     , cassava
+                     , jwt
+                     , parsec
+                     , errors
+                     , bifunctors
+  hs-source-dirs:      src
+  other-modules:       Paths_postgrest
+                     , PostgREST.App
+                     , PostgREST.Auth
+                     , PostgREST.Config
+                     , PostgREST.Error
+                     , PostgREST.Middleware
+                     , PostgREST.Parsers
+                     , PostgREST.DbStructure
+                     , PostgREST.QueryBuilder
+                     , PostgREST.RangeQuery
+                     , PostgREST.ApiRequest
+                     , PostgREST.Types
+
+library
+  if flag(ci)
+    ghc-options:       -Wall -W -Werror
+  else
+    ghc-options:       -Wall -W -O2
+
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
+  build-depends:       HTTP
+                     , MissingH
+                     , Ranged-sets
+                     , aeson
+                     , base >=4.6 && <5
+                     , base64-string
+                     , bcrypt
+                     , bifunctors
+                     , blaze-builder
+                     , bytestring
+                     , case-insensitive
+                     , cassava
+                     , containers
+                     , convertible
+                     , errors
+                     , hasql
+                     , hasql-backend
+                     , hasql-postgres
+                     , http-types
+                     , jwt
+                     , mtl
+                     , network
+                     , network-uri
+                     , optparse-applicative
+                     , parsec
+                     , regex-base
+                     , regex-tdfa
+                     , resource-pool
+                     , scientific
+                     , split
+                     , string-conversions
+                     , stringsearch
+                     , text
+                     , time
+                     , transformers
+                     , unordered-containers
+                     , vector
+                     , wai
+                     , wai-cors
+                     , wai-extra
+                     , wai-middleware-static
+                     , warp
+
+  Other-Modules:       Paths_postgrest
+  Exposed-Modules:     PostgREST.App
+                     , PostgREST.Auth
+                     , PostgREST.Config
+                     , PostgREST.Error
+                     , PostgREST.Middleware
+                     , PostgREST.Parsers
+                     , PostgREST.DbStructure
+                     , PostgREST.QueryBuilder
+                     , PostgREST.RangeQuery
+                     , PostgREST.ApiRequest
+                     , PostgREST.Types
   hs-source-dirs:      src
 
 Test-Suite spec
@@ -58,21 +145,35 @@ Test-Suite spec
   Default-Language:    Haskell2010
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
   Hs-Source-Dirs:      test, src
-  ghc-options:         -Wall -W -Werror
+  if flag(ci)
+    ghc-options:       -Wall -W -Werror
+  else
+    ghc-options:       -Wall -W -O2
   Main-Is:             Main.hs
-  Other-Modules:       App
-                     , Auth
-                     , Config
-                     , Error
-                     , Middleware
-                     , PgQuery
-                     , PgStructure
-                     , RangeQuery
-                     , Types
+  Other-Modules:       Feature.AuthSpec
+                     , Feature.CorsSpec
+                     , Feature.DeleteSpec
+                     , Feature.InsertSpec
+                     , Feature.QuerySpec
+                     , Feature.RangeSpec
+                     , Feature.StructureSpec
+                     , Paths_postgrest
+                     , PostgREST.App
+                     , PostgREST.Auth
+                     , PostgREST.Config
+                     , PostgREST.Error
+                     , PostgREST.Middleware
+                     , PostgREST.Parsers
+                     , PostgREST.DbStructure
+                     , PostgREST.QueryBuilder
+                     , PostgREST.RangeQuery
+                     , PostgREST.ApiRequest
+                     , PostgREST.Types
                      , Spec
                      , SpecHelper
-  Build-Depends:       base, hspec >= 2.1.2, QuickCheck
-                     , hspec-wai >= 0.5.0, hspec-wai-json
+                     , TestTypes
+  Build-Depends:       base, hspec == 2.2.*, QuickCheck
+                     , hspec-wai, hspec-wai-json
                      , hasql, hasql-backend
                      , hasql-postgres
                      , warp, wai
@@ -89,7 +190,6 @@ Test-Suite spec
                      , regex-base
                      , string-conversions
                      , http-media, regex-tdfa
-                     , regex-tdfa-text
                      , Ranged-sets
                      , transformers, MissingH, split
                      , bcrypt, base64-string
@@ -98,4 +198,10 @@ Test-Suite spec
                      , blaze-builder
                      , vector
                      , mtl
+                     , cassava
                      , process
+                     , heredoc
+                     , jwt
+                     , parsec
+                     , errors
+                     , bifunctors

schema-templates/blog.sql

@@ -0,0 +1,378 @@
+-------------------------------------------------------------------------------
+-- Adapted from https://github.com/robconery/pg-auth
+
+begin;
+
+-- comment out the role creation statements if
+-- you want to run this script more than once
+create role anon noinherit;
+create role author;
+
+create extension if not exists pgcrypto;
+create extension if not exists "uuid-ossp";
+
+-- We put things inside the basic_auth schema to hide
+-- them from public view. Certain public procs/views will
+-- refer to helpers and tables inside.
+create schema if not exists basic_auth;
+
+-------------------------------------------------------------------------------
+-- Utility functions
+
+create or replace function
+basic_auth.clearance_for_role(u name) returns void as
+$$
+declare
+  ok boolean;
+begin
+  select exists (
+    select rolname
+      from pg_authid
+     where pg_has_role(current_user, oid, 'member')
+       and rolname = u
+  ) into ok;
+  if not ok then
+    raise invalid_password using message =
+      'current user not member of role ' || u;
+  end if;
+end
+$$ LANGUAGE plpgsql;
+
+-------------------------------------------------------------------------------
+-- Users storage and constraints
+
+create table if not exists
+basic_auth.users (
+  email    text primary key check ( email ~* '^.+@.+\..+$' ),
+  pass     text not null check (length(pass) < 512),
+  role     name not null check (length(role) < 512),
+  verified boolean not null default false
+  -- If you like add more columns, or a json column
+);
+
+create or replace function
+basic_auth.check_role_exists() returns trigger
+  language plpgsql
+  as $$
+begin
+  if not exists (select 1 from pg_roles as r where r.rolname = new.role) then
+    raise foreign_key_violation using message =
+      'unknown database role: ' || new.role;
+    return null;
+  end if;
+  return new;
+end
+$$;
+
+drop trigger if exists ensure_user_role_exists on basic_auth.users;
+create constraint trigger ensure_user_role_exists
+  after insert or update on basic_auth.users
+  for each row
+  execute procedure basic_auth.check_role_exists();
+
+create or replace function
+basic_auth.encrypt_pass() returns trigger
+  language plpgsql
+  as $$
+begin
+  if tg_op = 'INSERT' or new.pass <> old.pass then
+    new.pass = crypt(new.pass, gen_salt('bf'));
+  end if;
+  return new;
+end
+$$;
+
+drop trigger if exists encrypt_pass on basic_auth.users;
+create trigger encrypt_pass
+  before insert or update on basic_auth.users
+  for each row
+  execute procedure basic_auth.encrypt_pass();
+
+create or replace function
+basic_auth.send_validation() returns trigger
+  language plpgsql
+  as $$
+declare
+  tok uuid;
+begin
+  select uuid_generate_v4() into tok;
+  insert into basic_auth.tokens (token, token_type, email)
+         values (tok, 'validation', new.email);
+  perform pg_notify('validate',
+    json_build_object(
+      'email', new.email,
+      'token', tok,
+      'token_type', 'validation'
+    )::text
+  );
+  return new;
+end
+$$;
+
+drop trigger if exists send_validation on basic_auth.users;
+create trigger send_validation
+  after insert on basic_auth.users
+  for each row
+  execute procedure basic_auth.send_validation();
+
+-------------------------------------------------------------------------------
+-- Email Validation and Password Reset
+
+drop type if exists token_type_enum cascade;
+create type token_type_enum as enum ('validation', 'reset');
+
+create table if not exists
+basic_auth.tokens (
+  token       uuid primary key,
+  token_type  token_type_enum not null,
+  email       text not null references basic_auth.users (email)
+                on delete cascade on update cascade,
+  created_at  timestamptz not null default current_date
+);
+
+-------------------------------------------------------------------------------
+-- Login helper
+
+create or replace function
+basic_auth.user_role(email text, pass text) returns name
+  language plpgsql
+  as $$
+begin
+  return (
+  select role from basic_auth.users
+   where users.email = user_role.email
+     and users.pass = crypt(user_role.pass, users.pass)
+  );
+end;
+$$;
+
+create or replace function
+basic_auth.current_email() returns text
+  language plpgsql
+  as $$
+begin
+  return current_setting('postgrest.claims.email');
+exception
+  -- handle unrecognized configuration parameter error
+  when undefined_object then return '';
+end;
+$$;
+
+
+-------------------------------------------------------------------------------
+-- Public functions (in current schema, not basic_auth)
+
+create or replace function
+request_password_reset(email text) returns void
+  language plpgsql
+  as $$
+declare
+  tok uuid;
+begin
+  delete from basic_auth.tokens
+   where token_type = 'reset'
+     and tokens.email = request_password_reset.email;
+
+  select uuid_generate_v4() into tok;
+  insert into basic_auth.tokens (token, token_type, email)
+         values (tok, 'reset', request_password_reset.email);
+  perform pg_notify('reset',
+    json_build_object(
+      'email', request_password_reset.email,
+      'token', tok,
+      'token_type', 'reset'
+    )::text
+  );
+end;
+$$;
+
+create or replace function
+reset_password(email text, token uuid, pass text)
+  returns void
+  language plpgsql
+  as $$
+declare
+  tok uuid;
+begin
+  if exists(select 1 from basic_auth.tokens
+             where tokens.email = reset_password.email
+               and tokens.token = reset_password.token
+               and token_type = 'reset') then
+    update basic_auth.users set pass=reset_password.pass
+     where users.email = reset_password.email;
+
+    delete from basic_auth.tokens
+     where tokens.email = reset_password.email
+       and tokens.token = reset_password.token
+       and token_type = 'reset';
+  else
+    raise invalid_password using message =
+      'invalid user or token';
+  end if;
+  delete from basic_auth.tokens
+   where token_type = 'reset'
+     and tokens.email = reset_password.email;
+
+  select uuid_generate_v4() into tok;
+  insert into basic_auth.tokens (token, token_type, email)
+         values (tok, 'reset', reset_password.email);
+  perform pg_notify('reset',
+    json_build_object(
+      'email', reset_password.email,
+      'token', tok
+    )::text
+  );
+end;
+$$;
+
+drop type if exists basic_auth.jwt_claims cascade;
+create type
+basic_auth.jwt_claims AS (role text, email text);
+
+create or replace function
+login(email text, pass text) returns basic_auth.jwt_claims
+  language plpgsql
+  as $$
+declare
+  _role name;
+  result basic_auth.jwt_claims;
+begin
+  select basic_auth.user_role(email, pass) into _role;
+  if _role is null then
+    raise invalid_password using message = 'invalid user or password';
+  end if;
+  -- TODO; check verified flag if you care whether users
+  -- have validated their emails
+  select _role as role, login.email as email into result;
+  return result;
+end;
+$$;
+
+create or replace function
+signup(email text, pass text) returns void
+as $$
+  insert into basic_auth.users (email, pass, role) values
+    (signup.email, signup.pass, 'author');
+$$ language sql;
+
+-------------------------------------------------------------------------------
+-- User management
+
+create or replace view users as
+select actual.role as role,
+       '***'::text as pass,
+       actual.email as email,
+       actual.verified as verified
+from basic_auth.users as actual,
+     (select rolname
+        from pg_authid
+       where pg_has_role(current_user, oid, 'member')
+     ) as member_of
+where actual.role = member_of.rolname
+  and (
+    actual.role <> 'author'
+    or email = basic_auth.current_email()
+  );
+
+create or replace function
+update_users() returns trigger
+language plpgsql
+AS $$
+begin
+  if tg_op = 'INSERT' then
+    perform basic_auth.clearance_for_role(new.role);
+
+    insert into basic_auth.users
+      (role, pass, email, verified) values
+      (coalesce(new.role, 'author'), new.pass,
+        new.email, coalesce(new.verified, false));
+    return new;
+  elsif tg_op = 'UPDATE' then
+    -- no need to check clearance for old.role because
+    -- an ineligible row would not even available to update (http 404)
+    perform basic_auth.clearance_for_role(new.role);
+
+    update basic_auth.users set
+      email  = new.email,
+      role   = new.role,
+      pass   = new.pass,
+      verified = coalesce(new.verified, old.verified, false)
+      where email = old.email;
+    return new;
+  elsif tg_op = 'DELETE' then
+    -- no need to check clearance for old.role (see previous case)
+
+    delete from basic_auth.users
+     where basic_auth.email = old.email;
+    return null;
+  end if;
+end
+$$;
+
+drop trigger if exists update_users on users;
+create trigger update_users
+  instead of insert or update or delete on
+    users for each row execute procedure update_users();
+
+-------------------------------------------------------------------------------
+-- Blogging stuff!
+
+create table if not exists
+posts (
+  id         bigserial primary key,
+  title      text not null,
+  body       text not null,
+  author     text not null references basic_auth.users (email)
+               on delete restrict on update cascade,
+  created_at timestamptz not null default current_date
+);
+
+create table if not exists
+comments (
+  id         bigserial primary key,
+  body       text not null,
+  author     text not null references basic_auth.users (email)
+               on delete restrict on update cascade,
+  post       bigint not null references posts (id)
+               on delete cascade on update cascade,
+  created_at timestamptz not null default current_date
+);
+
+-------------------------------------------------------------------------------
+-- Permissions
+
+grant insert on table basic_auth.users, basic_auth.tokens to anon;
+grant select on table pg_authid, basic_auth.users, posts, comments to anon;
+grant execute on function
+  login(text,text),
+  request_password_reset(text),
+  reset_password(text,uuid,text),
+  signup(text, text)
+  to anon;
+
+grant author to anon;
+grant select, insert, update, delete
+  on basic_auth.tokens, basic_auth.users to anon, author;
+grant select, insert, update, delete
+  on table users, posts, comments to author;
+grant usage, select on sequence posts_id_seq, comments_id_seq to author;
+
+grant usage on schema public, basic_auth to anon, author;
+
+ALTER TABLE posts ENABLE ROW LEVEL SECURITY;
+drop policy if exists authors_eigenedit on posts;
+create policy authors_eigenedit on posts
+  using (true)
+  with check (
+    author = basic_auth.current_email()
+  );
+
+ALTER TABLE comments ENABLE ROW LEVEL SECURITY;
+drop policy if exists authors_eigenedit on comments;
+create policy authors_eigenedit on comments
+  using (true)
+  with check (
+    author = basic_auth.current_email()
+  );
+
+commit;

scripts/release_s3.sh

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

src/App.hs

@@ -1,239 +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 :: Text -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
-app v1schema 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)
-            echoRequested = lookup "Prefer" hdrs == Just "return=representation"
-        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)
-          ] $ if echoRequested then cs insertedJson else ""
-
-    ([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 v1schema 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 :: Text -> RequestHeaders -> Text
-requestedSchema v1schema hdrs =
-  case verStr of
-       Just [[_, ver]] -> if ver == "1" then v1schema else ver
-       _ -> v1schema
-
-  where verRegex = "version[ ]*=[ ]*([0-9]+)" :: String
-        accept = cs <$> lookup hAccept hdrs :: Maybe Text
-        verStr = (=~ verRegex) <$> accept :: Maybe [[Text]]
-
-jsonH :: Header
-jsonH = (hContentType, "application/json")
-
-handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
-              -> H.Tx P.Postgres s Response
-handleJsonObj reqBody handler = do
-  let p = eitherDecode reqBody
-  case p of
-    Left err ->
-      return $ responseLBS status400 [jsonH] jErr
-      where
-        jErr = encode . object $
-          [("message", String $ "Failed to parse JSON payload. " <> cs err)]
-    Right (Object o) -> handler o
-    Right _ ->
-      return $ responseLBS status400 [jsonH] jErr
-      where
-        jErr = encode . object $
-          [("message", String "Expecting a JSON object")]
-
-
-data TableOptions = TableOptions {
-  tblOptcolumns :: [Column]
-, tblOptpkey :: [Text]
-}
-
-instance ToJSON TableOptions where
-  toJSON t = object [
-      "columns" .= tblOptcolumns t
-    , "pkey"   .= tblOptpkey t ]

src/Auth.hs

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

src/Config.hs

@@ -1,60 +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
-  , configV1Schema :: String
-  }
-
-argParser :: Parser AppConfig
-argParser = AppConfig
-  <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database")
-  <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault)
-  <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role")
-  <*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role")
-  <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault)
-
-  <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault)
-  <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE" <> help "postgres role to use for non-authenticated requests")
-  <*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS")
-  <*> option auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault)
-  <*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault)
-
-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
-    , 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 . cs . strip . cs) $ BS.split ',' hdrs
-      Nothing -> []

src/Main.hs

@@ -1,70 +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 Network.Wai.Middleware.RequestLogger (logStdout)
-import Data.List (intercalate)
-import Data.Version (versionBranch)
-import qualified Hasql as H
-import qualified Hasql.Postgres as P
-import Options.Applicative hiding (columns)
-
-import Config (AppConfig(..), argParser, corsPolicy)
-
-main :: IO ()
-main = do
-  let opts = info (helper <*> argParser) $
-                fullDesc
-                <> progDesc (
-                    "PostgREST "
-                    <> prettyVersion
-                    <> " / create a REST API to an existing Postgres database"
-                )
-  conf <- execParser opts
-  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 = logStdout
-        . (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 (cs $ configV1Schema conf) body) req
-    either (respond . errResponse) respond resOrError
-
-  where
-    prettyVersion = intercalate "." $ map show $ versionBranch version

src/Middleware.hs

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

src/PgQuery.hs

@@ -1,220 +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 qualified Data.Text as T
-import Text.Regex.TDFA ( (=~) )
-import Text.Regex.TDFA.Text ()
-import qualified Network.HTTP.Types.URI as Net
-import qualified Data.ByteString.Char8 as BS
-import Data.Monoid
-import Data.Vector (empty)
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Functor ( (<$>) )
-import Control.Monad (join)
-import Data.String.Conversions (cs)
-import qualified Data.Aeson as JSON
-import qualified Data.List as L
-import 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 :: T.Text
-, qtName   :: T.Text
-} deriving (Show)
-
-data OrderTerm = OrderTerm {
-  otTerm :: T.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 -> [T.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 <> " (" <>
-    T.intercalate ", " (map pgFmtIdent cols) <>
-    ") values ("
-    <> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
-    <> ") returning row_to_json(" <> fromQt t <> ".*)")
-  empty True
-
-insertSelect :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
-insertSelect t [] _ = B.Stmt
-  ("insert into " <> fromQt t <> " default values returning *") empty True
-insertSelect t cols vals = B.Stmt
-  ("insert into " <> fromQt t <> " ("
-    <> T.intercalate ", " (map pgFmtIdent cols)
-    <> ") select "
-    <> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals))
-  empty True
-
-update :: QualifiedTable -> [T.Text] -> [JSON.Value] -> PStmt
-update t cols vals = B.Stmt
-  ("update " <> fromQt t <> " set ("
-    <> T.intercalate ", " (map pgFmtIdent cols)
-    <> ") = ("
-    <> T.intercalate ", " (map ((<> "::unknown") . pgFmtLit . unquoted) vals)
-    <> ")")
-  empty True
-
-wherePred :: Net.QueryItem -> PStmt
-wherePred (col, predicate) = B.Stmt
-  (" " <> cs (pgFmtIdent $ cs col) <> " " <> op <> " " <> cs sqlValue)
-  empty True
-
-  where
-    opCode:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
-    value = T.intercalate "." rest
-
-    star c = if c == '*' then '%' else c
-    unknownLiteral = (<> "::unknown ") . pgFmtLit
-
-    sqlValue = case opCode of
-            "like" -> unknownLiteral $ T.map star value
-            "ilike" -> unknownLiteral $ T.map star value
-            "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
-            _    -> unknownLiteral value
-
-    op = case opCode of
-         "eq"  -> "="
-         "gt"  -> ">"
-         "lt"  -> "<"
-         "gte" -> ">="
-         "lte" -> "<="
-         "neq" -> "<>"
-         "like"-> "like"
-         "ilike"-> "ilike"
-         "in"  -> "in"
-         _     -> "="
-
-orderParse :: Net.Query -> [OrderTerm]
-orderParse q =
-  mapMaybe orderParseTerm . T.split (==',') $ cs order
-  where
-    order = fromMaybe "" $ join (lookup "order" q)
-
-orderParseTerm :: T.Text -> Maybe OrderTerm
-orderParseTerm s =
-  case T.split (=='.') s of
-       [c,d] ->
-         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 :: T.Text -> T.Text
-pgFmtIdent x =
-  let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in
-  if escaped =~ danger
-    then "\"" <> escaped <> "\""
-    else escaped
-
-  where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: T.Text
-
-pgFmtLit :: T.Text -> T.Text
-pgFmtLit x =
-  let trimmed = trimNullChars x
-      escaped = "'" <> T.replace "'" "''" trimmed <> "'"
-      slashed = T.replace "\\" "\\\\" escaped in
-  cs $ if escaped =~ ("\\\\" :: T.Text)
-    then "E" <> slashed
-    else slashed
-
-trimNullChars :: T.Text -> T.Text
-trimNullChars = T.takeWhile (/= '\x0')
-
-fromQt :: QualifiedTable -> T.Text
-fromQt t = pgFmtIdent (qtSchema t) <> "." <> pgFmtIdent (qtName t)
-
-unquoted :: JSON.Value -> T.Text
-unquoted (JSON.String t) = t
-unquoted (JSON.Number n) =
-  cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
-unquoted (JSON.Bool b) = cs . show $ b
-unquoted _ = ""

src/PgStructure.hs

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

src/PostgREST/ApiRequest.hs

@@ -0,0 +1,217 @@
+module PostgREST.ApiRequest where
+
+import qualified Data.Aeson              as JSON
+import qualified Data.ByteString         as BS
+import qualified Data.ByteString.Lazy    as BL
+import qualified Data.Csv                as CSV
+import           Data.List               (find)
+import qualified Data.HashMap.Strict     as M
+import qualified Data.Set                as S
+import           Data.Maybe              (fromMaybe, isJust, isNothing,
+                                          listToMaybe, fromJust)
+import           Control.Monad           (join)
+import           Data.Monoid             ((<>))
+import           Data.String.Conversions (cs)
+import qualified Data.Text               as T
+import qualified Data.Vector             as V
+import           Network.Wai             (Request (..))
+import           Network.Wai.Parse       (parseHttpAccept)
+import           PostgREST.RangeQuery    (NonnegRange, rangeRequested)
+import           PostgREST.Types         (QualifiedIdentifier (..),
+                                          Schema, Payload(..),
+                                          UniformObjects(..))
+import           Data.Ranged.Ranges      (singletonRange)                                          
+
+type RequestBody = BL.ByteString
+
+-- | Types of things a user wants to do to tables/views/procs
+data Action = ActionCreate | ActionRead
+            | ActionUpdate | ActionDelete
+            | ActionInfo   | ActionInvoke
+            | ActionUnknown BS.ByteString deriving Eq
+-- | The target db object of a user action
+data Target = TargetIdent QualifiedIdentifier
+            | TargetRoot
+            | TargetUnknown [T.Text]
+-- | Enumeration of currently supported content types for
+-- route responses and upload payloads
+data ContentType = ApplicationJSON | TextCSV deriving Eq
+instance Show ContentType where
+  show ApplicationJSON = "application/json"
+  show TextCSV         = "text/csv"
+
+{-|
+  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 {
+  -- | Set to Nothing for unknown HTTP verbs
+    iAction :: Action
+  -- | Set to Nothing for malformed range
+  , iRange  :: Maybe NonnegRange
+  -- | Set to Nothing for strangely nested urls
+  , iTarget :: Target
+  -- | The content type the client most desires (or JSON if undecided)
+  , iAccepts :: Either BS.ByteString ContentType
+  -- | Data sent by client and used for mutation actions
+  , iPayload :: Maybe Payload
+  -- | If client wants created items echoed back
+  , iPreferRepresentation :: Bool
+  -- | If client wants first row as raw object
+  , iPreferSingular :: Bool
+  -- | Whether the client wants a result count (slower)
+  , iPreferCount :: Bool
+  -- | Filters on the result ("id", "eq.10")
+  , iFilters :: [(String, String)]
+  -- | &select parameter used to shape the response
+  , iSelect :: String
+  -- | &order parameter
+  , iOrder :: Maybe String
+  }
+
+-- | Examines HTTP request and translates it into user intent.
+userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest
+userApiRequest schema req reqBody =
+  let action = case method of
+                 "GET"     -> ActionRead
+                 "POST"    -> if isTargetingProc
+                                then ActionInvoke
+                                else ActionCreate
+                 "PATCH"   -> ActionUpdate
+                 "DELETE"  -> ActionDelete
+                 "OPTIONS" -> ActionInfo
+                 other     -> ActionUnknown other
+      target = case path of
+                 []            -> TargetRoot
+                 [table]       -> TargetIdent
+                                  $ QualifiedIdentifier schema table
+                 ["rpc", proc] -> TargetIdent
+                                  $ QualifiedIdentifier schema proc
+                 other         -> TargetUnknown other
+      payload = case pickContentType (lookupHeader "content-type") of
+        Right ApplicationJSON ->
+          either (PayloadParseError . cs)
+            (\val -> case ensureUniform (pluralize val) of
+              Nothing -> PayloadParseError "All object keys must match"
+              Just json -> PayloadJSON json)
+            (JSON.eitherDecode reqBody)
+        Right TextCSV ->
+          either (PayloadParseError . cs)
+            (\val -> case ensureUniform (csvToJson val) of
+              Nothing -> PayloadParseError "All lines must have same number of fields"
+              Just json -> PayloadJSON json)
+            (CSV.decodeByName reqBody)
+        Left accept ->
+          PayloadParseError $
+            "Content-type not acceptable: " <> accept
+      relevantPayload = case action of
+        ActionCreate -> Just payload
+        ActionUpdate -> Just payload
+        ActionInvoke -> Just payload
+        _            -> Nothing in
+
+  ApiRequest {
+    iAction = action
+  , iRange  = if singular then Just (singletonRange 0) else rangeRequested hdrs
+  , iTarget = target
+  , iAccepts = pickContentType $ lookupHeader "accept"
+  , iPayload = relevantPayload
+  , iPreferRepresentation = hasPrefer "return=representation"
+  , iPreferSingular = singular
+  , iPreferCount = not $ hasPrefer "count=none"
+  , iFilters = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]
+  , iSelect = if method == "DELETE"
+              then "*"
+              else fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
+  , iOrder = join $ lookup "order" qParams
+  }
+
+ where
+  path            = pathInfo req
+  method          = requestMethod req
+  isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
+  hdrs            = requestHeaders req
+  qParams         = [(cs k, cs <$> v)|(k,v) <- queryString req]
+  lookupHeader    = flip lookup hdrs
+  hasPrefer val   = any (\(h,v) -> h == "Prefer" && v == val) hdrs
+  singular        = hasPrefer "plurality=singular"
+
+
+
+-- PRIVATE ---------------------------------------------------------------
+
+{-|
+  Picks a preferred content type from an Accept header (or from
+  Content-Type as a degenerate case).
+
+  For example
+  text/csv -> TextCSV
+  */*      -> ApplicationJSON
+  text/csv, application/json -> TextCSV
+  application/json, text/csv -> ApplicationJSON
+-}
+pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType
+pickContentType accept
+  | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON
+  | has ctCsv = Right TextCSV
+  | otherwise = Left accept'
+ where
+  ctAll  = "*/*"
+  ctCsv  = "text/csv"
+  ctJson = "application/json"
+  Just accept' = accept
+  findInAccept = flip find $ parseHttpAccept accept'
+  has          = isJust . findInAccept . BS.isPrefixOf
+
+type CsvData = V.Vector (M.HashMap T.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 $ cs 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 UniformObjects
+ensureUniform :: JSON.Array -> Maybe UniformObjects
+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 (UniformObjects objs)
+    else Nothing

src/PostgREST/App.hs

@@ -0,0 +1,334 @@
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+--module PostgREST.App where
+module PostgREST.App (
+  app
+) where
+
+import           Control.Applicative
+import           Control.Arrow             ((***))
+import           Control.Monad             (join)
+import           Data.Bifunctor            (first)
+import qualified Data.ByteString.Lazy      as BL
+import           Data.Functor.Identity
+import           Data.List                 (find, sortBy, delete)
+import           Data.Maybe                (fromMaybe, fromJust, mapMaybe)
+import           Data.Ord                  (comparing)
+import           Data.Ranged.Ranges        (emptyRange)
+import           Data.String.Conversions   (cs)
+import           Data.Text                 (Text, replace, strip)
+import           Data.Tree
+
+import           Text.Parsec.Error
+import           Text.ParserCombinators.Parsec (parse)
+
+import           Network.HTTP.Base         (urlEncodeVars)
+import           Network.HTTP.Types.Header
+import           Network.HTTP.Types.Status
+import           Network.HTTP.Types.URI    (parseSimpleQuery)
+import           Network.Wai
+
+import           Data.Aeson
+import           Data.Aeson.Types (emptyArray)
+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           PostgREST.Config          (AppConfig (..))
+import           PostgREST.Parsers
+import           PostgREST.DbStructure
+import           PostgREST.RangeQuery
+import           PostgREST.ApiRequest   (ApiRequest(..), ContentType(..)
+                                            , Action(..), Target(..)
+                                            , userApiRequest)
+import           PostgREST.Types
+import           PostgREST.Auth            (tokenJWT)
+import           PostgREST.Error           (errResponse)
+
+import           PostgREST.QueryBuilder ( asJson
+                                        , callProc
+                                        , addJoinConditions
+                                        , sourceSubqueryName
+                                        , requestToQuery
+                                        , addRelations
+                                        , createReadStatement
+                                        , createWriteStatement
+                                        )
+
+import           Prelude
+
+app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response
+app dbStructure conf reqBody req =
+  let
+      -- TODO: blow up for Left values (there is a middleware that checks the headers)
+      contentType = either (const ApplicationJSON) id (iAccepts apiRequest)
+      contentTypeH = (hContentType, cs $ show contentType) in
+
+  case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
+
+    (ActionRead, TargetIdent qi, Nothing) ->
+      case selectQuery of
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
+        Right q -> do
+          let range = iRange apiRequest
+              singular = iPreferSingular apiRequest
+              stm = createReadStatement q range singular
+                    (iPreferCount apiRequest) (contentType == TextCSV)
+          if range == Just emptyRange
+          then return $ errResponse status416 "HTTP Range error"
+          else do
+            row <- H.maybeEx stm
+            let (tableTotal, queryTotal, _ , body) = extractQueryResult row
+            if singular
+            then return $ if queryTotal <= 0
+              then responseLBS status404 [] ""
+              else responseLBS status200 [contentTypeH] (fromMaybe "{}" body)
+            else do
+              let frm = fromMaybe 0 $ rangeOffset <$> range
+                  to = frm+queryTotal-1
+                  contentRange = contentRangeH frm to tableTotal
+                  status = rangeStatus frm to tableTotal
+                  canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
+                    . sortBy (comparing fst)
+                    . map (join (***) cs)
+                    . parseSimpleQuery
+                    $ rawQueryString req
+              return $ responseLBS status
+                [contentTypeH, contentRange,
+                  ("Content-Location",
+                    "/" <> cs (qiName qi) <>
+                      if Prelude.null canonical then "" else "?" <> cs canonical
+                  )
+                ] (fromMaybe "[]" body)
+
+    (ActionCreate, TargetIdent (QualifiedIdentifier _ table),
+     Just payload@(PayloadJSON (UniformObjects rows))) ->
+      case queries of
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
+        Right (sq,mq) -> do
+          let isSingle = (==1) $ V.length rows
+          let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
+          let stm = createWriteStatement sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload
+          row <- H.maybeEx stm
+          let (_, _, location, body) = extractQueryResult row
+          return $ responseLBS status201
+            [
+              contentTypeH,
+              (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
+            ]
+            $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else ""
+
+    (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON _)) ->
+      case queries of
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
+        Right (sq,mq) -> do
+          let stm = createWriteStatement sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload
+          row <- H.maybeEx stm
+          let (_, queryTotal, _, body) = extractQueryResult row
+              r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
+              s = case () of _ | queryTotal == 0 -> status404
+                               | iPreferRepresentation apiRequest -> status200
+                               | otherwise -> status204
+          return $ responseLBS s [contentTypeH, r]
+            $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else ""
+
+    (ActionDelete, TargetIdent _, Nothing) ->
+      case queries of
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
+        Right (sq,mq) -> do
+          let fakeload = PayloadJSON $ UniformObjects V.empty
+          let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) fakeload
+          row <- H.maybeEx stm
+          let (_, queryTotal, _, _) = extractQueryResult row
+          return $ if queryTotal == 0
+            then notFound
+            else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
+
+    (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> do
+      let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
+          pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
+          body = encode (TableOptions cols pkeys)
+          filterCol :: Schema -> TableName -> Column -> Bool
+          filterCol sc tb (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && t==tb
+          filterCol _ _ _ =  False
+      return $ responseLBS status200 [jsonH, allOrigins] $ cs body
+
+    (ActionInvoke, TargetIdent qi,
+     Just (PayloadJSON (UniformObjects payload))) -> do
+      exists <- doesProcExist qi
+      if exists
+        then do
+          let p = V.head payload
+              call = B.Stmt "select " V.empty True <>
+                asJson (callProc qi p)
+              jwtSecret = configJwtSecret conf
+
+          bodyJson :: Maybe (Identity Value) <- H.maybeEx call
+          returnJWT <- doesProcReturnJWT qi
+          return $ responseLBS status200 [jsonH]
+                 (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in
+                    if returnJWT
+                    then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
+                    else cs $ encode body)
+        else return notFound
+
+    (ActionRead, TargetRoot, Nothing) -> do
+      body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure))
+      return $ responseLBS status200 [jsonH] $ cs body
+
+    (ActionUnknown _, _, _) -> return notFound
+
+    (_, TargetUnknown _, _) -> return notFound
+
+    (_, _, Just (PayloadParseError e)) ->
+      return $ responseLBS status400 [jsonH] $
+        cs (formatGeneralError "Cannot parse request payload" (cs e))
+
+    (_, _, _) -> return notFound
+
+ where
+  notFound = responseLBS status404 [] ""
+  filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
+  allPrKeys = dbPrimaryKeys dbStructure
+  allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
+  schema = cs $ configSchema conf
+  apiRequest = userApiRequest schema req reqBody
+  selectQuery = requestToQuery schema <$> (DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest)
+  mutateQuery = requestToQuery schema <$> (DbMutate <$> buildMutateRequest apiRequest)
+  queries = (,) <$> selectQuery <*> mutateQuery
+
+rangeStatus :: Int -> Int -> Maybe Int -> Status
+rangeStatus _ _ Nothing = status200
+rangeStatus frm to (Just total)
+  | frm > total            = status416
+  | (1 + to - frm) < total = status206
+  | otherwise               = status200
+
+contentRangeH :: Int -> Int -> Maybe Int -> Header
+contentRangeH frm to total =
+    ("Content-Range", cs headerValue)
+    where
+      headerValue   = rangeString <> "/" <> totalString
+      rangeString
+        | totalNotZero && fromInRange = show frm <> "-" <> cs (show to)
+        | otherwise = "*"
+      totalString   = fromMaybe "*" (show <$> total)
+      totalNotZero  = fromMaybe True ((/=) 0 <$> total)
+      fromInRange   = frm <= to
+
+jsonH :: Header
+jsonH = (hContentType, "application/json")
+
+formatRelationError :: Text -> Text
+formatRelationError = formatGeneralError
+  "could not find foreign keys between these entities"
+
+formatParserError :: ParseError -> Text
+formatParserError e = formatGeneralError message details
+  where
+     message = cs $ show (errorPos e)
+     details = strip $ replace "\n" " " $ cs
+       $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
+
+formatGeneralError :: Text -> Text -> Text
+formatGeneralError message details = cs $ encode $ object [
+  "message" .= message,
+  "details" .= details]
+
+augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either Text ReadRequest
+augumentRequestWithJoin schema allRels request =
+  (first formatRelationError . addRelations schema allRels Nothing) request
+  >>= addJoinConditions schema
+
+buildReadRequest :: [Relation] -> ApiRequest -> Either Text ReadRequest
+buildReadRequest allRels apiRequest  =
+  augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> readRequest <*> ord) <*> flts)
+  where
+    selStr = iSelect apiRequest
+    orderS = iOrder apiRequest
+    action = iAction apiRequest
+    target = iTarget apiRequest
+    (schema, rootTableName) = fromJust $ -- Make it safe
+      case target of
+        (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
+        _ -> Nothing
+
+    rootName = if action == ActionRead
+      then rootTableName
+      else sourceSubqueryName
+    filters = if action == ActionRead
+      then iFilters apiRequest
+      else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
+    rels = case action of
+      ActionCreate -> fakeSourceRelations ++ allRels
+      ActionUpdate -> fakeSourceRelations ++ allRels
+      _       -> allRels
+      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
+    readRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
+    addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
+    flts = mapM pRequestFilter filters
+    ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
+
+buildMutateRequest :: ApiRequest -> Either Text MutateRequest
+buildMutateRequest apiRequest =
+  mutateApiRequest
+  where
+    action = iAction apiRequest
+    target = iTarget apiRequest
+    payload = fromJust $ iPayload apiRequest
+    rootTableName = -- TODO: Make it safe
+      case target of
+        (TargetIdent (QualifiedIdentifier _ t) ) -> t
+        _ -> undefined
+    mutateApiRequest = case action of
+      ActionCreate -> Insert rootTableName <$> pure payload
+      ActionUpdate -> Update rootTableName <$> pure payload <*> cond
+      ActionDelete -> Delete rootTableName <$> cond
+      _        -> Left "Unsupported HTTP verb"
+    mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
+    cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
+
+addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest
+addFilter ([], flt) (Node (q@(Select {flt_=flts}), i) forest) = Node (q {flt_=flt:flts}, i) forest
+addFilter (path, flt) (Node rn forest) =
+  case targetNode of
+    Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
+    Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
+  where
+    targetNodeName:remainingPath = path
+    (targetNode,restForest) = splitForest targetNodeName forest
+    splitForest name forst =
+      case maybeNode of
+        Nothing -> (Nothing,forest)
+        Just node -> (Just node, delete node forest)
+      where maybeNode = find ((name==).fst.snd.rootLabel) forst
+
+-- 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=sourceSubqueryName}}
+  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceSubqueryName}}
+  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceSubqueryName}) <$> rt}
+  | otherwise = Nothing
+
+data TableOptions = TableOptions {
+  tblOptcolumns :: [Column]
+, tblOptpkey    :: [Text]
+}
+
+instance ToJSON TableOptions where
+  toJSON t = object [
+      "columns" .= tblOptcolumns t
+    , "pkey"   .= tblOptpkey t ]
+
+
+extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
+                         -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
+extractQueryResult = fromMaybe (Just 0, 0, Just "", Just "")

src/PostgREST/Auth.hs

@@ -0,0 +1,84 @@
+{-# 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 (
+    setRole
+  , claimsToSQL
+  , jwtClaims
+  , tokenJWT
+  ) where
+
+import           Control.Monad           (join)
+import           Data.Aeson              (Value (..), Object)
+import           Data.Aeson.Types        (emptyObject, emptyArray)
+import           Data.Vector             as V (null, head)
+import           Data.Map                as M (fromList, toList)
+import           Data.Monoid             ((<>))
+import           Data.String.Conversions (cs)
+import           Data.Text               (Text)
+import           Data.Time.Clock         (NominalDiffTime)
+import           PostgREST.QueryBuilder  (pgFmtLit, pgFmtIdent, unquoted)
+import qualified Web.JWT                 as JWT
+import qualified Data.HashMap.Lazy       as H
+
+{-|
+  Receives a map of JWT claims and returns a list
+  of PostgreSQL statements to set the claims as user defined GUCs.
+  Except if we have a claim called role,
+  this one is mapped to a SET ROLE statement.
+  In case there is any problem decoding the JWT it returns Nothing.
+-}
+claimsToSQL :: JWT.ClaimsMap -> [Text]
+claimsToSQL = map setVar . toList
+  where
+    setVar ("role", String val) = setRole val
+    setVar (k, val) = "set local postgrest.claims." <> pgFmtIdent k <>
+                      " = " <> valueToVariable val <> ";"
+    valueToVariable = pgFmtLit . unquoted
+
+{-|
+  Receives the JWT secret (from config) and a JWT and
+  returns a map of JWT claims
+  In case there is any problem decoding the JWT it returns Nothing.
+-}
+jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> Maybe JWT.ClaimsMap
+jwtClaims secret input time =
+  case join $ claim JWT.exp of
+    Just expires ->
+      if JWT.secondsSinceEpoch expires > time
+        then customClaims
+        else Nothing
+    _ -> customClaims
+  where
+    decoded = JWT.decodeAndVerifySignature secret input
+    claim :: (JWT.JWTClaimsSet -> a) -> Maybe a
+    claim prop = prop . JWT.claims <$> decoded
+    customClaims = claim JWT.unregisteredClaims
+
+-- | Receives the name of a role and returns a SET ROLE statement
+setRole :: Text -> Text
+setRole role = "set local role " <> cs (pgFmtLit role) <> ";"
+
+
+{-|
+  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 a) = JWT.encodeSigned JWT.HS256 secret
+                               JWT.def { JWT.unregisteredClaims = fromHashMap o }
+                          where
+                            Object o = if V.null a then emptyObject else V.head a
+                            fromHashMap :: Object -> JWT.ClaimsMap
+                            fromHashMap = M.fromList . H.toList
+tokenJWT secret _          = tokenJWT secret emptyArray

src/PostgREST/Config.hs

@@ -0,0 +1,99 @@
+{-|
+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
+                        , AppConfig (..)
+                        )
+       where
+
+import           Control.Applicative
+import qualified Data.ByteString.Char8       as BS
+import qualified Data.CaseInsensitive        as CI
+import           Data.List                   (intercalate)
+import           Data.String.Conversions     (cs)
+import           Data.Text                   (strip)
+import           Data.Version                (versionBranch)
+import           Network.Wai
+import           Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
+import           Options.Applicative
+import           Paths_postgrest             (version)
+import           Web.JWT                     (Secret, secret)
+import           Prelude
+
+-- | Data type to store all command line options
+data AppConfig = AppConfig {
+    configDatabase  :: String
+  , configPort      :: Int
+  , configAnonRole  :: String
+  , configSchema    :: String
+  , configJwtSecret :: Secret
+  , configPool      :: Int
+  }
+
+argParser :: Parser AppConfig
+argParser = AppConfig
+  <$> argument str (help "database connection string" <> metavar "STRING")
+
+  <*> option auto  (long "port"       <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault)
+  <*> strOption    (long "anonymous"  <> short 'a' <> help "postgres role to use for non-authenticated requests" <> metavar "ROLE")
+  <*> strOption    (long "schema"     <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "1" <> showDefault)
+  <*> (secret . cs <$>
+      strOption    (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault))
+  <*> option auto  (long "pool"       <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault)
+
+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 . cs . strip . cs) $ BS.split ',' hdrs
+      Nothing -> []
+
+-- | User friendly version number
+prettyVersion :: String
+prettyVersion = intercalate "." $ map show $ versionBranch version
+
+-- | Function to read and parse options from the command line
+readOptions :: IO AppConfig
+readOptions = customExecParser parserPrefs opts
+  where
+    opts = info (helper <*> argParser) $
+                    fullDesc
+                    <> progDesc (
+                    "PostgREST "
+                    <> prettyVersion
+                    <> " / create a REST API to an existing Postgres database"
+                    )
+    parserPrefs = prefs showHelpOnError
+
+-- | Tells the minimum PostgreSQL version required by this version of PostgREST
+minimumPgVersion :: Integer
+minimumPgVersion = 90300

src/PostgREST/DbStructure.hs

@@ -0,0 +1,353 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+module PostgREST.DbStructure (
+  getDbStructure
+, accessibleTables
+, doesProcExist
+, doesProcReturnJWT
+) where
+
+import           Control.Applicative
+import           Control.Monad          (join)
+import           Data.Functor.Identity
+import           Data.List              (elemIndex, find, subsequences, sort, transpose)
+import           Data.Maybe             (fromMaybe, fromJust, isJust, mapMaybe, listToMaybe)
+import           Data.Monoid
+import           Data.Text              (Text, split)
+import qualified Hasql                  as H
+import qualified Hasql.Postgres         as P
+import qualified Hasql.Backend          as B
+import           PostgREST.Types
+
+import           GHC.Exts               (groupWith)
+import           Prelude
+
+getDbStructure :: Schema -> H.Tx P.Postgres s DbStructure
+getDbStructure schema = do
+  tabs <- allTables
+  cols <- allColumns tabs
+  syns <- allSynonyms cols
+  rels <- allRelations tabs cols
+  keys <- allPrimaryKeys tabs
+
+  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'
+    }
+
+doesProc :: forall c s. B.CxValue c Int =>
+            (Text -> Text -> B.Stmt c) -> QualifiedIdentifier -> H.Tx c s Bool
+doesProc stmt qi = do
+  row :: Maybe (Identity Int) <- H.maybeEx $ stmt (qiSchema qi) (qiName qi)
+  return $ isJust row
+
+doesProcExist :: QualifiedIdentifier -> H.Tx P.Postgres s Bool
+doesProcExist = doesProc [H.stmt|
+      SELECT 1
+      FROM   pg_catalog.pg_namespace n
+      JOIN   pg_catalog.pg_proc p
+      ON     pronamespace = n.oid
+      WHERE  nspname = ?
+      AND    proname = ?
+    |]
+
+doesProcReturnJWT :: QualifiedIdentifier -> H.Tx P.Postgres s Bool
+doesProcReturnJWT = doesProc [H.stmt|
+      SELECT 1
+      FROM   pg_catalog.pg_namespace n
+      JOIN   pg_catalog.pg_proc p
+      ON     pronamespace = n.oid
+      WHERE  nspname = ?
+      AND    proname = ?
+      AND    pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims'
+    |]
+
+accessibleTables :: [Table] -> H.Tx P.Postgres s [Table]
+accessibleTables allTabs = do
+  accessible <- H.listEx $ [H.stmt|
+      SELECT
+        n.nspname AS table_schema,
+        c.relname AS table_name
+      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') 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 table_schema, table_name
+    |]
+  let isAccessible table = isJust $ find (\(s,n) -> tableSchema table == s && tableName table == n) accessible
+  return $ filter isAccessible allTabs
+
+synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]]
+synonymousColumns allSyns cols = synCols'
+  where
+    syns = sort $ filter ((== colTable (head cols)) . colTable . fst) allSyns
+    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
+    -- lookupFn _ _ = False
+    relToFk col (Relation{relColumns=cols, relFColumns=colsF}) = ForeignKey <$> colF
+      where
+        pos = elemIndex col cols
+        colF = (colsF !!) <$> pos
+
+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 $ head 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 ++ 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)
+    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 . head) (synonymousColumns syns cols)
+        newTable = (colTable . head) <$> 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.Tx P.Postgres s [Table]
+allTables = do
+    rows <- H.listEx $ [H.stmt|
+      SELECT
+        n.nspname AS table_schema,
+        c.relname AS table_name,
+        c.relkind = 'r' OR (c.relkind IN ('v','f'))
+        AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8
+        OR (EXISTS
+          ( SELECT 1
+            FROM pg_trigger
+            WHERE pg_trigger.tgrelid = c.oid
+            AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable
+      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
+    |]
+    return $ map tableFromRow rows
+
+tableFromRow :: (Text, Text, Bool) -> Table
+tableFromRow (s, n, i) = Table s n i
+
+allColumns :: [Table] -> H.Tx P.Postgres s [Column]
+allColumns tabs = do
+  cols <- H.listEx $ [H.stmt|
+      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 (
+          SELECT
+              table_schema,
+              table_name,
+              column_name,
+              ordinal_position,
+              is_nullable,
+              data_type,
+              is_updatable,
+              character_maximum_length,
+              numeric_precision,
+              column_default,
+              udt_name
+          FROM information_schema.columns
+          WHERE table_schema NOT IN ('pg_catalog', 'information_schema')
+      ) AS info
+      LEFT OUTER JOIN (
+          SELECT
+              n.nspname AS s,
+              t.typname AS n,
+              array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals
+          FROM pg_type t
+          JOIN pg_enum e ON t.oid = e.enumtypid
+          JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace
+          GROUP BY s,n
+      ) AS enum_info ON (info.udt_name = enum_info.n)
+      ORDER BY schema, position
+  |]
+  return $ mapMaybe (columnFromRow tabs) cols
+
+columnFromRow :: [Table] ->
+                 (Text,       Text,      Text,
+                  Int,        Bool,      Text,
+                  Bool,       Maybe Int, Maybe Int,
+                  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.Tx P.Postgres s [Relation]
+allRelations tabs cols = do
+  rels <- H.listEx $ [H.stmt|
+    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)
+  |]
+  return $ mapMaybe (relationFromRow tabs cols) rels
+
+relationFromRow :: [Table] -> [Column] -> (Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation
+relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) =
+  if isJust table && isJust tableF && length cols == length rcs && length colsF == length frcs
+    then Just $ Relation (fromJust table) cols (fromJust tableF) colsF Child Nothing Nothing Nothing
+    else Nothing
+  where
+    findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs
+    findCols s t cs = filter (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col `elem` cs) allCols
+    table  = findTable rs rt
+    tableF = findTable frs frt
+    cols  = findCols rs rt rcs
+    colsF = findCols frs frt frcs
+
+allPrimaryKeys :: [Table] -> H.Tx P.Postgres s [PrimaryKey]
+allPrimaryKeys tabs = do
+  pks <- H.listEx $ [H.stmt|
+    SELECT
+        kc.table_schema,
+        kc.table_name,
+        kc.column_name
+    FROM
+        information_schema.table_constraints tc,
+        information_schema.key_column_usage kc
+    WHERE
+        tc.constraint_type = 'PRIMARY KEY' AND
+        kc.table_name = tc.table_name AND
+        kc.table_schema = tc.table_schema AND
+        kc.constraint_name = tc.constraint_name AND
+        kc.table_schema NOT IN ('pg_catalog', 'information_schema')
+    |]
+  return $ mapMaybe (pkFromRow tabs) pks
+
+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.Tx P.Postgres s [(Column,Column)]
+allSynonyms allCols = do
+  syns <- H.listEx $ [H.stmt|
+    WITH synonyms AS (
+      SELECT
+        vcu.table_schema AS src_table_schema,
+        vcu.table_name AS src_table_name,
+        vcu.column_name AS src_column_name,
+        view.table_schema AS syn_table_schema,
+        view.table_name AS syn_table_name,
+        view.view_definition AS view_definition
+      FROM
+        information_schema.views AS view,
+        information_schema.view_column_usage AS vcu
+      WHERE
+        view.table_schema = vcu.view_schema AND
+        view.table_name = vcu.view_name AND
+        view.table_schema NOT IN ('pg_catalog', 'information_schema') AND
+        (SELECT COUNT(*) FROM information_schema.view_table_usage WHERE view_schema = view.table_schema AND view_name = view.table_name) = 1
+    )
+    SELECT
+      src_table_schema, src_table_name, src_column_name,
+      syn_table_schema, syn_table_name,
+      (regexp_matches(view_definition, CONCAT('\.(', src_column_name, ')(?=,|$)'), 'gn'))[1]
+    FROM synonyms
+    UNION (
+      SELECT
+        src_table_schema, src_table_name, src_column_name,
+        syn_table_schema, syn_table_name,
+        (regexp_matches(view_definition, CONCAT('\.', src_column_name, '\sAS\s("?)(.+?)\1(,|$)'), 'gn'))[2] /* " <- for syntax highlighting */
+      FROM synonyms
+    )
+    |]
+  return $ mapMaybe (synonymFromRow allCols) syns
+
+synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column)
+synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
+  where
+    col1 = findCol s1 t1 c1
+    col2 = findCol s2 t2 c2
+    findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols

src/PostgREST/Error.hs

@@ -1,23 +1,29 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
-module Error (PgError, errResponse) where
+module PostgREST.Error (PgError, pgErrResponse, errResponse) where
 
-import qualified Hasql as H
-import qualified Hasql.Postgres as P
+
+import           Data.Aeson                ((.=))
+import qualified Data.Aeson                as JSON
+import           Data.String.Conversions   (cs)
+import           Data.String.Utils         (replace)
+import           Data.Text                 (Text)
+import qualified Data.Text                 as T
+import qualified Hasql                     as H
+import qualified Hasql.Postgres            as P
+import           Network.HTTP.Types.Header
 import qualified Network.HTTP.Types.Status as HT
-import qualified Data.Aeson as JSON
-import qualified Data.Text as T
-import Data.Aeson ((.=))
-import Data.String.Conversions (cs)
-import Data.String.Utils(replace)
-import Network.Wai(Response, responseLBS)
-import Network.HTTP.Types.Header
+import           Network.Wai               (Response, responseLBS)
 
 type PgError = H.SessionError P.Postgres
 
-errResponse :: PgError -> Response
-errResponse e = responseLBS (httpStatus e)
+errResponse :: HT.Status -> Text -> Response
+errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"])
+
+pgErrResponse :: PgError -> Response
+pgErrResponse e = responseLBS (httpStatus e)
   [(hContentType, "application/json")] (JSON.encode e)
 
 instance JSON.ToJSON PgError where

src/PostgREST/Main.hs

@@ -0,0 +1,79 @@
+module Main where
+
+
+import           PostgREST.App
+import           PostgREST.Config                     (AppConfig (..),
+                                                       minimumPgVersion,
+                                                       prettyVersion,
+                                                       readOptions)
+import           PostgREST.Error                      (pgErrResponse, PgError)
+import           PostgREST.Middleware
+import           PostgREST.DbStructure
+
+import           Control.Monad                        (unless)
+import           Control.Monad.IO.Class               (liftIO)
+import           Data.Aeson                           (encode)
+import           Data.Functor.Identity
+import           Data.Monoid                          ((<>))
+import           Data.String.Conversions              (cs)
+import           Data.Text                            (Text)
+import qualified Hasql                                as H
+import qualified Hasql.Postgres                       as P
+import           Network.Wai
+import           Network.Wai.Handler.Warp             hiding (Connection)
+import           Network.Wai.Middleware.RequestLogger (logStdout)
+import           System.IO                            (BufferMode (..),
+                                                       hSetBuffering, stderr,
+                                                       stdin, stdout)
+import           Web.JWT                              (secret)
+
+isServerVersionSupported :: H.Session P.Postgres IO Bool
+isServerVersionSupported = do
+  Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|]
+  return $ read (cs row) >= minimumPgVersion
+
+hasqlError :: PgError -> IO a
+hasqlError = error . cs . encode
+
+main :: IO ()
+main = do
+  hSetBuffering stdout LineBuffering
+  hSetBuffering stdin  LineBuffering
+  hSetBuffering stderr NoBuffering
+
+  conf <- readOptions
+  let port = configPort conf
+
+  unless (secret "secret" /= configJwtSecret conf) $
+    putStrLn "WARNING, running in insecure mode, JWT secret is the default value"
+  Prelude.putStrLn $ "Listening on port " ++
+    (show $ configPort conf :: String)
+
+  let pgSettings = P.StringSettings $ cs (configDatabase conf)
+      appSettings = setPort port
+                  . setServerName (cs $ "postgrest/" <> prettyVersion)
+                  $ defaultSettings
+      middle = logStdout . defaultMiddle
+
+  poolSettings <- maybe (fail "Improper session settings") return $
+    H.poolSettings (fromIntegral $ configPool conf) 30
+  pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings
+
+  supportedOrError <- H.session pool isServerVersionSupported
+  either hasqlError
+    (\supported ->
+      unless supported $
+        error (
+          "Cannot run in this PostgreSQL version, PostgREST needs at least "
+          <> show minimumPgVersion)
+    ) supportedOrError
+
+  let txSettings = Just (H.ReadCommitted, Just True)
+  dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf)
+  dbStructure <- either hasqlError return dbOrError
+
+  runSettings appSettings $ middle $ \ req respond -> do
+    body <- strictRequestBody req
+    resOrError <- liftIO $ H.session pool $ H.tx txSettings $
+      runWithClaims conf (app dbStructure conf body) req
+    either (respond . pgErrResponse) respond resOrError

src/PostgREST/Middleware.hs

@@ -0,0 +1,72 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module PostgREST.Middleware where
+
+import           Data.Maybe                    (fromMaybe)
+import           Data.Text
+import           Data.String.Conversions       (cs)
+import           Data.Time.Clock.POSIX         (getPOSIXTime)
+import qualified Hasql                         as H
+import qualified Hasql.Postgres                as P
+
+import           Network.HTTP.Types.Header     (hAccept, hAuthorization)
+import           Network.HTTP.Types.Status     (status415, status400)
+import           Network.Wai                   (Application, Request (..), Response,
+                                                requestHeaders)
+import           Network.Wai.Middleware.Cors   (cors)
+import           Network.Wai.Middleware.Gzip   (def, gzip)
+import           Network.Wai.Middleware.Static (only, staticPolicy)
+
+import           PostgREST.ApiRequest       (pickContentType)
+import           PostgREST.Auth                (setRole, jwtClaims, claimsToSQL)
+import           PostgREST.Config              (AppConfig (..), corsPolicy)
+import           PostgREST.Error               (errResponse)
+
+import           System.IO.Unsafe              (unsafePerformIO)
+
+import           Prelude hiding(concat)
+
+import qualified Data.Vector             as V
+import qualified Hasql.Backend           as B
+import qualified Data.Map.Lazy           as M
+
+runWithClaims :: forall s. AppConfig ->
+                 (Request -> H.Tx P.Postgres s Response) ->
+                 Request -> H.Tx P.Postgres s Response
+runWithClaims conf app req = do
+    _ <- H.unitEx $ stmt setAnon
+    let time = unsafePerformIO getPOSIXTime
+    case split (== ' ') (cs auth) of
+      ("Bearer" : tokenStr : _) ->
+        case jwtClaims jwtSecret tokenStr time of
+          Just claims ->
+            if M.member "role" claims
+            then do
+              mapM_ H.unitEx $ stmt <$> claimsToSQL claims
+              app req
+            else invalidJWT
+          _ -> invalidJWT
+      _ -> app req
+  where
+    stmt c = B.Stmt c V.empty True
+    hdrs = requestHeaders req
+    jwtSecret = configJwtSecret conf
+    auth = fromMaybe "" $ lookup hAuthorization hdrs
+    anon = cs $ configAnonRole conf
+    setAnon = setRole anon
+    invalidJWT = return $ errResponse status400 "Invalid JWT"
+
+unsupportedAccept :: Application -> Application
+unsupportedAccept app req respond =
+  case accept of
+    Left _ -> respond $ errResponse status415 "Unsupported Accept header, try: application/json"
+    Right _ -> app req respond
+  where accept = pickContentType $ lookup hAccept $ requestHeaders req
+
+defaultMiddle :: Application -> Application
+defaultMiddle =
+    gzip def
+  . cors corsPolicy
+  . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
+  . unsupportedAccept

src/PostgREST/Parsers.hs

@@ -0,0 +1,112 @@
+module PostgREST.Parsers
+-- ( parseGetRequest
+-- )
+where
+
+import           Control.Applicative hiding ((<$>))
+import           Data.Monoid
+import           Data.String.Conversions       (cs)
+import           Data.Text                     (Text)
+import           Data.Tree
+import           PostgREST.Types
+import           Text.ParserCombinators.Parsec hiding (many, (<|>))
+import           PostgREST.QueryBuilder (operators)
+
+pRequestSelect :: Text -> Parser ReadRequest
+pRequestSelect rootNodeName = do
+  fieldTree <- pFieldForest
+  return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree
+  where
+    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
+    treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =
+      case fldForest of
+        [] -> Node (q {select=fld:select q}, i) rForest
+        _  -> Node (q, i) (foldr treeEntry (Node (Select [] [fn] [] Nothing, (fn, Nothing)) []) fldForest:rForest)
+
+pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
+pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
+  where
+    treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k
+    opVal = parse pOpValueExp ("failed to parse filter (" ++ v ++ ")") v
+    path = fst <$> treePath
+    fld = snd <$> treePath
+    op = fst <$> opVal
+    val = snd <$> opVal
+
+ws :: Parser Text
+ws = cs <$> many (oneOf " \t")
+
+lexeme :: Parser a -> Parser a
+lexeme p = ws *> p <* ws
+
+pTreePath :: Parser (Path,Field)
+pTreePath = do
+  p <- pFieldName `sepBy1` pDelimiter
+  jp <- optionMaybe pJsonPath
+  let pp = map cs p
+      jpp = map cs <$> jp
+  return (init pp, (last pp, jpp))
+
+pFieldForest :: Parser [Tree SelectItem]
+pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
+
+pFieldTree :: Parser (Tree SelectItem)
+pFieldTree = try (Node <$> pSelect <*> between (char '{') (char '}') pFieldForest)
+          <|>     Node <$> pSelect <*> pure []
+
+pStar :: Parser Text
+pStar = cs <$> (string "*" *> pure ("*"::String))
+
+pFieldName :: Parser Text
+pFieldName =  cs <$> (many1 (letter <|> digit <|> oneOf "_")
+          <?> "field name (* or [a..z0..9_])")
+
+pJsonPathStep :: Parser Text
+pJsonPathStep = cs <$> try (string "->" *> pFieldName)
+
+pJsonPath :: Parser [Text]
+pJsonPath = (++) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) )
+
+pField :: Parser Field
+pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath
+
+pSelect :: Parser SelectItem
+pSelect = lexeme $
+  try ((,) <$> pField <*>((cs <$>) <$> optionMaybe (string "::" *> many letter)) )
+  <|> do
+    s <- pStar
+    return ((s, Nothing), Nothing)
+
+pOperator :: Parser Operator
+pOperator = cs <$> (pOp <?> "operator (eq, gt, ...)")
+  where pOp = foldl (<|>) empty $ map (try . string . cs . fst) operators
+
+pValue :: Parser FValue
+pValue = VText <$> (cs <$> many anyChar)
+
+pDelimiter :: Parser Char
+pDelimiter = char '.' <?> "delimiter (.)"
+
+pOperatiorWithNegation :: Parser Operator
+pOperatiorWithNegation = try ( (<>) <$> ( cs <$> string "not." ) <*>  pOperator) <|> pOperator
+
+pOpValueExp :: Parser (Operator, FValue)
+pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue)
+
+pOrder :: Parser [OrderTerm]
+pOrder = lexeme pOrderTerm `sepBy` char ','
+
+pOrderTerm :: Parser OrderTerm
+pOrderTerm =
+  try ( do
+    c <- pFieldName
+    _ <- pDelimiter
+    d <- (string "asc" *> pure OrderAsc)
+         <|> (string "desc" *> pure OrderDesc)
+    nls <- optionMaybe (pDelimiter *> (
+                 try(string "nullslast" *> pure OrderNullsLast)
+             <|> try(string "nullsfirst" *> pure OrderNullsFirst)
+           ))
+    return $ OrderTerm c d nls
+  )
+  <|> OrderTerm <$> (cs <$> pFieldName) <*> pure OrderAsc <*> pure Nothing

src/PostgREST/QueryBuilder.hs

@@ -0,0 +1,446 @@
+{-# 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 (
+    addRelations
+  , addJoinConditions
+  , asJson
+  , callProc
+  , createReadStatement
+  , createWriteStatement
+  , operators
+  , pgFmtIdent
+  , pgFmtLit
+  , requestToQuery
+  , sourceSubqueryName
+  , unquoted
+  ) where
+
+import qualified Hasql                   as H
+import qualified Hasql.Backend           as B
+import qualified Hasql.Postgres          as P
+
+import qualified Data.Aeson              as JSON
+
+import           PostgREST.RangeQuery    (NonnegRange, rangeLimit, rangeOffset)
+import           Control.Error           (note, fromMaybe, mapMaybe)
+import           Control.Monad           (join)
+import qualified Data.HashMap.Strict     as HM
+import           Data.List               (find)
+import           Data.Monoid             ((<>))
+import           Data.Text               (Text, intercalate, unwords, replace, isInfixOf, toLower, split)
+import qualified Data.Text as T          (map, takeWhile)
+import           Data.String.Conversions (cs)
+import           Control.Applicative     (empty, (<|>))
+import           Data.Tree               (Tree(..))
+import qualified Data.Vector as V
+import           PostgREST.Types
+import qualified Data.Map as M
+import           Text.Regex.TDFA         ((=~))
+import qualified Data.ByteString.Char8   as BS
+import           Data.Scientific         ( FPFormat (..)
+                                         , formatScientific
+                                         , isInteger
+                                         )
+import           Prelude hiding          (unwords)
+
+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
+
+createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres
+createReadStatement selectQuery range isSingle countTable asCsv =
+  B.Stmt (
+    wrapQuery selectQuery [
+      if countTable then countAllF else countNoneF,
+      countF,
+      "null", -- location header can not be calucalted
+      if asCsv
+        then asCsvF
+        else if isSingle then asJsonSingleF else asJsonF
+    ] selectStarF range
+  ) V.empty True
+
+createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool ->
+                        [Text] -> Bool -> Payload -> B.Stmt P.Postgres
+createWriteStatement _ _ _ _ _ _ (PayloadParseError _) = undefined
+createWriteStatement selectQuery mutateQuery isSingle echoRequested
+                     pKeys asCsv (PayloadJSON (UniformObjects rows)) =
+  B.Stmt (
+    wrapQuery mutateQuery [
+      countNoneF, -- when updateing it does not make sense
+      countF,
+      if isSingle then locationF pKeys else "null",
+      if echoRequested
+      then
+        if asCsv
+        then asCsvF
+        else if isSingle then asJsonSingleF else asJsonF
+      else "null"
+
+    ] selectQuery Nothing
+  ) (V.singleton . B.encodeValue . JSON.Array . V.map JSON.Object $ rows) True
+
+addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest
+addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
+  case parentNode of
+    Nothing -> Node (query, (table, Nothing)) <$> updatedForest
+    (Just (Node (_, (parentTable, _)) _)) -> Node <$> (addRel n <$> rel) <*> updatedForest
+      where
+        rel = note ("no relation between " <> table <> " and " <> parentTable)
+            $  findRelation schema table parentTable
+           <|> findRelation schema parentTable table
+        addRel :: (ReadQuery, (NodeName, Maybe Relation)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation))
+        addRel (q, (t, _)) r = (q, (t, Just r))
+  where
+    updatedForest = mapM (addRelations schema allRelations (Just node)) forest
+    findRelation s t1 t2 =
+      find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations
+
+addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest
+addJoinConditions schema (Node (query, (n, r)) forest) =
+  case r of
+    Nothing -> Node (updatedQuery, (n,r))  <$> updatedForest -- this is the root node
+    Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(n,r)) <$> updatedForest
+    Just (Relation{relType=Parent}) -> Node (updatedQuery, (n,r)) <$> updatedForest
+    Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) ->
+      Node (qq, (n, r)) <$> updatedForest
+      where
+         q = addCond updatedQuery (getJoinConditions rel)
+         qq = q{from=tableName linkTable : from q}
+    _ -> Left "unknown relation"
+  where
+    -- add parentTable and parentJoinConditions to the query
+    updatedQuery = foldr (flip addCond) query parentJoinConditions
+      where
+        parentJoinConditions = map (getJoinConditions . snd) parents
+        parents = mapMaybe (getParents . rootLabel) forest
+        getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)
+        getParents _ = Nothing
+    updatedForest = mapM (addJoinConditions schema) forest
+    addCond q con = q{flt_=con ++ flt_ q}
+
+asJson :: StatementT
+asJson s = s {
+  B.stmtTemplate =
+    "array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from ("
+    <> B.stmtTemplate s <> ") t" }
+
+callProc :: QualifiedIdentifier -> JSON.Object -> PStmt
+callProc qi params = do
+  let args = intercalate "," $ map assignment (HM.toList params)
+  B.Stmt ("select * from " <> fromQi qi <> "(" <> args <> ")") empty True
+  where
+    assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
+
+operators :: [(Text, SqlFragment)]
+operators = [
+  ("eq", "="),
+  ("gte", ">="), -- has to be before gt (parsers)
+  ("gt", ">"),
+  ("lte", "<="), -- has to be before lt (parsers)
+  ("lt", "<"),
+  ("neq", "<>"),
+  ("like", "like"),
+  ("ilike", "ilike"),
+  ("in", "in"),
+  ("notin", "not in"),
+  ("isnot", "is not"), -- has to be before is (parsers)
+  ("is", "is"),
+  ("@@", "@@"),
+  ("@>", "@>"),
+  ("<@", "<@")
+  ]
+
+pgFmtIdent :: SqlFragment -> SqlFragment
+pgFmtIdent x =
+ let escaped = replace "\"" "\"\"" (trimNullChars $ cs x) in
+ if (cs escaped :: BS.ByteString) =~ danger
+   then "\"" <> escaped <> "\""
+   else escaped
+ where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString
+
+pgFmtLit :: SqlFragment -> SqlFragment
+pgFmtLit x =
+ let trimmed = trimNullChars x
+     escaped = "'" <> replace "'" "''" trimmed <> "'"
+     slashed = replace "\\" "\\\\" escaped in
+ if "\\\\" `isInfixOf` escaped
+   then "E" <> slashed
+   else slashed
+
+requestToQuery :: Schema -> DbRequest -> SqlQuery
+requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined
+requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined
+requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest)) =
+  query
+  where
+    -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
+    -- of our WITH query part
+    tblSchema tbl = if tbl == sourceSubqueryName then "" else schema
+    qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl
+    toQi t = QualifiedIdentifier (tblSchema t) t
+    query = unwords [
+      ("WITH " <> intercalate ", " (map fst withs)) `emptyOnNull` withs,
+      "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
+      "FROM ", intercalate ", " (map (fromQi . toQi) tbls ++ map snd withs),
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
+      orderF (fromMaybe [] ord)
+      ]
+    (withs, selects) = foldr getQueryParts ([],[]) forest
+    getQueryParts :: Tree ReadNode -> ([(SqlFragment, Text)], [SqlFragment]) -> ([(SqlFragment,Text)], [SqlFragment])
+    getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
+      where
+        sel = "("
+           <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
+           <> "FROM (" <> subquery <> ") " <> table
+           <> ") AS " <> table
+           where subquery = requestToQuery schema (DbRead (Node n forst))
+    getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
+      where
+        sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
+        wit = (table <> " AS ( " <> subquery <> " )", table)
+          where subquery = requestToQuery schema (DbRead (Node n forst))
+    getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
+      where
+        sel = "("
+           <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
+           <> "FROM (" <> subquery <> ") " <> table
+           <> ") AS " <> table
+           where subquery = requestToQuery schema (DbRead (Node n forst))
+    --the following is just to remove the warning
+    --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
+    --posible relations are Child Parent Many
+    getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
+requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) =
+  let qi = QualifiedIdentifier schema mainTbl
+      cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
+      colsString = intercalate ", " cols in
+  unwords [
+    "INSERT INTO ", fromQi qi,
+    " (" <> colsString <> ")" <>
+    " SELECT " <> colsString <>
+    " FROM json_populate_recordset(null::" , fromQi qi, ", ?)",
+    " RETURNING " <> fromQi qi <> ".*"
+    ]
+requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) =
+  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 (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
+        "RETURNING " <> fromQi qi <> ".*"
+        ]
+    Nothing -> undefined
+  where
+    qi = QualifiedIdentifier schema mainTbl
+
+requestToQuery schema (DbMutate (Delete mainTbl conditions)) =
+  query
+  where
+    qi = QualifiedIdentifier schema mainTbl
+    query = unwords [
+      "DELETE FROM ", fromQi qi,
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
+      "RETURNING " <> fromQi qi <> ".*"
+      ]
+
+sourceSubqueryName :: SqlFragment
+sourceSubqueryName = "pg_source"
+
+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 v = cs $ JSON.encode v
+
+-- private functions
+asCsvF :: SqlFragment
+asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
+  where
+    asCsvHeaderF =
+      "(SELECT string_agg(a.k, ',')" <>
+      "  FROM (" <>
+      "    SELECT json_object_keys(r)::TEXT as k" <>
+      "    FROM ( " <>
+      "      SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <>
+      "    ) s" <>
+      "  ) a" <>
+      ")"
+    asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')"
+
+asJsonF :: SqlFragment
+asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying"
+
+asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
+asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying "
+
+countAllF :: SqlFragment
+countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )"
+
+countF :: SqlFragment
+countF = "pg_catalog.count(t)"
+
+countNoneF :: SqlFragment
+countNoneF = "null"
+
+locationF :: [Text] -> SqlFragment
+locationF pKeys =
+    "(" <>
+    " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss  limit 1)" <>
+    " SELECT string_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 <> "')"
+    ) <>
+    ")"
+
+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)
+  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) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}}))
+
+emptyOnNull :: Text -> [a] -> Text
+emptyOnNull val x = if null x then "" else val
+
+orderF :: [OrderTerm] -> SqlFragment
+orderF ts =
+  if null ts
+    then ""
+    else "ORDER BY " <> clause
+  where
+    clause = intercalate "," (map queryTerm ts)
+    queryTerm :: OrderTerm -> Text
+    queryTerm t = " "
+           <> cs (pgFmtIdent $ otTerm t) <> " "
+           <> (cs.show) (otDirection t) <> " "
+           <> maybe "" (cs.show) (otNullOrder t) <> " "
+
+insertableValue :: JSON.Value -> SqlFragment
+insertableValue JSON.Null = "null"
+insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v
+
+whiteList :: Text -> SqlFragment
+whiteList val = fromMaybe
+  (cs (pgFmtLit val) <> "::unknown ")
+  (find ((==) . toLower $ val) ["null","true","false"])
+
+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) = pgFmtField table f <> pgFmtAsJsonPath jp
+pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAsJsonPath jp
+
+pgFmtCondition :: QualifiedIdentifier -> Filter -> SqlFragment
+pgFmtCondition table (Filter (col,jp) ops val) =
+  notOp <> " " <> sqlCol  <> " " <> pgFmtOperator opCode <> " " <>
+    if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue
+  where
+    headPredicate:rest = split (=='.') ops
+    hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
+    opCode      = hasNot (head rest) headPredicate
+    notOp       = hasNot headPredicate ""
+    sqlCol = case val of
+      VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp
+      VForeignKey qi _ -> pgFmtColumn qi col
+    sqlValue = valToStr val
+    getInner v = case v of
+      VText s -> s
+      _      -> ""
+    valToStr v = case v of
+      VText s -> pgFmtValue opCode s
+      VForeignKey (QualifiedIdentifier s _) (ForeignKey Column{colTable=Table{tableName=ft}, colName=fc}) -> pgFmtColumn qi fc
+        where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft
+      _ -> ""
+
+pgFmtValue :: Text -> Text -> SqlFragment
+pgFmtValue opCode val =
+ case opCode of
+   "like" -> unknownLiteral $ T.map star val
+   "ilike" -> unknownLiteral $ T.map star val
+   "in" -> "(" <> intercalate ", " (map unknownLiteral $ split (==',') val) <> ") "
+   "notin" -> "(" <> intercalate ", " (map unknownLiteral $ split (==',') val) <> ") "
+   "@@" -> "to_tsquery(" <> unknownLiteral val <> ") "
+   _    -> unknownLiteral val
+ where
+   star c = if c == '*' then '%' else c
+   unknownLiteral = (<> "::unknown ") . pgFmtLit
+
+pgFmtOperator :: Text -> SqlFragment
+pgFmtOperator opCode = fromMaybe "=" $ M.lookup opCode operatorsMap
+  where
+    operatorsMap = M.fromList operators
+
+pgFmtJsonPath :: Maybe JsonPath -> SqlFragment
+pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
+pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )
+pgFmtJsonPath _ = ""
+
+pgFmtAsJsonPath :: Maybe JsonPath -> SqlFragment
+pgFmtAsJsonPath Nothing = ""
+pgFmtAsJsonPath (Just xx) = " AS " <> last xx
+
+trimNullChars :: Text -> Text
+trimNullChars = T.takeWhile (/= '\x0')
+
+withSourceF :: SqlFragment -> SqlFragment
+withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")"
+
+fromF :: SqlFragment -> SqlFragment -> SqlFragment
+fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t"
+
+limitF :: Maybe NonnegRange -> SqlFragment
+limitF r  = "LIMIT " <> limit <> " OFFSET " <> offset
+  where
+    limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
+    offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
+
+selectStarF :: SqlFragment
+selectStarF = "SELECT * FROM " <> sourceSubqueryName
+
+wrapQuery :: SqlQuery -> [Text] -> Text ->  Maybe NonnegRange -> SqlQuery
+wrapQuery source selectColumns returnSelect range =
+  withSourceF source <>
+  " SELECT " <>
+  intercalate ", " selectColumns <>
+  " " <>
+  fromF returnSelect ( limitF range )

src/PostgREST/RangeQuery.hs

@@ -1,4 +1,4 @@
-module RangeQuery (
+module PostgREST.RangeQuery (
   rangeParse
 , rangeRequested
 , rangeLimit
@@ -6,19 +6,22 @@ module RangeQuery (
 , NonnegRange
 ) where
 
-import Control.Applicative
-import Network.HTTP.Types.Header
 
-import qualified Data.ByteString.Char8 as BS
+import           Control.Applicative
+import           Network.HTTP.Types.Header
+import           PostgREST.Types           ()
 
-import Data.Ranged.Boundaries
-import Data.Ranged.Ranges
+import qualified Data.ByteString.Char8     as BS
+import           Data.Ranged.Boundaries
+import           Data.Ranged.Ranges
 
-import Data.String.Conversions (cs)
-import Text.Regex.TDFA ((=~))
-import Text.Read (readMaybe)
+import           Data.String.Conversions   (cs)
+import           Text.Read                 (readMaybe)
+import           Text.Regex.TDFA           ((=~))
 
-import Data.Maybe (fromMaybe, listToMaybe)
+import           Data.Maybe                (fromMaybe, listToMaybe)
+
+import           Prelude
 
 type NonnegRange = Range Int
 
@@ -39,15 +42,15 @@ 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
+  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
+  case rangeLower range of
+    BoundaryBelow from -> from
+    _ -> error "range without lower bound" -- should never happen
 
 rangeGeq :: Int -> NonnegRange
 rangeGeq n =

src/PostgREST/Types.hs

@@ -0,0 +1,156 @@
+module PostgREST.Types where
+import Data.Text
+import Data.Tree
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString      as BS
+import qualified Data.Vector          as V
+import Data.Aeson
+
+data DbStructure = DbStructure {
+  dbTables :: [Table]
+, dbColumns :: [Column]
+, dbRelations :: [Relation]
+, dbPrimaryKeys :: [PrimaryKey]
+} 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)
+
+data ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord)
+
+data Column =
+    Column {
+      colTable     :: Table
+    , colName      :: Text
+    , colPosition  :: Int
+    , colNullable  :: Bool
+    , colType      :: Text
+    , colUpdatable :: Bool
+    , colMaxLen    :: Maybe Int
+    , colPrecision :: Maybe Int
+    , colDefault   :: Maybe Text
+    , colEnum      :: [Text]
+    , colFK        :: Maybe ForeignKey
+    }
+  | Star { colTable :: Table }
+  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      :: Text
+, otDirection :: OrderDirection
+, otNullOrder :: Maybe OrderNulls
+} deriving (Show, Eq)
+
+data QualifiedIdentifier = QualifiedIdentifier {
+  qiSchema :: Schema
+, qiName   :: TableName
+} deriving (Show, Eq)
+
+
+data RelationType = Child | Parent | Many 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 UniformObjects = UniformObjects (V.Vector Object)
+  deriving (Show, Eq)
+
+-- | When Hasql supports the COPY command then we can
+-- have a special payload just for CSV, but until
+-- then CSV is converted to a JSON array.
+data Payload = PayloadJSON UniformObjects
+             | PayloadParseError BS.ByteString
+             deriving (Show, Eq)
+
+type Operator = Text
+data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
+type FieldName = Text
+type JsonPath = [Text]
+type Field = (FieldName, Maybe JsonPath)
+type Cast = Text
+type NodeName = Text
+type SelectItem = (Field, Maybe Cast)
+type Path = [Text]
+data ReadQuery = Select { select::[SelectItem], from::[Text], flt_::[Filter], order::Maybe [OrderTerm] }  deriving (Show, Eq)
+data MutateQuery = Insert { in_::Text, qPayload::Payload }
+                 | Delete { in_::Text, where_::[Filter] }
+                 | Update { in_::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq)
+data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
+type ReadNode = (ReadQuery, (NodeName, Maybe Relation))
+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
+  _ == _ = False

src/Types.hs

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

stack.yaml

@@ -0,0 +1,7 @@
+flags: {}
+packages:
+- '.'
+extra-deps:
+  - Ranged-sets-0.3.0
+  - packdeps-0.4.1
+resolver: nightly-2015-10-27

test/Feature/AuthSpec.hs

@@ -18,13 +18,53 @@ spec = beforeAll
   it "hides tables that anonymous does not own" $
     get "/authors_only" `shouldRespondWith` 404
 
-  it "indicates login failure" $ do
-    let auth = authHeader "postgrest_test_author" "fakefake"
-    request methodGet "/authors_only" [auth] ""
-      `shouldRespondWith` 401
+  it "returns jwt functions as jwt tokens" $
+    post "/rpc/login" [json| { "id": "jdoe", "pass": "1234" } |]
+      `shouldRespondWith` ResponseMatcher {
+          matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |]
+        , matchStatus = 200
+        , matchHeaders = ["Content-Type" <:> "application/json"]
+        }
 
   it "allows users with permissions to see their tables" $ do
-    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    let auth = authHeader "jdoe" "1234"
+    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` 400
+
+  it "hides tables from users with invalid JWT" $ do
+    let auth = authHeaderJWT "ey9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 400
+
+  it "should fail when jwt contains no claims" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.MKYc_lOECtB0LJOiykilAdlHodB-I0_id2qHKq35dmc"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 400
+
+  it "hides tables from users with JWT that contain no claims about role" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.zyohGMnrDy4_8eJTl6I2AUXO3MeCCiwR24aGWRkTE9o"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 400
+
+  it "recovers after 400 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

test/Feature/CorsSpec.hs

@@ -22,7 +22,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 +41,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"

test/Feature/InsertSpec.hs

@@ -1,6 +1,6 @@
 module Feature.InsertSpec where
 
-import Test.Hspec
+import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus))
@@ -9,6 +9,7 @@ import SpecHelper
 
 import qualified Data.Aeson as JSON
 import Data.Maybe (fromJust)
+import Text.Heredoc
 import Network.HTTP.Types.Header
 import Network.HTTP.Types
 import Control.Monad (replicateM_)
@@ -18,16 +19,38 @@ import TestTypes(IncPK(..), CompoundPK(..))
 spec :: Spec
 spec = afterAll_ resetDb $ around withApp $ do
   describe "Posting new record" $ do
-    after_ (clearTable "menagerie") . it "accepts disparate json types" $ do
-      p <- post "/menagerie"
-        [json| {
-          "integer": 13, "double": 3.14159, "varchar": "testing!"
-        , "boolean": false, "date": "1900-01-01", "money": "$3.99"
-        , "enum": "foo"
-        } |]
-      liftIO $ do
-        simpleBody p `shouldBe` ""
-        simpleStatus p `shouldBe` created201
+    after_ (clearTable "menagerie") . context "disparate csv types" $ do
+      it "accepts disparate json types" $ do
+        p <- post "/menagerie"
+          [json| {
+            "integer": 13, "double": 3.14159, "varchar": "testing!"
+          , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+          , "enum": "foo"
+          } |]
+        liftIO $ do
+          simpleBody p `shouldBe` ""
+          simpleStatus p `shouldBe` created201
+
+      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` ResponseMatcher {
+            matchBody    = Just [str|{"integer":14,"varchar":"testing!"}|]
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "application/json"]
+          }
+
+      it "includes related data after insert" $
+        request methodPost "/projects?select=id,name,clients{id,name}" [("Prefer", "return=representation")]
+          [str|{"id":5,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|{"id":5,"name":"New Project","clients":{"id":2,"name":"Apple"}}|]
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "application/json", "Location" <:> "/projects?id=eq.5"]
+          }
+
 
     context "with no pk supplied" $ do
       context "into a table with auto-incrementing pk" . after_ (clearTable "auto_incrementing_pk") $
@@ -66,6 +89,15 @@ spec = afterAll_ resetDb $ around withApp $ do
             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz"
             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" . after_ (clearTable "compound_pk") $
       it "builds response location header appropriately" $
         post "/compound_pk" [json| { "k1":12, "k2":42 } |]
@@ -77,24 +109,126 @@ spec = afterAll_ resetDb $ around withApp $ do
 
     context "with invalid json payload" $
       it "fails with 400 and error" $
-        post "/simple_pk" "}{ x = 2"
+        post "/simple_pk" "}{ x = 2" `shouldRespondWith` 400
+
+    context "jsonb" . after_ (clearTable "json") $ do
+      it "serializes nested object" $ do
+        let inserted = [json| { "data": { "foo":"bar" } } |]
+        request methodPost "/json"
+                     [("Prefer", "return=representation")]
+                     inserted
           `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [json| {"message":"Failed to parse JSON payload. Failed reading: satisfy"} |]
-          , matchStatus  = 400
-          , matchHeaders = []
+            matchBody    = Just inserted
+          , matchStatus  = 201
+          , matchHeaders = ["Location" <:> [str|/json?data=eq.{"foo":"bar"}|]]
           }
 
+        -- TODO! the test above seems right, why was the one below working before and not now
+        -- p <- request methodPost "/json" [("Prefer", "return=representation")] inserted
+        -- liftIO $ do
+        --   simpleBody p `shouldBe` inserted
+        --   simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%7B%22foo%22%3A%22bar%22%7D"
+        --   simpleStatus p `shouldBe` created201
+
+      it "serializes nested array" $ do
+        let inserted = [json| { "data": [1,2,3] } |]
+        request methodPost "/json"
+                     [("Prefer", "return=representation")]
+                     inserted
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just inserted
+          , matchStatus  = 201
+          , matchHeaders = ["Location" <:> [str|/json?data=eq.[1,2,3]|]]
+          }
+        -- TODO! the test above seems right, why was the one below working before and not now
+        -- p <- request methodPost "/json" [("Prefer", "return=representation")] inserted
+        -- liftIO $ do
+        --   simpleBody p `shouldBe` inserted
+        --   simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%5B1%2C2%2C3%5D"
+        --   simpleStatus p `shouldBe` created201
+
+  describe "CSV insert" $ do
+
+    after_ (clearTable "menagerie") . context "disparate csv types" $
+      it "succeeds with multipart response" $ do
+        pendingWith "Decide on what to do with CSV insert"
+        let inserted = [str|integer,double,varchar,boolean,date,money,enum
+            |13,3.14159,testing!,false,1900-01-01,$3.99,foo
+            |12,0.1,a string,true,1929-10-01,12,bar
+            |]
+        request methodPost "/menagerie" [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")] inserted
+
+           `shouldRespondWith` ResponseMatcher {
+             matchBody    = Just inserted
+           , matchStatus  = 201
+           , matchHeaders = ["Content-Type" <:> "text/csv"]
+           }
+        -- p <- request methodPost "/menagerie" [("Content-Type", "text/csv")]
+        --        [str|integer,double,varchar,boolean,date,money,enum
+        --            |13,3.14159,testing!,false,1900-01-01,$3.99,foo
+        --            |12,0.1,a string,true,1929-10-01,12,bar
+        --            |]
+        -- liftIO $ do
+        --   simpleBody p `shouldBe` "Content-Type: application/json\nLocation: /menagerie?integer=eq.13\n\n\n--postgrest_boundary\nContent-Type: application/json\nLocation: /menagerie?integer=eq.12\n\n"
+        --   simpleStatus p `shouldBe` created201
+
+    after_ (clearTable "no_pk") . context "requesting full representation" $ do
+      it "returns full details of inserted record" $
+        request methodPost "/no_pk"
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"),  ("Prefer", "return=representation")]
+                     "a,b\nbar,baz"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "a,b\nbar,baz"
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "text/csv",
+                            "Location" <:> "/no_pk?a=eq.bar&b=eq.baz"]
+          }
+
+      -- it "can post nulls (old way)" $ do
+      --   pendingWith "changed the response when in csv mode"
+      --   request methodPost "/no_pk"
+      --                [("Content-Type", "text/csv"), ("Prefer", "return=representation")]
+      --                "a,b\nNULL,foo"
+      --     `shouldRespondWith` ResponseMatcher {
+      --       matchBody    = Just [json| { "a":null, "b":"foo" } |]
+      --     , matchStatus  = 201
+      --     , matchHeaders = ["Content-Type" <:> "application/json",
+      --                       "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
+      --     }
+      it "can post nulls" $
+        request methodPost "/no_pk"
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
+                     "a,b\nNULL,foo"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "a,b\n,foo"
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "text/csv",
+                            "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
+          }
+
+
+    after_ (clearTable "no_pk") . context "with wrong number of columns" $
+      it "fails for too few" $ do
+        p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
+        liftIO $ simpleStatus p `shouldBe` badRequest400
+      -- it does not fail because the extra columns are ignored
+      -- it "fails for too many" $ do
+      --   p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz,bat,bad"
+      --   liftIO $ simpleStatus p `shouldBe` badRequest400
+
   describe "Putting record" $ do
 
     context "to unkonwn uri" $
-      it "gives a 404" $
+      it "gives a 404" $ do
+        pendingWith "Decide on PUT usefullness"
         request methodPut "/fake" []
           [json| { "real": false } |]
             `shouldRespondWith` 404
 
     context "to a known uri" $ do
       context "without a fully-specified primary key" $
-        it "is not an allowed operation" $
+        it "is not an allowed operation" $ do
+          pendingWith "Decide on PUT usefullness"
           request methodPut "/compound_pk?k1=eq.12" []
             [json| { "k1":12, "k2":42 } |]
               `shouldRespondWith` 405
@@ -102,13 +236,15 @@ spec = afterAll_ resetDb $ around withApp $ do
       context "with a fully-specified primary key" $ do
 
         context "not specifying every column in the table" $
-          it "is rejected for lack of idempotence" $
+          it "is rejected for lack of idempotence" $ do
+            pendingWith "Decide on PUT usefullness"
             request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
               [json| { "k1":12, "k2":42 } |]
                 `shouldRespondWith` 400
 
         context "specifying every column in the table" . after_ (clearTable "compound_pk") $ do
           it "can create a new record" $ do
+            pendingWith "Decide on PUT usefullness"
             p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
                  [json| { "k1":12, "k2":42, "extra":3 } |]
             liftIO $ do
@@ -125,6 +261,7 @@ spec = afterAll_ resetDb $ around withApp $ do
               compoundExtra record `shouldBe` Just 3
 
           it "can update an existing record" $ do
+            pendingWith "Decide on PUT usefullness"
             _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
                  [json| { "k1":12, "k2":42, "extra":4 } |]
             _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
@@ -139,7 +276,8 @@ spec = afterAll_ resetDb $ around withApp $ do
 
       context "with an auto-incrementing primary key" . after_ (clearTable "auto_incrementing_pk") $
 
-        it "succeeds with 204" $
+        it "succeeds with 204" $ do
+          pendingWith "Decide on PUT usefullness"
           request methodPut "/auto_incrementing_pk?id=eq.1" []
                [json| {
                  "id":1,
@@ -162,10 +300,10 @@ spec = afterAll_ resetDb $ around withApp $ do
             `shouldRespondWith` 404
 
     context "on an empty table" $
-      it "succeeds with no effect" $
+      it "indicates no records found to update" $
         request methodPatch "/simple_pk" []
           [json| { "extra":20 } |]
-            `shouldRespondWith` 204
+            `shouldRespondWith` 404
 
     context "in a nonempty table" . before_ (clearTable "items" >> createItems 15) .
       after_ (clearTable "items") $ do
@@ -175,7 +313,11 @@ spec = afterAll_ resetDb $ around withApp $ do
           `shouldSatisfy` matchHeader "Content-Range" "\\*/0"
         request methodPatch "/items?id=eq.1" []
           [json| { "id":42 } |]
-            `shouldRespondWith` 204
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Nothing,
+              matchStatus  = 204,
+              matchHeaders = ["Content-Range" <:> "0-0/1"]
+            }
         g' <- get "/items?id=eq.42"
         liftIO $ simpleHeaders g'
           `shouldSatisfy` matchHeader "Content-Range" "0-0/1"
@@ -191,3 +333,45 @@ spec = afterAll_ resetDb $ around withApp $ do
         g <- get "/auto_incrementing_pk?non_nullable_string=eq.c"
         liftIO $ simpleHeaders g
           `shouldSatisfy` matchHeader "Content-Range" "0-9/10"
+
+      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 }] |]
+
+      it "can update based on a computed column" $
+        request methodPatch
+          "/items?always_true=eq.false"
+          [("Prefer", "return=representation")]
+          [json| { id: 100 } |]
+          `shouldRespondWith` 404
+      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}] |]
+
+  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

test/Feature/QuerySpec.hs

@@ -1,30 +1,33 @@
 module Feature.QuerySpec where
 
-import Test.Hspec
+import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
-import Hasql as H
-import Hasql.Postgres as H
-import Control.Monad (void)
-import Data.Text(Text)
+import Network.HTTP.Types
+import Network.Wai.Test (SResponse(simpleHeaders))
 
 import SpecHelper
+import Text.Heredoc
 
-testSet :: IO ()
-testSet = do
-  clearTable "items" >> clearTable "no_pk"
-  createItems 15
-  pool <- H.acquirePool pgSettings testPoolOpts
-  void . liftIO $ H.session pool $ H.tx Nothing $ do
-    H.unitEx $ insertNoPk "xyyx" "u"
-    H.unitEx $ insertNoPk "xYYx" "v"
-
-  where
-    insertNoPk :: Text -> Text -> H.Stmt H.Postgres
-    insertNoPk = [H.stmt|insert into "1".no_pk (a, b) values (?,?)|]
 
 spec :: Spec
-spec = beforeAll testSet . afterAll_ (clearTable "items") . around withApp $ do
+spec =
+  beforeAll (clearTable "items" >> createItems 15)
+   . beforeAll clearProjectsTable
+   . beforeAll (clearTable "complex_items" >> createComplexItems)
+   . beforeAll (clearTable "nullable_integer" >> createNullInteger)
+   . beforeAll (
+       clearTable "no_pk" >>
+       createNulls 2 >>
+       createLikableStrings >>
+       createJsonData)
+   . afterAll_ (clearTable "items" >> clearTable "complex_items" >> clearTable "no_pk" >> clearTable "simple_pk")
+   . around withApp $ 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 nonexistent table" $
     it "causes a 404" $
       get "/faketable" `shouldRespondWith` 404
@@ -38,6 +41,31 @@ spec = beforeAll testSet . afterAll_ (clearTable "items") . around withApp $ do
         , matchHeaders = ["Content-Range" <:> "0-0/1"]
         }
 
+    it "matches with equality using not operator" $
+      get "/items?id=not.eq.5"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just [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}] |]
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-13/14"]
+        }
+
+    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` ResponseMatcher {
+          matchBody    = Just [json| [{"id":14},{"id":15}] |]
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/2"]
+        }
+      get "/items?id=not.gt.2&order=id.asc"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just [json| [{"id":1},{"id":2}] |]
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-1/2"]
+        }
+
     it "matches items IN" $
       get "/items?id=in.1,3,5"
         `shouldRespondWith` ResponseMatcher {
@@ -46,19 +74,178 @@ spec = beforeAll testSet . afterAll_ (clearTable "items") . around withApp $ do
         , matchHeaders = ["Content-Range" <:> "0-2/3"]
         }
 
+    it "matches items NOT IN" $
+      get "/items?id=notin.2,4,6,7,8,9,10,11,12,13,14,15"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just [json| [{"id":1},{"id":3},{"id":5}] |]
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/3"]
+        }
+
+    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` ResponseMatcher {
+          matchBody    = Just [json| [{"id":1},{"id":3},{"id":5}] |]
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/3"]
+        }
+
+    it "matches nulls using not operator" $
+      get "/no_pk?a=not.is.null" `shouldRespondWith`
+        [json| [{"a":"1","b":"0"},{"a":"2","b":"0"}] |]
+
+    it "matches nulls in varchar and numeric fields alike" $ do
+      get "/no_pk?a=is.null" `shouldRespondWith`
+        [json| [{"a": null, "b": null}] |]
+
+      get "/nullable_integer?a=is.null" `shouldRespondWith` "[{\"a\":null}]"
+
     it "matches with like" $ do
-      get "/no_pk?a=like.*yx" `shouldRespondWith` [json|
-        [{"a":"xyyx","b":"u"}]|]
-      get "/no_pk?a=like.xy*" `shouldRespondWith` [json|
-        [{"a":"xyyx","b":"u"}]|]
-      get "/no_pk?a=like.*YY*" `shouldRespondWith` [json|
-        [{"a":"xYYx","b":"v"}]|]
+      get "/simple_pk?k=like.*yx" `shouldRespondWith`
+        "[{\"k\":\"xyyx\",\"extra\":\"u\"}]"
+      get "/simple_pk?k=like.xy*" `shouldRespondWith`
+        "[{\"k\":\"xyyx\",\"extra\":\"u\"}]"
+      get "/simple_pk?k=like.*YY*" `shouldRespondWith`
+        "[{\"k\":\"xYYx\",\"extra\":\"v\"}]"
+
+    it "matches with like using not operator" $
+      get "/simple_pk?k=not.like.*yx" `shouldRespondWith`
+        "[{\"k\":\"xYYx\",\"extra\":\"v\"}]"
 
     it "matches with ilike" $ do
-      get "/no_pk?a=ilike.xy*&order=b.asc" `shouldRespondWith` [json|
-        [{"a":"xyyx","b":"u"},{"a":"xYYx","b":"v"}]|]
-      get "/no_pk?a=ilike.*YY*&order=b.asc" `shouldRespondWith` [json|
-        [{"a":"xyyx","b":"u"},{"a":"xYYx","b":"v"}]|]
+      get "/simple_pk?k=ilike.xy*&order=extra.asc" `shouldRespondWith`
+        "[{\"k\":\"xyyx\",\"extra\":\"u\"},{\"k\":\"xYYx\",\"extra\":\"v\"}]"
+      get "/simple_pk?k=ilike.*YY*&order=extra.asc" `shouldRespondWith`
+        "[{\"k\":\"xyyx\",\"extra\":\"u\"},{\"k\":\"xYYx\",\"extra\":\"v\"}]"
+
+    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"}] |]
+
+    it "matches with tsearch @@ using not operator" $
+      get "/tsearch?text_search_vector=not.@@.foo" `shouldRespondWith`
+        [json| [{"text_search_vector":"'baz':1 'qux':2"}] |]
+
+    it "matches with computed column" $
+      get "/items?always_true=eq.true" `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}] |]
+
+    it "matches filtering nested items" $
+      get "/clients?select=id,projects{id,tasks{id,name}}&projects.tasks.name=like.Design*" `shouldRespondWith`
+        "[{\"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]}]|]
+
+    it "one simple column" $
+      get "/complex_items?select=id" `shouldRespondWith`
+        [json| [{"id":1},{"id":2},{"id":3}] |]
+
+    it "one simple column with casting (text)" $
+      get "/complex_items?select=id::text" `shouldRespondWith`
+        [json| [{"id":"1"},{"id":"2"},{"id":"3"}] |]
+
+    it "json column" $
+      get "/complex_items?id=eq.1&select=settings" `shouldRespondWith`
+        [json| [{"settings":{"foo":{"int":1,"bar":"baz"}}}] |]
+
+    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"
+
+    it "fails on bad casting (data of the wrong format)" $
+      get "/complex_items?select=settings->foo->>bar::integer"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just [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` ResponseMatcher {
+          matchBody    = Just [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"}] |]
+
+
+    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
+
+    it "requesting parents and children" $
+      get "/projects?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
+        "[{\"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 filtering parent columns" $
+      get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith`
+        "[{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1}}]"
+
+    it "requesting children 2 levels" $
+      get "/clients?id=eq.1&select=id,projects{id,tasks{id}}" `shouldRespondWith`
+        "[{\"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`
+        "[{\"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\":null}]"
+
+    it "requesting parents and children on views" $
+      get "/projects_view?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
+        "[{\"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`
+        "[{\"user_id\":2,\"task_id\":6,\"comments\":[{\"content\":\"Needs to be delivered ASAP\"}]}]"
+
+  describe "Plurality singular" $ do
+    it "will select an existing object" $
+      request methodGet "/items?id=eq.5" [("Prefer","plurality=singular")] ""
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just [json| {"id":5} |]
+        , matchStatus  = 200
+        , matchHeaders = []
+        }
+
+    it "works in the presence of a range header" $
+      let headers = ("Prefer","plurality=singular") :
+            rangeHdrs (ByteRangeFromTo 0 9) in
+      request methodGet "/items" headers ""
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just [json| {"id":1} |]
+        , matchStatus  = 200
+        , matchHeaders = []
+        }
+
+    it "will respond with 404 when not found" $
+      request methodGet "/items?id=eq.9999" [("Prefer","plurality=singular")] ""
+        `shouldRespondWith` 404
+
+    it "can shape plurality singular object routes" $
+      request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [("Prefer","plurality=singular")] ""
+        `shouldRespondWith`
+          "{\"id\":1,\"name\":\"Windows 7\",\"clients\":{\"id\":1,\"name\":\"Microsoft\"},\"tasks\":[{\"id\":1,\"name\":\"Design w7\"},{\"id\":2,\"name\":\"Code w7\"}]}"
+
 
   describe "ordering response" $ do
     it "by a column asc" $
@@ -76,8 +263,63 @@ spec = beforeAll testSet . afterAll_ (clearTable "items") . around withApp $ do
         , matchHeaders = ["Content-Range" <:> "0-1/2"]
         }
 
+    it "by a column asc with nulls last" $
+      get "/no_pk?order=a.asc.nullslast"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody = Just [json| [{"a":"1","b":"0"},
+                              {"a":"2","b":"0"},
+                              {"a":null,"b":null}] |]
+        , matchStatus = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/3"]
+        }
+
+    it "by a column desc with nulls first" $
+      get "/no_pk?order=a.desc.nullsfirst"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody = Just [json| [{"a":null,"b":null},
+                              {"a":"2","b":"0"},
+                              {"a":"1","b":"0"}] |]
+        , matchStatus = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/3"]
+        }
+
+    it "by a column desc with nulls last" $
+      get "/no_pk?order=a.desc.nullslast"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody = Just [json| [{"a":"2","b":"0"},
+                              {"a":"1","b":"0"},
+                              {"a":null,"b":null}] |]
+        , matchStatus = 200
+        , matchHeaders = ["Content-Range" <:> "0-2/3"]
+        }
+
     it "without other constraints" $
-      get "/items?order=asc.id" `shouldRespondWith` 200
+      get "/items?order=id.asc" `shouldRespondWith` 200
+
+  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 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` ResponseMatcher {
+          matchBody    = Just "k,extra\nxyyx,u\nxYYx,v"
+        , matchStatus  = 200
+        , matchHeaders = ["Content-Type" <:> "text/csv"]
+        }
 
   describe "Canonical location" $ do
     it "Sets Content-Location with alphabetized params" $
@@ -88,10 +330,39 @@ spec = beforeAll testSet . afterAll_ (clearTable "items") . around withApp $ do
         , matchHeaders = ["Content-Location" <:> "/no_pk?a=eq.1&b=eq.1"]
         }
 
-    it "Omits question mark when there are no params" $
-      get "/simple_pk"
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just "[]"
-        , matchStatus  = 200
-        , matchHeaders = ["Content-Location" <:> "/simple_pk"]
-        }
+    it "Omits question mark when there are no params" $ do
+      r <- get "/simple_pk"
+      liftIO $ do
+        let respHeaders = simpleHeaders r
+        respHeaders `shouldSatisfy` matchHeader
+          "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"}}}] |]
+      get "/json?data->foo->>bar=eq.fake" `shouldRespondWith`
+        [json| [] |]
+    it "can filter by properties inside json column using not" $
+      get "/json?data->foo->>bar=not.eq.baz" `shouldRespondWith`
+        [json| [] |]
+    it "can filter by properties inside json column using ->>" $
+      get "/json?data->>id=eq.1" `shouldRespondWith`
+        [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |]
+
+  describe "remote procedure call" $ do
+    context "a proc that returns a set" . before_ (clearTable "items" >> createItems 10) .
+      after_ (clearTable "items") $
+      it "returns proper json" $
+        post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`
+          [json| [ {"id": 3}, {"id":4} ] |]
+
+    context "a proc that returns an empty rowset" $
+      it "returns empty json array" $
+        post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith`
+          [json| [] |]
+
+    context "a proc that returns plain text" $
+      it "returns proper json" $
+        post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith`
+          [json| [{"sayhello":"Hello, world"}] |]

test/Feature/RangeSpec.hs

@@ -2,6 +2,7 @@ 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))
 
@@ -12,11 +13,39 @@ spec = beforeAll (clearTable "items" >> createItems 15) . afterAll_ (clearTable
   . around withApp $
   describe "GET /items" $ do
 
-    context "without range headers" $
+    context "without range headers" $ do
       context "with response under server size limit" $
         it "returns whole range with status 200" $
           get "/items" `shouldRespondWith` 200
 
+      context "when I don't want the count" $ do
+        it "returns range Content-Range with /*" $
+          request methodGet "/menagerie"
+                  [("Prefer", "count=none")] ""
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Just "[]"
+            , matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "*/*"]
+            }
+
+        it "returns range Content-Range with range/*" $
+          request methodGet "/items?order=id"
+                  [("Prefer", "count=none")] ""
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Just [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]
+            , matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "0-14/*"]
+            }
+
+        it "returns range Content-Range with range/* even using other filters" $
+          request methodGet "/items?id=eq.1&order=id"
+                  [("Prefer", "count=none")] ""
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Just [json| [{"id":1}] |]
+            , matchStatus  = 200
+            , matchHeaders = ["Content-Range" <:> "0-0/*"]
+            }
+
     context "with range headers" $ do
 
       context "of acceptable range" $ do

test/Feature/StructureSpec.hs

@@ -14,27 +14,42 @@ spec = around withApp $ 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}
+          {"schema":"test","name":"articleStars","insertable":true}
+        , {"schema":"test","name":"articles","insertable":true}
+        , {"schema":"test","name":"auto_incrementing_pk","insertable":true}
+        , {"schema":"test","name":"clients","insertable":true}
+        , {"schema":"test","name":"comments","insertable":true}
+        , {"schema":"test","name":"complex_items","insertable":true}
+        , {"schema":"test","name":"compound_pk","insertable":true}
+        , {"schema":"test","name":"has_count_column","insertable":false}
+        , {"schema":"test","name":"has_fk","insertable":true}
+        , {"schema":"test","name":"insertable_view_with_join","insertable":true}
+        , {"schema":"test","name":"items","insertable":true}
+        , {"schema":"test","name":"json","insertable":true}
+        , {"schema":"test","name":"materialized_view","insertable":false}
+        , {"schema":"test","name":"menagerie","insertable":true}
+        , {"schema":"test","name":"no_pk","insertable":true}
+        , {"schema":"test","name":"nullable_integer","insertable":true}
+        , {"schema":"test","name":"projects","insertable":true}
+        , {"schema":"test","name":"projects_view","insertable":true}
+        , {"schema":"test","name":"simple_pk","insertable":true}
+        , {"schema":"test","name":"tasks","insertable":true}
+        , {"schema":"test","name":"tsearch","insertable":true}
+        , {"schema":"test","name":"users","insertable":true}
+        , {"schema":"test","name":"users_projects","insertable":true}
+        , {"schema":"test","name":"users_tasks","insertable":true}
         ] |]
         {matchStatus = 200}
 
     it "lists only views user has permission to see" $ do
-      _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-      let auth = authHeader "jdoe" "1234"
+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
 
       request methodGet "/" [auth] ""
         `shouldRespondWith` [json| [
-            {"schema":"1","name":"authors_only","insertable":true}
+            {"schema":"test","name":"authors_only","insertable":true}
         ] |]
         {matchStatus = 200}
 
-
   describe "Table info" $ do
     it "is available with OPTIONS verb" $
       request methodOptions "/menagerie" [] "" `shouldRespondWith`
@@ -46,7 +61,7 @@ spec = around withApp $ do
             "default": null,
             "precision": 32,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "integer",
             "type": "integer",
             "maxLen": null,
@@ -59,7 +74,7 @@ spec = around withApp $ do
             "default": null,
             "precision": 53,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "double",
             "type": "double precision",
             "maxLen": null,
@@ -71,7 +86,7 @@ spec = around withApp $ do
             "default": null,
             "precision": null,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "varchar",
             "type": "character varying",
             "maxLen": null,
@@ -84,7 +99,7 @@ spec = around withApp $ do
             "default": null,
             "precision": null,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "boolean",
             "type": "boolean",
             "maxLen": null,
@@ -96,7 +111,7 @@ spec = around withApp $ do
             "default": null,
             "precision": null,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "date",
             "type": "date",
             "maxLen": null,
@@ -108,7 +123,7 @@ spec = around withApp $ do
             "default": null,
             "precision": null,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "money",
             "type": "money",
             "maxLen": null,
@@ -121,7 +136,7 @@ spec = around withApp $ do
             "default": null,
             "precision": null,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "enum",
             "type": "USER-DEFINED",
             "maxLen": null,
@@ -138,6 +153,61 @@ spec = around withApp $ do
       }
       |]
 
+    it "it includes primary and foreign keys for views" $
+      request methodOptions "/projects_view" [] "" `shouldRespondWith`
+      [json|
+      {
+         "pkey":[
+            "id"
+         ],
+         "columns":[
+          {
+            "references":null,
+            "default":null,
+            "precision":32,
+            "updatable":true,
+            "schema":"test",
+            "name":"id",
+            "type":"integer",
+            "maxLen":null,
+            "enum":[],
+            "nullable":true,
+            "position":1
+          },
+          {
+            "references":null,
+            "default":null,
+            "precision":null,
+            "updatable":true,
+            "schema":"test",
+            "name":"name",
+            "type":"text",
+            "maxLen":null,
+            "enum":[],
+            "nullable":true,
+            "position":2
+          },
+          {
+            "references": {
+              "schema":"test",
+              "column":"id",
+              "table":"clients"
+            },
+            "default":null,
+            "precision":32,
+            "updatable":true,
+            "schema":"test",
+            "name":"client_id",
+            "type":"integer",
+            "maxLen":null,
+            "enum":[],
+            "nullable":true,
+            "position":3
+          }
+        ]
+      }
+      |]
+
     it "includes foreign key data" $ do
       pendingWith "have to resolve issue #107"
 
@@ -150,7 +220,7 @@ spec = around withApp $ do
             "default": "nextval('\"1\".has_fk_id_seq'::regclass)",
             "precision": 64,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "id",
             "type": "bigint",
             "maxLen": null,
@@ -162,7 +232,7 @@ spec = around withApp $ do
             "default": null,
             "precision": 32,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "auto_inc_fk",
             "type": "integer",
             "maxLen": null,
@@ -174,7 +244,7 @@ spec = around withApp $ do
             "default": null,
             "precision": null,
             "updatable": true,
-            "schema": "1",
+            "schema": "test",
             "name": "simple_fk",
             "type": "character varying",
             "maxLen": 255,
@@ -186,3 +256,63 @@ spec = around withApp $ do
         ]
       }
       |]
+
+    it "includes all information on views for renamed columns, and raises relations to correct schema" $
+      request methodOptions "/articleStars" [] ""
+        `shouldRespondWith` [json|
+          {
+            "pkey": [
+              "articleId",
+              "userId"
+            ],
+            "columns": [
+              {
+                "references": {
+                  "schema": "test",
+                  "column": "id",
+                  "table": "articles"
+                },
+                "default": null,
+                "precision": 32,
+                "updatable": true,
+                "schema": "test",
+                "name": "articleId",
+                "type": "integer",
+                "maxLen": null,
+                "enum": [],
+                "nullable": true,
+                "position": 1
+              },
+              {
+                "references": {
+                  "schema": "test",
+                  "column": "id",
+                  "table": "users"
+                },
+                "default": null,
+                "precision": 32,
+                "updatable": true,
+                "schema": "test",
+                "name": "userId",
+                "type": "integer",
+                "maxLen": null,
+                "enum": [],
+                "nullable": true,
+                "position": 2
+              },
+              {
+                "references": null,
+                "default": null,
+                "precision": null,
+                "updatable": true,
+                "schema": "test",
+                "name": "createdAt",
+                "type": "timestamp without time zone",
+                "maxLen": null,
+                "enum": [],
+                "nullable": true,
+                "position": 3
+              }
+            ]
+          }
+        |]

test/SpecHelper.hs

@@ -5,71 +5,75 @@ import Test.Hspec
 import Test.Hspec.Wai
 
 import Hasql as H
-import Hasql.Backend as H
-import Hasql.Postgres as H
+import Hasql.Backend as B
+import Hasql.Postgres as P
 
 import Data.String.Conversions (cs)
 import Data.Monoid
 import Data.Text hiding (map)
 import qualified Data.Vector as V
 import Control.Monad (void)
+import Control.Applicative
 
 import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,
-                                  hRange, hAuthorization)
+                                  hRange, hAuthorization, hAccept)
 import Codec.Binary.Base64.String (encode)
 import Data.CaseInsensitive (CI(..))
 import Data.Maybe (fromMaybe)
 import Text.Regex.TDFA ((=~))
 import qualified Data.ByteString.Char8 as BS
-import Network.Wai.Middleware.Cors (cors)
 import System.Process (readProcess)
+import Web.JWT (secret)
 
-import App (app)
-import Config (AppConfig(..), corsPolicy)
-import Middleware
-import Error(errResponse)
--- import Auth (addUser)
+import qualified Data.Aeson.Types as J
+
+import PostgREST.App (app)
+import PostgREST.Config (AppConfig(..))
+import PostgREST.Middleware
+import PostgREST.Error(pgErrResponse)
+import PostgREST.DbStructure
+
+dbString :: String
+dbString = "postgres://postgrest_test@localhost:5432/postgrest_test"
 
 isLeft :: Either a b -> Bool
 isLeft (Left _ ) = True
 isLeft _ = False
 
 cfg :: AppConfig
-cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1"
+cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" (secret "safe") 10
 
 testPoolOpts :: PoolSettings
 testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
 
-pgSettings :: H.Settings
-pgSettings = H.ParamSettings (cs $ configDbHost cfg)
-                             (fromIntegral $ configDbPort cfg)
-                             (cs $ configDbUser cfg)
-                             (cs $ configDbPass cfg)
-                             (cs $ configDbName cfg)
+pgSettings :: P.Settings
+pgSettings = P.StringSettings $ cs dbString
 
 withApp :: ActionWith Application -> IO ()
 withApp perform = do
-  let anonRole = cs $ configAnonRole cfg
-      currRole = cs $ configDbUser cfg
-  pool :: H.Pool H.Postgres
+  pool :: H.Pool P.Postgres
     <- H.acquirePool pgSettings testPoolOpts
 
+  let txSettings = Just (H.ReadCommitted, Just True)
+  dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema cfg)
+  db <- either (fail . show) return dbOrError
+
   perform $ middle $ \req resp -> do
     body <- strictRequestBody req
-    result <- liftIO $ H.session pool $ H.tx Nothing
-      $ authenticated currRole anonRole (app (cs $ configV1Schema cfg) body) req
-    either (resp . errResponse) resp result
+    result <- liftIO $ H.session pool $ H.tx txSettings
+      $ runWithClaims cfg (app db cfg body) req
+    either (resp . pgErrResponse) resp result
 
-  where middle = cors corsPolicy
+  where middle = defaultMiddle
 
 
 resetDb :: IO ()
 resetDb = do
-  pool :: H.Pool H.Postgres
+  pool :: H.Pool P.Postgres
     <- H.acquirePool pgSettings testPoolOpts
   void . liftIO $ H.session pool $
     H.tx Nothing $ do
-      H.unitEx [H.stmt| drop schema if exists "1" cascade |]
+      H.unitEx [H.stmt| drop schema if exists test cascade |]
       H.unitEx [H.stmt| drop schema if exists private cascade |]
       H.unitEx [H.stmt| drop schema if exists postgrest cascade |]
 
@@ -85,6 +89,9 @@ loadFixture name =
 rangeHdrs :: ByteRange -> [Header]
 rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)]
 
+acceptHdrs :: BS.ByteString -> [Header]
+acceptHdrs mime = [(hAccept, mime)]
+
 rangeUnit :: Header
 rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items")
 
@@ -92,30 +99,84 @@ matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool
 matchHeader name valRegex headers =
   maybe False (=~ valRegex) $ lookup name headers
 
-authHeader :: String -> String -> Header
-authHeader u p =
+authHeaderBasic :: String -> String -> Header
+authHeaderBasic u p =
   (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
 
+authHeaderJWT :: String -> Header
+authHeaderJWT token =
+  (hAuthorization, cs $ "Bearer " ++ token)
+
+testPool :: IO(H.Pool P.Postgres)
+testPool = H.acquirePool pgSettings testPoolOpts
+
 clearTable :: Text -> IO ()
 clearTable table = do
-  pool :: H.Pool H.Postgres
-    <- H.acquirePool pgSettings testPoolOpts
+  pool <- testPool
   void . liftIO $ H.session pool $ H.tx Nothing $
-    H.unitEx $ H.Stmt ("delete from \"1\"."<>table) V.empty True
+    H.unitEx $ B.Stmt ("delete from test."<>table) V.empty True
+
+clearProjectsTable :: IO ()
+clearProjectsTable = do
+  pool <- testPool
+  void . liftIO $ H.session pool $ H.tx Nothing $
+    H.unitEx $ B.Stmt "delete from test.projects where id > 4" V.empty True
+
 
 createItems :: Int -> IO ()
 createItems n = do
-  pool :: H.Pool H.Postgres
-    <- H.acquirePool pgSettings testPoolOpts
+  pool <- testPool
   void . liftIO $ H.session pool $ H.tx Nothing txn
   where
-    txn = sequence_ $ map H.unitEx stmts
-    stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n]
+    txn = mapM_ H.unitEx stmts
+    stmts = map [H.stmt|insert into test.items (id) values (?)|] [1..n]
 
--- for hspec-wai
-pending_ :: WaiSession ()
-pending_ = liftIO Test.Hspec.pending
+createComplexItems :: IO ()
+createComplexItems = do
+  pool <- testPool
+  void . liftIO $ H.session pool $ H.tx Nothing txn
+  where
+    txn = mapM_ H.unitEx stmts
+    stmts = getZipList $ [H.stmt|insert into test.complex_items (id, name, settings, arr_data) values (?,?,?,?)|]
+        <$> ZipList ([1..3]::[Int])
+        <*> ZipList (["One", "Two", "Three"]::[Text])
+        <*> ZipList [jobj,jobj,jobj]
+        <*> ZipList ([[1], [1,2], [1,2,3]]::[[Int]])
+    jobj = J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])]
 
--- for hspec-wai
-pendingWith_ :: String -> WaiSession ()
-pendingWith_ = liftIO . Test.Hspec.pendingWith
+createNulls :: Int -> IO ()
+createNulls n = do
+  pool <- testPool
+  void . liftIO $ H.session pool $ H.tx Nothing txn
+  where
+    txn = mapM_ H.unitEx (stmt':stmts)
+    stmt' = [H.stmt|insert into test.no_pk (a,b) values (null,null)|]
+    stmts = map [H.stmt|insert into test.no_pk (a,b) values (?,0)|] [1..n]
+
+createNullInteger :: IO ()
+createNullInteger = do
+  pool <- testPool
+  void . liftIO $ H.session pool $ H.tx Nothing $
+    H.unitEx $ [H.stmt| insert into "test".nullable_integer (a) values (null) |]
+
+createLikableStrings :: IO ()
+createLikableStrings = do
+  pool <- testPool
+  void . liftIO $ H.session pool $ H.tx Nothing $ do
+    H.unitEx $ insertSimplePk "xyyx" "u"
+    H.unitEx $ insertSimplePk "xYYx" "v"
+  where
+    insertSimplePk :: Text -> Text -> H.Stmt P.Postgres
+    insertSimplePk = [H.stmt|insert into test.simple_pk (k, extra) values (?,?)|]
+
+createJsonData :: IO ()
+createJsonData = do
+  pool <- testPool
+  void . liftIO $ H.session pool $ H.tx Nothing $
+    H.unitEx $
+      [H.stmt|
+        insert into test.json (data) values (?)
+      |]
+      (J.object [("id", J.Number 1)
+                ,("foo", J.object [("bar", J.String "baz")])
+                ])

test/TestTypes.hs

@@ -8,9 +8,11 @@ module TestTypes (
 import qualified Data.Aeson as JSON
 import Data.Aeson ((.:))
 -- import Data.Maybe (fromJust)
-import Control.Applicative ((<$>), (<*>))
+import Control.Applicative
 import Control.Monad (mzero)
 
+import Prelude
+
 data IncPK = IncPK {
   incId :: Int
 , incNullableStr :: Maybe String

test/Unit/DbStructureSpec.hx

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

test/Unit/PgQuerySpec.hx

@@ -32,7 +32,7 @@ spec = around dbWithSchema $ do
   describe "insert" $
     describe "with an auto-increment key" $ do
       it "inserts and responds with a full object description" $ \conn -> do
-        r <- insert "1" "auto_incrementing_pk" (SqlRow [
+        r <- insert "test" "auto_incrementing_pk" (SqlRow [
             ("non_nullable_string", toSql ("a string"::String))]) conn
         let returnRow = incFromList . toList $ r
         incStr returnRow `shouldBe` "a string"
@@ -43,19 +43,19 @@ 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]]
@@ -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