diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -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 diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -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 --------------------------------------------------------------- diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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, [], "") diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -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 diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -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 diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs deleted file mode 100644 --- a/src/PostgREST/Main.hs +++ /dev/null @@ -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 diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -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 diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -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, ...)") diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -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') diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -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 = diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -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 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -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" } |] diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -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" diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -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" diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs --- a/test/Feature/QueryLimitedSpec.hs +++ b/test/Feature/QueryLimitedSpec.hs @@ -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"] + } diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -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" $ diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -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 diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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 diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -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 <$>