v0.3.2.0

Update operator documentation

CHANGELOG.md

@@ -5,8 +5,33 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ## Unreleased
 
+### Added
+
 ### Fixed
 
+## [0.3.2.0] - 2016-06-10
+
+### Added
+- Reload database schema on SIGHUP - @begriffs
+- Support "-" in column names - @ruslantalpa
+- Support column/node renaming `alias:column` - @ruslantalpa
+- Accept posts from HTML forms - @begriffs
+- Ability to order embedded entities - @ruslantalpa
+- Ability to paginate using &limit and &offset parameters - @ruslantalpa
+- Ability to apply limits to embedded entities and enforce --max-rows on all levels - @ruslantalpa, @begriffs
+- Add allow response header in OPTIONS - @begriffs
+
+### Fixed
+- Return 401 or 403 for access denied rather than 404 - @begriffs
+- Omit Content-Type header for empty body - @begriffs
+- Prevent role from being changed twice - @begriffs
+- Use read-only transaction for read requests - @ruslantalpa
+- Include entities from the same parent table using two different foreign keys - @ruslantalpa
+- Ensure that Location header in 201 response is URL-encoded - @league
+- Fix garbage collector CPU leak - @ruslantalpa et al.
+- Return deleted items when return=representation header is sent - @ruslantalpa
+- Use table default values for empty object inserts - @begriffs
+
 ## [0.3.1.1] - 2016-03-28
 
 ### Fixed

Dockerfile

@@ -1,6 +1,6 @@
 FROM debian:jessie
 
-ENV POSTGREST_VERSION 0.3.1.0
+ENV POSTGREST_VERSION 0.3.2.0
 ENV POSTGREST_SCHEMA public
 ENV POSTGREST_ANONYMOUS postgres
 ENV POSTGREST_JWT_SECRET thisisnotarealsecret

README.md

@@ -5,6 +5,7 @@
   <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)
+[![Docker Hub](https://img.shields.io/badge/Docker%20Hub-%E2%86%92-blue.svg)](https://hub.docker.com/r/begriffs/postgrest/)
 
 PostgREST serves a fully RESTful API from any existing PostgreSQL
 database. It provides a cleaner, more standards-compliant, faster

app.json

@@ -10,7 +10,7 @@
     },
     "POSTGREST_VER": {
       "description": "Version of PostgREST to deploy",
-      "value": "0.3.1.1"
+      "value": "0.3.2.0"
     },
     "DB_NAME": {
       "description": "Database name",

circle.yml

@@ -3,8 +3,9 @@ dependencies:
     - "~/.stack"
     - ".stack-work"
   pre:
-    - curl -L https://github.com/commercialhaskell/stack/releases/download/v1.0.2/stack-1.0.2-linux-x86_64.tar.gz | tar zx -C /tmp
+    - curl -L https://github.com/commercialhaskell/stack/releases/download/v1.1.2/stack-1.1.2-linux-x86_64.tar.gz | tar zx -C /tmp
-    - sudo mv /tmp/stack-1.0.2-linux-x86_64/stack /usr/bin
+    - sudo mv /tmp/stack-1.1.2-linux-x86_64/stack /usr/bin
+    - sudo apt-get update; sudo apt-get install --only-upgrade binutils
     - createuser --superuser --no-password postgrest_test
     - createdb -O postgrest_test -U ubuntu postgrest_test
   override:

docs/api/reading.md

@@ -91,15 +91,20 @@ These operators are available:
 abbreviation | meaning
 ------------ | -------
 eq           | equals
-gt           | greater than
-lt           | less than
 gte          | greater than or equal
+gt           | greater than
 lte          | less than or equal
+lt           | less than
+neq          | not 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`
+notin        | not one of a list of values e.g. `?a=notin.1,2,3`
+is           | checking for exact equality (null,true,false)
+isnot        | checking for exact inequality (null,true,false)
+@@           | full-text search using to_tsquery
+@>           | contains e.g. `?tags=@>.{example, new}`
+<@           | contained in e.g. `values=<@{1,2,3}`
 not          | negates another operator, see below
 
 To negate any operator, prefix it with `not` like `?a=not.eq.2`.
@@ -172,6 +177,12 @@ GET /people?order=age.nullsfirst
 GET /people?order=age.desc.nullslast
 ```
 
+To order the embedded items, you need to specify the tree path for the order param like so.
+```HTTP
+GET /projects?select=id,name,tasks{id,name}&order=id.asc&tasks.order=name.asc
+```
+
+
 You can also use [computed
 columns](http://www.postgresql.org/docs/current/interactive/xfunc-sql.html#XFUNC-SQL-COMPOSITE-FUNCTIONS)
 to order the results, even though the computed
@@ -208,6 +219,15 @@ Range: 0-4
 You can also use open-ended ranges for an offset with no limit:
 `Range: 10-`.
 
+In addition to the `Range` header, you can use `&limit` and `&offset` parameters
+to achieve the same result.
+
+You can also set a limit (but not offset) for the embedded items like so
+```HTTP
+/posts?select=id,title,body,comments{id,email,body}&limit=10&comments.limit=3
+```
+The above request will return the first 10 posts and for each of the posts, 3 comments at most
+
 #### Suppressing Counts
 
 Sometimes knowing the total row count of a query is unnecessary and
@@ -258,7 +278,8 @@ but the the select query is recursive. You could for instance specify
 GET /foo?select=x, y, bar{z, w, baz{*}}
 ```
 
-You can select not only using table names, but also column names!
+You can select not only using table names, but also foreign key column names!
+This is especially needed when you have a table with two foreign keys pointing to the same table, for example billing_address_id and shipping_address_id.
 To embed the same foreign key row from our client example earlier
 you could do the following:
 
@@ -270,8 +291,7 @@ In the response there will be a `client_id` object containing all
 the data for that row.
 
 However, a `client_id` object doesn't make a lot of sense, so you
-could do one of two things. Create a view which renames `client_id`
+could do one of two things. Tell PostgREST that you want the key renamed by using the `alias` feature like so `client:client_id{*}`, or just try `client{*}`
-to just `client` (this is the hard way), or just try `client{*}`
 in the select parameter! PostgREST supports smart ducktype checking
 for common foreign key names, so if your column name ends with
 `_id`, `_fk`, or any variation of the two (including camelcase)
@@ -285,6 +305,32 @@ GET /projects?id=eq.1&select=id, name, client{*}
 
 Would embed in the `client` key the row referenced with `client_id`.
 
+The `alias` feature works for embedded entities and also for regular columns. This is useful in situations where for example you use different naming conventions in the database and frontend.
+
+The following request will produce the output below:
+```HTTP
+GET /orders?id=eq.1&select=orderId:id, customer:customer_id{customerId:id, customerName:name}
+```
+
+```json
+[
+  {
+    "orderId": 1,
+    "customer": {
+      "customerId": 1,
+      "customerName": "John Smith"
+    }
+  }
+]
+```
+
+If you want to apply filters to the embedded items, you can do that like so:
+```HTTP
+GET /clients?id=eq.42&select=id,name,projects{id,name,is_active}&projects.is_active=eq.true
+```
+The above request will return the client with id=42 and all the projects for that client that are still active
+
+
 <div class="admonition note">
     <p class="admonition-title">Design Consideration</p>
     <p>In order for this feature to work as expected after a schema change, PostgREST currently requires to be restarted.</p>
@@ -328,14 +374,14 @@ 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">
+<div class="admonition warning">
-    <p class="admonition-title">Deprecation Warning</p>
+    <p class="admonition-title">Schema Changes</p>
 
-    <p>Although we currently use the OPTIONS verb for this, some
+    <p>Note that when the schema of your database changes PostgREST will not reflect
-    people <a
+    the change. You have to either restart PostgREST or send its running process
-    href="https://www.mnot.net/blog/2012/10/29/NO_OPTIONS">argue</a> that
+    a HUP signal:
-    this is inappropriate. We are considering a <code>describedby</code>
+
-    header link instead.</p>
+    <pre><code>killall -HUP postgrest</code></pre>
 </div>
 
 ### CORS

docs/examples/blog.md

@@ -71,21 +71,52 @@ security](http://www.postgresql.org/docs/9.5/static/ddl-rowsecurity.html).
 Note that it requires PostgreSQL 9.5 or later.
 
 ```sql
+grant select on posts, comments to anon;
+
 ALTER TABLE posts ENABLE ROW LEVEL SECURITY;
-drop policy if exists authors_eigenedit on posts;
+ALTER TABLE comments ENABLE ROW LEVEL SECURITY;
-create policy authors_eigenedit on posts
+
-  using (true)
+drop policy if exists posts_select_unsecure on posts;
+create policy posts_select_unsecure on posts for select
+  using (true);
+
+drop policy if exists comments_select_unsecure on comments;
+create policy comments_select_unsecure on comments for select
+  using (true);
+
+drop policy if exists authors_eigencreate on posts;
+create policy authors_eigencreate on posts for insert
   with check (
     author = basic_auth.current_email()
   );
 
-ALTER TABLE comments ENABLE ROW LEVEL SECURITY;
+drop policy if exists authors_eigencreate on comments;
-drop policy if exists authors_eigenedit on comments;
+create policy authors_eigencreate on comments for insert
-create policy authors_eigenedit on comments
+  with check (
-  using (true)
+      author = basic_auth.current_email()
+  );
+
+drop policy if exists authors_eigenedit on posts;
+create policy authors_eigenedit on posts for update
+  using (author = basic_auth.current_email())
   with check (
     author = basic_auth.current_email()
   );
+
+drop policy if exists authors_eigenedit on comments;
+create policy authors_eigenedit on comments for update
+  using (author = basic_auth.current_email())
+  with check (
+    author = basic_auth.current_email()
+  );
+
+drop policy if exists authors_eigendelete on posts;
+create policy authors_eigendelete on posts for delete
+  using (author = basic_auth.current_email());
+
+drop policy if exists authors_eigendelete on comments;
+create policy authors_eigendelete on comments for delete
+  using (author = basic_auth.current_email());
 ```
 
 Finally we need to modify the `users` view from the previous example.

docs/examples/users.md

@@ -409,14 +409,22 @@ login(email text, pass text) returns basic_auth.jwt_claims
   as $$
 declare
   _role name;
+  _verified boolean;
+  _email text;
   result basic_auth.jwt_claims;
 begin
+  -- check email and password
   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
+  -- check verified flag whether users
   -- have validated their emails
+  _email := email;
+  select verified from basic_auth.users as u where u.email=_email limit 1 into _verified;
+  if not _verified then
+    raise invalid_authorization_specification using message = 'user is not verified';
+  end if;
   select _role as role, login.email as email into result;
   return result;
 end;
@@ -456,15 +464,16 @@ Here's a function to get the email of the currently authenticated
 user.
 
 ```sql
+-- Prevent current_setting('postgrest.claims.email') from raising
+-- an exception if the setting is not present. Default it to ''.
+ALTER DATABASE your_db_name SET postgrest.claims.email TO '';
+
 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;
 $$;
 ```

main/Main.hs

@@ -23,7 +23,9 @@ import           System.IO                            (BufferMode (..),
                                                        hSetBuffering, stderr,
                                                        stdin, stdout)
 import           Web.JWT                              (secret)
+import           Data.IORef
 #ifndef mingw32_HOST_OS
+import           Control.Monad.IO.Class               (liftIO)
 import           System.Posix.Signals
 import           Control.Concurrent                   (myThreadId)
 import           Control.Exception.Base               (throwTo, AsyncException(..))
@@ -58,15 +60,6 @@ main = do
 
   pool <- P.acquire (configPool conf, 10, pgSettings)
 
-#ifndef mingw32_HOST_OS
-  tid <- myThreadId
-  forM_ [sigINT, sigTERM] $ \sig ->
-    void $ installHandler sig (Catch $ do
-        P.release pool
-        throwTo tid UserInterrupt
-      ) Nothing
-#endif
-
   result <- P.use pool $ do
     supported <- isServerVersionSupported
     unless supported $ error (
@@ -74,5 +67,21 @@ main = do
       <> show minimumPgVersion)
     getDbStructure (cs $ configSchema conf)
 
-  let dbStructure = either (error.show) id result
+  refDbStructure <- newIORef $ either (error.show) id result
-  runSettings appSettings $ postgrest conf dbStructure pool
+
+#ifndef mingw32_HOST_OS
+  tid <- myThreadId
+  forM_ [sigINT, sigTERM] $ \sig ->
+    void $ installHandler sig (Catch $ do
+        P.release pool
+        throwTo tid UserInterrupt
+      ) Nothing
+
+  void $ installHandler sigHUP (
+      Catch . void . P.use pool $ do
+        s <- getDbStructure (cs $ configSchema conf)
+        liftIO $ atomicWriteIORef refDbStructure s
+   ) Nothing
+#endif
+
+  runSettings appSettings $ postgrest conf refDbStructure pool

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.3.1.1
+version:               0.3.2.0
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
@@ -22,29 +22,34 @@ Flag CI
   Default:     False
 
 executable postgrest
-  main-is:             PostgREST/Main.hs
+  main-is:             Main.hs
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  ghc-options:
+    -threaded
+    -rtsopts
+    "-with-rtsopts=-N -I2"
   default-language:    Haskell2010
   build-depends:       aeson (>= 0.8 && < 0.10) || (>= 0.11 && < 0.12)
-                     , base >= 4.8 && < 5
+                     , base >= 4.8 && < 6
                      , bytestring
+                     , bytestring-tree-builder == 0.2.7
                      , case-insensitive
                      , cassava
                      , containers
                      , contravariant
                      , errors
-                     , hasql >= 0.19.9 && < 0.20
+                     , hasql == 0.19.12
-                     , hasql-pool >= 0.4 && < 0.5
+                     , hasql-pool == 0.4.1
-                     , hasql-transaction >= 0.4.3 && < 0.5
+                     , hasql-transaction == 0.4.5
                      , http-types
                      , interpolatedstring-perl6
                      , jwt
-                     , lens >=3.8 && < 5.0
+                     , microlens >= 0.4.2 && < 0.5
-                     , lens-aeson >= 1.0.0.0 && < 1.1.0.0
+                     , microlens-aeson >= 2.1.1 && < 2.2
                      , mtl
                      , optparse-applicative >= 0.11 && < 0.13
                      , parsec
+                     , postgresql-binary == 0.9.0.1
                      , postgrest
                      , regex-tdfa
                      , safe >= 0.3 && < 0.4
@@ -52,6 +57,7 @@ executable postgrest
                      , string-conversions
                      , text
                      , time
+                     , transformers
                      , unordered-containers
                      , vector
                      , wai >= 3.0.1
@@ -64,25 +70,13 @@ executable postgrest
   if !os(windows)
     build-depends:     unix >= 2.7 && < 3
 
-  hs-source-dirs:      src
+  hs-source-dirs:      main
-  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
   default-language:    Haskell2010
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
   build-depends:       aeson
-                     , base >=4.6 && <5
+                     , base
                      , bytestring
                      , case-insensitive
                      , cassava
@@ -95,8 +89,8 @@ library
                      , http-types
                      , interpolatedstring-perl6
                      , jwt
-                     , lens
+                     , microlens
-                     , lens-aeson
+                     , microlens-aeson
                      , mtl
                      , optparse-applicative
                      , parsec
@@ -135,7 +129,7 @@ Test-Suite spec
   Default-Language:    Haskell2010
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
-  Hs-Source-Dirs:      test, src
+  Hs-Source-Dirs:      test
   Main-Is:             Main.hs
   Other-Modules:       Feature.AuthSpec
                      , Feature.ConcurrentSpec
@@ -147,18 +141,6 @@ Test-Suite spec
                      , Feature.RangeSpec
                      , Feature.StructureSpec
                      , Feature.UnicodeSpec
-                     , Paths_postgrest
-                     , PostgREST.App
-                     , PostgREST.Auth
-                     , PostgREST.Config
-                     , PostgREST.Error
-                     , PostgREST.Middleware
-                     , PostgREST.Parsers
-                     , PostgREST.DbStructure
-                     , PostgREST.QueryBuilder
-                     , PostgREST.RangeQuery
-                     , PostgREST.ApiRequest
-                     , PostgREST.Types
                      , SpecHelper
                      , TestTypes
   Build-Depends:       aeson
@@ -175,18 +157,19 @@ Test-Suite spec
                      , hasql-pool
                      , hasql-transaction
                      , heredoc
-                     , hspec == 2.2.*
+                     , hspec
                      , hspec-wai
                      , hspec-wai-json
                      , http-types
                      , interpolatedstring-perl6
                      , jwt
-                     , lens
+                     , microlens
-                     , lens-aeson
+                     , microlens-aeson
                      , monad-control
                      , mtl
                      , optparse-applicative
                      , parsec
+                     , postgrest
                      , process
                      , regex-tdfa
                      , safe
@@ -197,7 +180,6 @@ Test-Suite spec
                      , transformers
                      , transformers-base
                      , unordered-containers
-                     , unix
                      , vector
                      , wai
                      , wai-cors

src/PostgREST/ApiRequest.hs

@@ -1,26 +1,32 @@
 module PostgREST.ApiRequest where
 
-import qualified Data.Aeson              as JSON
+import qualified Data.Aeson                as JSON
-import qualified Data.ByteString         as BS
+import qualified Data.ByteString           as BS
-import qualified Data.ByteString.Lazy    as BL
+import qualified Data.ByteString.Lazy      as BL
-import qualified Data.Csv                as CSV
+import qualified Data.Csv                  as CSV
-import           Data.List               (find)
+import           Data.List                 (find, sortBy)
-import qualified Data.HashMap.Strict     as M
+import qualified Data.HashMap.Strict       as M
-import qualified Data.Set                as S
+import qualified Data.Set                  as S
-import           Data.Maybe              (fromMaybe, isJust, isNothing,
+import           Data.Maybe                (fromMaybe, isJust, isNothing,
-                                          listToMaybe, fromJust)
+                                            listToMaybe, fromJust)
-import           Control.Monad           (join)
+import           Control.Arrow             ((***))
-import           Data.Monoid             ((<>))
+import           Control.Monad             (join)
-import           Data.String.Conversions (cs)
+import           Data.Monoid               ((<>))
-import qualified Data.Text               as T
+import           Data.Ord                  (comparing)
-import qualified Data.Vector             as V
+import           Data.String.Conversions   (cs)
-import           Network.Wai             (Request (..))
+import qualified Data.Text                 as T
-import           Network.Wai.Parse       (parseHttpAccept)
+import           Text.Read                 (readMaybe)
-import           PostgREST.RangeQuery    (NonnegRange, rangeRequested)
+import qualified Data.Vector               as V
-import           PostgREST.Types         (QualifiedIdentifier (..),
+import           Network.HTTP.Base         (urlEncodeVars)
-                                          Schema, Payload(..),
+import           Network.HTTP.Types.Header (hAuthorization)
-                                          UniformObjects(..))
+import           Network.HTTP.Types.URI    (parseSimpleQuery)
-import           Data.Ranged.Ranges      (singletonRange)
+import           Network.Wai               (Request (..))
+import           Network.Wai.Parse         (parseHttpAccept)
+import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange)
+import           PostgREST.Types           (QualifiedIdentifier (..),
+                                            Schema, Payload(..),
+                                            UniformObjects(..))
+import           Data.Ranged.Ranges        (singletonRange, rangeIntersection)
 
 type RequestBody = BL.ByteString
 
@@ -52,11 +58,11 @@ instance Show ContentType where
   if it is an action we are able to perform.
 -}
 data ApiRequest = ApiRequest {
-  -- | Set to Nothing for unknown HTTP verbs
+  -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
     iAction :: Action
-  -- | Set to Nothing for malformed range
+  -- | Requested range of rows within response
-  , iRange  :: NonnegRange
+  , iRange  :: M.HashMap String NonnegRange
-  -- | Set to Nothing for strangely nested urls
+  -- | The target, be it calling a proc or accessing a table
   , iTarget :: Target
   -- | The content type the client most desires (or JSON if undecided)
   , iAccepts :: Either BS.ByteString ContentType
@@ -72,8 +78,12 @@ data ApiRequest = ApiRequest {
   , iFilters :: [(String, String)]
   -- | &select parameter used to shape the response
   , iSelect :: String
-  -- | &order parameter
+  -- | &order parameters for each level
-  , iOrder :: Maybe String
+  , iOrder :: [(String,String)]
+  -- | Alphabetized (canonical) request query string for response URLs
+  , iCanonicalQS :: String
+  -- | JSON Web Token
+  , iJWT :: T.Text
   }
 
 -- | Examines HTTP request and translates it into user intent.
@@ -113,6 +123,13 @@ userApiRequest schema req reqBody =
               Nothing -> PayloadParseError "All lines must have same number of fields"
               Just json -> PayloadJSON json)
             (CSV.decodeByName reqBody)
+        -- This is a Left value because form-urlencoded is not a content
+        -- type which we ever use for responses, only something we handle
+        -- just this once for requests
+        Left "application/x-www-form-urlencoded" ->
+          PayloadJSON . UniformObjects . V.singleton . M.fromList
+                      . map (cs *** JSON.String . cs) . parseSimpleQuery
+                      $ cs reqBody
         Left accept ->
           PayloadParseError $
             "Content-type not acceptable: " <> accept
@@ -124,18 +141,23 @@ userApiRequest schema req reqBody =
 
   ApiRequest {
     iAction = action
-  , iRange  = if singular then singletonRange 0 else rangeRequested hdrs
   , iTarget = target
+  , iRange = M.insert "limit" (rangeIntersection headerRange urlRange) $
+      M.fromList [ (cs k, restrictRange (readMaybe =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ]
   , iAccepts = pickContentType $ lookupHeader "accept"
   , iPayload = relevantPayload
   , iPreferRepresentation = representation
   , iPreferSingular = singular
   , iPreferCount = not $ singular || hasPrefer "count=none"
-  , iFilters = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]
+  , iFilters = [ (cs k, fromJust v) | (k,v) <- qParams, isJust v, k /= "select", k /= "offset", not (endingIn ["order", "limit"] k) ]
-  , iSelect = if method == "DELETE"
+  , iSelect = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
-              then "*"
+  , iOrder = [(cs k, fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
-              else fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
+  , iCanonicalQS = urlEncodeVars
-  , iOrder = join $ lookup "order" qParams
+     . sortBy (comparing fst)
+     . map (join (***) cs)
+     . parseSimpleQuery
+     $ rawQueryString req
+  , iJWT = tokenStr
   }
 
  where
@@ -155,6 +177,20 @@ userApiRequest schema req reqBody =
     | hasPrefer "return=representation" = Full
     | hasPrefer "return=minimal" = None
     | otherwise = HeadersOnly
+  auth = fromMaybe "" $ lookupHeader hAuthorization
+  tokenStr = case T.split (== ' ') (cs auth) of
+    ("Bearer" : t : _) -> t
+    _                  -> ""
+  endingIn:: [T.Text] -> T.Text -> Bool
+  endingIn xx key = lastWord `elem` xx
+    where lastWord = last $ T.split (=='.') key
+
+  headerRange = if singular then singletonRange 0 else rangeRequested hdrs
+  urlOffsetRange = rangeGeq . fromMaybe (0::Integer) $
+    readMaybe =<< join (lookup "offset" qParams)
+  urlRange = restrictRange
+    (readMaybe =<< join (lookup "limit" qParams))
+    urlOffsetRange
 
 -- PRIVATE ---------------------------------------------------------------
 

src/PostgREST/App.hs

@@ -7,12 +7,11 @@ module PostgREST.App (
 ) where
 
 import           Control.Applicative
-import           Control.Arrow             ((***))
-import           Control.Monad             (join)
 import           Data.Bifunctor            (first)
-import           Data.List                 (find, sortBy, delete)
+import qualified Data.ByteString.Char8   as BS
-import           Data.Maybe                (isJust, fromMaybe, fromJust, mapMaybe)
+import           Data.IORef                (IORef, readIORef)
-import           Data.Ord                  (comparing)
+import           Data.List                 (find, delete)
+import           Data.Maybe                (fromMaybe, fromJust, mapMaybe)
 import           Data.Ranged.Ranges        (emptyRange)
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
@@ -24,10 +23,9 @@ import qualified Hasql.Transaction         as HT
 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.HTTP.Types.URI (renderSimpleQuery)
 import           Network.Wai
 import           Network.Wai.Middleware.RequestLogger (logStdout)
 
@@ -38,16 +36,18 @@ import           Data.Time.Clock.POSIX     (getPOSIXTime)
 import qualified Data.Vector               as V
 import qualified Hasql.Transaction         as H
 
+import qualified Data.HashMap.Strict       as M
+
 import           PostgREST.ApiRequest   (ApiRequest(..), ContentType(..)
                                             , Action(..), Target(..)
                                             , PreferRepresentation (..)
                                             , userApiRequest)
-import           PostgREST.Auth            (tokenJWT)
+import           PostgREST.Auth            (tokenJWT, jwtClaims, containsRole)
 import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.DbStructure
 import           PostgREST.Error           (errResponse, pgErrResponse)
 import           PostgREST.Parsers
-import           PostgREST.RangeQuery
+import           PostgREST.RangeQuery      (NonnegRange, allRange, rangeOffset, restrictRange)
 import           PostgREST.Middleware
 import           PostgREST.QueryBuilder ( callProc
                                         , addJoinConditions
@@ -64,21 +64,33 @@ import           PostgREST.Types
 import           Prelude
 
 
-postgrest :: AppConfig -> DbStructure -> P.Pool -> Application
+postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> Application
-postgrest conf dbStructure pool =
+postgrest conf refDbStructure pool =
   let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in
 
   middle $ \ req respond -> do
     time <- getPOSIXTime
     body <- strictRequestBody req
+    dbStructure <- readIORef refDbStructure
 
-    let handleReq = runWithClaims conf time (app dbStructure conf body) req
+    let schema = cs $ configSchema conf
-    resp <- either pgErrResponse id <$> P.use pool
+        apiRequest = userApiRequest schema req body
-      (HT.run handleReq HT.ReadCommitted HT.Write)
+        eClaims = jwtClaims (configJwtSecret conf) (iJWT apiRequest) time
+        authed = containsRole eClaims
+        handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
+        txMode = transactionMode $ iAction apiRequest
+
+    resp <- either (pgErrResponse authed) id <$> P.use pool
+      (HT.run handleReq HT.ReadCommitted txMode)
     respond resp
 
-app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Transaction Response
+transactionMode :: Action -> H.Mode
-app dbStructure conf reqBody req =
+transactionMode ActionRead = HT.Read
+transactionMode ActionInfo = HT.Read
+transactionMode _ = HT.Write
+
+app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
+app dbStructure conf apiRequest =
   let
       -- TODO: blow up for Left values (there is a middleware that checks the headers)
       contentType = either (const ApplicationJSON) id (iAccepts apiRequest)
@@ -91,7 +103,7 @@ app dbStructure conf reqBody req =
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (q, cq) -> do
           let singular = iPreferSingular apiRequest
-              stm = createReadStatement q cq range singular
+              stm = createReadStatement q cq singular
                     shouldCount (contentType == TextCSV)
           respondToRange $ do
             row <- H.query () stm
@@ -102,11 +114,7 @@ app dbStructure conf reqBody req =
               else responseLBS status200 [contentTypeH] (cs body)
             else do
               let (status, contentRange) = rangeHeader queryTotal tableTotal
-                  canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
+                  canonical = iCanonicalQS apiRequest
-                    . sortBy (comparing fst)
-                    . map (join (***) cs)
-                    . parseSimpleQuery
-                    $ rawQueryString req
               return $ responseLBS status
                 [contentTypeH, contentRange,
                   ("Content-Location",
@@ -124,13 +132,14 @@ app dbStructure conf reqBody req =
           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 qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload
           row <- H.query uniform stm
-          let (_, _, location, body) = extractQueryResult row
+          let (_, _, fs, body) = extractQueryResult row
-          return $ responseLBS status201
+              header =
-            [
+                if null fs then []
-              contentTypeH,
+                else [(hLocation, "/" <> cs table <> renderLocationFields fs)]
-              (hLocation, "/" <> cs table <> "?" <> cs location)
+
-            ]
+          return $ if iPreferRepresentation apiRequest == Full
-            $ if iPreferRepresentation apiRequest == Full then cs body else ""
+            then responseLBS status201 (contentTypeH : header) (cs body)
+            else responseLBS status201 header ""
 
     (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) ->
       case mutateSqlParts of
@@ -143,33 +152,39 @@ app dbStructure conf reqBody req =
               s = case () of _ | queryTotal == 0 -> status404
                                | iPreferRepresentation apiRequest == Full -> status200
                                | otherwise -> status204
-          return $ responseLBS s [contentTypeH, r]
+          return $ if iPreferRepresentation apiRequest == Full
-            $ if iPreferRepresentation apiRequest == Full then cs body else ""
+            then responseLBS s [contentTypeH, r] (cs body)
+            else responseLBS s [r] ""
 
     (ActionDelete, TargetIdent qi, Nothing) ->
       case mutateSqlParts of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq) -> do
           let emptyUniform = UniformObjects V.empty
-          let fakeload = PayloadJSON emptyUniform
+              fakeload = PayloadJSON emptyUniform
-          let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload
+              stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload
           row <- H.query emptyUniform stm
-          let (_, queryTotal, _, _) = extractQueryResult row
+          let (_, queryTotal, _, body) = extractQueryResult row
+              r = contentRangeH 1 0 (toInteger <$> Just queryTotal)
           return $ if queryTotal == 0
             then notFound
-            else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
+            else if iPreferRepresentation apiRequest == Full
+              then responseLBS status200 [contentTypeH, r] (cs body)
+              else responseLBS status204 [r] ""
 
     (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
-      if isJust $ find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure)
+      let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
-        then let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
+      case mTable of
-                 pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
+        Nothing -> return notFound
-                 body = encode (TableOptions cols pkeys)
+        Just table ->
-                 filterCol :: Schema -> TableName -> Column -> Bool
+          let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
-                 filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
+              pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
-                 filterCol _ _ _ =  False in
+              body = encode (TableOptions cols pkeys)
-          return $ responseLBS status200 [jsonH, allOrigins] $ cs body
+              filterCol :: Schema -> TableName -> Column -> Bool
-        else
+              filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
-          return notFound
+              filterCol _ _ _ =  False
+              acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
+          return $ responseLBS status200 [jsonH, allOrigins, acceptH] $ cs body
 
     (ActionInvoke, TargetProc qi,
      Just (PayloadJSON (UniformObjects payload))) -> do
@@ -179,7 +194,7 @@ app dbStructure conf reqBody req =
           let p = V.head payload
               jwtSecret = configJwtSecret conf
           respondToRange $ do
-            row <- H.query () (callProc qi p range shouldCount)
+            row <- H.query () (callProc qi p topLevelRange shouldCount)
             returnJWT <- H.query qi doesProcReturnJWT
             let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, emptyArray) row
                 (status, contentRange) = rangeHeader queryTotal tableTotal
@@ -210,25 +225,32 @@ app dbStructure conf reqBody req =
   allPrKeys = dbPrimaryKeys dbStructure
   allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
   schema = cs $ configSchema conf
-  apiRequest = userApiRequest schema req reqBody
   shouldCount = iPreferCount apiRequest
-  range = restrictRange (configMaxRows conf) $ iRange apiRequest
+  topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
-  readDbRequest = DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest
+  readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) apiRequest
   mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest
   selectQuery = requestToQuery schema <$> readDbRequest
   countQuery = requestToCountQuery schema <$> readDbRequest
   mutateQuery = requestToQuery schema <$> mutateDbRequest
   readSqlParts = (,) <$> selectQuery <*> countQuery
   mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
-  respondToRange response = if range == emptyRange
+  respondToRange response = if topLevelRange == emptyRange
                             then return $ errResponse status416 "HTTP Range error"
                             else response
-  rangeHeader queryTotal tableTotal = let frm = rangeOffset range
+  rangeHeader queryTotal tableTotal = let frm = rangeOffset topLevelRange
                                           to = frm + toInteger queryTotal - 1
                                           contentRange = contentRangeH frm to (toInteger <$> tableTotal)
                                           status = rangeStatus frm to (toInteger <$> tableTotal)
                                       in (status, contentRange)
 
+splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
+splitKeyValue kv = (k, BS.tail v)
+  where (k, v) = BS.break (== '=') kv
+
+renderLocationFields :: [BS.ByteString] -> BS.ByteString
+renderLocationFields fields =
+  renderSimpleQuery True $ map splitKeyValue fields
+
 rangeStatus :: Integer -> Integer -> Maybe Integer -> Status
 rangeStatus _ _ Nothing = status200
 rangeStatus frm to (Just total)
@@ -272,68 +294,122 @@ augumentRequestWithJoin schema allRels request =
   (first formatRelationError . addRelations schema allRels Nothing) request
   >>= addJoinConditions schema
 
-buildReadRequest :: [Relation] -> ApiRequest -> Either Text ReadRequest
+addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest)
-buildReadRequest allRels apiRequest  =
+addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
-  augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> readRequest <*> ord) <*> flts)
+    flip (foldr addFilter) <$> filters,
+    flip (foldr addOrder) <$> orders,
+    flip (foldr addRange) <$> ranges
+  ]
+  {-
+  The esence of what is going on above is that we are composing tree functions
+  of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context
+  -}
+  where
+    filters :: Either ParseError [(Path, Filter)]
+    filters = mapM pRequestFilter flts
+      where
+        action = iAction apiRequest
+        flts = 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
+    orders :: Either ParseError [(Path, [OrderTerm])]
+    orders = mapM pRequestOrder $ iOrder apiRequest
+    ranges :: Either ParseError [(Path, NonnegRange)]
+    ranges = mapM pRequestRange $ M.toList $ iRange apiRequest
+
+treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest
+treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
+  where
+    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
+    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
+
+buildReadRequest :: Maybe Integer -> [Relation] -> ApiRequest -> Either Text ReadRequest
+buildReadRequest maxRows allRels apiRequest  =
+  treeRestrictRange maxRows =<<
+  augumentRequestWithJoin schema relations =<<
+  first formatParserError readRequest
   where
-    selStr = iSelect apiRequest
-    orderS = iOrder apiRequest
-    action = iAction apiRequest
-    target = iTarget apiRequest
     (schema, rootTableName) = fromJust $ -- Make it safe
+      let target = iTarget apiRequest in
       case target of
         (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
         _ -> Nothing
 
-    rootName = if action == ActionRead
+    action :: Action
-      then rootTableName
+    action = iAction apiRequest
-      else sourceCTEName
+
-    filters = if action == ActionRead
+    readRequest :: Either ParseError ReadRequest
-      then iFilters apiRequest
+    readRequest = addFiltersOrdersRanges apiRequest <*>
-      else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
+      parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
-    rels = case action of
+      where
+        selStr = iSelect apiRequest
+        rootName = if action == ActionRead
+          then rootTableName
+          else sourceCTEName
+
+    relations :: [Relation]
+    relations = case action of
       ActionCreate -> fakeSourceRelations ++ allRels
       ActionUpdate -> fakeSourceRelations ++ allRels
+      ActionDelete -> fakeSourceRelations ++ allRels
       _       -> 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 =
+buildMutateRequest apiRequest = case action of
-  mutateApiRequest
+  ActionCreate -> Insert rootTableName <$> pure payload
+  ActionUpdate -> Update rootTableName <$> pure payload <*> filters
+  ActionDelete -> Delete rootTableName <$> filters
+  _        -> Left "Unsupported HTTP verb"
   where
     action = iAction apiRequest
-    target = iTarget apiRequest
     payload = fromJust $ iPayload apiRequest
     rootTableName = -- TODO: Make it safe
+      let target = iTarget apiRequest in
       case target of
         (TargetIdent (QualifiedIdentifier _ t) ) -> t
         _ -> undefined
-    mutateApiRequest = case action of
+    filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
-      ActionCreate -> Insert rootTableName <$> pure payload
+      where mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
-      ActionUpdate -> Update rootTableName <$> pure payload <*> cond
+
-      ActionDelete -> Delete rootTableName <$> cond
+addFilterToNode :: Filter -> ReadRequest -> ReadRequest
-      _        -> Left "Unsupported HTTP verb"
+addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f
-    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 = addProperty addFilterToNode
-addFilter (path, flt) (Node rn forest) =
+
+addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest
+addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f
+
+addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest
+addOrder = addProperty addOrderToNode
+
+addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest
+addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f
+
+addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest
+addRange = addProperty addRangeToNode
+
+addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest
+addProperty f ([], a) n = f a n
+addProperty f (path, a) (Node rn forest) =
   case targetNode of
-    Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
+    Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path
-    Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
+    Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest)
   where
     targetNodeName:remainingPath = path
     (targetNode,restForest) = splitForest targetNodeName forest
+    splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode)
     splitForest name forst =
       case maybeNode of
         Nothing -> (Nothing,forest)
         Just node -> (Just node, delete node forest)
-      where maybeNode = find ((name==).fst.snd.rootLabel) forst
+      where
+        maybeNode :: Maybe ReadRequest
+        maybeNode = find fnd forst
+          where
+            fnd :: ReadRequest -> Bool
+            fnd (Node (_,(n,_,_)) _) = n == name
 
 -- in a relation where one of the tables mathces "TableName"
 -- replace the name to that table with pg_source
@@ -359,4 +435,4 @@ instance ToJSON TableOptions where
 
 
 extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
-extractQueryResult = fromMaybe (Nothing, 0, "", "")
+extractQueryResult = fromMaybe (Nothing, 0, [], "")

src/PostgREST/Auth.hs

@@ -12,20 +12,20 @@ In the test suite there is an example of simple login function that can be used
 very simple authentication system inside the PostgreSQL database.
 -}
 module PostgREST.Auth (
-    setRole
+    claimsToSQL
-  , claimsToSQL
+  , containsRole
   , jwtClaims
   , tokenJWT
   ) where
 
-import           Control.Lens
+import           Lens.Micro
+import           Lens.Micro.Aeson
 import           Data.Aeson              (Value (..), parseJSON, toJSON)
-import           Data.Aeson.Lens
 import           Data.Aeson.Types        (parseMaybe, emptyObject, emptyArray)
 import qualified Data.ByteString         as BS
 import qualified Data.Vector             as V
 import qualified Data.HashMap.Strict     as M
-import           Data.Maybe              (fromMaybe)
+import           Data.Maybe              (fromMaybe, maybeToList, fromJust)
 import           Data.Monoid             ((<>))
 import           Data.String.Conversions (cs)
 import           Data.Text               (Text)
@@ -34,47 +34,41 @@ import           PostgREST.QueryBuilder  (pgFmtIdent, pgFmtLit, unquoted)
 import qualified Web.JWT                 as JWT
 
 {-|
-  Receives a map of JWT claims and returns a list
+  Receives a map of JWT claims and returns a list of PostgreSQL
-  of PostgreSQL statements to set the claims as user defined GUCs.
+  statements to set the claims as user defined GUCs.  Except if we
-  Except if we have a claim called role,
+  have a claim called role, this one is mapped to a SET ROLE
-  this one is mapped to a SET ROLE statement.
+  statement.
-  In case there is any problem decoding the JWT it returns Nothing.
 -}
 claimsToSQL :: M.HashMap Text Value -> [BS.ByteString]
-claimsToSQL = map setVar . M.toList
+claimsToSQL claims = roleStmts <> varStmts
-  where
+ where
-    setVar ("role", String val) = setRole val
+  roleStmts = maybeToList $
-    setVar (k, val) = "set local " <> cs (pgFmtIdent $ "postgrest.claims." <> k)
+    (\r -> "set local role " <> r <> ";") . cs . valueToVariable <$> M.lookup "role" claims
-                      <> " = " <> cs (valueToVariable val) <> ";"
+  varStmts = map setVar $ M.toList (M.delete "role" claims)
-    valueToVariable = pgFmtLit . unquoted
+  setVar (k, val) = "set local " <> cs (pgFmtIdent $ "postgrest.claims." <> k)
+                    <> " = " <> cs (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.
+  In case there is any problem decoding the JWT it returns an error Text
 -}
-
-
 jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> Either Text (M.HashMap Text Value)
-jwtClaims secret input time =
+jwtClaims _ "" _ = Right M.empty
-  case mClaims of
+jwtClaims secret jwt time =
-    Nothing -> Right M.empty
+  case isExpired <$> mClaims of
-    Just claims -> do
+    Just True -> Left "JWT expired"
-      let mExp = claims ^? key "exp" . _Integer
+    Nothing -> Left "Invalid JWT"
-          expired = fromMaybe False $ (<= time) . fromInteger <$> mExp
+    Just False -> Right $ value2map $ fromJust mClaims
-      if expired
-        then Left "JWT expired"
-        else Right (value2map claims)
  where
-  mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret input
+  isExpired claims =
+    let mExp = claims ^? key "exp" . _Integer
+    in fromMaybe False $ (<= time) . fromInteger <$> mExp
+  mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret jwt
   value2map (Object o) = o
   value2map _          = M.empty
 
-{-| Receives the name of a role and returns a SET ROLE statement -}
-setRole :: Text -> BS.ByteString
-setRole r = "set local role " <> cs (pgFmtLit r) <> ";"
-
-
 {-|
   Receives the JWT secret (from config) and a JWT and a JSON value
   and returns a signed JWT.
@@ -85,3 +79,10 @@ tokenJWT secret (Array arr) =
       jcs = parseMaybe parseJSON obj :: Maybe JWT.JWTClaimsSet in
   JWT.encodeSigned JWT.HS256 secret $ fromMaybe JWT.def jcs
 tokenJWT secret _ = tokenJWT secret emptyArray
+
+{-|
+  Whether a response from jwtClaims contains a role claim
+-}
+containsRole :: Either Text (M.HashMap Text Value) -> Bool
+containsRole (Left _) = False
+containsRole (Right claims) = M.member "role" claims

src/PostgREST/Error.hs

@@ -21,9 +21,15 @@ import           Network.Wai               (Response, responseLBS)
 errResponse :: HT.Status -> Text -> Response
 errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"])
 
-pgErrResponse :: P.UsageError -> Response
+pgErrResponse :: Bool -> P.UsageError -> Response
-pgErrResponse e = responseLBS (httpStatus e)
+pgErrResponse authed e =
-  [(hContentType, "application/json")] (JSON.encode e)
+  let status = httpStatus authed e
+      jsonType = (hContentType, "application/json")
+      wwwAuth = ("WWW-Authenticate", "Bearer")
+      hdrs = if status == HT.status401
+                then [jsonType, wwwAuth]
+                else [jsonType] in
+  responseLBS status hdrs (JSON.encode e)
 
 instance JSON.ToJSON P.UsageError where
   toJSON (P.ConnectionError e) = JSON.object [
@@ -60,10 +66,9 @@ instance JSON.ToJSON H.Error where
     "message" .= ("Database client error"::String),
     "details" .= (fmap cs d::Maybe T.Text)]
 
-httpStatus :: P.UsageError -> HT.Status
+httpStatus :: Bool -> P.UsageError -> HT.Status
-httpStatus (P.ConnectionError _) =
+httpStatus _ (P.ConnectionError _) = HT.status500
-  HT.status500
+httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
-httpStatus (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
   case cs c of
     '0':'8':_ -> HT.status503 -- pg connection err
     '0':'9':_ -> HT.status500 -- triggered action exception
@@ -88,7 +93,7 @@ httpStatus (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
     'P':'0':_ -> HT.status500 -- PL/pgSQL Error
     'X':'X':_ -> HT.status500 -- internal Error
     "42P01"   -> HT.status404 -- undefined table
-    "42501"   -> HT.status404 -- insufficient privilege
+    "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
     _         -> HT.status400
-httpStatus (P.SessionError (H.ResultError _)) = HT.status500
+httpStatus _ (P.SessionError (H.ResultError _)) = HT.status500
-httpStatus (P.SessionError (H.ClientError _)) = HT.status503
+httpStatus _ (P.SessionError (H.ClientError _)) = HT.status503

src/PostgREST/Middleware.hs

@@ -3,16 +3,13 @@
 
 module PostgREST.Middleware where
 
-import           Control.Monad                 (unless)
+import           Data.Aeson                    (Value (..))
-import qualified Data.ByteString               as BS
 import qualified Data.HashMap.Strict           as M
-import           Data.Maybe                    (fromMaybe)
 import           Data.String.Conversions       (cs)
 import           Data.Text
-import           Data.Time.Clock               (NominalDiffTime)
 import qualified Hasql.Transaction             as H
 
-import           Network.HTTP.Types.Header     (hAccept, hAuthorization)
+import           Network.HTTP.Types.Header     (hAccept)
 import           Network.HTTP.Types.Status     (status400, status415)
 import           Network.Wai                   (Application, Request (..),
                                                 Response, requestHeaders)
@@ -20,37 +17,25 @@ 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.ApiRequest          (ApiRequest(..), pickContentType)
-import           PostgREST.Auth                (setRole, jwtClaims, claimsToSQL)
+import           PostgREST.Auth                (claimsToSQL)
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 import           PostgREST.Error               (errResponse)
 
 import           Prelude                       hiding (concat, null)
 
-runWithClaims :: AppConfig -> NominalDiffTime ->
+runWithClaims :: AppConfig -> Either Text (M.HashMap Text Value) ->
-                 (Request -> H.Transaction Response) ->
+                 (ApiRequest -> H.Transaction Response) ->
-                 Request -> H.Transaction Response
+                 ApiRequest -> H.Transaction Response
-runWithClaims conf time app req = do
+runWithClaims conf eClaims app req =
-    H.sql setAnon
+  case eClaims of
-    let tokenStr = case split (== ' ') (cs auth) of
+    Left e -> clientErr e
-          ("Bearer" : t : _) -> t
+    Right claims -> do
-          _                  -> ""
+          -- role claim defaults to anon if not specified in jwt
-        eClaims = jwtClaims jwtSecret tokenStr time
+          H.sql . mconcat . claimsToSQL $ M.union claims (M.singleton "role" anon)
-    case eClaims of
+          app req
-      Left e -> clientErr e
-      Right claims ->
-        if M.null claims && not (null tokenStr)
-          then clientErr "Invalid JWT"
-          else do
-            let cmdBatch = mconcat $ claimsToSQL claims
-            unless (BS.null cmdBatch) (H.sql cmdBatch)
-            app req
   where
-    hdrs = requestHeaders req
+    anon = String . cs $ configAnonRole conf
-    jwtSecret = configJwtSecret conf
-    auth = fromMaybe "" $ lookup hAuthorization hdrs
-    anon = cs $ configAnonRole conf
-    setAnon = setRole anon
     clientErr = return . errResponse status400
 
 unsupportedAccept :: Application -> Application

src/PostgREST/Parsers.hs

@@ -6,22 +6,27 @@ where
 import           Control.Applicative           hiding ((<$>))
 import           Data.Monoid
 import           Data.String.Conversions       (cs)
-import           Data.Text                     (Text)
+import           Data.Text                     (Text, intercalate)
 import           Data.Tree
 import           PostgREST.QueryBuilder        (operators)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
+import           PostgREST.RangeQuery      (NonnegRange,allRange)
 
 pRequestSelect :: Text -> Parser ReadRequest
 pRequestSelect rootNodeName = do
   fieldTree <- pFieldForest
-  return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree
+  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree
   where
+    readQuery = Select [] [rootNodeName] [] Nothing allRange
     treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
-    treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =
+    treeEntry (Node fld@((fn, _),_,alias) 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)
+        _  -> Node (q, i) newForest
+          where
+            newForest =
+              foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest
 
 pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
 pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
@@ -33,6 +38,19 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
     op = fst <$> opVal
     val = snd <$> opVal
 
+pRequestOrder :: (String, String) -> Either ParseError (Path, [OrderTerm])
+pRequestOrder (k, v) = (,) <$> path <*> ord
+  where
+    treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k
+    path = fst <$> treePath
+    ord = parse pOrder ("failed to parse order (" ++ v ++ ")") v
+
+pRequestRange :: (String, NonnegRange) -> Either ParseError (Path, NonnegRange)
+pRequestRange (k, v) = (,) <$> path <*> pure v
+  where
+    treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k
+    path = fst <$> treePath
+
 ws :: Parser Text
 ws = cs <$> many (oneOf " \t")
 
@@ -51,15 +69,23 @@ pFieldForest :: Parser [Tree SelectItem]
 pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
 
 pFieldTree :: Parser (Tree SelectItem)
-pFieldTree = try (Node <$> pSelect <*> between (char '{') (char '}') pFieldForest)
+pFieldTree = try (Node <$> pSimpleSelect <*> between (char '{') (char '}') pFieldForest)
           <|>     Node <$> pSelect <*> pure []
 
 pStar :: Parser Text
 pStar = cs <$> (string "*" *> pure ("*"::String))
 
+
 pFieldName :: Parser Text
-pFieldName =  cs <$> (many1 (letter <|> digit <|> oneOf "_")
+pFieldName = do
-          <?> "field name (* or [a..z0..9_])")
+  matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"
+  return $ intercalate "-" $ map cs matches
+  where
+    isDash :: GenParser Char st ()
+    isDash = try ( char '-' >> notFollowedBy (char '>') )
+    dash :: Parser Char
+    dash = isDash *> pure '-'
+
 
 pJsonPathStep :: Parser Text
 pJsonPathStep = cs <$> try (string "->" *> pFieldName)
@@ -70,12 +96,28 @@ pJsonPath = (++) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldN
 pField :: Parser Field
 pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath
 
+aliasSeparator :: Parser ()
+aliasSeparator = char ':' >> notFollowedBy (char ':')
+
+pSimpleSelect :: Parser SelectItem
+pSimpleSelect = lexeme $ try ( do
+    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
+    fld <- pField
+    return (fld, Nothing, alias)
+  )
+
 pSelect :: Parser SelectItem
 pSelect = lexeme $
-  try ((,) <$> pField <*>((cs <$>) <$> optionMaybe (string "::" *> many letter)) )
+  try (
+    do
+      alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
+      fld <- pField
+      cast <- optionMaybe (string "::" *> many letter)
+      return (fld, cs <$> cast, alias)
+  )
   <|> do
     s <- pStar
-    return ((s, Nothing), Nothing)
+    return ((s, Nothing), Nothing, Nothing)
 
 pOperator :: Parser Operator
 pOperator = cs <$> (pOp <?> "operator (eq, gt, ...)")

src/PostgREST/QueryBuilder.hs

@@ -35,18 +35,18 @@ import qualified Hasql.Decoders          as HD
 import qualified Data.Aeson              as JSON
 import           Data.Int                (Int64)
 
-import           PostgREST.RangeQuery    (NonnegRange, rangeLimit, rangeOffset)
+import           PostgREST.RangeQuery    (NonnegRange, rangeLimit, rangeOffset, allRange)
-import           Control.Error           (note, fromMaybe, mapMaybe)
+import           Control.Error           (note, fromMaybe)
 import           Data.Functor.Contravariant (contramap)
 import qualified Data.HashMap.Strict     as HM
-import           Data.List               (find, (\\))
+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 qualified Data.Text as T          (map, takeWhile, null)
 import qualified Data.Text.Encoding as T
 import           Data.String.Conversions (cs)
 import           Control.Applicative     ((<|>))
-import           Control.Monad           (join)
+import           Control.Monad           (replicateM)
 import           Data.Tree               (Tree(..))
 import qualified Data.Vector as V
 import           PostgREST.Types
@@ -61,9 +61,20 @@ import           Data.Scientific         ( FPFormat (..)
 import           Prelude hiding          (unwords)
 import           PostgREST.ApiRequest    (PreferRepresentation (..))
 
+{-| The generic query result format used by API responses. The location header
+    is represented as a list of strings containing variable bindings like
+    @"k1=eq.42"@, or the empty list if there is no location header.
+-}
+type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString)
 
-{-| The generic query result format used by API responses -}
+standardRow :: HD.Row ResultsWithCount
-type ResultsWithCount = (Maybe Int64, Int64, BS.ByteString, BS.ByteString)
+standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
+                    <*> HD.value header <*> HD.value HD.bytea
+  where
+    header = HD.array $ HD.arrayDimension replicateM $ HD.arrayValue HD.bytea
+
+noLocationF :: Text
+noLocationF = "array[]::text[]"
 
 {-| Read and Write api requests use a similar response format which includes
     various record counts and possible location header. This is the decoder
@@ -72,16 +83,10 @@ type ResultsWithCount = (Maybe Int64, Int64, BS.ByteString, BS.ByteString)
 decodeStandard :: HD.Result ResultsWithCount
 decodeStandard =
   HD.singleRow standardRow
- where
-  standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
-                      <*> HD.value HD.bytea <*> HD.value HD.bytea
 
 decodeStandardMay :: HD.Result (Maybe ResultsWithCount)
 decodeStandardMay =
   HD.maybeRow standardRow
- where
-  standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
-                      <*> HD.value HD.bytea <*> HD.value HD.bytea
 
 {-| JSON and CSV payloads from the client are given to us as
     UniformObjects (objects who all have the same keys),
@@ -91,19 +96,19 @@ encodeUniformObjs :: HE.Params UniformObjects
 encodeUniformObjs =
   contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json)
 
-createReadStatement :: SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool ->
+createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
                        H.Query () ResultsWithCount
-createReadStatement selectQuery countQuery range isSingle countTotal asCsv =
+createReadStatement selectQuery countQuery isSingle countTotal asCsv =
   unicodeStatement sql HE.unit decodeStandard True
  where
   sql = [qc|
       WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}
-      FROM ( SELECT * FROM {sourceCTEName} {limitF range}) t |]
+      FROM ( SELECT * FROM {sourceCTEName}) t |]
   countResultF = if countTotal then "("<>countQuery<>")" else "null"
   cols = intercalate ", " [
       countResultF <> " AS total_result_set",
       "pg_catalog.count(t) AS page_total",
-      "'' AS header",
+      noLocationF <> " AS header",
       bodyF <> " AS body"
     ]
   bodyF
@@ -121,7 +126,7 @@ createWriteStatement _ _ mutateQuery _ None
  where
   sql = [qc|
       WITH {sourceCTEName} AS ({mutateQuery})
-      SELECT '', 0, '', '' |]
+      SELECT '', 0, {noLocationF}, '' |]
 
 createWriteStatement qi _ mutateQuery isSingle HeadersOnly
                      pKeys _ (PayloadJSON (UniformObjects _)) =
@@ -134,7 +139,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly
   cols = intercalate ", " [
       "'' AS total_result_set",
       "pg_catalog.count(t) AS page_total",
-      if isSingle then locationF pKeys else "''",
+      if isSingle then locationF pKeys else noLocationF,
       "''"
     ]
 
@@ -149,7 +154,7 @@ createWriteStatement qi selectQuery mutateQuery isSingle Full
   cols = intercalate ", " [
       "'' AS total_result_set", -- when updateing it does not make sense
       "pg_catalog.count(t) AS page_total",
-      if isSingle then locationF pKeys else "''" <> " AS header",
+      if isSingle then locationF pKeys else noLocationF <> " AS header",
       bodyF <> " AS body"
     ]
   bodyF
@@ -158,18 +163,18 @@ createWriteStatement qi selectQuery mutateQuery isSingle Full
     | otherwise = asJsonF
 
 addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest
-addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _)) forest) =
+addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _, alias)) forest) =
   case parentNode of
-    (Just (Node (Select{from=[parentTable]}, (_, _)) _)) -> Node <$> (addRel readNode <$> rel) <*> updatedForest
+    (Just (Node (Select{from=[parentTable]}, (_, _, _)) _)) -> Node <$> (addRel readNode <$> rel) <*> updatedForest
       where
         rel = note ("no relation between " <> parentTable <> " and " <> name)
             $  findRelationByTable schema name parentTable
            <|> findRelationByColumn schema parentTable name
-        addRel :: (ReadQuery, (NodeName, Maybe Relation)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation))
+        addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
-        addRel (query', (n, _)) r = (query' {from=fromRelation}, (n, Just r))
+        addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a))
           where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query')
 
-    _ -> Node (query, (name, Nothing)) <$> updatedForest
+    _ -> Node (query, (name, Nothing, alias)) <$> updatedForest
   where
     updatedForest = mapM (addRelations schema allRelations (Just node)) forest
     -- Searches through all the relations and returns a match given the parameter conditions.
@@ -182,25 +187,18 @@ addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _
       where n `colMatches` rc = (cs ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (cs n :: BS.ByteString)
 
 addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest
-addJoinConditions schema (Node (query, (n, r)) forest) =
+addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
   case r of
-    Nothing -> Node (updatedQuery, (n,r))  <$> updatedForest -- this is the root node
+    Nothing -> Node nn  <$> updatedForest -- this is the root node
-    Just rel@Relation{relType=Child} -> Node (addCond updatedQuery (getJoinConditions rel),(n,r)) <$> updatedForest
+    Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest
-    Just Relation{relType=Parent} -> Node (updatedQuery, (n,r)) <$> updatedForest
+    Just Relation{relType=Parent} -> Node nn <$> updatedForest
     Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->
-      Node (qq, (n, r)) <$> updatedForest
+      Node (qq, (n, r, a)) <$> updatedForest
       where
-         query' = addCond updatedQuery (getJoinConditions rel)
+         query' = addCond query (getJoinConditions rel)
          qq = query'{from=tableName linkTable : from query'}
     _ -> 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 query' con = query'{flt_=con ++ flt_ query'}
 
@@ -262,7 +260,7 @@ pgFmtLit x =
 
 requestToCountQuery :: Schema -> DbRequest -> SqlQuery
 requestToCountQuery _ (DbMutate _) = undefined
-requestToCountQuery schema (DbRead (Node (Select _ _ conditions _, (mainTbl, _)) _)) =
+requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _, _)) _)) =
  unwords [
    "SELECT pg_catalog.count(1)",
    "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
@@ -276,7 +274,7 @@ requestToCountQuery schema (DbRead (Node (Select _ _ conditions _, (mainTbl, _))
 requestToQuery :: Schema -> DbRequest -> SqlQuery
 requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined
 requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined
-requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (nodeName, maybeRelation)) forest)) =
+requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) =
   query
   where
     -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
@@ -288,9 +286,10 @@ requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (nod
     query = unwords [
       "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
       "FROM ", intercalate ", " (map (fromQi . toQi) tbls),
-      unwords (map joinStr joins),
+      unwords joins,
-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) localConditions )) `emptyOnNull` localConditions,
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
-      orderF (fromMaybe [] ord)
+      orderF (fromMaybe [] ord),
+      limitF range
       ]
     orderF ts =
         if null ts
@@ -304,50 +303,48 @@ requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (nod
                 <> (cs.show) (otDirection t) <> " "
                 <> maybe "" (cs.show) (otNullOrder t) <> " "
     (joins, selects) = foldr getQueryParts ([],[]) forest
-    parentTables = map snd joins
+
-    parentConditions = join $ map (( `filter` conditions ) . filterParentConditions) parentTables
+    getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
-    localConditions = conditions \\ parentConditions
+    getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s)
-    joinStr :: (SqlFragment, TableName) -> SqlFragment
-    joinStr (sql, t) = "LEFT OUTER JOIN " <> sql <> " ON " <>
-      intercalate " AND " ( map (pgFmtCondition qi ) joinConditions )
-      where
-        joinConditions = filter (filterParentConditions t) conditions
-    filterParentConditions parentTable (Filter _ _ (VForeignKey (QualifiedIdentifier "" t) _)) = parentTable == t
-    filterParentConditions _ _ = False
-    getQueryParts :: Tree ReadNode -> ([(SqlFragment, TableName)], [SqlFragment]) -> ([(SqlFragment,TableName)], [SqlFragment])
-    getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}})) forst) (j,s) = (j,sel:s)
       where
         sel = "COALESCE(("
            <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
            <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
-           <> "), '[]') AS " <> pgFmtIdent name
+           <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
            where subquery = requestToQuery schema (DbRead (Node n forst))
-    getQueryParts (Node n@(_, (name, Just Relation{relType=Parent,relTable=Table{tableName=table}})) forst) (j,s) = (joi:j,sel:s)
+    getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (joi:j,sel:s)
       where
-        sel = "row_to_json(" <> pgFmtIdent table <> ".*) AS "<>pgFmtIdent name --TODO must be singular
+        node_name = fromMaybe name alias
-        joi = ("( " <> subquery <> " ) AS " <> pgFmtIdent table, table)
+        local_table_name = table <> "_" <> node_name
+        replaceTableName localTableName (Filter a b (VForeignKey (QualifiedIdentifier "" _) c)) = Filter a b (VForeignKey (QualifiedIdentifier "" localTableName) c)
+        replaceTableName _ x = x
+        sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name
+        joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name  <>
+              " ON " <> intercalate " AND " ( map (pgFmtCondition qi . replaceTableName local_table_name) (getJoinConditions r) )
           where subquery = requestToQuery schema (DbRead (Node n forst))
-    getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}})) forst) (j,s) = (j,sel:s)
+    getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s)
       where
         sel = "COALESCE (("
            <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
            <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
-           <> "), '[]') AS " <> pgFmtIdent name
+           <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
            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
+    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
+      colsString = intercalate ", " cols
-  unwords [
+      insInto = unwords [ "INSERT INTO" , fromQi qi,
-    "INSERT INTO ", fromQi qi,
+          if T.null colsString then "" else "(" <> colsString <> ")"
-    " (" <> colsString <> ")" <>
+        ]
-    " SELECT " <> colsString <>
+      vals = unwords $ if T.null colsString
-    " FROM json_populate_recordset(null::" , fromQi qi, ", $1)"
+                then ["DEFAULT VALUES"]
-    ]
+                else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] in
+  insInto <> vals
+
 requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) =
   case rows V.!? 0 of
     Just obj ->
@@ -361,7 +358,6 @@ requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects row
     Nothing -> undefined
   where
     qi = QualifiedIdentifier schema mainTbl
-
 requestToQuery schema (DbMutate (Delete mainTbl conditions)) =
   query
   where
@@ -406,7 +402,7 @@ locationF :: [Text] -> SqlFragment
 locationF pKeys =
     "(" <>
     " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceCTEName <> " as ss  limit 1)" <>
-    " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <>
+    " SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))" <>
     " FROM s, json_each_text(s.r) AS json_data" <>
     (
       if null pKeys
@@ -415,7 +411,9 @@ locationF pKeys =
     ) <> ")"
 
 limitF :: NonnegRange -> SqlFragment
-limitF r  = "LIMIT " <> limit <> " OFFSET " <> offset
+limitF r  = if r == allRange
+  then ""
+  else "LIMIT " <> limit <> " OFFSET " <> offset
   where
     limit  = maybe "ALL" (cs . show) $ rangeLimit r
     offset = cs . show $ rangeOffset r
@@ -463,8 +461,8 @@ 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), Nothing, alias) = pgFmtField table f <> pgFmtAs jp alias
-pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAsJsonPath jp
+pgFmtSelectItem table (f@(_, jp), Just cast, alias) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs jp alias
 
 pgFmtCondition :: QualifiedIdentifier -> Filter -> SqlFragment
 pgFmtCondition table (Filter (col,jp) ops val) =
@@ -511,9 +509,10 @@ pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
 pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )
 pgFmtJsonPath _ = ""
 
-pgFmtAsJsonPath :: Maybe JsonPath -> SqlFragment
+pgFmtAs :: Maybe JsonPath -> Maybe Alias -> SqlFragment
-pgFmtAsJsonPath Nothing = ""
+pgFmtAs Nothing Nothing = ""
-pgFmtAsJsonPath (Just xx) = " AS " <> last xx
+pgFmtAs (Just xx) Nothing = " AS " <> pgFmtIdent (last xx)
+pgFmtAs _ (Just alias) = " AS " <> pgFmtIdent alias
 
 trimNullChars :: Text -> Text
 trimNullChars = T.takeWhile (/= '\x0')

src/PostgREST/RangeQuery.hs

@@ -4,13 +4,14 @@ module PostgREST.RangeQuery (
 , rangeLimit
 , rangeOffset
 , restrictRange
+, rangeGeq
+, allRange
 , NonnegRange
 ) where
 
 
 import           Control.Applicative
 import           Network.HTTP.Types.Header
-import           PostgREST.Types           ()
 
 import qualified Data.ByteString.Char8     as BS
 import           Data.Ranged.Boundaries
@@ -34,18 +35,19 @@ rangeParse range = do
     Just parsedRange ->
       let [_, from, to] = readMaybe . cs <$> parsedRange
           lower         = fromMaybe emptyRange   (rangeGeq <$> from)
-          upper         = fromMaybe (rangeGeq 0) (rangeLeq <$> to) in
+          upper         = fromMaybe allRange (rangeLeq <$> to) in
       rangeIntersection lower upper
-    Nothing -> rangeGeq 0
+    Nothing -> allRange
 
 rangeRequested :: RequestHeaders -> NonnegRange
-rangeRequested = rangeParse . fromMaybe "" . lookup hRange
+rangeRequested headers = fromMaybe allRange $
+  rangeParse <$> lookup hRange headers
 
 restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange
 restrictRange Nothing r = r
 restrictRange (Just limit) r =
-  rangeIntersection r $
+   rangeIntersection r $
-    Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)
+     Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)
 
 rangeLimit :: NonnegRange -> Maybe Integer
 rangeLimit range =
@@ -63,6 +65,9 @@ rangeGeq :: Integer -> NonnegRange
 rangeGeq n =
   Range (BoundaryBelow n) BoundaryAboveAll
 
+allRange :: NonnegRange
+allRange = rangeGeq 0
+
 rangeLeq :: Integer -> NonnegRange
 rangeLeq n =
   Range BoundaryBelowAll (BoundaryAbove n)

src/PostgREST/Types.hs

@@ -6,6 +6,7 @@ import           Data.Int             (Int32)
 import           Data.Text
 import           Data.Tree
 import qualified Data.Vector          as V
+import           PostgREST.RangeQuery (NonnegRange)
 
 data DbStructure = DbStructure {
   dbTables      :: [Table]
@@ -106,16 +107,17 @@ data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (
 type FieldName = Text
 type JsonPath = [Text]
 type Field = (FieldName, Maybe JsonPath)
+type Alias = Text
 type Cast = Text
 type NodeName = Text
-type SelectItem = (Field, Maybe Cast)
+type SelectItem = (Field, Maybe Cast, Maybe Alias)
 type Path = [Text]
-data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm] } deriving (Show, Eq)
+data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
 data MutateQuery = Insert { in_::TableName, qPayload::Payload }
                  | Delete { in_::TableName, where_::[Filter] }
                  | Update { in_::TableName, 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 ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
 type ReadRequest = Tree ReadNode
 type MutateRequest = MutateQuery
 data DbRequest = DbRead ReadRequest | DbMutate MutateRequest

stack.yaml

@@ -1,15 +1,24 @@
-resolver: lts-5.5
+resolver: lts-6.2
 extra-deps:
   - Ranged-sets-0.3.0
-  - bytestring-tree-builder-0.2.5
+  - bytestring-tree-builder-0.2.7
-  - hasql-0.19.9
+  - hasql-0.19.12
-  - hasql-pool-0.4
+  - hasql-pool-0.4.1
-  - hasql-transaction-0.4.3
+  - hasql-transaction-0.4.5
-  - packdeps-0.4.2.1
+  - jwt-0.7.2
+  - postgresql-binary-0.9.0.1
+  - binary-parser-0.5.2
+  - contravariant-extras-0.3.2
+  - placeholders-0.1
   - postgresql-error-codes-1
-  - postgresql-binary-0.8.1
+  - success-0.2.6
+  - tuple-th-0.2.5
+  - wai-cors-0.2.5
+  - cryptohash-sha256-0.11.100.0
+  - hackage-security-0.5.2.1
+
 ghc-options:
-  postgrest: -O2 -Werror -Wall -fwarn-monomorphism-restriction -fwarn-missing-exported-sigs -fwarn-identities
+  postgrest: -O2 -Werror -Wall -fwarn-identities
 
 packages:
-- '.'
+- .

test/Feature/AuthSpec.hs

@@ -13,8 +13,29 @@ import Network.Wai (Application)
 spec :: SpecWith Application
 spec = describe "authorization" $ do
 
-  it "hides tables that anonymous does not own" $
+  it "denies access to tables that anonymous does not own" $
-    get "/authors_only" `shouldRespondWith` 404
+    get "/authors_only" `shouldRespondWith` ResponseMatcher {
+        matchBody = Just [json| {
+          "hint":null,
+          "details":null,
+          "code":"42501",
+          "message":"permission denied for relation authors_only"} |]
+      , matchStatus = 401
+      , matchHeaders = ["WWW-Authenticate" <:> "Bearer"]
+      }
+
+  it "denies access to tables that postgrest_test_author does not own" $
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" in
+    request methodGet "/private_table" [auth] ""
+      `shouldRespondWith` ResponseMatcher {
+        matchBody = Just [json| {
+          "hint":null,
+          "details":null,
+          "code":"42501",
+          "message":"permission denied for relation private_table"} |]
+      , matchStatus = 403
+      , matchHeaders = []
+      }
 
   it "returns jwt functions as jwt tokens" $
     post "/rpc/login" [json| { "id": "jdoe", "pass": "1234" } |]

test/Feature/DeleteSpec.hs

@@ -19,6 +19,28 @@ spec =
           , matchHeaders = ["Content-Range" <:> "*/1"]
           }
 
+      it "returns the deleted item" $
+        request methodDelete "/items?id=eq.2" [("Prefer", "return=representation")] ""
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":2}]|]
+          , matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "*/1"]
+          }
+      it "returns the deleted item and shapes the response" $
+        request methodDelete "/complex_items?id=eq.2&select=id,name" [("Prefer", "return=representation")] ""
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":2,"name":"Two"}]|]
+          , matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "*/1"]
+          }
+      it "can embed (parent) entities" $
+        request methodDelete "/tasks?id=eq.8&select=id,name,project{id}" [("Prefer", "return=representation")] ""
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|]
+          , matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "*/1"]
+          }
+
       it "actually clears items ouf the db" $ do
         _ <- request methodDelete "/items?id=lt.15" [] ""
         get "/items"

test/Feature/InsertSpec.hs

@@ -32,6 +32,8 @@ spec = do
         liftIO $ do
           simpleBody p `shouldBe` ""
           simpleStatus p `shouldBe` created201
+          -- should not have content type set when body is empty
+          lookup hContentType (simpleHeaders p) `shouldBe` Nothing
 
       it "filters columns in result using &select" $
         request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]
@@ -53,6 +55,15 @@ spec = do
           , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8", "Location" <:> "/projects?id=eq.6"]
           }
 
+    context "from an html form" $
+      it "accepts disparate json types" $ do
+        p <- request methodPost "/menagerie"
+               [("Content-Type", "application/x-www-form-urlencoded")]
+               ("integer=7&double=2.71828&varchar=forms+are+fun&" <>
+                "boolean=false&date=1900-01-01&money=$3.99&enum=foo")
+        liftIO $ do
+          simpleBody p `shouldBe` ""
+          simpleStatus p `shouldBe` created201
 
     context "with no pk supplied" $ do
       context "into a table with auto-incrementing pk" $
@@ -110,13 +121,32 @@ spec = do
             simpleStatus p `shouldBe` created201
 
     context "with compound pk supplied" $
-      it "builds response location header appropriately" $
+      it "builds response location header appropriately" $ do
-        post "/compound_pk" [json| { "k1":12, "k2":42 } |]
+        let inserted    = [json| { "k1":12, "k2":"Rock & R+ll" } |]
-          `shouldRespondWith` ResponseMatcher {
+            expectedObj = CompoundPK 12 "Rock & R+ll" Nothing
-            matchBody    = Nothing,
+            expectedLoc = "/compound_pk?k1=eq.12&k2=eq.Rock%20%26%20R%2Bll"
-            matchStatus  = 201,
+        p <- request methodPost "/compound_pk"
-            matchHeaders = ["Location" <:> "/compound_pk?k1=eq.12&k2=eq.42"]
+                     [("Prefer", "return=representation")]
-          }
+                     inserted
+        liftIO $ do
+          JSON.decode (simpleBody p) `shouldBe` Just expectedObj
+          simpleStatus p `shouldBe` created201
+          lookup hLocation (simpleHeaders p) `shouldBe` Just expectedLoc
+
+        r <- get expectedLoc
+        liftIO $ do
+          JSON.decode (simpleBody r) `shouldBe` Just [expectedObj]
+          simpleStatus r `shouldBe` ok200
+
+    context "with bulk insert" $
+      it "returns 201 but no location header" $ do
+        let bulkData = [json| [ {"k1":21, "k2":"hello world"}
+                              , {"k1":22, "k2":"bye for now"}]
+                            |]
+        p <- request methodPost "/compound_pk" [] bulkData
+        liftIO $ do
+          simpleStatus p `shouldBe` created201
+          lookup hLocation (simpleHeaders p) `shouldBe` Nothing
 
     context "with invalid json payload" $
       it "fails with 400 and error" $
@@ -137,24 +167,34 @@ spec = do
     context "jsonb" $ do
       it "serializes nested object" $ do
         let inserted = [json| { "data": { "foo":"bar" } } |]
+            location = "/json?data=eq.%7B%22foo%22%3A%22bar%22%7D"
         request methodPost "/json"
                      [("Prefer", "return=representation")]
                      inserted
           `shouldRespondWith` ResponseMatcher {
             matchBody    = Just inserted
           , matchStatus  = 201
-          , matchHeaders = ["Location" <:> [str|/json?data=eq.{"foo":"bar"}|]]
+          , matchHeaders = ["Location" <:> location]
           }
 
       it "serializes nested array" $ do
         let inserted = [json| { "data": [1,2,3] } |]
+            location = "/json?data=eq.%5B1%2C2%2C3%5D"
         request methodPost "/json"
                      [("Prefer", "return=representation")]
                      inserted
           `shouldRespondWith` ResponseMatcher {
             matchBody    = Just inserted
           , matchStatus  = 201
-          , matchHeaders = ["Location" <:> [str|/json?data=eq.[1,2,3]|]]
+          , matchHeaders = ["Location" <:> location]
+          }
+
+    context "empty object" $
+      it "successfully populates table with all-default columns" $
+        post "/items" "{}" `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just ""
+          , matchStatus  = 201
+          , matchHeaders = []
           }
 
   describe "CSV insert" $ do
@@ -259,7 +299,7 @@ spec = do
               length rows `shouldBe` 1
               let record = head rows
               compoundK1 record `shouldBe` 12
-              compoundK2 record `shouldBe` 42
+              compoundK2 record `shouldBe` "42"
               compoundExtra record `shouldBe` Just 3
 
           it "can update an existing record" $ do
@@ -312,13 +352,15 @@ spec = do
         g <- get "/items?id=eq.42"
         liftIO $ simpleHeaders g
           `shouldSatisfy` matchHeader "Content-Range" "\\*/0"
-        request methodPatch "/items?id=eq.2" []
+        p <- request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |]
-          [json| { "id":42 } |]
+        pure p `shouldRespondWith` ResponseMatcher {
-            `shouldRespondWith` ResponseMatcher {
+            matchBody    = Nothing,
-              matchBody    = Nothing,
+            matchStatus  = 204,
-              matchStatus  = 204,
+            matchHeaders = ["Content-Range" <:> "0-0/1"]
-              matchHeaders = ["Content-Range" <:> "0-0/1"]
+          }
-            }
+        liftIO $
+          lookup hContentType (simpleHeaders p) `shouldBe` Nothing
+
         g' <- get "/items?id=eq.42"
         liftIO $ simpleHeaders g'
           `shouldSatisfy` matchHeader "Content-Range" "0-0/1"

test/Feature/QueryLimitedSpec.hs

@@ -5,7 +5,7 @@ import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus))
-
+import Text.Heredoc
 import SpecHelper
 import Network.Wai (Application)
 
@@ -15,15 +15,23 @@ spec =
     it "restricts results" $
       get "/items"
         `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just [json| [{"id":1},{"id":2},{"id":3}] |]
+          matchBody    = Just [json| [{"id":1},{"id":2}] |]
         , matchStatus  = 206
-        , matchHeaders = ["Content-Range" <:> "0-2/15"]
+        , matchHeaders = ["Content-Range" <:> "0-1/15"]
         }
 
     it "respects additional client limiting" $ do
       r <- request methodGet  "/items"
-                   (rangeHdrs $ ByteRangeFromTo 0 1) ""
+                   (rangeHdrs $ ByteRangeFromTo 0 0) ""
       liftIO $ do
         simpleHeaders r `shouldSatisfy`
-          matchHeader "Content-Range" "0-1/15"
+          matchHeader "Content-Range" "0-0/15"
         simpleStatus r `shouldBe` partialContent206
+
+    it "limit works on all levels" $
+      get "/users?select=id,tasks{id}&order=id.asc&tasks.order=id.asc"
+        `shouldRespondWith` ResponseMatcher {
+          matchBody    = Just [str|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|]
+        , matchStatus  = 206
+        , matchHeaders = ["Content-Range" <:> "0-1/3"]
+        }

test/Feature/QuerySpec.hs

@@ -143,16 +143,29 @@ spec = 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]}]|]
+        [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|]
+
+    it "dash `-` in column names is accepted" $
+      get "/complex_items?id=eq.3&select=id,field-with_sep" `shouldRespondWith`
+        [str|[{"id":3,"field-with_sep":1}]|]
 
     it "one simple column" $
       get "/complex_items?select=id" `shouldRespondWith`
         [json| [{"id":1},{"id":2},{"id":3}] |]
 
+    it "rename simple column" $
+      get "/complex_items?id=eq.1&select=myId:id" `shouldRespondWith`
+        [json| [{"myId":1}] |]
+
+
     it "one simple column with casting (text)" $
       get "/complex_items?select=id::text" `shouldRespondWith`
         [json| [{"id":"1"},{"id":"2"},{"id":"3"}] |]
 
+    it "rename simple column with casting" $
+      get "/complex_items?id=eq.1&select=myId:id::text" `shouldRespondWith`
+        [json| [{"myId":"1"}] |]
+
     it "json column" $
       get "/complex_items?id=eq.1&select=settings" `shouldRespondWith`
         [json| [{"settings":{"foo":{"int":1,"bar":"baz"}}}] |]
@@ -161,6 +174,10 @@ spec = do
       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 "rename json subfield one level with casting (json)" $
+      get "/complex_items?id=eq.1&select=myFoo:settings->>foo::json" `shouldRespondWith`
+        [json| [{"myFoo":{"int":1,"bar":"baz"}}] |] -- the value of foo here is of type "text"
+
     it "fails on bad casting (data of the wrong format)" $
       get "/complex_items?select=settings->foo->>bar::integer"
         `shouldRespondWith` ResponseMatcher {
@@ -182,15 +199,33 @@ spec = do
       get "/complex_items?id=eq.1&select=settings->foo->>bar" `shouldRespondWith`
         [json| [{"bar":"baz"}] |]
 
+    it "rename json subfield two levels (string)" $
+      get "/complex_items?id=eq.1&select=myBar:settings->foo->>bar" `shouldRespondWith`
+        [json| [{"myBar":"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 "rename json subfield two levels with casting (int)" $
+      get "/complex_items?id=eq.1&select=myInt:settings->foo->>int::integer" `shouldRespondWith`
+        [json| [{"myInt":1}] |] -- the value in the db is an int, but here we expect a string for now
+
     it "requesting parents and children" $
       get "/projects?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`
         [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
 
+    it "embed data with two fk pointing to the same table" $
+      get "/orders?id=eq.1&select=id, name, billing_address_id{id}, shipping_address_id{id}" `shouldRespondWith`
+        [str|[{"id":1,"name":"order 1","billing_address_id":{"id":1},"shipping_address_id":{"id":2}}]|]
+
+
+    it "requesting parents and children while renaming them" $
+      get "/projects?id=eq.1&select=myId:id, name, project_client:client_id{*}, project_tasks:tasks{id, name}" `shouldRespondWith`
+        [str|[{"myId":1,"name":"Windows 7","project_client":{"id":1,"name":"Microsoft"},"project_tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]
+
+
     it "requesting parents and filtering parent columns" $
       get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith`
         [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|]
@@ -211,6 +246,10 @@ spec = do
       get "/tasks?select=id,users{id}" `shouldRespondWith`
         [str|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|]
 
+    it "requesting many<->many relation with rename" $
+      get "/tasks?id=eq.1&select=id,theUsers:users{id}" `shouldRespondWith`
+        [str|[{"id":1,"theUsers":[{"id":1},{"id":3}]}]|]
+
 
     it "requesting many<->many relation reverse" $
       get "/users?select=id,tasks{id}" `shouldRespondWith`
@@ -323,6 +362,28 @@ spec = do
     it "without other constraints" $
       get "/items?order=id.asc" `shouldRespondWith` 200
 
+    it "ordering embeded entities" $
+      get "/projects?id=eq.1&select=id, name, tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|]
+
+    it "ordering embeded entities with alias" $
+      get "/projects?id=eq.1&select=id, name, the_tasks:tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","the_tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|]
+
+    it "ordering embeded entities, two levels" $
+      get "/projects?id=eq.1&select=id, name, tasks{id, name, users{id, name}}&tasks.order=name.asc&tasks.users.order=name.desc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7","users":[{"id":1,"name":"Angela Martin"}]},{"id":1,"name":"Design w7","users":[{"id":3,"name":"Dwight Schrute"},{"id":1,"name":"Angela Martin"}]}]}]|]
+
+    it "ordering embeded parents does not break things" $
+      get "/projects?id=eq.1&select=id, name, clients{id, name}&clients.order=name.asc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"}}]|]
+
+    it "ordering embeded parents does not break things when using ducktape names" $
+      get "/projects?id=eq.1&select=id, name, client{id, name}&client.order=name.asc" `shouldRespondWith`
+        [str|[{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}]|]
+
+
+
   describe "Accept headers" $ do
     it "should respond an unknown accept type with 415" $
       request methodGet "/simple_pk"

test/Feature/RangeSpec.hs

@@ -9,6 +9,7 @@ import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus))
 import qualified Data.ByteString.Lazy         as BL
 
 import SpecHelper
+import Text.Heredoc
 import Network.Wai (Application)
 
 defaultRange :: BL.ByteString
@@ -142,6 +143,50 @@ spec = do
             , matchHeaders = ["Content-Range" <:> "0-0/*"]
             }
 
+    context "with limit/offset parameters" $ do
+      it "no parameters return everything" $
+        get "/items?select=id&order=id.asc"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]
+          , matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-14/15"]
+          }
+      it "top level limit with parameter" $
+        get "/items?select=id&order=id.asc&limit=3"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":1},{"id":2},{"id":3}]|]
+          , matchStatus  = 206
+          , matchHeaders = ["Content-Range" <:> "0-2/15"]
+          }
+      it "headers override get parameters" $
+        request methodGet  "/items?select=id&order=id.asc&limit=3"
+                     (rangeHdrs $ ByteRangeFromTo 0 1) ""
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":1},{"id":2}]|]
+          , matchStatus  = 206
+          , matchHeaders = ["Content-Range" <:> "0-1/15"]
+          }
+
+      it "limit works on all levels" $
+        get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=1&projects.tasks.order=id.asc&projects.tasks.limit=2"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]}]}]|]
+          , matchStatus  = 206
+          , matchHeaders = ["Content-Range" <:> "0-0/2"]
+          }
+
+      it "fails on offset specified below level 1" $
+        get "/clients?select=id,projects{id,tasks{id}}&projects.offset=2&projects.limit=1"
+          `shouldRespondWith` 400
+
+      it "limit and offset works on first level" $
+        get "/items?select=id&order=id.asc&limit=3&offset=2"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":3},{"id":4},{"id":5}]|]
+          , matchStatus  = 206
+          , matchHeaders = ["Content-Range" <:> "2-4/15"]
+          }
+
     context "with range headers" $ do
 
       context "of acceptable range" $ do

test/Feature/StructureSpec.hs

@@ -8,6 +8,7 @@ import SpecHelper
 
 import Network.HTTP.Types
 import Network.Wai (Application)
+import Network.Wai.Test (SResponse(simpleHeaders))
 
 spec :: SpecWith Application
 spec = do
@@ -17,6 +18,7 @@ spec = do
       request methodGet "/" [] ""
         `shouldRespondWith` [json| [
           {"schema":"test","name":"Escap3e;","insertable":true}
+        , {"schema":"test","name":"addresses","insertable":true}
         , {"schema":"test","name":"articleStars","insertable":true}
         , {"schema":"test","name":"articles","insertable":true}
         , {"schema":"test","name":"auto_incrementing_pk","insertable":true}
@@ -24,6 +26,7 @@ spec = do
         , {"schema":"test","name":"comments","insertable":true}
         , {"schema":"test","name":"complex_items","insertable":true}
         , {"schema":"test","name":"compound_pk","insertable":true}
+        , {"schema":"test","name":"empty_table","insertable":true}
         , {"schema":"test","name":"filtered_tasks","insertable":true}
         , {"schema":"test","name":"ghostBusters","insertable":true}
         , {"schema":"test","name":"has_count_column","insertable":false}
@@ -36,6 +39,7 @@ spec = do
         , {"schema":"test","name":"menagerie","insertable":true}
         , {"schema":"test","name":"no_pk","insertable":true}
         , {"schema":"test","name":"nullable_integer","insertable":true}
+        , {"schema":"test","name":"orders","insertable":true}
         , {"schema":"test","name":"projects","insertable":true}
         , {"schema":"test","name":"projects_view","insertable":true}
         , {"schema":"test","name":"simple_pk","insertable":true}
@@ -379,3 +383,17 @@ spec = do
 
     it "errors for non existant tables" $
       request methodOptions "/dne" [] "" `shouldRespondWith` 404
+
+  describe "Allow header" $ do
+
+    it "includes read/write verbs for writeable table" $ do
+      r <- request methodOptions "/items" [] ""
+      liftIO $
+        simpleHeaders r `shouldSatisfy`
+          matchHeader "Allow" "GET,POST,PATCH,DELETE"
+
+    it "includes read verbs for read-only table" $ do
+      r <- request methodOptions "/has_count_column" [] ""
+      liftIO $
+        simpleHeaders r `shouldSatisfy`
+          matchHeader "Allow" "GET"

test/Main.hs

@@ -7,6 +7,7 @@ import qualified Hasql.Pool as P
 
 import PostgREST.DbStructure (getDbStructure)
 import PostgREST.App (postgrest)
+import Data.IORef
 import Data.String.Conversions (cs)
 
 import qualified Feature.AuthSpec
@@ -27,10 +28,10 @@ main = do
   pool <- P.acquire (3, 10, cs testDbConn)
 
   result <- P.use pool $ getDbStructure "test"
-  let dbStructure = either (error.show) id result
+  refDbStructure <- newIORef $ either (error.show) id result
-      withApp = return $ postgrest testCfg dbStructure pool
+  let withApp = return $ postgrest testCfg refDbStructure pool
-      ltdApp  = return $ postgrest testLtdRowsCfg dbStructure pool
+      ltdApp  = return $ postgrest testLtdRowsCfg refDbStructure pool
-      unicodeApp = return $ postgrest testUnicodeCfg dbStructure pool
+      unicodeApp = return $ postgrest testUnicodeCfg refDbStructure pool
 
   hspec $ do
     mapM_ (beforeAll_ resetDb . before withApp) specs

test/SpecHelper.hs

@@ -27,7 +27,7 @@ testUnicodeCfg =
 
 testLtdRowsCfg :: AppConfig
 testLtdRowsCfg =
-  AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 3) True
+  AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 2) True
 
 setupDb :: IO ()
 setupDb = do

test/TestTypes.hs

@@ -37,9 +37,9 @@ instance JSON.FromJSON IncPK where
 
 data CompoundPK = CompoundPK {
   compoundK1 :: Int
-, compoundK2 :: Int
+, compoundK2 :: String
 , compoundExtra :: Maybe Int
-}
+} deriving (Eq, Show)
 
 instance JSON.FromJSON CompoundPK where
   parseJSON (JSON.Object r) = CompoundPK <$>

test/fixtures/data.sql

@@ -204,7 +204,7 @@ INSERT INTO items VALUES (15);
 -- Name: items_id_seq; Type: SEQUENCE SET; Schema: test; Owner: -
 --
 
-SELECT pg_catalog.setval('items_id_seq', 1, true);
+SELECT pg_catalog.setval('items_id_seq', 15, true);
 
 
 --
@@ -267,7 +267,20 @@ TRUNCATE TABLE "ghostBusters" CASCADE;
 INSERT INTO "ghostBusters" VALUES (1), (3), (5);
 
 TRUNCATE TABLE "withUnique" CASCADE;
-INSERT INTO "withUnique" VALUES ('nodup', 'blah')
+INSERT INTO "withUnique" VALUES ('nodup', 'blah');
+
+
+
+TRUNCATE TABLE addresses CASCADE;
+INSERT INTO addresses VALUES (1, 'address 1');
+INSERT INTO addresses VALUES (2, 'address 2');
+INSERT INTO addresses VALUES (3, 'address 3');
+INSERT INTO addresses VALUES (4, 'address 4');
+
+TRUNCATE TABLE orders CASCADE;
+INSERT INTO orders VALUES (1, 'order 1', 1, 2);
+INSERT INTO orders VALUES (2, 'order 2', 3, 4);
+
 --
 -- PostgreSQL database dump complete
 --

test/fixtures/privileges.sql

@@ -17,6 +17,7 @@ GRANT ALL ON TABLE
     , comments
     , complex_items
     , compound_pk
+    , empty_table
     , has_count_column
     , has_fk
     , insertable_view_with_join
@@ -38,6 +39,8 @@ GRANT ALL ON TABLE
     , "ghostBusters"
     , "withUnique"
     , "موارد"
+    , addresses
+    , orders
 TO postgrest_test_anonymous;
 
 GRANT INSERT ON TABLE insertonly TO postgrest_test_anonymous;

test/fixtures/schema.sql

@@ -432,7 +432,8 @@ CREATE TABLE complex_items (
     id bigint NOT NULL,
     name text,
     settings pg_catalog.json,
-    arr_data integer[]
+    arr_data integer[],
+		"field-with_sep" integer default 1 not null
 );
 
 
@@ -442,7 +443,7 @@ CREATE TABLE complex_items (
 
 CREATE TABLE compound_pk (
     k1 integer NOT NULL,
-    k2 integer NOT NULL,
+    k2 text NOT NULL,
     extra integer
 );
 
@@ -457,6 +458,13 @@ CREATE TABLE empty_table (
 );
 
 
+--
+-- Name: private_table; Type: TABLE; Schema: test; Owner: -
+--
+
+CREATE TABLE private_table ();
+
+
 --
 -- Name: has_count_column; Type: VIEW; Schema: test; Owner: -
 --
@@ -1000,6 +1008,19 @@ ALTER TABLE ONLY users_tasks
 ALTER TABLE ONLY users_tasks
     ADD CONSTRAINT users_tasks_user_id_fkey FOREIGN KEY (user_id) REFERENCES users(id);
 
+
+create table addresses (
+	id                   int not null unique,
+	address              text not null
+);
+
+create table orders (
+	id                   int not null unique,
+	name                 text not null,
+	billing_address_id   int references addresses(id),
+	shipping_address_id  int references addresses(id)
+);
+
 --
 -- PostgreSQL database dump complete
 --