postgrest 0.3.1.1 → 0.3.2.0
raw patch · 22 files changed
+799/−439 lines, 22 filesdep +bytestring-tree-builderdep +microlensdep +microlens-aesondep −lensdep −lens-aesondep ~basedep ~hasqldep ~hasql-pool
Dependencies added: bytestring-tree-builder, microlens, microlens-aeson, postgresql-binary
Dependencies removed: lens, lens-aeson
Dependency ranges changed: base, hasql, hasql-pool, hasql-transaction, hspec, unix
Files
- main/Main.hs +87/−0
- postgrest.cabal +24/−42
- src/PostgREST/ApiRequest.hs +69/−33
- src/PostgREST/App.hs +161/−85
- src/PostgREST/Auth.hs +35/−34
- src/PostgREST/Error.hs +15/−10
- src/PostgREST/Main.hs +0/−78
- src/PostgREST/Middleware.hs +15/−30
- src/PostgREST/Parsers.hs +51/−9
- src/PostgREST/QueryBuilder.hs +76/−77
- src/PostgREST/RangeQuery.hs +11/−6
- src/PostgREST/Types.hs +5/−3
- test/Feature/AuthSpec.hs +23/−2
- test/Feature/DeleteSpec.hs +22/−0
- test/Feature/InsertSpec.hs +59/−17
- test/Feature/QueryLimitedSpec.hs +13/−5
- test/Feature/QuerySpec.hs +62/−1
- test/Feature/RangeSpec.hs +45/−0
- test/Feature/StructureSpec.hs +18/−0
- test/Main.hs +5/−4
- test/SpecHelper.hs +1/−1
- test/TestTypes.hs +2/−2
+ main/Main.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE CPP #-}++module Main where+++import PostgREST.App+import PostgREST.Config (AppConfig (..),+ minimumPgVersion,+ prettyVersion,+ readOptions)+import PostgREST.DbStructure++import Control.Monad+import Data.Monoid ((<>))+import Data.String.Conversions (cs)+import qualified Hasql.Query as H+import qualified Hasql.Session as H+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Pool as P+import Network.Wai.Handler.Warp+import System.IO (BufferMode (..),+ hSetBuffering, stderr,+ stdin, stdout)+import Web.JWT (secret)+import Data.IORef+#ifndef mingw32_HOST_OS+import Control.Monad.IO.Class (liftIO)+import System.Posix.Signals+import Control.Concurrent (myThreadId)+import Control.Exception.Base (throwTo, AsyncException(..))+#endif++isServerVersionSupported :: H.Session Bool+isServerVersionSupported = do+ ver <- H.query () pgVersion+ return $ read (cs ver) >= minimumPgVersion+ where+ pgVersion =+ H.statement "SHOW server_version_num"+ HE.unit (HD.singleRow $ HD.value HD.text) True++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stdin LineBuffering+ hSetBuffering stderr NoBuffering++ conf <- readOptions+ let port = configPort conf+ pgSettings = cs (configDatabase conf)+ appSettings = setPort port+ . setServerName (cs $ "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)++ pool <- P.acquire (configPool conf, 10, pgSettings)++ result <- P.use pool $ do+ supported <- isServerVersionSupported+ unless supported $ error (+ "Cannot run in this PostgreSQL version, PostgREST needs at least "+ <> show minimumPgVersion)+ getDbStructure (cs $ configSchema conf)++ refDbStructure <- newIORef $ either (error.show) id result++#ifndef mingw32_HOST_OS+ tid <- myThreadId+ forM_ [sigINT, sigTERM] $ \sig ->+ void $ installHandler sig (Catch $ do+ P.release pool+ throwTo tid UserInterrupt+ ) Nothing++ void $ installHandler sigHUP (+ Catch . void . P.use pool $ do+ s <- getDbStructure (cs $ configSchema conf)+ liftIO $ atomicWriteIORef refDbStructure s+ ) Nothing+#endif++ runSettings appSettings $ postgrest conf refDbStructure pool
postgrest.cabal view
@@ -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.1.1+version: 0.3.2.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE@@ -22,29 +22,34 @@ Default: False executable postgrest- main-is: PostgREST/Main.hs+ main-is: Main.hs default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options:+ -threaded+ -rtsopts+ "-with-rtsopts=-N -I2" default-language: Haskell2010 build-depends: aeson (>= 0.8 && < 0.10) || (>= 0.11 && < 0.12)- , base >= 4.8 && < 5+ , base >= 4.8 && < 6 , bytestring+ , bytestring-tree-builder == 0.2.7 , case-insensitive , cassava , containers , contravariant , errors- , hasql >= 0.19.9 && < 0.20- , hasql-pool >= 0.4 && < 0.5- , hasql-transaction >= 0.4.3 && < 0.5+ , hasql == 0.19.12+ , hasql-pool == 0.4.1+ , hasql-transaction == 0.4.5 , http-types , interpolatedstring-perl6 , jwt- , lens >=3.8 && < 5.0- , lens-aeson >= 1.0.0.0 && < 1.1.0.0+ , 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 , postgrest , regex-tdfa , safe >= 0.3 && < 0.4@@ -52,6 +57,7 @@ , string-conversions , text , time+ , transformers , unordered-containers , vector , wai >= 3.0.1@@ -64,25 +70,13 @@ if !os(windows) build-depends: unix >= 2.7 && < 3 - hs-source-dirs: src- other-modules: Paths_postgrest- , PostgREST.App- , PostgREST.Auth- , PostgREST.Config- , PostgREST.Error- , PostgREST.Middleware- , PostgREST.Parsers- , PostgREST.DbStructure- , PostgREST.QueryBuilder- , PostgREST.RangeQuery- , PostgREST.ApiRequest- , PostgREST.Types+ hs-source-dirs: main library default-language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes build-depends: aeson- , base >=4.6 && <5+ , base , bytestring , case-insensitive , cassava@@ -95,8 +89,8 @@ , http-types , interpolatedstring-perl6 , jwt- , lens- , lens-aeson+ , microlens+ , microlens-aeson , mtl , optparse-applicative , parsec@@ -135,7 +129,7 @@ Default-Language: Haskell2010 default-extensions: OverloadedStrings, ScopedTypeVariables, QuasiQuotes ghc-options: -threaded -rtsopts -with-rtsopts=-N- Hs-Source-Dirs: test, src+ Hs-Source-Dirs: test Main-Is: Main.hs Other-Modules: Feature.AuthSpec , Feature.ConcurrentSpec@@ -147,18 +141,6 @@ , Feature.RangeSpec , Feature.StructureSpec , Feature.UnicodeSpec- , Paths_postgrest- , PostgREST.App- , PostgREST.Auth- , PostgREST.Config- , PostgREST.Error- , PostgREST.Middleware- , PostgREST.Parsers- , PostgREST.DbStructure- , PostgREST.QueryBuilder- , PostgREST.RangeQuery- , PostgREST.ApiRequest- , PostgREST.Types , SpecHelper , TestTypes Build-Depends: aeson@@ -175,18 +157,19 @@ , hasql-pool , hasql-transaction , heredoc- , hspec == 2.2.*+ , hspec , hspec-wai , hspec-wai-json , http-types , interpolatedstring-perl6 , jwt- , lens- , lens-aeson+ , microlens+ , microlens-aeson , monad-control , mtl , optparse-applicative , parsec+ , postgrest , process , regex-tdfa , safe@@ -197,7 +180,6 @@ , transformers , transformers-base , unordered-containers- , unix , vector , wai , wai-cors
src/PostgREST/ApiRequest.hs view
@@ -1,26 +1,32 @@ module PostgREST.ApiRequest where -import qualified Data.Aeson as JSON-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL-import qualified Data.Csv as CSV-import Data.List (find)-import qualified Data.HashMap.Strict as M-import qualified Data.Set as S-import Data.Maybe (fromMaybe, isJust, isNothing,- listToMaybe, fromJust)-import Control.Monad (join)-import Data.Monoid ((<>))-import Data.String.Conversions (cs)-import qualified Data.Text as T-import qualified Data.Vector as V-import Network.Wai (Request (..))-import Network.Wai.Parse (parseHttpAccept)-import PostgREST.RangeQuery (NonnegRange, rangeRequested)-import PostgREST.Types (QualifiedIdentifier (..),- Schema, Payload(..),- UniformObjects(..))-import Data.Ranged.Ranges (singletonRange)+import qualified Data.Aeson as JSON+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Csv as CSV+import Data.List (find, sortBy)+import qualified Data.HashMap.Strict as M+import qualified Data.Set as S+import Data.Maybe (fromMaybe, isJust, isNothing,+ listToMaybe, 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.URI (parseSimpleQuery)+import Network.Wai (Request (..))+import Network.Wai.Parse (parseHttpAccept)+import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange)+import PostgREST.Types (QualifiedIdentifier (..),+ Schema, Payload(..),+ UniformObjects(..))+import Data.Ranged.Ranges (singletonRange, rangeIntersection) type RequestBody = BL.ByteString @@ -52,11 +58,11 @@ if it is an action we are able to perform. -} data ApiRequest = ApiRequest {- -- | Set to Nothing for unknown HTTP verbs+ -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST iAction :: Action- -- | Set to Nothing for malformed range- , iRange :: NonnegRange- -- | Set to Nothing for strangely nested urls+ -- | Requested range of rows within response+ , iRange :: M.HashMap String 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@@ -72,8 +78,12 @@ , iFilters :: [(String, String)] -- | &select parameter used to shape the response , iSelect :: String- -- | &order parameter- , iOrder :: Maybe String+ -- | &order parameters for each level+ , iOrder :: [(String,String)]+ -- | Alphabetized (canonical) request query string for response URLs+ , iCanonicalQS :: String+ -- | JSON Web Token+ , iJWT :: T.Text } -- | Examines HTTP request and translates it into user intent.@@ -113,6 +123,13 @@ Nothing -> PayloadParseError "All lines must have same number of fields" Just json -> PayloadJSON json) (CSV.decodeByName reqBody)+ -- This is a Left value because form-urlencoded is not a content+ -- type which we ever use for responses, only something we handle+ -- just this once for requests+ Left "application/x-www-form-urlencoded" ->+ PayloadJSON . UniformObjects . V.singleton . M.fromList+ . map (cs *** JSON.String . cs) . parseSimpleQuery+ $ cs reqBody Left accept -> PayloadParseError $ "Content-type not acceptable: " <> accept@@ -124,18 +141,23 @@ ApiRequest { iAction = action- , iRange = if singular then singletonRange 0 else rangeRequested hdrs , iTarget = target+ , iRange = M.insert "limit" (rangeIntersection headerRange urlRange) $+ M.fromList [ (cs k, restrictRange (readMaybe =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ] , iAccepts = pickContentType $ lookupHeader "accept" , iPayload = relevantPayload , iPreferRepresentation = representation , iPreferSingular = singular , iPreferCount = not $ singular || hasPrefer "count=none"- , iFilters = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]- , iSelect = if method == "DELETE"- then "*"- else fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams- , iOrder = join $ lookup "order" qParams+ , 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 } where@@ -155,6 +177,20 @@ | hasPrefer "return=representation" = Full | hasPrefer "return=minimal" = None | otherwise = HeadersOnly+ auth = fromMaybe "" $ lookupHeader hAuthorization+ tokenStr = case T.split (== ' ') (cs auth) of+ ("Bearer" : t : _) -> t+ _ -> ""+ endingIn:: [T.Text] -> T.Text -> Bool+ endingIn xx key = lastWord `elem` xx+ where lastWord = last $ T.split (=='.') key++ headerRange = if singular then singletonRange 0 else rangeRequested hdrs+ urlOffsetRange = rangeGeq . fromMaybe (0::Integer) $+ readMaybe =<< join (lookup "offset" qParams)+ urlRange = restrictRange+ (readMaybe =<< join (lookup "limit" qParams))+ urlOffsetRange -- PRIVATE ---------------------------------------------------------------
src/PostgREST/App.hs view
@@ -7,12 +7,11 @@ ) where import Control.Applicative-import Control.Arrow ((***))-import Control.Monad (join) import Data.Bifunctor (first)-import Data.List (find, sortBy, delete)-import Data.Maybe (isJust, fromMaybe, fromJust, mapMaybe)-import Data.Ord (comparing)+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)@@ -24,10 +23,9 @@ import Text.Parsec.Error import Text.ParserCombinators.Parsec (parse) -import Network.HTTP.Base (urlEncodeVars) import Network.HTTP.Types.Header import Network.HTTP.Types.Status-import Network.HTTP.Types.URI (parseSimpleQuery)+import Network.HTTP.Types.URI (renderSimpleQuery) import Network.Wai import Network.Wai.Middleware.RequestLogger (logStdout) @@ -38,16 +36,18 @@ import qualified Data.Vector as V import qualified Hasql.Transaction as H +import qualified Data.HashMap.Strict as M+ import PostgREST.ApiRequest (ApiRequest(..), ContentType(..) , Action(..), Target(..) , PreferRepresentation (..) , userApiRequest)-import PostgREST.Auth (tokenJWT)+import PostgREST.Auth (tokenJWT, jwtClaims, containsRole) import PostgREST.Config (AppConfig (..)) import PostgREST.DbStructure import PostgREST.Error (errResponse, pgErrResponse) import PostgREST.Parsers-import PostgREST.RangeQuery+import PostgREST.RangeQuery (NonnegRange, allRange, rangeOffset, restrictRange) import PostgREST.Middleware import PostgREST.QueryBuilder ( callProc , addJoinConditions@@ -64,21 +64,33 @@ import Prelude -postgrest :: AppConfig -> DbStructure -> P.Pool -> Application-postgrest conf dbStructure pool =+postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> Application+postgrest conf refDbStructure pool = let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in middle $ \ req respond -> do time <- getPOSIXTime body <- strictRequestBody req+ dbStructure <- readIORef refDbStructure - let handleReq = runWithClaims conf time (app dbStructure conf body) req- resp <- either pgErrResponse id <$> P.use pool- (HT.run handleReq HT.ReadCommitted HT.Write)+ 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 -app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Transaction Response-app dbStructure conf reqBody req =+transactionMode :: Action -> H.Mode+transactionMode ActionRead = HT.Read+transactionMode ActionInfo = HT.Read+transactionMode _ = HT.Write++app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response+app dbStructure conf apiRequest = let -- TODO: blow up for Left values (there is a middleware that checks the headers) contentType = either (const ApplicationJSON) id (iAccepts apiRequest)@@ -91,7 +103,7 @@ Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (q, cq) -> do let singular = iPreferSingular apiRequest- stm = createReadStatement q cq range singular+ stm = createReadStatement q cq singular shouldCount (contentType == TextCSV) respondToRange $ do row <- H.query () stm@@ -102,11 +114,7 @@ else responseLBS status200 [contentTypeH] (cs body) else do let (status, contentRange) = rangeHeader queryTotal tableTotal- canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?- . sortBy (comparing fst)- . map (join (***) cs)- . parseSimpleQuery- $ rawQueryString req+ canonical = iCanonicalQS apiRequest return $ responseLBS status [contentTypeH, contentRange, ("Content-Location",@@ -124,14 +132,15 @@ let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload row <- H.query uniform stm- let (_, _, location, body) = extractQueryResult row- return $ responseLBS status201- [- contentTypeH,- (hLocation, "/" <> cs table <> "?" <> cs location)- ]- $ if iPreferRepresentation apiRequest == Full then cs body else ""+ let (_, _, fs, body) = extractQueryResult row+ header =+ if null fs then []+ else [(hLocation, "/" <> cs table <> renderLocationFields fs)] + return $ if iPreferRepresentation apiRequest == Full+ then responseLBS status201 (contentTypeH : header) (cs body)+ else responseLBS status201 header ""+ (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e@@ -143,33 +152,39 @@ s = case () of _ | queryTotal == 0 -> status404 | iPreferRepresentation apiRequest == Full -> status200 | otherwise -> status204- return $ responseLBS s [contentTypeH, r]- $ if iPreferRepresentation apiRequest == Full then cs body else ""+ return $ if iPreferRepresentation apiRequest == Full+ then responseLBS s [contentTypeH, r] (cs body)+ else responseLBS s [r] "" (ActionDelete, TargetIdent qi, Nothing) -> case mutateSqlParts of Left e -> return $ responseLBS status400 [jsonH] $ cs e Right (sq,mq) -> do let emptyUniform = UniformObjects V.empty- let fakeload = PayloadJSON emptyUniform- let stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload+ fakeload = PayloadJSON emptyUniform+ stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload row <- H.query emptyUniform stm- let (_, queryTotal, _, _) = extractQueryResult row+ let (_, queryTotal, _, body) = extractQueryResult row+ r = contentRangeH 1 0 (toInteger <$> Just queryTotal) return $ if queryTotal == 0 then notFound- else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""+ else if iPreferRepresentation apiRequest == Full+ then responseLBS status200 [contentTypeH, r] (cs body)+ else responseLBS status204 [r] "" (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->- if isJust $ find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure)- then 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 in- return $ responseLBS status200 [jsonH, allOrigins] $ cs body- else- return notFound+ 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 (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) -> do@@ -179,7 +194,7 @@ let p = V.head payload jwtSecret = configJwtSecret conf respondToRange $ do- row <- H.query () (callProc qi p range shouldCount)+ row <- H.query () (callProc qi p topLevelRange shouldCount) returnJWT <- H.query qi doesProcReturnJWT let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, emptyArray) row (status, contentRange) = rangeHeader queryTotal tableTotal@@ -210,25 +225,32 @@ allPrKeys = dbPrimaryKeys dbStructure allOrigins = ("Access-Control-Allow-Origin", "*") :: Header schema = cs $ configSchema conf- apiRequest = userApiRequest schema req reqBody shouldCount = iPreferCount apiRequest- range = restrictRange (configMaxRows conf) $ iRange apiRequest- readDbRequest = DbRead <$> buildReadRequest (dbRelations dbStructure) 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 range == emptyRange+ respondToRange response = if topLevelRange == emptyRange then return $ errResponse status416 "HTTP Range error" else response- rangeHeader queryTotal tableTotal = let frm = rangeOffset range+ rangeHeader queryTotal tableTotal = let frm = rangeOffset topLevelRange to = frm + toInteger queryTotal - 1 contentRange = contentRangeH frm to (toInteger <$> tableTotal) status = rangeStatus frm to (toInteger <$> tableTotal) in (status, contentRange) +splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)+splitKeyValue kv = (k, BS.tail v)+ where (k, v) = BS.break (== '=') kv++renderLocationFields :: [BS.ByteString] -> BS.ByteString+renderLocationFields fields =+ renderSimpleQuery True $ map splitKeyValue fields+ rangeStatus :: Integer -> Integer -> Maybe Integer -> Status rangeStatus _ _ Nothing = status200 rangeStatus frm to (Just total)@@ -272,68 +294,122 @@ (first formatRelationError . addRelations schema allRels Nothing) request >>= addJoinConditions schema -buildReadRequest :: [Relation] -> ApiRequest -> Either Text ReadRequest-buildReadRequest allRels apiRequest =- augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> readRequest <*> ord) <*> flts)+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- selStr = iSelect apiRequest- orderS = iOrder apiRequest- action = iAction apiRequest- target = iTarget apiRequest+ 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 - rootName = if action == ActionRead- then rootTableName- else sourceCTEName- filters = if action == ActionRead- then iFilters apiRequest- else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update- rels = case action of+ 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- readRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr- addOrder (Node (q,i) f) o = Node (q{order=o}, i) f- flts = mapM pRequestFilter filters- ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS buildMutateRequest :: ApiRequest -> Either Text MutateRequest-buildMutateRequest apiRequest =- mutateApiRequest+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- target = iTarget apiRequest payload = fromJust $ iPayload apiRequest rootTableName = -- TODO: Make it safe+ let target = iTarget apiRequest in case target of (TargetIdent (QualifiedIdentifier _ t) ) -> t _ -> undefined- mutateApiRequest = case action of- ActionCreate -> Insert rootTableName <$> pure payload- ActionUpdate -> Update rootTableName <$> pure payload <*> cond- ActionDelete -> Delete rootTableName <$> cond- _ -> Left "Unsupported HTTP verb"- mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table- cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters+ 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 ([], flt) (Node (q@Select {flt_=flts}, i) forest) = Node (q {flt_=flt:flts}, i) forest-addFilter (path, flt) (Node rn forest) =+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 filter is silenty dropped in the Request does not contain the required path- Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)+ 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 = find ((name==).fst.snd.rootLabel) forst+ where+ maybeNode :: Maybe ReadRequest+ maybeNode = find fnd forst+ where+ fnd :: ReadRequest -> Bool+ fnd (Node (_,(n,_,_)) _) = n == name -- in a relation where one of the tables mathces "TableName" -- replace the name to that table with pg_source@@ -359,4 +435,4 @@ extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount-extractQueryResult = fromMaybe (Nothing, 0, "", "")+extractQueryResult = fromMaybe (Nothing, 0, [], "")
src/PostgREST/Auth.hs view
@@ -12,20 +12,20 @@ very simple authentication system inside the PostgreSQL database. -} module PostgREST.Auth (- setRole- , claimsToSQL+ claimsToSQL+ , containsRole , jwtClaims , tokenJWT ) where -import Control.Lens+import Lens.Micro+import Lens.Micro.Aeson import Data.Aeson (Value (..), parseJSON, toJSON)-import Data.Aeson.Lens import Data.Aeson.Types (parseMaybe, emptyObject, emptyArray) import qualified Data.ByteString as BS import qualified Data.Vector as V import qualified Data.HashMap.Strict as M-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, maybeToList, fromJust) import Data.Monoid ((<>)) import Data.String.Conversions (cs) import Data.Text (Text)@@ -34,47 +34,41 @@ import qualified Web.JWT as JWT {-|- Receives a map of JWT claims and returns a list- of PostgreSQL statements to set the claims as user defined GUCs.- Except if we have a claim called role,- this one is mapped to a SET ROLE statement.- In case there is any problem decoding the JWT it returns Nothing.+ Receives a map of JWT claims and returns a list of PostgreSQL+ statements to set the claims as user defined GUCs. Except if we+ have a claim called role, this one is mapped to a SET ROLE+ statement. -} claimsToSQL :: M.HashMap Text Value -> [BS.ByteString]-claimsToSQL = map setVar . M.toList- where- setVar ("role", String val) = setRole val- setVar (k, val) = "set local " <> cs (pgFmtIdent $ "postgrest.claims." <> k)- <> " = " <> cs (valueToVariable val) <> ";"- valueToVariable = pgFmtLit . unquoted+claimsToSQL claims = roleStmts <> varStmts+ where+ roleStmts = maybeToList $+ (\r -> "set local role " <> r <> ";") . cs . 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) <> ";"+ valueToVariable = pgFmtLit . unquoted {-| Receives the JWT secret (from config) and a JWT and returns a map of JWT claims- In case there is any problem decoding the JWT it returns Nothing.+ In case there is any problem decoding the JWT it returns an error Text -}-- jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> Either Text (M.HashMap Text Value)-jwtClaims secret input time =- case mClaims of- Nothing -> Right M.empty- Just claims -> do- let mExp = claims ^? key "exp" . _Integer- expired = fromMaybe False $ (<= time) . fromInteger <$> mExp- if expired- then Left "JWT expired"- else Right (value2map claims)+jwtClaims _ "" _ = Right 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 where- mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret input+ isExpired claims =+ let mExp = claims ^? key "exp" . _Integer+ in fromMaybe False $ (<= time) . fromInteger <$> mExp+ mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret jwt value2map (Object o) = o value2map _ = M.empty -{-| Receives the name of a role and returns a SET ROLE statement -}-setRole :: Text -> BS.ByteString-setRole r = "set local role " <> cs (pgFmtLit r) <> ";"-- {-| Receives the JWT secret (from config) and a JWT and a JSON value and returns a signed JWT.@@ -85,3 +79,10 @@ jcs = parseMaybe parseJSON obj :: Maybe JWT.JWTClaimsSet in JWT.encodeSigned JWT.HS256 secret $ fromMaybe JWT.def jcs tokenJWT secret _ = tokenJWT secret emptyArray++{-|+ Whether a response from jwtClaims contains a role claim+-}+containsRole :: Either Text (M.HashMap Text Value) -> Bool+containsRole (Left _) = False+containsRole (Right claims) = M.member "role" claims
src/PostgREST/Error.hs view
@@ -21,9 +21,15 @@ errResponse :: HT.Status -> Text -> Response errResponse status message = responseLBS status [(hContentType, "application/json")] (cs $ T.concat ["{\"message\":\"",message,"\"}"]) -pgErrResponse :: P.UsageError -> Response-pgErrResponse e = responseLBS (httpStatus e)- [(hContentType, "application/json")] (JSON.encode e)+pgErrResponse :: Bool -> P.UsageError -> Response+pgErrResponse authed e =+ let status = httpStatus authed e+ jsonType = (hContentType, "application/json")+ wwwAuth = ("WWW-Authenticate", "Bearer")+ hdrs = if status == HT.status401+ then [jsonType, wwwAuth]+ else [jsonType] in+ responseLBS status hdrs (JSON.encode e) instance JSON.ToJSON P.UsageError where toJSON (P.ConnectionError e) = JSON.object [@@ -60,10 +66,9 @@ "message" .= ("Database client error"::String), "details" .= (fmap cs d::Maybe T.Text)] -httpStatus :: P.UsageError -> HT.Status-httpStatus (P.ConnectionError _) =- HT.status500-httpStatus (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =+httpStatus :: Bool -> P.UsageError -> HT.Status+httpStatus _ (P.ConnectionError _) = HT.status500+httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) = case cs c of '0':'8':_ -> HT.status503 -- pg connection err '0':'9':_ -> HT.status500 -- triggered action exception@@ -88,7 +93,7 @@ 'P':'0':_ -> HT.status500 -- PL/pgSQL Error 'X':'X':_ -> HT.status500 -- internal Error "42P01" -> HT.status404 -- undefined table- "42501" -> HT.status404 -- insufficient privilege+ "42501" -> if authed then HT.status403 else HT.status401 -- insufficient privilege _ -> HT.status400-httpStatus (P.SessionError (H.ResultError _)) = HT.status500-httpStatus (P.SessionError (H.ClientError _)) = HT.status503+httpStatus _ (P.SessionError (H.ResultError _)) = HT.status500+httpStatus _ (P.SessionError (H.ClientError _)) = HT.status503
− src/PostgREST/Main.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE CPP #-}--module Main where---import PostgREST.App-import PostgREST.Config (AppConfig (..),- minimumPgVersion,- prettyVersion,- readOptions)-import PostgREST.DbStructure--import Control.Monad-import Data.Monoid ((<>))-import Data.String.Conversions (cs)-import qualified Hasql.Query as H-import qualified Hasql.Session as H-import qualified Hasql.Decoders as HD-import qualified Hasql.Encoders as HE-import qualified Hasql.Pool as P-import Network.Wai.Handler.Warp-import System.IO (BufferMode (..),- hSetBuffering, stderr,- stdin, stdout)-import Web.JWT (secret)-#ifndef mingw32_HOST_OS-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- where- pgVersion =- H.statement "SHOW server_version_num"- HE.unit (HD.singleRow $ HD.value HD.text) True--main :: IO ()-main = do- hSetBuffering stdout LineBuffering- hSetBuffering stdin LineBuffering- hSetBuffering stderr NoBuffering-- conf <- readOptions- let port = configPort conf- pgSettings = cs (configDatabase conf)- appSettings = setPort port- . setServerName (cs $ "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)-- pool <- P.acquire (configPool conf, 10, pgSettings)--#ifndef mingw32_HOST_OS- tid <- myThreadId- forM_ [sigINT, sigTERM] $ \sig ->- void $ installHandler sig (Catch $ do- P.release pool- throwTo tid UserInterrupt- ) Nothing-#endif-- result <- P.use pool $ do- supported <- isServerVersionSupported- unless supported $ error (- "Cannot run in this PostgreSQL version, PostgREST needs at least "- <> show minimumPgVersion)- getDbStructure (cs $ configSchema conf)-- let dbStructure = either (error.show) id result- runSettings appSettings $ postgrest conf dbStructure pool
src/PostgREST/Middleware.hs view
@@ -3,16 +3,13 @@ module PostgREST.Middleware where -import Control.Monad (unless)-import qualified Data.ByteString as BS+import Data.Aeson (Value (..)) import qualified Data.HashMap.Strict as M-import Data.Maybe (fromMaybe) import Data.String.Conversions (cs) import Data.Text-import Data.Time.Clock (NominalDiffTime) import qualified Hasql.Transaction as H -import Network.HTTP.Types.Header (hAccept, hAuthorization)+import Network.HTTP.Types.Header (hAccept) import Network.HTTP.Types.Status (status400, status415) import Network.Wai (Application, Request (..), Response, requestHeaders)@@ -20,37 +17,25 @@ import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Static (only, staticPolicy) -import PostgREST.ApiRequest (pickContentType)-import PostgREST.Auth (setRole, jwtClaims, claimsToSQL)+import PostgREST.ApiRequest (ApiRequest(..), pickContentType)+import PostgREST.Auth (claimsToSQL) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) import Prelude hiding (concat, null) -runWithClaims :: AppConfig -> NominalDiffTime ->- (Request -> H.Transaction Response) ->- Request -> H.Transaction Response-runWithClaims conf time app req = do- H.sql setAnon- let tokenStr = case split (== ' ') (cs auth) of- ("Bearer" : t : _) -> t- _ -> ""- eClaims = jwtClaims jwtSecret tokenStr time- case eClaims of- Left e -> clientErr e- Right claims ->- if M.null claims && not (null tokenStr)- then clientErr "Invalid JWT"- else do- let cmdBatch = mconcat $ claimsToSQL claims- unless (BS.null cmdBatch) (H.sql cmdBatch)- app req+runWithClaims :: AppConfig -> Either Text (M.HashMap Text Value) ->+ (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 where- hdrs = requestHeaders req- jwtSecret = configJwtSecret conf- auth = fromMaybe "" $ lookup hAuthorization hdrs- anon = cs $ configAnonRole conf- setAnon = setRole anon+ anon = String . cs $ configAnonRole conf clientErr = return . errResponse status400 unsupportedAccept :: Application -> Application
src/PostgREST/Parsers.hs view
@@ -6,22 +6,27 @@ import Control.Applicative hiding ((<$>)) import Data.Monoid import Data.String.Conversions (cs)-import Data.Text (Text)+import Data.Text (Text, intercalate) import Data.Tree import PostgREST.QueryBuilder (operators) import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>))+import PostgREST.RangeQuery (NonnegRange,allRange) pRequestSelect :: Text -> Parser ReadRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest- return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree+ return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree where+ readQuery = Select [] [rootNodeName] [] Nothing allRange treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest- treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =+ treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) = case fldForest of [] -> Node (q {select=fld:select q}, i) rForest- _ -> Node (q, i) (foldr treeEntry (Node (Select [] [fn] [] Nothing, (fn, Nothing)) []) fldForest:rForest)+ _ -> Node (q, i) newForest+ where+ newForest =+ foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)@@ -33,6 +38,19 @@ op = fst <$> opVal val = snd <$> opVal +pRequestOrder :: (String, String) -> Either ParseError (Path, [OrderTerm])+pRequestOrder (k, v) = (,) <$> path <*> ord+ where+ treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k+ path = fst <$> treePath+ ord = parse pOrder ("failed to parse order (" ++ v ++ ")") v++pRequestRange :: (String, NonnegRange) -> Either ParseError (Path, NonnegRange)+pRequestRange (k, v) = (,) <$> path <*> pure v+ where+ treePath = parse pTreePath ("failed to parser tree path (" ++ k ++ ")") k+ path = fst <$> treePath+ ws :: Parser Text ws = cs <$> many (oneOf " \t") @@ -51,16 +69,24 @@ pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldTree :: Parser (Tree SelectItem)-pFieldTree = try (Node <$> pSelect <*> between (char '{') (char '}') pFieldForest)+pFieldTree = try (Node <$> pSimpleSelect <*> between (char '{') (char '}') pFieldForest) <|> Node <$> pSelect <*> pure [] pStar :: Parser Text pStar = cs <$> (string "*" *> pure ("*"::String)) + pFieldName :: Parser Text-pFieldName = cs <$> (many1 (letter <|> digit <|> oneOf "_")- <?> "field name (* or [a..z0..9_])")+pFieldName = do+ matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"+ return $ intercalate "-" $ map cs matches+ where+ isDash :: GenParser Char st ()+ isDash = try ( char '-' >> notFollowedBy (char '>') )+ dash :: Parser Char+ dash = isDash *> pure '-' + pJsonPathStep :: Parser Text pJsonPathStep = cs <$> try (string "->" *> pFieldName) @@ -70,12 +96,28 @@ pField :: Parser Field pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath +aliasSeparator :: Parser ()+aliasSeparator = char ':' >> notFollowedBy (char ':')++pSimpleSelect :: Parser SelectItem+pSimpleSelect = lexeme $ try ( do+ alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )+ fld <- pField+ return (fld, Nothing, alias)+ )+ pSelect :: Parser SelectItem pSelect = lexeme $- try ((,) <$> pField <*>((cs <$>) <$> optionMaybe (string "::" *> many letter)) )+ try (+ do+ alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )+ fld <- pField+ cast <- optionMaybe (string "::" *> many letter)+ return (fld, cs <$> cast, alias)+ ) <|> do s <- pStar- return ((s, Nothing), Nothing)+ return ((s, Nothing), Nothing, Nothing) pOperator :: Parser Operator pOperator = cs <$> (pOp <?> "operator (eq, gt, ...)")
src/PostgREST/QueryBuilder.hs view
@@ -35,18 +35,18 @@ import qualified Data.Aeson as JSON import Data.Int (Int64) -import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset)-import Control.Error (note, fromMaybe, mapMaybe)+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.List (find) import Data.Monoid ((<>)) import Data.Text (Text, intercalate, unwords, replace, isInfixOf, toLower, split)-import qualified Data.Text as T (map, takeWhile)+import qualified Data.Text as T (map, takeWhile, null) import qualified Data.Text.Encoding as T import Data.String.Conversions (cs) import Control.Applicative ((<|>))-import Control.Monad (join)+import Control.Monad (replicateM) import Data.Tree (Tree(..)) import qualified Data.Vector as V import PostgREST.Types@@ -61,10 +61,21 @@ import Prelude hiding (unwords) import PostgREST.ApiRequest (PreferRepresentation (..)) +{-| The generic query result format used by API responses. The location header+ is represented as a list of strings containing variable bindings like+ @"k1=eq.42"@, or the empty list if there is no location header.+-}+type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString) -{-| The generic query result format used by API responses -}-type ResultsWithCount = (Maybe Int64, Int64, BS.ByteString, BS.ByteString)+standardRow :: HD.Row ResultsWithCount+standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8+ <*> HD.value header <*> HD.value HD.bytea+ where+ header = HD.array $ HD.arrayDimension replicateM $ HD.arrayValue HD.bytea +noLocationF :: Text+noLocationF = "array[]::text[]"+ {-| Read and Write api requests use a similar response format which includes various record counts and possible location header. This is the decoder for that common type of query.@@ -72,16 +83,10 @@ decodeStandard :: HD.Result ResultsWithCount decodeStandard = HD.singleRow standardRow- where- standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8- <*> HD.value HD.bytea <*> HD.value HD.bytea decodeStandardMay :: HD.Result (Maybe ResultsWithCount) decodeStandardMay = HD.maybeRow standardRow- where- standardRow = (,,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8- <*> HD.value HD.bytea <*> HD.value HD.bytea {-| JSON and CSV payloads from the client are given to us as UniformObjects (objects who all have the same keys),@@ -91,19 +96,19 @@ encodeUniformObjs = contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json) -createReadStatement :: SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool ->+createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> H.Query () ResultsWithCount-createReadStatement selectQuery countQuery range isSingle countTotal asCsv =+createReadStatement selectQuery countQuery isSingle countTotal asCsv = unicodeStatement sql HE.unit decodeStandard True where sql = [qc| WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols}- FROM ( SELECT * FROM {sourceCTEName} {limitF range}) t |]+ FROM ( SELECT * FROM {sourceCTEName}) t |] countResultF = if countTotal then "("<>countQuery<>")" else "null" cols = intercalate ", " [ countResultF <> " AS total_result_set", "pg_catalog.count(t) AS page_total",- "'' AS header",+ noLocationF <> " AS header", bodyF <> " AS body" ] bodyF@@ -121,7 +126,7 @@ where sql = [qc| WITH {sourceCTEName} AS ({mutateQuery})- SELECT '', 0, '', '' |]+ SELECT '', 0, {noLocationF}, '' |] createWriteStatement qi _ mutateQuery isSingle HeadersOnly pKeys _ (PayloadJSON (UniformObjects _)) =@@ -134,7 +139,7 @@ cols = intercalate ", " [ "'' AS total_result_set", "pg_catalog.count(t) AS page_total",- if isSingle then locationF pKeys else "''",+ if isSingle then locationF pKeys else noLocationF, "''" ] @@ -149,7 +154,7 @@ cols = intercalate ", " [ "'' AS total_result_set", -- when updateing it does not make sense "pg_catalog.count(t) AS page_total",- if isSingle then locationF pKeys else "''" <> " AS header",+ if isSingle then locationF pKeys else noLocationF <> " AS header", bodyF <> " AS body" ] bodyF@@ -158,18 +163,18 @@ | otherwise = asJsonF addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest-addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _)) forest) =+addRelations schema allRelations parentNode node@(Node readNode@(query, (name, _, alias)) forest) = case parentNode of- (Just (Node (Select{from=[parentTable]}, (_, _)) _)) -> Node <$> (addRel readNode <$> rel) <*> updatedForest+ (Just (Node (Select{from=[parentTable]}, (_, _, _)) _)) -> Node <$> (addRel readNode <$> rel) <*> updatedForest where rel = note ("no relation between " <> parentTable <> " and " <> name) $ findRelationByTable schema name parentTable <|> findRelationByColumn schema parentTable name- addRel :: (ReadQuery, (NodeName, Maybe Relation)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation))- addRel (query', (n, _)) r = (query' {from=fromRelation}, (n, Just r))+ 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)) <$> updatedForest+ _ -> Node (query, (name, Nothing, alias)) <$> updatedForest where updatedForest = mapM (addRelations schema allRelations (Just node)) forest -- Searches through all the relations and returns a match given the parameter conditions.@@ -182,25 +187,18 @@ where n `colMatches` rc = (cs ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (cs n :: BS.ByteString) addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest-addJoinConditions schema (Node (query, (n, r)) forest) =+addJoinConditions schema (Node nn@(query, (n, r, a)) forest) = case r of- Nothing -> Node (updatedQuery, (n,r)) <$> updatedForest -- this is the root node- Just rel@Relation{relType=Child} -> Node (addCond updatedQuery (getJoinConditions rel),(n,r)) <$> updatedForest- Just Relation{relType=Parent} -> Node (updatedQuery, (n,r)) <$> updatedForest+ 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)) <$> updatedForest+ Node (qq, (n, r, a)) <$> updatedForest where- query' = addCond updatedQuery (getJoinConditions rel)+ query' = addCond query (getJoinConditions rel) qq = query'{from=tableName linkTable : from query'} _ -> Left "unknown relation" where- -- add parentTable and parentJoinConditions to the query- updatedQuery = foldr (flip addCond) query parentJoinConditions- where- parentJoinConditions = map (getJoinConditions . snd) parents- parents = mapMaybe (getParents . rootLabel) forest- getParents (_, (tbl, Just rel@Relation{relType=Parent})) = Just (tbl, rel)- getParents _ = Nothing updatedForest = mapM (addJoinConditions schema) forest addCond query' con = query'{flt_=con ++ flt_ query'} @@ -262,7 +260,7 @@ requestToCountQuery :: Schema -> DbRequest -> SqlQuery requestToCountQuery _ (DbMutate _) = undefined-requestToCountQuery schema (DbRead (Node (Select _ _ conditions _, (mainTbl, _)) _)) =+requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _, _)) _)) = unwords [ "SELECT pg_catalog.count(1)", "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,@@ -276,7 +274,7 @@ requestToQuery :: Schema -> DbRequest -> SqlQuery requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined-requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (nodeName, maybeRelation)) forest)) =+requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) = query where -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name@@ -288,9 +286,10 @@ query = unwords [ "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), "FROM ", intercalate ", " (map (fromQi . toQi) tbls),- unwords (map joinStr joins),- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) localConditions )) `emptyOnNull` localConditions,- orderF (fromMaybe [] ord)+ unwords joins,+ ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,+ orderF (fromMaybe [] ord),+ limitF range ] orderF ts = if null ts@@ -304,50 +303,48 @@ <> (cs.show) (otDirection t) <> " " <> maybe "" (cs.show) (otNullOrder t) <> " " (joins, selects) = foldr getQueryParts ([],[]) forest- parentTables = map snd joins- parentConditions = join $ map (( `filter` conditions ) . filterParentConditions) parentTables- localConditions = conditions \\ parentConditions- joinStr :: (SqlFragment, TableName) -> SqlFragment- joinStr (sql, t) = "LEFT OUTER JOIN " <> sql <> " ON " <>- intercalate " AND " ( map (pgFmtCondition qi ) joinConditions )- where- joinConditions = filter (filterParentConditions t) conditions- filterParentConditions parentTable (Filter _ _ (VForeignKey (QualifiedIdentifier "" t) _)) = parentTable == t- filterParentConditions _ _ = False- getQueryParts :: Tree ReadNode -> ([(SqlFragment, TableName)], [SqlFragment]) -> ([(SqlFragment,TableName)], [SqlFragment])- getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}})) forst) (j,s) = (j,sel:s)++ getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])+ getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s) where sel = "COALESCE((" <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) " <> "FROM (" <> subquery <> ") " <> pgFmtIdent table- <> "), '[]') AS " <> pgFmtIdent name+ <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias) where subquery = requestToQuery schema (DbRead (Node n forst))- getQueryParts (Node n@(_, (name, Just Relation{relType=Parent,relTable=Table{tableName=table}})) forst) (j,s) = (joi:j,sel:s)+ getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (joi:j,sel:s) where- sel = "row_to_json(" <> pgFmtIdent table <> ".*) AS "<>pgFmtIdent name --TODO must be singular- joi = ("( " <> subquery <> " ) AS " <> pgFmtIdent table, table)+ node_name = fromMaybe name alias+ local_table_name = table <> "_" <> node_name+ replaceTableName localTableName (Filter a b (VForeignKey (QualifiedIdentifier "" _) c)) = Filter a b (VForeignKey (QualifiedIdentifier "" localTableName) c)+ replaceTableName _ x = x+ sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name+ joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name <>+ " ON " <> intercalate " AND " ( map (pgFmtCondition qi . replaceTableName local_table_name) (getJoinConditions r) ) where subquery = requestToQuery schema (DbRead (Node n forst))- getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}})) forst) (j,s) = (j,sel:s)+ getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s) where sel = "COALESCE ((" <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) " <> "FROM (" <> subquery <> ") " <> pgFmtIdent table- <> "), '[]') AS " <> pgFmtIdent name+ <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias) where subquery = requestToQuery schema (DbRead (Node n forst)) --the following is just to remove the warning --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many- getQueryParts (Node (_,(_,Nothing)) _) _ = undefined+ getQueryParts (Node (_,(_,Nothing,_)) _) _ = undefined requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) = let qi = QualifiedIdentifier schema mainTbl cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))- colsString = intercalate ", " cols in- unwords [- "INSERT INTO ", fromQi qi,- " (" <> colsString <> ")" <>- " SELECT " <> colsString <>- " FROM json_populate_recordset(null::" , fromQi qi, ", $1)"- ]+ 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)) = case rows V.!? 0 of Just obj ->@@ -361,7 +358,6 @@ Nothing -> undefined where qi = QualifiedIdentifier schema mainTbl- requestToQuery schema (DbMutate (Delete mainTbl conditions)) = query where@@ -406,7 +402,7 @@ locationF pKeys = "(" <> " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceCTEName <> " as ss limit 1)" <>- " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <>+ " SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))" <> " FROM s, json_each_text(s.r) AS json_data" <> ( if null pKeys@@ -415,7 +411,9 @@ ) <> ")" limitF :: NonnegRange -> SqlFragment-limitF r = "LIMIT " <> limit <> " OFFSET " <> offset+limitF r = if r == allRange+ then ""+ else "LIMIT " <> limit <> " OFFSET " <> offset where limit = maybe "ALL" (cs . show) $ rangeLimit r offset = cs . show $ rangeOffset r@@ -463,8 +461,8 @@ pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment-pgFmtSelectItem table (f@(_, jp), Nothing) = pgFmtField table f <> pgFmtAsJsonPath jp-pgFmtSelectItem table (f@(_, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAsJsonPath jp+pgFmtSelectItem table (f@(_, jp), Nothing, alias) = pgFmtField table f <> pgFmtAs jp alias+pgFmtSelectItem table (f@(_, jp), Just cast, alias) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs jp alias pgFmtCondition :: QualifiedIdentifier -> Filter -> SqlFragment pgFmtCondition table (Filter (col,jp) ops val) =@@ -511,9 +509,10 @@ pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs ) pgFmtJsonPath _ = "" -pgFmtAsJsonPath :: Maybe JsonPath -> SqlFragment-pgFmtAsJsonPath Nothing = ""-pgFmtAsJsonPath (Just xx) = " AS " <> last xx+pgFmtAs :: Maybe JsonPath -> Maybe Alias -> SqlFragment+pgFmtAs Nothing Nothing = ""+pgFmtAs (Just xx) Nothing = " AS " <> pgFmtIdent (last xx)+pgFmtAs _ (Just alias) = " AS " <> pgFmtIdent alias trimNullChars :: Text -> Text trimNullChars = T.takeWhile (/= '\x0')
src/PostgREST/RangeQuery.hs view
@@ -4,13 +4,14 @@ , rangeLimit , rangeOffset , restrictRange+, rangeGeq+, allRange , NonnegRange ) where import Control.Applicative import Network.HTTP.Types.Header-import PostgREST.Types () import qualified Data.ByteString.Char8 as BS import Data.Ranged.Boundaries@@ -34,18 +35,19 @@ Just parsedRange -> let [_, from, to] = readMaybe . cs <$> parsedRange lower = fromMaybe emptyRange (rangeGeq <$> from)- upper = fromMaybe (rangeGeq 0) (rangeLeq <$> to) in+ upper = fromMaybe allRange (rangeLeq <$> to) in rangeIntersection lower upper- Nothing -> rangeGeq 0+ Nothing -> allRange rangeRequested :: RequestHeaders -> NonnegRange-rangeRequested = rangeParse . fromMaybe "" . lookup hRange+rangeRequested headers = fromMaybe allRange $+ rangeParse <$> lookup hRange headers restrictRange :: Maybe Integer -> NonnegRange -> NonnegRange restrictRange Nothing r = r restrictRange (Just limit) r =- rangeIntersection r $- Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1)+ rangeIntersection r $+ Range BoundaryBelowAll (BoundaryAbove $ rangeOffset r + limit - 1) rangeLimit :: NonnegRange -> Maybe Integer rangeLimit range =@@ -62,6 +64,9 @@ rangeGeq :: Integer -> NonnegRange rangeGeq n = Range (BoundaryBelow n) BoundaryAboveAll++allRange :: NonnegRange+allRange = rangeGeq 0 rangeLeq :: Integer -> NonnegRange rangeLeq n =
src/PostgREST/Types.hs view
@@ -6,6 +6,7 @@ import Data.Text import Data.Tree import qualified Data.Vector as V+import PostgREST.RangeQuery (NonnegRange) data DbStructure = DbStructure { dbTables :: [Table]@@ -106,16 +107,17 @@ type FieldName = Text type JsonPath = [Text] type Field = (FieldName, Maybe JsonPath)+type Alias = Text type Cast = Text type NodeName = Text-type SelectItem = (Field, Maybe Cast)+type SelectItem = (Field, Maybe Cast, Maybe Alias) type Path = [Text]-data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm] } deriving (Show, Eq)+data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq) data MutateQuery = Insert { in_::TableName, qPayload::Payload } | Delete { in_::TableName, where_::[Filter] } | Update { in_::TableName, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)-type ReadNode = (ReadQuery, (NodeName, Maybe Relation))+type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) type ReadRequest = Tree ReadNode type MutateRequest = MutateQuery data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
test/Feature/AuthSpec.hs view
@@ -13,8 +13,29 @@ spec :: SpecWith Application spec = describe "authorization" $ do - it "hides tables that anonymous does not own" $- get "/authors_only" `shouldRespondWith` 404+ it "denies access to tables that anonymous does not own" $+ get "/authors_only" `shouldRespondWith` ResponseMatcher {+ matchBody = Just [json| {+ "hint":null,+ "details":null,+ "code":"42501",+ "message":"permission denied for relation authors_only"} |]+ , matchStatus = 401+ , matchHeaders = ["WWW-Authenticate" <:> "Bearer"]+ }++ it "denies access to tables that postgrest_test_author does not own" $+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" in+ request methodGet "/private_table" [auth] ""+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [json| {+ "hint":null,+ "details":null,+ "code":"42501",+ "message":"permission denied for relation private_table"} |]+ , matchStatus = 403+ , matchHeaders = []+ } it "returns jwt functions as jwt tokens" $ post "/rpc/login" [json| { "id": "jdoe", "pass": "1234" } |]
test/Feature/DeleteSpec.hs view
@@ -19,6 +19,28 @@ , matchHeaders = ["Content-Range" <:> "*/1"] } + it "returns the deleted item" $+ request methodDelete "/items?id=eq.2" [("Prefer", "return=representation")] ""+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":2}]|]+ , matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "*/1"]+ }+ it "returns the deleted item and shapes the response" $+ request methodDelete "/complex_items?id=eq.2&select=id,name" [("Prefer", "return=representation")] ""+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":2,"name":"Two"}]|]+ , matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "*/1"]+ }+ it "can embed (parent) entities" $+ request methodDelete "/tasks?id=eq.8&select=id,name,project{id}" [("Prefer", "return=representation")] ""+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|]+ , matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "*/1"]+ }+ it "actually clears items ouf the db" $ do _ <- request methodDelete "/items?id=lt.15" [] "" get "/items"
test/Feature/InsertSpec.hs view
@@ -32,6 +32,8 @@ liftIO $ do simpleBody p `shouldBe` "" simpleStatus p `shouldBe` created201+ -- should not have content type set when body is empty+ lookup hContentType (simpleHeaders p) `shouldBe` Nothing it "filters columns in result using &select" $ request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]@@ -53,6 +55,15 @@ , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8", "Location" <:> "/projects?id=eq.6"] } + context "from an html form" $+ it "accepts disparate json types" $ do+ p <- request methodPost "/menagerie"+ [("Content-Type", "application/x-www-form-urlencoded")]+ ("integer=7&double=2.71828&varchar=forms+are+fun&" <>+ "boolean=false&date=1900-01-01&money=$3.99&enum=foo")+ liftIO $ do+ simpleBody p `shouldBe` ""+ simpleStatus p `shouldBe` created201 context "with no pk supplied" $ do context "into a table with auto-incrementing pk" $@@ -110,14 +121,33 @@ simpleStatus p `shouldBe` created201 context "with compound pk supplied" $- it "builds response location header appropriately" $- post "/compound_pk" [json| { "k1":12, "k2":42 } |]- `shouldRespondWith` ResponseMatcher {- matchBody = Nothing,- matchStatus = 201,- matchHeaders = ["Location" <:> "/compound_pk?k1=eq.12&k2=eq.42"]- }+ it "builds response location header appropriately" $ do+ let inserted = [json| { "k1":12, "k2":"Rock & R+ll" } |]+ expectedObj = CompoundPK 12 "Rock & R+ll" Nothing+ expectedLoc = "/compound_pk?k1=eq.12&k2=eq.Rock%20%26%20R%2Bll"+ p <- request methodPost "/compound_pk"+ [("Prefer", "return=representation")]+ inserted+ liftIO $ do+ JSON.decode (simpleBody p) `shouldBe` Just expectedObj+ simpleStatus p `shouldBe` created201+ lookup hLocation (simpleHeaders p) `shouldBe` Just expectedLoc + r <- get expectedLoc+ liftIO $ do+ JSON.decode (simpleBody r) `shouldBe` Just [expectedObj]+ simpleStatus r `shouldBe` ok200++ context "with bulk insert" $+ it "returns 201 but no location header" $ do+ let bulkData = [json| [ {"k1":21, "k2":"hello world"}+ , {"k1":22, "k2":"bye for now"}]+ |]+ p <- request methodPost "/compound_pk" [] bulkData+ liftIO $ do+ simpleStatus p `shouldBe` created201+ lookup hLocation (simpleHeaders p) `shouldBe` Nothing+ context "with invalid json payload" $ it "fails with 400 and error" $ post "/simple_pk" "}{ x = 2" `shouldRespondWith` 400@@ -137,26 +167,36 @@ context "jsonb" $ do it "serializes nested object" $ do let inserted = [json| { "data": { "foo":"bar" } } |]+ location = "/json?data=eq.%7B%22foo%22%3A%22bar%22%7D" request methodPost "/json" [("Prefer", "return=representation")] inserted `shouldRespondWith` ResponseMatcher { matchBody = Just inserted , matchStatus = 201- , matchHeaders = ["Location" <:> [str|/json?data=eq.{"foo":"bar"}|]]+ , matchHeaders = ["Location" <:> location] } it "serializes nested array" $ do let inserted = [json| { "data": [1,2,3] } |]+ location = "/json?data=eq.%5B1%2C2%2C3%5D" request methodPost "/json" [("Prefer", "return=representation")] inserted `shouldRespondWith` ResponseMatcher { matchBody = Just inserted , matchStatus = 201- , matchHeaders = ["Location" <:> [str|/json?data=eq.[1,2,3]|]]+ , matchHeaders = ["Location" <:> location] } + context "empty object" $+ it "successfully populates table with all-default columns" $+ post "/items" "{}" `shouldRespondWith` ResponseMatcher {+ matchBody = Just ""+ , matchStatus = 201+ , matchHeaders = []+ }+ describe "CSV insert" $ do context "disparate csv types" $@@ -259,7 +299,7 @@ length rows `shouldBe` 1 let record = head rows compoundK1 record `shouldBe` 12- compoundK2 record `shouldBe` 42+ compoundK2 record `shouldBe` "42" compoundExtra record `shouldBe` Just 3 it "can update an existing record" $ do@@ -312,13 +352,15 @@ g <- get "/items?id=eq.42" liftIO $ simpleHeaders g `shouldSatisfy` matchHeader "Content-Range" "\\*/0"- request methodPatch "/items?id=eq.2" []- [json| { "id":42 } |]- `shouldRespondWith` ResponseMatcher {- matchBody = Nothing,- matchStatus = 204,- matchHeaders = ["Content-Range" <:> "0-0/1"]- }+ p <- request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |]+ pure p `shouldRespondWith` ResponseMatcher {+ matchBody = Nothing,+ matchStatus = 204,+ matchHeaders = ["Content-Range" <:> "0-0/1"]+ }+ liftIO $+ lookup hContentType (simpleHeaders p) `shouldBe` Nothing+ g' <- get "/items?id=eq.42" liftIO $ simpleHeaders g' `shouldSatisfy` matchHeader "Content-Range" "0-0/1"
test/Feature/QueryLimitedSpec.hs view
@@ -5,7 +5,7 @@ import Test.Hspec.Wai.JSON import Network.HTTP.Types import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus))-+import Text.Heredoc import SpecHelper import Network.Wai (Application) @@ -15,15 +15,23 @@ it "restricts results" $ get "/items" `shouldRespondWith` ResponseMatcher {- matchBody = Just [json| [{"id":1},{"id":2},{"id":3}] |]+ matchBody = Just [json| [{"id":1},{"id":2}] |] , matchStatus = 206- , matchHeaders = ["Content-Range" <:> "0-2/15"]+ , matchHeaders = ["Content-Range" <:> "0-1/15"] } it "respects additional client limiting" $ do r <- request methodGet "/items"- (rangeHdrs $ ByteRangeFromTo 0 1) ""+ (rangeHdrs $ ByteRangeFromTo 0 0) "" liftIO $ do simpleHeaders r `shouldSatisfy`- matchHeader "Content-Range" "0-1/15"+ matchHeader "Content-Range" "0-0/15" simpleStatus r `shouldBe` partialContent206++ it "limit works on all levels" $+ get "/users?select=id,tasks{id}&order=id.asc&tasks.order=id.asc"+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|]+ , matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-1/3"]+ }
test/Feature/QuerySpec.hs view
@@ -143,16 +143,29 @@ it "selectStar works in absense of parameter" $ get "/complex_items?id=eq.3" `shouldRespondWith`- [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3]}]|]+ [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|] + it "dash `-` in column names is accepted" $+ get "/complex_items?id=eq.3&select=id,field-with_sep" `shouldRespondWith`+ [str|[{"id":3,"field-with_sep":1}]|]+ it "one simple column" $ get "/complex_items?select=id" `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3}] |] + it "rename simple column" $+ get "/complex_items?id=eq.1&select=myId:id" `shouldRespondWith`+ [json| [{"myId":1}] |]++ it "one simple column with casting (text)" $ get "/complex_items?select=id::text" `shouldRespondWith` [json| [{"id":"1"},{"id":"2"},{"id":"3"}] |] + it "rename simple column with casting" $+ get "/complex_items?id=eq.1&select=myId:id::text" `shouldRespondWith`+ [json| [{"myId":"1"}] |]+ it "json column" $ get "/complex_items?id=eq.1&select=settings" `shouldRespondWith` [json| [{"settings":{"foo":{"int":1,"bar":"baz"}}}] |]@@ -161,6 +174,10 @@ get "/complex_items?id=eq.1&select=settings->>foo::json" `shouldRespondWith` [json| [{"foo":{"int":1,"bar":"baz"}}] |] -- the value of foo here is of type "text" + it "rename json subfield one level with casting (json)" $+ get "/complex_items?id=eq.1&select=myFoo:settings->>foo::json" `shouldRespondWith`+ [json| [{"myFoo":{"int":1,"bar":"baz"}}] |] -- the value of foo here is of type "text"+ it "fails on bad casting (data of the wrong format)" $ get "/complex_items?select=settings->foo->>bar::integer" `shouldRespondWith` ResponseMatcher {@@ -182,15 +199,33 @@ get "/complex_items?id=eq.1&select=settings->foo->>bar" `shouldRespondWith` [json| [{"bar":"baz"}] |] + it "rename json subfield two levels (string)" $+ get "/complex_items?id=eq.1&select=myBar:settings->foo->>bar" `shouldRespondWith`+ [json| [{"myBar":"baz"}] |] + it "json subfield two levels with casting (int)" $ get "/complex_items?id=eq.1&select=settings->foo->>int::integer" `shouldRespondWith` [json| [{"int":1}] |] -- the value in the db is an int, but here we expect a string for now + it "rename json subfield two levels with casting (int)" $+ get "/complex_items?id=eq.1&select=myInt:settings->foo->>int::integer" `shouldRespondWith`+ [json| [{"myInt":1}] |] -- the value in the db is an int, but here we expect a string for now+ it "requesting parents and children" $ get "/projects?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith` [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] + it "embed data with two fk pointing to the same table" $+ get "/orders?id=eq.1&select=id, name, billing_address_id{id}, shipping_address_id{id}" `shouldRespondWith`+ [str|[{"id":1,"name":"order 1","billing_address_id":{"id":1},"shipping_address_id":{"id":2}}]|]+++ it "requesting parents and children while renaming them" $+ get "/projects?id=eq.1&select=myId:id, name, project_client:client_id{*}, project_tasks:tasks{id, name}" `shouldRespondWith`+ [str|[{"myId":1,"name":"Windows 7","project_client":{"id":1,"name":"Microsoft"},"project_tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|]++ it "requesting parents and filtering parent columns" $ get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith` [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|]@@ -211,7 +246,11 @@ get "/tasks?select=id,users{id}" `shouldRespondWith` [str|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|] + it "requesting many<->many relation with rename" $+ get "/tasks?id=eq.1&select=id,theUsers:users{id}" `shouldRespondWith`+ [str|[{"id":1,"theUsers":[{"id":1},{"id":3}]}]|] + it "requesting many<->many relation reverse" $ get "/users?select=id,tasks{id}" `shouldRespondWith` [str|[{"id":1,"tasks":[{"id":1},{"id":2},{"id":3},{"id":4}]},{"id":2,"tasks":[{"id":5},{"id":6},{"id":7}]},{"id":3,"tasks":[{"id":1},{"id":5}]}]|]@@ -322,6 +361,28 @@ it "without other constraints" $ get "/items?order=id.asc" `shouldRespondWith` 200++ it "ordering embeded entities" $+ get "/projects?id=eq.1&select=id, name, tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`+ [str|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|]++ it "ordering embeded entities with alias" $+ get "/projects?id=eq.1&select=id, name, the_tasks:tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`+ [str|[{"id":1,"name":"Windows 7","the_tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|]++ it "ordering embeded entities, two levels" $+ get "/projects?id=eq.1&select=id, name, tasks{id, name, users{id, name}}&tasks.order=name.asc&tasks.users.order=name.desc" `shouldRespondWith`+ [str|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7","users":[{"id":1,"name":"Angela Martin"}]},{"id":1,"name":"Design w7","users":[{"id":3,"name":"Dwight Schrute"},{"id":1,"name":"Angela Martin"}]}]}]|]++ it "ordering embeded parents does not break things" $+ get "/projects?id=eq.1&select=id, name, clients{id, name}&clients.order=name.asc" `shouldRespondWith`+ [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"}}]|]++ it "ordering embeded parents does not break things when using ducktape names" $+ get "/projects?id=eq.1&select=id, name, client{id, name}&client.order=name.asc" `shouldRespondWith`+ [str|[{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}]|]++ describe "Accept headers" $ do it "should respond an unknown accept type with 415" $
test/Feature/RangeSpec.hs view
@@ -9,6 +9,7 @@ import qualified Data.ByteString.Lazy as BL import SpecHelper+import Text.Heredoc import Network.Wai (Application) defaultRange :: BL.ByteString@@ -141,6 +142,50 @@ , matchStatus = 200 , matchHeaders = ["Content-Range" <:> "0-0/*"] }++ context "with limit/offset parameters" $ do+ it "no parameters return everything" $+ get "/items?select=id&order=id.asc"+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]+ , matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-14/15"]+ }+ it "top level limit with parameter" $+ get "/items?select=id&order=id.asc&limit=3"+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":1},{"id":2},{"id":3}]|]+ , matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-2/15"]+ }+ it "headers override get parameters" $+ request methodGet "/items?select=id&order=id.asc&limit=3"+ (rangeHdrs $ ByteRangeFromTo 0 1) ""+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":1},{"id":2}]|]+ , matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-1/15"]+ }++ it "limit works on all levels" $+ get "/clients?select=id,projects{id,tasks{id}}&order=id.asc&limit=1&projects.order=id.asc&projects.limit=1&projects.tasks.order=id.asc&projects.tasks.limit=2"+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]}]}]|]+ , matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "0-0/2"]+ }++ it "fails on offset specified below level 1" $+ get "/clients?select=id,projects{id,tasks{id}}&projects.offset=2&projects.limit=1"+ `shouldRespondWith` 400++ it "limit and offset works on first level" $+ get "/items?select=id&order=id.asc&limit=3&offset=2"+ `shouldRespondWith` ResponseMatcher {+ matchBody = Just [str|[{"id":3},{"id":4},{"id":5}]|]+ , matchStatus = 206+ , matchHeaders = ["Content-Range" <:> "2-4/15"]+ } context "with range headers" $ do
test/Feature/StructureSpec.hs view
@@ -8,6 +8,7 @@ import Network.HTTP.Types import Network.Wai (Application)+import Network.Wai.Test (SResponse(simpleHeaders)) spec :: SpecWith Application spec = do@@ -17,6 +18,7 @@ request methodGet "/" [] "" `shouldRespondWith` [json| [ {"schema":"test","name":"Escap3e;","insertable":true}+ , {"schema":"test","name":"addresses","insertable":true} , {"schema":"test","name":"articleStars","insertable":true} , {"schema":"test","name":"articles","insertable":true} , {"schema":"test","name":"auto_incrementing_pk","insertable":true}@@ -24,6 +26,7 @@ , {"schema":"test","name":"comments","insertable":true} , {"schema":"test","name":"complex_items","insertable":true} , {"schema":"test","name":"compound_pk","insertable":true}+ , {"schema":"test","name":"empty_table","insertable":true} , {"schema":"test","name":"filtered_tasks","insertable":true} , {"schema":"test","name":"ghostBusters","insertable":true} , {"schema":"test","name":"has_count_column","insertable":false}@@ -36,6 +39,7 @@ , {"schema":"test","name":"menagerie","insertable":true} , {"schema":"test","name":"no_pk","insertable":true} , {"schema":"test","name":"nullable_integer","insertable":true}+ , {"schema":"test","name":"orders","insertable":true} , {"schema":"test","name":"projects","insertable":true} , {"schema":"test","name":"projects_view","insertable":true} , {"schema":"test","name":"simple_pk","insertable":true}@@ -379,3 +383,17 @@ it "errors for non existant tables" $ request methodOptions "/dne" [] "" `shouldRespondWith` 404++ describe "Allow header" $ do++ it "includes read/write verbs for writeable table" $ do+ r <- request methodOptions "/items" [] ""+ liftIO $+ simpleHeaders r `shouldSatisfy`+ matchHeader "Allow" "GET,POST,PATCH,DELETE"++ it "includes read verbs for read-only table" $ do+ r <- request methodOptions "/has_count_column" [] ""+ liftIO $+ simpleHeaders r `shouldSatisfy`+ matchHeader "Allow" "GET"
test/Main.hs view
@@ -7,6 +7,7 @@ import PostgREST.DbStructure (getDbStructure) import PostgREST.App (postgrest)+import Data.IORef import Data.String.Conversions (cs) import qualified Feature.AuthSpec@@ -27,10 +28,10 @@ pool <- P.acquire (3, 10, cs testDbConn) result <- P.use pool $ getDbStructure "test"- let dbStructure = either (error.show) id result- withApp = return $ postgrest testCfg dbStructure pool- ltdApp = return $ postgrest testLtdRowsCfg dbStructure pool- unicodeApp = return $ postgrest testUnicodeCfg dbStructure pool+ 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 hspec $ do mapM_ (beforeAll_ resetDb . before withApp) specs
test/SpecHelper.hs view
@@ -27,7 +27,7 @@ testLtdRowsCfg :: AppConfig testLtdRowsCfg =- AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 3) True+ AppConfig testDbConn "postgrest_test_anonymous" "test" 3000 (secret "safe") 10 (Just 2) True setupDb :: IO () setupDb = do
test/TestTypes.hs view
@@ -37,9 +37,9 @@ data CompoundPK = CompoundPK { compoundK1 :: Int-, compoundK2 :: Int+, compoundK2 :: String , compoundExtra :: Maybe Int-}+} deriving (Eq, Show) instance JSON.FromJSON CompoundPK where parseJSON (JSON.Object r) = CompoundPK <$>