postgrest 0.3.2.0 → 0.4.0.0

raw patch · 32 files changed

+2633/−1751 lines, 32 filesdep +aeson-qqdep +ansi-wl-pprintdep +auto-updatedep −base64-stringdep −bytestring-tree-builderdep −errorsdep ~Ranged-setsdep ~aesondep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-qq, ansi-wl-pprint, auto-update, base64-bytestring, configurator, either, hjsonpointer, hjsonschema, insert-ordered-containers, lens, lens-aeson, network-uri, protolude, swagger2

Dependencies removed: base64-string, bytestring-tree-builder, errors, microlens, microlens-aeson, mtl, postgresql-binary, string-conversions, transformers

Dependency ranges changed: Ranged-sets, aeson, base, hasql, hasql-pool, hasql-transaction, optparse-applicative, safe, unix, wai, wai-middleware-static, warp

API changes (from Hackage documentation)

Files

• main/Main.hs +68/−28
• postgrest.cabal +49/−80
• src/PostgREST/ApiRequest.hs +178/−145
• src/PostgREST/App.hs +231/−353
• src/PostgREST/Auth.hs +33/−24
• src/PostgREST/Config.hs +132/−47
• src/PostgREST/DbRequestBuilder.hs +275/−0
• src/PostgREST/DbStructure.hs +112/−115
• src/PostgREST/Error.hs +66/−30
• src/PostgREST/Middleware.hs +27/−25
• src/PostgREST/OpenAPI.hs +357/−0
• src/PostgREST/Parsers.hs +50/−50
• src/PostgREST/QueryBuilder.hs +116/−151
• src/PostgREST/RangeQuery.hs +8/−10
• src/PostgREST/Types.hs +30/−18
• test/Feature/AuthSpec.hs +63/−15
• test/Feature/BinaryJwtSecretSpec.hs +21/−0
• test/Feature/ConcurrentSpec.hs +2/−0
• test/Feature/CorsSpec.hs +3/−1
• test/Feature/DeleteSpec.hs +20/−9
• test/Feature/InsertSpec.hs +135/−117
• test/Feature/NoJwtSpec.hs +25/−0
• test/Feature/ProxySpec.hs +15/−0
• test/Feature/QueryLimitedSpec.hs +17/−6
• test/Feature/QuerySpec.hs +148/−59
• test/Feature/RangeSpec.hs +34/−36
• test/Feature/SingularSpec.hs +198/−0
• test/Feature/StructureSpec.hs +66/−366
• test/Feature/UnicodeSpec.hs +2/−0
• test/Main.hs +40/−10
• test/SpecHelper.hs +107/−33
• test/TestTypes.hs +5/−23

@@ -2,17 +2,25 @@  module Main where -+import           Protolude import           PostgREST.App import           PostgREST.Config                     (AppConfig (..),+                                                       PgVersion (..),                                                        minimumPgVersion,                                                        prettyVersion,                                                        readOptions)+import           PostgREST.Error                      (prettyUsageError)+import           PostgREST.OpenAPI                    (isMalformedProxyUri) import           PostgREST.DbStructure -import           Control.Monad-import           Data.Monoid                          ((<>))-import           Data.String.Conversions              (cs)+import           Control.AutoUpdate+import           Data.ByteString.Base64               (decode)+import           Data.String                          (IsString (..))+import           Data.Text                            (stripPrefix, pack, replace)+import           Data.Text.Encoding                   (encodeUtf8, decodeUtf8)+import           Data.Text.IO                         (hPutStrLn, readFile)+import           Data.Function                        (id)+import           Data.Time.Clock.POSIX                (getPOSIXTime) import qualified Hasql.Query                          as H import qualified Hasql.Session                        as H import qualified Hasql.Decoders                       as HD@@ -20,25 +28,20 @@ import qualified Hasql.Pool                           as P import           Network.Wai.Handler.Warp import           System.IO                            (BufferMode (..),-                                                       hSetBuffering, stderr,-                                                       stdin, stdout)-import           Web.JWT                              (secret)+                                                       hSetBuffering) import           Data.IORef #ifndef mingw32_HOST_OS-import           Control.Monad.IO.Class               (liftIO) import           System.Posix.Signals-import           Control.Concurrent                   (myThreadId)-import           Control.Exception.Base               (throwTo, AsyncException(..)) #endif  isServerVersionSupported :: H.Session Bool isServerVersionSupported = do   ver <- H.query () pgVersion-  return $ read (cs ver) >= minimumPgVersion+  return $ ver >= pgvNum minimumPgVersion  where   pgVersion =-    H.statement "SHOW server_version_num"-      HE.unit (HD.singleRow $ HD.value HD.text) True+    H.statement "SELECT current_setting('server_version_num')::integer"+      HE.unit (HD.singleRow $ HD.value HD.int4) False  main :: IO () main = do@@ -46,29 +49,36 @@   hSetBuffering stdin  LineBuffering   hSetBuffering stderr NoBuffering -  conf <- readOptions-  let port = configPort conf-      pgSettings = cs (configDatabase conf)-      appSettings = setPort port-                  . setServerName (cs $ "postgrest/" <> prettyVersion)+  conf <- loadSecretFile =<< readOptions+  let host = configHost conf+      port = configPort conf+      proxy = configProxyUri conf+      pgSettings = toS (configDatabase conf)+      appSettings = setHost ((fromString . toS) host)+                  . setPort port+                  . setServerName (toS $ "postgrest/" <> prettyVersion)                   $ defaultSettings -  unless (secret "secret" /= configJwtSecret conf) $-    putStrLn "WARNING, running in insecure mode, JWT secret is the default value"-  Prelude.putStrLn $ "Listening on port " ++-    (show $ configPort conf :: String)+  when (isMalformedProxyUri $ toS <$> proxy) $ panic+    "Malformed proxy uri, a correct example: https://example.com:8443/basePath" +  putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)+   pool <- P.acquire (configPool conf, 10, pgSettings)    result <- P.use pool $ do     supported <- isServerVersionSupported-    unless supported $ error (+    unless supported $ panic (       "Cannot run in this PostgreSQL version, PostgREST needs at least "-      <> show minimumPgVersion)-    getDbStructure (cs $ configSchema conf)+      <> pgvName minimumPgVersion)+    getDbStructure (toS $ configSchema conf) -  refDbStructure <- newIORef $ either (error.show) id result+  forM_ (lefts [result]) $ \e -> do+    hPutStrLn stderr (prettyUsageError e)+    exitFailure +  refDbStructure <- newIORef $ either (panic . show) id result+ #ifndef mingw32_HOST_OS   tid <- myThreadId   forM_ [sigINT, sigTERM] $ \sig ->@@ -79,9 +89,39 @@    void $ installHandler sigHUP (       Catch . void . P.use pool $ do-        s <- getDbStructure (cs $ configSchema conf)+        s <- getDbStructure (toS $ configSchema conf)         liftIO $ atomicWriteIORef refDbStructure s    ) Nothing #endif -  runSettings appSettings $ postgrest conf refDbStructure pool+  -- ask for the OS time at most once per second+  getTime <- mkAutoUpdate+    defaultUpdateSettings { updateAction = getPOSIXTime }++  runSettings appSettings $ postgrest conf refDbStructure pool getTime++loadSecretFile :: AppConfig -> IO AppConfig+loadSecretFile conf = extractAndTransform mSecret+  where+    mSecret   = decodeUtf8 <$> configJwtSecret conf+    isB64     = configJwtSecretIsBase64 conf++    extractAndTransform :: Maybe Text -> IO AppConfig+    extractAndTransform Nothing  = return conf+    extractAndTransform (Just s) =+      fmap setSecret $ transformString isB64 =<<+        case stripPrefix "@" s of+            Nothing       -> return s+            Just filename -> readFile (toS filename)++    transformString :: Bool -> Text -> IO ByteString+    transformString False t = return . encodeUtf8 $ t+    transformString True  t =+      case decode (encodeUtf8 $ replaceUrlChars t) of+        Left errMsg -> panic $ pack errMsg+        Right bs    -> return bs++    setSecret bs = conf { configJwtSecret = Just bs }++    replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="+        

@@ -2,7 +2,7 @@ description:           Reads the schema of a PostgreSQL database and creates RESTful routes                        for the tables and views, supporting all HTTP verbs that security                        permits.-version:               0.3.2.0+version:               0.4.0.0 synopsis:              REST API for any Postgres database license:               MIT license-file:          LICENSE@@ -23,168 +23,137 @@  executable postgrest   main-is:             Main.hs-  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes+  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude   ghc-options:     -threaded     -rtsopts     "-with-rtsopts=-N -I2"   default-language:    Haskell2010-  build-depends:       aeson (>= 0.8 && < 0.10) || (>= 0.11 && < 0.12)-                     , base >= 4.8 && < 6-                     , bytestring-                     , bytestring-tree-builder == 0.2.7-                     , case-insensitive-                     , cassava-                     , containers-                     , contravariant-                     , errors-                     , hasql == 0.19.12-                     , hasql-pool == 0.4.1-                     , hasql-transaction == 0.4.5-                     , http-types-                     , interpolatedstring-perl6-                     , jwt-                     , microlens >= 0.4.2 && < 0.5-                     , microlens-aeson >= 2.1.1 && < 2.2-                     , mtl-                     , optparse-applicative >= 0.11 && < 0.13-                     , parsec-                     , postgresql-binary == 0.9.0.1+  build-depends:       auto-update+                     , base+                     , hasql+                     , hasql-pool                      , postgrest-                     , regex-tdfa-                     , safe >= 0.3 && < 0.4-                     , scientific-                     , string-conversions+                     , protolude                      , text                      , time-                     , transformers-                     , unordered-containers-                     , vector-                     , wai >= 3.0.1-                     , wai-cors-                     , wai-extra-                     , wai-middleware-static >= 0.6.0-                     , warp >= 3.1.0-                     , HTTP-                     , Ranged-sets+                     , warp+                     , bytestring+                     , base64-bytestring   if !os(windows)-    build-depends:     unix >= 2.7 && < 3+    build-depends:     unix    hs-source-dirs:      main  library   default-language:    Haskell2010-  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes+  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude   build-depends:       aeson-                     , base+                     , ansi-wl-pprint+                     , base >= 4.8 && < 6                      , bytestring                      , case-insensitive                      , cassava+                     , configurator                      , containers                      , contravariant-                     , errors+                     , either                      , hasql-                     , hasql-transaction-                     , hasql-pool+                     , hasql-pool == 0.4.1+                     , hasql-transaction == 0.5+                     , heredoc+                     , HTTP                      , http-types+                     , insert-ordered-containers                      , interpolatedstring-perl6                      , jwt-                     , microlens-                     , microlens-aeson-                     , mtl-                     , optparse-applicative+                     , lens+                     , lens-aeson+                     , network-uri+                     , optparse-applicative >= 0.12.0.0 && < 0.13.0.0                      , parsec+                     , protolude+                     , Ranged-sets == 0.3.0                      , regex-tdfa                      , safe                      , scientific-                     , string-conversions+                     , swagger2                      , text                      , time                      , unordered-containers                      , vector-                     , HTTP-                     , Ranged-sets-                     , wai >= 3.0.1+                     , wai                      , wai-cors                      , wai-extra-                     , wai-middleware-static >= 0.6.0-                     , warp >= 3.1.0+                     , wai-middleware-static    Other-Modules:       Paths_postgrest-  Exposed-Modules:     PostgREST.App+  Exposed-Modules:     PostgREST.ApiRequest+                     , PostgREST.App                      , PostgREST.Auth                      , PostgREST.Config+                     , PostgREST.DbStructure+                     , PostgREST.DbRequestBuilder                      , PostgREST.Error                      , PostgREST.Middleware+                     , PostgREST.OpenAPI                      , PostgREST.Parsers-                     , PostgREST.DbStructure                      , PostgREST.QueryBuilder                      , PostgREST.RangeQuery-                     , PostgREST.ApiRequest                      , PostgREST.Types   hs-source-dirs:      src  Test-Suite spec   Type:                exitcode-stdio-1.0   Default-Language:    Haskell2010-  default-extensions:  OverloadedStrings, ScopedTypeVariables, QuasiQuotes+  default-extensions:  OverloadedStrings, QuasiQuotes, NoImplicitPrelude   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   Hs-Source-Dirs:      test   Main-Is:             Main.hs   Other-Modules:       Feature.AuthSpec+                     , Feature.BinaryJwtSecretSpec                      , Feature.ConcurrentSpec                      , Feature.CorsSpec                      , Feature.DeleteSpec                      , Feature.InsertSpec-                     , Feature.QuerySpec+                     , Feature.NoJwtSpec+                     , Feature.ProxySpec                      , Feature.QueryLimitedSpec+                     , Feature.QuerySpec                      , Feature.RangeSpec+                     , Feature.SingularSpec                      , Feature.StructureSpec                      , Feature.UnicodeSpec                      , SpecHelper                      , TestTypes   Build-Depends:       aeson+                     , aeson-qq                      , async+                     , auto-update                      , base-                     , base64-string                      , bytestring+                     , base64-bytestring                      , case-insensitive                      , cassava                      , containers                      , contravariant-                     , errors                      , hasql                      , hasql-pool-                     , hasql-transaction                      , heredoc+                     , hjsonpointer+                     , hjsonschema                      , hspec                      , hspec-wai                      , hspec-wai-json                      , http-types-                     , interpolatedstring-perl6-                     , jwt-                     , microlens-                     , microlens-aeson+                     , lens+                     , lens-aeson                      , monad-control-                     , mtl-                     , optparse-applicative-                     , parsec                      , postgrest                      , process+                     , protolude                      , regex-tdfa-                     , safe-                     , scientific-                     , string-conversions-                     , text                      , time-                     , transformers                      , transformers-base-                     , unordered-containers-                     , vector                      , wai-                     , wai-cors                      , wai-extra-                     , wai-middleware-static-                     , warp-                     , HTTP-                     , Ranged-sets

@@ -1,32 +1,44 @@-module PostgREST.ApiRequest where+{-|+Module      : PostgREST.ApiRequest+Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.+-}+module PostgREST.ApiRequest ( ApiRequest(..)+                            , ApiRequestError(..)+                            , ContentType(..)+                            , Action(..)+                            , Target(..)+                            , PreferRepresentation (..)+                            , mutuallyAgreeable+                            , toHeader+                            , userApiRequest+                            , toMime+                            ) where +import           Protolude import qualified Data.Aeson                as JSON import qualified Data.ByteString           as BS+import qualified Data.ByteString.Internal  as BS (c2w) import qualified Data.ByteString.Lazy      as BL import qualified Data.Csv                  as CSV-import           Data.List                 (find, sortBy)+import qualified Data.List                 as L+import           Data.List                 (lookup, last) import qualified Data.HashMap.Strict       as M import qualified Data.Set                  as S-import           Data.Maybe                (fromMaybe, isJust, isNothing,-                                            listToMaybe, fromJust)+import           Data.Maybe                (fromJust) import           Control.Arrow             ((***))-import           Control.Monad             (join)-import           Data.Monoid               ((<>))-import           Data.Ord                  (comparing)-import           Data.String.Conversions   (cs) import qualified Data.Text                 as T-import           Text.Read                 (readMaybe) import qualified Data.Vector               as V import           Network.HTTP.Base         (urlEncodeVars)-import           Network.HTTP.Types.Header (hAuthorization)+import           Network.HTTP.Types.Header (hAuthorization, hContentType, Header) import           Network.HTTP.Types.URI    (parseSimpleQuery) import           Network.Wai               (Request (..)) import           Network.Wai.Parse         (parseHttpAccept)-import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange)+import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)+import           Data.Ranged.Boundaries import           PostgREST.Types           (QualifiedIdentifier (..),-                                            Schema, Payload(..),-                                            UniformObjects(..))-import           Data.Ranged.Ranges        (singletonRange, rangeIntersection)+                                            Schema,+                                            PayloadJSON(..))+import           Data.Ranged.Ranges        (Range(..), rangeIntersection, emptyRange)  type RequestBody = BL.ByteString @@ -34,22 +46,40 @@ data Action = ActionCreate | ActionRead             | ActionUpdate | ActionDelete             | ActionInfo   | ActionInvoke-            | ActionInappropriate+            | ActionInspect             deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier             | TargetProc  QualifiedIdentifier             | TargetRoot-            | TargetUnknown [T.Text]+            | TargetUnknown [Text]+            deriving Eq -- | How to return the inserted data data PreferRepresentation = Full | HeadersOnly | None deriving Eq--- | Enumeration of currently supported content types for--- route responses and upload payloads-data ContentType = ApplicationJSON | TextCSV deriving Eq-instance Show ContentType where-  show ApplicationJSON = "application/json; charset=utf-8"-  show TextCSV         = "text/csv; charset=utf-8"+                          --+-- | Enumeration of currently supported response content types+data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI+                 | CTSingularJSON+                 | CTAny | CTOther BS.ByteString deriving Eq +data ApiRequestError = ErrorActionInappropriate+                     | ErrorInvalidBody ByteString+                     | ErrorInvalidRange+                     deriving (Show, Eq)++-- | Convert from ContentType to a full HTTP Header+toHeader :: ContentType -> Header+toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")++-- | Convert from ContentType to a ByteString representing the mime type+toMime :: ContentType -> ByteString+toMime CTApplicationJSON = "application/json"+toMime CTTextCSV         = "text/csv"+toMime CTOpenAPI         = "application/openapi+json"+toMime CTSingularJSON    = "application/vnd.pgrst.object+json"+toMime CTAny             = "*/*"+toMime (CTOther ct)      = ct+ {-|   Describes what the user wants to do. This data type is a   translation of the raw elements of an HTTP request into domain@@ -61,163 +91,166 @@   -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST     iAction :: Action   -- | Requested range of rows within response-  , iRange  :: M.HashMap String NonnegRange+  , iRange  :: M.HashMap ByteString NonnegRange   -- | The target, be it calling a proc or accessing a table   , iTarget :: Target-  -- | The content type the client most desires (or JSON if undecided)-  , iAccepts :: Either BS.ByteString ContentType+  -- | Content types the client will accept, [CTAny] if no Accept header+  , iAccepts :: [ContentType]   -- | Data sent by client and used for mutation actions-  , iPayload :: Maybe Payload+  , iPayload :: Maybe PayloadJSON   -- | If client wants created items echoed back   , iPreferRepresentation :: PreferRepresentation-  -- | If client wants first row as raw object-  , iPreferSingular :: Bool+  -- | Pass all parameters as a single json object to a stored procedure+  , iPreferSingleObjectParameter :: Bool   -- | Whether the client wants a result count (slower)   , iPreferCount :: Bool   -- | Filters on the result ("id", "eq.10")-  , iFilters :: [(String, String)]+  , iFilters :: [(Text, Text)]   -- | &select parameter used to shape the response-  , iSelect :: String+  , iSelect :: Text   -- | &order parameters for each level-  , iOrder :: [(String,String)]+  , iOrder :: [(Text, Text)]   -- | Alphabetized (canonical) request query string for response URLs-  , iCanonicalQS :: String+  , iCanonicalQS :: ByteString   -- | JSON Web Token-  , iJWT :: T.Text+  , iJWT :: Text   }  -- | Examines HTTP request and translates it into user intent.-userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest-userApiRequest schema req reqBody =-  let action =-        if isTargetingProc-          then-            if method == "POST"-               then ActionInvoke-               else ActionInappropriate-          else-            case method of-               "GET"     -> ActionRead-               "POST"    -> ActionCreate-               "PATCH"   -> ActionUpdate-               "DELETE"  -> ActionDelete-               "OPTIONS" -> ActionInfo-               _         -> ActionInappropriate-      target = case path of-                 []            -> TargetRoot-                 [table]       -> TargetIdent-                                  $ QualifiedIdentifier schema table-                 ["rpc", proc] -> TargetProc-                                  $ QualifiedIdentifier schema proc-                 other         -> TargetUnknown other-      payload = case pickContentType (lookupHeader "content-type") of-        Right ApplicationJSON ->-          either (PayloadParseError . cs)-            (\val -> case ensureUniform (pluralize val) of-              Nothing -> PayloadParseError "All object keys must match"-              Just json -> PayloadJSON json)-            (JSON.eitherDecode reqBody)-        Right TextCSV ->-          either (PayloadParseError . cs)-            (\val -> case ensureUniform (csvToJson val) of-              Nothing -> PayloadParseError "All lines must have same number of fields"-              Just json -> PayloadJSON json)-            (CSV.decodeByName reqBody)-        -- This is a Left value because form-urlencoded is not a content-        -- type which we ever use for responses, only something we handle-        -- just this once for requests-        Left "application/x-www-form-urlencoded" ->-          PayloadJSON . UniformObjects . V.singleton . M.fromList-                      . map (cs *** JSON.String . cs) . parseSimpleQuery-                      $ cs reqBody-        Left accept ->-          PayloadParseError $-            "Content-type not acceptable: " <> accept-      relevantPayload = case action of-        ActionCreate -> Just payload-        ActionUpdate -> Just payload-        ActionInvoke -> Just payload-        _            -> Nothing in--  ApiRequest {-    iAction = action-  , iTarget = target-  , iRange = M.insert "limit" (rangeIntersection headerRange urlRange) $-      M.fromList [ (cs k, restrictRange (readMaybe =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ]-  , iAccepts = pickContentType $ lookupHeader "accept"-  , iPayload = relevantPayload-  , iPreferRepresentation = representation-  , iPreferSingular = singular-  , iPreferCount = not $ singular || hasPrefer "count=none"-  , iFilters = [ (cs k, fromJust v) | (k,v) <- qParams, isJust v, k /= "select", k /= "offset", not (endingIn ["order", "limit"] k) ]-  , iSelect = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams-  , iOrder = [(cs k, fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]-  , iCanonicalQS = urlEncodeVars-     . sortBy (comparing fst)-     . map (join (***) cs)-     . parseSimpleQuery-     $ rawQueryString req-  , iJWT = tokenStr-  }-+userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest+userApiRequest schema req reqBody+  | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate+  | topLevelRange == emptyRange = Left ErrorInvalidRange+  | shouldParsePayload && isLeft payload = either (Left . ErrorInvalidBody . toS) undefined payload+  | otherwise = Right ApiRequest {+      iAction = action+      , iTarget = target+      , iRange = ranges+      , iAccepts = fromMaybe [CTAny] $+        map decodeContentType . parseHttpAccept <$> lookupHeader "accept"+      , iPayload = relevantPayload+      , iPreferRepresentation = representation+      , iPreferSingleObjectParameter = singleObject+      , iPreferCount = hasPrefer "count=exact"+      , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ]+      , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams+      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]+      , iCanonicalQS = toS $ urlEncodeVars+        . L.sortBy (comparing fst)+        . map (join (***) toS)+        . parseSimpleQuery+        $ rawQueryString req+      , iJWT = tokenStr+      }  where+  isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path+  payload =+    case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of+      CTApplicationJSON ->+          either Left (\val -> case ensureUniform (pluralize val) of+            Nothing -> Left "All object keys must match"+            Just json -> Right json) (JSON.eitherDecode reqBody)+      CTTextCSV ->+          either Left (\val -> case ensureUniform (csvToJson val) of+            Nothing -> Left "All lines must have same number of fields"+            Just json -> Right json) (CSV.decodeByName reqBody)+      CTOther "application/x-www-form-urlencoded" ->+        Right . PayloadJSON . V.singleton . M.fromList+                    . map (toS *** JSON.String . toS) . parseSimpleQuery+                    $ toS reqBody+      ct ->+        Left $ toS $ "Content-Type not acceptable: " <> toMime ct+  topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges+  action = case method of+            "GET"     -> if target == TargetRoot+                          then ActionInspect+                          else ActionRead+            "POST"    -> if isTargetingProc+                          then ActionInvoke+                          else ActionCreate+            "PATCH"   -> ActionUpdate+            "DELETE"  -> ActionDelete+            "OPTIONS" -> ActionInfo+            _         -> ActionInspect+  target = case path of+              []            -> TargetRoot+              [table]       -> TargetIdent+                              $ QualifiedIdentifier schema table+              ["rpc", proc] -> TargetProc+                              $ QualifiedIdentifier schema proc+              other         -> TargetUnknown other+  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke]+  relevantPayload = if shouldParsePayload+                      then rightToMaybe payload+                      else Nothing   path            = pathInfo req   method          = requestMethod req-  isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path   hdrs            = requestHeaders req-  qParams         = [(cs k, cs <$> v)|(k,v) <- queryString req]+  qParams         = [(toS k, v)|(k,v) <- queryString req]   lookupHeader    = flip lookup hdrs-  hasPrefer :: T.Text -> Bool+  hasPrefer :: Text -> Bool   hasPrefer val   = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs     where-        split :: BS.ByteString -> [T.Text]-        split = map T.strip . T.split (==';') . cs-  singular        = hasPrefer "plurality=singular"+        split :: BS.ByteString -> [Text]+        split = map T.strip . T.split (==',') . toS+  singleObject    = hasPrefer "params=single-object"   representation     | hasPrefer "return=representation" = Full     | hasPrefer "return=minimal" = None     | otherwise = HeadersOnly   auth = fromMaybe "" $ lookupHeader hAuthorization-  tokenStr = case T.split (== ' ') (cs auth) of+  tokenStr = case T.split (== ' ') (toS auth) of     ("Bearer" : t : _) -> t     _                  -> ""-  endingIn:: [T.Text] -> T.Text -> Bool+  endingIn:: [Text] -> Text -> Bool   endingIn xx key = lastWord `elem` xx     where lastWord = last $ T.split (=='.') key -  headerRange = if singular then singletonRange 0 else rangeRequested hdrs-  urlOffsetRange = rangeGeq . fromMaybe (0::Integer) $-    readMaybe =<< join (lookup "offset" qParams)-  urlRange = restrictRange-    (readMaybe =<< join (lookup "limit" qParams))-    urlOffsetRange+  headerRange = rangeRequested hdrs+  replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]+  limitParams :: M.HashMap ByteString NonnegRange+  limitParams  = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]+  offsetParams :: M.HashMap ByteString NonnegRange+  offsetParams = M.fromList [(toS (replaceLast "limit" k), fromMaybe allRange (rangeGeq <$> (readMaybe =<< (toS <$> v)))) | (k,v) <- qParams, isJust v, endingIn ["offset"] k] --- PRIVATE ---------------------------------------------------------------+  urlRange = M.unionWith f limitParams offsetParams+    where+      f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)+        where+          l = fromMaybe 0 $ rangeLimit rl+          o = rangeOffset ro+  ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange  {-|-  Picks a preferred content type from an Accept header (or from-  Content-Type as a degenerate case).+  Find the best match from a list of content types accepted by the+  client in order of decreasing preference and a list of types+  producible by the server.  If there is no match but the client+  accepts */* then return the top server pick.+-}+mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType+mutuallyAgreeable sProduces cAccepts =+  let exact = listToMaybe $ L.intersect cAccepts sProduces in+  if isNothing exact && CTAny `elem` cAccepts+     then listToMaybe sProduces+     else exact -  For example-  text/csv -> TextCSV-  */*      -> ApplicationJSON-  text/csv, application/json -> TextCSV-  application/json, text/csv -> ApplicationJSON+-- PRIVATE ---------------------------------------------------------------++{-|+  Warning: discards MIME parameters -}-pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType-pickContentType accept-  | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON-  | has ctCsv = Right TextCSV-  | otherwise = Left accept'- where-  ctAll  = "*/*"-  ctCsv  = "text/csv"-  ctJson = "application/json"-  Just accept' = accept-  findInAccept = flip find $ parseHttpAccept accept'-  has          = isJust . findInAccept . BS.isPrefixOf+decodeContentType :: BS.ByteString -> ContentType+decodeContentType ct =+  case BS.takeWhile (/= BS.c2w ';') ct of+    "application/json"                  -> CTApplicationJSON+    "text/csv"                          -> CTTextCSV+    "application/openapi+json"          -> CTOpenAPI+    "application/vnd.pgrst.object+json" -> CTSingularJSON+    "application/vnd.pgrst.object"      -> CTSingularJSON+    "*/*"                               -> CTAny+    ct'                                 -> CTOther ct' -type CsvData = V.Vector (M.HashMap T.Text BL.ByteString)+type CsvData = V.Vector (M.HashMap Text BL.ByteString)  {-|   Converts CSV like@@ -239,7 +272,7 @@     M.map (\str ->         if str == "NULL"           then JSON.Null-          else JSON.String $ cs str+          else JSON.String $ toS str       )  -- | Convert {foo} to [{foo}], leave arrays unchanged@@ -250,8 +283,8 @@ pluralize _                   = V.empty  -- | Test that Array contains only Objects having the same keys--- and if so mark it as UniformObjects-ensureUniform :: JSON.Array -> Maybe UniformObjects+-- and if so mark it as PayloadJSON+ensureUniform :: JSON.Array -> Maybe PayloadJSON ensureUniform arr =   let objs :: V.Vector JSON.Object       objs = foldr -- filter non-objects, map to raw objects@@ -264,5 +297,5 @@       areKeysUniform = all (==canonicalKeys) keysPerObj in    if (V.length objs == V.length arr) && areKeysUniform-    then Just (UniformObjects objs)+    then Just (PayloadJSON objs)     else Nothing

@@ -7,82 +7,76 @@ ) where  import           Control.Applicative-import           Data.Bifunctor            (first)-import qualified Data.ByteString.Char8   as BS+import qualified Data.ByteString.Char8     as BS import           Data.IORef                (IORef, readIORef)-import           Data.List                 (find, delete)-import           Data.Maybe                (fromMaybe, fromJust, mapMaybe)-import           Data.Ranged.Ranges        (emptyRange)-import           Data.String.Conversions   (cs)-import           Data.Text                 (Text, replace, strip)-import           Data.Tree--import qualified Hasql.Pool                as P-import qualified Hasql.Transaction         as HT+import           Data.Text                 (intercalate)+import           Data.Time.Clock.POSIX     (POSIXTime) -import           Text.Parsec.Error-import           Text.ParserCombinators.Parsec (parse)+import qualified Hasql.Pool                 as P+import qualified Hasql.Transaction          as HT+import qualified Hasql.Transaction.Sessions as HT  import           Network.HTTP.Types.Header import           Network.HTTP.Types.Status-import           Network.HTTP.Types.URI (renderSimpleQuery)+import           Network.HTTP.Types.URI    (renderSimpleQuery) import           Network.Wai import           Network.Wai.Middleware.RequestLogger (logStdout)+import           Web.JWT                   (binarySecret) -import           Data.Aeson-import           Data.Aeson.Types (emptyArray)-import           Data.Monoid-import           Data.Time.Clock.POSIX     (getPOSIXTime) import qualified Data.Vector               as V import qualified Hasql.Transaction         as H  import qualified Data.HashMap.Strict       as M -import           PostgREST.ApiRequest   (ApiRequest(..), ContentType(..)-                                            , Action(..), Target(..)-                                            , PreferRepresentation (..)-                                            , userApiRequest)-import           PostgREST.Auth            (tokenJWT, jwtClaims, containsRole)+import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)+                                        , Action(..), Target(..)+                                        , PreferRepresentation (..)+                                        , mutuallyAgreeable+                                        , toHeader+                                        , userApiRequest+                                        , toMime+                                        )+import           PostgREST.Auth            (jwtClaims, containsRole) import           PostgREST.Config          (AppConfig (..)) import           PostgREST.DbStructure-import           PostgREST.Error           (errResponse, pgErrResponse)-import           PostgREST.Parsers-import           PostgREST.RangeQuery      (NonnegRange, allRange, rangeOffset, restrictRange)+import           PostgREST.DbRequestBuilder(readRequest, mutateRequest)+import           PostgREST.Error           (errResponse, pgErrResponse, apiRequestErrResponse, singularityError)+import           PostgREST.RangeQuery      (allRange, rangeOffset) import           PostgREST.Middleware import           PostgREST.QueryBuilder ( callProc-                                        , addJoinConditions-                                        , sourceCTEName                                         , requestToQuery                                         , requestToCountQuery-                                        , addRelations                                         , createReadStatement                                         , createWriteStatement                                         , ResultsWithCount                                         ) import           PostgREST.Types--import           Prelude+import           PostgREST.OpenAPI +import           Data.Function (id)+import           Protolude                hiding (intercalate, Proxy) -postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> Application-postgrest conf refDbStructure pool =+postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> IO POSIXTime ->+             Application+postgrest conf refDbStructure pool getTime =   let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in    middle $ \ req respond -> do-    time <- getPOSIXTime+    time <- getTime     body <- strictRequestBody req     dbStructure <- readIORef refDbStructure -    let schema = cs $ configSchema conf-        apiRequest = userApiRequest schema req body-        eClaims = jwtClaims (configJwtSecret conf) (iJWT apiRequest) time-        authed = containsRole eClaims-        handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest-        txMode = transactionMode $ iAction apiRequest--    resp <- either (pgErrResponse authed) id <$> P.use pool-      (HT.run handleReq HT.ReadCommitted txMode)-    respond resp+    response <- case userApiRequest (configSchema conf) req body of+      Left err -> return $ apiRequestErrResponse err+      Right apiRequest -> do+        let jwtSecret = binarySecret <$> configJwtSecret conf+            eClaims = jwtClaims jwtSecret (iJWT apiRequest) time+            authed = containsRole eClaims+            handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest+            txMode = transactionMode $ iAction apiRequest+        response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq+        return $ either (pgErrResponse authed) identity response+    respond response  transactionMode :: Action -> H.Mode transactionMode ActionRead = HT.Read@@ -91,157 +85,205 @@  app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response app dbStructure conf apiRequest =-  let-      -- TODO: blow up for Left values (there is a middleware that checks the headers)-      contentType = either (const ApplicationJSON) id (iAccepts apiRequest)-      contentTypeH = (hContentType, cs $ show contentType) in--  case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of+  case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of+    Left errorResponse -> return errorResponse+    Right contentType ->+      case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of -    (ActionRead, TargetIdent qi, Nothing) ->-      case readSqlParts of-        Left e -> return $ responseLBS status400 [jsonH] $ cs e-        Right (q, cq) -> do-          let singular = iPreferSingular apiRequest-              stm = createReadStatement q cq singular-                    shouldCount (contentType == TextCSV)-          respondToRange $ do-            row <- H.query () stm-            let (tableTotal, queryTotal, _ , body) = row-            if singular-            then return $ if queryTotal <= 0-              then responseLBS status404 [] ""-              else responseLBS status200 [contentTypeH] (cs body)-            else do-              let (status, contentRange) = rangeHeader queryTotal tableTotal+        (ActionRead, TargetIdent qi, Nothing) ->+          case readSqlParts of+            Left errorResponse -> return errorResponse+            Right (q, cq) -> do+              let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount (contentType == CTTextCSV)+              row <- H.query () stm+              let (tableTotal, queryTotal, _ , body) = row+                  (status, contentRange) = rangeHeader queryTotal tableTotal                   canonical = iCanonicalQS apiRequest-              return $ responseLBS status-                [contentTypeH, contentRange,-                  ("Content-Location",-                    "/" <> cs (qiName qi) <>-                      if Prelude.null canonical then "" else "?" <> cs canonical-                  )-                ] (cs body)--    (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table),-     Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->-      case mutateSqlParts of-        Left e -> return $ responseLBS status400 [jsonH] $ cs e-        Right (sq,mq) -> do-          let isSingle = (==1) $ V.length rows-          let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?-          let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload-          row <- H.query uniform stm-          let (_, _, fs, body) = extractQueryResult row-              header =-                if null fs then []-                else [(hLocation, "/" <> cs table <> renderLocationFields fs)]+              return $+                if contentType == CTSingularJSON && queryTotal /= 1+                  then singularityError (toInteger queryTotal)+                  else responseLBS status+                    [toHeader contentType, contentRange,+                      ("Content-Location",+                        "/" <> toS (qiName qi) <>+                          if BS.null canonical then "" else "?" <> toS canonical+                      )+                    ] (toS body) -          return $ if iPreferRepresentation apiRequest == Full-            then responseLBS status201 (contentTypeH : header) (cs body)-            else responseLBS status201 header ""+        (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->+          case mutateSqlParts of+            Left errorResponse -> return errorResponse+            Right (sq, mq) -> do+              let isSingle = (==1) $ V.length rows+              if contentType == CTSingularJSON+                 && not isSingle+                 && iPreferRepresentation apiRequest == Full+                then return $ singularityError (toInteger $ V.length rows)+                else do+                  let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?+                      stm = createWriteStatement sq mq+                        (contentType == CTSingularJSON) isSingle+                        (contentType == CTTextCSV) (iPreferRepresentation apiRequest)+                        pKeys+                  row <- H.query payload stm+                  let (_, _, fs, body) = extractQueryResult row+                      headers = catMaybes [+                          if null fs+                            then Nothing+                            else Just (hLocation, "/" <> toS table <> renderLocationFields fs)+                        , if iPreferRepresentation apiRequest == Full+                            then Just $ toHeader contentType+                            else Nothing+                        , Just . contentRangeH 1 0 $+                            toInteger <$> if shouldCount then Just (V.length rows) else Nothing+                        ] -    (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) ->-      case mutateSqlParts of-        Left e -> return $ responseLBS status400 [jsonH] $ cs e-        Right (sq,mq) -> do-          let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload-          row <- H.query uniform stm-          let (_, queryTotal, _, body) = extractQueryResult row-              r = contentRangeH 0 (toInteger $ queryTotal-1) (toInteger <$> Just queryTotal)-              s = case () of _ | queryTotal == 0 -> status404-                               | iPreferRepresentation apiRequest == Full -> status200-                               | otherwise -> status204-          return $ if iPreferRepresentation apiRequest == Full-            then responseLBS s [contentTypeH, r] (cs body)-            else responseLBS s [r] ""+                  return . responseLBS status201 headers $+                    if iPreferRepresentation apiRequest == Full+                      then toS body else "" -    (ActionDelete, TargetIdent qi, Nothing) ->-      case mutateSqlParts of-        Left e -> return $ responseLBS status400 [jsonH] $ cs e-        Right (sq,mq) -> do-          let emptyUniform = UniformObjects V.empty-              fakeload = PayloadJSON emptyUniform-              stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload-          row <- H.query emptyUniform stm-          let (_, queryTotal, _, body) = extractQueryResult row-              r = contentRangeH 1 0 (toInteger <$> Just queryTotal)-          return $ if queryTotal == 0-            then notFound-            else if iPreferRepresentation apiRequest == Full-              then responseLBS status200 [contentTypeH, r] (cs body)-              else responseLBS status204 [r] ""+        (ActionUpdate, TargetIdent _, Just payload) ->+          case mutateSqlParts of+            Left errorResponse -> return errorResponse+            Right (sq, mq) -> do+              let stm = createWriteStatement sq mq+                    (contentType == CTSingularJSON) False (contentType == CTTextCSV)+                    (iPreferRepresentation apiRequest) []+              row <- H.query payload stm+              let (_, queryTotal, _, body) = extractQueryResult row+              if contentType == CTSingularJSON+                 && queryTotal /= 1+                 && iPreferRepresentation apiRequest == Full+                then do+                  HT.condemn+                  return $ singularityError (toInteger queryTotal)+                else do+                  let r = contentRangeH 0 (toInteger $ queryTotal-1)+                            (toInteger <$> if shouldCount then Just queryTotal else Nothing)+                      s = if iPreferRepresentation apiRequest == Full+                            then status200+                            else status204+                  return $ if iPreferRepresentation apiRequest == Full+                    then responseLBS s [toHeader contentType, r] (toS body)+                    else responseLBS s [r] "" -    (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->-      let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in-      case mTable of-        Nothing -> return notFound-        Just table ->-          let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure-              pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys-              body = encode (TableOptions cols pkeys)-              filterCol :: Schema -> TableName -> Column -> Bool-              filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb-              filterCol _ _ _ =  False-              acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in-          return $ responseLBS status200 [jsonH, allOrigins, acceptH] $ cs body+        (ActionDelete, TargetIdent _, Nothing) ->+          case mutateSqlParts of+            Left errorResponse -> return errorResponse+            Right (sq, mq) -> do+              let emptyPayload = PayloadJSON V.empty+                  stm = createWriteStatement sq mq+                    (contentType == CTSingularJSON) False+                    (contentType == CTTextCSV)+                    (iPreferRepresentation apiRequest) []+              row <- H.query emptyPayload stm+              let (_, queryTotal, _, body) = extractQueryResult row+                  r = contentRangeH 1 0 $+                        toInteger <$> if shouldCount then Just queryTotal else Nothing+              if contentType == CTSingularJSON+                 && queryTotal /= 1+                 && iPreferRepresentation apiRequest == Full+                then do+                  HT.condemn+                  return $ singularityError (toInteger queryTotal)+                else+                  return $ if iPreferRepresentation apiRequest == Full+                    then responseLBS status200 [toHeader contentType, r] (toS body)+                    else responseLBS status204 [r] "" -    (ActionInvoke, TargetProc qi,-     Just (PayloadJSON (UniformObjects payload))) -> do-      exists <- H.query qi doesProcExist-      if exists-        then do-          let p = V.head payload-              jwtSecret = configJwtSecret conf-          respondToRange $ do-            row <- H.query () (callProc qi p topLevelRange shouldCount)-            returnJWT <- H.query qi doesProcReturnJWT-            let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, emptyArray) row-                (status, contentRange) = rangeHeader queryTotal tableTotal-              in-              return $ responseLBS status [jsonH, contentRange]-                      (if returnJWT-                      then "{\"token\":\"" <> cs (tokenJWT jwtSecret body) <> "\"}"-                      else cs $ encode body)-        else return notFound+        (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->+          let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in+          case mTable of+            Nothing -> return notFound+            Just table ->+              let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in+              return $ responseLBS status200 [allOrigins, acceptH] "" -    (ActionRead, TargetRoot, Nothing) -> do-      body <- encode <$> H.query schema accessibleTables-      return $ responseLBS status200 [jsonH] $ cs body+        (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->+          case readSqlParts of+            Left errorResponse -> return errorResponse+            Right (q, cq) -> do+              let p = V.head payload+                  singular = contentType == CTSingularJSON+                  paramsAsSingleObject = iPreferSingleObjectParameter apiRequest+              row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular paramsAsSingleObject)+              let (tableTotal, queryTotal, body) =+                    fromMaybe (Just 0, 0, "[]") row+                  (status, contentRange) = rangeHeader queryTotal tableTotal+              if singular && queryTotal /= 1+                then do+                  HT.condemn+                  return $ singularityError (toInteger queryTotal)+                else return $ responseLBS status [jsonH, contentRange] (toS body) -    (ActionInappropriate, _, _) -> return $ responseLBS status405 [] ""+        (ActionInspect, TargetRoot, Nothing) -> do+          let host = configHost conf+              port = toInteger $ configPort conf+              proxy = pickProxy $ toS <$> configProxyUri conf+              uri Nothing = ("http", host, port, "/")+              uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)+              uri' = uri proxy+              encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri'+          body <- encodeApi . toTableInfo <$> H.query schema accessibleTables+          return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body -    (_, _, Just (PayloadParseError e)) ->-      return $ responseLBS status400 [jsonH] $-        cs (formatGeneralError "Cannot parse request payload" (cs e))+        _ -> return notFound -    (_, TargetUnknown _, _) -> return notFound+    where+      toTableInfo :: [Table] -> [(Table, [Column], [Text])]+      toTableInfo = map (\t ->+        let tSchema = tableSchema t+            tTable = tableName t+            cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure+            pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys+        in (t, cols, pkeys))+      notFound = responseLBS status404 [] ""+      filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk+      filterCol :: Schema -> TableName -> Column -> Bool+      filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb+      filterCol _ _ _ =  False+      allPrKeys = dbPrimaryKeys dbStructure+      allOrigins = ("Access-Control-Allow-Origin", "*") :: Header+      jsonH = toHeader CTApplicationJSON+      shouldCount = iPreferCount apiRequest+      schema = toS $ configSchema conf+      topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest+      rangeHeader queryTotal tableTotal =+        let lower = rangeOffset topLevelRange+            upper = lower + toInteger queryTotal - 1+            contentRange = contentRangeH lower upper (toInteger <$> tableTotal)+            status = rangeStatus lower upper (toInteger <$> tableTotal)+        in (status, contentRange) -    (_, _, _) -> return notFound+      mapSnd f (a, b) = (a, f b)+      readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest+      readDbRequest = DbRead <$> readReq+      mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< readReq)+      selectQuery = requestToQuery schema False <$> readDbRequest+      mutateQuery = requestToQuery schema False <$> mutateDbRequest+      countQuery = requestToCountQuery schema <$> readDbRequest+      readSqlParts = (,) <$> selectQuery <*> countQuery+      mutateSqlParts = (,) <$> selectQuery <*> mutateQuery - where-  notFound = responseLBS status404 [] ""-  filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk-  allPrKeys = dbPrimaryKeys dbStructure-  allOrigins = ("Access-Control-Allow-Origin", "*") :: Header-  schema = cs $ configSchema conf-  shouldCount = iPreferCount apiRequest-  topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest-  readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) apiRequest-  mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest-  selectQuery = requestToQuery schema <$> readDbRequest-  countQuery = requestToCountQuery schema <$> readDbRequest-  mutateQuery = requestToQuery schema <$> mutateDbRequest-  readSqlParts = (,) <$> selectQuery <*> countQuery-  mutateSqlParts = (,) <$> selectQuery <*> mutateQuery-  respondToRange response = if topLevelRange == emptyRange-                            then return $ errResponse status416 "HTTP Range error"-                            else response-  rangeHeader queryTotal tableTotal = let frm = rangeOffset topLevelRange-                                          to = frm + toInteger queryTotal - 1-                                          contentRange = contentRangeH frm to (toInteger <$> tableTotal)-                                          status = rangeStatus frm to (toInteger <$> tableTotal)-                                      in (status, contentRange)+responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType+responseContentTypeOrError accepts action = serves contentTypesForRequest accepts+  where+    contentTypesForRequest =+      case action of+        ActionRead ->    [CTApplicationJSON, CTSingularJSON, CTTextCSV]+        ActionCreate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]+        ActionUpdate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]+        ActionDelete ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]+        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON]+        ActionInspect -> [CTOpenAPI]+        ActionInfo ->    [CTTextCSV]+    serves sProduces cAccepts =+      case mutuallyAgreeable sProduces cAccepts of+        Nothing -> do+          let failed = intercalate ", " $ map (toS . toMime) cAccepts+          Left $ errResponse status415 $+            "None of these Content-Types are available: " <> failed+        Just ct -> Right ct  splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) splitKeyValue kv = (k, BS.tail v)@@ -253,186 +295,22 @@  rangeStatus :: Integer -> Integer -> Maybe Integer -> Status rangeStatus _ _ Nothing = status200-rangeStatus frm to (Just total)-  | frm > total            = status416-  | (1 + to - frm) < total = status206+rangeStatus lower upper (Just total)+  | lower > total            = status416+  | (1 + upper - lower) < total = status206   | otherwise               = status200  contentRangeH :: Integer -> Integer -> Maybe Integer -> Header-contentRangeH frm to total =-    ("Content-Range", cs headerValue)+contentRangeH lower upper total =+    ("Content-Range", headerValue)     where       headerValue   = rangeString <> "/" <> totalString       rangeString-        | totalNotZero && fromInRange = show frm <> "-" <> cs (show to)+        | totalNotZero && fromInRange = show lower <> "-" <> show upper         | otherwise = "*"       totalString   = fromMaybe "*" (show <$> total)       totalNotZero  = fromMaybe True ((/=) 0 <$> total)-      fromInRange   = frm <= to--jsonH :: Header-jsonH = (hContentType, "application/json; charset=utf-8")--formatRelationError :: Text -> Text-formatRelationError = formatGeneralError-  "could not find foreign keys between these entities"--formatParserError :: ParseError -> Text-formatParserError e = formatGeneralError message details-  where-     message = cs $ show (errorPos e)-     details = strip $ replace "\n" " " $ cs-       $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)--formatGeneralError :: Text -> Text -> Text-formatGeneralError message details = cs $ encode $ object [-  "message" .= message,-  "details" .= details]--augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either Text ReadRequest-augumentRequestWithJoin schema allRels request =-  (first formatRelationError . addRelations schema allRels Nothing) request-  >>= addJoinConditions schema--addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest)-addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [-    flip (foldr addFilter) <$> filters,-    flip (foldr addOrder) <$> orders,-    flip (foldr addRange) <$> ranges-  ]-  {--  The esence of what is going on above is that we are composing tree functions-  of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context-  -}-  where-    filters :: Either ParseError [(Path, Filter)]-    filters = mapM pRequestFilter flts-      where-        action = iAction apiRequest-        flts = if action == ActionRead-          then iFilters apiRequest-          else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update-    orders :: Either ParseError [(Path, [OrderTerm])]-    orders = mapM pRequestOrder $ iOrder apiRequest-    ranges :: Either ParseError [(Path, NonnegRange)]-    ranges = mapM pRequestRange $ M.toList $ iRange apiRequest--treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest-treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request-  where-    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode-    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)--buildReadRequest :: Maybe Integer -> [Relation] -> ApiRequest -> Either Text ReadRequest-buildReadRequest maxRows allRels apiRequest  =-  treeRestrictRange maxRows =<<-  augumentRequestWithJoin schema relations =<<-  first formatParserError readRequest-  where-    (schema, rootTableName) = fromJust $ -- Make it safe-      let target = iTarget apiRequest in-      case target of-        (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)-        _ -> Nothing--    action :: Action-    action = iAction apiRequest--    readRequest :: Either ParseError ReadRequest-    readRequest = addFiltersOrdersRanges apiRequest <*>-      parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr-      where-        selStr = iSelect apiRequest-        rootName = if action == ActionRead-          then rootTableName-          else sourceCTEName--    relations :: [Relation]-    relations = case action of-      ActionCreate -> fakeSourceRelations ++ allRels-      ActionUpdate -> fakeSourceRelations ++ allRels-      ActionDelete -> fakeSourceRelations ++ allRels-      _       -> allRels-      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation--buildMutateRequest :: ApiRequest -> Either Text MutateRequest-buildMutateRequest apiRequest = case action of-  ActionCreate -> Insert rootTableName <$> pure payload-  ActionUpdate -> Update rootTableName <$> pure payload <*> filters-  ActionDelete -> Delete rootTableName <$> filters-  _        -> Left "Unsupported HTTP verb"-  where-    action = iAction apiRequest-    payload = fromJust $ iPayload apiRequest-    rootTableName = -- TODO: Make it safe-      let target = iTarget apiRequest in-      case target of-        (TargetIdent (QualifiedIdentifier _ t) ) -> t-        _ -> undefined-    filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters-      where mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table--addFilterToNode :: Filter -> ReadRequest -> ReadRequest-addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f--addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest-addFilter = addProperty addFilterToNode--addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest-addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f--addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest-addOrder = addProperty addOrderToNode--addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest-addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f--addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest-addRange = addProperty addRangeToNode--addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest-addProperty f ([], a) n = f a n-addProperty f (path, a) (Node rn forest) =-  case targetNode of-    Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path-    Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest)-  where-    targetNodeName:remainingPath = path-    (targetNode,restForest) = splitForest targetNodeName forest-    splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode)-    splitForest name forst =-      case maybeNode of-        Nothing -> (Nothing,forest)-        Just node -> (Just node, delete node forest)-      where-        maybeNode :: Maybe ReadRequest-        maybeNode = find fnd forst-          where-            fnd :: ReadRequest -> Bool-            fnd (Node (_,(n,_,_)) _) = n == name---- in a relation where one of the tables mathces "TableName"--- replace the name to that table with pg_source--- this "fake" relations is needed so that in a mutate query--- we can look a the "returning *" part which is wrapped with a "with"--- as just another table that has relations with other tables-toSourceRelation :: TableName -> Relation -> Maybe Relation-toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)-  | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}-  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}-  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}-  | otherwise = Nothing--data TableOptions = TableOptions {-  tblOptcolumns :: [Column]-, tblOptpkey    :: [Text]-}--instance ToJSON TableOptions where-  toJSON t = object [-      "columns" .= tblOptcolumns t-    , "pkey"   .= tblOptpkey t ]-+      fromInRange   = lower <= upper  extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount extractQueryResult = fromMaybe (Nothing, 0, [], "")

@@ -16,19 +16,17 @@   , containsRole   , jwtClaims   , tokenJWT+  , JWTAttempt(..)   ) where -import           Lens.Micro-import           Lens.Micro.Aeson+import           Protolude+import           Control.Lens import           Data.Aeson              (Value (..), parseJSON, toJSON)+import           Data.Aeson.Lens import           Data.Aeson.Types        (parseMaybe, emptyObject, emptyArray)-import qualified Data.ByteString         as BS import qualified Data.Vector             as V import qualified Data.HashMap.Strict     as M-import           Data.Maybe              (fromMaybe, maybeToList, fromJust)-import           Data.Monoid             ((<>))-import           Data.String.Conversions (cs)-import           Data.Text               (Text)+import           Data.Maybe              (fromJust) import           Data.Time.Clock         (NominalDiffTime) import           PostgREST.QueryBuilder  (pgFmtIdent, pgFmtLit, unquoted) import qualified Web.JWT                 as JWT@@ -39,33 +37,44 @@   have a claim called role, this one is mapped to a SET ROLE   statement. -}-claimsToSQL :: M.HashMap Text Value -> [BS.ByteString]+claimsToSQL :: M.HashMap Text Value -> [ByteString] claimsToSQL claims = roleStmts <> varStmts  where   roleStmts = maybeToList $-    (\r -> "set local role " <> r <> ";") . cs . valueToVariable <$> M.lookup "role" claims+    (\r -> "set local role " <> r <> ";") . toS . valueToVariable <$> M.lookup "role" claims   varStmts = map setVar $ M.toList (M.delete "role" claims)-  setVar (k, val) = "set local " <> cs (pgFmtIdent $ "postgrest.claims." <> k)-                    <> " = " <> cs (valueToVariable val) <> ";"+  setVar (k, val) = "set local " <> toS (pgFmtIdent $ "request.jwt.claim." <> k)+                    <> " = " <> toS (valueToVariable val) <> ";"   valueToVariable = pgFmtLit . unquoted  {-|-  Receives the JWT secret (from config) and a JWT and-  returns a map of JWT claims-  In case there is any problem decoding the JWT it returns an error Text+  Possible situations encountered with client JWTs -}-jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> Either Text (M.HashMap Text Value)-jwtClaims _ "" _ = Right M.empty+data JWTAttempt = JWTExpired+                | JWTInvalid+                | JWTMissingSecret+                | JWTClaims (M.HashMap Text Value)+                deriving Eq++{-|+  Receives the JWT secret (from config) and a JWT and returns a map+  of JWT claims.+-}+jwtClaims :: Maybe JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt+jwtClaims _ "" _ = JWTClaims M.empty jwtClaims secret jwt time =-  case isExpired <$> mClaims of-    Just True -> Left "JWT expired"-    Nothing -> Left "Invalid JWT"-    Just False -> Right $ value2map $ fromJust mClaims+  case secret of+    Nothing -> JWTMissingSecret+    Just s ->+      let mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature s jwt in+      case isExpired <$> mClaims of+        Just True -> JWTExpired+        Nothing -> JWTInvalid+        Just False -> JWTClaims $ value2map $ fromJust mClaims  where   isExpired claims =     let mExp = claims ^? key "exp" . _Integer     in fromMaybe False $ (<= time) . fromInteger <$> mExp-  mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret jwt   value2map (Object o) = o   value2map _          = M.empty @@ -83,6 +92,6 @@ {-|   Whether a response from jwtClaims contains a role claim -}-containsRole :: Either Text (M.HashMap Text Value) -> Bool-containsRole (Left _) = False-containsRole (Right claims) = M.member "role" claims+containsRole :: JWTAttempt -> Bool+containsRole (JWTClaims claims) = M.member "role" claims+containsRole _ = False

@@ -2,12 +2,13 @@ Module      : PostgREST.Config Description : Manages PostgREST configuration options. -This module provides a helper function to read the command line arguments using the optparse-applicative-and the AppConfig type to store them.-It also can be used to define other middleware configuration that may be delegated to some sort of-external configuration.+This module provides a helper function to read the command line+arguments using the optparse-applicative and the AppConfig type to store+them.  It also can be used to define other middleware configuration that+may be delegated to some sort of external configuration. -It currently includes a hardcoded CORS policy but this could easly be turned in configurable behaviour if needed.+It currently includes a hardcoded CORS policy but this could easly be+turned in configurable behaviour if needed.  Other hardcoded options such as the minimum version number also belong here. -}@@ -15,49 +16,51 @@                         , readOptions                         , corsPolicy                         , minimumPgVersion+                        , PgVersion (..)                         , AppConfig (..)                         )        where +import           System.IO.Error             (IOError) import           Control.Applicative+import qualified Data.ByteString             as B import qualified Data.ByteString.Char8       as BS import qualified Data.CaseInsensitive        as CI-import           Data.List                   (intercalate)-import           Data.String.Conversions     (cs)-import           Data.Text                   (strip)+import qualified Data.Configurator           as C+import qualified Data.Configurator.Types     as C+import           Data.List                   (lookup)+import           Data.Text                   (strip, intercalate, lines)+import           Data.Text.Encoding          (encodeUtf8)+import           Data.Text.IO                (hPutStrLn) import           Data.Version                (versionBranch) import           Network.Wai import           Network.Wai.Middleware.Cors (CorsResourcePolicy (..))-import           Options.Applicative+import           Options.Applicative hiding  (str) import           Paths_postgrest             (version)-import           Prelude-import           Safe                        (readMay)-import           Web.JWT                     (Secret, secret)+import           Text.Heredoc+import           Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>)) --- | Data type to store all command line options+import           Protolude hiding            (intercalate+                                             , (<>))++-- | Config file settings for the server data AppConfig = AppConfig {-    configDatabase  :: String-  , configAnonRole  :: String-  , configSchema    :: String-  , configPort      :: Int-  , configJwtSecret :: Secret-  , configPool      :: Int-  , configMaxRows   :: Maybe Integer-  , configQuiet     :: Bool-  }+    configDatabase          :: Text+  , configAnonRole          :: Text+  , configProxyUri          :: Maybe Text+  , configSchema            :: Text+  , configHost              :: Text+  , configPort              :: Int -argParser :: Parser AppConfig-argParser = AppConfig-  <$> argument str (help "(REQUIRED) database connection string, e.g. postgres://user:pass@host:port/db" <> metavar "DB_URL")-  <*> strOption    (long "anonymous"  <> short 'a' <> help "(REQUIRED) postgres role to use for non-authenticated requests" <> metavar "ROLE")-  <*> strOption    (long "schema"     <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "public" <> showDefault)-  <*> option auto  (long "port"       <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault)-  <*> (secret . cs <$>-      strOption    (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault))-  <*> option auto  (long "pool"       <> short 'o' <> help "max connections in database pool" <> metavar "COUNT" <> value 10 <> showDefault)-  <*> (readMay <$> strOption  (long "max-rows"   <> short 'm' <> help "max rows in response" <> metavar "COUNT" <> value "infinity" <> showDefault))-  <*> pure False+  , configJwtSecret         :: Maybe B.ByteString+  , configJwtSecretIsBase64 :: Bool +  , configPool              :: Int+  , configMaxRows           :: Maybe Integer+  , configReqCheck          :: Maybe Text+  , configQuiet             :: Bool+  }+ defaultCorsPolicy :: CorsResourcePolicy defaultCorsPolicy =  CorsResourcePolicy Nothing   ["GET", "POST", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing@@ -78,26 +81,108 @@   where     headers = requestHeaders req     accHeaders = case lookup "access-control-request-headers" headers of-      Just hdrs -> map (CI.mk . cs . strip . cs) $ BS.split ',' hdrs+      Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs       Nothing -> []  -- | User friendly version number-prettyVersion :: String+prettyVersion :: Text prettyVersion = intercalate "." $ map show $ versionBranch version  -- | Function to read and parse options from the command line readOptions :: IO AppConfig-readOptions = customExecParser parserPrefs opts-  where-    opts = info (helper <*> argParser) $-                    fullDesc-                    <> progDesc (-                    "PostgREST "-                    <> prettyVersion-                    <> " / create a REST API to an existing Postgres database"-                    )-    parserPrefs = prefs showHelpOnError+readOptions = do+  -- First read the config file path from command line+  cfgPath <- customExecParser parserPrefs opts+  -- Now read the actual config file+  conf <- catch+    (C.load [C.Required cfgPath])+    configNotfoundHint +  handle missingKeyHint $ do+    -- db ----------------+    cDbUri    <- C.require conf "db-uri"+    cDbSchema <- C.require conf "db-schema"+    cDbAnon   <- C.require conf "db-anon-role"+    cPool     <- C.lookupDefault 10 conf "db-pool"+    -- server ------------+    cHost     <- C.lookupDefault "*4" conf "server-host"+    cPort     <- C.lookupDefault 3000 conf "server-port"+    cProxy    <- C.lookup conf "server-proxy-uri"+    -- jwt ---------------+    cJwtSec   <- C.lookup conf "jwt-secret"+    cJwtB64   <- C.lookupDefault False conf "secret-is-base64"+    -- safety ------------+    cMaxRows  <- C.lookup conf "max-rows"+    cReqCheck <- C.lookup conf "pre-request"++    return $ AppConfig cDbUri cDbAnon cProxy cDbSchema cHost cPort+          (encodeUtf8 <$> cJwtSec) cJwtB64 cPool cMaxRows cReqCheck False++ where+  opts = info (helper <*> pathParser) $+           fullDesc+           <> progDesc (+               "PostgREST "+               <> toS prettyVersion+               <> " / create a REST API to an existing Postgres database"+             )+           <> footerDoc (Just $+               text "Example Config File:"+               <> nest 2 (hardline <> exampleCfg)+             )++  parserPrefs = prefs showHelpOnError++  configNotfoundHint :: IOError -> IO a+  configNotfoundHint e = do+    hPutStrLn stderr $+      "Cannot open config file:\n\t" <> show e+    exitFailure++  missingKeyHint :: C.KeyError -> IO a+  missingKeyHint (C.KeyError n) = do+    hPutStrLn stderr $+      "Required config parameter \"" <> n <> "\" is missing or of wrong type.\n" <>+      "Try the --example-config option to see how to configure PostgREST."+    exitFailure++  exampleCfg :: Doc+  exampleCfg = vsep . map (text . toS) . lines $+    [str|db-uri = "postgres://user:pass@localhost:5432/dbname"+        |db-schema = "public"+        |db-anon-role = "postgres"+        |db-pool = 10+        |+        |server-host = "*4"+        |server-port = 3000+        |+        |## base url for swagger output+        |# server-proxy-uri = ""+        |+        |## choose a secret to enable JWT auth+        |## (use "@filename" to load from separate file)+        |# jwt-secret = "foo"+        |# secret-is-base64 = false+        |+        |## limit rows in response+        |# max-rows = 1000+        |+        |## stored proc to exec immediately after auth+        |# pre-request = "stored_proc_name"+        |]+++pathParser :: Parser FilePath+pathParser =+  strArgument $+    metavar "FILENAME" <>+    help "Path to configuration file"++data PgVersion = PgVersion {+  pgvNum  :: Int32+, pgvName :: Text+}+ -- | Tells the minimum PostgreSQL version required by this version of PostgREST-minimumPgVersion :: Integer-minimumPgVersion = 90300+minimumPgVersion :: PgVersion+minimumPgVersion = PgVersion 90300 "9.3"

@@ -0,0 +1,275 @@+{-# LANGUAGE FlexibleContexts #-}+module PostgREST.DbRequestBuilder (+  readRequest+, mutateRequest+) where++import           Control.Applicative+import           Control.Lens.Getter       (view)+import           Control.Lens.Tuple        (_1)+import qualified Data.ByteString.Char8     as BS+import           Data.List                 (delete, lookup)+import           Data.Maybe                (fromJust)+import           Data.Text                 (isInfixOf, dropWhile, drop)+import           Data.Tree+import           Data.Either.Combinators   (mapLeft)++import           Text.Parsec.Error++import           Network.HTTP.Types.Status+import           Network.Wai++import           Data.Foldable (foldr1)+import qualified Data.HashMap.Strict       as M++import           PostgREST.ApiRequest   ( ApiRequest(..) +                                        , Action(..), Target(..)+                                        , PreferRepresentation (..)+                                        )+import           PostgREST.Error           (errResponse, formatParserError)+import           PostgREST.Parsers+import           PostgREST.RangeQuery      (NonnegRange, restrictRange)+import           PostgREST.QueryBuilder (getJoinConditions, sourceCTEName)+import           PostgREST.Types++import           Protolude                hiding (from, dropWhile, drop)+import           Text.Regex.TDFA         ((=~))+import           Unsafe                  (unsafeHead)++readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest+readRequest maxRows allRels allProcs apiRequest  =+  mapLeft (errResponse status400) $+  treeRestrictRange maxRows =<<+  augumentRequestWithJoin schema relations =<<+  first formatParserError parseReadRequest+  where+    (schema, rootTableName) = fromJust $ -- Make it safe+      let target = iTarget apiRequest in+      case target of+        (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)+        (TargetProc  (QualifiedIdentifier s p) ) -> Just (s, t)+          where+            returnType = fromMaybe "" $ lookup p allProcs+            -- we are looking for results looking like "SETOF schema.tablename" and want to extract tablename+            t = if "SETOF " `isInfixOf` returnType+              then drop 1 $ dropWhile (/= '.') returnType+              else p++        _ -> Nothing++    action :: Action+    action = iAction apiRequest++    parseReadRequest :: Either ParseError ReadRequest+    parseReadRequest = addFiltersOrdersRanges apiRequest <*>+      pRequestSelect rootName selStr+      where+        selStr = iSelect apiRequest+        rootName = if action == ActionRead+          then rootTableName+          else sourceCTEName++    relations :: [Relation]+    relations = case action of+      ActionCreate -> fakeSourceRelations ++ allRels+      ActionUpdate -> fakeSourceRelations ++ allRels+      ActionDelete -> fakeSourceRelations ++ allRels+      ActionInvoke -> fakeSourceRelations ++ allRels+      _       -> allRels+      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation++treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest+treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request+  where+    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode+    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)++augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either Text ReadRequest+augumentRequestWithJoin schema allRels request =+  (first formatRelationError . addRelations schema allRels Nothing) request+  >>= addJoinConditions schema+  where+    formatRelationError = ("could not find foreign keys between these entities, " <>)++addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest+addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) =+  case parentNode of+    (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) ->+      Node <$> readNode' <*> forest'+      where+        forest' = updateForest $ hush node'+        node' = Node <$> readNode' <*> pure forest+        readNode' = addRel readNode <$> rel+        rel :: Either Text Relation+        rel = note ("no relation between " <> parentNodeTable <> " and " <> name)+            $ findRelation schema name parentNodeTable++            where+              findRelation s nodeTableName parentNodeTableName =+                find (\r ->+                  s == tableSchema (relTable r) && -- match schema for relation table+                  s == tableSchema (relFTable r) && -- match schema for relation foriegn table+                  (++                    -- (request)        => projects { ..., clients{...} }+                    -- will match+                    -- (relation type)  => parent+                    -- (entity)         => clients  {id}+                    -- (foriegn entity) => projects {client_id}+                    (+                      nodeTableName == tableName (relTable r) && -- match relation table name+                      parentNodeTableName == tableName (relFTable r) -- match relation foreign table name+                    ) ||+++                    -- (request)        => projects { ..., client_id{...} }+                    -- will match+                    -- (relation type)  => parent+                    -- (entity)         => clients  {id}+                    -- (foriegn entity) => projects {client_id}+                    (+                      parentNodeTableName == tableName (relFTable r) &&+                      length (relFColumns r) == 1 &&+                      nodeTableName `colMatches` (colName . unsafeHead . relFColumns) r+                    )++                    -- (request)        => project_id { ..., client_id{...} }+                    -- will match+                    -- (relation type)  => parent+                    -- (entity)         => clients  {id}+                    -- (foriegn entity) => projects {client_id}+                    -- this case works becasue before reaching this place+                    -- addRelation will turn project_id to project so the above condition will match+                  )+                ) allRelations+                where n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString)+        addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))+        addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a))+          where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query')++    _ -> n' <$> updateForest (Just (n' forest))+      where+        n' = Node (query, (name, Just r, alias))+        t = Table schema name True -- !!! TODO find another way to get the table from the query+        r = Relation t [] t [] Root Nothing Nothing Nothing+  where+    updateForest :: Maybe ReadRequest -> Either Text [ReadRequest]+    updateForest n = mapM (addRelations schema allRelations n) forest++addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest+addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =+  case r of+    Just Relation{relType=Root} -> Node nn  <$> updatedForest -- this is the root node+    Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest+    Just Relation{relType=Parent} -> Node nn <$> updatedForest+    Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->+      Node (qq, (n, r, a)) <$> updatedForest+      where+         query' = addCond query (getJoinConditions rel)+         qq = query'{from=tableName linkTable : from query'}+    _ -> Left "unknown relation"+  where+    updatedForest = mapM (addJoinConditions schema) forest+    addCond query' con = query'{flt_=con ++ flt_ query'}++addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest)+addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [+    flip (foldr addFilter) <$> filters,+    flip (foldr addOrder) <$> orders,+    flip (foldr addRange) <$> ranges+  ]+  {-+  The esence of what is going on above is that we are composing tree functions+  of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context+  -}+  where+    filters :: Either ParseError [(Path, Filter)]+    filters = mapM pRequestFilter flts+      where+        action = iAction apiRequest+        flts+          | action == ActionRead = iFilters apiRequest+          | action == ActionInvoke = iFilters apiRequest+          | otherwise = filter (( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update+    orders :: Either ParseError [(Path, [OrderTerm])]+    orders = mapM pRequestOrder $ iOrder apiRequest+    ranges :: Either ParseError [(Path, NonnegRange)]+    ranges = mapM pRequestRange $ M.toList $ iRange apiRequest++addFilterToNode :: Filter -> ReadRequest -> ReadRequest+addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f++addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest+addFilter = addProperty addFilterToNode++addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest+addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f++addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest+addOrder = addProperty addOrderToNode++addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest+addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f++addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest+addRange = addProperty addRangeToNode++addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest+addProperty f ([], a) n = f a n+addProperty f (path, a) (Node rn forest) =+  case targetNode of+    Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path+    Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest)+  where+    targetNodeName:remainingPath = path+    (targetNode,restForest) = splitForest targetNodeName forest+    splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode)+    splitForest name forst =+      case maybeNode of+        Nothing -> (Nothing,forest)+        Just node -> (Just node, delete node forest)+      where+        maybeNode :: Maybe ReadRequest+        maybeNode = find fnd forst+          where+            fnd :: ReadRequest -> Bool+            fnd (Node (_,(n,_,_)) _) = n == name++-- in a relation where one of the tables mathces "TableName"+-- replace the name to that table with pg_source+-- this "fake" relations is needed so that in a mutate query+-- we can look a the "returning *" part which is wrapped with a "with"+-- as just another table that has relations with other tables+toSourceRelation :: TableName -> Relation -> Maybe Relation+toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)+  | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}+  | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}+  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}+  | otherwise = Nothing++mutateRequest :: ApiRequest -> ReadRequest -> Either Response MutateRequest+mutateRequest apiRequest readReq = mapLeft (errResponse status400) $+  case action of+    ActionCreate -> Right $ Insert rootTableName payload returnings+    ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings+    ActionDelete -> Delete rootTableName <$> filters <*> pure returnings+    _        -> Left "Unsupported HTTP verb"+  where+    action = iAction apiRequest+    payload = fromJust $ iPayload apiRequest+    rootTableName = -- TODO: Make it safe+      let target = iTarget apiRequest in+      case target of+        (TargetIdent (QualifiedIdentifier _ t) ) -> t+        _ -> undefined+    fieldNames :: ReadRequest -> PreferRepresentation -> [FieldName]+    fieldNames _ None = []+    fieldNames (Node (sel, _) forest) _ =+      map (fst . view _1) (select sel) ++ map colName fks+      where+        fks = concatMap (fromMaybe [] . f) forest+        f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _)) _) = Just cols+        f _ = Nothing+    returnings = fieldNames readReq (iPreferRepresentation apiRequest) +    filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters+      where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table

@@ -6,8 +6,6 @@ module PostgREST.DbStructure (   getDbStructure , accessibleTables-, doesProcExist-, doesProcReturnJWT ) where  import qualified Hasql.Decoders                as HD@@ -15,21 +13,18 @@ import qualified Hasql.Query                   as H  import           Control.Applicative-import           Control.Monad                 (join, replicateM)-import           Data.Functor.Contravariant    (contramap)-import           Data.List                     (elemIndex, find, sort,-                                                subsequences, transpose)-import           Data.Maybe                    (fromJust, fromMaybe, isJust,-                                                listToMaybe, mapMaybe)-import           Data.Monoid-import           Data.Text                     (Text, split)+import           Data.List                     (elemIndex)+import           Data.Maybe                    (fromJust)+import           Data.Text                     (split, strip,+                                                breakOn, dropAround)+import qualified Data.Text                     as T import qualified Hasql.Session                 as H import           PostgREST.Types import           Text.InterpolatedString.Perl6 (q) -import           Data.Int                      (Int32) import           GHC.Exts                      (groupWith)-import           Prelude+import           Protolude+import           Unsafe (unsafeHead)  getDbStructure :: Schema -> H.Session DbStructure getDbStructure schema = do@@ -38,6 +33,7 @@   syns <- H.query () $ allSynonyms cols   rels <- H.query () $ allRelations tabs cols   keys <- H.query () $ allPrimaryKeys tabs+  procs <- H.query schema accessibleProcs    let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels       cols' = addForeignKeys rels' cols@@ -48,13 +44,9 @@     , dbColumns = cols'     , dbRelations = rels'     , dbPrimaryKeys = keys'+    , dbProcs = procs     } -encodeQi :: HE.Params QualifiedIdentifier-encodeQi =-  contramap qiSchema (HE.value HE.text) <>-  contramap qiName   (HE.value HE.text)- decodeTables :: HD.Result [Table] decodeTables =   HD.rowsList tblRow@@ -104,33 +96,37 @@     <*> HD.value HD.text <*> HD.value HD.text     <*> HD.value HD.text <*> HD.value HD.text -doesProcExist :: H.Query QualifiedIdentifier Bool-doesProcExist =-  H.statement sql encodeQi (HD.singleRow (HD.value HD.bool)) True+accessibleProcs :: H.Query Schema [(Text, ProcDescription)]+accessibleProcs =+  H.statement sql (HE.value HE.text)+    (map addName <$> HD.rowsList (ProcDescription <$> HD.value HD.text+                                <*> (parseArgs <$> HD.value HD.text)+                                <*> HD.value HD.text)) True  where-  sql = [q| SELECT EXISTS (-      SELECT 1-      FROM   pg_catalog.pg_namespace n-      JOIN   pg_catalog.pg_proc p-      ON     pronamespace = n.oid-      WHERE  nspname = $1-      AND    proname = $2-    ) |]+  addName :: ProcDescription -> (Text, ProcDescription)+  addName pd = (pdName pd, pd) -doesProcReturnJWT :: H.Query QualifiedIdentifier Bool-doesProcReturnJWT =-  H.statement sql encodeQi (HD.singleRow (HD.value HD.bool)) True- where-  sql = [q| SELECT EXISTS (-      SELECT 1-      FROM   pg_catalog.pg_namespace n-      JOIN   pg_catalog.pg_proc p-      ON     pronamespace = n.oid-      WHERE  nspname = $1-      AND    proname = $2-      AND    pg_catalog.pg_get_function_result(p.oid) like '%jwt_claims'-    ) |]+  parseArgs :: Text -> [PgArg]+  parseArgs = mapMaybe (parseArg . strip) . split (==',') +  parseArg :: Text -> Maybe PgArg+  parseArg a =+    let (body, def) = breakOn " DEFAULT " a+        (name, typ) = breakOn " " body in+    if T.null typ+       then Nothing+       else Just $+         PgArg (dropAround (== '"') name) (strip typ) (T.null def)++  sql = [q|+    SELECT p.proname as "proc_name",+           pg_get_function_arguments(p.oid) as "args",+           pg_get_function_result(p.oid) as "return_type"+    FROM   pg_namespace n+    JOIN   pg_proc p+    ON     pronamespace = n.oid+    WHERE  n.nspname = $1|]+ accessibleTables :: H.Query Schema [Table] accessibleTables =   H.statement sql (HE.value HE.text) decodeTables True@@ -161,7 +157,9 @@ synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]] synonymousColumns allSyns cols = synCols'   where-    syns = sort $ filter ((== colTable (head cols)) . colTable . fst) allSyns+    syns = case headMay cols of+            Just firstCol -> sort $ filter ((== colTable firstCol) . colTable . fst) allSyns+            Nothing -> []     synCols  = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols     synCols' = (filter sameTable . filter matchLength) synCols     matchLength cs = length cols == length cs@@ -175,11 +173,10 @@     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+    relToFk col Relation{relColumns=cols, relFColumns=colsF} = do+      pos <- elemIndex col cols+      colF <- atMay colsF pos+      return $ ForeignKey colF  addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation] addSynonymousRelations _ [] = []@@ -187,7 +184,7 @@   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+    synRels cols mapFn = map (\cs -> mapFn (colTable $ unsafeHead cs) cs) $ synonymousColumns syns cols  addParentRelations :: [Relation] -> [Relation] addParentRelations [] = []@@ -220,8 +217,8 @@       where         cols = relFColumns rel         table = relFTable rel-        newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . head) (synonymousColumns syns cols)-        newTable = (colTable . head) <$> newCols+        newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . unsafeHead) (synonymousColumns syns cols)+        newTable = (colTable . unsafeHead) <$> newCols  synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey] synonymousPrimaryKeys _ [] = []@@ -289,13 +286,13 @@                         CASE                             WHEN bt.typelem <> 0::oid AND bt.typlen = (-1) THEN 'ARRAY'::text                             WHEN nbt.nspname = 'pg_catalog'::name THEN format_type(t.typbasetype, NULL::integer)-                            ELSE 'USER-DEFINED'::text+                            ELSE format_type(a.atttypid, a.atttypmod)                         END                         ELSE                         CASE                             WHEN t.typelem <> 0::oid AND t.typlen = (-1) THEN 'ARRAY'::text                             WHEN nt.nspname = 'pg_catalog'::name THEN format_type(a.atttypid, NULL::integer)-                            ELSE 'USER-DEFINED'::text+                            ELSE format_type(a.atttypid, a.atttypmod)                         END                     END::information_schema.character_data AS data_type,                 information_schema._pg_char_max_length(information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*))::information_schema.cardinal_number AS character_maximum_length,@@ -560,73 +557,73 @@  where   -- query explanation at https://gist.github.com/ruslantalpa/2eab8c930a65e8043d8f   sql = [q|-    WITH view_columns AS (-    	SELECT-    		c.oid AS view_oid,-    		a.attname::information_schema.sql_identifier AS column_name-    	FROM pg_attribute a-    	JOIN pg_class c ON a.attrelid = c.oid-    	JOIN pg_namespace nc ON c.relnamespace = nc.oid-    	WHERE-    		NOT pg_is_other_temp_schema(nc.oid)-    		AND a.attnum > 0-    		AND NOT a.attisdropped-    		AND (c.relkind = 'v'::"char")-    		AND nc.nspname NOT IN ('information_schema', 'pg_catalog')+    with view_columns as (+        select+            c.oid as view_oid,+            a.attname::information_schema.sql_identifier as column_name+        from pg_attribute a+        join pg_class c on a.attrelid = c.oid+        join pg_namespace nc on c.relnamespace = nc.oid+        where+            not pg_is_other_temp_schema(nc.oid)+            and a.attnum > 0+            and not a.attisdropped+            and (c.relkind = 'v'::"char")+            and nc.nspname not in ('information_schema', 'pg_catalog')     ),-    view_column_usage AS (-    	SELECT DISTINCT-    		v.oid as view_oid,-    		nv.nspname::information_schema.sql_identifier AS view_schema,-    		v.relname::information_schema.sql_identifier AS view_name,-    		nt.nspname::information_schema.sql_identifier AS table_schema,-    		t.relname::information_schema.sql_identifier AS table_name,-    		a.attname::information_schema.sql_identifier AS column_name,-    		pg_get_viewdef(v.oid)::information_schema.character_data AS view_definition-    	FROM pg_namespace nv-    	JOIN pg_class v ON nv.oid = v.relnamespace-    	JOIN pg_depend dv ON v.oid = dv.refobjid-    	JOIN pg_depend dt ON dv.objid = dt.objid-    	JOIN pg_class t ON dt.refobjid = t.oid-    	JOIN pg_namespace nt ON t.relnamespace = nt.oid-    	JOIN pg_attribute a ON t.oid = a.attrelid AND dt.refobjsubid = a.attnum+    view_column_usage as (+        select distinct+            v.oid as view_oid,+            nv.nspname::information_schema.sql_identifier as view_schema,+            v.relname::information_schema.sql_identifier as view_name,+            nt.nspname::information_schema.sql_identifier as table_schema,+            t.relname::information_schema.sql_identifier as table_name,+            a.attname::information_schema.sql_identifier as column_name,+            pg_get_viewdef(v.oid)::information_schema.character_data as view_definition+        from pg_namespace nv+        join pg_class v on nv.oid = v.relnamespace+        join pg_depend dv on v.oid = dv.refobjid+        join pg_depend dt on dv.objid = dt.objid+        join pg_class t on dt.refobjid = t.oid+        join pg_namespace nt on t.relnamespace = nt.oid+        join pg_attribute a on t.oid = a.attrelid and dt.refobjsubid = a.attnum -    	WHERE-    		nv.nspname not in ('information_schema', 'pg_catalog')-    		AND v.relkind = 'v'::"char"-    		AND dv.refclassid = 'pg_class'::regclass::oid-    		AND dv.classid = 'pg_rewrite'::regclass::oid-    		AND dv.deptype = 'i'::"char"-    		AND dv.refobjid <> dt.refobjid-    		AND dt.classid = 'pg_rewrite'::regclass::oid-    		AND dt.refclassid = 'pg_class'::regclass::oid-    		AND (t.relkind = ANY (ARRAY['r'::"char", 'v'::"char", 'f'::"char"]))+        where+            nv.nspname not in ('information_schema', 'pg_catalog')+            and v.relkind = 'v'::"char"+            and dv.refclassid = 'pg_class'::regclass::oid+            and dv.classid = 'pg_rewrite'::regclass::oid+            and dv.deptype = 'i'::"char"+            and dv.refobjid <> dt.refobjid+            and dt.classid = 'pg_rewrite'::regclass::oid+            and dt.refclassid = 'pg_class'::regclass::oid+            and (t.relkind = any (array['r'::"char", 'v'::"char", 'f'::"char"]))     ),-    candidates AS (-    	SELECT-    		vcu.*,-    		(-    			SELECT CASE WHEN match IS NOT NULL THEN coalesce(match[7], match[4]) END-    			FROM REGEXP_MATCHES(-    				CONCAT('SELECT ', SPLIT_PART(vcu.view_definition, 'SELECT', 2)),-    				CONCAT('SELECT.*?((',vcu.table_name,')|(\w+))\.(', vcu.column_name, ')(\sAS\s(")?([^"]+)\6)?.*?FROM.*?',vcu.table_schema,'\.(\2|',vcu.table_name,'\s+(AS\s)?\3)'),-    				'ns'-    			) match-    		) AS view_column_name-    	FROM view_column_usage AS vcu+    candidates as (+        select+            vcu.*,+            (+                select case when match is not null then coalesce(match[8], match[7], match[4]) end+                from regexp_matches(+                    CONCAT('SELECT ', SPLIT_PART(vcu.view_definition, 'SELECT', 2)),+                    CONCAT('SELECT.*?((',vcu.table_name,')|(\w+))\.(', vcu.column_name, ')(\s+AS\s+("([^"]+)"|([^, \n\t]+)))?.*?FROM.*?',vcu.table_schema,'\.(\2|',vcu.table_name,'\s+(as\s)?\3)'),+                    'nsi'+                ) match+            ) as view_column_name+        from view_column_usage as vcu     )-    SELECT-    	c.table_schema,-    	c.table_name,-    	c.column_name AS table_column_name,-    	c.view_schema,-    	c.view_name,-    	c.view_column_name-    FROM view_columns AS vc, candidates AS c-    WHERE-    	vc.view_oid = c.view_oid AND-    	vc.column_name = c.view_column_name-    ORDER BY c.view_schema, c.view_name, c.table_name, c.view_column_name+    select+        c.table_schema,+        c.table_name,+        c.column_name as table_column_name,+        c.view_schema,+        c.view_name,+        c.view_column_name+    from view_columns as vc, candidates as c+    where+        vc.view_oid = c.view_oid+        and vc.column_name = c.view_column_name+    order by c.view_schema, c.view_name, c.table_name, c.view_column_name     |]  synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column)

@@ -2,74 +2,108 @@ {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.Error (pgErrResponse, errResponse) where-+module PostgREST.Error (apiRequestErrResponse, pgErrResponse, errResponse, prettyUsageError, singularityError, formatGeneralError, formatParserError) where +import           Protolude import           Data.Aeson                ((.=)) import qualified Data.Aeson                as JSON-import           Data.Maybe                (fromMaybe)-import           Data.Monoid               ((<>))-import           Data.String.Conversions   (cs)-import           Data.Text                 (Text)-import qualified Data.Text                 as T+import           Data.Text                 (replace, strip, unwords) import qualified Hasql.Pool                as P import qualified Hasql.Session             as H-import           Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT import           Network.Wai               (Response, responseLBS)+import           PostgREST.ApiRequest      (toHeader, toMime, ContentType(..), ApiRequestError(..))+import           Text.Parsec.Error +apiRequestErrResponse :: ApiRequestError -> Response+apiRequestErrResponse err =+  case err of+    ErrorActionInappropriate -> errResponse HT.status405 "Bad Request"+    ErrorInvalidBody errorMessage -> errResponse HT.status400 $ toS errorMessage+    ErrorInvalidRange -> errResponse HT.status416 "HTTP Range error"+ errResponse :: HT.Status -> Text -> Response-errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"])+errResponse status message = jsonErrResponse status $ JSON.object ["message" .= message] +jsonErrResponse :: HT.Status -> JSON.Value -> Response+jsonErrResponse status message = responseLBS status [toHeader CTApplicationJSON] $ JSON.encode message+ pgErrResponse :: Bool -> P.UsageError -> Response pgErrResponse authed e =   let status = httpStatus authed e-      jsonType = (hContentType, "application/json")+      jsonType = toHeader CTApplicationJSON       wwwAuth = ("WWW-Authenticate", "Bearer")       hdrs = if status == HT.status401                 then [jsonType, wwwAuth]                 else [jsonType] in   responseLBS status hdrs (JSON.encode e) +prettyUsageError :: P.UsageError -> Text+prettyUsageError (P.ConnectionError e) =+  "Database connection error:\n" <> toS (fromMaybe "" e)+prettyUsageError e = show $ JSON.encode e++singularityError :: Integer -> Response+singularityError numRows =+  responseLBS HT.status406+    [toHeader CTSingularJSON]+    $ toS . formatGeneralError+      "JSON object requested, multiple (or no) rows returned"+      $ unwords+        [ "Results contain", show numRows, "rows,"+        , toS (toMime CTSingularJSON), "requires 1 row"+        ]++formatParserError :: ParseError -> Text+formatParserError e = formatGeneralError message details+  where+     message = show $ errorPos e+     details = strip $ replace "\n" " " $ toS+       $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)++formatGeneralError :: Text -> Text -> Text+formatGeneralError message details = toS . JSON.encode $+  JSON.object ["message" .= message, "details" .= details]+ instance JSON.ToJSON P.UsageError where   toJSON (P.ConnectionError e) = JSON.object [-    "code" .= ("" :: T.Text),-    "message" .= ("Connection error" :: T.Text),-    "details" .= (cs (fromMaybe "" e) :: T.Text)]+    "code" .= ("" :: Text),+    "message" .= ("Connection error" :: Text),+    "details" .= (toS $ fromMaybe "" e :: Text)]   toJSON (P.SessionError e) = JSON.toJSON e -- H.Error  instance JSON.ToJSON H.Error where   toJSON (H.ResultError (H.ServerError c m d h)) = JSON.object [-    "code" .= (cs c::T.Text),-    "message" .= (cs m::T.Text),-    "details" .= (fmap cs d::Maybe T.Text),-    "hint" .= (fmap cs h::Maybe T.Text)]+    "code" .= (toS c::Text),+    "message" .= (toS m::Text),+    "details" .= (fmap toS d::Maybe Text),+    "hint" .= (fmap toS h::Maybe Text)]   toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [-    "message" .= (cs m::T.Text)]+    "message" .= (m::Text)]   toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [-    "message" .= ("Row error: end of input"::String),+    "message" .= ("Row error: end of input"::Text),     "details" .=-      ("Attempt to parse more columns than there are in the result"::String),-    "details" .= ("Row number " <> show i)]+      ("Attempt to parse more columns than there are in the result"::Text),+    "details" .= (("Row number " <> show i)::Text)]   toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [-    "message" .= ("Row error: unexpected null"::String),-    "details" .= ("Attempt to parse a NULL as some value."::String),-    "details" .= ("Row number " <> show i)]+    "message" .= ("Row error: unexpected null"::Text),+    "details" .= ("Attempt to parse a NULL as some value."::Text),+    "details" .= (("Row number " <> show i)::Text)]   toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [-    "message" .= ("Row error: Wrong value parser used"::String),+    "message" .= ("Row error: Wrong value parser used"::Text),     "details" .= d,-    "details" .= ("Row number " <> show i)]+    "details" .= (("Row number " <> show i)::Text)]   toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [-    "message" .= ("Unexpected amount of rows"::String),+    "message" .= ("Unexpected amount of rows"::Text),     "details" .= i]   toJSON (H.ClientError d) = JSON.object [-    "message" .= ("Database client error"::String),-    "details" .= (fmap cs d::Maybe T.Text)]+    "message" .= ("Database client error"::Text),+    "details" .= (fmap toS d::Maybe Text)]  httpStatus :: Bool -> P.UsageError -> HT.Status httpStatus _ (P.ConnectionError _) = HT.status500 httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =-  case cs c of+  case toS c of     '0':'8':_ -> HT.status503 -- pg connection err     '0':'9':_ -> HT.status500 -- triggered action exception     '0':'L':_ -> HT.status403 -- invalid grantor@@ -90,8 +124,10 @@     '5':'8':_ -> HT.status500 -- system error     'F':'0':_ -> HT.status500 -- conf file error     'H':'V':_ -> HT.status500 -- foreign data wrapper error+    "P0001"   -> HT.status400 -- default code for "raise"     'P':'0':_ -> HT.status500 -- PL/pgSQL Error     'X':'X':_ -> HT.status500 -- internal Error+    "42883"   -> HT.status404 -- undefined function     "42P01"   -> HT.status404 -- undefined table     "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege     _         -> HT.status400

@@ -5,49 +5,51 @@  import           Data.Aeson                    (Value (..)) import qualified Data.HashMap.Strict           as M-import           Data.String.Conversions       (cs)-import           Data.Text import qualified Hasql.Transaction             as H -import           Network.HTTP.Types.Header     (hAccept)-import           Network.HTTP.Types.Status     (status400, status415)-import           Network.Wai                   (Application, Request (..),-                                                Response, requestHeaders)+import           Network.HTTP.Types.Status     (unauthorized401, status500)+import           Network.Wai                   (Application, Response,+                                                responseLBS) import           Network.Wai.Middleware.Cors   (cors) import           Network.Wai.Middleware.Gzip   (def, gzip) import           Network.Wai.Middleware.Static (only, staticPolicy) -import           PostgREST.ApiRequest          (ApiRequest(..), pickContentType)-import           PostgREST.Auth                (claimsToSQL)+import           PostgREST.ApiRequest          (ApiRequest(..), ContentType(..),+                                                toHeader)+import           PostgREST.Auth                (claimsToSQL, JWTAttempt(..)) import           PostgREST.Config              (AppConfig (..), corsPolicy) import           PostgREST.Error               (errResponse) -import           Prelude                       hiding (concat, null)+import           Protolude                     hiding (concat, null) -runWithClaims :: AppConfig -> Either Text (M.HashMap Text Value) ->+runWithClaims :: AppConfig -> JWTAttempt ->                  (ApiRequest -> H.Transaction Response) ->                  ApiRequest -> H.Transaction Response runWithClaims conf eClaims app req =   case eClaims of-    Left e -> clientErr e-    Right claims -> do-          -- role claim defaults to anon if not specified in jwt-          H.sql . mconcat . claimsToSQL $ M.union claims (M.singleton "role" anon)-          app req+    JWTExpired -> return $ unauthed "JWT expired"+    JWTInvalid -> return $ unauthed "JWT invalid"+    JWTMissingSecret -> return $ errResponse status500 "Server lacks JWT secret"+    JWTClaims claims -> do+      -- role claim defaults to anon if not specified in jwt+      let setClaims = claimsToSQL (M.union claims (M.singleton "role" anon))+      H.sql $ mconcat setClaims+      mapM_ H.sql customReqCheck+      app req   where-    anon = String . cs $ configAnonRole conf-    clientErr = return . errResponse status400--unsupportedAccept :: Application -> Application-unsupportedAccept app req respond =-  case accept of-    Left _ -> respond $ errResponse status415 "Unsupported Accept header, try: application/json"-    Right _ -> app req respond-  where accept = pickContentType $ lookup hAccept $ requestHeaders req+    anon = String . toS $ configAnonRole conf+    customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf+    unauthed message = responseLBS unauthorized401+      [ toHeader CTApplicationJSON+      , ( "WWW-Authenticate"+        , "Bearer error=\"invalid_token\", " <>+          "error_description=\"" <> message <> "\""+        )+      ]+      (toS $ "{\"message\":\""<>message<>"\"}")  defaultMiddle :: Application -> Application defaultMiddle =     gzip def   . cors corsPolicy   . staticPolicy (only [("favicon.ico", "static/favicon.ico")])-  . unsupportedAccept

@@ -0,0 +1,357 @@+{-# LANGUAGE OverloadedStrings #-}++module PostgREST.OpenAPI (+  encodeOpenAPI+  , isMalformedProxyUri+  , pickProxy+  ) where++import           Control.Lens+import           Data.Aeson                  (decode, encode)+import           Data.HashMap.Strict.InsOrd  (InsOrdHashMap, fromList)+import           Data.Maybe                  (fromJust)+import           Data.String                 (IsString (..))+import           Data.Text                   (unpack, pack, concat, intercalate, init, tail, toLower)+import qualified Data.Set                    as Set+import           Network.URI                 (parseURI, isAbsoluteURI,+                                              URI (..), URIAuth (..))++import           Protolude hiding              (concat, (&), Proxy, get, intercalate)++import           Data.Swagger++import           PostgREST.ApiRequest        (ContentType(..), toMime)+import           PostgREST.Config            (prettyVersion)+import           PostgREST.QueryBuilder      (operators)+import           PostgREST.Types             (Table(..), Column(..), PgArg(..),+                                              Proxy(..), ProcDescription(..))++makeMimeList :: [ContentType] -> MimeList+makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs++toSwaggerType :: Text -> SwaggerType t+toSwaggerType "text"      = SwaggerString+toSwaggerType "integer"   = SwaggerInteger+toSwaggerType "boolean"   = SwaggerBoolean+toSwaggerType "numeric"   = SwaggerNumber+toSwaggerType _           = SwaggerString++makeTableDef :: (Table, [Column], [Text]) -> (Text, Schema)+makeTableDef (t, cs, _) =+  let tn = tableName t in+      (tn, (mempty :: Schema)+        & type_ .~ SwaggerObject+        & properties .~ fromList (map makeProperty cs))++makeProperty :: Column -> (Text, Referenced Schema)+makeProperty c = (colName c, Inline u)+  where+    r = mempty :: Schema+    s = if null $ colEnum c+           then r+           else r & enum_ .~ decode (encode (colEnum c))+    t = s & type_ .~ toSwaggerType (colType c)+    u = t & format ?~ colType c++makeProcDef :: ProcDescription -> (Text, Schema)+makeProcDef pd = ("(rpc) " <> pdName pd, s)+  where+    s = (mempty :: Schema)+          & type_ .~ SwaggerObject+          & properties .~ fromList (map makeProcProperty (pdArgs pd))+          & required .~ map pgaName (filter pgaReq (pdArgs pd))++makeProcProperty :: PgArg -> (Text, Referenced Schema)+makeProcProperty (PgArg n t _) = (n, Inline s)+  where+    s = (mempty :: Schema)+          & type_ .~ toSwaggerType t+          & format ?~ t++makeOperatorPattern :: Text+makeOperatorPattern =+  intercalate "|"+  [ concat ["^", x, y, "[.]"] |+    x <- ["not[.]", ""],+    y <- map fst operators ]++makeRowFilter :: Column -> Param+makeRowFilter c =+  (mempty :: Param)+  & name .~ colName c+  & required ?~ False+  & schema .~ ParamOther ((mempty :: ParamOtherSchema)+    & in_ .~ ParamQuery+    & type_ .~ SwaggerString+    & format ?~ colType c+    & pattern ?~ makeOperatorPattern)++makeRowFilters :: [Column] -> [Param]+makeRowFilters = map makeRowFilter++makeOrderItems :: [Column] -> [Text]+makeOrderItems cs =+  [ concat [x, y, z] |+    x <- map colName cs,+    y <- [".asc", ".desc", ""],+    z <- [".nullsfirst", ".nulllast", ""]+  ]++makeRangeParams :: [Param]+makeRangeParams =+  [ (mempty :: Param)+    & name        .~ "Range"+    & description ?~ "Limiting and Pagination"+    & required    ?~ False+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)+      & in_ .~ ParamHeader+      & type_ .~ SwaggerString)+  , (mempty :: Param)+    & name        .~ "Range-Unit"+    & description ?~ "Limiting and Pagination"+    & required    ?~ False+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)+      & in_ .~ ParamHeader+      & type_ .~ SwaggerString+      & default_ .~ decode "\"items\"")+  , (mempty :: Param)+    & name        .~ "offset"+    & description ?~ "Limiting and Pagination"+    & required    ?~ False+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)+      & in_ .~ ParamQuery+      & type_ .~ SwaggerString)+  , (mempty :: Param)+    & name        .~ "limit"+    & description ?~ "Limiting and Pagination"+    & required    ?~ False+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)+      & in_ .~ ParamQuery+      & type_ .~ SwaggerString)+  ]++makePreferParam :: [Text] -> Param+makePreferParam ts =+  (mempty :: Param)+  & name        .~ "Prefer"+  & description ?~ "Preference"+  & required    ?~ False+  & schema .~ ParamOther ((mempty :: ParamOtherSchema)+    & in_ .~ ParamHeader+    & type_ .~ SwaggerString+    & enum_ .~ decode (encode ts))++makeSelectParam :: Param+makeSelectParam =+  (mempty :: Param)+    & name        .~ "select"+    & description ?~ "Filtering Columns"+    & required    ?~ False+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)+      & in_ .~ ParamQuery+      & type_ .~ SwaggerString)++makeGetParams :: [Column] -> [Param]+makeGetParams [] =+  makeRangeParams +++  [ makeSelectParam+  , makePreferParam ["count=none"]+  ]+makeGetParams cs =+  makeRangeParams +++  [ makeSelectParam+  , (mempty :: Param)+    & name        .~ "order"+    & description ?~ "Ordering"+    & required    ?~ False+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)+      & in_ .~ ParamQuery+      & type_ .~ SwaggerString+      & enum_ .~ decode (encode $ makeOrderItems cs))+  , makePreferParam ["count=none"]+  ]++makePostParams :: Text -> [Param]+makePostParams tn =+  [ makePreferParam ["return=representation",+                     "return=minimal", "return=none"]+  , (mempty :: Param)+    & name        .~ "body"+    & description ?~ tn+    & required    ?~ False+    & schema .~ ParamBody (Ref (Reference tn))+  ]++makeProcParam :: Text -> [Param]+makeProcParam refName =+  [ makePreferParam ["params=single-object"]+  , (mempty :: Param)+    & name     .~ "args"+    & required ?~ True+    & schema   .~ ParamBody (Ref (Reference refName))+  ]++makeDeleteParams :: [Param]+makeDeleteParams =+  [ makePreferParam ["return=representation", "return=minimal", "return=none"] ]++makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)+makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)+  where+    tOp = (mempty :: Operation)+      & tags .~ Set.fromList [tn]+      & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]+      & at 200 ?~ "OK"+    getOp = tOp+      & parameters .~ map Inline (makeGetParams cs ++ rs)+      & at 206 ?~ "Partial Content"+    postOp = tOp+      & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]+      & parameters .~ map Inline (makePostParams tn)+      & at 201 ?~ "Created"+    patchOp = tOp+      & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]+      & parameters .~ map Inline (makePostParams tn ++ rs)+      & at 204 ?~ "No Content"+    deletOp = tOp+      & parameters .~ map Inline (makeDeleteParams ++ rs)+    pr = (mempty :: PathItem) & get ?~ getOp+    pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp+    p False = pr+    p True  = pw+    rs = makeRowFilters cs+    tn = tableName t++makeProcPathItem :: ProcDescription -> (FilePath, PathItem)+makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)+  where+    postOp = (mempty :: Operation)+      & parameters .~ map Inline (makeProcParam $ "(rpc) " <> pdName pd)+      & tags .~ Set.fromList ["(rpc) " <> pdName pd]+      & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON]+      & at 200 ?~ "OK"+    pe = (mempty :: PathItem) & post ?~ postOp++makeRootPathItem :: (FilePath, PathItem)+makeRootPathItem = ("/", p)+  where+    getOp = (mempty :: Operation)+      & tags .~ Set.fromList ["/"]+      & produces ?~ makeMimeList [CTOpenAPI]+      & at 200 ?~ "OK"+    pr = (mempty :: PathItem) & get ?~ getOp+    p = pr++makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem+makePathItems pds ti = fromList $ makeRootPathItem :+  map makePathItem ti ++ map makeProcPathItem pds++escapeHostName :: Text -> Text+escapeHostName "*"  = "0.0.0.0"+escapeHostName "*4" = "0.0.0.0"+escapeHostName "!4" = "0.0.0.0"+escapeHostName "*6" = "0.0.0.0"+escapeHostName "!6" = "0.0.0.0"+escapeHostName h    = h++postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Swagger+postgrestSpec pds ti (s, h, p, b) = (mempty :: Swagger)+  & basePath ?~ unpack b+  & schemes ?~ [s']+  & info .~ ((mempty :: Info)+      & version .~ prettyVersion+      & title .~ "PostgREST API"+      & description ?~ "This is a dynamic API generated by PostgREST")+  & host .~ h'+  & definitions .~ fromList (map makeTableDef ti <> map makeProcDef pds)+  & paths .~ makePathItems pds ti+    where+      s' = if s == "http" then Http else Https+      h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))++encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> LByteString+encodeOpenAPI pds ti uri = encode $ postgrestSpec pds ti uri++{-|+  Test whether a proxy uri is malformed or not.+  A valid proxy uri should be an absolute uri without query and user info,+  only http(s) schemes are valid, port number range is 1-65535.++  For example+  http://postgrest.com/openapi.json+  https://postgrest.com:8080/openapi.json+-}+isMalformedProxyUri :: Maybe Text -> Bool+isMalformedProxyUri Nothing =  False+isMalformedProxyUri (Just uri)+  | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri+  | otherwise = True++toURI :: Text -> URI+toURI uri = fromJust $ parseURI (toS uri)++pickProxy :: Maybe Text -> Maybe Proxy+pickProxy proxy+  | isNothing proxy = Nothing+  -- should never happen+  -- since the request would have been rejected by the middleware if proxy uri+  -- is malformed+  | isMalformedProxyUri proxy = Nothing+  | otherwise = Just Proxy {+    proxyScheme = scheme+  , proxyHost = host'+  , proxyPort = port''+  , proxyPath = path'+  }+ where+   uri = toURI $ fromJust proxy+   scheme = init $ toLower $ pack $ uriScheme uri+   path URI {uriPath = ""} =  "/"+   path URI {uriPath = p} = p+   path' = pack $ path uri+   authority = fromJust $ uriAuthority uri+   host' = pack $ uriRegName authority+   port' = uriPort authority+   readPort = fromMaybe 80 . readMaybe+   port'' :: Integer+   port'' = case (port', scheme) of+             ("", "http") -> 80+             ("", "https") -> 443+             _ -> readPort $ unpack $ tail $ pack port'++isUriValid:: URI -> Bool+isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]++fAnd :: [a -> Bool] -> a -> Bool+fAnd fs x = all ($x) fs++isSchemeValid :: URI -> Bool+isSchemeValid URI {uriScheme = s}+  | toLower (pack s) == "https:" = True+  | toLower (pack s) == "http:" = True+  | otherwise = False++isQueryValid :: URI -> Bool+isQueryValid URI {uriQuery = ""} = True+isQueryValid _ = False++isAuthorityValid :: URI -> Bool+isAuthorityValid URI {uriAuthority = a}+  | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a+  | otherwise = False++isUserInfoValid :: URIAuth -> Bool+isUserInfoValid URIAuth {uriUserInfo = ""} = True+isUserInfoValid _ = False++isHostValid :: URIAuth -> Bool+isHostValid URIAuth {uriRegName = ""} = False+isHostValid _ = True++isPortValid :: URIAuth -> Bool+isPortValid URIAuth {uriPort = ""} = True+isPortValid URIAuth {uriPort = (':':p)} =+  case readMaybe p of+    Just i -> i > (0 :: Integer) && i < 65536+    Nothing -> False+isPortValid _ = False

@@ -1,69 +1,68 @@-module PostgREST.Parsers--- ( parseGetRequest--- )-where+module PostgREST.Parsers where -import           Control.Applicative           hiding ((<$>))-import           Data.Monoid-import           Data.String.Conversions       (cs)-import           Data.Text                     (Text, intercalate)+import           Protolude                     hiding (try, intercalate)+import           Control.Monad                ((>>))+import           Data.Text                     (intercalate)+import           Data.List                     (init, last) import           Data.Tree import           PostgREST.QueryBuilder        (operators) import           PostgREST.Types import           Text.ParserCombinators.Parsec hiding (many, (<|>)) import           PostgREST.RangeQuery      (NonnegRange,allRange) -pRequestSelect :: Text -> Parser ReadRequest-pRequestSelect rootNodeName = do-  fieldTree <- pFieldForest-  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree-  where-    readQuery = Select [] [rootNodeName] [] Nothing allRange-    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest-    treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =-      case fldForest of-        [] -> Node (q {select=fld:select q}, i) rForest-        _  -> Node (q, i) newForest-          where-            newForest =-              foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest+pRequestSelect :: Text -> Text -> Either ParseError ReadRequest+pRequestSelect rootName selStr = +  parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) -pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)+pRequestFilter :: (Text, Text) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)   where-    treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k-    opVal = parse pOpValueExp ("failed to parse filter (" ++ v ++ ")") v+    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k+    opVal = parse pOpValueExp ("failed to parse filter (" ++ toS v ++ ")") $ toS v     path = fst <$> treePath     fld = snd <$> treePath     op = fst <$> opVal     val = snd <$> opVal -pRequestOrder :: (String, String) -> Either ParseError (Path, [OrderTerm])-pRequestOrder (k, v) = (,) <$> path <*> ord+pRequestOrder :: (Text, Text) -> Either ParseError (Path, [OrderTerm])+pRequestOrder (k, v) = (,) <$> path <*> ord'   where-    treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k+    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k     path = fst <$> treePath-    ord = parse pOrder ("failed to parse order (" ++ v ++ ")") v+    ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v -pRequestRange :: (String, NonnegRange) -> Either ParseError (Path, NonnegRange)+pRequestRange :: (ByteString, NonnegRange) -> Either ParseError (Path, NonnegRange) pRequestRange (k, v) = (,) <$> path <*> pure v   where-    treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k+    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k     path = fst <$> treePath  ws :: Parser Text-ws = cs <$> many (oneOf " \t")+ws = toS <$> many (oneOf " \t")  lexeme :: Parser a -> Parser a lexeme p = ws *> p <* ws +pReadRequest :: Text -> Parser ReadRequest+pReadRequest rootNodeName = do+  fieldTree <- pFieldForest+  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree+  where+    readQuery = Select [] [rootNodeName] [] Nothing allRange+    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest+    treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =+      case fldForest of+        [] -> Node (q {select=fld:select q}, i) rForest+        _  -> Node (q, i) newForest+          where+            newForest =+              foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest+ pTreePath :: Parser (Path,Field) pTreePath = do   p <- pFieldName `sepBy1` pDelimiter   jp <- optionMaybe pJsonPath-  let pp = map cs p-      jpp = map cs <$> jp-  return (init pp, (last pp, jpp))+  return (init p, (last p, jp))  pFieldForest :: Parser [Tree SelectItem] pFieldForest = pFieldTree `sepBy1` lexeme (char ',')@@ -73,13 +72,13 @@           <|>     Node <$> pSelect <*> pure []  pStar :: Parser Text-pStar = cs <$> (string "*" *> pure ("*"::String))+pStar = toS <$> (string "*" *> pure ("*"::ByteString))   pFieldName :: Parser Text pFieldName = do   matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"-  return $ intercalate "-" $ map cs matches+  return $ intercalate "-" $ map toS matches   where     isDash :: GenParser Char st ()     isDash = try ( char '-' >> notFollowedBy (char '>') )@@ -88,10 +87,10 @@   pJsonPathStep :: Parser Text-pJsonPathStep = cs <$> try (string "->" *> pFieldName)+pJsonPathStep = toS <$> try (string "->" *> pFieldName)  pJsonPath :: Parser [Text]-pJsonPath = (++) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) )+pJsonPath = (<>) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) )  pField :: Parser Field pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath@@ -112,25 +111,25 @@     do       alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )       fld <- pField-      cast <- optionMaybe (string "::" *> many letter)-      return (fld, cs <$> cast, alias)+      cast' <- optionMaybe (string "::" *> many letter)+      return (fld, toS <$> cast', alias)   )   <|> do     s <- pStar     return ((s, Nothing), Nothing, Nothing)  pOperator :: Parser Operator-pOperator = cs <$> (pOp <?> "operator (eq, gt, ...)")-  where pOp = foldl (<|>) empty $ map (try . string . cs . fst) operators+pOperator = toS <$> (pOp <?> "operator (eq, gt, ...)")+  where pOp = foldl (<|>) empty $ map (try . string . toS . fst) operators  pValue :: Parser FValue-pValue = VText <$> (cs <$> many anyChar)+pValue = VText <$> (toS <$> many anyChar)  pDelimiter :: Parser Char pDelimiter = char '.' <?> "delimiter (.)"  pOperatiorWithNegation :: Parser Operator-pOperatiorWithNegation = try ( (<>) <$> ( cs <$> string "not." ) <*>  pOperator) <|> pOperator+pOperatiorWithNegation = try ( (<>) <$> ( toS <$> string "not." ) <*>  pOperator) <|> pOperator  pOpValueExp :: Parser (Operator, FValue) pOpValueExp = (,) <$> pOperatiorWithNegation <*> (pDelimiter *> pValue)@@ -141,14 +140,15 @@ pOrderTerm :: Parser OrderTerm pOrderTerm =   try ( do-    c <- pFieldName-    _ <- pDelimiter-    d <- (string "asc" *> pure OrderAsc)-         <|> (string "desc" *> pure OrderDesc)+    c <- pField+    d <- optionMaybe (try $ pDelimiter *> (+               try(string "asc" *> pure OrderAsc)+           <|> try(string "desc" *> pure OrderDesc)+         ))     nls <- optionMaybe (pDelimiter *> (                  try(string "nullslast" *> pure OrderNullsLast)              <|> try(string "nullsfirst" *> pure OrderNullsFirst)            ))     return $ OrderTerm c d nls   )-  <|> OrderTerm <$> (cs <$> pFieldName) <*> pure OrderAsc <*> pure Nothing+  <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing

@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE TupleSections        #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-|@@ -13,11 +12,10 @@ Any function that outputs a SQL fragment should be in this module. -} module PostgREST.QueryBuilder (-    addRelations-  , addJoinConditions-  , callProc+    callProc   , createReadStatement   , createWriteStatement+  , getJoinConditions   , operators   , pgFmtIdent   , pgFmtLit@@ -33,32 +31,24 @@ import qualified Hasql.Decoders          as HD  import qualified Data.Aeson              as JSON-import           Data.Int                (Int64)  import           PostgREST.RangeQuery    (NonnegRange, rangeLimit, rangeOffset, allRange)-import           Control.Error           (note, fromMaybe) import           Data.Functor.Contravariant (contramap) import qualified Data.HashMap.Strict     as HM-import           Data.List               (find)-import           Data.Monoid             ((<>))-import           Data.Text               (Text, intercalate, unwords, replace, isInfixOf, toLower, split)+import           Data.Text               (intercalate, unwords, replace, isInfixOf, toLower, split) import qualified Data.Text as T          (map, takeWhile, null) import qualified Data.Text.Encoding as T-import           Data.String.Conversions (cs)-import           Control.Applicative     ((<|>))-import           Control.Monad           (replicateM) import           Data.Tree               (Tree(..)) import qualified Data.Vector as V import           PostgREST.Types import qualified Data.Map as M import           Text.InterpolatedString.Perl6 (qc)-import           Text.Regex.TDFA         ((=~)) import qualified Data.ByteString.Char8   as BS import           Data.Scientific         ( FPFormat (..)                                          , formatScientific                                          , isInteger                                          )-import           Prelude hiding          (unwords)+import           Protolude hiding        (from, intercalate, ord, cast) import           PostgREST.ApiRequest    (PreferRepresentation (..))  {-| The generic query result format used by API responses. The location header@@ -89,25 +79,25 @@   HD.maybeRow standardRow  {-| JSON and CSV payloads from the client are given to us as-    UniformObjects (objects who all have the same keys),+    PayloadJSON (objects who all have the same keys),     and we turn this into an old fasioned JSON array -}-encodeUniformObjs :: HE.Params UniformObjects+encodeUniformObjs :: HE.Params PayloadJSON encodeUniformObjs =-  contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json)+  contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json)  createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->                        H.Query () ResultsWithCount createReadStatement selectQuery countQuery isSingle countTotal asCsv =-  unicodeStatement sql HE.unit decodeStandard True+  unicodeStatement sql HE.unit decodeStandard False  where   sql = [qc|       WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}-      FROM ( SELECT * FROM {sourceCTEName}) t |]+      FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |]   countResultF = if countTotal then "("<>countQuery<>")" else "null"   cols = intercalate ", " [       countResultF <> " AS total_result_set",-      "pg_catalog.count(t) AS page_total",+      "pg_catalog.count(_postgrest_t) AS page_total",       noLocationF <> " AS header",       bodyF <> " AS body"     ]@@ -116,116 +106,78 @@     | isSingle = asJsonSingleF     | otherwise = asJsonF -createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool ->-                        PreferRepresentation -> [Text] -> Bool -> Payload ->-                        H.Query UniformObjects (Maybe ResultsWithCount)-createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined-createWriteStatement _ _ mutateQuery _ None-                     _ _ (PayloadJSON (UniformObjects _)) =+createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->+                        PreferRepresentation -> [Text] ->+                        H.Query PayloadJSON (Maybe ResultsWithCount)+createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys =   unicodeStatement sql encodeUniformObjs decodeStandardMay True+  where-  sql = [qc|+  sql = case rep of+    None -> [qc|       WITH {sourceCTEName} AS ({mutateQuery})       SELECT '', 0, {noLocationF}, '' |]--createWriteStatement qi _ mutateQuery isSingle HeadersOnly-                     pKeys _ (PayloadJSON (UniformObjects _)) =-  unicodeStatement sql encodeUniformObjs decodeStandardMay True- where-  sql = [qc|-      WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)+    HeadersOnly -> [qc|+      WITH {sourceCTEName} AS ({mutateQuery})       SELECT {cols}-      FROM (SELECT 1 FROM {sourceCTEName}) t |]-  cols = intercalate ", " [-      "'' AS total_result_set",-      "pg_catalog.count(t) AS page_total",-      if isSingle then locationF pKeys else noLocationF,-      "''"-    ]--createWriteStatement qi selectQuery mutateQuery isSingle Full-                     pKeys asCsv (PayloadJSON (UniformObjects _)) =-  unicodeStatement sql encodeUniformObjs decodeStandardMay True- where-  sql = [qc|-      WITH {sourceCTEName} AS ({mutateQuery} RETURNING {fromQi qi}.*)+      FROM (SELECT 1 FROM {sourceCTEName}) _postgrest_t |]+    Full -> [qc|+      WITH {sourceCTEName} AS ({mutateQuery})       SELECT {cols}-      FROM ({selectQuery}) t |]+      FROM ({selectQuery}) _postgrest_t |]+   cols = intercalate ", " [       "'' AS total_result_set", -- when updateing it does not make sense-      "pg_catalog.count(t) AS page_total",-      if isSingle then locationF pKeys else noLocationF <> " AS header",-      bodyF <> " AS body"+      "pg_catalog.count(_postgrest_t) AS page_total",+      if wantHdrs+         then locationF pKeys+         else noLocationF <> " AS header",+      if rep == Full+         then bodyF <> " AS body"+         else "''"     ]+   bodyF     | asCsv = asCsvF-    | isSingle = asJsonSingleF+    | wantSingle = asJsonSingleF     | otherwise = asJsonF -addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest-addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _, alias)) forest) =-  case parentNode of-    (Just (Node (Select{from=[parentTable]}, (_, _, _)) _)) -> Node <$> (addRel readNode <$> rel) <*> updatedForest-      where-        rel = note ("no relation between " <> parentTable <> " and " <> name)-            $  findRelationByTable schema name parentTable-           <|> findRelationByColumn schema parentTable name-        addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))-        addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a))-          where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query')--    _ -> Node (query, (name, Nothing, alias)) <$> updatedForest-  where-    updatedForest = mapM (addRelations schema allRelations (Just node)) forest-    -- Searches through all the relations and returns a match given the parameter conditions.-    -- Will only find a relation where both schemas are in the PostgREST schema.-    -- `findRelationByColumn` also does a ducktype check to see if the column name has any variation of `id` or `fk`. If so then the relation is returned as a match.-    findRelationByTable s t1 t2 =-      find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t1 == tableName (relTable r) && t2 == tableName (relFTable r)) allRelations-    findRelationByColumn s t c =-      find (\r -> s == tableSchema (relTable r) && s == tableSchema (relFTable r) && t == tableName (relFTable r) && length (relFColumns r) == 1 && c `colMatches` (colName . head . relFColumns) r) allRelations-      where n `colMatches` rc = (cs ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (cs n :: BS.ByteString)--addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest-addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =-  case r of-    Nothing -> Node nn  <$> updatedForest -- this is the root node-    Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest-    Just Relation{relType=Parent} -> Node nn <$> updatedForest-    Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->-      Node (qq, (n, r, a)) <$> updatedForest-      where-         query' = addCond query (getJoinConditions rel)-         qq = query'{from=tableName linkTable : from query'}-    _ -> Left "unknown relation"-  where-    updatedForest = mapM (addJoinConditions schema) forest-    addCond query' con = query'{flt_=con ++ flt_ query'}--type ProcResults = (Maybe Int64, Int64, JSON.Value)-callProc :: QualifiedIdentifier -> JSON.Object -> NonnegRange -> Bool -> H.Query () (Maybe ProcResults)-callProc qi params range countTotal =+type ProcResults = (Maybe Int64, Int64, ByteString)+callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults)+callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson =   unicodeStatement sql HE.unit decodeProc True   where     sql = [qc|-            WITH t AS (select * {_callSql})+            WITH {sourceCTEName} AS ({_callSql})             SELECT-              {_countExpr} as countTotal,-              pg_catalog.count(1) as countResult,-              array_to_json(-                coalesce(array_agg(row_to_json(r)), '\{}')-              )::character varying-            FROM (select * from t {limitF range}) r;+              {countResultF} AS total_result_set,+              pg_catalog.count(_postgrest_t) AS page_total,+              case+                when pg_catalog.count(*) > 1 then+                  {bodyF}+                else+                  coalesce(((array_agg(row_to_json(_postgrest_t)))[1]->{_procName})::character varying, {bodyF})++              end as body+            FROM ({selectQuery}) _postgrest_t;           |]-    _args = intercalate "," $ map _assignment (HM.toList params)+          -- FROM (select * from {sourceCTEName} {limitF range}) t;+    countResultF = if countTotal then "("<>countQuery<>")" else "null::bigint" :: Text+    _args = if paramsAsJson+                then insertableValueWithType "json" $ JSON.Object params+                else intercalate "," $ map _assignment (HM.toList params)+    _procName = pgFmtLit $ qiName qi     _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v-    _callSql = [qc| from {fromQi qi}({_args}) |] :: Text+    _callSql = [qc|select * from {fromQi qi}({_args}) |] :: Text     _countExpr = if countTotal-                   then "(select pg_catalog.count(1) from t)"+                   then [qc|(select pg_catalog.count(*) from {sourceCTEName})|]                    else "null::bigint" :: Text     decodeProc = HD.maybeRow procRow     procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8-                   <*> HD.value HD.json+                   <*> HD.value HD.bytea+    bodyF+     | isSingle = asJsonSingleF+     | otherwise = asJsonF  operators :: [(Text, SqlFragment)] operators = [@@ -247,7 +199,7 @@   ]  pgFmtIdent :: SqlFragment -> SqlFragment-pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ cs x) <> "\""+pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\""  pgFmtLit :: SqlFragment -> SqlFragment pgFmtLit x =@@ -262,22 +214,23 @@ requestToCountQuery _ (DbMutate _) = undefined requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _, _)) _)) =  unwords [-   "SELECT pg_catalog.count(1)",-   "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,-   ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions+   "SELECT pg_catalog.count(*)",+   "FROM ", fromQi qi,+   ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi) localConditions )) `emptyOnNull` localConditions    ]  where+   qi = if mainTbl == sourceCTEName+     then QualifiedIdentifier "" mainTbl+     else QualifiedIdentifier schema mainTbl    fn Filter{value=VText _} = True    fn Filter{value=VForeignKey _ _} = False    localConditions = filter fn conditions -requestToQuery :: Schema -> DbRequest -> SqlQuery-requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined-requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined-requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) =+requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery+requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) =   query   where-    -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name+    -- TODO! the following helper functions are just to remove the "schema" part when the table is "source" which is the name     -- of our WITH query part     mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)     tblSchema tbl = if tbl == sourceCTEName then "" else schema@@ -289,7 +242,7 @@       unwords joins,       ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,       orderF (fromMaybe [] ord),-      limitF range+      if isParent then "" else limitF range       ]     orderF ts =         if null ts@@ -299,9 +252,9 @@             clause = intercalate "," (map queryTerm ts)             queryTerm :: OrderTerm -> Text             queryTerm t = " "-                <> cs (pgFmtColumn qi $ otTerm t) <> " "-                <> (cs.show) (otDirection t) <> " "-                <> maybe "" (cs.show) (otNullOrder t) <> " "+                <> toS (pgFmtField qi $ otTerm t) <> " "+                <> maybe "" show (otDirection t) <> " "+                <> maybe "" show (otNullOrder t) <> " "     (joins, selects) = foldr getQueryParts ([],[]) forest      getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])@@ -311,7 +264,7 @@            <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "            <> "FROM (" <> subquery <> ") " <> pgFmtIdent table            <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)-           where subquery = requestToQuery schema (DbRead (Node n forst))+           where subquery = requestToQuery schema False (DbRead (Node n forst))     getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (joi:j,sel:s)       where         node_name = fromMaybe name alias@@ -321,31 +274,34 @@         sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name         joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name  <>               " ON " <> intercalate " AND " ( map (pgFmtCondition qi . replaceTableName local_table_name) (getJoinConditions r) )-          where subquery = requestToQuery schema (DbRead (Node n forst))+          where subquery = requestToQuery schema True (DbRead (Node n forst))     getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s)       where         sel = "COALESCE (("            <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "            <> "FROM (" <> subquery <> ") " <> pgFmtIdent table            <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)-           where subquery = requestToQuery schema (DbRead (Node n forst))+           where subquery = requestToQuery schema False (DbRead (Node n forst))     --the following is just to remove the warning     --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only     --posible relations are Child Parent Many-    getQueryParts (Node (_,(_,Nothing,_)) _) _ = undefined-requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) =-  let qi = QualifiedIdentifier schema mainTbl-      cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))-      colsString = intercalate ", " cols-      insInto = unwords [ "INSERT INTO" , fromQi qi,-          if T.null colsString then "" else "(" <> colsString <> ")"-        ]-      vals = unwords $ if T.null colsString-                then ["DEFAULT VALUES"]-                else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] in-  insInto <> vals--requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) =+    getQueryParts _ _ = undefined+requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) =+  insInto <> vals <> ret+  where qi = QualifiedIdentifier schema mainTbl+        cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))+        colsString = intercalate ", " cols+        insInto = unwords [ "INSERT INTO" , fromQi qi,+            if T.null colsString then "" else "(" <> colsString <> ")"+          ]+        vals = unwords $+          if T.null colsString+            then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"]+            else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"]+        ret = if null returnings +                  then ""+                  else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)]+requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions returnings)) =   case rows V.!? 0 of     Just obj ->       let assignments = map@@ -353,18 +309,20 @@       unwords [         "UPDATE ", fromQi qi,         " SET " <> intercalate "," assignments <> " ",-        ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions+        ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,+        ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnNull` returnings         ]     Nothing -> undefined   where     qi = QualifiedIdentifier schema mainTbl-requestToQuery schema (DbMutate (Delete mainTbl conditions)) =+requestToQuery schema _ (DbMutate (Delete mainTbl conditions returnings)) =   query   where     qi = QualifiedIdentifier schema mainTbl     query = unwords [       "DELETE FROM ", fromQi qi,-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,+      ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnNull` returnings       ]  sourceCTEName :: SqlFragment@@ -373,9 +331,9 @@ unquoted :: JSON.Value -> Text unquoted (JSON.String t) = t unquoted (JSON.Number n) =-  cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n-unquoted (JSON.Bool b) = cs . show $ b-unquoted v = cs $ JSON.encode v+  toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n+unquoted (JSON.Bool b) = show b+unquoted v = toS $ JSON.encode v  -- private functions asCsvF :: SqlFragment@@ -390,13 +348,13 @@       "    ) s" <>       "  ) a" <>       ")"-    asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')"+    asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')"  asJsonF :: SqlFragment-asJsonF = "coalesce(array_to_json(array_agg(row_to_json(t))), '[]')::character varying"+asJsonF = "coalesce(array_to_json(array_agg(row_to_json(_postgrest_t))), '[]')::character varying"  asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element-asJsonSingleF = "coalesce(string_agg(row_to_json(t)::text, ','), '')::character varying "+asJsonSingleF = "coalesce(string_agg(row_to_json(_postgrest_t)::text, ','), '')::character varying "  locationF :: [Text] -> SqlFragment locationF pKeys =@@ -415,8 +373,8 @@   then ""   else "LIMIT " <> limit <> " OFFSET " <> offset   where-    limit  = maybe "ALL" (cs . show) $ rangeLimit r-    offset = cs . show $ rangeOffset r+    limit  = maybe "ALL" show $ rangeLimit r+    offset = show $ rangeOffset r  fromQi :: QualifiedIdentifier -> SqlFragment fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n@@ -430,6 +388,7 @@     Child  -> zipWith (toFilter tN ftN) cols fcs     Parent -> zipWith (toFilter tN ftN) cols fcs     Many   -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2)+    Root   -> undefined --error "undefined getJoinConditions"   where     s = if typ == Parent then "" else tableSchema t     tN = tableName t@@ -448,9 +407,13 @@ insertableValue JSON.Null = "null" insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v +insertableValueWithType :: Text -> JSON.Value -> SqlFragment+insertableValueWithType t v =+  pgFmtLit (unquoted v) <> "::" <> t+ whiteList :: Text -> SqlFragment whiteList val = fromMaybe-  (cs (pgFmtLit val) <> "::unknown ")+  (toS (pgFmtLit val) <> "::unknown ")   (find ((==) . toLower $ val) ["null","true","false"])  pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment@@ -471,7 +434,7 @@   where     headPredicate:rest = split (=='.') ops     hasNot caseTrue caseFalse = if headPredicate == "not" then caseTrue else caseFalse-    opCode      = hasNot (head rest) headPredicate+    opCode      = hasNot (headDef "eq" rest) headPredicate     notOp       = hasNot headPredicate ""     sqlCol = case val of       VText _ -> pgFmtColumn table col <> pgFmtJsonPath jp@@ -511,7 +474,9 @@  pgFmtAs :: Maybe JsonPath -> Maybe Alias -> SqlFragment pgFmtAs Nothing Nothing = ""-pgFmtAs (Just xx) Nothing = " AS " <> pgFmtIdent (last xx)+pgFmtAs (Just xx) Nothing = case lastMay xx of+  Just alias -> " AS " <> pgFmtIdent alias+  Nothing -> "" pgFmtAs _ (Just alias) = " AS " <> pgFmtIdent alias  trimNullChars :: Text -> Text

@@ -17,13 +17,11 @@ import           Data.Ranged.Boundaries import           Data.Ranged.Ranges -import           Data.String.Conversions   (cs)-import           Text.Read                 (readMaybe) import           Text.Regex.TDFA           ((=~)) -import           Data.Maybe                (fromMaybe, listToMaybe)+import Data.List (lookup) -import           Prelude+import           Protolude  type NonnegRange = Range Integer @@ -33,9 +31,9 @@    case listToMaybe (range =~ rangeRegex :: [[BS.ByteString]]) of     Just parsedRange ->-      let [_, from, to] = readMaybe . cs <$> parsedRange-          lower         = fromMaybe emptyRange   (rangeGeq <$> from)-          upper         = fromMaybe allRange (rangeLeq <$> to) in+      let [_, mLower, mUpper] = readMaybe . toS <$> parsedRange+          lower         = fromMaybe emptyRange   (rangeGeq <$> mLower)+          upper         = fromMaybe allRange (rangeLeq <$> mUpper) in       rangeIntersection lower upper     Nothing -> allRange @@ -52,14 +50,14 @@ rangeLimit :: NonnegRange -> Maybe Integer rangeLimit range =   case [rangeLower range, rangeUpper range] of-    [BoundaryBelow from, BoundaryAbove to] -> Just (1 + to - from)+    [BoundaryBelow lower, BoundaryAbove upper] -> Just (1 + upper - lower)     _ -> Nothing  rangeOffset :: NonnegRange -> Integer rangeOffset range =   case rangeLower range of-    BoundaryBelow from -> from-    _ -> error "range without lower bound" -- should never happen+    BoundaryBelow lower -> lower+    _ -> panic "range without lower bound" -- should never happen  rangeGeq :: Integer -> NonnegRange rangeGeq n =

@@ -1,9 +1,8 @@ module PostgREST.Types where+import           Protolude+import qualified GHC.Show import           Data.Aeson-import qualified Data.ByteString      as BS import qualified Data.ByteString.Lazy as BL-import           Data.Int             (Int32)-import           Data.Text import           Data.Tree import qualified Data.Vector          as V import           PostgREST.RangeQuery (NonnegRange)@@ -13,8 +12,21 @@ , dbColumns     :: [Column] , dbRelations   :: [Relation] , dbPrimaryKeys :: [PrimaryKey]+, dbProcs       :: [(Text,ProcDescription)] } deriving (Show, Eq) +data PgArg = PgArg {+  pgaName :: Text+, pgaType :: Text+, pgaReq  :: Bool+} deriving (Show, Eq)++data ProcDescription = ProcDescription {+  pdName       :: Text+, pdArgs       :: [PgArg]+, pdReturnType :: Text+} deriving (Show, Eq)+ type Schema = Text type TableName = Text type SqlQuery = Text@@ -64,8 +76,8 @@   show OrderNullsLast  = "nulls last"  data OrderTerm = OrderTerm {-  otTerm      :: Text-, otDirection :: OrderDirection+  otTerm      :: Field+, otDirection :: Maybe OrderDirection , otNullOrder :: Maybe OrderNulls } deriving (Show, Eq) @@ -75,7 +87,7 @@ } deriving (Show, Eq)  -data RelationType = Child | Parent | Many deriving (Show, Eq)+data RelationType = Child | Parent | Many | Root deriving (Show, Eq) data Relation = Relation {   relTable    :: Table , relColumns  :: [Column]@@ -89,18 +101,18 @@  -- | An array of JSON objects that has been verified to have -- the same keys in every object-newtype UniformObjects = UniformObjects (V.Vector Object)+newtype PayloadJSON = PayloadJSON (V.Vector Object)   deriving (Show, Eq) -unUniformObjects :: UniformObjects -> V.Vector Object-unUniformObjects (UniformObjects objs) = objs+unPayloadJSON :: PayloadJSON -> V.Vector Object+unPayloadJSON (PayloadJSON objs) = objs --- | When Hasql supports the COPY command then we can--- have a special payload just for CSV, but until--- then CSV is converted to a JSON array.-data Payload = PayloadJSON UniformObjects-             | PayloadParseError BS.ByteString-             deriving (Show, Eq)+data Proxy = Proxy {+  proxyScheme     :: Text+, proxyHost       :: Text+, proxyPort       :: Integer+, proxyPath       :: Text+} deriving (Show, Eq)  type Operator = Text data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)@@ -113,9 +125,9 @@ type SelectItem = (Field, Maybe Cast, Maybe Alias) type Path = [Text] data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)-data MutateQuery = Insert { in_::TableName, qPayload::Payload }-                 | Delete { in_::TableName, where_::[Filter] }-                 | Update { in_::TableName, qPayload::Payload, where_::[Filter] } deriving (Show, Eq)+data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }+                 | Delete { in_::TableName, where_::[Filter], returning::[FieldName] }+                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], returning::[FieldName] } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) type ReadRequest = Tree ReadNode

@@ -1,6 +1,7 @@ module Feature.AuthSpec where  -- {{{ Imports+import Text.Heredoc import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON@@ -8,10 +9,13 @@  import SpecHelper import Network.Wai (Application)++import Protolude hiding (get) -- }}}  spec :: SpecWith Application spec = describe "authorization" $ do+  let single = ("Accept","application/vnd.pgrst.object+json")    it "denies access to tables that anonymous does not own" $     get "/authors_only" `shouldRespondWith` ResponseMatcher {@@ -38,17 +42,18 @@       }    it "returns jwt functions as jwt tokens" $-    post "/rpc/login" [json| { "id": "jdoe", "pass": "1234" } |]+    request methodPost "/rpc/login" [single]+      [json| { "id": "jdoe", "pass": "1234" } |]       `shouldRespondWith` ResponseMatcher {-          matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"} |]+          matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xuYW1lIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.P2G9EVSVI22MWxXWFuhEYd9BZerLS1WDlqzdqplM15s"} |]         , matchStatus = 200         , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]         }    it "sql functions can encode custom and standard claims" $-    post "/rpc/jwt_test" "{}"+    request methodPost  "/rpc/jwt_test" [single] "{}"       `shouldRespondWith` ResponseMatcher {-          matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6MTMwMDgxOTM4MCwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3QiLCJpYXQiOjEzMDA4MTkzODAsImF1ZCI6ImV2ZXJ5b25lIn0._tQCF79-ZZGMlLktd3csM_bVaiMg7A8YvIb6K2hcu5w"} |]+          matchBody = Just [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpc3MiOiJqb2UiLCJzdWIiOiJmdW4iLCJhdWQiOiJldmVyeW9uZSIsImV4cCI6MTMwMDgxOTM4MCwibmJmIjoxMzAwODE5MzgwLCJpYXQiOjEzMDA4MTkzODAsImp0aSI6ImZvbyIsInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdCIsImh0dHA6Ly9wb3N0Z3Jlc3QuY29tL2ZvbyI6dHJ1ZX0.IHF16ZSU6XTbOnUWO8CCpUn2fJwt8P00rlYVyXQjpWc"} |]         , matchStatus = 200         , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]         }@@ -56,10 +61,7 @@   it "sql functions can read custom and standard claims variables" $ do     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwLCJhdWQiOiJldmVyeW9uZSJ9.AQmCA7CMScvfaDRMqRPeUY6eNf--69gpW-kxaWfq9X0"     request methodPost "/rpc/reveal_big_jwt" [auth] "{}"-      `shouldRespondWith` [json| [-          {"sub":"fun", "jti":"foo", "nbf":1300819380, "exp":9999999999,-          "http://postgrest.com/foo":true, "iss":"joe", "iat":1300819380,-          "aud":"everyone"}] |]+      `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","aud":"everyone","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|]    it "allows users with permissions to see their tables" $ do     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"@@ -80,26 +82,72 @@   it "fails with an expired token" $ do     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjE0NDY2NzgxNDksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.enk_qZ_u6gZsXY4R8bREKB_HNExRpM0lIWSLktk9JJQ"     request methodGet "/authors_only" [auth] ""-      `shouldRespondWith` 400+      `shouldRespondWith` ResponseMatcher {+          matchBody = Nothing+        , matchStatus = 401+        , matchHeaders = [+            "WWW-Authenticate" <:>+            "Bearer error=\"invalid_token\", error_description=\"JWT expired\""+          ]+        }    it "hides tables from users with invalid JWT" $ do     let auth = authHeaderJWT "ey9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"     request methodGet "/authors_only" [auth] ""-      `shouldRespondWith` 400+      `shouldRespondWith` ResponseMatcher {+          matchBody = Nothing+        , matchStatus = 401+        , matchHeaders = [+            "WWW-Authenticate" <:>+            "Bearer error=\"invalid_token\", error_description=\"JWT invalid\""+          ]+        }    it "should fail when jwt contains no claims" $ do-    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.MKYc_lOECtB0LJOiykilAdlHodB-I0_id2qHKq35dmc"+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.lu-rG8aSCiw-aOlN0IxpRGz5r7Jwq7K9r3tuMPUpytI"     request methodGet "/authors_only" [auth] ""-      `shouldRespondWith` 400+      `shouldRespondWith` 401    it "hides tables from users with JWT that contain no claims about role" $ do-    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.zyohGMnrDy4_8eJTl6I2AUXO3MeCCiwR24aGWRkTE9o"+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.Jneso9X519Vh0z7i9PbXIu7W1HEoq9RRw9BBbyQKFCQ"     request methodGet "/authors_only" [auth] ""-      `shouldRespondWith` 400+      `shouldRespondWith` 401 -  it "recovers after 400 error with logged in user" $ do+  it "recovers after 401 error with logged in user" $ do     _ <- post "/authors_only" [json| { "owner": "jdoe", "secret": "test content" } |]     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"     _ <- request methodPost "/rpc/problem" [auth] ""     request methodGet "/authors_only" [auth] ""       `shouldRespondWith` 200++  describe "custom pre-request proc acting on id claim" $ do++    it "able to switch to postgrest_test_author role (id=1)" $+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6MX0.mI2HNoOum6xM3sc4oHLxU4yLv-_WV5W1kqBfY_wEvLw" in+      request methodPost "/rpc/get_current_user" [auth]+        [json| {} |]+         `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|"postgrest_test_author"|]+          , matchStatus = 200+          , matchHeaders = []+          }++    it "able to switch to postgrest_test_default_role (id=2)" $+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Mn0.W7jLsG-zswM91AJkCvZeIMHrnz7_6ceY2jnscVl3Yhk" in+      request methodPost "/rpc/get_current_user" [auth]+        [json| {} |]+         `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|"postgrest_test_default_role"|]+          , matchStatus = 200+          , matchHeaders = []+          }++    it "raises error (id=3)" $+      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6M30.15Gy8PezQhJIaHYDJVLa-Gmz9T3sJnW66EKAYIsXc7c" in+      request methodPost "/rpc/get_current_user" [auth]+        [json| {} |]+         `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|{"hint":"Please contact administrator","details":null,"code":"P0001","message":"Disabled ID --> 3"}|]+          , matchStatus = 400+          , matchHeaders = []+          }

@@ -0,0 +1,21 @@+module Feature.BinaryJwtSecretSpec where++-- {{{ Imports+import Test.Hspec+import Test.Hspec.Wai+import Network.HTTP.Types++import SpecHelper+import Network.Wai (Application)++import Protolude hiding (get)+-- }}}++spec :: SpecWith Application+spec = describe "server started with binary JWT secret" $++  -- this test will stop working 9999999999s after the UNIX EPOCH+  it "succeeds with jwt token encoded with a binary secret" $ do+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.l_EcSRWeNtL4OKUTIplrHyioNrff9Rd0MV7RXNCxCyk"+    request methodGet "/authors_only" [auth] ""+      `shouldRespondWith` 200

@@ -16,6 +16,8 @@  import Network.Wai (Application) +import Protolude hiding (get)+ spec :: SpecWith Application spec =   describe "Queryiny in parallel" $

@@ -10,6 +10,8 @@  import Network.HTTP.Types import Network.Wai (Application)++import Protolude hiding (get) -- }}}  spec :: SpecWith Application@@ -69,4 +71,4 @@         liftIO $ do           simpleHeaders r `shouldSatisfy` matchHeader             "Access-Control-Allow-Origin" "\\*"-          simpleBody r `shouldSatisfy` not . BL.null+          simpleBody r `shouldSatisfy` BL.null

@@ -7,6 +7,8 @@ import Network.HTTP.Types import Network.Wai (Application) +import Protolude hiding (get)+ spec :: SpecWith Application spec =   describe "Deleting" $ do@@ -16,11 +18,11 @@           `shouldRespondWith` ResponseMatcher {             matchBody    = Nothing           , matchStatus  = 204-          , matchHeaders = ["Content-Range" <:> "*/1"]+          , matchHeaders = ["Content-Range" <:> "*/*"]           } -      it "returns the deleted item" $-        request methodDelete "/items?id=eq.2" [("Prefer", "return=representation")] ""+      it "returns the deleted item and count if requested" $+        request methodDelete "/items?id=eq.2" [("Prefer", "return=representation"), ("Prefer", "count=exact")] ""           `shouldRespondWith` ResponseMatcher {             matchBody    = Just [str|[{"id":2}]|]           , matchStatus  = 200@@ -31,14 +33,17 @@           `shouldRespondWith` ResponseMatcher {             matchBody    = Just [str|[{"id":2,"name":"Two"}]|]           , matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "*/1"]+          , matchHeaders = ["Content-Range" <:> "*/*"]           }+      it "can rename and cast the selected columns" $+        request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] ""+          `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|]       it "can embed (parent) entities" $         request methodDelete "/tasks?id=eq.8&select=id,name,project{id}" [("Prefer", "return=representation")] ""           `shouldRespondWith` ResponseMatcher {             matchBody    = Just [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|]           , matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "*/1"]+          , matchHeaders = ["Content-Range" <:> "*/*"]           }        it "actually clears items ouf the db" $ do@@ -47,12 +52,18 @@           `shouldRespondWith` ResponseMatcher {             matchBody    = Just [str|[{"id":15}]|]           , matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "0-0/1"]+          , matchHeaders = ["Content-Range" <:> "0-0/*"]           } -    context "known route, unknown record" $-      it "fails with 404" $-        request methodDelete "/items?id=eq.101" [] "" `shouldRespondWith` 404+    context "known route, no records matched" $+      it "includes [] body if return=rep" $+        request methodDelete "/items?id=eq.101"+          [("Prefer", "return=representation")] ""+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just "[]"+          , matchStatus  = 200+          , matchHeaders = ["Content-Range" <:> "*/*"]+          }      context "totally unknown route" $       it "fails with 404" $

@@ -8,8 +8,8 @@ import SpecHelper  import qualified Data.Aeson as JSON+import Data.List (lookup) import Data.Maybe (fromJust)-import Data.Monoid ((<>)) import Text.Heredoc import Network.HTTP.Types.Header import Network.HTTP.Types@@ -18,6 +18,8 @@ import TestTypes(IncPK(..), CompoundPK(..)) import Network.Wai (Application) +import Protolude hiding (get)+ spec :: SpecWith Application spec = do   describe "Posting new record" $ do@@ -37,24 +39,39 @@        it "filters columns in result using &select" $         request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]-          [json| {+          [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!"}|]+          }] |] `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|[{"integer":14,"varchar":"testing!"}]|]           , matchStatus  = 201           , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]           } +    context "requesting full representation" $ do       it "includes related data after insert" $-        request methodPost "/projects?select=id,name,clients{id,name}" [("Prefer", "return=representation")]+        request methodPost "/projects?select=id,name,clients{id,name}"+                [("Prefer", "return=representation"), ("Prefer", "count=exact")]           [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {-            matchBody    = Just [str|{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}|]+            matchBody    = Just [str|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|]           , matchStatus  = 201-          , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8", "Location" <:> "/projects?id=eq.6"]+          , matchHeaders = [ "Content-Type" <:> "application/json; charset=utf-8"+                           , "Location" <:> "/projects?id=eq.6"+                           , "Content-Range" <:> "*/1" ]           } +      it "can rename and cast the selected columns" $+        request methodPost "/projects?select=pId:id::text,pName:name,cId:client_id::text"+                [("Prefer", "return=representation")] +          [str|{"id":7,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|[{"pId":"7","pName":"New Project","cId":"2"}]|]+          , matchStatus  = 201+          , matchHeaders = [ "Content-Type" <:> "application/json; charset=utf-8"+                           , "Location" <:> "/projects?id=eq.7"+                           , "Content-Range" <:> "*/*" ]+          }+     context "from an html form" $       it "accepts disparate json types" $ do         p <- request methodPost "/menagerie"@@ -81,9 +98,11 @@             incNullableStr record `shouldBe` Nothing        context "into a table with simple pk" $-        it "fails with 400 and error" $-          post "/simple_pk" [json| { "extra":"foo"} |]-            `shouldRespondWith` 400+        it "fails with 400 and error" $ do+          p <- post "/simple_pk" [json| { "extra":"foo"} |]+          liftIO $ do+            simpleStatus p `shouldBe` badRequest400+            isErrorFormat (simpleBody p) `shouldBe` True        context "into a table with no pk" $ do         it "succeeds with 201 and a link including all fields" $ do@@ -98,10 +117,18 @@                        [("Prefer", "return=representation")]                        [json| { "a":"bar", "b":"baz" } |]           liftIO $ do-            simpleBody p `shouldBe` [json| { "a":"bar", "b":"baz" } |]+            simpleBody p `shouldBe` [json| [{ "a":"bar", "b":"baz" }] |]             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz"             simpleStatus p `shouldBe` created201 +        it "returns empty array when no items inserted, and return=rep" $ do+          p <- request methodPost "/no_pk"+                       [("Prefer", "return=representation")]+                       [json| [] |]+          liftIO $ do+            simpleBody p `shouldBe` [json| [] |]+            simpleStatus p `shouldBe` created201+         it "can insert in tables with no select privileges" $ do           p <- request methodPost "/insertonly"                        [("Prefer", "return=minimal")]@@ -116,7 +143,7 @@                        [("Prefer", "return=representation")]                        [json| { "a":null, "b":"foo" } |]           liftIO $ do-            simpleBody p `shouldBe` [json| { "a":null, "b":"foo" } |]+            simpleBody p `shouldBe` [json| [{ "a":null, "b":"foo" }] |]             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=is.null&b=eq.foo"             simpleStatus p `shouldBe` created201 @@ -129,7 +156,7 @@                      [("Prefer", "return=representation")]                      inserted         liftIO $ do-          JSON.decode (simpleBody p) `shouldBe` Just expectedObj+          JSON.decode (simpleBody p) `shouldBe` Just [expectedObj]           simpleStatus p `shouldBe` created201           lookup hLocation (simpleHeaders p) `shouldBe` Just expectedLoc @@ -149,8 +176,11 @@           lookup hLocation (simpleHeaders p) `shouldBe` Nothing      context "with invalid json payload" $-      it "fails with 400 and error" $-        post "/simple_pk" "}{ x = 2" `shouldRespondWith` 400+      it "fails with 400 and error" $ do+        p <- post "/simple_pk" "}{ x = 2"+        liftIO $ do+          simpleStatus p `shouldBe` badRequest400+          isErrorFormat (simpleBody p) `shouldBe` True      context "with valid json payload" $       it "succeeds and returns 201 created" $@@ -172,7 +202,7 @@                      [("Prefer", "return=representation")]                      inserted           `shouldRespondWith` ResponseMatcher {-            matchBody    = Just inserted+            matchBody    = Just [str|[{"data":{"foo":"bar"}}]|]           , matchStatus  = 201           , matchHeaders = ["Location" <:> location]           }@@ -184,7 +214,7 @@                      [("Prefer", "return=representation")]                      inserted           `shouldRespondWith` ResponseMatcher {-            matchBody    = Just inserted+            matchBody    = Just [str|[{"data":[1,2,3]}]|]           , matchStatus  = 201           , matchHeaders = ["Location" <:> location]           }@@ -196,6 +226,28 @@           , matchStatus  = 201           , matchHeaders = []           }+    context "table with limited privileges" $ do+      it "succeeds if correct select is applied" $+        request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")]+          [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|[{"article_id":2,"user_id":1}]|]+          , matchStatus  = 201+          , matchHeaders = []+          }+      it "fails if more columns are selected" $+        request methodPost "/limited_article_stars?select=article_id,user_id,created_at" [("Prefer", "return=representation")]+          [json| {"article_id": 2, "user_id": 2} |] `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]+          , matchStatus  = 401+          , matchHeaders = []+          }+      it "fails if select is not specified" $+        request methodPost "/limited_article_stars" [("Prefer", "return=representation")]+          [json| {"article_id": 3, "user_id": 1} |] `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|]+          , matchStatus  = 401+          , matchHeaders = []+          }    describe "CSV insert" $ do @@ -237,11 +289,23 @@                             "Location" <:> "/no_pk?a=is.null&b=eq.foo"]           } +      it "only returns the requested column header with its associated data" $+        request methodPost "/projects?select=id"+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]+                     "id,name,client_id\n8,Xenix,1\n9,Windows NT,1"+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just "id\n8\n9"+          , matchStatus  = 201+          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",+                            "Content-Range" <:> "*/*"]+          }      context "with wrong number of columns" $       it "fails for too few" $ do         p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"-        liftIO $ simpleStatus p `shouldBe` badRequest400+        liftIO $ do+          simpleStatus p `shouldBe` badRequest400+          isErrorFormat (simpleBody p) `shouldBe` True      context "with unicode values" $       it "succeeds and returns usable location header" $ do@@ -250,7 +314,7 @@                      [("Prefer", "return=representation")]                      payload         liftIO $ do-          simpleBody p `shouldBe` payload+          simpleBody p `shouldBe` "["<>payload<>"]"           simpleStatus p `shouldBe` created201          let Just location = lookup hLocation $ simpleHeaders p@@ -258,81 +322,6 @@         liftIO $ simpleBody r `shouldBe` "["<>payload<>"]"  -  describe "Putting record" $ do--    context "to unknown uri" $-      it "gives a 404" $ do-        pendingWith "Decide on PUT usefullness"-        request methodPut "/fake" []-          [json| { "real": false } |]-            `shouldRespondWith` 404--    context "to a known uri" $ do-      context "without a fully-specified primary key" $-        it "is not an allowed operation" $ do-          pendingWith "Decide on PUT usefullness"-          request methodPut "/compound_pk?k1=eq.12" []-            [json| { "k1":12, "k2":42 } |]-              `shouldRespondWith` 405--      context "with a fully-specified primary key" $ do--        context "not specifying every column in the table" $-          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" $ 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-              simpleBody p `shouldBe` ""-              simpleStatus p `shouldBe` status204--            r <- get "/compound_pk?k1=eq.12&k2=eq.42"-            let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK])-            liftIO $ do-              length rows `shouldBe` 1-              let record = head rows-              compoundK1 record `shouldBe` 12-              compoundK2 record `shouldBe` "42"-              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" []-                 [json| { "k1":12, "k2":42, "extra":5 } |]--            r <- get "/compound_pk?k1=eq.12&k2=eq.42"-            let rows = fromJust (JSON.decode $ simpleBody r :: Maybe [CompoundPK])-            liftIO $ do-              length rows `shouldBe` 1-              let record = head rows-              compoundExtra record `shouldBe` Just 5--      context "with an auto-incrementing primary key"$--        it "succeeds with 204" $ do-          pendingWith "Decide on PUT usefullness"-          request methodPut "/auto_incrementing_pk?id=eq.1" []-               [json| {-                 "id":1,-                 "nullable_string":"hi",-                 "non_nullable_string":"bye",-                 "inserted_at": "2020-11-11"-               } |]-            `shouldRespondWith` ResponseMatcher {-              matchBody    = Nothing,-              matchStatus  = 204,-              matchHeaders = []-            }-   describe "Patching record" $ do      context "to unknown uri" $@@ -345,26 +334,50 @@       it "indicates no records found to update" $         request methodPatch "/empty_table" []           [json| { "extra":20 } |]-            `shouldRespondWith` 404+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just "",+            matchStatus  = 204,+            matchHeaders = ["Content-Range" <:> "*/*"]+          }      context "in a nonempty table" $ do       it "can update a single item" $ do         g <- get "/items?id=eq.42"         liftIO $ simpleHeaders g-          `shouldSatisfy` matchHeader "Content-Range" "\\*/0"+          `shouldSatisfy` matchHeader "Content-Range" "\\*/\\*"         p <- request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |]         pure p `shouldRespondWith` ResponseMatcher {             matchBody    = Nothing,             matchStatus  = 204,-            matchHeaders = ["Content-Range" <:> "0-0/1"]+            matchHeaders = ["Content-Range" <:> "0-0/*"]           }-        liftIO $-          lookup hContentType (simpleHeaders p) `shouldBe` Nothing+        liftIO $ lookup hContentType (simpleHeaders p) `shouldBe` Nothing +        -- check it really got updated         g' <- get "/items?id=eq.42"         liftIO $ simpleHeaders g'-          `shouldSatisfy` matchHeader "Content-Range" "0-0/1"+          `shouldSatisfy` matchHeader "Content-Range" "0-0/\\*"+        -- put value back for other tests+        void $ request methodPatch "/items?id=eq.42" [] [json| { "id":2 } |] +      it "returns empty array when no rows updated and return=rep" $+        request methodPatch "/items?id=eq.999999"+          [("Prefer", "return=representation")] [json| { "id":999999 } |]+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just "[]",+            matchStatus  = 200,+            matchHeaders = ["Content-Range" <:> "*/*"]+          }++      it "returns updated object as array when return=rep" $+        request methodPatch "/items?id=eq.2"+          [("Prefer", "return=representation")] [json| { "id":2 } |]+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|[{"id":2}]|],+            matchStatus  = 200,+            matchHeaders = ["Content-Range" <:> "0-0/*"]+          }+       it "can update multiple items" $ do         replicateM_ 10 $ post "/auto_incrementing_pk"           [json| { non_nullable_string: "a" } |]@@ -375,7 +388,7 @@           [json| { non_nullable_string: "c" } |]         g <- get "/auto_incrementing_pk?non_nullable_string=eq.c"         liftIO $ simpleHeaders g-          `shouldSatisfy` matchHeader "Content-Range" "0-9/10"+          `shouldSatisfy` matchHeader "Content-Range" "0-9/\\*"        it "can set a column to NULL" $ do         _ <- post "/no_pk" [json| { a: "keepme", b: "nullme" } |]@@ -383,12 +396,28 @@         get "/no_pk?a=eq.keepme" `shouldRespondWith`           [json| [{ a: "keepme", b: null }] |] +      it "can set a json column to escaped value" $ do+        _ <- post "/json" [json| { data: {"escaped":"bar"} } |]+        request methodPatch "/json?data->>escaped=eq.bar"+                     [("Prefer", "return=representation")]+                     [json| { "data": { "escaped":" \"bar" } } |]+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [json| [{ "data": { "escaped":" \"bar" } }] |]+          , matchStatus  = 200+          , matchHeaders = []+          }+       it "can update based on a computed column" $         request methodPatch           "/items?always_true=eq.false"           [("Prefer", "return=representation")]           [json| { id: 100 } |]-          `shouldRespondWith` 404+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just "[]",+            matchStatus  = 200,+            matchHeaders = ["Content-Range" <:> "*/*"]+          }+       it "can provide a representation" $ do         _ <- post "/items"           [json| { id: 1 } |]@@ -398,17 +427,6 @@           [json| { id: 99 } |]           `shouldRespondWith` [json| [{id:99}] |] -      it "can set a json column to escaped value" $ do-        _ <- post "/json" [json| { data: {"escaped":"bar"} } |]-        request methodPatch "/json?data->>escaped=eq.bar"-                     [("Prefer", "return=representation")]-                     [json| { "data": { "escaped":" \"bar" } } |]-          `shouldRespondWith` ResponseMatcher {-            matchBody    = Just [json| [{ "data": { "escaped":" \"bar" } }] |]-          , matchStatus  = 200-          , matchHeaders = []-          }-     context "with unicode values" $       it "succeeds and returns values intact" $ do         void $ request methodPost "/no_pk" []@@ -430,13 +448,13 @@         [ auth, ("Prefer", "return=representation") ]         [json| { "secret": "nyancat" } |]       liftIO $ do-          simpleBody p1 `shouldBe` [str|{"owner":"jdoe","secret":"nyancat"}|]-          simpleStatus p1 `shouldBe` created201+        simpleBody p1 `shouldBe` [str|[{"owner":"jdoe","secret":"nyancat"}]|]+        simpleStatus p1 `shouldBe` created201        p2 <- request methodPost "/authors_only"         -- jwt token for jroe         [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.YuF_VfmyIxWyuceT7crnNKEprIYXsJAyXid3rjPjIow", ("Prefer", "return=representation") ]         [json| { "secret": "lolcat", "owner": "hacker" } |]       liftIO $ do-          simpleBody p2 `shouldBe` [str|{"owner":"jroe","secret":"lolcat"}|]-          simpleStatus p2 `shouldBe` created201+        simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|]+        simpleStatus p2 `shouldBe` created201

@@ -0,0 +1,25 @@+module Feature.NoJwtSpec where++-- {{{ Imports+import Test.Hspec+import Test.Hspec.Wai+import Network.HTTP.Types++import SpecHelper+import Network.Wai (Application)++import Protolude hiding (get)+-- }}}++spec :: SpecWith Application+spec = describe "server started without JWT secret" $ do++  -- this test will stop working 9999999999s after the UNIX EPOCH+  it "responds with error on attempted auth" $ do+    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.QaPPLWTuyydMu_q7H4noMT7Lk6P4muet1OpJXF6ofhc"+    request methodGet "/authors_only" [auth] ""+      `shouldRespondWith` 500++  it "behaves normally when user does not attempt auth" $+    request methodGet "/items" [] ""+      `shouldRespondWith` 200

@@ -0,0 +1,15 @@+module Feature.ProxySpec where++import Test.Hspec hiding (pendingWith)++import SpecHelper++import Network.Wai (Application)++import Protolude hiding (get)++spec :: SpecWith Application+spec =+  describe "GET / with proxy" $+    it "returns a valid openapi spec with proxy" $+      validateOpenApiResponse [("Accept", "application/openapi+json")]

@@ -9,6 +9,8 @@ import SpecHelper import Network.Wai (Application) +import Protolude hiding (get)+ spec :: SpecWith Application spec =   describe "Requesting many items with server limits enabled" $ do@@ -16,8 +18,8 @@       get "/items"         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":1},{"id":2}] |]-        , matchStatus  = 206-        , matchHeaders = ["Content-Range" <:> "0-1/15"]+        , matchStatus  = 200+        , matchHeaders = ["Content-Range" <:> "0-1/*"]         }      it "respects additional client limiting" $ do@@ -25,13 +27,22 @@                    (rangeHdrs $ ByteRangeFromTo 0 0) ""       liftIO $ do         simpleHeaders r `shouldSatisfy`-          matchHeader "Content-Range" "0-0/15"-        simpleStatus r `shouldBe` partialContent206+          matchHeader "Content-Range" "0-0/*"+        simpleStatus r `shouldBe` ok200      it "limit works on all levels" $       get "/users?select=id,tasks{id}&order=id.asc&tasks.order=id.asc"         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [str|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|]-        , matchStatus  = 206-        , matchHeaders = ["Content-Range" <:> "0-1/3"]+        , matchStatus  = 200+        , matchHeaders = ["Content-Range" <:> "0-1/*"]         }++    it "limit is not applied to parent embeds" $+      get "/tasks?select=id,project{id}&id=gt.5"+        `shouldRespondWith` ResponseMatcher {+          matchBody    = Just [str|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|]+        , matchStatus  = 200+        , matchHeaders = ["Content-Range" <:> "0-1/*"]+        }+

@@ -4,12 +4,14 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Network.HTTP.Types-import Network.Wai.Test (SResponse(simpleHeaders))+import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus,simpleBody))  import SpecHelper import Text.Heredoc import Network.Wai (Application) +import Protolude hiding (get)+ spec :: SpecWith Application spec = do @@ -17,6 +19,10 @@     it "should not confuse count column with pg_catalog.count aggregate" $       get "/has_count_column" `shouldRespondWith` 200 +  describe "Querying a table with a column called t" $+    it "should not conflict with internal postgrest table alias" $+      get "/clashing_column?select=t" `shouldRespondWith` 200+   describe "Querying a nonexistent table" $     it "causes a 404" $       get "/faketable" `shouldRespondWith` 404@@ -27,7 +33,7 @@         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":5}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-0/1"]+        , matchHeaders = ["Content-Range" <:> "0-0/*"]         }      it "matches with equality using not operator" $@@ -35,7 +41,7 @@         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-13/14"]+        , matchHeaders = ["Content-Range" <:> "0-13/*"]         }      it "matches with more than one condition using not operator" $@@ -46,13 +52,13 @@         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":14},{"id":15}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-1/2"]+        , matchHeaders = ["Content-Range" <:> "0-1/*"]         }       get "/items?id=not.gt.2&order=id.asc"         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":1},{"id":2}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-1/2"]+        , matchHeaders = ["Content-Range" <:> "0-1/*"]         }      it "matches items IN" $@@ -60,7 +66,7 @@         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":1},{"id":3},{"id":5}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-2/3"]+        , matchHeaders = ["Content-Range" <:> "0-2/*"]         }      it "matches items NOT IN" $@@ -68,7 +74,7 @@         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":1},{"id":3},{"id":5}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-2/3"]+        , matchHeaders = ["Content-Range" <:> "0-2/*"]         }      it "matches items NOT IN using not operator" $@@ -76,7 +82,7 @@         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":1},{"id":3},{"id":5}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-2/3"]+        , matchHeaders = ["Content-Range" <:> "0-2/*"]         }      it "matches nulls using not operator" $@@ -126,6 +132,14 @@       get "/items?order=anti_id.desc" `shouldRespondWith`         [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] +    it "matches filtering nested items 2" $+      get "/clients?select=id,projects{id,tasks2{id,name}}&projects.tasks.name=like.Design*"+        `shouldRespondWith` ResponseMatcher {+          matchBody    = Just [json| {"message":"could not find foreign keys between these entities, no relation between projects and tasks2"}|]+        , matchStatus  = 400+        , matchHeaders = []+        }+     it "matches filtering nested items" $       get "/clients?select=id,projects{id,tasks{id,name}}&projects.tasks.name=like.Design*" `shouldRespondWith`         [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1,"name":"Design w7"}]},{"id":2,"tasks":[{"id":3,"name":"Design w10"}]}]},{"id":2,"projects":[{"id":3,"tasks":[{"id":5,"name":"Design IOS"}]},{"id":4,"tasks":[{"id":7,"name":"Design OSX"}]}]}]|]@@ -225,7 +239,15 @@       get "/projects?id=eq.1&select=myId:id, name, project_client:client_id{*}, project_tasks:tasks{id, name}" `shouldRespondWith`         [str|[{"myId":1,"name":"Windows 7","project_client":{"id":1,"name":"Microsoft"},"project_tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] +    it "requesting parents two levels up while using FK to specify the link" $+      get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith`+        [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] +    it "requesting parents two levels up while using FK to specify the link (with rename)" $+      get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith`+        [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|]++     it "requesting parents and filtering parent columns" $       get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith`         [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|]@@ -259,6 +281,11 @@       get "/projects_view?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`         [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] +    it "requesting parents and children on views with renamed keys" $+      get "/projects_view_alt?t_id=eq.1&select=t_id, name, clients{*}, tasks{id, name}" `shouldRespondWith`+        [str|[{"t_id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]++     it "requesting children with composite key" $       get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments{content}" `shouldRespondWith`         [str|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|]@@ -275,60 +302,33 @@       get "/projects?id=in.1,3&select=id,name,client_id,client{id,name}" `shouldRespondWith`         [str|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|] --  describe "Plurality singular" $ do-    it "will select an existing object" $-      request methodGet "/items?id=eq.5" [("Prefer","plurality=singular")] ""-        `shouldRespondWith` ResponseMatcher {-          matchBody    = Just [json| {"id":5} |]-        , matchStatus  = 200-        , matchHeaders = []-        }--    it "can combine multiple prefer values" $-      request methodGet "/items?id=eq.5" [("Prefer","plurality=singular ; future=new; count=none")] ""-        `shouldRespondWith` ResponseMatcher {-          matchBody    = Just [json| {"id":5} |]-        , matchStatus  = 200-        , matchHeaders = []-        }--    it "works in the presence of a range header" $-      let headers = ("Prefer","plurality=singular") :-            rangeHdrs (ByteRangeFromTo 0 9) in-      request methodGet "/items" headers ""-        `shouldRespondWith` ResponseMatcher {-          matchBody    = Just [json| {"id":1} |]-        , matchStatus  = 200-        , matchHeaders = []-        }--    it "will respond with 404 when not found" $-      request methodGet "/items?id=eq.9999" [("Prefer","plurality=singular")] ""-        `shouldRespondWith` 404--    it "can shape plurality singular object routes" $-      request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [("Prefer","plurality=singular")] ""-        `shouldRespondWith`-          [str|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|]--   describe "ordering response" $ do     it "by a column asc" $       get "/items?id=lte.2&order=id.asc"         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":1},{"id":2}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-1/2"]+        , matchHeaders = ["Content-Range" <:> "0-1/*"]         }     it "by a column desc" $       get "/items?id=lte.2&order=id.desc"         `shouldRespondWith` ResponseMatcher {           matchBody    = Just [json| [{"id":2},{"id":1}] |]         , matchStatus  = 200-        , matchHeaders = ["Content-Range" <:> "0-1/2"]+        , matchHeaders = ["Content-Range" <:> "0-1/*"]         } +    it "by a column with nulls first" $+      get "/no_pk?order=a.nullsfirst"+        `shouldRespondWith` ResponseMatcher {+          matchBody = Just [json| [{"a":null,"b":null},+                              {"a":"1","b":"0"},+                              {"a":"2","b":"0"}+                              ] |]+        , matchStatus = 200+        , matchHeaders = ["Content-Range" <:> "0-2/*"]+        }+     it "by a column asc with nulls last" $       get "/no_pk?order=a.asc.nullslast"         `shouldRespondWith` ResponseMatcher {@@ -336,7 +336,7 @@                               {"a":"2","b":"0"},                               {"a":null,"b":null}] |]         , matchStatus = 200-        , matchHeaders = ["Content-Range" <:> "0-2/3"]+        , matchHeaders = ["Content-Range" <:> "0-2/*"]         }      it "by a column desc with nulls first" $@@ -346,7 +346,7 @@                               {"a":"2","b":"0"},                               {"a":"1","b":"0"}] |]         , matchStatus = 200-        , matchHeaders = ["Content-Range" <:> "0-2/3"]+        , matchHeaders = ["Content-Range" <:> "0-2/*"]         }      it "by a column desc with nulls last" $@@ -356,9 +356,17 @@                               {"a":"1","b":"0"},                               {"a":null,"b":null}] |]         , matchStatus = 200-        , matchHeaders = ["Content-Range" <:> "0-2/3"]+        , matchHeaders = ["Content-Range" <:> "0-2/*"]         } +    it "by a json column property asc" $+      get "/json?order=data->>id.asc" `shouldRespondWith`+        [json| [{"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}, {"data": {"id": 3}}] |]++    it "by a json column with two level property nulls first" $+      get "/json?order=data->foo->>bar.nullsfirst" `shouldRespondWith`+        [json| [{"data": {"id": 3}}, {"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}] |]+     it "without other constraints" $       get "/items?order=id.asc" `shouldRespondWith` 200 @@ -395,6 +403,27 @@               (acceptHdrs "*/*") ""         `shouldRespondWith` 200 +    it "*/* should rescue an unknown type" $+      request methodGet "/simple_pk"+              (acceptHdrs "text/unknowntype, */*") ""+        `shouldRespondWith` 200++    it "specific available preference should override */*" $ do+      r <- request methodGet "/simple_pk"+              (acceptHdrs "text/csv, */*") ""+      liftIO $ do+        let respHeaders = simpleHeaders r+        respHeaders `shouldSatisfy` matchHeader+          "Content-Type" "text/csv; charset=utf-8"++    it "honors client preference even when opposite of server preference" $ do+      r <- request methodGet "/simple_pk"+              (acceptHdrs "text/csv, application/json") ""+      liftIO $ do+        let respHeaders = simpleHeaders r+        respHeaders `shouldSatisfy` matchHeader+          "Content-Type" "text/csv; charset=utf-8"+     it "should respond correctly to multiple types in accept header" $       request methodGet "/simple_pk"               (acceptHdrs "text/unknowntype, text/csv") ""@@ -445,7 +474,17 @@                 (rangeHdrs (ByteRangeFromTo 0 0))  [json| { "min": 2, "max": 4 } |]            `shouldRespondWith` ResponseMatcher {               matchBody    = Just [json| [{"id":3}] |]-            , matchStatus = 206+            , matchStatus = 200+            , matchHeaders = ["Content-Range" <:> "0-0/*"]+            }++      it "includes total count if requested" $+        request methodPost "/rpc/getitemrange"+                (rangeHdrsWithCount (ByteRangeFromTo 0 0))+                [json| { "min": 2, "max": 4 } |]+           `shouldRespondWith` ResponseMatcher {+              matchBody    = Just [json| [{"id":3}] |]+            , matchStatus = 206 -- it now knows the response is partial             , matchHeaders = ["Content-Range" <:> "0-0/2"]             } @@ -454,6 +493,35 @@         post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`           [json| [ {"id": 3}, {"id":4} ] |] +    context "unknown function" $+      it "returns 404" $+        post "/rpc/fakefunc" [json| {} |] `shouldRespondWith` 404++    context "shaping the response returned by a proc" $ do+      it "returns a project" $+        post "/rpc/getproject" [json| { "id": 1} |] `shouldRespondWith`+          [str|[{"id":1,"name":"Windows 7","client_id":1}]|]++      it "can filter proc results" $+        post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id" [json| {} |] `shouldRespondWith`+          [json|[{"id":2},{"id":3},{"id":4}]|]++      it "can limit proc results" $+        post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id?limit=2&offset=1" [json| {} |]+          `shouldRespondWith` ResponseMatcher {+               matchBody    = Just [json|[{"id":3},{"id":4}]|]+             , matchStatus = 200+             , matchHeaders = ["Content-Range" <:> "1-2/*"]+             }++      it "select works on the first level" $+        post "/rpc/getproject?select=id,name" [json| { "id": 1} |] `shouldRespondWith`+          [str|[{"id":1,"name":"Windows 7"}]|]++      it "can embed foreign entities to the items returned by a proc" $+        post "/rpc/getproject?select=id,name,client{id},tasks{id}" [json| { "id": 1} |] `shouldRespondWith`+          [str|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|]+     context "a proc that returns an empty rowset" $       it "returns empty json array" $         post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith`@@ -462,21 +530,28 @@     context "a proc that returns plain text" $ do       it "returns proper json" $         post "/rpc/sayhello" [json| { "name": "world" } |] `shouldRespondWith`-          [json| [{"sayhello":"Hello, world"}] |]+          [json|"Hello, world"|]        it "can handle unicode" $         post "/rpc/sayhello" [json| { "name": "￥" } |] `shouldRespondWith`-          [json| [{"sayhello":"Hello, ￥"}] |]+          [json|"Hello, ￥"|]      context "improper input" $ do       it "rejects unknown content type even if payload is good" $         request methodPost "/rpc/sayhello"           (acceptHdrs "audio/mpeg3") [json| { "name": "world" } |]             `shouldRespondWith` 415-      it "rejects malformed json payload" $-        request methodPost "/rpc/sayhello"+      it "rejects malformed json payload" $ do+        p <- request methodPost "/rpc/sayhello"           (acceptHdrs "application/json") "sdfsdf"-            `shouldRespondWith` 400+        liftIO $ do+          simpleStatus p `shouldBe` badRequest400+          isErrorFormat (simpleBody p) `shouldBe` True+      it "treats simple plpgsql raise as invalid input" $ do+        p <- post "/rpc/problem" "{}"+        liftIO $ do+          simpleStatus p `shouldBe` badRequest400+          isErrorFormat (simpleBody p) `shouldBe` True      context "unsupported verbs" $ do       it "DELETE fails" $@@ -497,9 +572,23 @@      it "executes the proc exactly once per request" $ do       post "/rpc/callcounter" [json| {} |] `shouldRespondWith`-        [json| [{"callcounter":1}] |]+        [json|1|]       post "/rpc/callcounter" [json| {} |] `shouldRespondWith`-        [json| [{"callcounter":2}] |]+        [json|2|]++    context "expects a single json object" $ do+      it "does not expand posted json into parameters" $+        request methodPost "/rpc/singlejsonparam"+          [("Prefer","params=single-object")] [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] `shouldRespondWith`+          [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |]++      it "accepts parameters from an html form" $+        request methodPost "/rpc/singlejsonparam"+          [("Prefer","params=single-object"),("Content-Type", "application/x-www-form-urlencoded")]+          ("integer=7&double=2.71828&varchar=forms+are+fun&" <>+           "boolean=false&date=1900-01-01&money=$3.99&enum=foo") `shouldRespondWith`+          [json| { "integer": "7", "double": "2.71828", "varchar" : "forms are fun"+                 , "boolean":"false", "date":"1900-01-01", "money":"$3.99", "enum":"foo" } |]    describe "weird requests" $ do     it "can query as normal" $ do

@@ -12,6 +12,8 @@ import Text.Heredoc import Network.Wai (Application) +import Protolude hiding (get)+ defaultRange :: BL.ByteString defaultRange = [json| { "min": 0, "max": 15 } |] @@ -28,8 +30,7 @@        context "when I don't want the count" $ do         it "returns range Content-Range with */* for empty range" $-          request methodPost "/rpc/getitemrange"-                  [("Prefer", "count=none")] emptyRange+          request methodPost "/rpc/getitemrange" [] emptyRange             `shouldRespondWith` ResponseMatcher {               matchBody    = Just [json| [] |]             , matchStatus  = 200@@ -37,8 +38,7 @@             }          it "returns range Content-Range with range/*" $-          request methodPost "/rpc/getitemrange"-                  [("Prefer", "count=none")] defaultRange+          request methodPost "/rpc/getitemrange" [] defaultRange             `shouldRespondWith` ResponseMatcher {               matchBody    = Just [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]             , matchStatus  = 200@@ -53,8 +53,8 @@                        (rangeHdrs $ ByteRangeFromTo 0 1) defaultRange           liftIO $ do             simpleHeaders r `shouldSatisfy`-              matchHeader "Content-Range" "0-1/15"-            simpleStatus r `shouldBe` partialContent206+              matchHeader "Content-Range" "0-1/*"+            simpleStatus r `shouldBe` ok200          it "understands open-ended ranges" $           request methodPost "/rpc/getitemrange"@@ -67,7 +67,7 @@             `shouldRespondWith` ResponseMatcher {               matchBody    = Just "[]"             , matchStatus  = 200-            , matchHeaders = ["Content-Range" <:> "*/0"]+            , matchHeaders = ["Content-Range" <:> "*/*"]             }          it "allows one-item requests" $ do@@ -75,16 +75,16 @@                        (rangeHdrs $ ByteRangeFromTo 0 0) defaultRange           liftIO $ do             simpleHeaders r `shouldSatisfy`-              matchHeader "Content-Range" "0-0/15"-            simpleStatus r `shouldBe` partialContent206+              matchHeader "Content-Range" "0-0/*"+            simpleStatus r `shouldBe` ok200          it "handles ranges beyond collection length via truncation" $ do           r <- request methodPost  "/rpc/getitemrange"                        (rangeHdrs $ ByteRangeFromTo 10 100) defaultRange           liftIO $ do             simpleHeaders r `shouldSatisfy`-              matchHeader "Content-Range" "10-14/15"-            simpleStatus r `shouldBe` partialContent206+              matchHeader "Content-Range" "10-14/*"+            simpleStatus r `shouldBe` ok200        context "of invalid range" $ do         it "fails with 416 for offside range" $@@ -94,7 +94,7 @@          it "refuses a range with nonzero start when there are no items" $           request methodPost "/rpc/getitemrange"-                  (rangeHdrs $ ByteRangeFromTo 1 2) emptyRange+                  (rangeHdrsWithCount $ ByteRangeFromTo 1 2) emptyRange             `shouldRespondWith` ResponseMatcher {               matchBody    = Nothing             , matchStatus  = 416@@ -103,12 +103,13 @@          it "refuses a range requesting start past last item" $           request methodPost "/rpc/getitemrange"-                  (rangeHdrs $ ByteRangeFromTo 100 199) defaultRange+                  (rangeHdrsWithCount $ ByteRangeFromTo 100 199) defaultRange             `shouldRespondWith` ResponseMatcher {               matchBody    = Nothing             , matchStatus  = 416             , matchHeaders = ["Content-Range" <:> "*/15"]             }+   describe "GET /items" $ do     context "without range headers" $ do       context "with response under server size limit" $@@ -149,42 +150,39 @@           `shouldRespondWith` ResponseMatcher {             matchBody    = Just [str|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]           , matchStatus  = 200-          , matchHeaders = ["Content-Range" <:> "0-14/15"]+          , matchHeaders = ["Content-Range" <:> "0-14/*"]           }       it "top level limit with parameter" $         get "/items?select=id&order=id.asc&limit=3"           `shouldRespondWith` ResponseMatcher {             matchBody    = Just [str|[{"id":1},{"id":2},{"id":3}]|]-          , matchStatus  = 206-          , matchHeaders = ["Content-Range" <:> "0-2/15"]+          , matchStatus  = 200+          , matchHeaders = ["Content-Range" <:> "0-2/*"]           }       it "headers override get parameters" $         request methodGet  "/items?select=id&order=id.asc&limit=3"                      (rangeHdrs $ ByteRangeFromTo 0 1) ""           `shouldRespondWith` ResponseMatcher {             matchBody    = Just [str|[{"id":1},{"id":2}]|]-          , matchStatus  = 206-          , matchHeaders = ["Content-Range" <:> "0-1/15"]+          , matchStatus  = 200+          , matchHeaders = ["Content-Range" <:> "0-1/*"]           }        it "limit works on all levels" $-        get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=1&projects.tasks.order=id.asc&projects.tasks.limit=2"+        get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=2&projects.tasks.order=id.asc&projects.tasks.limit=1"           `shouldRespondWith` ResponseMatcher {-            matchBody    = Just [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]}]}]|]-          , matchStatus  = 206-          , matchHeaders = ["Content-Range" <:> "0-0/2"]+            matchBody    = Just [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1}]},{"id":2,"tasks":[{"id":3}]}]}]|]+          , matchStatus  = 200+          , matchHeaders = ["Content-Range" <:> "0-0/*"]           } -      it "fails on offset specified below level 1" $-        get "/clients?select=id,projects{id,tasks{id}}&projects.offset=2&projects.limit=1"-          `shouldRespondWith` 400        it "limit and offset works on first level" $         get "/items?select=id&order=id.asc&limit=3&offset=2"           `shouldRespondWith` ResponseMatcher {             matchBody    = Just [str|[{"id":3},{"id":4},{"id":5}]|]-          , matchStatus  = 206-          , matchHeaders = ["Content-Range" <:> "2-4/15"]+          , matchStatus  = 200+          , matchHeaders = ["Content-Range" <:> "2-4/*"]           }      context "with range headers" $ do@@ -195,8 +193,8 @@                        (rangeHdrs $ ByteRangeFromTo 0 1) ""           liftIO $ do             simpleHeaders r `shouldSatisfy`-              matchHeader "Content-Range" "0-1/15"-            simpleStatus r `shouldBe` partialContent206+              matchHeader "Content-Range" "0-1/*"+            simpleStatus r `shouldBe` ok200          it "understands open-ended ranges" $           request methodGet "/items"@@ -209,7 +207,7 @@             `shouldRespondWith` ResponseMatcher {               matchBody    = Just "[]"             , matchStatus  = 200-            , matchHeaders = ["Content-Range" <:> "*/0"]+            , matchHeaders = ["Content-Range" <:> "*/*"]             }          it "allows one-item requests" $ do@@ -217,16 +215,16 @@                        (rangeHdrs $ ByteRangeFromTo 0 0) ""           liftIO $ do             simpleHeaders r `shouldSatisfy`-              matchHeader "Content-Range" "0-0/15"-            simpleStatus r `shouldBe` partialContent206+              matchHeader "Content-Range" "0-0/*"+            simpleStatus r `shouldBe` ok200          it "handles ranges beyond collection length via truncation" $ do           r <- request methodGet  "/items"                        (rangeHdrs $ ByteRangeFromTo 10 100) ""           liftIO $ do             simpleHeaders r `shouldSatisfy`-              matchHeader "Content-Range" "10-14/15"-            simpleStatus r `shouldBe` partialContent206+              matchHeader "Content-Range" "10-14/*"+            simpleStatus r `shouldBe` ok200        context "of invalid range" $ do         it "fails with 416 for offside range" $@@ -236,7 +234,7 @@          it "refuses a range with nonzero start when there are no items" $           request methodGet "/menagerie"-                  (rangeHdrs $ ByteRangeFromTo 1 2) ""+                  (rangeHdrsWithCount $ ByteRangeFromTo 1 2) ""             `shouldRespondWith` ResponseMatcher {               matchBody    = Nothing             , matchStatus  = 416@@ -245,7 +243,7 @@          it "refuses a range requesting start past last item" $           request methodGet "/items"-                  (rangeHdrs $ ByteRangeFromTo 100 199) ""+                  (rangeHdrsWithCount $ ByteRangeFromTo 100 199) ""             `shouldRespondWith` ResponseMatcher {               matchBody    = Nothing             , matchStatus  = 416

@@ -0,0 +1,198 @@+module Feature.SingularSpec where++import Text.Heredoc+import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON+import Network.HTTP.Types+import Network.Wai.Test (SResponse(..))++import Network.Wai (Application)++import SpecHelper+import Protolude hiding (get)+++spec :: SpecWith Application+spec =+  describe "Requesting singular json object" $ do+    let pgrstObj = "application/vnd.pgrst.object+json"+        singular = ("Accept", pgrstObj)++    context "with GET request" $ do+      it "fails for zero rows" $+        request methodGet  "/items?id=gt.0&id=lt.0" [singular] ""+          `shouldRespondWith` 406++      it "will select an existing object" $ do+        request methodGet "/items?id=eq.5" [singular] ""+          `shouldRespondWith` [str|{"id":5}|]+        -- also test without the +json suffix+        request methodGet "/items?id=eq.5"+          [("Accept", "application/vnd.pgrst.object")] ""+          `shouldRespondWith` [str|{"id":5}|]++      it "can combine multiple prefer values" $+        request methodGet "/items?id=eq.5" [singular, ("Prefer","count=none")] ""+          `shouldRespondWith` [str|{"id":5}|]++      it "can shape plurality singular object routes" $+        request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [singular] ""+          `shouldRespondWith`+            [str|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|]++    context "when updating rows" $ do++      it "works for one row" $ do+        _ <- post "/addresses" [json| { id: 97, address: "A Street" } |]+        request methodPatch+          "/addresses?id=eq.97"+          [("Prefer", "return=representation"), singular]+          [json| { address: "B Street" } |]+          `shouldRespondWith`+            [str|{"id":97,"address":"B Street"}|]++      it "raises an error for multiple rows" $ do+        _ <- post "/addresses" [json| { id: 98, address: "xxx" } |]+        _ <- post "/addresses" [json| { id: 99, address: "yyy" } |]+        p <- request methodPatch+          "/addresses?id=gt.0"+          [("Prefer", "return=representation"), singular]+          [json| { address: "zzz" } |]+        liftIO $ do+          simpleStatus p `shouldBe` notAcceptable406+          isErrorFormat (simpleBody p) `shouldBe` True++        -- the rows should not be updated, either+        get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|]++      it "raises an error for zero rows" $ do+        p <- request methodPatch  "/items?id=gt.0&id=lt.0"+          [("Prefer", "return=representation"), singular] [json|{"id":1}|]+        liftIO $ do+          simpleStatus p `shouldBe` notAcceptable406+          isErrorFormat (simpleBody p) `shouldBe` True++    context "when creating rows" $ do++      it "works for one row" $ do+        p <- request methodPost+          "/addresses"+          [("Prefer", "return=representation"), singular]+          [json| [ { id: 100, address: "xxx" } ] |]+        liftIO $ simpleBody p `shouldBe` [str|{"id":100,"address":"xxx"}|]++      it "works for one row even with return=minimal" $ do+        request methodPost "/addresses"+          [("Prefer", "return=minimal"), singular]+          [json| [ { id: 101, address: "xxx" } ] |]+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just ""+          , matchStatus  = 201+          , matchHeaders = ["Content-Range" <:> "*/*"]+          }+        -- and the element should exist+        get "/addresses?id=eq.101"+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just [str|[{"id":101,"address":"xxx"}]|]+          , matchStatus  = 200+          , matchHeaders = []+          }++      it "raises an error when attempting to create multiple entities" $ do+        p <- request methodPost+          "/addresses"+          [("Prefer", "return=representation"), singular]+          [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]+        liftIO $ simpleStatus p `shouldBe` notAcceptable406++        -- the rows should not exist, either+        get "/addresses?id=eq.200" `shouldRespondWith` "[]"++      it "return=minimal allows request to create multiple elements" $+        request methodPost "/addresses"+          [("Prefer", "return=minimal"), singular]+          [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Just ""+          , matchStatus  = 201+          , matchHeaders = ["Content-Range" <:> "*/*"]+          }++      it "raises an error when creating zero entities" $ do+        p <- request methodPost+          "/addresses"+          [("Prefer", "return=representation"), singular]+          [json| [ ] |]+        liftIO $ do+          simpleStatus p `shouldBe` notAcceptable406+          isErrorFormat (simpleBody p) `shouldBe` True++    context "when deleting rows" $ do++      it "works for one row" $ do+        p <- request methodDelete+          "/items?id=eq.11"+          [("Prefer", "return=representation"), singular] ""+        liftIO $ simpleBody p `shouldBe` [str|{"id":11}|]++      it "raises an error when attempting to delete multiple entities" $ do+        let firstItems = "/items?id=gt.0&id=lt.11"+        request methodDelete firstItems+          [("Prefer", "return=representation"), singular] ""+          `shouldRespondWith` 406++        -- the rows should not exist, either+        get firstItems+          `shouldRespondWith` ResponseMatcher {+            matchBody    = Nothing+          , matchStatus  = 200+          , matchHeaders = ["Content-Range" <:> "0-9/*"]+          }++      it "raises an error when deleting zero entities" $ do+        p <- request methodDelete "/items?id=lt.0"+          [("Prefer", "return=representation"), singular] ""+        liftIO $ do+          simpleStatus p `shouldBe` notAcceptable406+          isErrorFormat (simpleBody p) `shouldBe` True++    context "when calling a stored proc" $ do++      it "fails for zero rows" $ do+        p <- request methodPost "/rpc/getproject"+          [singular] [json|{ "id": 9999999}|]+        liftIO $ do+          simpleStatus p `shouldBe` notAcceptable406+          isErrorFormat (simpleBody p) `shouldBe` True++      -- this one may be controversial, should vnd.pgrst.object include+      -- the likes of 2 and "hello?"+      it "succeeds for scalar result" $+        request methodPost "/rpc/sayhello"+          [singular] [json|{ "name": "world"}|]+          `shouldRespondWith` 200++      it "returns a single object for json proc" $+        request methodPost "/rpc/getproject"+          [singular] [json|{ "id": 1}|] `shouldRespondWith`+          [str|{"id":1,"name":"Windows 7","client_id":1}|]++      it "fails for multiple rows" $ do+        p <- request methodPost "/rpc/getallprojects" [singular] "{}"+        liftIO $ do+          simpleStatus p `shouldBe` notAcceptable406+          isErrorFormat (simpleBody p) `shouldBe` True++      it "executes the proc exactly once per request" $ do+        request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]+          `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]+        p <- request methodPost "/rpc/setprojects" [singular]+          [json| {"id_l": 1, "id_h": 2, "name": "changed"} |]+        liftIO $ do+          simpleStatus p `shouldBe` notAcceptable406+          isErrorFormat (simpleBody p) `shouldBe` True++        -- should not actually have executed the function+        request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]+          `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]

@@ -2,387 +2,87 @@  import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai-import Test.Hspec.Wai.JSON+import Network.HTTP.Types +import Control.Lens ((^?))+import Data.Aeson.Lens+import Data.Aeson.QQ+ import SpecHelper -import Network.HTTP.Types import Network.Wai (Application)-import Network.Wai.Test (SResponse(simpleHeaders))+import Network.Wai.Test (SResponse(..)) +import Protolude hiding (get)+ spec :: SpecWith Application spec = do -  describe "GET /" $ do-    it "lists views in schema" $-      request methodGet "/" [] ""-        `shouldRespondWith` [json| [-          {"schema":"test","name":"Escap3e;","insertable":true}-        , {"schema":"test","name":"addresses","insertable":true}-        , {"schema":"test","name":"articleStars","insertable":true}-        , {"schema":"test","name":"articles","insertable":true}-        , {"schema":"test","name":"auto_incrementing_pk","insertable":true}-        , {"schema":"test","name":"clients","insertable":true}-        , {"schema":"test","name":"comments","insertable":true}-        , {"schema":"test","name":"complex_items","insertable":true}-        , {"schema":"test","name":"compound_pk","insertable":true}-        , {"schema":"test","name":"empty_table","insertable":true}-        , {"schema":"test","name":"filtered_tasks","insertable":true}-        , {"schema":"test","name":"ghostBusters","insertable":true}-        , {"schema":"test","name":"has_count_column","insertable":false}-        , {"schema":"test","name":"has_fk","insertable":true}-        , {"schema":"test","name":"insertable_view_with_join","insertable":true}-        , {"schema":"test","name":"insertonly","insertable":true}-        , {"schema":"test","name":"items","insertable":true}-        , {"schema":"test","name":"json","insertable":true}-        , {"schema":"test","name":"materialized_view","insertable":false}-        , {"schema":"test","name":"menagerie","insertable":true}-        , {"schema":"test","name":"no_pk","insertable":true}-        , {"schema":"test","name":"nullable_integer","insertable":true}-        , {"schema":"test","name":"orders","insertable":true}-        , {"schema":"test","name":"projects","insertable":true}-        , {"schema":"test","name":"projects_view","insertable":true}-        , {"schema":"test","name":"simple_pk","insertable":true}-        , {"schema":"test","name":"tasks","insertable":true}-        , {"schema":"test","name":"tsearch","insertable":true}-        , {"schema":"test","name":"users","insertable":true}-        , {"schema":"test","name":"users_projects","insertable":true}-        , {"schema":"test","name":"users_tasks","insertable":true}-        , {"schema":"test","name":"withUnique","insertable":true}-        ] |]-        {matchStatus = 200}--    it "lists only views user has permission to see" $ do-      let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"--      request methodGet "/" [auth] ""-        `shouldRespondWith` [json| [-            {"schema":"test","name":"authors_only","insertable":true}-        ] |]-        {matchStatus = 200}--  describe "Table info" $ do-    it "The structure of complex views is correctly detected" $-      request methodOptions "/filtered_tasks" [] "" `shouldRespondWith`-      [json|-      {-        "pkey": [-          "myId"-        ],-        "columns": [-          {-            "references": null,-            "default": null,-            "precision": 32,-            "updatable": true,-            "schema": "test",-            "name": "myId",-            "type": "integer",-            "maxLen": null,-            "enum": [],-            "nullable": true,-            "position": 1-          },-          {-            "references": null,-            "default": null,-            "precision": null,-            "updatable": true,-            "schema": "test",-            "name": "name",-            "type": "text",-            "maxLen": null,-            "enum": [],-            "nullable": true,-            "position": 2-          },-          {-            "references": {-              "schema": "test",-              "column": "id",-              "table": "projects"-            },-            "default": null,-            "precision": 32,-            "updatable": true,-            "schema": "test",-            "name": "projectID",-            "type": "integer",-            "maxLen": null,-            "enum": [],-            "nullable": true,-            "position": 3-          }-        ]-      }-      |]+  describe "OpenAPI" $ do+    it "root path returns a valid openapi spec" $+      validateOpenApiResponse [("Accept", "application/openapi+json")] -    it "is available with OPTIONS verb" $-      request methodOptions "/menagerie" [] "" `shouldRespondWith`-      [json|-      {-        "pkey":["integer"],-        "columns":[-          {-            "default": null,-            "precision": 32,-            "updatable": true,-            "schema": "test",-            "name": "integer",-            "type": "integer",-            "maxLen": null,-            "enum": [],-            "nullable": false,-            "position": 1,-            "references": null,-            "default": null-          }, {-            "default": null,-            "precision": 53,-            "updatable": true,-            "schema": "test",-            "name": "double",-            "type": "double precision",-            "maxLen": null,-            "enum": [],-            "nullable": false,-            "references": null,-            "position": 2-          }, {-            "default": null,-            "precision": null,-            "updatable": true,-            "schema": "test",-            "name": "varchar",-            "type": "character varying",-            "maxLen": null,-            "enum": [],-            "nullable": false,-            "position": 3,-            "references": null,-            "default": null-          }, {-            "default": null,-            "precision": null,-            "updatable": true,-            "schema": "test",-            "name": "boolean",-            "type": "boolean",-            "maxLen": null,-            "enum": [],-            "nullable": false,-            "references": null,-            "position": 4-          }, {-            "default": null,-            "precision": null,-            "updatable": true,-            "schema": "test",-            "name": "date",-            "type": "date",-            "maxLen": null,-            "enum": [],-            "nullable": false,-            "references": null,-            "position": 5-          }, {-            "default": null,-            "precision": null,-            "updatable": true,-            "schema": "test",-            "name": "money",-            "type": "money",-            "maxLen": null,-            "enum": [],-            "nullable": false,-            "position": 6,-            "references": null,-            "default": null-          }, {-            "default": null,-            "precision": null,-            "updatable": true,-            "schema": "test",-            "name": "enum",-            "type": "USER-DEFINED",-            "maxLen": null,-            "enum": [-              "foo",-              "bar"-            ],-            "nullable": false,-            "position": 7,-            "references": null,-            "default": null-          }-        ]-      }-      |]+    it "should respond to openapi request on none root path with 415" $+      request methodGet "/items"+              (acceptHdrs "application/openapi+json") ""+        `shouldRespondWith` 415 -    it "it includes primary and foreign keys for views" $-      request methodOptions "/projects_view" [] "" `shouldRespondWith`-      [json|-      {-         "pkey":[-            "id"-         ],-         "columns":[-          {-            "references":null,-            "default":null,-            "precision":32,-            "updatable":true,-            "schema":"test",-            "name":"id",-            "type":"integer",-            "maxLen":null,-            "enum":[],-            "nullable":true,-            "position":1-          },-          {-            "references":null,-            "default":null,-            "precision":null,-            "updatable":true,-            "schema":"test",-            "name":"name",-            "type":"text",-            "maxLen":null,-            "enum":[],-            "nullable":true,-            "position":2-          },-          {-            "references": {-              "schema":"test",-              "column":"id",-              "table":"clients"-            },-            "default":null,-            "precision":32,-            "updatable":true,-            "schema":"test",-            "name":"client_id",-            "type":"integer",-            "maxLen":null,-            "enum":[],-            "nullable":true,-            "position":3-          }-        ]-      }-      |]+    describe "RPC" $ -    it "includes foreign key data" $-      request methodOptions "/has_fk" [] ""-        `shouldRespondWith` [json|-      {-        "pkey": ["id"],-        "columns":[-          {-            "default": "nextval('test.has_fk_id_seq'::regclass)",-            "precision": 64,-            "updatable": true,-            "schema": "test",-            "name": "id",-            "type": "bigint",-            "maxLen": null,-            "nullable": false,-            "position": 1,-            "enum": [],-            "references": null-          }, {-            "default": null,-            "precision": 32,-            "updatable": true,-            "schema": "test",-            "name": "auto_inc_fk",-            "type": "integer",-            "maxLen": null,-            "nullable": true,-            "position": 2,-            "enum": [],-            "references": {"schema":"test", "table": "auto_incrementing_pk", "column": "id"}-          }, {-            "default": null,-            "precision": null,-            "updatable": true,-            "schema": "test",-            "name": "simple_fk",-            "type": "character varying",-            "maxLen": 255,-            "nullable": true,-            "position": 3,-            "enum": [],-            "references": {"schema":"test", "table": "simple_pk", "column": "k"}-          }-        ]-      }-      |]+      it "includes a representative function with parameters" $ do+        r <- simpleBody <$> get "/"+        let ref = r ^? key "paths" . key "/rpc/varied_arguments"+                     . key "post"  . key "parameters"+                     . nth 1       . key "schema"+                     . key "$ref"  . _String+            args = r ^? key "definitions" . key "(rpc) varied_arguments" -    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-              },+        liftIO $ do+          ref `shouldBe` Just "#/definitions/(rpc) varied_arguments"+          args `shouldBe` Just+            [aesonQQ|               {-                "references": {-                  "schema": "test",-                  "column": "id",-                  "table": "users"+                "required": [+                  "double",+                  "varchar",+                  "boolean",+                  "date",+                  "money",+                  "enum"+                ],+                "properties": {+                  "double": {+                    "format": "double precision",+                    "type": "string"+                  },+                  "varchar": {+                    "format": "character varying",+                    "type": "string"+                  },+                  "boolean": {+                    "format": "boolean",+                    "type": "boolean"+                  },+                  "date": {+                    "format": "date",+                    "type": "string"+                  },+                  "money": {+                    "format": "money",+                    "type": "string"+                  },+                  "enum": {+                    "format": "test.enum_menagerie_type",+                    "type": "string"+                  },+                  "integer": {+                    "format": "integer",+                    "type": "integer"+                  }                 },-                "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+                "type": "object"               }-            ]-          }-        |]--    it "errors for non existant tables" $-      request methodOptions "/dne" [] "" `shouldRespondWith` 404+            |]    describe "Allow header" $ do 

@@ -6,6 +6,8 @@ import Network.Wai (Application) import Control.Monad (void) +import Protolude hiding (get)+ spec :: SpecWith Application spec =   describe "Reading and writing to unicode schema and table names" $

@@ -7,43 +7,72 @@  import PostgREST.DbStructure (getDbStructure) import PostgREST.App (postgrest)+import Control.AutoUpdate+import Data.Function (id) import Data.IORef-import Data.String.Conversions (cs)+import Data.Time.Clock.POSIX   (getPOSIXTime)  import qualified Feature.AuthSpec+import qualified Feature.BinaryJwtSecretSpec import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec import qualified Feature.InsertSpec+import qualified Feature.NoJwtSpec import qualified Feature.QueryLimitedSpec import qualified Feature.QuerySpec import qualified Feature.RangeSpec import qualified Feature.StructureSpec+import qualified Feature.SingularSpec import qualified Feature.UnicodeSpec+import qualified Feature.ProxySpec +import Protolude+ main :: IO () main = do-  setupDb+  testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test"+  setupDb testDbConn -  pool <- P.acquire (3, 10, cs testDbConn)+  pool <- P.acquire (3, 10, toS testDbConn)+  -- ask for the OS time at most once per second+  getTime <- mkAutoUpdate+    defaultUpdateSettings { updateAction = getPOSIXTime } +   result <- P.use pool $ getDbStructure "test"-  refDbStructure <- newIORef $ either (error.show) id result-  let withApp = return $ postgrest testCfg refDbStructure pool-      ltdApp  = return $ postgrest testLtdRowsCfg refDbStructure pool-      unicodeApp = return $ postgrest testUnicodeCfg refDbStructure pool+  refDbStructure <- newIORef $ either (panic.show) id result+  let withApp      = return $ postgrest (testCfg testDbConn)          refDbStructure pool getTime+      ltdApp       = return $ postgrest (testLtdRowsCfg testDbConn)   refDbStructure pool getTime+      unicodeApp   = return $ postgrest (testUnicodeCfg testDbConn)   refDbStructure pool getTime+      proxyApp     = return $ postgrest (testProxyCfg testDbConn)     refDbStructure pool getTime+      noJwtApp     = return $ postgrest (testCfgNoJWT testDbConn)     refDbStructure pool getTime+      binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime +  let reset = resetDb testDbConn   hspec $ do-    mapM_ (beforeAll_ resetDb . before withApp) specs+    mapM_ (beforeAll_ reset . before withApp) specs      -- this test runs with a different server flag-    beforeAll_ resetDb . before ltdApp $+    beforeAll_ reset . before ltdApp $       describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec      -- this test runs with a different schema-    beforeAll_ resetDb . before unicodeApp $+    beforeAll_ reset . before unicodeApp $       describe "Feature.UnicodeSpec" Feature.UnicodeSpec.spec +    -- this test runs with a proxy+    beforeAll_ reset . before proxyApp $+      describe "Feature.ProxySpec" Feature.ProxySpec.spec++    -- this test runs without a JWT secret+    beforeAll_ reset . before noJwtApp $+      describe "Feature.NoJwtSpec" Feature.NoJwtSpec.spec++    -- this test runs with a binary JWT secret+    beforeAll_ reset . before binaryJwtApp $+      describe "Feature.BinaryJwtSecretSpec" Feature.BinaryJwtSecretSpec.spec+  where   specs = map (uncurry describe) [       ("Feature.AuthSpec"         , Feature.AuthSpec.spec)@@ -53,5 +82,6 @@     , ("Feature.InsertSpec"       , Feature.InsertSpec.spec)     , ("Feature.QuerySpec"        , Feature.QuerySpec.spec)     , ("Feature.RangeSpec"        , Feature.RangeSpec.spec)+    , ("Feature.SingularSpec"     , Feature.SingularSpec.spec)     , ("Feature.StructureSpec"    , Feature.StructureSpec.spec)     ]

@@ -1,66 +1,140 @@ module SpecHelper where -import Data.String.Conversions (cs) import Control.Monad (void) -import Network.HTTP.Types.Header (Header, ByteRange, renderByteRange,-                                  hRange, hAuthorization, hAccept)-import Codec.Binary.Base64.String (encode)+import qualified System.IO.Error as E+import System.Environment (getEnv)++import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient) import Data.CaseInsensitive (CI(..))+import qualified Data.Set as S+import qualified Data.Map.Strict as M+import Data.List (lookup) import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BL import System.Process (readProcess)-import Web.JWT (secret)  import PostgREST.Config (AppConfig(..)) -testDbConn :: String-testDbConn = "postgres://postgrest_test_authenticator@localhost:5432/postgrest_test"+import Test.Hspec hiding (pendingWith)+import Test.Hspec.Wai -testCfg :: AppConfig-testCfg =-  AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 Nothing True+import Network.HTTP.Types+import Network.Wai.Test (SResponse(simpleStatus, simpleHeaders, simpleBody)) -testUnicodeCfg :: AppConfig-testUnicodeCfg =-  AppConfig testDbConn "postgrest_test_anonymous" "تست" 3000 (secret "safe") 10 Nothing True+import Data.Maybe (fromJust)+import Data.Aeson (decode, Value(..))+import qualified Data.JsonSchema.Draft4 as D4 -testLtdRowsCfg :: AppConfig-testLtdRowsCfg =-  AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 2) True+import Protolude -setupDb :: IO ()-setupDb = do-  void $ readProcess "psql" ["-d", "postgres", "-a", "-f", "test/fixtures/database.sql"] []-  loadFixture "roles"-  loadFixture "schema"-  loadFixture "privileges"-  resetDb+validateOpenApiResponse :: [Header] -> WaiSession ()+validateOpenApiResponse headers = do+  r <- request methodGet "/" headers ""+  liftIO $+    let respStatus = simpleStatus r in+    respStatus `shouldSatisfy`+      \s -> s == Status { statusCode = 200, statusMessage="OK" }+  liftIO $+    let respHeaders = simpleHeaders r in+    respHeaders `shouldSatisfy`+      \hs -> ("Content-Type", "application/openapi+json; charset=utf-8") `elem` hs+  liftIO $+    let respBody = simpleBody r+        schema :: D4.Schema+        schema = D4.emptySchema { D4._schemaRef = Just "openapi.json" }+        schemaContext :: D4.SchemaWithURI D4.Schema+        schemaContext = D4.SchemaWithURI+          { D4._swSchema = schema+          , D4._swURI    = Just "test/fixtures/openapi.json"+          }+       in+       D4.fetchFilesystemAndValidate schemaContext ((fromJust . decode) respBody) `shouldReturn` Right () -resetDb :: IO ()-resetDb = loadFixture "data"+getEnvVarWithDefault :: Text -> Text -> IO Text+getEnvVarWithDefault var def = do+  varValue <- getEnv (toS var) `E.catchIOError` const (return $ toS def)+  return $ toS varValue -loadFixture :: FilePath -> IO()-loadFixture name =-  void $ readProcess "psql" ["-U", "postgrest_test", "-d", "postgrest_test", "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []+_baseCfg :: AppConfig+_baseCfg =  -- Connection Settings+  AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000+            -- Jwt settings+            (Just $ encodeUtf8 "safe") False+            -- Connection Modifiers+            10 Nothing (Just "test.switch_role")+            -- Debug Settings+            True +testCfg :: Text -> AppConfig+testCfg testDbConn = _baseCfg { configDatabase = testDbConn }++testCfgNoJWT :: Text -> AppConfig+testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing }++testUnicodeCfg :: Text -> AppConfig+testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchema = "تست" }++testLtdRowsCfg :: Text -> AppConfig+testLtdRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 }++testProxyCfg :: Text -> AppConfig+testProxyCfg testDbConn = (testCfg testDbConn) { configProxyUri = Just "https://postgrest.com/openapi.json" }++testCfgBinaryJWT :: Text -> AppConfig+testCfgBinaryJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Just secretBs }+  where secretBs = B64.decodeLenient "h2CGB1FoBd51aQooCS2g+UmRgYQfTPQ6v3+9ALbaqM4="+++setupDb :: Text -> IO ()+setupDb dbConn = do+  loadFixture dbConn "database"+  loadFixture dbConn "roles"+  loadFixture dbConn "schema"+  loadFixture dbConn "jwt"+  loadFixture dbConn "privileges"+  resetDb dbConn++resetDb :: Text -> IO ()+resetDb dbConn = loadFixture dbConn "data"++loadFixture :: Text -> FilePath -> IO()+loadFixture dbConn name =+  void $ readProcess "psql" [toS dbConn, "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] []+ rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] +rangeHdrsWithCount :: ByteRange -> [Header]+rangeHdrsWithCount r = ("Prefer", "count=exact") : rangeHdrs r+ acceptHdrs :: BS.ByteString -> [Header] acceptHdrs mime = [(hAccept, mime)]  rangeUnit :: Header rangeUnit = ("Range-Unit" :: CI BS.ByteString, "items") -matchHeader :: CI BS.ByteString -> String -> [Header] -> Bool+matchHeader :: CI BS.ByteString -> BS.ByteString -> [Header] -> Bool matchHeader name valRegex headers =   maybe False (=~ valRegex) $ lookup name headers -authHeaderBasic :: String -> String -> Header+authHeaderBasic :: BS.ByteString -> BS.ByteString -> Header authHeaderBasic u p =-  (hAuthorization, cs $ "Basic " ++ encode (u ++ ":" ++ p))+  (hAuthorization, "Basic " <> (toS . B64.encode . toS $ u <> ":" <> p)) -authHeaderJWT :: String -> Header+authHeaderJWT :: BS.ByteString -> Header authHeaderJWT token =-  (hAuthorization, cs $ "Bearer " ++ token)+  (hAuthorization, "Bearer " <> token)++-- | Tests whether the text can be parsed as a json object comtaining+-- the key "message", and optional keys "details", "hint", "code",+-- and no extraneous keys+isErrorFormat :: BL.ByteString -> Bool+isErrorFormat s =+  "message" `S.member` keys &&+    S.null (S.difference keys validKeys)+ where+  obj = decode s :: Maybe (M.Map Text Value)+  keys = fromMaybe S.empty (M.keysSet <$> obj)+  validKeys = S.fromList ["message", "details", "hint", "code"]

@@ -1,23 +1,18 @@ module TestTypes (   IncPK(..) , CompoundPK(..)--- , incFromList--- , compoundFromList ) where  import qualified Data.Aeson as JSON import Data.Aeson ((.:))--- import Data.Maybe (fromJust)-import Control.Applicative-import Control.Monad (mzero) -import Prelude+import Protolude  data IncPK = IncPK {   incId :: Int-, incNullableStr :: Maybe String-, incStr :: String-, incInsert :: String+, incNullableStr :: Maybe Text+, incStr :: Text+, incInsert :: Text } deriving (Eq, Show)  instance JSON.FromJSON IncPK where@@ -28,16 +23,9 @@     r .: "inserted_at"   parseJSON _ = mzero --- incFromList :: [(String, SqlValue)] -> IncPK--- incFromList row = IncPK---   (fromSql . fromJust $ lookup "id" row)---   (fromSql . fromJust $ lookup "nullable_string" row)---   (fromSql . fromJust $ lookup "non_nullable_string" row)---   (fromSql . fromJust $ lookup "inserted_at" row)- data CompoundPK = CompoundPK {   compoundK1 :: Int-, compoundK2 :: String+, compoundK2 :: Text , compoundExtra :: Maybe Int } deriving (Eq, Show) @@ -47,9 +35,3 @@     r .: "k2" <*>     r .: "extra"   parseJSON _ = mzero---- compoundFromList :: [(String, SqlValue)] -> CompoundPK--- compoundFromList row = CompoundPK---   (fromSql . fromJust $ lookup "k1" row)---   (fromSql . fromJust $ lookup "k2" row)---   (fromSql . fromJust $ lookup "extra" row)