Patch version bump for conditional -Werror flag

Make postgrest a library

CHANGELOG.md

@@ -3,6 +3,17 @@
 All notable changes to this project will be documented in this file.
 This project adheres to [Semantic Versioning](http://semver.org/).
 
+## [0.2.9.0] - 2015-05-20
+### Added
+- Return range headers in PATCH
+- Return PATCHed resources if header "Prefer: return=representation"
+- Allow nested objects and arrays in JSON post for jsonb columns
+- JSON Web Tokens - [Federico Rampazzo](https://github.com/framp)
+- Expose PostgREST as a Haskell package
+
+### Fixed
+- Return 404 if no records updated by PATCH
+
 ## [0.2.8.0] - 2015-04-17
 ### Added
 - Option to specify nulls first or last, eg `/people?order=age.desc.nullsfirst`

CONTRIBUTING.md

@@ -0,0 +1,50 @@
+# Contributing to PostgREST
+
+**First:** if you're unsure or afraid of _anything_, just ask or
+submit the issue or pull request anyways. You won't be yelled at
+for giving your best effort. The worst that can happen is that
+you'll be politely asked to change something. We appreciate any
+sort of contributions, and don't want a wall of rules to get in the
+way of that.
+
+However, for those individuals who want a bit more guidance on the
+best way to contribute to the project, read on. This document will
+cover what we're looking for. By addressing all the points we're
+looking for, it raises the chances we can quickly merge or address
+your contributions.
+
+## Issues
+
+### Reporting an Issue
+
+* Make sure you test against the latest released version. It is possible
+  we already fixed the bug you're experiencing.
+
+* Also check the `CHANGELOG.md` to see if any unreleased changes affect
+  the issue. The very newest changes can take a little while to be released
+  as a new official version.
+
+* Provide steps to reproduce the issue, including your OS version and
+  the specific database schema that you are using.
+
+## Code
+
+### Haskell Conventions
+
+* All contributions must pass the tests before being merged. When
+  you create a pull request your code will automatically be tested.
+
+* All code must also pass [hlint](http://community.haskell.org/~ndm/hlint/)
+  with no warnings. This helps enforce a uniform style for all
+  committers. Continuous integration will check this as well on every
+  pull request.
+
+## Maintenance
+
+### Schedule
+
+Currently I (@begriffs) am the sole maintainer, and while I am
+overjoyed to help resolve issues I also have to balance this with
+my other obligations.  I check and respond to github issues **once
+per week** (on Mondays). So if you don't get a response right away
+don't worry, I will definitely get to it.

README.md

@@ -20,7 +20,7 @@ your own projects.
 
 ### Usage
 
-Download the binary ([OS X](http://bin.begriffs.com/dbapi/osx/postgrest-0.2.8.0.tar.xz) / [Linux](http://bin.begriffs.com/dbapi/heroku/postgrest-0.2.8.0.tar.xz)) and invoke like so:
+Download the binary ([OS X](http://bin.begriffs.com/dbapi/osx/postgrest-0.2.9.0.tar.xz) / [Linux](http://bin.begriffs.com/dbapi/heroku/postgrest-0.2.9.0.tar.xz)) and invoke like so:
 
 ```bash
 postgrest  --db-host localhost  --db-port 5432     \

app.json

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

circle.yml

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

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.8.0
+version:               0.2.9.1
 synopsis:              REST API for any Postgres database
 license:               MIT
 license-file:          LICENSE
@@ -12,15 +12,23 @@ maintainer:            cred+github@begriffs.com
 category:              Web
 build-type:            Simple
 cabal-version:         >=1.10
+source-repository head
+  type: git
+  location: git://github.com/begriffs/postgrest.git
+
+Flag CI
+  Description: No warnings allowed in continuous integration
+  Manual:      True
+  Default:     False
 
 executable postgrest
-  main-is:             Main.hs
+  main-is:             PostgREST/Main.hs
-  ghc-options:         -Wall -W -O2
-  default-language:    Haskell2010
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
+  default-language:    Haskell2010
   build-depends:       base >=4.6 && <5
-                     , hasql == 0.7.3, hasql-backend == 0.4.1
+                     , postgrest
-                     , hasql-postgres == 0.10.3
+                     , hasql == 0.7.3.1, hasql-backend == 0.4.1
+                     , hasql-postgres == 0.10.3.1
                      , warp >= 3.0.2, wai >= 3.0.1
                      , wai-extra, wai-cors
                      , wai-middleware-static >= 0.6.0
@@ -43,15 +51,51 @@ executable postgrest
                      , vector
                      , mtl
                      , cassava
-  Other-Modules:       App
+                     , jwt
-                     , Auth
+  hs-source-dirs:      src
-                     , Config
+
-                     , Error
+library
-                     , Middleware
+  if flag(ci)
-                     , PgQuery
+    ghc-options:       -Wall -W -Werror
-                     , PgStructure
+  else
-                     , RangeQuery
+    ghc-options:       -Wall -W -O2
-                     , Types
+
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
+  build-depends:       base >=4.6 && <5
+                     , hasql == 0.7.3.1, hasql-backend == 0.4.1
+                     , hasql-postgres == 0.10.3.1
+                     , warp >= 3.0.2, wai >= 3.0.1
+                     , wai-extra, wai-cors
+                     , wai-middleware-static >= 0.6.0
+                     , HTTP, convertible, http-types
+                     , case-insensitive
+                     , scientific, time
+                     , aeson, network >= 2.6
+                     , bytestring, text, split, string-conversions
+                     , stringsearch
+                     , containers, unordered-containers
+                     , optparse-applicative == 0.11.*
+                     , regex-base, regex-tdfa
+                     , regex-tdfa-text
+                     , Ranged-sets
+                     , transformers, MissingH
+                     , bcrypt >= 0.0.6, base64-string
+                     , network-uri >= 2.6
+                     , resource-pool
+                     , blaze-builder
+                     , vector
+                     , mtl
+                     , cassava
+                     , jwt
+  Exposed-Modules:     PostgREST.App
+                     , PostgREST.Auth
+                     , PostgREST.Config
+                     , PostgREST.Error
+                     , PostgREST.Middleware
+                     , PostgREST.PgQuery
+                     , PostgREST.PgStructure
+                     , PostgREST.RangeQuery
   hs-source-dirs:      src
 
 Test-Suite spec
@@ -59,23 +103,25 @@ Test-Suite spec
   Default-Language:    Haskell2010
   default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes
   Hs-Source-Dirs:      test, src
-  ghc-options:         -Wall -W -Werror
+  if flag(ci)
+    ghc-options:       -Wall -W -Werror
+  else
+    ghc-options:       -Wall -W -O2
   Main-Is:             Main.hs
-  Other-Modules:       App
+  Other-Modules:       PostgREST.App
-                     , Auth
+                     , PostgREST.Auth
-                     , Config
+                     , PostgREST.Config
-                     , Error
+                     , PostgREST.Error
-                     , Middleware
+                     , PostgREST.Middleware
-                     , PgQuery
+                     , PostgREST.PgQuery
-                     , PgStructure
+                     , PostgREST.PgStructure
-                     , RangeQuery
+                     , PostgREST.RangeQuery
-                     , Types
                      , Spec
                      , SpecHelper
   Build-Depends:       base, hspec >= 2.1.2, QuickCheck
                      , hspec-wai >= 0.5.0, hspec-wai-json
-                     , hasql == 0.7.3, hasql-backend == 0.4.1
+                     , hasql == 0.7.3.1, hasql-backend == 0.4.1
-                     , hasql-postgres == 0.10.3
+                     , hasql-postgres == 0.10.3.1
                      , warp, wai
                      , packdeps, hlint
                      , HTTP, convertible
@@ -102,3 +148,4 @@ Test-Suite spec
                      , cassava
                      , process
                      , heredoc
+                     , jwt

src/PostgREST/App.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
-module App (app, sqlError, isSqlError) where
+module PostgREST.App (app, sqlError, isSqlError) where
 
 import Control.Monad (join)
 import Control.Arrow ((***), second)
@@ -34,13 +34,16 @@ import qualified Hasql as H
 import qualified Hasql.Backend as B
 import qualified Hasql.Postgres as P
 
-import Auth
+import PostgREST.Config (AppConfig(..))
-import PgQuery
+import PostgREST.Auth
-import RangeQuery
+import PostgREST.PgQuery
-import PgStructure
+import PostgREST.RangeQuery
+import PostgREST.PgStructure
 
-app :: Text -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
+import Prelude
-app v1schema reqBody req =
+
+app :: AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
+app conf reqBody req =
   case (path, verb) of
     ([], _) -> do
       body <- encode <$> tables (cs schema)
@@ -102,6 +105,27 @@ app v1schema reqBody req =
             , (hLocation, "/postgrest/users?id=eq." <> cs (userId u))
             ] ""
 
+    (["postgrest", "tokens"], "POST") ->
+      case jwtSecret of
+        "secret" -> return $ responseLBS status500 [jsonH] $
+          encode . object $ [("message", String "JWT Secret is set as \"secret\" which is an unsafe default.")]
+        _ -> do
+          let user = decode reqBody :: Maybe AuthUser
+
+          case user of
+            Nothing -> return $ responseLBS status400 [jsonH] $
+              encode . object $ [("message", String "Failed to parse user.")]
+            Just u -> do
+              setRole authenticator
+              login <- signInRole (cs $ userId u)
+                              (cs $ userPass u)
+              case login of
+                LoginSuccess role ->
+                  return $ responseLBS status201 [ jsonH ] $
+                    encode . object $ [("token", String $ tokenJWT jwtSecret (cs $ userId u) role)]
+                _  -> return $ responseLBS status401 [jsonH] $
+                  encode . object $ [("message", String "Failed authentication.")]
+
     ([table], "POST") -> do
       let qt = QualifiedTable schema (cs table)
           echoRequested = lookup "Prefer" hdrs == Just "return=representation"
@@ -164,10 +188,22 @@ app v1schema reqBody req =
     ([table], "PATCH") ->
       handleJsonObj reqBody $ \obj -> do
         let qt = QualifiedTable schema (cs table)
-        H.unitEx
+            up = returningStarT
-          $ whereT qq
+               . whereT qq
-          $ update qt (map cs $ M.keys obj) (M.elems obj)
+               $ update qt (map cs $ M.keys obj) (M.elems obj)
-        return $ responseLBS status204 [ jsonH ] ""
+            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) queryTotal
+            echoRequested = lookup "Prefer" hdrs == Just "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 = QualifiedTable schema (cs table)
@@ -189,7 +225,9 @@ app v1schema reqBody req =
     verb   = requestMethod req
     qq     = queryString req
     hdrs   = requestHeaders req
-    schema = requestedSchema v1schema hdrs
+    schema = requestedSchema (cs $ configV1Schema conf) hdrs
+    authenticator = cs $ configDbUser conf
+    jwtSecret = cs $ configJwtSecret conf
     range  = rangeRequested hdrs
     allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
 

src/PostgREST/Auth.hs

@@ -1,18 +1,22 @@
 {-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings #-}
-module Auth where
+module PostgREST.Auth where
 
 import Data.Aeson
 import Control.Monad (mzero)
-import Control.Applicative ( (<*>), (<$>) )
+import Control.Applicative
 import Crypto.BCrypt
 import Data.Text
 import Data.Monoid
+import Data.Map
 import qualified Data.Vector as V
 import qualified Hasql as H
 import qualified Hasql.Backend as B
 import qualified Hasql.Postgres as P
+import qualified Web.JWT as JWT
 import Data.String.Conversions (cs)
-import PgQuery (pgFmtLit)
+import PostgREST.PgQuery (pgFmtLit)
+
+import Prelude
 
 import System.IO.Unsafe
 
@@ -26,7 +30,7 @@ instance FromJSON AuthUser where
   parseJSON (Object v) = AuthUser <$>
                          v .: "id" <*>
                          v .: "pass" <*>
-                         v .: "role"
+                         v .:? "role" .!= ""
   parseJSON _ = mzero
 
 instance ToJSON AuthUser where
@@ -69,3 +73,19 @@ signInRole user pass = do
          then LoginSuccess role
          else LoginFailed
     ) u
+
+signInWithJWT :: Text -> Text -> LoginAttempt
+signInWithJWT secret input = case maybeRole of
+    Just (Just (String role)) -> LoginSuccess $ cs role
+    _   -> LoginFailed
+  where 
+    maybeRole = (Data.Map.lookup "role" <$> claims) ::Maybe (Maybe Value)
+    claims = JWT.unregisteredClaims <$> JWT.claims <$> decoded
+    decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input
+    
+tokenJWT :: Text -> Text -> Text -> Text
+tokenJWT secret uid role = JWT.encodeSigned JWT.HS256 (JWT.secret secret) claimsSet
+  where
+    claimsSet = JWT.def {
+      JWT.unregisteredClaims = Data.Map.fromList [("id", String uid), ("role", String role)]
+    }

src/PostgREST/Config.hs

@@ -1,4 +1,4 @@
-module Config where
+module PostgREST.Config where
 
 import Network.Wai
 import Control.Applicative
@@ -8,6 +8,7 @@ import qualified Data.ByteString.Char8 as BS
 import Data.String.Conversions (cs)
 import Options.Applicative hiding (columns)
 import Network.Wai.Middleware.Cors (CorsResourcePolicy(..))
+import Prelude
 
 data AppConfig = AppConfig {
     configDbName :: String
@@ -21,6 +22,8 @@ data AppConfig = AppConfig {
   , configSecure :: Bool
   , configPool :: Int
   , configV1Schema :: String
+  
+  , configJwtSecret :: String
   }
 
 argParser :: Parser AppConfig
@@ -36,6 +39,7 @@ argParser = AppConfig
   <*> switch (long "secure" <> short 's' <> help "Redirect all requests to HTTPS")
   <*> option auto (long "db-pool" <> metavar "COUNT" <> value 10 <> help "Max connections in database pool" <> showDefault)
   <*> strOption (long "v1schema" <> metavar "NAME" <> value "1" <> help "Schema to use for nonspecified version (or explicit v1)" <> showDefault)
+  <*> strOption (long "jwt-secret" <> metavar "SECRET" <> value "secret" <> help "Secret used to encrypt and decrypt JWT tokens)" <> showDefault)
 
 defaultCorsPolicy :: CorsResourcePolicy
 defaultCorsPolicy =  CorsResourcePolicy Nothing

src/PostgREST/Error.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
 
-module Error (PgError, errResponse) where
+module PostgREST.Error (PgError, errResponse) where
 
 import qualified Hasql as H
 import qualified Hasql.Postgres as P

src/PostgREST/Main.hs

@@ -2,9 +2,9 @@ module Main where
 
 import Paths_postgrest (version)
 
-import App
+import PostgREST.App
-import Middleware
+import PostgREST.Middleware
-import Error(errResponse)
+import PostgREST.Error(errResponse)
 
 import Control.Monad (unless)
 import Control.Monad.IO.Class (liftIO)
@@ -21,7 +21,7 @@ import qualified Hasql as H
 import qualified Hasql.Postgres as P
 import Options.Applicative hiding (columns)
 
-import Config (AppConfig(..), argParser, corsPolicy)
+import PostgREST.Config (AppConfig(..), argParser, corsPolicy)
 
 main :: IO ()
 main = do
@@ -38,6 +38,8 @@ main = do
 
   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)
 
@@ -53,8 +55,6 @@ main = do
         . (if configSecure conf then redirectInsecure else id)
         . gzip def . cors corsPolicy
         . staticPolicy (only [("favicon.ico", "static/favicon.ico")])
-      anonRole = cs $ configAnonRole conf
-      currRole = cs $ configDbUser conf
 
   poolSettings <- maybe (fail "Improper session settings") return $
                 H.poolSettings (fromIntegral $ configPool conf) 30
@@ -64,7 +64,7 @@ main = do
   runSettings appSettings $ middle $ \req respond -> do
     body <- strictRequestBody req
     resOrError <- liftIO $ H.session pool $ H.tx Nothing $
-      authenticated currRole anonRole (app (cs $ configV1Schema conf) body) req
+      authenticated conf (app conf body) req
     either (respond . errResponse) respond resOrError
 
   where

src/PostgREST/Middleware.hs

@@ -1,10 +1,10 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Middleware where
+module PostgREST.Middleware where
 
 import Data.Maybe (fromMaybe)
-import Data.Monoid (mconcat)
+import Data.Monoid
 import Data.Text
 -- import Data.Pool(withResource, Pool)
 
@@ -19,13 +19,16 @@ import Network.Wai (Application, requestHeaders, responseLBS, rawPathInfo,
                    rawQueryString, isSecure, Request(..), Response)
 import Network.URI (URI(..), parseURI)
 
-import Auth (LoginAttempt(..), signInRole, setRole, resetRole)
+import PostgREST.Config (AppConfig(..))
+import PostgREST.Auth (LoginAttempt(..), signInRole, signInWithJWT, setRole, resetRole)
 import Codec.Binary.Base64.String (decode)
 
-authenticated :: forall s. Text -> Text ->
+import Prelude
+
+authenticated :: forall s. AppConfig ->
                  (Request -> H.Tx P.Postgres s Response) ->
                  Request -> H.Tx P.Postgres s Response
-authenticated currentRole anon app req = do
+authenticated conf app req = do
   attempt <- httpRequesterRole (requestHeaders req)
   case attempt of
     MalformedAuth ->
@@ -36,6 +39,9 @@ authenticated currentRole anon app req = do
     NoCredentials ->     if anon /= currentRole then runInRole anon else app req
 
  where
+   jwtSecret = cs $ configJwtSecret conf
+   currentRole = cs $ configDbUser conf
+   anon = cs $ configAnonRole conf
    httpRequesterRole :: RequestHeaders -> H.Tx P.Postgres s LoginAttempt
    httpRequesterRole hdrs = do
     let auth = fromMaybe "" $ lookup hAuthorization hdrs
@@ -44,6 +50,8 @@ authenticated currentRole anon app req = do
         case split (==':') (cs . decode . cs $ b64) of
           (u:p:_) -> signInRole u p
           _ -> return MalformedAuth
+      ("Bearer" : jwt : _) ->
+        return $ signInWithJWT jwtSecret jwt
       _ -> return NoCredentials
 
    runInRole :: Text -> H.Tx P.Postgres s Response

src/PostgREST/PgQuery.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiWayIf #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module PgQuery where
+module PostgREST.PgQuery where
 
-import RangeQuery
+import PostgREST.RangeQuery
 
 import qualified Hasql as H
 import qualified Hasql.Postgres as P
@@ -17,7 +17,7 @@ import qualified Data.ByteString.Char8 as BS
 import Data.Monoid
 import Data.Vector (empty)
 import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Functor ( (<$>) )
+import Data.Functor
 import Control.Monad (join)
 import Data.String.Conversions (cs)
 import qualified Data.Aeson as JSON
@@ -25,6 +25,8 @@ import qualified Data.List as L
 import qualified Data.Vector as V
 import Data.Scientific (isInteger, formatScientific, FPFormat(..))
 
+import Prelude
+
 type PStmt = H.Stmt P.Postgres
 instance Monoid PStmt where
   mappend (B.Stmt query params prep) (B.Stmt query' params' prep') =
@@ -59,6 +61,12 @@ whereT params q =
    cols = [ col | col <- params, fst col `notElem` ["order"] ]
    conjunction = mconcat $ L.intersperse andq (map wherePred 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
@@ -268,7 +276,7 @@ unquoted (JSON.String t) = t
 unquoted (JSON.Number n) =
   cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
 unquoted (JSON.Bool b) = cs . show $ b
-unquoted _ = ""
+unquoted v = cs $ JSON.encode v
 
 insertableText :: T.Text -> T.Text
 insertableText = (<> "::unknown") . pgFmtLit

src/PostgREST/PgStructure.hs

@@ -1,20 +1,23 @@
 {-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeSynonymInstances,
-             MultiParamTypeClasses, ScopedTypeVariables #-}
+             MultiParamTypeClasses, ScopedTypeVariables,
-module PgStructure where
+             FlexibleContexts #-}
+module PostgREST.PgStructure where
 
-import PgQuery (QualifiedTable(..))
+import PostgREST.PgQuery (QualifiedTable(..))
 import Data.Text hiding (foldl, map, zipWith, concat)
 import Data.Aeson
 import Data.Functor.Identity
 import Data.String.Conversions (cs)
 import Data.Maybe (fromMaybe)
-import Control.Applicative ( (<$>) )
+import Control.Applicative
 
 import qualified Data.Map as Map
 
 import qualified Hasql as H
 import qualified Hasql.Postgres as P
 
+import Prelude
+
 foreignKeys :: QualifiedTable -> H.Tx P.Postgres s (Map.Map Text ForeignKey)
 foreignKeys table = do
   r <- H.listEx $ [H.stmt|

src/PostgREST/RangeQuery.hs

@@ -1,4 +1,4 @@
-module RangeQuery (
+module PostgREST.RangeQuery (
   rangeParse
 , rangeRequested
 , rangeLimit
@@ -20,6 +20,8 @@ import Text.Read (readMaybe)
 
 import Data.Maybe (fromMaybe, listToMaybe)
 
+import Prelude
+
 type NonnegRange = Range Int
 
 rangeParse :: BS.ByteString -> Maybe NonnegRange

src/Types.hs

@@ -1,57 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Types where
-
-import qualified Data.Aeson as JSON
-import Data.Aeson.Types (Parser)
-
-import Data.Scientific (floatingOrInteger)
-import Data.HashMap.Strict (foldlWithKey')
-import Data.Text (Text)
-import Data.Text.Encoding (decodeUtf8)
-import Data.Time.Calendar (showGregorian)
-import Control.Monad (mzero)
-
-instance JSON.FromJSON SqlValue where
-  parseJSON (JSON.Number n)    = return $ either toSql iToSql (floatingOrInteger n :: Either Double Int)
-  parseJSON (JSON.String s)    = return $ toSql s
-  parseJSON (JSON.Bool   b)    = return $ toSql b
-  parseJSON JSON.Null          = return SqlNull
-  parseJSON (JSON.Object o)    = return . toSql $ JSON.encode o
-  parseJSON (JSON.Array  a)    = return . toSql $ JSON.encode a
-
-instance JSON.ToJSON SqlValue where
-  toJSON (SqlString s)         = JSON.toJSON s
-  toJSON (SqlByteString s)     = JSON.toJSON $ decodeUtf8 s
-  toJSON (SqlWord32 w)         = JSON.toJSON w
-  toJSON (SqlWord64 w)         = JSON.toJSON w
-  toJSON (SqlInt32 i)          = JSON.toJSON i
-  toJSON (SqlInt64 i)          = JSON.toJSON i
-  toJSON (SqlInteger i)        = JSON.toJSON i
-  toJSON (SqlChar c)           = JSON.toJSON c
-  toJSON (SqlBool b)           = JSON.toJSON b
-  toJSON (SqlDouble n)         = JSON.toJSON n
-  toJSON (SqlRational n)       = JSON.toJSON n
-  toJSON (SqlLocalDate d)      = JSON.toJSON $ showGregorian d
-  toJSON (SqlLocalTimeOfDay t) = JSON.toJSON $ show t
-  toJSON (SqlLocalTime t)      = JSON.toJSON $ show t
-  toJSON SqlNull               = JSON.Null
-  toJSON x                     = JSON.toJSON $ show x
-
-
-newtype SqlRow = SqlRow {getRow :: [(Text, SqlValue)] } deriving (Show)
-
-sqlRowColumns :: SqlRow -> [Text]
-sqlRowColumns = map fst . getRow
-
-sqlRowValues :: SqlRow -> [SqlValue]
-sqlRowValues = map snd . getRow
-
-instance JSON.FromJSON SqlRow where
-  parseJSON (JSON.Object m) = foldlWithKey' add (return $ SqlRow []) m
-    where
-      add :: Parser SqlRow -> Text -> JSON.Value -> Parser SqlRow
-      add parser k v = do
-        SqlRow l <- parser
-        sqlV <- JSON.parseJSON v
-        return . SqlRow $ (k, sqlV) : l
-  parseJSON _ = mzero

test/Feature/AuthSpec.hs

@@ -18,13 +18,37 @@ spec = beforeAll
   it "hides tables that anonymous does not own" $
     get "/authors_only" `shouldRespondWith` 404
 
-  it "indicates login failure" $ do
+  it "indicates login failure (BasicAuth)" $ do
-    let auth = authHeader "postgrest_test_author" "fakefake"
+    let auth = authHeaderBasic "postgrest_test_author" "fakefake"
     request methodGet "/authors_only" [auth] ""
       `shouldRespondWith` 401
 
-  it "allows users with permissions to see their tables" $ do
+  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 = authHeader "jdoe" "1234"
+    let auth = authHeaderBasic "jdoe" "1234"
     request methodGet "/authors_only" [auth] ""
       `shouldRespondWith` 200
+      
+  it "allows users to login (JWT)" $ do
+    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
+    post "/postgrest/tokens" [json| { "id":"jdoe", "pass": "1234" } |] 
+      `shouldRespondWith` ResponseMatcher {
+          matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |]
+        , matchStatus = 201
+        , matchHeaders = ["Content-Type" <:> "application/json"]
+        }
+      
+  it "indicates login failure (JWT)" $ do
+    _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
+    post "/postgrest/tokens" [json| { "id":"jdoe", "pass": "NOPE" } |] 
+      `shouldRespondWith` ResponseMatcher {
+          matchBody = Just [json| {"message":"Failed authentication."} |]
+        , matchStatus = 401
+        , matchHeaders = ["Content-Type" <:> "application/json"]
+        }
+
+  it "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

test/Feature/InsertSpec.hs

@@ -94,6 +94,22 @@ spec = afterAll_ resetDb $ around withApp $ do
           , matchHeaders = []
           }
 
+    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
+        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
+        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" $
@@ -216,10 +232,10 @@ spec = afterAll_ resetDb $ around withApp $ do
             `shouldRespondWith` 404
 
     context "on an empty table" $
-      it "succeeds with no effect" $
+      it "indicates no records found to update" $
         request methodPatch "/simple_pk" []
           [json| { "extra":20 } |]
-            `shouldRespondWith` 204
+            `shouldRespondWith` 404
 
     context "in a nonempty table" . before_ (clearTable "items" >> createItems 15) .
       after_ (clearTable "items") $ do
@@ -229,7 +245,11 @@ spec = afterAll_ resetDb $ around withApp $ do
           `shouldSatisfy` matchHeader "Content-Range" "\\*/0"
         request methodPatch "/items?id=eq.1" []
           [json| { "id":42 } |]
-            `shouldRespondWith` 204
+            `shouldRespondWith` ResponseMatcher {
+              matchBody    = Nothing,
+              matchStatus  = 204,
+              matchHeaders = ["Content-Range" <:> "0-0/1"]
+            }
         g' <- get "/items?id=eq.42"
         liftIO $ simpleHeaders g'
           `shouldSatisfy` matchHeader "Content-Range" "0-0/1"
@@ -245,3 +265,12 @@ spec = afterAll_ resetDb $ around withApp $ do
         g <- get "/auto_incrementing_pk?non_nullable_string=eq.c"
         liftIO $ simpleHeaders g
           `shouldSatisfy` matchHeader "Content-Range" "0-9/10"
+
+      it "can provide a representation" $ do
+        _ <- post "/items"
+          [json| { id: 1 } |]
+        request methodPatch
+          "/items?id=eq.1"
+          [("Prefer", "return=representation")]
+          [json| { id: 99 } |]
+          `shouldRespondWith` [json| [{id:99}] |]

test/Feature/StructureSpec.hs

@@ -27,7 +27,7 @@ spec = around withApp $ do
 
     it "lists only views user has permission to see" $ do
       _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |]
-      let auth = authHeader "jdoe" "1234"
+      let auth = authHeaderBasic "jdoe" "1234"
 
       request methodGet "/" [auth] ""
         `shouldRespondWith` [json| [

test/SpecHelper.hs

@@ -26,17 +26,17 @@ import System.Process (readProcess)
 
 import qualified Data.Aeson.Types as J
 
-import App (app)
+import PostgREST.App (app)
-import Config (AppConfig(..), corsPolicy)
+import PostgREST.Config (AppConfig(..), corsPolicy)
-import Middleware
+import PostgREST.Middleware
-import Error(errResponse)
+import PostgREST.Error(errResponse)
 
 isLeft :: Either a b -> Bool
 isLeft (Left _ ) = True
 isLeft _ = False
 
 cfg :: AppConfig
-cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1"
+cfg = AppConfig "postgrest_test" 5432 "postgrest_test" "" "localhost" 3000 "postgrest_anonymous" False 10 "1" "safe"
 
 testPoolOpts :: PoolSettings
 testPoolOpts = fromMaybe (error "bad settings") $ H.poolSettings 1 30
@@ -50,15 +50,13 @@ pgSettings = P.ParamSettings (cs $ configDbHost cfg)
 
 withApp :: ActionWith Application -> IO ()
 withApp perform = do
-  let anonRole = cs $ configAnonRole cfg
-      currRole = cs $ configDbUser cfg
   pool :: H.Pool P.Postgres
     <- H.acquirePool pgSettings testPoolOpts
 
   perform $ middle $ \req resp -> do
     body <- strictRequestBody req
     result <- liftIO $ H.session pool $ H.tx Nothing
-      $ authenticated currRole anonRole (app (cs $ configV1Schema cfg) body) req
+      $ authenticated cfg (app cfg body) req
     either (resp . errResponse) resp result
 
   where middle = cors corsPolicy
@@ -93,9 +91,13 @@ matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool
 matchHeader name valRegex headers =
   maybe False (=~ valRegex) $ lookup name headers
 
-authHeader :: String -> String -> Header
+authHeaderBasic :: String -> String -> Header
-authHeader u p =
+authHeaderBasic u p =
   (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))
+  
+authHeaderJWT :: String -> Header
+authHeaderJWT token =
+  (hAuthorization, cs $ "Bearer " ++ token)
 
 testPool :: IO(H.Pool P.Postgres)
 testPool = H.acquirePool pgSettings testPoolOpts

test/TestTypes.hs

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