Merge v3

CHANGELOG.md

@@ -3,6 +3,20 @@
 All notable changes to this project will be documented in this file.
 This project adheres to [Semantic Versioning](http://semver.org/).
 
+## Unreleased
+
+### Added
+- Ensure JWT expires - @calebmer
+- Postgres connection string argument - @calebmer
+- Encode JWT for procs that return type `jwt_claims` - @
+- Full text operators `@>`,`<@` - @ruslantalpa
+
+### Removed
+- API versioning feature - @calebmer
+- `--db-x` command line arguments - @calebmer
+- Secure flag - @calebmer
+- PUT request handling - @ruslantalpa
+
 ## [0.2.12.1] - 2015-11-12
 
 ### Fixed

README.md

@@ -24,13 +24,16 @@ your own projects.
 Download the binary ([latest release](https://github.com/begriffs/postgrest/releases/latest)) and invoke like so:
 
 ```bash
-postgrest  --db-host localhost  --db-port 5432     \
+postgrest postgres://postgres:foobar@localhost:5432/my_db \
-           --db-name my_db      --db-user postgres \
+          --port 3000 \
-           --db-pass foobar     --db-pool 200      \
+          --schema public \
-           --anonymous postgres --port 3000        \
+          --anonymous postgres \
-           --v1schema public
+          --pool 200
 ```
 
+For more information on valid connection strings see the
+[Postgres docs](http://www.postgresql.org/docs/9.4/static/libpq-connect.html#LIBPQ-CONNSTRING).
+
 In production include the `--secure` option which redirects all
 requests to HTTPS. Note that PostgREST does not handle the SSL
 internally and must be put behind another server that does (such
@@ -100,13 +103,14 @@ guide](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions).
 ### Versioning
 
 A robust long-lived API needs the freedom to exist in multiple
-versions. PostgREST supports versioning through HTTP content
+versions. Therefore it is a best practice that you version the database
-negotiation. Requests for a certain version translate into switching
+schema exposed to PostgREST (e.g. `public1` or `api2`). This way you
-which database schema to search for tables. PostgreSQL schema search
+future proof your API by allowing it to be backwards compatible when
-paths allow tables from earlier versions to be reused verbatim in
+you want to publish breaking API changes (e.g. a later version could
-later versions.
+be `public2` or `api3`).
 
-To learn more, see the [guide to versioning](https://github.com/begriffs/postgrest/wiki/API-Versioning).
+For routing to different versions of a PostgREST API use a request
+proxy (such as [nginx](http://nginx.org)).
 
 ### Self-documention
 
@@ -153,7 +157,6 @@ and the [guide to routing](https://github.com/begriffs/postgrest/wiki/Routing).
 ### Guides
 
 * [Routing](https://github.com/begriffs/postgrest/wiki/Routing)
-* [Versioning](https://github.com/begriffs/postgrest/wiki/API-Versioning)
 * [Performance](https://github.com/begriffs/postgrest/wiki/Performance-and-Scaling)
 * [Security](https://github.com/begriffs/postgrest/wiki/Security-and-Permissions)
 * [Tutorial](http://blog.jonharrington.org/postgrest-introduction/) (external)

circle.yml

@@ -3,7 +3,7 @@ machine:
     - createuser --superuser --no-password postgrest_test
     - createdb -O postgrest_test -U ubuntu postgrest_test
   ghc:
-    version: 7.8.3
+    version: 7.10.1
 dependencies:
   override:
     - cabal update

debian/postgrest.default

@@ -7,17 +7,23 @@
 # database host
 #POSTGREST_DBHOST=localhost
 
+# database host
+#POSTGREST_DBPORT=5432
+
 # database to use
-#POSTGREST_DBNAME=
+#POSTGREST_DBNAME=app
 
 # database user
-#POSTGREST_DBUSER=postgres
+#POSTGREST_DBUSER=authenticator
 
 # database password
 #POSTGREST_DBPASS=
 
 # database pool
-#POSTGREST_DBPOOL=10
+#POSTGREST_POOL=10
 
-# additional options
+# jwt secret
-#POSTGREST_OPTS=
+#POSTGREST_JWT_SECRET=secret
+
+# default schema
+#POSTGREST_SCHEMA=public

debian/postgrest.init.d

@@ -13,31 +13,52 @@ if test -f /etc/default/postgrest; then
     . /etc/default/postgrest
 fi
 POSTGREST=/usr/local/bin/postgrest
+CONNECTION_STRING="postgres://"
+POSTGREST_OPTS=""
 POSTGREST_USER=${POSTGREST_USER:-postgrest}
-POSTGREST_DBNAME=${POSTGREST_DBNAME:-postgres}
+POSTGREST_PORT=${POSTGREST_PORT:-3000}
-POSTGREST_DBUSER=${POSTGREST_DBUSER:-postgres}
+POSTGREST_DBUSER=${POSTGREST_DBUSER:-authenticator}
-if [ -n "$POSTGREST_DBHOST" ]; then
+#POSTGREST_DBPASS=${POSTGREST_DBPASS:-authenticator}
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-host $POSTGREST_DBHOST"
+POSTGREST_DBHOST=${POSTGREST_DBHOST:-localhost}
-fi
+POSTGREST_DBPORT=${POSTGREST_DBPORT:-5432}
-if [ -n "$POSTGREST_DBNAME" ]; then
+POSTGREST_DBNAME=${POSTGREST_DBNAME:-app}
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-name $POSTGREST_DBNAME"
+POSTGREST_DBPOOL=${POSTGREST_DBPOOL:-10}
-fi
+POSTGREST_ANON=${POSTGREST_ANON:-anonymous}
-if [ -n "$POSTGREST_DBUSER" ]; then
+POSTGREST_JWT_SECRET=${POSTGREST_JWT_SECRET:-secret}
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-user $POSTGREST_DBUSER"
+POSTGREST_SCHEMA=${POSTGREST_SCHEMA:-public}
-	POSTGREST_OPTS="$POSTGREST_OPTS --anonymous $POSTGREST_DBUSER"
+
-fi
+CONNECTION_STRING="$CONNECTION_STRING$POSTGREST_DBUSER"
 if [ -n "$POSTGREST_DBPASS" ]; then
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-pass $POSTGREST_DBPASS"
+	CONNECTION_STRING="$CONNECTION_STRING:$POSTGREST_DBPASS"
 fi
-if [ -n "$POSTGREST_DBPOOL" ]; then
+CONNECTION_STRING="$CONNECTION_STRING@$POSTGREST_DBHOST:$POSTGREST_DBPORT/$POSTGREST_DBNAME"
-	POSTGREST_OPTS="$POSTGREST_OPTS --db-pool $POSTGREST_DBPOOL"
+
+if [ -n "$POSTGREST_PORT" ]; then
+	POSTGREST_OPTS="$POSTGREST_OPTS --port $POSTGREST_PORT"
 fi
-POSTGREST_OPTS="$POSTGREST_OPTS --v1schema public"
+
+if [ -n "$POSTGREST_POOL" ]; then
+	POSTGREST_OPTS="$POSTGREST_OPTS --pool $POSTGREST_POOL"
+fi
+if [ -n "$POSTGREST_JWT_SECRET" ]; then
+	#export POSTGREST_JWT_SECRET="$POSTGREST_JWT_SECRET"
+	POSTGREST_OPTS="$POSTGREST_OPTS --jwt-secret $POSTGREST_JWT_SECRET"
+fi
+if [ -n "$POSTGREST_SCHEMA" ]; then
+	POSTGREST_OPTS="$POSTGREST_OPTS --schema $POSTGREST_SCHEMA"
+fi
+if [ -n "$POSTGREST_ANON" ]; then
+	POSTGREST_OPTS="$POSTGREST_OPTS --anonymous $POSTGREST_ANON"
+fi
+
+#export CONNECTION_STRING="$CONNECTION_STRING"
+
+START_PARAMS="$CONNECTION_STRING $POSTGREST_OPTS"
 
 start()
 {
 	log_daemon_msg "Starting PostgreSQL REST API daemon" "postgrest" || true
-	if start-stop-daemon --start --quiet --oknodo --chuid ${POSTGREST_USER} --startas /usr/local/bin/postgrest-wrapper --exec $POSTGREST -- $POSTGREST_OPTS; then
+	if start-stop-daemon --start --quiet --oknodo --chuid ${POSTGREST_USER} --startas /usr/local/bin/postgrest-wrapper --exec $POSTGREST -- $START_PARAMS; then
 		log_end_msg 0 || true
 	else
 		log_end_msg 1 || true

postgrest.cabal

@@ -2,7 +2,7 @@ name:                  postgrest
 description:           Reads the schema of a PostgreSQL database and creates RESTful routes
                        for the tables and views, supporting all HTTP verbs that security
                        permits.
-version:               0.2.12.1
+version:               0.3.0.0
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
@@ -22,10 +22,15 @@ Flag CI
   Default:     False
 
 executable postgrest
+  if flag(ci)
+    ghc-options:       -Wall -W -Werror
+  else
+    ghc-options:       -Wall -W -O2
+
   main-is:             PostgREST/Main.hs
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
   default-language:    Haskell2010
-  build-depends:       base >=4.6 && <5
+  build-depends:       base >= 4.8 && < 5
                      , postgrest
                      , hasql >= 0.7.3 && < 0.8
                      , hasql-backend >= 0.4.1 && < 0.5
@@ -37,6 +42,7 @@ executable postgrest
                      , case-insensitive
                      , scientific, time
                      , aeson >= 0.8, network >= 2.6
+                     , aeson-pretty >= 0.7 && < 0.8
                      , bytestring, text, split, string-conversions
                      , stringsearch
                      , containers, unordered-containers
@@ -56,6 +62,18 @@ executable postgrest
                      , errors
                      , bifunctors
   hs-source-dirs:      src
+  other-modules:       Paths_postgrest
+                     , PostgREST.App
+                     , PostgREST.Auth
+                     , PostgREST.Config
+                     , PostgREST.Error
+                     , PostgREST.Middleware
+                     , PostgREST.Parsers
+                     , PostgREST.PgQuery
+                     , PostgREST.DbStructure
+                     , PostgREST.QueryBuilder
+                     , PostgREST.RangeQuery
+                     , PostgREST.Types
 
 library
   if flag(ci)
@@ -65,47 +83,61 @@ library
 
   default-language:    Haskell2010
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
-  build-depends:       base >=4.6 && <5
+  build-depends:       HTTP
-                     , hasql, hasql-backend
+                     , MissingH
-                     , hasql-postgres
-                     , warp, wai
-                     , wai-extra, wai-cors
-                     , wai-middleware-static
-                     , HTTP, convertible, http-types
-                     , case-insensitive
-                     , scientific, time
-                     , aeson, network
-                     , bytestring, text, split, string-conversions
-                     , stringsearch
-                     , containers, unordered-containers
-                     , optparse-applicative
-                     , regex-base, regex-tdfa
                      , Ranged-sets
-                     , transformers, MissingH
+                     , aeson
-                     , bcrypt, base64-string
+                     , base >=4.6 && <5
-                     , network-uri
+                     , base64-string
-                     , resource-pool
+                     , bcrypt
-                     , blaze-builder
-                     , vector
-                     , mtl
-                     , cassava
-                     , jwt
-                     , parsec
-                     , errors
                      , bifunctors
+                     , blaze-builder
+                     , bytestring
+                     , case-insensitive
+                     , cassava
+                     , containers
+                     , convertible
+                     , errors
+                     , hasql
+                     , hasql-backend
+                     , hasql-postgres
+                     , http-types
+                     , jwt
+                     , mtl
+                     , network
+                     , network-uri
+                     , optparse-applicative
+                     , parsec
+                     , regex-base
+                     , regex-tdfa
+                     , resource-pool
+                     , scientific
+                     , split
+                     , string-conversions
+                     , stringsearch
+                     , text
+                     , time
+                     , transformers
+                     , unordered-containers
+                     , vector
+                     , wai
+                     , wai-cors
+                     , wai-extra
+                     , wai-middleware-static
+                     , warp
 
   Other-Modules:       Paths_postgrest
   Exposed-Modules:     PostgREST.App
-                     , PostgREST.Types
-                     , PostgREST.Parsers
-                     , PostgREST.QueryBuilder
                      , PostgREST.Auth
                      , PostgREST.Config
                      , PostgREST.Error
                      , PostgREST.Middleware
+                     , PostgREST.Parsers
                      , PostgREST.PgQuery
-                     , PostgREST.PgStructure
+                     , PostgREST.DbStructure
+                     , PostgREST.QueryBuilder
                      , PostgREST.RangeQuery
+                     , PostgREST.Types
   hs-source-dirs:      src
 
 Test-Suite spec
@@ -118,21 +150,29 @@ Test-Suite spec
   else
     ghc-options:       -Wall -W -O2
   Main-Is:             Main.hs
-  Other-Modules:       PostgREST.App
+  Other-Modules:       Feature.AuthSpec
-                     , PostgREST.Types
+                     , Feature.CorsSpec
-                     , PostgREST.Parsers
+                     , Feature.DeleteSpec
-                     , PostgREST.QueryBuilder
+                     , Feature.InsertSpec
+                     , Feature.QuerySpec
+                     , Feature.RangeSpec
+                     , Feature.StructureSpec
+                     , Paths_postgrest
+                     , PostgREST.App
                      , PostgREST.Auth
                      , PostgREST.Config
                      , PostgREST.Error
                      , PostgREST.Middleware
+                     , PostgREST.Parsers
                      , PostgREST.PgQuery
-                     , PostgREST.PgStructure
+                     , PostgREST.DbStructure
+                     , PostgREST.QueryBuilder
                      , PostgREST.RangeQuery
+                     , PostgREST.Types
                      , Spec
                      , SpecHelper
-                     , Paths_postgrest
+                     , TestTypes
-  Build-Depends:       base, hspec == 2.1.*, QuickCheck
+  Build-Depends:       base, hspec == 2.2.*, QuickCheck
                      , hspec-wai, hspec-wai-json
                      , hasql, hasql-backend
                      , hasql-postgres

src/PostgREST/App.hs

@@ -1,102 +1,77 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+--module PostgREST.App where
 module PostgREST.App (
   app
-, sqlError
-, isSqlError
 , contentTypeForAccept
-, jsonH
-, requestedSchema
-, TableOptions(..)
 ) where
 
-import qualified Blaze.ByteString.Builder  as BB
 import           Control.Applicative
-import           Control.Arrow             (second, (***))
+import           Control.Arrow             ((***))
 import           Control.Monad             (join)
 import           Data.Bifunctor            (first)
 import qualified Data.ByteString.Char8     as BS
 import qualified Data.ByteString.Lazy      as BL
-import           Data.CaseInsensitive      (original)
 import qualified Data.Csv                  as CSV
 import           Data.Functor.Identity
-import qualified Data.HashMap.Strict       as M
+import qualified Data.HashMap.Strict       as HM
-import           Data.List                 (find, sortBy)
+import           Data.List                 (find, sortBy, delete, transpose)
-import           Data.Maybe                (fromMaybe, isJust, isNothing,
+import           Data.Maybe                (fromMaybe, fromJust, isJust, isNothing, mapMaybe)
-                                            mapMaybe)
 import           Data.Ord                  (comparing)
 import           Data.Ranged.Ranges        (emptyRange)
-import qualified Data.Set                  as S
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
-import           Text.Regex.TDFA           ((=~))
+import           Data.Tree
+import qualified Data.Map as M
 
 import           Text.Parsec.Error
+import           Text.ParserCombinators.Parsec (parse)
 
 import           Network.HTTP.Base         (urlEncodeVars)
 import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
 import           Network.HTTP.Types.URI    (parseSimpleQuery)
 import           Network.Wai
-import           Network.Wai.Internal      (Response (..))
 import           Network.Wai.Parse         (parseHttpAccept)
 
 import           Data.Aeson
+import           Data.Aeson.Types (emptyArray)
 import           Data.Monoid
 import qualified Data.Vector               as V
 import qualified Hasql                     as H
 import qualified Hasql.Backend             as B
 import qualified Hasql.Postgres            as P
 
-import           PostgREST.Auth
 import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.Parsers
 import           PostgREST.PgQuery
-import           PostgREST.PgStructure
+import           PostgREST.DbStructure
 import           PostgREST.QueryBuilder
 import           PostgREST.RangeQuery
 import           PostgREST.Types
+import           PostgREST.Auth (tokenJWT)
 
 import           Prelude
 
-app :: DbStructure -> AppConfig -> BL.ByteString -> DbRole -> Request -> H.Tx P.Postgres s Response
+app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
-app dbstructure conf reqBody dbrole req =
+app dbStructure conf reqBody req =
   case (path, verb) of
 
-    ([], _) -> do
-      let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs
-      return $ responseLBS status200 [jsonH] $ cs body
-
-    ([table], "OPTIONS") -> do
-      let cols = filter (filterCol schema table) allCols
-          pkeys = map pkName $ filter (filterPk schema table) allPrKeys
-          body = encode (TableOptions cols pkeys)
-      return $ responseLBS status200 [jsonH, allOrigins] $ cs body
-
     ([table], "GET") ->
       if range == Just emptyRange
       then return $ responseLBS status416 [] "HTTP Range error"
       else
-        case queries of
+        case request of
-          Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
+          Left e -> return $ responseLBS status400 [jsonH] $ cs e
-          Right (qs, cqs) -> do
+          Right (selectQuery, _, _) -> do
-            let qt = qualify table
+            let q = B.Stmt (createStatement selectQuery Nothing True range [] (not $ hasPrefer "count=none") isCsv) V.empty True
-                count = if hasPrefer "count=none"
-                      then countNone
-                      else cqs
-                q = B.Stmt "select " V.empty True <>
-                    parentheticT count
-                    <> commaq <> (
-                    bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
-                    . limitT range
-                    $ qs
-                  )
             row <- H.maybeEx q
-            let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
+            let (tableTotal, queryTotal, _ , body) = extractQueryResult row
-                to = from+queryTotal-1
+                to = frm+queryTotal-1
-                contentRange = contentRangeH from to tableTotal
+                contentRange = contentRangeH frm to tableTotal
-                status = rangeStatus from to tableTotal
+                status = rangeStatus frm to tableTotal
-                canonical = urlEncodeVars
+                canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
                   . sortBy (comparing fst)
                   . map (join (***) cs)
                   . parseSimpleQuery
@@ -108,99 +83,48 @@ app dbstructure conf reqBody dbrole req =
                     if Prelude.null canonical then "" else "?" <> cs canonical
                 )
               ] (fromMaybe "[]" body)
-
         where
-            from = fromMaybe 0 $ rangeOffset <$> range
+            frm = fromMaybe 0 $ rangeOffset <$> range
-            apiRequest = first formatParserError (parseGetRequest req)
-                     >>= first formatRelationError . addRelations schema allRels Nothing
-                     >>= addJoinConditions schema allCols
-                     where
-                       formatRelationError :: Text -> Text
-                       formatRelationError e = cs $ encode $ object [
-                         "mesage" .= ("could not find foreign keys between these entities"::String),
-                         "details" .= e]
-                       formatParserError :: ParseError -> Text
-                       formatParserError e = cs $ encode $ object [
-                         "message" .= message,
-                         "details" .= details]
-                         where
-                           message = show (errorPos e)
-                           details = strip $ replace "\n" " " $ cs
-                             $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
 
-            query = requestToQuery schema <$> apiRequest
+    ([table], "POST") ->
-            countQuery = requestToCountQuery schema <$> apiRequest
+      case request of
-            queries = (,) <$> query <*> countQuery
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
-
+        Right (selectQuery, mutateQuery, isSingle) -> do
-
+          let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-    (["postgrest", "users"], "POST") -> do
+              q = B.Stmt (createStatement selectQuery (Just (mutateQuery, isSingle)) echoRequested Nothing pKeys False isCsv) V.empty True
-      let user = decode reqBody :: Maybe AuthUser
+          row <- H.maybeEx q
-
+          let (_, _, location, body) = extractQueryResult row
-      case user of
-        Nothing -> return $ responseLBS status400 [jsonH] $
-          encode . object $ [("message", String "Failed to parse user.")]
-        Just u -> do
-          _ <- addUser (cs $ userId u)
-            (cs $ userPass u) (cs <$> userRole u)
           return $ responseLBS status201
-            [ jsonH
+            [
-            , (hLocation, "/postgrest/users?id=eq." <> cs (userId u))
+              contentTypeH,
-            ] ""
+              (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
+            ]
+            $ if echoRequested then fromMaybe "[]" body else ""
 
-    (["postgrest", "tokens"], "POST") ->
+    ([_], "PATCH") ->
-      case jwtSecret of
+      case request of
-        "secret" -> return $ responseLBS status500 [jsonH] $
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
-          encode . object $ [("message", String "JWT Secret is set as \"secret\" which is an unsafe default.")]
+        Right (selectQuery, mutateQuery, _) -> do
-        _ -> do
+          let q = B.Stmt (createStatement selectQuery (Just (mutateQuery, False)) echoRequested Nothing [] False isCsv) V.empty True
-          let user = decode reqBody :: Maybe AuthUser
+          row <- H.maybeEx q
+          let (_, queryTotal, _, body) = extractQueryResult row
+              r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
+              s = case () of _ | queryTotal == 0 -> status404
+                               | echoRequested -> status200
+                               | otherwise -> status204
+          return $ responseLBS s [contentTypeH, r]
+            $ if echoRequested then fromMaybe "[]" body else ""
 
-          case user of
+    ([_], "DELETE") ->
-            Nothing -> return $ responseLBS status400 [jsonH] $
+      case request of
-              encode . object $ [("message", String "Failed to parse user.")]
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
-            Just u -> do
+        Right (selectQuery, mutateQuery, _) -> do
-              setRole authenticator
+          let q = B.Stmt (createStatement selectQuery (Just (mutateQuery, False)) False Nothing [] True isCsv) V.empty True
-              login <- signInRole (cs $ userId u) (cs $ userPass u)
+          row <- H.maybeEx q
-              case login of
+          let (_, queryTotal, _, _) = extractQueryResult row
-                LoginSuccess role uid ->
+          return $ if queryTotal == 0
-                  return $ responseLBS status201 [ jsonH ] $
+            then responseLBS status404 [] ""
-                    encode . object $ [("token", String $ tokenJWT jwtSecret uid role)]
+            else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
-                _  -> return $ responseLBS status401 [jsonH] $
-                  encode . object $ [("message", String "Failed authentication.")]
-
-    ([table], "POST") -> do
-      let qt = qualify table
-          echoRequested = hasPrefer "return=representation"
-          parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
-          parsed = if lookupHeader "Content-Type" == Just csvMT
-            then do
-              rows <- CSV.decode CSV.NoHeader reqBody
-              if V.null rows then Left "CSV requires header"
-                else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))
-            else eitherDecode reqBody >>= \val ->
-              case val of
-                Object obj -> Right .  second V.singleton .  V.unzip .  V.fromList $
-                  M.toList obj
-                _ -> Left "Expecting single JSON object or CSV rows"
-      case parsed of
-        Left err -> return $ responseLBS status400 [] $
-          encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]
-        Right toBeInserted -> do
-          rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
-          let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
-              pKeys = map pkName $ filter (filterPk schema table) allPrKeys
-              responses = flip map inserted $ \obj -> do
-                let primaries =
-                      if Prelude.null pKeys
-                        then obj
-                        else M.filterWithKey (const . (`elem` pKeys)) obj
-                let params = urlEncodeVars
-                      $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
-                      $ sortBy (comparing fst) $ M.toList primaries
-                responseLBS status201
-                  [ jsonH
-                  , (hLocation, "/" <> cs table <> "?" <> cs params)
-                  ] $ if echoRequested then encode obj else ""
-          return $ multipart status201 responses
 
     (["rpc", proc], "POST") -> do
       let qi = QualifiedIdentifier schema (cs proc)
@@ -208,137 +132,75 @@ app dbstructure conf reqBody dbrole req =
       if exists
         then do
           let call = B.Stmt "select " V.empty True <>
-                asJson (callProc qi $ fromMaybe M.empty (decode reqBody))
+                asJson (callProc qi $ fromMaybe HM.empty (decode reqBody))
-          body :: Maybe (Identity Text) <- H.maybeEx call
+          bodyJson :: Maybe (Identity Value) <- H.maybeEx call
+          returnJWT <- doesProcReturnJWT schema proc
           return $ responseLBS status200 [jsonH]
-            (cs $ fromMaybe "[]" $ runIdentity <$> body)
+                 (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in
+                    if returnJWT
+                    then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"
+                    else cs $ encode body)
         else return $ responseLBS status404 [] ""
 
       -- check that proc exists
       -- check that arg names are all specified
-      -- select * from "1".proc(a := "foo"::undefined) where whereT limit limitT
+      -- select * from public.proc(a := "foo"::undefined) where whereT limit limitT
 
-    ([table], "PUT") ->
+    ([], _) -> do
-      handleJsonObj reqBody $ \obj -> do
+      body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) allTabs)
-        let qt = qualify table
+      return $ responseLBS status200 [jsonH] $ cs body
-            pKeys = map pkName $ filter (filterPk schema table) allPrKeys
-            specifiedKeys = map (cs . fst) qq
-        if S.fromList pKeys /= S.fromList specifiedKeys
-          then return $ responseLBS status405 []
-            "You must speficy all and only primary keys as params"
-          else do
-            let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols
-                cols = map cs $ M.keys obj
-            if S.fromList tableCols == S.fromList cols
-              then do
-                let vals = M.elems obj
-                H.unitEx $ iffNotT
-                  (whereT qt qq $ update qt cols vals)
-                  (insertSelect qt cols vals)
-                return $ responseLBS status204 [ jsonH ] ""
 
-              else return $ if Prelude.null tableCols
+    ([table], "OPTIONS") -> do
-                then responseLBS status404 [] ""
+      let cols = filter (filterCol schema table) allCols
-                else responseLBS status400 []
+          pkeys = map pkName $ filter (filterPk schema table) allPrKeys
-                  "You must specify all columns in PUT request"
+          body = encode (TableOptions cols pkeys)
-
+      return $ responseLBS status200 [jsonH, allOrigins] $ cs body
-    ([table], "PATCH") ->
-      handleJsonObj reqBody $ \obj -> do
-        let qt = qualify table
-            up = returningStarT
-              . whereT qt qq
-              $ update qt (map cs $ M.keys obj) (M.elems obj)
-            patch = withT up "t" $ B.Stmt
-              "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying"
-              V.empty True
-
-        row <- H.maybeEx patch
-        let (queryTotal, body) =
-              fromMaybe (0 :: Int, Just "" :: Maybe Text) row
-            r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
-            echoRequested = hasPrefer "return=representation"
-            s = case () of _ | queryTotal == 0 -> status404
-                             | echoRequested -> status200
-                             | otherwise -> status204
-        return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
-
-    ([table], "DELETE") -> do
-      let qt = qualify table
-          del = countT
-            . returningStarT
-            . whereT qt qq
-            $ deleteFrom qt
-      row <- H.maybeEx del
-      let (Identity deletedCount) = fromMaybe (Identity 0 :: Identity Int) row
-      return $ if deletedCount == 0
-        then responseLBS status404 [] ""
-        else responseLBS status204 [("Content-Range", "*/"<> cs (show deletedCount))] ""
 
     (_, _) ->
       return $ responseLBS status404 [] ""
 
   where
-    allTabs = tables dbstructure
+    allTabs = dbTables dbStructure
-    allRels = relations dbstructure
+    allRels = dbRelations dbStructure
-    allCols = columns dbstructure
+    allCols = dbColumns dbStructure
-    allPrKeys = primaryKeys dbstructure
+    allPrKeys = dbPrimaryKeys dbStructure
-    filterCol sc table (Column{colSchema=s, colTable=t}) =  s==sc && table==t
+    filterCol sc table (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && table==t
     filterCol _ _ _ =  False
-    filterPk sc table pk = sc == pkSchema pk && table == pkTable pk
+    filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
-
-    filterTableAcl :: Text -> Table -> Bool
-    filterTableAcl r (Table{tableAcl=a}) = r `elem` a
     path          = pathInfo req
     verb          = requestMethod req
-    qq            = queryString req
-    qualify       = QualifiedIdentifier schema
     hdrs          = requestHeaders req
     lookupHeader  = flip lookup hdrs
     hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs
     accept        = lookupHeader hAccept
-    schema        = requestedSchema (cs $ configV1Schema conf) accept
+    schema        = cs $ configSchema conf
-    authenticator = cs $ configDbUser conf
+    jwtSecret     = (cs $ configJwtSecret conf) :: Text
-    jwtSecret     = cs $ configJwtSecret conf
     range         = rangeRequested hdrs
     allOrigins    = ("Access-Control-Allow-Origin", "*") :: Header
     contentType   = fromMaybe "application/json" $ contentTypeForAccept accept
+    isCsv         = contentType == csvMT
     contentTypeH  = (hContentType, contentType)
-
+    echoRequested = hasPrefer "return=representation"
-sqlError :: t
+    request = parseRequest schema allRels (head path) req reqBody --TODO! is head safe?
-sqlError = undefined
-
-isSqlError :: t
-isSqlError = undefined
 
 rangeStatus :: Int -> Int -> Maybe Int -> Status
 rangeStatus _ _ Nothing = status200
-rangeStatus from to (Just total)
+rangeStatus frm to (Just total)
-  | from > total            = status416
+  | frm > total            = status416
-  | (1 + to - from) < total = status206
+  | (1 + to - frm) < total = status206
   | otherwise               = status200
 
 contentRangeH :: Int -> Int -> Maybe Int -> Header
-contentRangeH from to total =
+contentRangeH frm to total =
     ("Content-Range", cs headerValue)
     where
       headerValue   = rangeString <> "/" <> totalString
       rangeString
-        | totalNotZero && fromInRange = show from <> "-" <> cs (show to)
+        | totalNotZero && fromInRange = show frm <> "-" <> cs (show to)
         | otherwise = "*"
       totalString   = fromMaybe "*" (show <$> total)
       totalNotZero  = fromMaybe True ((/=) 0 <$> total)
-      fromInRange   = from <= to
+      fromInRange   = frm <= to
-
-requestedSchema :: Text -> Maybe BS.ByteString -> Text
-requestedSchema v1schema accept =
-  case verStr of
-    Just [[_, ver]] -> if ver == "1" then v1schema else cs ver
-    _ -> v1schema
-
-  where
-    verRegex = "version[ ]*=[ ]*([0-9]+)" :: BS.ByteString
-    verStr = (=~ verRegex) <$> accept :: Maybe [[BS.ByteString]]
-
 
 jsonMT :: BS.ByteString
 jsonMT = "application/json"
@@ -362,48 +224,120 @@ contentTypeForAccept accept
     findInAccept = flip find $ parseHttpAccept acceptH
     has          = isJust . findInAccept . BS.isPrefixOf
 
-bodyForAccept :: BS.ByteString -> QualifiedIdentifier  -> StatementT
-bodyForAccept contentType table
-  | contentType == csvMT = asCsvWithCount table
-  | otherwise = asJsonWithCount -- defaults to JSON
-
-handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
-              -> H.Tx P.Postgres s Response
-handleJsonObj reqBody handler = do
-  let p = eitherDecode reqBody
-  case p of
-    Left err ->
-      return $ responseLBS status400 [jsonH] jErr
-      where
-        jErr = encode . object $
-          [("message", String $ "Failed to parse JSON payload. " <> cs err)]
-    Right (Object o) -> handler o
-    Right _ ->
-      return $ responseLBS status400 [jsonH] jErr
-      where
-        jErr = encode . object $
-          [("message", String "Expecting a JSON object")]
-
 parseCsvCell :: BL.ByteString -> Value
 parseCsvCell s = if s == "NULL" then Null else String $ cs s
 
-multipart :: Status -> [Response] -> Response
+formatRelationError :: Text -> Text
-multipart _ [] = responseLBS status204 [] ""
+formatRelationError e = cs $ encode $ object [
-multipart _ [r] = r
+  "mesage" .= ("could not find foreign keys between these entities"::String),
-multipart s rs =
+  "details" .= e]
-  responseLBS s [(hContentType, "multipart/mixed; boundary=\"postgrest_boundary\"")] $
-    BL.intercalate "\n--postgrest_boundary\n" (map renderResponseBody rs)
 
+formatParserError :: ParseError -> Text
+formatParserError e = cs $ encode $ object [
+  "message" .= message,
+  "details" .= details]
   where
-    renderHeader :: Header -> BL.ByteString
+     message = show (errorPos e)
-    renderHeader (k, v) = cs (original k) <> ": " <> cs v
+     details = strip $ replace "\n" " " $ cs
+       $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
 
-    renderResponseBody :: Response -> BL.ByteString
+parseRequestBody :: Bool -> BL.ByteString -> Either Text ([Text],[[Value]])
-    renderResponseBody (ResponseBuilder _ headers b) =
+parseRequestBody isCsv reqBody = first cs $
-      BL.intercalate "\n" (map renderHeader headers)
+  checkStructure =<<
-        <> "\n\n" <> BB.toLazyByteString b
+  if isCsv
-    renderResponseBody _ = error
+  then do
-      "Unable to create multipart response from non-ResponseBuilder"
+    rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody
+    if null rows then Left "CSV requires header" -- TODO! should check if length rows > 1 (header and 1 row)
+      else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows))
+  else eitherDecode reqBody >>= convertJson
+  where
+    checkStructure :: ([Text], [[Value]]) -> Either String ([Text], [[Value]])
+    checkStructure v
+      | headerMatchesContent v = Right v
+      | isCsv = Left "CSV header does not match rows length"
+      | otherwise = Left "The number of keys in objects do not match"
+
+    headerMatchesContent :: ([Text], [[Value]]) -> Bool
+    headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals
+      where headerLength = length header
+
+convertJson :: Value -> Either String ([Text],[[Value]])
+convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
+  where
+    invalidMsg = "Expecting single JSON object or JSON array of objects"
+    normalized :: Either String [(Text, [Value])]
+    normalized = groupByKey =<< normalizeValue v
+
+    vals :: [(Text, [Value])] -> [[Value]]
+    vals = transpose . map snd
+
+    header :: [(Text, [Value])] -> [Text]
+    header = map fst
+
+    groupByKey :: Value -> Either String [(Text,[Value])]
+    groupByKey (Array a) = HM.toList . foldr (HM.unionWith (++)) (HM.fromList []) <$> maps
+      where
+        maps :: Either String [HM.HashMap Text [Value]]
+        maps = mapM getElems $ V.toList a
+        getElems (Object o) = Right $ HM.map (:[]) o
+        getElems _ = Left invalidMsg
+    groupByKey _ = Left invalidMsg
+
+    normalizeValue :: Value -> Either String Value
+    normalizeValue val =
+      case val of
+        Object obj  -> Right $ Array (V.fromList[Object obj])
+        a@(Array _) -> Right a
+        _ -> Left invalidMsg
+
+augumentRequestWithJoin :: Schema ->  [Relation] ->  ApiRequest -> Either Text ApiRequest
+augumentRequestWithJoin schema allRels request =
+  (first formatRelationError . addRelations schema allRels Nothing) request
+  >>= addJoinConditions schema
+
+-- we use strings here because most of this data will be sent to parsers (which need strings for now)
+queryParams :: Request -> [(String, Maybe String)]
+queryParams httpRequest = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
+
+selectStr :: [(String, Maybe String)] -> String
+selectStr qParams = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
+
+whereFilters :: [(String, Maybe String)] -> [(String, String)]
+whereFilters qParams = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]
+
+orderStr :: [(String, Maybe String)] -> Maybe String
+orderStr qParams = join $ lookup "order" qParams
+
+buildSelectApiRequest :: Text -> String -> [(String, String)] -> Maybe String -> Either Text ApiRequest
+buildSelectApiRequest rootTableName sel wher orderS =
+  first formatParserError $ foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
+  where
+    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++sel++">>") sel
+    addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
+    flts = mapM pRequestFilter wher
+    ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
+
+addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
+addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest
+addFilter (path, flt) (Node rn forest) =
+  case targetNode of
+    Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
+    Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
+  where
+    targetNodeName:remainingPath = path
+    (targetNode,restForest) = splitForest targetNodeName forest
+    splitForest name forst =
+      case maybeNode of
+        Nothing -> (Nothing,forest)
+        Just node -> (Just node, delete node forest)
+      where maybeNode = find ((name==).fst.snd.rootLabel) forst
+
+toSourceRelation :: Text -> Relation -> Maybe Relation
+toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
+  | mt == tableName t = Just $ r {relTable=t {tableName=sourceSubqueryName}}
+  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceSubqueryName}}
+  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceSubqueryName}) <$> rt}
+  | otherwise = Nothing
 
 data TableOptions = TableOptions {
   tblOptcolumns :: [Column]
@@ -414,3 +348,75 @@ instance ToJSON TableOptions where
   toJSON t = object [
       "columns" .= tblOptcolumns t
     , "pkey"   .= tblOptpkey t ]
+
+parseRequest :: Schema -> [Relation] -> NodeName -> Request -> BL.ByteString -> Either Text (Text, Text, Bool)
+parseRequest schema allRels rootTableName httpRequest reqBody =
+  (,,) <$> selectQuery
+       <*> (if method == "GET" then pure "" else mutateQuery)
+       <*> (if method == "GET" then pure False else pure isSingleRecord)
+  where
+    hdrs = requestHeaders httpRequest
+    lookupHeader = flip lookup hdrs
+    isCsv = lookupHeader "Content-Type" == Just csvMT
+    method = requestMethod httpRequest
+    qParams = queryParams httpRequest
+    parsedBody = parseRequestBody isCsv reqBody
+    isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody
+    parseField f = parse pField ("failed to parse field <<"++f++">>") f
+    flds =  join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody)
+    vals = snd <$> parsedBody
+    setWith = if isSingleRecord
+          then M.fromList <$> (zip <$> flds <*> (head <$> vals))
+          else Left "Expecting a sigle CSV line with header or a JSON object"
+    allFilters = whereFilters qParams
+    mutateFilters = filter (not . ( '.' `elem` ) . fst) allFilters -- update/delete filters can be only on the root table
+    cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
+    fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels
+    rels = case method of
+      "POST"  -> fakeSourceRelations ++ allRels
+      "PATCH" -> fakeSourceRelations ++ allRels
+      _       -> allRels
+    selectApiRequest = augumentRequestWithJoin schema rels
+      =<< buildSelectApiRequest rootName sel filters (orderStr qParams)
+      where
+        sel = if method == "DELETE"
+          then "*" -- we are not returning the records so no need to consider nested items
+          else selectStr qParams
+        rootName = if method == "GET"
+          then rootTableName
+          else sourceSubqueryName
+        filters = if method == "GET"
+          then allFilters
+          else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update
+    selectQuery = requestToQuery schema <$> selectApiRequest
+    mutateQuery = requestToQuery schema <$> case method of
+      "POST"   -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals)    <*> pure (rootTableName, Nothing)) <*> pure []
+      "PATCH"  -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
+      "DELETE" -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure []
+      _        -> undefined
+
+createStatement :: Text -> Maybe (Text, Bool) -> Bool -> Maybe NonnegRange -> [Text] -> Bool -> Bool -> Text
+createStatement selectQuery Nothing _ range _ countTable asCsv =
+  wrapQuery selectQuery [
+    if countTable then countAllF else countNoneF,
+    countF,
+    "null", -- location header can not be calucalted
+    if asCsv then asCsvF else asJsonF
+  ] selectStarF range
+createStatement selectQuery (Just (changeQuery, isSingle)) echoRequested _ pKeys _ asCsv =
+  wrapQuery changeQuery [
+    countNoneF, -- when updateing it does not make sense
+    countF,
+    if isSingle then locationF pKeys else "null",
+    if echoRequested
+    then
+      if asCsv
+      then asCsvF
+      else if isSingle then asJsonSingleF else asJsonF
+    else "null"
+
+  ] selectQuery Nothing
+
+extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
+                         -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
+extractQueryResult = fromMaybe (Just 0, 0, Just "", Just "")

src/PostgREST/Auth.hs

@@ -1,104 +1,84 @@
-module PostgREST.Auth where
+{-# LANGUAGE FlexibleContexts #-}
+{-|
+Module      : PostgREST.Auth
+Description : PostgREST authorization functions.
 
-import           Control.Applicative
+This module provides functions to deal with the JWT authorization (http://jwt.io).
-import           Control.Monad           (mzero)
+It also can be used to define other authorization functions,
-import           Crypto.BCrypt
+in the future Oauth, LDAP and similar integrations can be coded here.
-import           Data.Aeson
+
-import           Data.Map
+Authentication should always be implemented in an external service.
-import           Data.Monoid
+In the test suite there is an example of simple login function that can be used for a
+very simple authentication system inside the PostgreSQL database.
+-}
+module PostgREST.Auth (
+    setRole
+  , claimsToSQL
+  , jwtClaims
+  , tokenJWT
+  ) where
+
+import           Control.Monad           (join)
+import           Data.Aeson              (Value (..), Object)
+import           Data.Aeson.Types        (emptyObject, emptyArray)
+import           Data.Vector             as V (null, head)
+import           Data.Map                as M (fromList, toList)
+import           Data.Monoid             ((<>))
 import           Data.String.Conversions (cs)
-import           Data.Text
+import           Data.Text               (Text)
-import           Data.Maybe (isNothing)
+import           Data.Time.Clock         (NominalDiffTime)
-import qualified Data.Vector             as V
+import           PostgREST.PgQuery       (pgFmtLit, pgFmtIdent, unquoted)
-import qualified Hasql                   as H
-import qualified Hasql.Backend           as B
-import qualified Hasql.Postgres          as P
-import           PostgREST.PgQuery       (pgFmtLit)
-import           Prelude
 import qualified Web.JWT                 as JWT
+import qualified Data.HashMap.Lazy       as H
 
-import           System.IO.Unsafe
+{-|
-
+  Receives a map of JWT claims and returns a list
-data AuthUser = AuthUser {
+  of PostgreSQL statements to set the claims as user defined GUCs.
-    userId   :: String
+  Except if we have a claim called role,
-  , userPass :: String
+  this one is mapped to a SET ROLE statement.
-  , userRole :: Maybe String
+  In case there is any problem decoding the JWT it returns Nothing.
-  } deriving (Show)
+-}
-
+claimsToSQL :: JWT.ClaimsMap -> [Text]
-instance FromJSON AuthUser where
+claimsToSQL = map setVar . toList
-  parseJSON (Object v) = AuthUser <$>
+  where
-                         v .: "id" <*>
+    setVar ("role", String val) = setRole val
-                         v .: "pass" <*>
+    setVar (k, val) = "set local postgrest.claims." <> pgFmtIdent k <>
-                         v .:? "role"
+                      " = " <> valueToVariable val <> ";"
-  parseJSON _ = mzero
+    valueToVariable = pgFmtLit . unquoted
-
+
-instance ToJSON AuthUser where
+{-|
-  toJSON u = object [
+  Receives the JWT secret (from config) and a JWT and
-      "id" .= userId u
+  returns a map of JWT claims
-    , "pass" .= userPass u
+  In case there is any problem decoding the JWT it returns Nothing.
-    , "role" .= userRole u ]
+-}
-
+jwtClaims :: Text -> Text -> NominalDiffTime -> Maybe JWT.ClaimsMap
-type DbRole = Text
+jwtClaims secret input time =
-type UserId = Text
+  case join $ claim JWT.exp of
-
+    Just expires ->
-data LoginAttempt =
+      if JWT.secondsSinceEpoch expires > time
-    NoCredentials
+        then customClaims
-  | MalformedAuth
+        else Nothing
-  | LoginFailed
+    _ -> customClaims
-  | LoginSuccess DbRole UserId
-  deriving (Eq, Show)
-
-checkPass :: Text -> Text -> Bool
-checkPass = (. cs) . validatePassword . cs
-
-setRole :: Text -> H.Tx P.Postgres s ()
-setRole role = H.unitEx $ B.Stmt ("set local role " <> cs (pgFmtLit role)) V.empty True
-
-setUserId :: Text -> H.Tx P.Postgres s ()
-setUserId uid =
-  if uid /= ""
-    then H.unitEx $ B.Stmt ("set local user_vars.user_id = " <> cs (pgFmtLit uid)) V.empty True
-    else resetUserId
-
-resetUserId :: H.Tx P.Postgres s ()
-resetUserId = H.unitEx [H.stmt|reset user_vars.user_id|]
-
-addUser :: Text -> Text -> Maybe Text -> H.Tx P.Postgres s ()
-addUser identity pass role =
-  H.unitEx $
-    if isNothing role
-      then [H.stmt|insert into postgrest.auth (id, pass) values (?, ?)|]
-        identity hashedText
-      else [H.stmt|insert into postgrest.auth (id, pass, rolname) values (?, ?, ?)|]
-        identity hashedText role
-  where Just hashed = unsafePerformIO $ hashPasswordUsingPolicy fastBcryptHashingPolicy (cs pass)
-        hashedText = cs hashed :: Text
-
-signInRole :: Text -> Text -> H.Tx P.Postgres s LoginAttempt
-signInRole user pass = do
-  u <- H.maybeEx $ [H.stmt|select id, pass, rolname from postgrest.auth where id = ?|] user
-  return $ maybe LoginFailed (\r ->
-      let (uid, hashed, role) = r in
-      if checkPass hashed pass
-         then LoginSuccess role uid
-         else LoginFailed
-    ) u
-
-signInWithJWT :: Text -> Text -> LoginAttempt
-signInWithJWT secret input = case maybeRole of
-    Just (Just (String role)) -> case maybeUserId of
-      Just (Just (String uid)) -> LoginSuccess (cs role) (cs uid)
-      _   -> LoginFailed
-    _   -> LoginFailed
   where
-    maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value)
-    maybeUserId = (Data.Map.lookup "id" <$> claims) ::Maybe (Maybe Value)
-    claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded
     decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input
+    claim :: (JWT.JWTClaimsSet -> a) -> Maybe a
+    claim prop = prop . JWT.claims <$> decoded
+    customClaims = claim JWT.unregisteredClaims
 
-tokenJWT :: Text -> Text -> Text -> Text
+-- | Receives the name of a role and returns a SET ROLE statement
-tokenJWT secret uid role = JWT.encodeSigned JWT.HS256 (JWT.secret secret) claimsSet
+setRole :: Text -> Text
-  where
+setRole role = "set local role " <> cs (pgFmtLit role) <> ";"
-    claimsSet = JWT.def {
+
-      JWT.unregisteredClaims = Data.Map.fromList [("id", String uid), ("role", String role)]
+
-    }
+{-|
+  Receives the JWT secret (from config) and a JWT and a JSON value
+  and returns a signed JWT.
+-}
+tokenJWT :: Text -> Value -> Text
+tokenJWT secret (Array a) = JWT.encodeSigned JWT.HS256 (JWT.secret secret)
+                               JWT.def { JWT.unregisteredClaims = fromHashMap o }
+                          where
+                            Object o = if V.null a then emptyObject else V.head a
+                            fromHashMap :: Object -> JWT.ClaimsMap
+                            fromHashMap = M.fromList . H.toList
+tokenJWT secret _          = tokenJWT secret emptyArray

src/PostgREST/Config.hs

@@ -28,44 +28,33 @@ import           Data.Text                   (strip)
 import           Data.Version                (versionBranch)
 import           Network.Wai
 import           Network.Wai.Middleware.Cors (CorsResourcePolicy (..))
-import           Options.Applicative         hiding (columns)
+import           Options.Applicative
 import           Paths_postgrest             (version)
 import           Prelude
 
 -- | Data type to store all command line options
 data AppConfig = AppConfig {
-    configDbName    :: String
+    configDatabase  :: String
-  , configDbPort    :: Int
-  , configDbUser    :: String
-  , configDbPass    :: String
-  , configDbHost    :: String
-
   , configPort      :: Int
   , configAnonRole  :: String
-  , configSecure    :: Bool
+  , configSchema    :: String
-  , configPool      :: Int
-  , configV1Schema  :: String
   , configJwtSecret :: String
+  , configPool      :: Int
   }
 
 argParser :: Parser AppConfig
 argParser = AppConfig
-  <$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database")
+  <$> argument str (help "database connection string" <> metavar "STRING")
-  <*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault)
-  <*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role")
-  <*> strOption (long "db-pass" <> metavar "PASS" <> value "" <> help "password for authenticator role")
-  <*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault)
 
-  <*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault)
+  <*> option auto  (long "port"       <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault)
-  <*> strOption (long "anonymous" <> short 'a' <> metavar "ROLE" <> help "postgres role to use for non-authenticated requests")
+  <*> strOption    (long "anonymous"  <> short 'a' <> help "postgres role to use for non-authenticated requests" <> metavar "ROLE")
-  <*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS")
+  <*> strOption    (long "schema"     <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "1" <> showDefault)
-  <*> option auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault)
+  <*> strOption    (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault)
-  <*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault)
+  <*> option auto  (long "pool"       <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault)
-  <*> strOption (long "jwt-secret" <> metavar "SECRET" <> value "secret" <> help "Secret used to encrypt and decrypt JWT tokens)" <> showDefault)
 
 defaultCorsPolicy :: CorsResourcePolicy
 defaultCorsPolicy =  CorsResourcePolicy Nothing
-  ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
+  ["GET", "POST", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing
   (Just $ 60*60*24) False False True
 
 -- | CORS policy to be used in by Wai Cors middleware

src/PostgREST/DbStructure.hs

@@ -0,0 +1,354 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeSynonymInstances  #-}
+module PostgREST.DbStructure (
+  getDbStructure
+, accessibleTables
+, doesProcExist
+, doesProcReturnJWT
+) where
+
+import           Control.Applicative
+import           Control.Monad          (join)
+import           Data.Functor.Identity
+import           Data.List              (elemIndex, find, subsequences, sort, transpose)
+import           Data.Maybe             (fromMaybe, fromJust, isJust, mapMaybe, listToMaybe)
+import           Data.Monoid
+import           Data.Text              (Text, split)
+import qualified Hasql                  as H
+import qualified Hasql.Postgres         as P
+import qualified Hasql.Backend          as B
+import           PostgREST.PgQuery      ()
+import           PostgREST.Types
+
+import           GHC.Exts               (groupWith)
+import           Prelude
+
+getDbStructure :: Schema -> H.Tx P.Postgres s DbStructure
+getDbStructure schema = do
+  tabs <- allTables
+  cols <- allColumns tabs
+  syns <- allSynonyms cols
+  rels <- allRelations tabs cols
+  keys <- allPrimaryKeys tabs
+
+  let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels
+      cols' = addForeignKeys rels' cols
+      keys' = synonymousPrimaryKeys syns keys
+
+  return DbStructure {
+      dbTables = tabs
+    , dbColumns = cols'
+    , dbRelations = rels'
+    , dbPrimaryKeys = keys'
+    }
+
+doesProc :: forall c s. B.CxValue c Int =>
+            (Text -> Text -> B.Stmt c) -> Text -> Text -> H.Tx c s Bool
+doesProc stmt schema proc = do
+  row :: Maybe (Identity Int) <- H.maybeEx $ stmt schema proc
+  return $ isJust row
+
+doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
+doesProcExist = doesProc [H.stmt|
+      SELECT 1
+      FROM   pg_catalog.pg_namespace n
+      JOIN   pg_catalog.pg_proc p
+      ON     pronamespace = n.oid
+      WHERE  nspname = ?
+      AND    proname = ?
+    |]
+
+doesProcReturnJWT :: Text -> Text -> H.Tx P.Postgres s Bool
+doesProcReturnJWT = doesProc [H.stmt|
+      SELECT 1
+      FROM   pg_catalog.pg_namespace n
+      JOIN   pg_catalog.pg_proc p
+      ON     pronamespace = n.oid
+      WHERE  nspname = ?
+      AND    proname = ?
+      AND    pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims'
+    |]
+
+accessibleTables :: [Table] -> H.Tx P.Postgres s [Table]
+accessibleTables allTabs = do
+  accessible <- H.listEx $ [H.stmt|
+      SELECT
+        n.nspname AS table_schema,
+        c.relname AS table_name
+      FROM pg_class c
+      JOIN pg_namespace n ON n.oid = c.relnamespace
+      WHERE
+        c.relkind IN ('v','r','m') AND
+        n.nspname NOT IN ('pg_catalog', 'information_schema') AND (
+          pg_has_role(c.relowner, 'USAGE'::text) OR
+          has_table_privilege(c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR
+          has_any_column_privilege(c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text)
+        )
+      ORDER BY table_schema, table_name
+    |]
+  let isAccessible table = isJust $ find (\(s,n) -> tableSchema table == s && tableName table == n) accessible
+  return $ filter isAccessible allTabs
+
+synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]]
+synonymousColumns allSyns cols = synCols'
+  where
+    syns = sort $ filter ((== colTable (head cols)) . colTable . fst) allSyns
+    synCols  = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols
+    synCols' = (filter sameTable . filter matchLength) synCols
+    matchLength cs = length cols == length cs
+    sameTable (c:cs) = all (\cc -> colTable c == colTable cc) (c:cs)
+    sameTable [] = False
+
+addForeignKeys :: [Relation] -> [Column] -> [Column]
+addForeignKeys rels = map addFk
+  where
+    addFk col = col { colFK = fk col }
+    fk col = join $ relToFk col <$> find (lookupFn col) rels
+    lookupFn :: Column -> Relation -> Bool
+    lookupFn c (Relation{relColumns=cs, relType=rty}) = c `elem` cs && rty==Child
+    -- lookupFn _ _ = False
+    relToFk col (Relation{relColumns=cols, relFColumns=colsF}) = ForeignKey <$> colF
+      where
+        pos = elemIndex col cols
+        colF = (colsF !!) <$> pos
+
+addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation]
+addSynonymousRelations _ [] = []
+addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynonymousRelations syns rels
+  where
+    synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs})
+    synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs})
+    synRels cols mapFn = map (\cs -> mapFn (colTable $ head cs) cs) $ synonymousColumns syns cols
+
+addParentRelations :: [Relation] -> [Relation]
+addParentRelations [] = []
+addParentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : addParentRelations rels
+
+addManyToManyRelations :: [Relation] -> [Relation]
+addManyToManyRelations rels = rels ++ mapMaybe link2Relation links
+  where
+    links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels
+    groupFn :: Relation -> Text
+    groupFn (Relation{relTable=Table{tableSchema=s, tableName=t}}) = s<>"_"<>t
+    combinations k ns = filter ((k==).length) (subsequences ns)
+    link2Relation [
+      Relation{relTable=lt, relColumns=lc1, relFTable=t,  relFColumns=c},
+      Relation{             relColumns=lc2, relFTable=ft, relFColumns=fc}
+      ]
+      | lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation t c ft fc Many (Just lt) (Just lc1) (Just lc2)
+      | otherwise = Nothing
+    link2Relation _ = Nothing
+
+raiseRelations :: Schema -> [(Column,Column)] -> [Relation] -> [Relation]
+raiseRelations schema syns = map raiseRel
+  where
+    raiseRel rel
+      | tableSchema table == schema = rel
+      | isJust newCols = rel{relFTable=fromJust newTable,relFColumns=fromJust newCols}
+      | otherwise = rel
+      where
+        cols = relFColumns rel
+        table = relFTable rel
+        newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . head) (synonymousColumns syns cols)
+        newTable = (colTable . head) <$> newCols
+
+synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey]
+synonymousPrimaryKeys _ [] = []
+synonymousPrimaryKeys syns (key:keys) = key : newKeys ++ synonymousPrimaryKeys syns keys
+  where
+    keySyns = filter ((\c -> colTable c == pkTable key && colName c == pkName key) . fst) syns
+    newKeys = map ((\c -> PrimaryKey{pkTable=colTable c,pkName=colName c}) . snd) keySyns
+
+allTables :: H.Tx P.Postgres s [Table]
+allTables = do
+    rows <- H.listEx $ [H.stmt|
+      SELECT
+        n.nspname AS table_schema,
+        c.relname AS table_name,
+        c.relkind = 'r' OR (c.relkind IN ('v','f'))
+        AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8
+        OR (EXISTS
+          ( SELECT 1
+            FROM pg_trigger
+            WHERE pg_trigger.tgrelid = c.oid
+            AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable
+      FROM pg_class c
+      JOIN pg_namespace n ON n.oid = c.relnamespace
+      WHERE c.relkind IN ('v','r','m')
+        AND n.nspname NOT IN ('pg_catalog', 'information_schema')
+      GROUP BY table_schema, table_name, insertable
+      ORDER BY table_schema, table_name
+    |]
+    return $ map tableFromRow rows
+
+tableFromRow :: (Text, Text, Bool) -> Table
+tableFromRow (s, n, i) = Table s n i
+
+allColumns :: [Table] -> H.Tx P.Postgres s [Column]
+allColumns tabs = do
+  cols <- H.listEx $ [H.stmt|
+      SELECT DISTINCT
+          info.table_schema AS schema,
+          info.table_name AS table_name,
+          info.column_name AS name,
+          info.ordinal_position AS position,
+          info.is_nullable::boolean AS nullable,
+          info.data_type AS col_type,
+          info.is_updatable::boolean AS updatable,
+          info.character_maximum_length AS max_len,
+          info.numeric_precision AS precision,
+          info.column_default AS default_value,
+          array_to_string(enum_info.vals, ',') AS enum
+      FROM (
+          SELECT
+              table_schema,
+              table_name,
+              column_name,
+              ordinal_position,
+              is_nullable,
+              data_type,
+              is_updatable,
+              character_maximum_length,
+              numeric_precision,
+              column_default,
+              udt_name
+          FROM information_schema.columns
+          WHERE table_schema NOT IN ('pg_catalog', 'information_schema')
+      ) AS info
+      LEFT OUTER JOIN (
+          SELECT
+              n.nspname AS s,
+              t.typname AS n,
+              array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals
+          FROM pg_type t
+          JOIN pg_enum e ON t.oid = e.enumtypid
+          JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace
+          GROUP BY s,n
+      ) AS enum_info ON (info.udt_name = enum_info.n)
+      ORDER BY schema, position
+  |]
+  return $ mapMaybe (columnFromRow tabs) cols
+
+columnFromRow :: [Table] ->
+                 (Text,       Text,      Text,
+                  Int,        Bool,      Text,
+                  Bool,       Maybe Int, Maybe Int,
+                  Maybe Text, Maybe Text)
+                 -> Maybe Column
+columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table
+  where
+    buildColumn tbl = Column tbl n pos nul typ u l p d (parseEnum e) Nothing
+    table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
+    parseEnum :: Maybe Text -> [Text]
+    parseEnum str = fromMaybe [] $ split (==',') <$> str
+
+allRelations :: [Table] -> [Column] -> H.Tx P.Postgres s [Relation]
+allRelations tabs cols = do
+  rels <- H.listEx $ [H.stmt|
+    SELECT ns1.nspname AS table_schema,
+           tab.relname AS table_name,
+           column_info.cols AS columns,
+           ns2.nspname AS foreign_table_schema,
+           other.relname AS foreign_table_name,
+           column_info.refs AS foreign_columns
+    FROM pg_constraint,
+       LATERAL (SELECT array_agg(cols.attname) AS cols,
+                       array_agg(cols.attnum)  AS nums,
+                       array_agg(refs.attname) AS refs
+                  FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,
+                       LATERAL (SELECT * FROM pg_attribute
+                                 WHERE attrelid = conrelid AND attnum = col)
+                            AS cols,
+                       LATERAL (SELECT * FROM pg_attribute
+                                 WHERE attrelid = confrelid AND attnum = ref)
+                            AS refs)
+            AS column_info,
+       LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = connamespace) AS ns1,
+       LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
+       LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other,
+       LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2
+    WHERE confrelid != 0
+    ORDER BY (conrelid, column_info.nums)
+  |]
+  return $ mapMaybe (relationFromRow tabs cols) rels
+
+relationFromRow :: [Table] -> [Column] -> (Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation
+relationFromRow allTabs allCols (rs, rt, rcs, frs, frt, frcs) =
+  if isJust table && isJust tableF && length cols == length rcs && length colsF == length frcs
+    then Just $ Relation (fromJust table) cols (fromJust tableF) colsF Child Nothing Nothing Nothing
+    else Nothing
+  where
+    findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs
+    findCols s t cs = filter (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col `elem` cs) allCols
+    table  = findTable rs rt
+    tableF = findTable frs frt
+    cols  = findCols rs rt rcs
+    colsF = findCols frs frt frcs
+
+allPrimaryKeys :: [Table] -> H.Tx P.Postgres s [PrimaryKey]
+allPrimaryKeys tabs = do
+  pks <- H.listEx $ [H.stmt|
+    SELECT
+        kc.table_schema,
+        kc.table_name,
+        kc.column_name
+    FROM
+        information_schema.table_constraints tc,
+        information_schema.key_column_usage kc
+    WHERE
+        tc.constraint_type = 'PRIMARY KEY' AND
+        kc.table_name = tc.table_name AND
+        kc.table_schema = tc.table_schema AND
+        kc.constraint_name = tc.constraint_name AND
+        kc.table_schema NOT IN ('pg_catalog', 'information_schema')
+    |]
+  return $ mapMaybe (pkFromRow tabs) pks
+
+pkFromRow :: [Table] -> (Schema, Text, Text) -> Maybe PrimaryKey
+pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n
+  where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs
+
+allSynonyms :: [Column] -> H.Tx P.Postgres s [(Column,Column)]
+allSynonyms allCols = do
+  syns <- H.listEx $ [H.stmt|
+    WITH synonyms AS (
+      SELECT
+        vcu.table_schema AS src_table_schema,
+        vcu.table_name AS src_table_name,
+        vcu.column_name AS src_column_name,
+        view.table_schema AS syn_table_schema,
+        view.table_name AS syn_table_name,
+        view.view_definition AS view_definition
+      FROM
+        information_schema.views AS view,
+        information_schema.view_column_usage AS vcu
+      WHERE
+        view.table_schema = vcu.view_schema AND
+        view.table_name = vcu.view_name AND
+        view.table_schema NOT IN ('pg_catalog', 'information_schema') AND
+        (SELECT COUNT(*) FROM information_schema.view_table_usage WHERE view_schema = view.table_schema AND view_name = view.table_name) = 1
+    )
+    SELECT
+      src_table_schema, src_table_name, src_column_name,
+      syn_table_schema, syn_table_name,
+      (regexp_matches(view_definition, CONCAT('\.(', src_column_name, ')(?=,|$)'), 'gn'))[1]
+    FROM synonyms
+    UNION (
+      SELECT
+        src_table_schema, src_table_name, src_column_name,
+        syn_table_schema, syn_table_name,
+        (regexp_matches(view_definition, CONCAT('\.', src_column_name, '\sAS\s("?)(.+?)\1(,|$)'), 'gn'))[2] /* " <- for syntax highlighting */
+      FROM synonyms
+    )
+    |]
+  return $ mapMaybe (synonymFromRow allCols) syns
+
+synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column)
+synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2
+  where
+    col1 = findCol s1 t1 c1
+    col2 = findCol s2 t2 c2
+    findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols

src/PostgREST/Main.hs

@@ -1,39 +1,39 @@
 module Main where
 
 
-import           PostgREST.PgStructure
-import           PostgREST.Types
-import           Network.Wai
-
 import           PostgREST.App
-import           PostgREST.Error                      (errResponse)
+import           PostgREST.Config                     (AppConfig (..),
+                                                       minimumPgVersion,
+                                                       prettyVersion,
+                                                       readOptions)
+import           PostgREST.Error                      (errResponse, PgError)
 import           PostgREST.Middleware
+import           PostgREST.DbStructure
 
 import           Control.Monad                        (unless)
 import           Control.Monad.IO.Class               (liftIO)
+import           Data.Aeson                           (encode)
 import           Data.Functor.Identity
 import           Data.Monoid                          ((<>))
 import           Data.String.Conversions              (cs)
 import           Data.Text                            (Text)
 import qualified Hasql                                as H
 import qualified Hasql.Postgres                       as P
+import           Network.Wai
 import           Network.Wai.Handler.Warp             hiding (Connection)
 import           Network.Wai.Middleware.RequestLogger (logStdout)
-
 import           System.IO                            (BufferMode (..),
                                                        hSetBuffering, stderr,
                                                        stdin, stdout)
 
-import           PostgREST.Config                     (AppConfig (..),
-                                                       prettyVersion,
-                                                       readOptions,
-                                                       minimumPgVersion)
-
 isServerVersionSupported :: H.Session P.Postgres IO Bool
 isServerVersionSupported = do
-  Identity (row :: Text) <- H.tx Nothing $ H.singleEx $ [H.stmt|SHOW server_version_num|]
+  Identity (row :: Text) <- H.tx Nothing $ H.singleEx [H.stmt|SHOW server_version_num|]
   return $ read (cs row) >= minimumPgVersion
 
+hasqlError :: PgError -> IO a
+hasqlError = error . cs . encode
+
 main :: IO ()
 main = do
   hSetBuffering stdout LineBuffering
@@ -43,55 +43,36 @@ main = do
   conf <- readOptions
   let port = configPort conf
 
-  unless (configSecure conf) $
-    putStrLn "WARNING, running in insecure mode, auth will be in plaintext"
   unless ("secret" /= configJwtSecret conf) $
     putStrLn "WARNING, running in insecure mode, JWT secret is the default value"
   Prelude.putStrLn $ "Listening on port " ++
     (show $ configPort conf :: String)
 
-  let pgSettings = P.ParamSettings (cs $ configDbHost conf)
+  let pgSettings = P.StringSettings $ cs (configDatabase conf)
-                     (fromIntegral $ configDbPort conf)
-                     (cs $ configDbUser conf)
-                     (cs $ configDbPass conf)
-                     (cs $ configDbName conf)
       appSettings = setPort port
                   . setServerName (cs $ "postgrest/" <> prettyVersion)
                   $ defaultSettings
-      middle = logStdout . defaultMiddle (configSecure conf)
+      middle = logStdout . defaultMiddle
 
   poolSettings <- maybe (fail "Improper session settings") return $
     H.poolSettings (fromIntegral $ configPool conf) 30
   pool :: H.Pool P.Postgres <- H.acquirePool pgSettings poolSettings
 
   supportedOrError <- H.session pool isServerVersionSupported
-  either (fail . show)
+  either hasqlError
     (\supported ->
       unless supported $
-        fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0"
+        error (
+          "Cannot run in this PostgreSQL version, PostgREST needs at least "
+          <> show minimumPgVersion)
     ) supportedOrError
 
   let txSettings = Just (H.ReadCommitted, Just True)
-  metadata <- H.session pool $ H.tx txSettings $ do
+  dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf)
-    tabs <- allTables
+  dbStructure <- either hasqlError return dbOrError
-    rels <- allRelations
-    cols <- allColumns rels
-    keys <- allPrimaryKeys
-    return (tabs, rels, cols, keys)
-
-  dbstructure <- case metadata of
-    Left e -> fail $ show e
-    Right (tabs, rels, cols, keys) ->
-      return DbStructure {
-          tables=tabs
-        , columns=cols
-        , relations=rels
-        , primaryKeys=keys
-        }
-
 
   runSettings appSettings $ middle $ \ req respond -> do
     body <- strictRequestBody req
     resOrError <- liftIO $ H.session pool $ H.tx txSettings $
-      authenticated conf (app dbstructure conf body) req
+      runWithClaims conf (app dbStructure conf body) req
     either (respond . errResponse) respond resOrError

src/PostgREST/Middleware.hs

@@ -4,91 +4,57 @@
 module PostgREST.Middleware where
 
 import           Data.Maybe                    (fromMaybe, isNothing)
-import           Data.Monoid
 import           Data.Text
 import           Data.String.Conversions       (cs)
+import           Data.Time.Clock.POSIX         (getPOSIXTime)
 import qualified Hasql                         as H
 import qualified Hasql.Postgres                as P
 
-import           Network.HTTP.Types            (RequestHeaders)
+import           Network.HTTP.Types.Header     (hAccept, hAuthorization)
-import           Network.HTTP.Types.Header     (hAccept, hAuthorization,
+import           Network.HTTP.Types.Status     (status415, status400)
-                                                hLocation)
+import           Network.Wai                   (Application, Request (..), Response,
-import           Network.HTTP.Types.Status     (status301, status400, status401,
+                                                requestHeaders, responseLBS)
-                                                status415)
-import           Network.URI                   (URI (..), parseURI)
-import           Network.Wai                   (Application, Request (..),
-                                                Response, isSecure, rawPathInfo,
-                                                rawQueryString, requestHeaders,
-                                                responseLBS)
 import           Network.Wai.Middleware.Cors   (cors)
 import           Network.Wai.Middleware.Gzip   (def, gzip)
 import           Network.Wai.Middleware.Static (only, staticPolicy)
 
-import           Codec.Binary.Base64.String    (decode)
 import           PostgREST.App                 (contentTypeForAccept)
-import           PostgREST.Auth                (DbRole, LoginAttempt (..),
+import           PostgREST.Auth                (setRole, jwtClaims, claimsToSQL)
-                                                setRole, setUserId, signInRole,
-                                                signInWithJWT)
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 
-import           Prelude
+import           System.IO.Unsafe              (unsafePerformIO)
 
-authenticated :: forall s. AppConfig ->
+import           Prelude hiding(concat)
-                 (DbRole -> Request -> H.Tx P.Postgres s Response) ->
+
+import qualified Data.Vector             as V
+import qualified Hasql.Backend           as B
+import qualified Data.Map.Lazy           as M
+
+runWithClaims :: forall s. AppConfig ->
+                 (Request -> H.Tx P.Postgres s Response) ->
                  Request -> H.Tx P.Postgres s Response
-authenticated conf app req = do
+runWithClaims conf app req = do
-  attempt <- httpRequesterRole (requestHeaders req)
+    _ <- H.unitEx $ stmt setAnon
-  case attempt of
+    let time = unsafePerformIO getPOSIXTime
-    MalformedAuth ->
+    case split (== ' ') (cs auth) of
-      return $ responseLBS status400 [] "Malformed basic auth header"
+      ("Bearer" : tokenStr : _) ->
-    LoginFailed ->
+        case jwtClaims jwtSecret tokenStr time of
-      return $ responseLBS status401 [] "Invalid username or password"
+          Just claims ->
-    LoginSuccess role uid -> if role /= currentRole then runInRole role uid else app currentRole req
+            if M.member "role" claims
-    NoCredentials         -> if anon /= currentRole then runInRole anon "" else app currentRole req
+            then do
-
+              mapM_ H.unitEx $ stmt <$> claimsToSQL claims
- where
+              app req
-   jwtSecret = cs $ configJwtSecret conf
+            else invalidJWT
-   currentRole = cs $ configDbUser conf
+          _ -> invalidJWT
-   anon = cs $ configAnonRole conf
+      _ -> app req
-   httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt
+  where
-   httpRequesterRole hdrs = do
+    stmt c = B.Stmt c V.empty True
-    let auth = fromMaybe "" $ lookup hAuthorization hdrs
+    hdrs = requestHeaders req
-    case split (==' ') (cs auth) of
+    jwtSecret = (cs $ configJwtSecret conf) :: Text
-      ("Basic" : b64 : _) ->
+    auth = fromMaybe "" $ lookup hAuthorization hdrs
-        case split (==':') (cs . decode . cs $ b64) of
+    anon = cs $ configAnonRole conf
-          (u:p:_) -> signInRole u p
+    setAnon = setRole anon
-          _ -> return MalformedAuth
+    invalidJWT = return $ responseLBS status400 [("Content-Type","application/json")] "{\"message\":\"Invalid JWT\"}"
-      ("Bearer" : jwt : _) ->
-        return $ signInWithJWT jwtSecret jwt
-      _ -> return NoCredentials
-
-   runInRole :: Text -> Text -> H.Tx P.Postgres s Response
-   runInRole r uid = do
-     setUserId uid
-     setRole r
-     app r req
-
-
-redirectInsecure :: Application -> Application
-redirectInsecure app req respond = do
-  let hdrs = requestHeaders req
-      host = lookup "host" hdrs
-      uriM = parseURI . cs =<< mconcat [
-        Just "https://",
-        host,
-        Just $ rawPathInfo req,
-        Just $ rawQueryString req]
-      isHerokuSecure = lookup "x-forwarded-proto" hdrs == Just "https"
-
-  if not (isSecure req || isHerokuSecure)
-    then case uriM of
-      Just uri ->
-        respond $ responseLBS status301 [
-            (hLocation, cs . show $ uri { uriScheme = "https:" })
-          ] ""
-      Nothing ->
-        respond $ responseLBS status400 [] "SSL is required"
-    else app req respond
 
 unsupportedAccept :: Application -> Application
 unsupportedAccept app req respond = do
@@ -98,8 +64,9 @@ unsupportedAccept app req respond = do
   then respond $ responseLBS status415 [] "Unsupported Accept header, try: application/json"
   else app req respond
 
-defaultMiddle :: Bool -> Application -> Application
+defaultMiddle :: Application -> Application
-defaultMiddle secure = (if secure then redirectInsecure else id)
+defaultMiddle =
-  . gzip def . cors corsPolicy
+    gzip def
+  . cors corsPolicy
   . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
   . unsupportedAccept

src/PostgREST/Parsers.hs

@@ -1,48 +1,27 @@
 module PostgREST.Parsers
-( parseGetRequest
+-- ( parseGetRequest
-)
+-- )
 where
 
 import           Control.Applicative hiding ((<$>))
---lines needed for ghc 7.8
-import           Data.Functor ((<$>))
-import           Data.Traversable (traverse)
-
-import           Control.Monad                 (join)
-import           Data.List                     (delete, find)
-import           Data.Maybe
 import           Data.Monoid
 import           Data.String.Conversions       (cs)
 import           Data.Text                     (Text)
 import           Data.Tree
-import           Network.Wai                   (Request, pathInfo, queryString)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
-
+import           PostgREST.PgQuery (operators)
-parseGetRequest :: Request -> Either ParseError ApiRequest
-parseGetRequest httpRequest =
-  foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
-  where
-    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
-    addOrder (Node r f) o = Node r{order=o} f
-    flts = mapM pRequestFilter whereFilters
-    rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
-    qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
-    orderStr = join $ lookup "order" qString
-    ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr
-    selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to *
-    whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ]
 
 pRequestSelect :: Text -> Parser ApiRequest
 pRequestSelect rootNodeName = do
   fieldTree <- pFieldForest
-  return $ foldr treeEntry (Node (Select rootNodeName [] [] [] Nothing Nothing) []) fieldTree
+  return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree
   where
     treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest
-    treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) =
+    treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =
       case fldForest of
-        [] -> Node (rNode {fields=fld:fields rNode}) rForest
+        [] -> Node (q {select=fld:select q}, i) rForest
-        _  -> Node rNode (foldr treeEntry (Node (Select fn [] [] [] Nothing Nothing) []) fldForest:rForest)
+        _  -> Node (q, i) (foldr treeEntry (Node (Select [] [fn] [] Nothing, (fn, Nothing)) []) fldForest:rForest)
 
 pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
 pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
@@ -54,21 +33,6 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
     op = fst <$> opVal
     val = snd <$> opVal
 
-addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
-addFilter ([], flt) (Node rn@(Select {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest
-addFilter (path, flt) (Node rn forest) =
-  case targetNode of
-    Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
-    Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
-  where
-    targetNodeName:remainingPath = path
-    (targetNode,restForest) = splitForest targetNodeName forest
-    splitForest name forst =
-      case maybeNode of
-        Nothing -> (Nothing,forest)
-        Just node -> (Just node, delete node forest)
-      where maybeNode = find ((name==).mainTable.rootLabel) forst
-
 ws :: Parser Text
 ws = cs <$> many (oneOf " \t")
 
@@ -82,22 +46,20 @@ pTreePath = do
   let pp = map cs p
       jpp = map cs <$> jp
   return (init pp, (last pp, jpp))
-  where
-
 
 pFieldForest :: Parser [Tree SelectItem]
 pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
 
 pFieldTree :: Parser (Tree SelectItem)
-pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')'))
+pFieldTree = try (Node <$> pSelect <*> between (char '(') (char ')') pFieldForest)
-      <|>    Node <$> pSelect <*> pure []
+          <|>     Node <$> pSelect <*> pure []
 
 pStar :: Parser Text
 pStar = cs <$> (string "*" *> pure ("*"::String))
 
 pFieldName :: Parser Text
 pFieldName =  cs <$> (many1 (letter <|> digit <|> oneOf "_")
-      <?> "field name (* or [a..z0..9_])")
+          <?> "field name (* or [a..z0..9_])")
 
 pJsonPathStep :: Parser Text
 pJsonPathStep = cs <$> try (string "->" *> pFieldName)
@@ -116,22 +78,8 @@ pSelect = lexeme $
     return ((s, Nothing), Nothing)
 
 pOperator :: Parser Operator
-pOperator = cs <$> ( try (string "lte") -- has to be before lt
+pOperator = cs <$> (pOp <?> "operator (eq, gt, ...)")
-     <|> try (string "lt")
+  where pOp = foldl (<|>) empty $ map (try . string . cs . fst) operators
-     <|> try (string "eq")
-     <|> try (string "gte") -- has to be before gh
-     <|> try (string "gt")
-     <|> try (string "lt")
-     <|> try (string "neq")
-     <|> try (string "like")
-     <|> try (string "ilike")
-     <|> try (string "in")
-     <|> try (string "notin")
-     <|> try (string "is" )
-     <|> try (string "isnot")
-     <|> try (string "@@")
-     <?> "operator (eq, gt, ...)"
-     )
 
 pValue :: Parser FValue
 pValue = VText <$> (cs <$> many anyChar)

src/PostgREST/PgQuery.hs

@@ -3,14 +3,48 @@
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module PostgREST.PgQuery where
+module PostgREST.PgQuery (
+  fromQi
+, insertableValue
+, wrapQuery
+, asJson
+, callProc
+, unquoted
+, operators
+
+-- format functions
+, pgFmtLit
+, pgFmtIdent
+, pgFmtValue
+, pgFmtCondition
+, pgFmtColumn
+, pgFmtJsonPath
+, pgFmtTable
+, pgFmtField
+, pgFmtSelectItem
+, pgFmtAsJsonPath
+
+-- query fragments
+, sourceSubqueryName
+, orderF
+, countNoneF
+, countAllF
+, countF
+, locationF
+, asCsvF
+, asJsonSingleF
+, asJsonF
+, selectStarF
+
+, StatementT
+) where
 
 
 import qualified Hasql                   as H
 import qualified Hasql.Backend           as B
 import qualified Hasql.Postgres          as P
 import           PostgREST.RangeQuery
-import           PostgREST.Types         (OrderTerm (..), QualifiedIdentifier(..))
+import           PostgREST.Types
 
 import           Control.Monad           (join)
 import qualified Data.Aeson              as JSON
@@ -25,11 +59,10 @@ import           Data.Scientific         (FPFormat (..), formatScientific,
 import           Data.String.Conversions (cs)
 import qualified Data.Text               as T
 import           Data.Vector             (empty)
-import qualified Data.Vector             as V
-import qualified Network.HTTP.Types.URI  as Net
 import           Text.Regex.TDFA         ((=~))
 
 import           Prelude
+import qualified Data.Map                as M
 
 type PStmt = H.Stmt P.Postgres
 instance Monoid PStmt where
@@ -37,81 +70,35 @@ instance Monoid PStmt where
     B.Stmt (query <> query') (params <> params') (prep && prep')
   mempty = B.Stmt "" empty True
 type StatementT = PStmt -> PStmt
+data JsonbPath =
+    ColIdentifier T.Text
+  | KeyIdentifier T.Text
+  | SingleArrow JsonbPath JsonbPath
+  | DoubleArrow JsonbPath JsonbPath
+  deriving (Show)
 
 
-limitT :: Maybe NonnegRange -> StatementT
+operators :: [(T.Text, T.Text)]
-limitT r q =
+operators = [
-  q <> B.Stmt (" LIMIT " <> limit <> " OFFSET " <> offset <> " ") empty True
+  ("eq", "="),
-  where
+  ("gte", ">="), -- has to be before gt (parsers)
-    limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
+  ("gt", ">"),
-    offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
+  ("lte", "<="), -- has to be before lt (parsers)
+  ("lt", "<"),
+  ("neq", "<>"),
+  ("like", "like"),
+  ("ilike", "ilike"),
+  ("in", "in"),
+  ("notin", "not in"),
+  ("isnot", "is not"), -- has to be before is (parsers)
+  ("is", "is"),
+  ("@@", "@@"),
+  ("@>", "@>"),
+  ("<@", "<@")
+  ]
 
-whereT :: QualifiedIdentifier -> Net.Query -> StatementT
+operatorsMap :: M.Map T.Text T.Text
-whereT table params q =
+operatorsMap = M.fromList operators
-  if L.null cols
-    then q
-    else q <> B.Stmt " where " empty True <> conjunction
-  where
-    cols = [ col | col <- params, fst col `notElem` ["order","select"] ]
-    wherePredTable = wherePred table
-    conjunction = mconcat $ L.intersperse andq (map wherePredTable cols)
-
-withT :: PStmt -> T.Text -> StatementT
-withT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
-  B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq <> " from " <> v)
-    (ep <> wp)
-    (epre && wpre)
-
-orderT :: [OrderTerm] -> StatementT
-orderT ts q =
-  if L.null ts
-    then q
-    else q <> B.Stmt " order by " empty True <> clause
-  where
-    clause = mconcat $ L.intersperse commaq (map queryTerm ts)
-    queryTerm :: OrderTerm -> PStmt
-    queryTerm t = B.Stmt
-      (" " <> cs (pgFmtIdent $ otTerm t) <> " "
-           <> cs (otDirection t)         <> " "
-           <> maybe "" cs (otNullOrder t) <> " ")
-      empty True
-
-parentheticT :: StatementT
-parentheticT s =
-  s { B.stmtTemplate = " (" <> B.stmtTemplate s <> ") " }
-
-iffNotT :: PStmt -> StatementT
-iffNotT (B.Stmt aq ap apre) (B.Stmt bq bp bpre) =
-  B.Stmt
-    ("WITH aaa AS (" <> aq <> " returning *) " <>
-      bq <> " WHERE NOT EXISTS (SELECT * FROM aaa)")
-    (ap <> bp)
-    (apre && bpre)
-
-countT :: StatementT
-countT s =
-  s { B.stmtTemplate = "WITH qqq AS (" <> B.stmtTemplate s <> ") SELECT pg_catalog.count(1) FROM qqq" }
-
-countRows :: QualifiedIdentifier  -> PStmt
-countRows t = B.Stmt ("select pg_catalog.count(1) from " <> fromQi t) empty True
-
-countNone :: PStmt
-countNone = B.Stmt "select null" empty True
-
-asCsvWithCount :: QualifiedIdentifier -> StatementT
-asCsvWithCount table = withCount . asCsv table
-
-asCsv :: QualifiedIdentifier -> StatementT
-asCsv table s = s {
-  B.stmtTemplate =
-    "(select string_agg(quote_ident(column_name::text), ',') from "
-    <> "(select column_name from information_schema.columns where quote_ident(table_schema) || '.' || table_name = '"
-    <> fromQi table <> "' order by ordinal_position) h) || '\r' || "
-    <> "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\r'), '') from ("
-    <> B.stmtTemplate s <> ") t" }
-
-asJsonWithCount :: StatementT
-asJsonWithCount = withCount . asJson
 
 asJson :: StatementT
 asJson s = s {
@@ -119,56 +106,6 @@ asJson s = s {
     "array_to_json(coalesce(array_agg(row_to_json(t)), '{}'))::character varying from ("
     <> B.stmtTemplate s <> ") t" }
 
-withCount :: StatementT
-withCount s = s { B.stmtTemplate = "pg_catalog.count(t), " <> B.stmtTemplate s }
-
-asJsonRow :: StatementT
-asJsonRow s = s { B.stmtTemplate = "row_to_json(t) from (" <> B.stmtTemplate s <> ") t" }
-
-returningStarT :: StatementT
-returningStarT s = s { B.stmtTemplate = B.stmtTemplate s <> " RETURNING *" }
-
-deleteFrom :: QualifiedIdentifier -> PStmt
-deleteFrom t = B.Stmt ("delete from " <> fromQi t) empty True
-
-insertInto :: QualifiedIdentifier
-              -> V.Vector T.Text
-              -> V.Vector (V.Vector JSON.Value)
-              -> PStmt
-insertInto t cols vals
-  | V.null cols = B.Stmt ("insert into " <> fromQi t <> " default values returning *") empty True
-  | otherwise   = B.Stmt
-    ("insert into " <> fromQi t <> " (" <>
-      T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <>
-      ") values "
-      <> T.intercalate ", "
-        (V.toList $ V.map (\v -> "("
-            <> T.intercalate ", " (V.toList $ V.map insertableValue v)
-            <> ")"
-          ) vals
-        )
-      <> " returning row_to_json(" <> fromQi t <> ".*)")
-    empty True
-
-insertSelect :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
-insertSelect t [] _ = B.Stmt
-  ("insert into " <> fromQi t <> " default values returning *") empty True
-insertSelect t cols vals = B.Stmt
-  ("insert into " <> fromQi t <> " ("
-    <> T.intercalate ", " (map pgFmtIdent cols)
-    <> ") select "
-    <> T.intercalate ", " (map insertableValue vals))
-  empty True
-
-update :: QualifiedIdentifier -> [T.Text] -> [JSON.Value] -> PStmt
-update t cols vals = B.Stmt
-  ("update " <> fromQi t <> " set ("
-    <> T.intercalate ", " (map pgFmtIdent cols)
-    <> ") = ("
-    <> T.intercalate ", " (map insertableValue vals)
-    <> ")")
-  empty True
-
 callProc :: QualifiedIdentifier -> JSON.Object -> PStmt
 callProc qi params = do
   let args = T.intercalate "," $ map assignment (H.toList params)
@@ -176,116 +113,19 @@ callProc qi params = do
   where
     assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
 
-wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt
-wherePred table (col, predicate) =
-  B.Stmt (notOp <> " " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <>
-      if opCode `elem` ["is","isnot"] then whiteList value
-                                 else cs sqlValue)
-      empty True
-
-  where
-    headPredicate:rest = T.split (=='.') $ cs $ fromMaybe "." predicate
-    hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
-    opCode        = hasNot (head rest) headPredicate
-    notOp         = hasNot headPredicate ""
-    value         = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
-    sqlValue = pgFmtValue opCode value
-    op = pgFmtOperator opCode
-
-
 whiteList :: T.Text -> T.Text
 whiteList val = fromMaybe
   (cs (pgFmtLit val) <> "::unknown ")
   (L.find ((==) . T.toLower $ val) ["null","true","false"])
 
-pgFmtValue :: T.Text -> T.Text -> T.Text
-pgFmtValue opCode value =
-  case opCode of
-    "like" -> unknownLiteral $ T.map star value
-    "ilike" -> unknownLiteral $ T.map star value
-    "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
-    "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
-    "@@" -> "to_tsquery(" <> unknownLiteral value <> ") "
-    _    -> unknownLiteral value
-  where
-    star c = if c == '*' then '%' else c
-    unknownLiteral = (<> "::unknown ") . pgFmtLit
-
-pgFmtOperator :: T.Text -> T.Text
-pgFmtOperator opCode =
-  case opCode of
-    "eq"  -> "="
-    "gt"  -> ">"
-    "lt"  -> "<"
-    "gte" -> ">="
-    "lte" -> "<="
-    "neq" -> "<>"
-    "like"-> "like"
-    "ilike"-> "ilike"
-    "in"  -> "in"
-    "notin" -> "not in"
-    "is"    -> "is"
-    "isnot" -> "is not"
-    "@@" -> "@@"
-    _     -> "="
-
-commaq :: PStmt
-commaq  = B.Stmt ", " empty True
-
-andq :: PStmt
-andq = B.Stmt " and " empty True
-
-data JsonbPath =
-    ColIdentifier T.Text
-  | KeyIdentifier T.Text
-  | SingleArrow JsonbPath JsonbPath
-  | DoubleArrow JsonbPath JsonbPath
-  deriving (Show)
-
-parseJsonbPath :: T.Text -> Maybe JsonbPath
-parseJsonbPath p =
-  case T.splitOn "->>" p of
-    [a,b] ->
-      let i:is = T.splitOn "->" a in
-      Just $ DoubleArrow
-        (foldl SingleArrow (ColIdentifier i) (map KeyIdentifier is))
-        (KeyIdentifier b)
-    _ -> Nothing
-
-pgFmtJsonbPath :: QualifiedIdentifier -> T.Text -> T.Text
-pgFmtJsonbPath table p =
-  pgFmtJsonbPath' $ fromMaybe (ColIdentifier p) (parseJsonbPath p)
-  where
-    pgFmtJsonbPath' (ColIdentifier i) = fromQi table <> "." <> pgFmtIdent i
-    pgFmtJsonbPath' (KeyIdentifier i) = pgFmtLit i
-    pgFmtJsonbPath' (SingleArrow a b) =
-      pgFmtJsonbPath' a <> "->" <> pgFmtJsonbPath' b
-    pgFmtJsonbPath' (DoubleArrow a b) =
-      pgFmtJsonbPath' a <> "->>" <> pgFmtJsonbPath' b
-
-pgFmtIdent :: T.Text -> T.Text
-pgFmtIdent x =
-  let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in
-  if (cs escaped :: BS.ByteString) =~ danger
-    then "\"" <> escaped <> "\""
-    else escaped
-
-  where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString
-
-pgFmtLit :: T.Text -> T.Text
-pgFmtLit x =
-  let trimmed = trimNullChars x
-      escaped = "'" <> T.replace "'" "''" trimmed <> "'"
-      slashed = T.replace "\\" "\\\\" escaped in
-  if T.isInfixOf "\\\\" escaped
-    then "E" <> slashed
-    else slashed
-
 trimNullChars :: T.Text -> T.Text
 trimNullChars = T.takeWhile (/= '\x0')
 
 fromQi :: QualifiedIdentifier -> T.Text
-fromQi t = pgFmtIdent (qiSchema t) <> "." <> pgFmtIdent (qiName t)
+fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n
+  where
+    n = qiName t
+    s = qiSchema t
 
 unquoted :: JSON.Value -> T.Text
 unquoted (JSON.String t) = t
@@ -301,6 +141,169 @@ insertableValue :: JSON.Value -> T.Text
 insertableValue JSON.Null = "null"
 insertableValue v = insertableText $ unquoted v
 
-paramFilter :: JSON.Value -> T.Text
+wrapQuery :: T.Text -> [T.Text] -> T.Text ->  Maybe NonnegRange -> T.Text
-paramFilter JSON.Null = "is.null"
+wrapQuery source selectColumns returnSelect range =
-paramFilter v = "eq." <> unquoted v
+  withSourceF source <>
+  " SELECT " <>
+  T.intercalate ", " selectColumns <>
+  " " <>
+  fromF returnSelect ( limitF range )
+
+
+-- query fragments
+sourceSubqueryName :: T.Text
+sourceSubqueryName = "pg_source"
+
+withSourceF :: T.Text -> T.Text
+withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")"
+
+countF :: T.Text
+countF = "pg_catalog.count(t)"
+
+countAllF :: T.Text
+countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )"
+
+countNoneF :: T.Text
+countNoneF = "null"
+
+asJsonF :: T.Text
+asJsonF = "array_to_json(array_agg(row_to_json(t)))::character varying"
+
+asJsonSingleF :: T.Text --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element
+asJsonSingleF = "string_agg(row_to_json(t)::text, ',')::character varying "
+
+asCsvF :: T.Text
+asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
+
+asCsvHeaderF :: T.Text
+asCsvHeaderF =
+  "(SELECT string_agg(a.k, ',')" <>
+  "  FROM (" <>
+  "    SELECT json_object_keys(r)::TEXT as k" <>
+  "    FROM ( " <>
+  "      SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <>
+  "    ) s" <>
+  "  ) a" <>
+  ")"
+
+asCsvBodyF :: T.Text
+asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')"
+
+selectStarF :: T.Text
+selectStarF = "SELECT * FROM " <> sourceSubqueryName
+
+fromF :: T.Text -> T.Text -> T.Text
+fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t"
+
+limitF :: Maybe NonnegRange -> T.Text
+limitF r  = "LIMIT " <> limit <> " OFFSET " <> offset
+  where
+    limit  = maybe "ALL" (cs . show) $ join $ rangeLimit <$> r
+    offset = cs . show $ fromMaybe 0 $ rangeOffset <$> r
+
+locationF :: [T.Text] -> T.Text
+locationF pKeys =
+    "(" <>
+    " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss  limit 1)" <>
+    " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <>
+    " FROM s, json_each_text(s.r) AS json_data" <>
+    (
+      if null pKeys
+      then ""
+      else " WHERE json_data.key IN ('" <> T.intercalate "','" pKeys <> "')"
+    ) <>
+    ")"
+
+orderF :: [OrderTerm] -> T.Text
+orderF ts =
+  if L.null ts
+    then ""
+    else "ORDER BY " <> clause
+  where
+    clause = T.intercalate "," (map queryTerm ts)
+    queryTerm :: OrderTerm -> T.Text
+    queryTerm t = " "
+           <> cs (pgFmtIdent $ otTerm t) <> " "
+           <> cs (otDirection t)         <> " "
+           <> maybe "" cs (otNullOrder t) <> " "
+
+-- formating functions
+
+pgFmtValue :: T.Text -> T.Text -> T.Text
+pgFmtValue opCode val =
+ case opCode of
+   "like" -> unknownLiteral $ T.map star val
+   "ilike" -> unknownLiteral $ T.map star val
+   "in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') val) <> ") "
+   "notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') val) <> ") "
+   "@@" -> "to_tsquery(" <> unknownLiteral val <> ") "
+   _    -> unknownLiteral val
+ where
+   star c = if c == '*' then '%' else c
+   unknownLiteral = (<> "::unknown ") . pgFmtLit
+
+pgFmtOperator :: T.Text -> T.Text
+pgFmtOperator opCode = fromMaybe "=" $ M.lookup opCode operatorsMap
+
+pgFmtIdent :: T.Text -> T.Text
+pgFmtIdent x =
+ let escaped = T.replace "\"" "\"\"" (trimNullChars $ cs x) in
+ if (cs escaped :: BS.ByteString) =~ danger
+   then "\"" <> escaped <> "\""
+   else escaped
+
+ where danger = "^$|^[^a-z_]|[^a-z_0-9]" :: BS.ByteString
+
+pgFmtLit :: T.Text -> T.Text
+pgFmtLit x =
+ let trimmed = trimNullChars x
+     escaped = "'" <> T.replace "'" "''" trimmed <> "'"
+     slashed = T.replace "\\" "\\\\" escaped in
+ if T.isInfixOf "\\\\" escaped
+   then "E" <> slashed
+   else slashed
+
+pgFmtCondition :: QualifiedIdentifier -> Filter -> T.Text
+pgFmtCondition table (Filter (col,jp) ops val) =
+  notOp <> " " <> sqlCol  <> " " <> pgFmtOperator opCode <> " " <>
+    if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue
+  where
+    headPredicate:rest = T.split (=='.') ops
+    hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
+    opCode      = hasNot (head rest) headPredicate
+    notOp       = hasNot headPredicate ""
+    sqlCol = case val of
+      VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp
+      VForeignKey qi _ -> pgFmtColumn qi col
+    sqlValue = valToStr val
+    getInner v = case v of
+      VText s -> s
+      _      -> ""
+    valToStr v = case v of
+      VText s -> pgFmtValue opCode s
+      VForeignKey (QualifiedIdentifier s _) (ForeignKey Column{colTable=Table{tableName=ft}, colName=fc}) -> pgFmtColumn qi fc
+        where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft
+      _ -> ""
+
+pgFmtColumn :: QualifiedIdentifier -> T.Text -> T.Text
+pgFmtColumn table "*" = fromQi table <> ".*"
+pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
+
+pgFmtJsonPath :: Maybe JsonPath -> T.Text
+pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
+pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )
+pgFmtJsonPath _ = ""
+
+pgFmtTable :: Table -> T.Text
+pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n
+
+pgFmtField :: QualifiedIdentifier -> Field -> T.Text
+pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp
+
+pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> T.Text
+pgFmtSelectItem table (f@(_, jp), Nothing) = pgFmtField table f <> pgFmtAsJsonPath jp
+pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAsJsonPath jp
+
+pgFmtAsJsonPath :: Maybe JsonPath -> T.Text
+pgFmtAsJsonPath Nothing = ""
+pgFmtAsJsonPath (Just xx) = " AS " <> last xx

src/PostgREST/PgStructure.hs

@@ -1,264 +0,0 @@
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeSynonymInstances  #-}
-module PostgREST.PgStructure where
-
-import           Control.Applicative
-import           Control.Monad         (join)
-import           Data.Functor.Identity
-import           Data.List             (elemIndex, find)
-import           Data.Maybe            (fromMaybe, isJust, mapMaybe)
-import           Data.Monoid
-import           Data.Text             (Text, split)
-import qualified Hasql                 as H
-import qualified Hasql.Postgres        as P
-import           PostgREST.PgQuery     ()
-import           PostgREST.Types
-
-import           GHC.Exts              (groupWith)
-import           Prelude
-
-
-doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
-doesProcExist schema proc = do
-  row :: Maybe (Identity Int) <- H.maybeEx $ [H.stmt|
-      SELECT 1
-      FROM   pg_catalog.pg_namespace n
-      JOIN   pg_catalog.pg_proc p
-      ON     pronamespace = n.oid
-      WHERE  nspname = ?
-      AND    proname = ?
-    |] schema proc
-  return $ isJust row
-
-
-tableFromRow :: (Text, Text, Bool, Maybe Text) -> Table
-tableFromRow (s, n, i, a) = Table s n i (parseAcl a)
-  where
-    parseAcl :: Maybe Text -> [Text]
-    parseAcl str = fromMaybe [] $ split (==',') <$> str
-
-columnFromRow :: (Text,       Text,      Text,
-                  Int,        Bool,      Text,
-                  Bool,       Maybe Int, Maybe Int,
-                  Maybe Text, Maybe Text)
-              -> Column
-columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
-  Column s t n pos nul typ u l p d (parseEnum e) Nothing
-
-  where
-    parseEnum :: Maybe Text -> [Text]
-    parseEnum str = fromMaybe [] $ split (==',') <$> str
-
-
-relationFromRow :: (Text, Text, [Text], Text, [Text]) -> Relation
-relationFromRow (s, t, cs, ft, fcs) = Relation s t cs ft fcs Child Nothing Nothing Nothing
-
-pkFromRow :: (Text, Text, Text) -> PrimaryKey
-pkFromRow (s, t, n) = PrimaryKey s t n
-
-
-addParentRelation :: Relation -> [Relation] -> [Relation]
-addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c Parent Nothing Nothing Nothing:rel:rels
-
-allTables :: H.Tx P.Postgres s [Table]
-allTables = do
-    rows <- H.listEx $ [H.stmt|
-      SELECT
-        n.nspname AS table_schema,
-        c.relname AS table_name,
-        c.relkind = 'r' OR (c.relkind IN ('v','f'))
-        AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8
-        OR (EXISTS
-          ( SELECT 1
-            FROM pg_trigger
-            WHERE pg_trigger.tgrelid = c.oid
-            AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable,
-        array_to_string(array_agg(r.rolname), ',') AS acl
-      FROM pg_class c
-      CROSS JOIN pg_roles r
-      JOIN pg_namespace n ON n.oid = c.relnamespace
-      WHERE c.relkind IN ('v','r','m')
-        AND n.nspname NOT IN ('pg_catalog', 'information_schema')
-        AND (
-          pg_has_role(r.rolname, c.relowner, 'USAGE'::text) OR
-          has_table_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, DELETE, TRUNCATE, REFERENCES, TRIGGER'::text) OR
-          has_any_column_privilege(r.rolname, c.oid, 'SELECT, INSERT, UPDATE, REFERENCES'::text) )
-
-      GROUP BY table_schema, table_name, insertable
-      ORDER BY table_schema, table_name
-    |]
-    return $ map tableFromRow rows
-
-allRelations :: H.Tx P.Postgres s [Relation]
-allRelations = do
-  rels <- H.listEx $ [H.stmt|
-    WITH table_fk AS (
-        SELECT ns.nspname AS table_schema,
-               tab.relname AS table_name,
-               column_info.cols AS columns,
-               other.relname AS foreign_table_name,
-               column_info.refs AS foreign_columns
-        FROM pg_constraint,
-           LATERAL (SELECT array_agg(cols.attname) AS cols,
-                           array_agg(cols.attnum)  AS nums,
-                           array_agg(refs.attname) AS refs
-                      FROM ( SELECT unnest(conkey) AS col, unnest(confkey) AS ref) k,
-                           LATERAL (SELECT * FROM pg_attribute
-                                     WHERE attrelid = conrelid AND attnum = col)
-                                AS cols,
-                           LATERAL (SELECT * FROM pg_attribute
-                                     WHERE attrelid = confrelid AND attnum = ref)
-                                AS refs)
-                AS column_info,
-           LATERAL (SELECT * FROM pg_namespace
-                            WHERE pg_namespace.oid = connamespace) AS ns,
-           LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
-           LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other
-        WHERE confrelid != 0
-        ORDER BY (conrelid, column_info.nums)
-    )
-
-    SELECT * FROM table_fk
-    UNION
-    (
-        SELECT
-            vcu.table_schema,
-            vcu.view_name AS table_name,
-            array_agg(vcu.column_name::text) AS columns,
-            table_fk.foreign_table_name,
-            table_fk.foreign_columns
-        FROM information_schema.view_column_usage as vcu
-        JOIN table_fk ON
-            table_fk.table_schema = vcu.view_schema AND
-            table_fk.table_name = vcu.table_name AND
-            vcu.column_name = ANY (table_fk.columns)
-        WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
-        AND columns = table_fk.columns
-        GROUP BY vcu.table_schema, vcu.view_name, table_fk.foreign_table_name, table_fk.foreign_columns
-    )
-    UNION
-    (
-        SELECT
-            vcu.view_schema as table_schema,
-            table_fk.table_name,
-            table_fk.columns,
-            vcu.view_name as foreign_table_name,
-            array_agg(vcu.column_name::text) as foreign_columns
-        FROM information_schema.view_column_usage as vcu
-        JOIN table_fk ON
-            table_fk.table_schema = vcu.view_schema AND
-            table_fk.foreign_table_name = vcu.table_name AND
-            vcu.column_name = ANY (table_fk.foreign_columns)
-        WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
-            AND foreign_columns = table_fk.foreign_columns
-        GROUP BY vcu.view_schema, table_fk.table_name, vcu.view_name, table_fk.columns
-    )
-  |]
-  let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels
-  let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations
-  return $ simpleRelations ++ mapMaybe link2Relation links
-  where
-    groupFn :: Relation -> Text
-    groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t
-    link2Relation [
-      Relation{relSchema=sc, relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c},
-      Relation{                           relColumns=lc2, relFTable=ft, relFColumns=fc}
-      ] = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2)
-    link2Relation _ = Nothing
-
-allColumns :: [Relation] -> H.Tx P.Postgres s [Column]
-allColumns rels = do
-  cols <- H.listEx $ [H.stmt|
-      SELECT
-          info.table_schema AS schema,
-          info.table_name AS table_name,
-          info.column_name AS name,
-          info.ordinal_position AS position,
-          info.is_nullable::boolean AS nullable,
-          info.data_type AS col_type,
-          info.is_updatable::boolean AS updatable,
-          info.character_maximum_length AS max_len,
-          info.numeric_precision AS precision,
-          info.column_default AS default_value,
-          array_to_string(enum_info.vals, ',') AS enum
-      FROM (
-          SELECT
-              table_schema,
-              table_name,
-              column_name,
-              ordinal_position,
-              is_nullable,
-              data_type,
-              is_updatable,
-              character_maximum_length,
-              numeric_precision,
-              column_default,
-              udt_name
-          FROM information_schema.columns
-          WHERE table_schema NOT IN ('pg_catalog', 'information_schema')
-      ) AS info
-      LEFT OUTER JOIN (
-          SELECT
-              n.nspname AS s,
-              t.typname AS n,
-              array_agg(e.enumlabel ORDER BY e.enumsortorder) AS vals
-          FROM pg_type t
-          JOIN pg_enum e ON t.oid = e.enumtypid
-          JOIN pg_catalog.pg_namespace n ON n.oid = t.typnamespace
-          GROUP BY s,n
-      ) AS enum_info ON (info.udt_name = enum_info.n)
-      ORDER BY schema, position
-  |]
-  return $ map (addFK . columnFromRow) cols
-
-  where
-    addFK col = col { colFK = fk col }
-    fk col = join $ relToFk (colName col) <$> find (lookupFn col) rels
-    lookupFn :: Column -> Relation -> Bool
-    lookupFn (Column{colSchema=cs, colTable=ct, colName=cn})  (Relation{relSchema=rs, relTable=rt, relColumns=rc, relType=rty}) =
-      cs==rs && ct==rt && cn `elem` rc && rty==Child
-    lookupFn _ _ = False
-    relToFk cName (Relation{relFTable=t, relColumns=cs, relFColumns=fcs}) = ForeignKey t <$> c
-      where
-        pos = elemIndex cName cs
-        c = (fcs !!) <$> pos
-
-allPrimaryKeys :: H.Tx P.Postgres s [PrimaryKey]
-allPrimaryKeys = do
-  pks <- H.listEx $ [H.stmt|
-    WITH table_pk AS (
-        SELECT
-            kc.table_schema,
-            kc.table_name,
-            kc.column_name
-        FROM
-            information_schema.table_constraints tc,
-            information_schema.key_column_usage kc
-        WHERE
-            tc.constraint_type = 'PRIMARY KEY' AND
-            kc.table_name = tc.table_name AND
-            kc.table_schema = tc.table_schema AND
-            kc.constraint_name = tc.constraint_name AND
-            kc.table_schema NOT IN ('pg_catalog', 'information_schema')
-    )
-    SELECT table_schema,
-           table_name,
-           column_name
-    FROM table_pk
-    UNION (
-        SELECT
-            vcu.view_schema,
-            vcu.view_name,
-            vcu.column_name
-         FROM information_schema.view_column_usage AS vcu
-         JOIN
-            table_pk ON table_pk.table_schema = vcu.view_schema AND
-            table_pk.table_name = vcu.table_name AND
-            table_pk.column_name = vcu.column_name
-         WHERE vcu.view_schema NOT IN ('pg_catalog','information_schema')
-    )
-    |]
-  return $ map pkFromRow pks

src/PostgREST/QueryBuilder.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 module PostgREST.QueryBuilder
 where
 
@@ -6,160 +7,148 @@ import           Control.Error
 import           Data.List         (find)
 import           Data.Monoid
 import           Data.Text         hiding (filter, find, foldr, head, last, map,
-                                    null, zipWith)
+                                    null, zipWith, concatMap)
 import           Control.Applicative
 import           Data.Tree
-import           PostgREST.PgQuery (PStmt, fromQi,
+import           PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem,
-                                    orderT, pgFmtIdent, pgFmtLit, pgFmtOperator,
+                                    pgFmtIdent, pgFmtCondition,
-                                    pgFmtValue, whiteList)
+                                    insertableValue, orderF, sourceSubqueryName, pgFmtJsonPath)
 import           PostgREST.Types
-import qualified Data.Vector       as V (empty)
+import qualified Data.Map as M
-import qualified Hasql.Backend     as B
 
-findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation
+findRelation :: [Relation] -> Schema -> Text -> Text -> Maybe Relation
 findRelation allRelations s t1 t2 =
-  find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations
+  find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations
 
-addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
+addRelations :: Schema -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
-addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) =
+addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
   case parentNode of
-    Nothing -> Node query{relation=Nothing} <$> updatedForest
+    Nothing -> Node (query, (table, Nothing)) <$> updatedForest
-    (Just (Node (Select{mainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
+    (Just (Node (_, (parentTable, _)) _)) -> Node <$> (addRel n <$> rel) <*> updatedForest
       where
         rel = note ("no relation between " <> table <> " and " <> parentTable)
             $  findRelation allRelations schema table parentTable
            <|> findRelation allRelations schema parentTable table
-        addRel :: Query -> Relation -> Query
+        addRel :: (Query, (NodeName, Maybe Relation)) -> Relation -> (Query, (NodeName, Maybe Relation))
-        addRel q r = q{relation = Just r}
+        addRel (q, (t, _)) r = (q, (t, Just r))
   where
     updatedForest = mapM (addRelations schema allRelations (Just node)) forest
 
 getJoinConditions :: Relation -> [Filter]
-getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) =
+getJoinConditions (Relation t cs ft fcs typ lt lc1 lc2) =
   case typ of
-    Child  -> zipWith (toFilter t ft) cs fcs
+    Child  -> zipWith (toFilter tN ftN) cs fcs
-    Parent -> zipWith (toFilter t ft) cs fcs
+    Parent -> zipWith (toFilter tN ftN) cs fcs
-    Many   -> zipWith (toFilter t (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" lt)) fcs (fromMaybe [] lc2)
+    Many   -> zipWith (toFilter tN ltN) cs (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2)
   where
-    toFilter :: Text -> Text -> FieldName -> FieldName -> Filter
+    s = tableSchema t
-    toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc))
+    tN = tableName t
+    ftN = tableName ft
+    ltN = fromMaybe "" (tableName <$> lt)
+    toFilter :: Text -> Text -> Column -> Column -> Filter
+    toFilter tb ftb c fc = Filter (colName c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}}))
 
-addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest
+addJoinConditions :: Text -> ApiRequest -> Either Text ApiRequest
-addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) =
+addJoinConditions schema (Node (query, (n, r)) forest) =
   case r of
-    Nothing -> Node updatedQuery  <$> updatedForest -- this is the root node
+    Nothing -> Node (updatedQuery, (n,r))  <$> updatedForest -- this is the root node
-    Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest
+    Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(n,r)) <$> updatedForest
-    Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest
+    Just (Relation{relType=Parent}) -> Node (updatedQuery, (n,r)) <$> updatedForest
     Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) ->
-      Node <$> pure qq <*> updatedForest
+      Node (qq, (n, r)) <$> updatedForest
       where
          q = addCond updatedQuery (getJoinConditions rel)
-         qq = q{joinTables=linkTable:joinTables q}
+         qq = q{from=tableName linkTable : from q}
-    _ -> Left "unknow relation"
+    _ -> Left "unknown relation"
   where
     -- add parentTable and parentJoinConditions to the query
-    updatedQuery = foldr (flip addCond) (query{joinTables = parentTables ++ joinTables query}) parentJoinConditions
+    updatedQuery = foldr (flip addCond) (query{from = parentTables ++ from query}) parentJoinConditions
       where
-        parentJoinConditions = map (getJoinConditions.snd) parents
+        parentJoinConditions = map (getJoinConditions . snd) parents
         parentTables = map fst parents
-        parents = mapMaybe (getParents.rootLabel) forest
+        parents = mapMaybe (getParents . rootLabel) forest
-        getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel)
+        getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)
         getParents _ = Nothing
-    updatedForest = mapM (addJoinConditions schema allColumns) forest
+    updatedForest = mapM (addJoinConditions schema) forest
-    addCond q con = q{filters=con ++ filters q}
+    addCond q con = q{where_=con ++ where_ q}
 
-requestToCountQuery :: Text -> ApiRequest -> PStmt
+emptyOnNull :: Text -> [a] -> Text
-requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) =
+emptyOnNull val x = if null x then "" else val
-  B.Stmt query V.empty True
+
+requestToQuery :: Text -> ApiRequest -> Text
+requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) =
+  query
   where
+    -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
+    -- of our WITH query part
+    tblSchema tbl = if tbl == sourceSubqueryName then "" else schema
+    qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl
+    toQi t = QualifiedIdentifier (tblSchema t) t
     query = Data.Text.unwords [
-      "SELECT pg_catalog.count(1)",
-      "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions
-      ]
-    emptyOnNull val x = if null x then "" else val
-    localConditions = filter fn conditions
-      where
-        fn  (Filter{value=VText _}) = True
-        fn  (Filter{value=VForeignKey _ _}) = False
-
-requestToQuery :: Text -> ApiRequest -> PStmt
-requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) =
-  orderT (fromMaybe [] ord)  query
-  where
-    query = B.Stmt qStr V.empty True
-    qStr = Data.Text.unwords [
       ("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
-      "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
+      "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
-      "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) (mainTbl:tbls)),
+      "FROM ", intercalate ", " (map (fromQi . toQi) tbls),
-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
+      orderF (fromMaybe [] ord)
       ]
-    emptyOnNull val x = if null x then "" else val
     (withs, selects) = foldr getQueryParts ([],[]) forest
-    getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text])
+    getQueryParts :: Tree ApiNode -> ([Text], [Text]) -> ([Text], [Text])
-    getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s)
+    getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
       where
         sel = "("
            <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
            <> "FROM (" <> subquery <> ") " <> table
            <> ") AS " <> table
-           where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
+           where subquery = requestToQuery schema (Node n forst)
-
+    getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
-    getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType=Parent}))}) forst) (w,s) = (wit:w,sel:s)
       where
         sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
         wit = table <> " AS ( " <> subquery <> " )"
-          where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
+          where subquery = requestToQuery schema (Node n forst)
-
+    getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
-    getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s)
       where
         sel = "("
            <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
            <> "FROM (" <> subquery <> ") " <> table
            <> ") AS " <> table
-           where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
+           where subquery = requestToQuery schema (Node n forst)
-
+    --the following is just to remove the warning
-    -- the following is just to remove the warning
     --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
     --posible relations are Child Parent Many
-    getQueryParts (Node (Select{relation=Nothing}) _) _ = undefined
+    getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
-
+requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) =
-pgFmtCondition :: QualifiedIdentifier -> Filter -> Text
+  query
-pgFmtCondition table (Filter (col,jp) ops val) =
-  notOp <> " " <> sqlCol  <> " " <> pgFmtOperator opCode <> " " <>
-    if opCode `elem` ["is","isnot"] then whiteList (getInner val) else sqlValue
   where
-    headPredicate:rest = split (=='.') ops
+    qi = QualifiedIdentifier schema mainTbl
-    hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse
+    query = Data.Text.unwords [
-    opCode      = hasNot (head rest) headPredicate
+      "INSERT INTO ", fromQi qi,
-    notOp       = hasNot headPredicate ""
+      " (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ",
-    sqlCol = case val of
+      "VALUES " <> intercalate ", "
-      VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp
+        ( map (\v ->
-      VForeignKey qi _ -> pgFmtColumn qi col
+            "(" <>
-    sqlValue = valToStr val
+            intercalate ", " ( map insertableValue v ) <>
-    getInner v = case v of
+            ")"
-      VText s -> s
+          ) vals
-      _      -> ""
+        ),
-    valToStr v = case v of
+      "RETURNING " <> fromQi qi <> ".*"
-      VText s -> pgFmtValue opCode s
+      ]
-      VForeignKey (QualifiedIdentifier s _) (ForeignKey ft fc) -> pgFmtColumn (QualifiedIdentifier s ft) fc
+requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
-
+  query
-pgFmtColumn :: QualifiedIdentifier -> Text -> Text
+  where
-pgFmtColumn table "*" = fromQi table <> ".*"
+    qi = QualifiedIdentifier schema mainTbl
-pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
+    query = Data.Text.unwords [
-
+      "UPDATE ", fromQi qi,
-pgFmtJsonPath :: Maybe JsonPath -> Text
+      " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ",
-pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
-pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )
+      "RETURNING " <> fromQi qi <> ".*"
-pgFmtJsonPath _ = ""
+      ]
-
+    formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v
-pgFmtTable :: Table -> Text
+requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) =
-pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n
+  query
-
+  where
-pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text
+    qi = QualifiedIdentifier schema mainTbl
-pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp
+    query = Data.Text.unwords [
-pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp
+      "DELETE FROM ", fromQi qi,
-
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
-asJsonPath :: Maybe JsonPath -> Text
+      "RETURNING " <> fromQi qi <> ".*"
-asJsonPath Nothing = ""
+      ]
-asJsonPath (Just xx) = " AS " <> last xx

src/PostgREST/Types.hs

@@ -3,69 +3,71 @@ import Data.Text
 import Data.Tree
 import qualified Data.ByteString.Char8 as BS
 import Data.Aeson
+import Data.Map
 
 data DbStructure = DbStructure {
-  tables :: [Table]
+  dbTables :: [Table]
-, columns :: [Column]
+, dbColumns :: [Column]
-, relations :: [Relation]
+, dbRelations :: [Relation]
-, primaryKeys :: [PrimaryKey]
+, dbPrimaryKeys :: [PrimaryKey]
-}
-
-
-data Table = Table {
-  tableSchema :: Text
-, tableName :: Text
-, tableInsertable :: Bool
-, tableAcl :: [Text]
-} deriving (Show)
-
-data ForeignKey = ForeignKey {
-  fkTable::Text, fkCol::Text
 } deriving (Show, Eq)
 
+type Schema = Text
 
-data Column = Column {
+data Table = Table {
-  colSchema :: Text
+  tableSchema     :: Schema
-, colTable :: Text
+, tableName       :: Text
-, colName :: Text
+, tableInsertable :: Bool
-, colPosition :: Int
+} deriving (Show, Ord)
-, colNullable :: Bool
+
-, colType :: Text
+data ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord)
-, colUpdatable :: Bool
+
-, colMaxLen :: Maybe Int
+data Column =
-, colPrecision :: Maybe Int
+    Column {
-, colDefault :: Maybe Text
+      colTable     :: Table
-, colEnum :: [Text]
+    , colName      :: Text
-, colFK :: Maybe ForeignKey
+    , colPosition  :: Int
-} | Star {colSchema :: Text, colTable :: Text } deriving (Show)
+    , colNullable  :: Bool
+    , colType      :: Text
+    , colUpdatable :: Bool
+    , colMaxLen    :: Maybe Int
+    , colPrecision :: Maybe Int
+    , colDefault   :: Maybe Text
+    , colEnum      :: [Text]
+    , colFK        :: Maybe ForeignKey
+    }
+  | Star { colTable :: Table }
+  deriving (Show, Ord)
+
+type Synonym = (Column,Column)
 
 data PrimaryKey = PrimaryKey {
-  pkSchema::Text, pkTable::Text, pkName::Text
+    pkTable :: Table
-}
+  , pkName  :: Text
+} deriving (Show, Eq)
 
 data OrderTerm = OrderTerm {
-  otTerm :: Text
+  otTerm      :: Text
 , otDirection :: BS.ByteString
 , otNullOrder :: Maybe BS.ByteString
 } deriving (Show, Eq)
 
 data QualifiedIdentifier = QualifiedIdentifier {
-  qiSchema :: Text
+  qiSchema :: Schema
 , qiName   :: Text
 } deriving (Show, Eq)
 
 
 data RelationType = Child | Parent | Many deriving (Show, Eq)
 data Relation = Relation {
-  relSchema  :: Text
+  relTable    :: Table
-, relTable   :: Text
+, relColumns  :: [Column]
-, relColumns  :: [Text]
+, relFTable   :: Table
-, relFTable  :: Text
+, relFColumns :: [Column]
-, relFColumns :: [Text]
+, relType     :: RelationType
-, relType    :: RelationType
+, relLTable   :: Maybe Table
-, relLTable  :: Maybe Text
+, relLCols1   :: Maybe [Column]
-, relLCols1   :: Maybe [Text]
+, relLCols2   :: Maybe [Column]
-, relLCols2   :: Maybe [Text]
 } deriving (Show, Eq)
 
 
@@ -75,23 +77,21 @@ type FieldName = Text
 type JsonPath = [Text]
 type Field = (FieldName, Maybe JsonPath)
 type Cast = Text
+type NodeName = Text
 type SelectItem = (Field, Maybe Cast)
 type Path = [Text]
-data Query = Select {
+data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] }
-  mainTable::Text
+           | Insert { into::Text, fields::[Field], values::[[Value]] }
-, fields::[SelectItem]
+           | Delete { from::[Text], where_::[Filter] }
-, joinTables::[Text]
+           | Update { into::Text, set::Map Field Value, where_::[Filter] } deriving (Show, Eq)
-, filters::[Filter]
-, order::Maybe [OrderTerm]
-, relation::Maybe Relation
-} deriving (Show, Eq)
 data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
-type ApiRequest = Tree Query
+type ApiNode = (Query, (NodeName, Maybe Relation))
+type ApiRequest = Tree ApiNode
 
 
 instance ToJSON Column where
   toJSON c = object [
-      "schema"    .= colSchema c
+      "schema"    .= tableSchema t
     , "name"      .= colName c
     , "position"  .= colPosition c
     , "nullable"  .= colNullable c
@@ -102,12 +102,27 @@ instance ToJSON Column where
     , "references".= colFK c
     , "default"   .= colDefault c
     , "enum"      .= colEnum c ]
+    where
+      t = colTable c
 
 instance ToJSON ForeignKey where
-  toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
+  toJSON fk = object [
+      "schema" .= tableSchema t
+    , "table"  .= tableName t
+    , "column" .= colName c ]
+    where
+      c = fkCol fk
+      t = colTable c
 
 instance ToJSON Table where
   toJSON v = object [
       "schema"     .= tableSchema v
     , "name"       .= tableName v
     , "insertable" .= tableInsertable v ]
+
+instance Eq Table where
+  Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
+
+instance Eq Column where
+  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
+  _ == _ = False

stack.yaml

@@ -4,4 +4,4 @@ packages:
 extra-deps:
   - Ranged-sets-0.3.0
   - packdeps-0.4.1
-resolver: lts-3.10
+resolver: nightly-2015-10-27

test/Feature/AuthSpec.hs

@@ -18,55 +18,53 @@ spec = beforeAll
   it "hides tables that anonymous does not own" $
     get "/authors_only" `shouldRespondWith` 404
 
-  it "indicates login failure (BasicAuth)" $ do
+  it "returns jwt functions as jwt tokens" $
-    let auth = authHeaderBasic "postgrest_test_author" "fakefake"
+    post "/rpc/login" [json| { "id": "jdoe", "pass": "1234" } |]
-    request methodGet "/authors_only" [auth] ""
-      `shouldRespondWith` 401
-
-  it "allows users with permissions to see their tables (BasicAuth)" $ do
-    _ <- post "/postgrest/users" [json| { "id": "jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    let auth = authHeaderBasic "jdoe" "1234"
-    request methodGet "/authors_only" [auth] ""
-      `shouldRespondWith` 200
-
-  it "respects database constraints for role" $
-    post "/postgrest/users" [json| { "id": "ssmith", "pass": "1234", "role": "SUPER_ADMIN_TRUNCATE_POWERS" } |]
-      `shouldRespondWith` 400
-
-  it "does not send a value when no role is provided" $ do
-    post "/postgrest/users" [json| { "id": "bdeey", "pass": "1234" } |]
-      `shouldRespondWith` 201
-    let auth = authHeaderBasic "jdoe" "1234"
-    request methodGet "/authors_only" [auth] ""
-      `shouldRespondWith` 200
-
-  it "recovers after 400 error with logged in user" $ do
-    _ <- post "/postgrest/users" [json| { "id": "jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    let auth = authHeaderBasic "jdoe" "1234"
-    _ <- request methodPost "/rpc/problem" [auth] ""
-    request methodGet "/authors_only" [auth] ""
-      `shouldRespondWith` 200
-
-  it "allows users to login (JWT)" $ do
-    _ <- post "/postgrest/users" [json| { "id": "jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    post "/postgrest/tokens" [json| { "id": "jdoe", "pass": "1234" } |]
       `shouldRespondWith` ResponseMatcher {
           matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |]
-        , matchStatus = 201
+        , matchStatus = 200
         , matchHeaders = ["Content-Type" <:> "application/json"]
         }
 
-  it "indicates login failure (JWT)" $ do
+  it "allows users with permissions to see their tables" $ do
-    _ <- post "/postgrest/users" [json| { "id": "jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-    post "/postgrest/tokens" [json| { "id": "jdoe", "pass": "NOPE" } |]
-      `shouldRespondWith` ResponseMatcher {
-          matchBody = Just [json| {"message":"Failed authentication."} |]
-        , matchStatus = 401
-        , matchHeaders = ["Content-Type" <:> "application/json"]
-        }
-
-  it "allows users with permissions to see their tables (JWT)" $ do
-    _ <- post "/postgrest/users" [json| { "id": "jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
     request methodGet "/authors_only" [auth] ""
       `shouldRespondWith` 200
+
+  it "works with tokens which have extra fields" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIiwia2V5MSI6InZhbHVlMSIsImtleTIiOiJ2YWx1ZTIiLCJrZXkzIjoidmFsdWUzIiwiYSI6MSwiYiI6MiwiYyI6M30.GfydCh-F4wnM379xs0n1zUgalwJIsb6YoBapCo8HlFk"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200
+
+  -- this test will stop working 9999999999s after the UNIX EPOCH
+  it "succeeds with an unexpired token" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.QaPPLWTuyydMu_q7H4noMT7Lk6P4muet1OpJXF6ofhc"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200
+
+  it "fails with an expired token" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjE0NDY2NzgxNDksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.enk_qZ_u6gZsXY4R8bREKB_HNExRpM0lIWSLktk9JJQ"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 400
+
+  it "hides tables from users with invalid JWT" $ do
+    let auth = authHeaderJWT "ey9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 400
+
+  it "should fail when jwt contains no claims" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.MKYc_lOECtB0LJOiykilAdlHodB-I0_id2qHKq35dmc"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 400
+
+  it "hides tables from users with JWT that contain no claims about role" $ do
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.zyohGMnrDy4_8eJTl6I2AUXO3MeCCiwR24aGWRkTE9o"
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 400
+
+  it "recovers after 400 error with logged in user" $ do
+    _ <- post "/authors_only" [json| { "owner": "jdoe", "secret": "test content" } |]
+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
+    _ <- request methodPost "/rpc/problem" [auth] ""
+    request methodGet "/authors_only" [auth] ""
+      `shouldRespondWith` 200

test/Feature/CorsSpec.hs

@@ -41,7 +41,7 @@ spec = around withApp $ describe "CORS" $ do
             "true"
           respHeaders `shouldSatisfy` matchHeader
             "Access-Control-Allow-Methods"
-            "GET, POST, PUT, PATCH, DELETE, OPTIONS, HEAD"
+            "GET, POST, PATCH, DELETE, OPTIONS, HEAD"
           respHeaders `shouldSatisfy` matchHeader
             "Access-Control-Allow-Headers"
             "Authentication, Foo, Bar, Accept, Accept-Language, Content-Language"

test/Feature/InsertSpec.hs

@@ -1,6 +1,6 @@
 module Feature.InsertSpec where
 
-import Test.Hspec
+import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus))
@@ -19,16 +19,38 @@ import TestTypes(IncPK(..), CompoundPK(..))
 spec :: Spec
 spec = afterAll_ resetDb $ around withApp $ do
   describe "Posting new record" $ do
-    after_ (clearTable "menagerie") . it "accepts disparate json types" $ do
+    after_ (clearTable "menagerie") . context "disparate csv types" $ do
-      p <- post "/menagerie"
+      it "accepts disparate json types" $ do
-        [json| {
+        p <- post "/menagerie"
-          "integer": 13, "double": 3.14159, "varchar": "testing!"
+          [json| {
-        , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+            "integer": 13, "double": 3.14159, "varchar": "testing!"
-        , "enum": "foo"
+          , "boolean": false, "date": "1900-01-01", "money": "$3.99"
-        } |]
+          , "enum": "foo"
-      liftIO $ do
+          } |]
-        simpleBody p `shouldBe` ""
+        liftIO $ do
-        simpleStatus p `shouldBe` created201
+          simpleBody p `shouldBe` ""
+          simpleStatus p `shouldBe` created201
+
+      it "filters columns in result using &select" $
+        request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]
+          [json| {
+            "integer": 14, "double": 3.14159, "varchar": "testing!"
+          , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+          , "enum": "foo"
+          } |] `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|{"integer":14,"varchar":"testing!"}|]
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "application/json"]
+          }
+
+      it "includes related data after insert" $
+        request methodPost "/projects?select=id,name,clients(id,name)" [("Prefer", "return=representation")]
+          [str|{"id":5,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|{"id":5,"name":"New Project","clients":{"id":2,"name":"Apple"}}|]
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "application/json", "Location" <:> "/projects?id=eq.5"]
+          }
+
 
     context "with no pk supplied" $ do
       context "into a table with auto-incrementing pk" . after_ (clearTable "auto_incrementing_pk") $
@@ -92,55 +114,99 @@ spec = afterAll_ resetDb $ around withApp $ do
     context "jsonb" . after_ (clearTable "json") $ do
       it "serializes nested object" $ do
         let inserted = [json| { "data": { "foo":"bar" } } |]
-        p <- request methodPost "json" [("Prefer", "return=representation")] inserted
+        request methodPost "/json"
-        liftIO $ do
+                     [("Prefer", "return=representation")]
-          simpleBody p `shouldBe` inserted
+                     inserted
-          simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%7B%22foo%22%3A%22bar%22%7D"
+          `shouldRespondWith` ResponseMatcher {
-          simpleStatus p `shouldBe` created201
+            matchBody    = Just inserted
+          , matchStatus  = 201
+          , matchHeaders = ["Location" <:> [str|/json?data=eq.{"foo":"bar"}|]]
+          }
+
+        -- TODO! the test above seems right, why was the one below working before and not now
+        -- p <- request methodPost "/json" [("Prefer", "return=representation")] inserted
+        -- liftIO $ do
+        --   simpleBody p `shouldBe` inserted
+        --   simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%7B%22foo%22%3A%22bar%22%7D"
+        --   simpleStatus p `shouldBe` created201
+
       it "serializes nested array" $ do
         let inserted = [json| { "data": [1,2,3] } |]
-        p <- request methodPost "json" [("Prefer", "return=representation")] inserted
+        request methodPost "/json"
-        liftIO $ do
+                     [("Prefer", "return=representation")]
-          simpleBody p `shouldBe` inserted
+                     inserted
-          simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%5B1%2C2%2C3%5D"
+          `shouldRespondWith` ResponseMatcher {
-          simpleStatus p `shouldBe` created201
+            matchBody    = Just inserted
+          , matchStatus  = 201
+          , matchHeaders = ["Location" <:> [str|/json?data=eq.[1,2,3]|]]
+          }
+        -- TODO! the test above seems right, why was the one below working before and not now
+        -- p <- request methodPost "/json" [("Prefer", "return=representation")] inserted
+        -- liftIO $ do
+        --   simpleBody p `shouldBe` inserted
+        --   simpleHeaders p `shouldSatisfy` matchHeader hLocation "/json\\?data=eq\\.%5B1%2C2%2C3%5D"
+        --   simpleStatus p `shouldBe` created201
 
   describe "CSV insert" $ do
 
     after_ (clearTable "menagerie") . context "disparate csv types" $
       it "succeeds with multipart response" $ do
-        p <- request methodPost "/menagerie" [("Content-Type", "text/csv")]
+        pendingWith "Decide on what to do with CSV insert"
-               [str|integer,double,varchar,boolean,date,money,enum
+        let inserted = [str|integer,double,varchar,boolean,date,money,enum
-                   |13,3.14159,testing!,false,1900-01-01,$3.99,foo
+            |13,3.14159,testing!,false,1900-01-01,$3.99,foo
-                   |12,0.1,a string,true,1929-10-01,12,bar
+            |12,0.1,a string,true,1929-10-01,12,bar
-                   |]
+            |]
-        liftIO $ do
+        request methodPost "/menagerie" [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")] inserted
-          simpleBody p `shouldBe` "Content-Type: application/json\nLocation: /menagerie?integer=eq.13\n\n\n--postgrest_boundary\nContent-Type: application/json\nLocation: /menagerie?integer=eq.12\n\n"
+
-          simpleStatus p `shouldBe` created201
+           `shouldRespondWith` ResponseMatcher {
+             matchBody    = Just inserted
+           , matchStatus  = 201
+           , matchHeaders = ["Content-Type" <:> "text/csv"]
+           }
+        -- p <- request methodPost "/menagerie" [("Content-Type", "text/csv")]
+        --        [str|integer,double,varchar,boolean,date,money,enum
+        --            |13,3.14159,testing!,false,1900-01-01,$3.99,foo
+        --            |12,0.1,a string,true,1929-10-01,12,bar
+        --            |]
+        -- liftIO $ do
+        --   simpleBody p `shouldBe` "Content-Type: application/json\nLocation: /menagerie?integer=eq.13\n\n\n--postgrest_boundary\nContent-Type: application/json\nLocation: /menagerie?integer=eq.12\n\n"
+        --   simpleStatus p `shouldBe` created201
 
     after_ (clearTable "no_pk") . context "requesting full representation" $ do
       it "returns full details of inserted record" $
         request methodPost "/no_pk"
-                     [("Content-Type", "text/csv"), ("Prefer", "return=representation")]
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"),  ("Prefer", "return=representation")]
                      "a,b\nbar,baz"
           `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [json| { "a":"bar", "b":"baz" } |]
+            matchBody    = Just "a,b\nbar,baz"
           , matchStatus  = 201
-          , matchHeaders = ["Content-Type" <:> "application/json",
+          , matchHeaders = ["Content-Type" <:> "text/csv",
                             "Location" <:> "/no_pk?a=eq.bar&b=eq.baz"]
           }
 
+      -- it "can post nulls (old way)" $ do
+      --   pendingWith "changed the response when in csv mode"
+      --   request methodPost "/no_pk"
+      --                [("Content-Type", "text/csv"), ("Prefer", "return=representation")]
+      --                "a,b\nNULL,foo"
+      --     `shouldRespondWith` ResponseMatcher {
+      --       matchBody    = Just [json| { "a":null, "b":"foo" } |]
+      --     , matchStatus  = 201
+      --     , matchHeaders = ["Content-Type" <:> "application/json",
+      --                       "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
+      --     }
       it "can post nulls" $
         request methodPost "/no_pk"
-                     [("Content-Type", "text/csv"), ("Prefer", "return=representation")]
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
                      "a,b\nNULL,foo"
           `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [json| { "a":null, "b":"foo" } |]
+            matchBody    = Just "a,b\n,foo"
           , matchStatus  = 201
-          , matchHeaders = ["Content-Type" <:> "application/json",
+          , matchHeaders = ["Content-Type" <:> "text/csv",
                             "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
           }
 
+
     after_ (clearTable "no_pk") . context "with wrong number of columns" $ do
       it "fails for too few" $ do
         p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
@@ -159,7 +225,8 @@ spec = afterAll_ resetDb $ around withApp $ do
 
     context "to a known uri" $ do
       context "without a fully-specified primary key" $
-        it "is not an allowed operation" $
+        it "is not an allowed operation" $ do
+          pendingWith "Decide on PUT usefullness"
           request methodPut "/compound_pk?k1=eq.12" []
             [json| { "k1":12, "k2":42 } |]
               `shouldRespondWith` 405
@@ -167,13 +234,15 @@ spec = afterAll_ resetDb $ around withApp $ do
       context "with a fully-specified primary key" $ do
 
         context "not specifying every column in the table" $
-          it "is rejected for lack of idempotence" $
+          it "is rejected for lack of idempotence" $ do
+            pendingWith "Decide on PUT usefullness"
             request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
               [json| { "k1":12, "k2":42 } |]
                 `shouldRespondWith` 400
 
         context "specifying every column in the table" . after_ (clearTable "compound_pk") $ do
           it "can create a new record" $ do
+            pendingWith "Decide on PUT usefullness"
             p <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
                  [json| { "k1":12, "k2":42, "extra":3 } |]
             liftIO $ do
@@ -190,6 +259,7 @@ spec = afterAll_ resetDb $ around withApp $ do
               compoundExtra record `shouldBe` Just 3
 
           it "can update an existing record" $ do
+            pendingWith "Decide on PUT usefullness"
             _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
                  [json| { "k1":12, "k2":42, "extra":4 } |]
             _ <- request methodPut "/compound_pk?k1=eq.12&k2=eq.42" []
@@ -204,7 +274,8 @@ spec = afterAll_ resetDb $ around withApp $ do
 
       context "with an auto-incrementing primary key" . after_ (clearTable "auto_incrementing_pk") $
 
-        it "succeeds with 204" $
+        it "succeeds with 204" $ do
+          pendingWith "Decide on PUT usefullness"
           request methodPut "/auto_incrementing_pk?id=eq.1" []
                [json| {
                  "id":1,
@@ -284,14 +355,15 @@ spec = afterAll_ resetDb $ around withApp $ do
 
   describe "Row level permission" $
     it "set user_id when inserting rows" $ do
+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
       _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
       _ <- post "/postgrest/users" [json| { "id":"jroe", "pass": "1234", "role": "postgrest_test_author" } |]
 
       p1 <- request methodPost "/authors_only"
-        [ authHeaderBasic "jdoe" "1234", ("Prefer", "return=representation") ]
+        [ auth, ("Prefer", "return=representation") ]
         [json| { "secret": "nyancat" } |]
       liftIO $ do
-          simpleBody p1 `shouldBe` [json| { "owner":"jdoe", "secret":"nyancat" } |]
+          simpleBody p1 `shouldBe` [str|{"owner":"jdoe","secret":"nyancat"}|]
           simpleStatus p1 `shouldBe` created201
 
       p2 <- request methodPost "/authors_only"
@@ -299,5 +371,5 @@ spec = afterAll_ resetDb $ around withApp $ do
         [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.YuF_VfmyIxWyuceT7crnNKEprIYXsJAyXid3rjPjIow", ("Prefer", "return=representation") ]
         [json| { "secret": "lolcat", "owner": "hacker" } |]
       liftIO $ do
-          simpleBody p2 `shouldBe` [json| { "owner":"jroe", "secret":"lolcat" } |]
+          simpleBody p2 `shouldBe` [str|{"owner":"jroe","secret":"lolcat"}|]
           simpleStatus p2 `shouldBe` created201

test/Feature/QuerySpec.hs

@@ -7,10 +7,13 @@ import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleHeaders))
 
 import SpecHelper
+import Text.Heredoc
+
 
 spec :: Spec
 spec =
   beforeAll (clearTable "items" >> createItems 15)
+   . beforeAll clearProjectsTable
    . beforeAll (clearTable "complex_items" >> createComplexItems)
    . beforeAll (clearTable "nullable_integer" >> createNullInteger)
    . beforeAll (
@@ -134,11 +137,20 @@ spec =
       get "/clients?select=id,projects(id,tasks(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith`
         "[{\"id\":1,\"projects\":[{\"id\":1,\"tasks\":[{\"id\":1,\"name\":\"Design w7\"}]},{\"id\":2,\"tasks\":[{\"id\":3,\"name\":\"Design w10\"}]}]},{\"id\":2,\"projects\":[{\"id\":3,\"tasks\":[{\"id\":5,\"name\":\"Design IOS\"}]},{\"id\":4,\"tasks\":[{\"id\":7,\"name\":\"Design OSX\"}]}]}]"
 
+    it "matches with @> operator" $
+      get "/complex_items?select=id&arr_data=@>.{2}" `shouldRespondWith`
+        [str|[{"id":2},{"id":3}]|]
+
+    it "matches with <@ operator" $
+      get "/complex_items?select=id&arr_data=<@.{1,2,4}" `shouldRespondWith`
+        [str|[{"id":1},{"id":2}]|]
+
+
   describe "Shaping response with select parameter" $ do
 
     it "selectStar works in absense of parameter" $
       get "/complex_items?id=eq.3" `shouldRespondWith`
-        "[{\"id\":3,\"name\":\"Three\",\"settings\":{\"foo\":{\"int\":1,\"bar\":\"baz\"}}}]"
+        [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3]}]|]
 
     it "one simple column" $
       get "/complex_items?select=id" `shouldRespondWith`
@@ -272,7 +284,7 @@ spec =
       request methodGet "/simple_pk"
               (acceptHdrs "text/csv; version=1") ""
         `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just "k,extra\rxyyx,u\rxYYx,v"
+          matchBody    = Just "k,extra\nxyyx,u\nxYYx,v"
         , matchStatus  = 200
         , matchHeaders = ["Content-Type" <:> "text/csv"]
         }

test/Feature/StructureSpec.hs

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

test/SpecHelper.hs

@@ -30,25 +30,23 @@ import PostgREST.App (app)
 import PostgREST.Config (AppConfig(..))
 import PostgREST.Middleware
 import PostgREST.Error(errResponse)
-import PostgREST.PgStructure
+import PostgREST.DbStructure
-import PostgREST.Types
+
+dbString :: String
+dbString = "postgres://postgrest_test@localhost:5432/postgrest_test"
 
 isLeft :: Either a b -> Bool
 isLeft (Left _ ) = True
 isLeft _ = False
 
 cfg :: AppConfig
-cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1" "safe"
+cfg = AppConfig dbString 3000 "postgrest_anonymous" "test" "safe" 10
 
 testPoolOpts :: PoolSettings
 testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
 
 pgSettings :: P.Settings
-pgSettings = P.ParamSettings (cs $ configDbHost cfg)
+pgSettings = P.StringSettings $ cs dbString
-                             (fromIntegral $ configDbPort cfg)
-                             (cs $ configDbUser cfg)
-                             (cs $ configDbPass cfg)
-                             (cs $ configDbName cfg)
 
 withApp :: ActionWith Application -> IO ()
 withApp perform = do
@@ -56,30 +54,16 @@ withApp perform = do
     <- H.acquirePool pgSettings testPoolOpts
 
   let txSettings = Just (H.ReadCommitted, Just True)
-  metadata <- H.session pool $ H.tx txSettings $ do
+  dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema cfg)
-    tabs <- allTables
+  db <- either (fail . show) return dbOrError
-    rels <- allRelations
-    cols <- allColumns rels
-    keys <- allPrimaryKeys
-    return (tabs, rels, cols, keys)
-
-  dbstructure <- case metadata of
-    Left e -> fail $ show e
-    Right (tabs, rels, cols, keys) ->
-      return $ DbStructure {
-          tables=tabs
-        , columns=cols
-        , relations=rels
-        , primaryKeys=keys
-        }
 
   perform $ middle $ \req resp -> do
     body <- strictRequestBody req
     result <- liftIO $ H.session pool $ H.tx txSettings
-      $ authenticated cfg (app dbstructure cfg body) req
+      $ runWithClaims cfg (app db cfg body) req
     either (resp . errResponse) resp result
 
-  where middle = defaultMiddle False
+  where middle = defaultMiddle
 
 
 resetDb :: IO ()
@@ -88,7 +72,7 @@ resetDb = do
     <- H.acquirePool pgSettings testPoolOpts
   void . liftIO $ H.session pool $
     H.tx Nothing $ do
-      H.unitEx [H.stmt| drop schema if exists "1" cascade |]
+      H.unitEx [H.stmt| drop schema if exists test cascade |]
       H.unitEx [H.stmt| drop schema if exists private cascade |]
       H.unitEx [H.stmt| drop schema if exists postgrest cascade |]
 
@@ -129,7 +113,14 @@ clearTable :: Text -> IO ()
 clearTable table = do
   pool <- testPool
   void . liftIO $ H.session pool $ H.tx Nothing $
-    H.unitEx $ B.Stmt ("delete from \"1\"."<>table) V.empty True
+    H.unitEx $ B.Stmt ("delete from test."<>table) V.empty True
+
+clearProjectsTable :: IO ()
+clearProjectsTable = do
+  pool <- testPool
+  void . liftIO $ H.session pool $ H.tx Nothing $
+    H.unitEx $ B.Stmt "delete from test.projects where id > 4" V.empty True
+
 
 createItems :: Int -> IO ()
 createItems n = do
@@ -137,7 +128,7 @@ createItems n = do
   void . liftIO $ H.session pool $ H.tx Nothing txn
   where
     txn = mapM_ H.unitEx stmts
-    stmts = map [H.stmt|insert into "1".items (id) values (?)|] [1..n]
+    stmts = map [H.stmt|insert into test.items (id) values (?)|] [1..n]
 
 createComplexItems :: IO ()
 createComplexItems = do
@@ -145,11 +136,12 @@ createComplexItems = do
   void . liftIO $ H.session pool $ H.tx Nothing txn
   where
     txn = mapM_ H.unitEx stmts
-    stmts = getZipList $ [H.stmt|insert into "1".complex_items (id, name, settings) values (?,?,?)|]
+    stmts = getZipList $ [H.stmt|insert into test.complex_items (id, name, settings, arr_data) values (?,?,?,?)|]
         <$> ZipList ([1..3]::[Int])
         <*> ZipList (["One", "Two", "Three"]::[Text])
-        <*> ZipList ([jobj,jobj,jobj])
+        <*> ZipList [jobj,jobj,jobj]
-    jobj = (J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])])
+        <*> ZipList ([[1], [1,2], [1,2,3]]::[[Int]])
+    jobj = J.object [("foo", J.object [("int", J.Number 1),("bar", J.String "baz")])]
 
 createNulls :: Int -> IO ()
 createNulls n = do
@@ -157,14 +149,14 @@ createNulls n = do
   void . liftIO $ H.session pool $ H.tx Nothing txn
   where
     txn = mapM_ H.unitEx (stmt':stmts)
-    stmt' = [H.stmt|insert into "1".no_pk (a,b) values (null,null)|]
+    stmt' = [H.stmt|insert into test.no_pk (a,b) values (null,null)|]
-    stmts = map [H.stmt|insert into "1".no_pk (a,b) values (?,0)|] [1..n]
+    stmts = map [H.stmt|insert into test.no_pk (a,b) values (?,0)|] [1..n]
 
 createNullInteger :: IO ()
 createNullInteger = do
   pool <- testPool
   void . liftIO $ H.session pool $ H.tx Nothing $
-    H.unitEx $ [H.stmt| insert into "1".nullable_integer (a) values (null) |]
+    H.unitEx $ [H.stmt| insert into "test".nullable_integer (a) values (null) |]
 
 createLikableStrings :: IO ()
 createLikableStrings = do
@@ -174,7 +166,7 @@ createLikableStrings = do
     H.unitEx $ insertSimplePk "xYYx" "v"
   where
     insertSimplePk :: Text -> Text -> H.Stmt P.Postgres
-    insertSimplePk = [H.stmt|insert into "1".simple_pk (k, extra) values (?,?)|]
+    insertSimplePk = [H.stmt|insert into test.simple_pk (k, extra) values (?,?)|]
 
 createJsonData :: IO ()
 createJsonData = do
@@ -182,7 +174,7 @@ createJsonData = do
   void . liftIO $ H.session pool $ H.tx Nothing $
     H.unitEx $
       [H.stmt|
-        insert into "1".json (data) values (?)
+        insert into test.json (data) values (?)
       |]
       (J.object [("id", J.Number 1)
                 ,("foo", J.object [("bar", J.String "baz")])

test/Unit/DbStructureSpec.hx

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

test/Unit/PgQuerySpec.hx

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

test/fixtures/schema.sql

@@ -5,10 +5,10 @@ SET check_function_bodies = false;
 SET client_min_messages = warning;
 
 
-CREATE SCHEMA "1";
+CREATE SCHEMA test;
 
 
-ALTER SCHEMA "1" OWNER TO postgrest_test;
+ALTER SCHEMA test OWNER TO postgrest_test;
 
 
 CREATE SCHEMA postgrest;
@@ -30,7 +30,7 @@ CREATE EXTENSION IF NOT EXISTS plpgsql WITH SCHEMA pg_catalog;
 COMMENT ON EXTENSION plpgsql IS 'PL/pgSQL procedural language';
 
 
-SET search_path = "1", pg_catalog;
+SET search_path = test, pg_catalog;
 
 
 CREATE TYPE enum_menagerie_type AS ENUM (
@@ -39,7 +39,7 @@ CREATE TYPE enum_menagerie_type AS ENUM (
 );
 
 
-ALTER TYPE "1".enum_menagerie_type OWNER TO postgrest_test;
+ALTER TYPE test.enum_menagerie_type OWNER TO postgrest_test;
 
 SET search_path = postgrest, pg_catalog;
 
@@ -76,25 +76,25 @@ CREATE FUNCTION set_authors_only_owner() RETURNS trigger
     LANGUAGE plpgsql
     AS $$
 begin
-  NEW.owner = current_setting('user_vars.user_id');
+  NEW.owner = current_setting('postgrest.claims.id');
   RETURN NEW;
 end
 $$;
 
 ALTER FUNCTION postgrest.set_authors_only_owner() OWNER TO postgrest_test;
 
-CREATE FUNCTION "1".insert_insertable_view_with_join() RETURNS trigger
+CREATE FUNCTION test.insert_insertable_view_with_join() RETURNS trigger
     LANGUAGE plpgsql
     AS $$
 begin
-  INSERT INTO "1".auto_incrementing_pk (nullable_string, non_nullable_string) VALUES (NEW.nullable_string, NEW.non_nullable_string);
+  INSERT INTO test.auto_incrementing_pk (nullable_string, non_nullable_string) VALUES (NEW.nullable_string, NEW.non_nullable_string);
   RETURN NEW;
 end;
 $$;
 
-ALTER FUNCTION "1".insert_insertable_view_with_join() OWNER TO postgrest_test;
+ALTER FUNCTION test.insert_insertable_view_with_join() OWNER TO postgrest_test;
 
-SET search_path = "1", pg_catalog;
+SET search_path = test, pg_catalog;
 
 SET default_tablespace = '';
 
@@ -107,7 +107,7 @@ CREATE TABLE authors_only (
 );
 
 
-ALTER TABLE "1".authors_only OWNER TO postgrest_test_author;
+ALTER TABLE test.authors_only OWNER TO postgrest_test_author;
 
 
 CREATE TABLE auto_incrementing_pk (
@@ -118,7 +118,7 @@ CREATE TABLE auto_incrementing_pk (
 );
 
 
-ALTER TABLE "1".auto_incrementing_pk OWNER TO postgrest_test;
+ALTER TABLE test.auto_incrementing_pk OWNER TO postgrest_test;
 
 
 CREATE SEQUENCE auto_incrementing_pk_id_seq
@@ -129,7 +129,7 @@ CREATE SEQUENCE auto_incrementing_pk_id_seq
     CACHE 1;
 
 
-ALTER TABLE "1".auto_incrementing_pk_id_seq OWNER TO postgrest_test;
+ALTER TABLE test.auto_incrementing_pk_id_seq OWNER TO postgrest_test;
 
 
 ALTER SEQUENCE auto_incrementing_pk_id_seq OWNED BY auto_incrementing_pk.id;
@@ -143,7 +143,7 @@ CREATE TABLE compound_pk (
 );
 
 
-ALTER TABLE "1".compound_pk OWNER TO postgrest_test;
+ALTER TABLE test.compound_pk OWNER TO postgrest_test;
 
 
 CREATE TABLE has_fk (
@@ -153,7 +153,7 @@ CREATE TABLE has_fk (
 );
 
 
-ALTER TABLE "1".has_fk OWNER TO postgrest_test;
+ALTER TABLE test.has_fk OWNER TO postgrest_test;
 
 
 CREATE SEQUENCE has_fk_id_seq
@@ -164,18 +164,18 @@ CREATE SEQUENCE has_fk_id_seq
     CACHE 1;
 
 
-ALTER TABLE "1".has_fk_id_seq OWNER TO postgrest_test;
+ALTER TABLE test.has_fk_id_seq OWNER TO postgrest_test;
 
 
 ALTER SEQUENCE has_fk_id_seq OWNED BY has_fk.id;
 
-CREATE MATERIALIZED VIEW "1".materialized_view AS
+CREATE MATERIALIZED VIEW test.materialized_view AS
  SELECT
     version();
 
-ALTER TABLE "1".materialized_view OWNER TO postgrest_test;
+ALTER TABLE test.materialized_view OWNER TO postgrest_test;
 
-CREATE VIEW "1".insertable_view_with_join AS
+CREATE VIEW test.insertable_view_with_join AS
  SELECT has_fk.id,
     has_fk.auto_inc_fk,
     has_fk.simple_fk,
@@ -186,12 +186,12 @@ CREATE VIEW "1".insertable_view_with_join AS
      JOIN auto_incrementing_pk USING (id));
 
 
-ALTER TABLE "1".insertable_view_with_join OWNER TO postgrest_test;
+ALTER TABLE test.insertable_view_with_join OWNER TO postgrest_test;
 
-CREATE VIEW "1".has_count_column AS
+CREATE VIEW test.has_count_column AS
  SELECT 1 AS count;
 
-ALTER TABLE "1".insertable_view_with_join OWNER TO postgrest_test;
+ALTER TABLE test.insertable_view_with_join OWNER TO postgrest_test;
 
 
 CREATE TABLE items (
@@ -199,50 +199,51 @@ CREATE TABLE items (
 );
 
 
-ALTER TABLE "1".items OWNER TO postgrest_test;
+ALTER TABLE test.items OWNER TO postgrest_test;
 
 CREATE TABLE complex_items (
     id bigint NOT NULL,
     name text,
-    settings json
+    settings json,
+    arr_data INTEGER[]
 );
 
 
-ALTER TABLE "1".complex_items OWNER TO postgrest_test;
+ALTER TABLE test.complex_items OWNER TO postgrest_test;
 
 --- Structure for testing table relations
 CREATE TABLE clients(
     id INT PRIMARY KEY     NOT NULL,
     name           TEXT    NOT NULL
 );
-ALTER TABLE "1".clients OWNER TO postgrest_test;
+ALTER TABLE test.clients OWNER TO postgrest_test;
 
 CREATE TABLE projects(
     id INT PRIMARY KEY     NOT NULL,
     name           TEXT    NOT NULL,
     client_id      INT     REFERENCES clients(id)
 );
-ALTER TABLE "1".projects OWNER TO postgrest_test;
+ALTER TABLE test.projects OWNER TO postgrest_test;
 
 CREATE TABLE tasks(
     id INT PRIMARY KEY     NOT NULL,
     name           TEXT    NOT NULL,
     project_id      INT     REFERENCES projects(id)
 );
-ALTER TABLE "1".tasks OWNER TO postgrest_test;
+ALTER TABLE test.tasks OWNER TO postgrest_test;
 
 CREATE TABLE users(
     id INT PRIMARY KEY     NOT NULL,
     name           TEXT    NOT NULL
 );
-ALTER TABLE "1".users OWNER TO postgrest_test;
+ALTER TABLE test.users OWNER TO postgrest_test;
 
 CREATE TABLE users_tasks(
     user_id      INT     REFERENCES users(id),
     task_id      INT     REFERENCES tasks(id),
     CONSTRAINT task_user PRIMARY KEY (task_id,user_id)
 );
-ALTER TABLE "1".users_tasks OWNER TO postgrest_test;
+ALTER TABLE test.users_tasks OWNER TO postgrest_test;
 
 CREATE TABLE comments(
 id INT PRIMARY KEY   NOT NULL,
@@ -252,31 +253,22 @@ task_id      INT     NOT NULL,
 content      TEXT    NOT NULL,
 FOREIGN KEY (task_id,user_id) REFERENCES users_tasks (task_id,user_id)
 );
-ALTER TABLE "1".comments OWNER TO postgrest_test;
+ALTER TABLE test.comments OWNER TO postgrest_test;
 
 CREATE TABLE users_projects(
     user_id         INT     REFERENCES users(id),
     project_id      INT     REFERENCES projects(id),
     CONSTRAINT project_user PRIMARY KEY (project_id, user_id)
 );
-ALTER TABLE "1".users_projects OWNER TO postgrest_test;
+ALTER TABLE test.users_projects OWNER TO postgrest_test;
 
-CREATE VIEW "1".projects_view AS
+CREATE VIEW test.projects_view AS
   SELECT
       projects.id,
       projects.name,
       projects.client_id
   FROM projects;
-ALTER TABLE "1".projects_view OWNER TO postgrest_test;
+ALTER TABLE test.projects_view OWNER TO postgrest_test;
-------- SAMPLE DATA -----
-INSERT INTO clients VALUES (1, 'Microsoft'),(2, 'Apple');
-INSERT INTO projects VALUES (1,'Windows 7', 1),(2,'Windows 10', 1),(3,'IOS', 2),(4,'OSX', 2);
-INSERT INTO tasks VALUES (1,'Design w7',1),(2,'Code w7',1),(3,'Design w10',2),(4,'Code w10',2),(5,'Design IOS',3),(6,'Code IOS',3),(7,'Design OSX',4),(8,'Code OSX',4);
-INSERT INTO users VALUES (1, 'Angela Martin'),(2, 'Michael Scott'),(3, 'Dwight Schrute');
-INSERT INTO users_projects VALUES(1,1),(1,2),(2,3),(2,4),(3,1),(3,3);
-INSERT INTO users_tasks VALUES(1,1),(1,2),(1,3),(1,4),(2,5),(2,6),(2,7),(3,1),(3,5);
-INSERT INTO comments VALUES (1, 1, 2, 6, 'Needs to be delivered ASAP');
-----------------
 
 CREATE SEQUENCE items_id_seq
     START WITH 1
@@ -286,27 +278,36 @@ CREATE SEQUENCE items_id_seq
     CACHE 1;
 
 
-ALTER TABLE "1".items_id_seq OWNER TO postgrest_test;
+ALTER TABLE test.items_id_seq OWNER TO postgrest_test;
 
 
 ALTER SEQUENCE items_id_seq OWNED BY items.id;
 
 
 
-CREATE FUNCTION "1".getitemrange(min bigint, max bigint) RETURNS SETOF "1".items AS $$
+CREATE FUNCTION test.getitemrange(min bigint, max bigint) RETURNS SETOF test.items AS $$
-    SELECT * FROM "1".items WHERE id > $1 AND id <= $2;
+    SELECT * FROM test.items WHERE id > $1 AND id <= $2;
 $$ LANGUAGE SQL;
 
-CREATE FUNCTION "1".test_empty_rowset() RETURNS SETOF int AS $$
+CREATE FUNCTION test_empty_rowset() RETURNS SETOF int AS $$
     SELECT null::int FROM (SELECT 1) a WHERE false;
 $$ LANGUAGE SQL;
 
-CREATE FUNCTION "1".sayhello(name text) RETURNS text AS $$
+CREATE TYPE public.jwt_claims AS (role text, id text);
+
+CREATE FUNCTION test.login(id text, pass text)
+RETURNS public.jwt_claims
+SECURITY DEFINER
+AS $$
+SELECT rolname::text, id::text FROM postgrest.auth WHERE id = id AND pass = pass;
+$$ LANGUAGE SQL;
+
+CREATE FUNCTION test.sayhello(name text) RETURNS text AS $$
     SELECT 'Hello, ' || $1;
 $$ LANGUAGE SQL;
 
 
-CREATE FUNCTION "1".problem() RETURNS void LANGUAGE plpgsql AS
+CREATE FUNCTION test.problem() RETURNS void LANGUAGE plpgsql AS
 $$
 BEGIN
       RAISE 'bad thing';
@@ -325,7 +326,7 @@ CREATE TABLE menagerie (
 );
 
 
-ALTER TABLE "1".menagerie OWNER TO postgrest_test;
+ALTER TABLE test.menagerie OWNER TO postgrest_test;
 
 
 CREATE TABLE no_pk (
@@ -334,7 +335,7 @@ CREATE TABLE no_pk (
 );
 
 
-ALTER TABLE "1".no_pk OWNER TO postgrest_test;
+ALTER TABLE test.no_pk OWNER TO postgrest_test;
 
 
 CREATE TABLE nullable_integer (
@@ -342,7 +343,7 @@ CREATE TABLE nullable_integer (
 );
 
 
-ALTER TABLE "1".nullable_integer OWNER TO postgrest_test;
+ALTER TABLE test.nullable_integer OWNER TO postgrest_test;
 
 
 CREATE TABLE simple_pk (
@@ -351,7 +352,7 @@ CREATE TABLE simple_pk (
 );
 
 
-ALTER TABLE "1".simple_pk OWNER TO postgrest_test;
+ALTER TABLE test.simple_pk OWNER TO postgrest_test;
 
 
 CREATE TABLE json
@@ -360,14 +361,14 @@ CREATE TABLE json
 );
 
 
-ALTER TABLE "1".json OWNER TO postgrest_test;
+ALTER TABLE test.json OWNER TO postgrest_test;
 
 
 CREATE TABLE tsearch (
     text_search_vector tsvector
 );
 
-ALTER TABLE "1".tsearch OWNER TO postgrest_test;
+ALTER TABLE test.tsearch OWNER TO postgrest_test;
 
 SET search_path = postgrest, pg_catalog;
 
@@ -385,8 +386,8 @@ SET search_path = private, pg_catalog;
 
 
 CREATE TABLE articles (
+    id integer PRIMARY KEY NOT NULL,
     body text,
-    id integer NOT NULL,
     owner name NOT NULL
 );
 
@@ -394,22 +395,32 @@ CREATE TABLE articles (
 ALTER TABLE private.articles OWNER TO postgrest_test;
 
 
-CREATE SEQUENCE articles_id_seq
+CREATE TABLE article_stars (
-    START WITH 1
+  article_id int REFERENCES articles(id),
-    INCREMENT BY 1
+  user_id int REFERENCES test.users(id),
-    NO MINVALUE
+  created_at timestamp NOT NULL DEFAULT now(),
-    NO MAXVALUE
+  CONSTRAINT user_article PRIMARY KEY (article_id, user_id)
-    CACHE 1;
+);
+
+ALTER TABLE private.article_stars OWNER TO postgrest_test;
 
 
-ALTER TABLE private.articles_id_seq OWNER TO postgrest_test;
+
+SET search_path = test, pg_catalog;
 
 
-ALTER SEQUENCE articles_id_seq OWNED BY articles.id;
 
+CREATE VIEW "articleStars" AS
+  SELECT article_id AS "articleId", user_id AS "userId", created_at AS "createdAt"
+  FROM private.article_stars;
 
-SET search_path = "1", pg_catalog;
+ALTER TABLE test."articleStars" OWNER TO postgrest_test;
 
+CREATE VIEW articles AS
+  SELECT *
+  FROM private.articles;
+
+ALTER TABLE test.articles OWNER TO postgrest_test;
 
 ALTER TABLE ONLY auto_incrementing_pk ALTER COLUMN id SET DEFAULT nextval('auto_incrementing_pk_id_seq'::regclass);
 
@@ -417,36 +428,10 @@ ALTER TABLE ONLY auto_incrementing_pk ALTER COLUMN id SET DEFAULT nextval('auto_
 
 ALTER TABLE ONLY has_fk ALTER COLUMN id SET DEFAULT nextval('has_fk_id_seq'::regclass);
 
-
-
 ALTER TABLE ONLY items ALTER COLUMN id SET DEFAULT nextval('items_id_seq'::regclass);
 
-
-SET search_path = private, pg_catalog;
-
-
-ALTER TABLE ONLY articles ALTER COLUMN id SET DEFAULT nextval('articles_id_seq'::regclass);
-
-
-SET search_path = "1", pg_catalog;
-
-
-
-
-
-
-
-
 SELECT pg_catalog.setval('auto_incrementing_pk_id_seq', 1, true);
 
-
-
-
-
-
-
-
-
 SELECT pg_catalog.setval('has_fk_id_seq', 1, false);
 
 
@@ -469,24 +454,20 @@ SET search_path = private, pg_catalog;
 
 
 
+SET search_path = test, pg_catalog;
 
-SELECT pg_catalog.setval('articles_id_seq', 1, false);
+CREATE FUNCTION public.always_true(test.items) RETURNS boolean
-
-
-SET search_path = "1", pg_catalog;
-
-CREATE FUNCTION public.always_true("1".items) RETURNS boolean
     LANGUAGE sql STABLE
     AS $$ SELECT true $$;
 
-ALTER FUNCTION public.always_true("1".items) OWNER TO postgrest_test;
+ALTER FUNCTION public.always_true(test.items) OWNER TO postgrest_test;
 
 
 
 ALTER TABLE ONLY authors_only
     ADD CONSTRAINT authors_only_pkey PRIMARY KEY (secret);
 
-CREATE TRIGGER insert_insertable_view_with_join INSTEAD OF INSERT ON "1".insertable_view_with_join FOR EACH ROW EXECUTE PROCEDURE "1".insert_insertable_view_with_join();
+CREATE TRIGGER insert_insertable_view_with_join INSTEAD OF INSERT ON test.insertable_view_with_join FOR EACH ROW EXECUTE PROCEDURE test.insert_insertable_view_with_join();
 
 
 CREATE TRIGGER secrets_owner_track BEFORE INSERT OR UPDATE ON authors_only FOR EACH ROW EXECUTE PROCEDURE postgrest.set_authors_only_owner();
@@ -533,10 +514,6 @@ ALTER TABLE ONLY auth
 SET search_path = private, pg_catalog;
 
 
-ALTER TABLE ONLY articles
-    ADD CONSTRAINT articles_pkey PRIMARY KEY (id);
-
-
 SET search_path = postgrest, pg_catalog;
 
 
@@ -549,7 +526,7 @@ SET search_path = private, pg_catalog;
 CREATE TRIGGER articles_owner_track BEFORE INSERT OR UPDATE ON articles FOR EACH ROW EXECUTE PROCEDURE postgrest.update_owner();
 
 
-SET search_path = "1", pg_catalog;
+SET search_path = test, pg_catalog;
 
 
 ALTER TABLE ONLY has_fk
@@ -562,11 +539,11 @@ ALTER TABLE ONLY has_fk
 
 
 
-REVOKE ALL ON SCHEMA "1" FROM PUBLIC;
+REVOKE ALL ON SCHEMA test FROM PUBLIC;
-REVOKE ALL ON SCHEMA "1" FROM postgrest_test;
+REVOKE ALL ON SCHEMA test FROM postgrest_test;
-GRANT ALL ON SCHEMA "1" TO postgrest_test;
+GRANT ALL ON SCHEMA test TO postgrest_test;
-GRANT USAGE ON SCHEMA "1" TO postgrest_anonymous;
+GRANT USAGE ON SCHEMA test TO postgrest_anonymous;
-GRANT USAGE ON SCHEMA "1" TO postgrest_test_author;
+GRANT USAGE ON SCHEMA test TO postgrest_test_author;
 
 
 
@@ -657,6 +634,14 @@ REVOKE ALL ON TABLE projects_view FROM PUBLIC;
 REVOKE ALL ON TABLE projects_view FROM postgrest_test;
 GRANT ALL ON TABLE projects_view TO postgrest_test;
 GRANT ALL ON TABLE projects_view TO postgrest_anonymous;
+REVOKE ALL ON TABLE articles FROM PUBLIC;
+REVOKE ALL ON TABLE articles FROM postgrest_test;
+GRANT ALL ON TABLE  articles TO postgrest_test;
+GRANT ALL ON TABLE  articles TO postgrest_anonymous;
+REVOKE ALL ON TABLE "articleStars" FROM PUBLIC;
+REVOKE ALL ON TABLE "articleStars" FROM postgrest_test;
+GRANT ALL ON TABLE  "articleStars" TO postgrest_test;
+GRANT ALL ON TABLE  "articleStars" TO postgrest_anonymous;
 ---------
 
 
@@ -670,6 +655,11 @@ REVOKE ALL ON FUNCTION test_empty_rowset() FROM postgrest_test;
 GRANT EXECUTE ON FUNCTION test_empty_rowset() TO postgrest_test;
 GRANT EXECUTE ON FUNCTION test_empty_rowset() TO postgrest_anonymous;
 
+REVOKE ALL ON FUNCTION login(text, text) FROM PUBLIC;
+REVOKE ALL ON FUNCTION login(text, text) FROM postgrest_test;
+GRANT EXECUTE ON FUNCTION login(text, text) TO postgrest_test;
+GRANT EXECUTE ON FUNCTION login(text, text) TO postgrest_anonymous;
+
 REVOKE ALL ON FUNCTION sayhello(text) FROM PUBLIC;
 REVOKE ALL ON FUNCTION sayhello(text) FROM postgrest_test;
 GRANT EXECUTE ON FUNCTION sayhello(text) TO postgrest_test;
@@ -743,10 +733,10 @@ REVOKE ALL ON TABLE has_count_column FROM postgrest_test;
 GRANT ALL ON TABLE has_count_column TO postgrest_test;
 GRANT ALL ON TABLE has_count_column TO postgrest_anonymous;
 
-REVOKE ALL ON FUNCTION public.always_true("1".items) FROM PUBLIC;
+REVOKE ALL ON FUNCTION public.always_true(test.items) FROM PUBLIC;
-REVOKE ALL ON FUNCTION public.always_true("1".items) FROM postgrest_test;
+REVOKE ALL ON FUNCTION public.always_true(test.items) FROM postgrest_test;
-GRANT ALL ON FUNCTION public.always_true("1".items) TO postgrest_test;
+GRANT ALL ON FUNCTION public.always_true(test.items) TO postgrest_test;
-GRANT ALL ON FUNCTION public.always_true("1".items) TO postgrest_anonymous;
+GRANT ALL ON FUNCTION public.always_true(test.items) TO postgrest_anonymous;
 
 
 SET search_path = postgrest, pg_catalog;
@@ -764,3 +754,18 @@ SET search_path = private, pg_catalog;
 REVOKE ALL ON TABLE articles FROM PUBLIC;
 REVOKE ALL ON TABLE articles FROM postgrest_test;
 GRANT ALL ON TABLE articles TO postgrest_test;
+
+SET search_path = test, private, postgrest, public, pg_catalog;
+
+------- SAMPLE DATA -----
+INSERT INTO clients VALUES (1, 'Microsoft'),(2, 'Apple');
+INSERT INTO projects VALUES (1,'Windows 7', 1),(2,'Windows 10', 1),(3,'IOS', 2),(4,'OSX', 2);
+INSERT INTO tasks VALUES (1,'Design w7',1),(2,'Code w7',1),(3,'Design w10',2),(4,'Code w10',2),(5,'Design IOS',3),(6,'Code IOS',3),(7,'Design OSX',4),(8,'Code OSX',4);
+INSERT INTO users VALUES (1, 'Angela Martin'),(2, 'Michael Scott'),(3, 'Dwight Schrute');
+INSERT INTO users_projects VALUES(1,1),(1,2),(2,3),(2,4),(3,1),(3,3);
+INSERT INTO users_tasks VALUES(1,1),(1,2),(1,3),(1,4),(2,5),(2,6),(2,7),(3,1),(3,5);
+INSERT INTO comments VALUES (1, 1, 2, 6, 'Needs to be delivered ASAP');
+INSERT INTO postgrest.auth (id, pass, rolname) VALUES ('jdoe', '1234', 'postgrest_test_author');
+INSERT INTO private.articles (id, body, owner) VALUES (1, 'No… It''s a thing; it''s like a plan, but with more greatness.', 2), (2, 'Stop talking, brain thinking. Hush.', 3), (3, 'It''s a fez. I wear a fez now. Fezes are cool.', 1);
+INSERT INTO private.article_stars (article_id, user_id) VALUES (1,1), (1,2), (2,3), (3,2), (1,3);
+----------------