postgrest 0.4.4.0 → 0.5.0.0
raw patch · 26 files changed
+1455/−819 lines, 26 filesdep +auto-updatedep +contravariant-extrasdep +timedep ~hasql-pooldep ~hasql-transactiondep ~josenew-uploader
Dependencies added: auto-update, contravariant-extras, time
Dependency ranges changed: hasql-pool, hasql-transaction, jose
Files
- main/Main.hs +26/−6
- postgrest.cabal +14/−7
- src/PostgREST/ApiRequest.hs +53/−55
- src/PostgREST/App.hs +105/−71
- src/PostgREST/Auth.hs +31/−18
- src/PostgREST/Config.hs +28/−4
- src/PostgREST/DbRequestBuilder.hs +172/−176
- src/PostgREST/DbStructure.hs +112/−68
- src/PostgREST/Error.hs +3/−0
- src/PostgREST/Middleware.hs +4/−3
- src/PostgREST/OpenAPI.hs +1/−1
- src/PostgREST/Parsers.hs +51/−57
- src/PostgREST/QueryBuilder.hs +128/−116
- src/PostgREST/Types.hs +75/−37
- test/Feature/AndOrParamsSpec.hs +7/−22
- test/Feature/DeleteSpec.hs +1/−1
- test/Feature/InsertSpec.hs +16/−2
- test/Feature/QueryLimitedSpec.hs +2/−2
- test/Feature/QuerySpec.hs +312/−123
- test/Feature/RangeSpec.hs +1/−1
- test/Feature/RpcSpec.hs +48/−30
- test/Feature/SingularSpec.hs +1/−1
- test/Feature/StructureSpec.hs +35/−3
- test/Feature/UpsertSpec.hs +200/−0
- test/Main.hs +23/−15
- test/SpecHelper.hs +6/−0
main/Main.hs view
@@ -7,12 +7,16 @@ import PostgREST.Config (AppConfig (..), minimumPgVersion, prettyVersion, readOptions)-import PostgREST.DbStructure (getDbStructure, getPgVersion)+import PostgREST.DbStructure (getDbStructure, getPgVersion,+ fillSessionWithSettings) import PostgREST.Error (encodeError) import PostgREST.OpenAPI (isMalformedProxyUri) import PostgREST.Types (DbStructure, Schema, PgVersion(..)) import Protolude hiding (hPutStrLn, replace) ++import Control.AutoUpdate (defaultUpdateSettings,+ mkAutoUpdate, updateAction) import Control.Retry (RetryStatus, capDelay, exponentialBackoff, retrying, rsPreviousDelay)@@ -24,6 +28,7 @@ import Data.Text (pack, replace, stripPrefix, strip) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.IO (hPutStrLn)+import Data.Time.Clock (getCurrentTime) import qualified Hasql.Pool as P import qualified Hasql.Session as H import Network.Wai.Handler.Warp (defaultSettings,@@ -32,6 +37,7 @@ setTimeout) import System.IO (BufferMode (..), hSetBuffering)+ #ifndef mingw32_HOST_OS import System.Posix.Signals #endif@@ -58,10 +64,11 @@ :: ThreadId -- ^ This thread is killed if pg version is unsupported -> P.Pool -- ^ The PostgreSQL connection pool -> Schema -- ^ Schema PostgREST is serving up+ -> [(Text, Text)] -- ^ Settings or Environment passed in through the config -> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure' -> IORef Bool -- ^ Used as a binary Semaphore -> IO ()-connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do+connectionWorker mainTid pool schema settings refDbStructure refIsWorkerOn = do isWorkerOn <- readIORef refIsWorkerOn unless isWorkerOn $ do atomicWriteIORef refIsWorkerOn True@@ -79,6 +86,7 @@ ("Cannot run in this PostgreSQL version, PostgREST needs at least " <> pgvName minimumPgVersion) killThread mainTid+ fillSessionWithSettings settings dbStructure <- getDbStructure schema actualPgVersion liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure case result of@@ -140,18 +148,23 @@ port = configPort conf proxy = configProxyUri conf pgSettings = toS (configDatabase conf) -- is the db-uri+ roleClaimKey = configRoleClaimKey conf appSettings = setHost ((fromString . toS) host) -- Warp settings . setPort port . setServerName (toS $ "postgrest/" <> prettyVersion) . setTimeout 3600 $ defaultSettings- --- -- Checks that the provided proxy uri is formated correctly,- -- does not test if it works here.++ -- Checks that the provided proxy uri is formated correctly when (isMalformedProxyUri $ toS <$> proxy) $ panic "Malformed proxy uri, a correct example: https://example.com:8443/basePath"++ -- Checks that the provided jspath is valid+ when (isLeft roleClaimKey) $+ panic $ show roleClaimKey+ putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) -- -- create connection pool with the provided settings, returns either@@ -173,6 +186,7 @@ mainTid pool (configSchema conf)+ (configSettings conf) refDbStructure refIsWorkerOn --@@ -195,22 +209,28 @@ mainTid pool (configSchema conf)+ (configSettings conf) refDbStructure refIsWorkerOn ) Nothing #endif - --++ -- ask for the OS time at most once per second+ getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime}+ -- run the postgrest application runSettings appSettings $ postgrest conf refDbStructure pool+ getTime (connectionWorker mainTid pool (configSchema conf)+ (configSettings conf) refDbStructure refIsWorkerOn)
postgrest.cabal view
@@ -2,19 +2,19 @@ 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.4.4.0+version: 0.5.0.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE author: Joe Nelson, Adam Baker-homepage: https://github.com/begriffs/postgrest+homepage: https://github.com/PostgREST/postgrest maintainer: cred+github@begriffs.com category: Web build-type: Simple cabal-version: >=1.10 source-repository head type: git- location: git://github.com/begriffs/postgrest.git+ location: git://github.com/PostgREST/postgrest.git Flag CI Description: No warnings allowed in continuous integration@@ -29,12 +29,14 @@ -rtsopts "-with-rtsopts=-N -I2" default-language: Haskell2010- build-depends: base+ build-depends: auto-update+ , base , hasql , hasql-pool , postgrest , protolude , text+ , time , warp , bytestring , base64-bytestring@@ -57,17 +59,18 @@ , configurator-ng == 0.0.0.1 , containers , contravariant+ , contravariant-extras , either , gitrev , hasql- , hasql-pool == 0.4.1- , hasql-transaction == 0.5+ , hasql-pool+ , hasql-transaction , heredoc , HTTP , http-types , insert-ordered-containers , interpolatedstring-perl6- , jose >= 0.6+ , jose , lens , lens-aeson , network-uri@@ -80,6 +83,7 @@ , scientific , swagger2 , text+ , time , unordered-containers , vector , wai@@ -131,11 +135,13 @@ , Feature.AndOrParamsSpec , Feature.RpcSpec , Feature.NonexistentSchemaSpec+ , Feature.UpsertSpec , SpecHelper , TestTypes Build-Depends: aeson , aeson-qq , async+ , auto-update , base , bytestring , base64-bytestring@@ -158,6 +164,7 @@ , process , protolude , regex-tdfa+ , time , transformers-base , wai , wai-extra
src/PostgREST/ApiRequest.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-| Module : PostgREST.ApiRequest Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.@@ -13,7 +14,7 @@ import Protolude import qualified Data.Aeson as JSON-import Data.Aeson.Types (emptyObject)+import Data.Aeson.Types (emptyObject, emptyArray) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS (c2w) import qualified Data.ByteString.Lazy as BL@@ -33,14 +34,7 @@ import Network.Wai.Parse (parseHttpAccept) import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset) import Data.Ranged.Boundaries-import PostgREST.Types ( QualifiedIdentifier (..)- , Schema- , PayloadJSON(..)- , ContentType(..)- , ApiRequestError(..)- , toMime- , operators- , ftsOperators)+import PostgREST.Types import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange) import qualified Data.CaseInsensitive as CI import Web.Cookie (parseCookiesText)@@ -48,10 +42,10 @@ type RequestBody = BL.ByteString -- | Types of things a user wants to do to tables/views/procs-data Action = ActionCreate | ActionRead- | ActionUpdate | ActionDelete- | ActionInfo | ActionInvoke{isReadOnly :: Bool}- | ActionInspect+data Action = ActionCreate | ActionRead+ | ActionUpdate | ActionDelete+ | ActionInfo | ActionInvoke{isReadOnly :: Bool}+ | ActionInspect | ActionSingleUpsert deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier@@ -61,7 +55,7 @@ deriving Eq -- | How to return the inserted data data PreferRepresentation = Full | HeadersOnly | None deriving Eq- --+ {-| Describes what the user wants to do. This data type is a translation of the raw elements of an HTTP request into domain@@ -86,6 +80,8 @@ , iPreferSingleObjectParameter :: Bool -- | Whether the client wants a result count (slower) , iPreferCount :: Bool+ -- | Whether the client wants to UPSERT or ignore records on PK conflict+ , iPreferResolution :: Maybe PreferResolution -- | Filters on the result ("id", "eq.10") , iFilters :: [(Text, Text)] -- | &and and &or parameters used for complex boolean logic@@ -102,8 +98,6 @@ , iHeaders :: [(Text, Text)] -- | Request Cookies , iCookies :: [(Text, Text)]- -- | Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)- , iRpcQParams :: [(Text, Text)] } -- | Examines HTTP request and translates it into user intent.@@ -122,8 +116,10 @@ , iPreferRepresentation = representation , iPreferSingleObjectParameter = singleObject , iPreferCount = hasPrefer "count=exact"+ , iPreferResolution = if hasPrefer (show MergeDuplicates) then Just MergeDuplicates+ else if hasPrefer (show IgnoreDuplicates) then Just IgnoreDuplicates+ else Nothing , iFilters = filters- , iRpcQParams = rpcQParams , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ] , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]@@ -137,6 +133,7 @@ , iCookies = fromMaybe [] $ parseCookiesText <$> lookupHeader "Cookie" } where+ -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..) (filters, rpcQParams) = case action of ActionInvoke{isReadOnly=True} -> partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts@@ -148,20 +145,22 @@ isEmbedPath = T.isInfixOf "." isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path payload =- case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of- CTApplicationJSON ->- note "All object keys must match" . ensureUniform . pluralize+ case (decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type", action) of+ (_, ActionInvoke{isReadOnly=True}) ->+ Right $ PayloadJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams)+ (CTApplicationJSON, _) ->+ note "All object keys must match" . payloadAttributes reqBody =<< if BL.null reqBody && isTargetingProc then Right emptyObject else JSON.eitherDecode reqBody- CTTextCSV ->- note "All lines must have same number of fields" . ensureUniform . csvToJson- =<< CSV.decodeByName reqBody- CTOther "application/x-www-form-urlencoded" ->- Right . PayloadJSON . V.singleton . M.fromList- . map (toS *** JSON.String . toS) . parseSimpleQuery- $ toS reqBody- ct ->+ (CTTextCSV, _) -> do+ json <- csvToJson <$> CSV.decodeByName reqBody+ note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json+ (CTOther "application/x-www-form-urlencoded", _) ->+ let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody+ keys = S.fromList $ M.keys json in+ Right $ PayloadJSON (JSON.encode json) PJObject keys+ (ct, _) -> Left $ toS $ "Content-Type not acceptable: " <> toMime ct topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges action =@@ -174,6 +173,7 @@ then ActionInvoke{isReadOnly=False} else ActionCreate "PATCH" -> ActionUpdate+ "PUT" -> ActionSingleUpsert "DELETE" -> ActionDelete "OPTIONS" -> ActionInfo _ -> ActionInspect@@ -184,9 +184,8 @@ ["rpc", proc] -> TargetProc $ QualifiedIdentifier schema proc other -> TargetUnknown other- shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}]- relevantPayload | action == ActionInvoke{isReadOnly=True} = Nothing- | shouldParsePayload = rightToMaybe payload+ shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke{isReadOnly=False}, ActionInvoke{isReadOnly=True}]+ relevantPayload | shouldParsePayload = rightToMaybe payload | otherwise = Nothing path = pathInfo req method = requestMethod req@@ -270,9 +269,9 @@ The reason for its odd signature is so that it can compose directly with CSV.decodeByName -}-csvToJson :: (CSV.Header, CsvData) -> JSON.Array+csvToJson :: (CSV.Header, CsvData) -> JSON.Value csvToJson (_, vals) =- V.map rowToJsonObj vals+ JSON.Array $ V.map rowToJsonObj vals where rowToJsonObj = JSON.Object . M.map (\str ->@@ -281,27 +280,26 @@ else JSON.String $ toS str ) --- | Convert {foo} to [{foo}], leave arrays unchanged--- and truncate everything else to an empty array.-pluralize :: JSON.Value -> JSON.Array-pluralize obj@(JSON.Object _) = V.singleton obj-pluralize (JSON.Array arr) = arr-pluralize _ = V.empty+payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON+payloadAttributes raw json =+ -- Test that Array contains only Objects having the same keys+ case json of+ JSON.Array arr ->+ case arr V.!? 0 of+ Just (JSON.Object o) ->+ let canonicalKeys = S.fromList $ M.keys o+ areKeysUniform = all (\case+ JSON.Object x -> S.fromList (M.keys x) == canonicalKeys+ _ -> False) arr in+ if areKeysUniform+ then Just $ PayloadJSON raw (PJArray $ V.length arr) canonicalKeys+ else Nothing+ Just _ -> Nothing+ Nothing -> Just emptyPJArray --- | Test that Array contains only Objects having the same keys--- and if so mark it as PayloadJSON-ensureUniform :: JSON.Array -> Maybe PayloadJSON-ensureUniform arr =- let objs :: V.Vector JSON.Object- objs = foldr -- filter non-objects, map to raw objects- (\val result -> case val of- JSON.Object o -> V.cons o result- _ -> result)- V.empty arr- keysPerObj = V.map (S.fromList . M.keys) objs- canonicalKeys = fromMaybe S.empty $ keysPerObj V.!? 0- areKeysUniform = all (==canonicalKeys) keysPerObj in+ JSON.Object o -> Just $ PayloadJSON raw PJObject (S.fromList $ M.keys o) - if (V.length objs == V.length arr) && areKeysUniform- then Just (PayloadJSON objs)- else Nothing+ -- truncate everything else to an empty array.+ _ -> Just emptyPJArray+ where+ emptyPJArray = PayloadJSON (JSON.encode emptyArray) (PJArray 0) S.empty
src/PostgREST/App.hs view
@@ -1,16 +1,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-} module PostgREST.App ( postgrest ) where import Control.Applicative-import Data.Aeson (toJSON, eitherDecode)+import Data.Aeson as JSON import qualified Data.ByteString.Char8 as BS import Data.Maybe import Data.IORef (IORef, readIORef) import Data.Text (intercalate)+import Data.Time.Clock (UTCTime)+import qualified Data.Set as S import qualified Hasql.Pool as P import qualified Hasql.Transaction as HT@@ -22,7 +25,6 @@ import Network.Wai import Network.Wai.Middleware.RequestLogger (logStdout) -import qualified Data.Vector as V import qualified Hasql.Transaction as H import qualified Data.HashMap.Strict as M@@ -38,7 +40,6 @@ import PostgREST.DbStructure import PostgREST.DbRequestBuilder( readRequest , mutateRequest- , readRpcRequest , fieldNames ) import PostgREST.Error ( simpleError, pgError@@ -62,12 +63,13 @@ import Protolude hiding (intercalate, Proxy) import Safe (headMay) -postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO () -> Application-postgrest conf refDbStructure pool worker =+postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application+postgrest conf refDbStructure pool getTime worker = let middle = (if configQuiet conf then id else logStdout) . defaultMiddle jwtSecret = parseJWK <$> configJwtSecret conf in middle $ \ req respond -> do+ time <- getTime body <- strictRequestBody req maybeDbStructure <- readIORef refDbStructure case maybeDbStructure of@@ -76,38 +78,47 @@ response <- case userApiRequest (configSchema conf) req body of Left err -> return $ apiRequestError err Right apiRequest -> do- eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest)+ eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf) let authed = containsRole eClaims- handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest- txMode = transactionMode dbStructure- (iTarget apiRequest) (iAction apiRequest)+ proc = case (iTarget apiRequest, iPayload apiRequest, iPreferSingleObjectParameter apiRequest) of+ (TargetProc qi, Just PayloadJSON{pjKeys}, s) -> findProc qi pjKeys s $ dbProcs dbStructure+ _ -> Nothing+ handleReq = runWithClaims conf eClaims (app dbStructure proc conf) apiRequest+ txMode = transactionMode proc (iAction apiRequest) response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq return $ either (pgError authed) identity response when (responseStatus response == status503) worker respond response -transactionMode :: DbStructure -> Target -> Action -> H.Mode-transactionMode structure target action =+findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription+findProc qi payloadKeys paramsAsSingleObject allProcs =+ let procs = M.lookup (qiName qi) allProcs in+ -- Handle overloaded functions case+ join $ (case length <$> procs of+ Just 1 -> headMay -- if it's not an overloaded function then immediatly get the ProcDescription+ _ -> find (\x ->+ if paramsAsSingleObject+ then length (pdArgs x) == 1 -- if the arg is not of json type let the db give the err+ else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x))+ ) <$> procs++transactionMode :: Maybe ProcDescription -> Action -> H.Mode+transactionMode proc action = case action of ActionRead -> HT.Read ActionInfo -> HT.Read ActionInspect -> HT.Read ActionInvoke{isReadOnly=False} ->- let proc =- case target of- (TargetProc qi) -> M.lookup (qiName qi) $- dbProcs structure- _ -> Nothing- v = fromMaybe Volatile $ pdVolatility <$> proc in+ let v = fromMaybe Volatile $ pdVolatility <$> proc in if v == Stable || v == Immutable then HT.Read else HT.Write ActionInvoke{isReadOnly=True} -> HT.Read _ -> HT.Write -app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response-app dbStructure conf apiRequest =+app :: DbStructure -> Maybe ProcDescription -> AppConfig -> ApiRequest -> H.Transaction Response+app dbStructure proc conf apiRequest = case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of Left errorResponse -> return errorResponse Right contentType ->@@ -136,48 +147,52 @@ ) ] (toS body) - (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->- case mutateSqlParts of+ (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType}) ->+ case mutateSqlParts tSchema tName of Left errorResponse -> return errorResponse Right (sq, mq) -> do- let isSingle = (==1) $ V.length rows+ let (isSingle, nRows) = case pjType of+ PJArray len -> (len == 1, len)+ PJObject -> (True, 1) if contentType == CTSingularJSON && not isSingle && iPreferRepresentation apiRequest == Full- then return $ singularityError (toInteger $ V.length rows)+ then return $ singularityError (toInteger nRows) else do- let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?+ let pkCols = tablePKCols dbStructure tSchema tName stm = createWriteStatement sq mq (contentType == CTSingularJSON) isSingle- (contentType == CTTextCSV) (iPreferRepresentation apiRequest)- pKeys- row <- H.query payload stm+ (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols+ row <- H.query (toS pjRaw) stm let (_, _, fs, body) = extractQueryResult row headers = catMaybes [ if null fs then Nothing- else Just (hLocation, "/" <> toS table <> renderLocationFields fs)+ else Just (hLocation, "/" <> toS tName <> renderLocationFields fs) , if iPreferRepresentation apiRequest == Full then Just $ toHeader contentType else Nothing , Just . contentRangeH 1 0 $- toInteger <$> if shouldCount then Just (V.length rows) else Nothing+ toInteger <$> if shouldCount then Just nRows else Nothing+ , if null pkCols+ then Nothing+ else (\x -> ("Preference-Applied", show x)) <$> iPreferResolution apiRequest ] return . responseLBS status201 headers $ if iPreferRepresentation apiRequest == Full then toS body else "" - (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON rows)) ->- case (mutateSqlParts, null <$> rows V.!? 0, iPreferRepresentation apiRequest == Full) of+ (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just p@PayloadJSON{pjRaw}) ->+ case (mutateSqlParts tSchema tName, pjIsEmpty p, iPreferRepresentation apiRequest == Full) of (Left errorResponse, _, _) -> return errorResponse- (_, Just True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"- (_, Just True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""+ (_, True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"+ (_, True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] "" (Right (sq, mq), _, _) -> do let stm = createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) []- row <- H.query payload stm+ row <- H.query (toS pjRaw) stm let (_, queryTotal, _, body) = extractQueryResult row if contentType == CTSingularJSON && queryTotal /= 1@@ -195,16 +210,46 @@ then responseLBS s [toHeader contentType, r] (toS body) else responseLBS s [r] "" - (ActionDelete, TargetIdent _, Nothing) ->- case mutateSqlParts of+ (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType, pjKeys}) ->+ case mutateSqlParts tSchema tName of Left errorResponse -> return errorResponse Right (sq, mq) -> do- let emptyPayload = PayloadJSON V.empty- stm = createWriteStatement sq mq+ let isSingle = case pjType of+ PJArray len -> len == 1+ PJObject -> True+ colNames = colName <$> tableCols dbStructure tSchema tName+ if topLevelRange /= allRange+ then return $ simpleError status400 [] "Range header and limit/offset querystring parameters are not allowed for PUT"+ else if not isSingle+ then return $ simpleError status400 [] "PUT payload must contain a single row"+ else if S.fromList colNames /= pjKeys+ then return $ simpleError status400 [] "You must specify all columns in the payload when using PUT"+ else do+ row <- H.query (toS pjRaw) $+ createWriteStatement sq mq (contentType == CTSingularJSON) False+ (contentType == CTTextCSV) (iPreferRepresentation apiRequest) []+ let (_, queryTotal, _, body) = extractQueryResult row+ -- Makes sure the querystring pk matches the payload pk+ -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, PUT /items?id=eq.14 { "id" : 2, .. } is rejected+ -- If this condition is not satisfied then nothing is inserted, check the WHERE for INSERT in QueryBuilder.hs to see how it's done+ if queryTotal /= 1+ then do+ HT.condemn+ return $ simpleError status400 [] "Payload values do not match URL in primary key column(s)"+ else+ return $ if iPreferRepresentation apiRequest == Full+ then responseLBS status200 [toHeader contentType] (toS body)+ else responseLBS status204 [] ""++ (ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) ->+ case mutateSqlParts tSchema tName of+ Left errorResponse -> return errorResponse+ Right (sq, mq) -> do+ let stm = createWriteStatement sq mq (contentType == CTSingularJSON) False (contentType == CTTextCSV) (iPreferRepresentation apiRequest) []- row <- H.query emptyPayload stm+ row <- H.query mempty stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 1 0 $ toInteger <$> if shouldCount then Just queryTotal else Nothing@@ -227,33 +272,32 @@ let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in return $ responseLBS status200 [allOrigins, acceptH] "" - (ActionInvoke _isReadOnly, TargetProc qi, payload) ->- let proc = M.lookup (qiName qi) allProcs- returnsScalar = case proc of+ (ActionInvoke _, TargetProc qi, Just PayloadJSON{pjRaw, pjType, pjKeys}) ->+ let returnsScalar = case proc of Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True _ -> False rpcBinaryField = if returnsScalar then Right Nothing else binaryField contentType =<< fldNames- parts = (,,) <$> readSqlParts <*> rpcBinaryField <*> rpcQParams in+ parts = (,) <$> readSqlParts <*> rpcBinaryField in case parts of Left errorResponse -> return errorResponse- Right ((q, cq), bField, params) -> do- let prms = case payload of- Just (PayloadJSON pld) -> V.head pld- Nothing -> M.fromList $ second toJSON <$> params -- toJSON is just for reusing the callProc function+ Right ((q, cq), bField) -> do+ let isObject = case pjType of+ PJObject -> True+ PJArray _ -> False singular = contentType == CTSingularJSON- paramsAsSingleObject = iPreferSingleObjectParameter apiRequest- row <- H.query () $- callProc qi prms returnsScalar q cq shouldCount- singular paramsAsSingleObject+ specifiedPgArgs = filter ((`S.member` pjKeys) . pgaName) $ fromMaybe [] (pdArgs <$> proc)+ row <- H.query (toS pjRaw) $+ callProc qi specifiedPgArgs returnsScalar q cq shouldCount+ singular (iPreferSingleObjectParameter apiRequest) (contentType == CTTextCSV)- (contentType == CTOctetStream) _isReadOnly bField+ (contentType == CTOctetStream) bField isObject (pgVersion dbStructure) let (tableTotal, queryTotal, body, jsonHeaders) = fromMaybe (Just 0, 0, "[]", "[]") row (status, contentRange) = rangeHeader queryTotal tableTotal- decodedHeaders = first toS $ eitherDecode $ toS jsonHeaders :: Either Text [GucHeader]+ decodedHeaders = first toS $ JSON.eitherDecode $ toS jsonHeaders :: Either Text [GucHeader] case decodedHeaders of Left _ -> return gucHeadersError Right hs ->@@ -270,26 +314,16 @@ uri Nothing = ("http", host, port, "/") uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) uri' = uri proxy- encodeApi ti sd procs = encodeOpenAPI (M.elems procs) (toTableInfo ti) uri' sd (dbPrimaryKeys dbStructure)+ toTableInfo :: [Table] -> [(Table, [Column], [Text])]+ toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn))+ encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure body <- encodeApi <$> H.query schema accessibleTables <*> H.query schema schemaDescription <*> H.query schema accessibleProcs return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body _ -> return notFound where- toTableInfo :: [Table] -> [(Table, [Column], [Text])]- toTableInfo = map (\t ->- let tSchema = tableSchema t- tTable = tableName t- cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure- pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys- in (t, cols, pkeys)) notFound = responseLBS status404 [] ""- filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk- filterCol :: Schema -> TableName -> Column -> Bool- filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb- allPrKeys = dbPrimaryKeys dbStructure- allProcs = dbProcs dbStructure allOrigins = ("Access-Control-Allow-Origin", "*") :: Header shouldCount = iPreferCount apiRequest schema = toS $ configSchema conf@@ -301,16 +335,15 @@ status = rangeStatus lower upper (toInteger <$> tableTotal) in (status, contentRange) - readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) allProcs apiRequest+ readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) proc apiRequest fldNames = fieldNames <$> readReq readDbRequest = DbRead <$> readReq- mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< fldNames)- rpcQParams = readRpcRequest apiRequest selectQuery = requestToQuery schema False <$> readDbRequest- mutateQuery = requestToQuery schema False <$> mutateDbRequest countQuery = requestToCountQuery schema <$> readDbRequest readSqlParts = (,) <$> selectQuery <*> countQuery- mutateSqlParts = (,) <$> selectQuery <*> mutateQuery+ mutateSqlParts s t =+ (,) <$> selectQuery+ <*> (requestToQuery schema False . DbMutate <$> (mutateRequest apiRequest t (tablePKCols dbStructure s t) =<< fldNames)) responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType responseContentTypeOrError accepts action = serves contentTypesForRequest accepts@@ -324,6 +357,7 @@ ActionInvoke _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream] ActionInspect -> [CTOpenAPI, CTApplicationJSON] ActionInfo -> [CTTextCSV]+ ActionSingleUpsert -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] serves sProduces cAccepts = case mutuallyAgreeable sProduces cAccepts of Nothing -> do
src/PostgREST/Auth.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-| Module : PostgREST.Auth Description : PostgREST authorization functions.@@ -19,8 +20,11 @@ ) where import Control.Lens.Operators-import Data.Aeson (Value (..), decode, toJSON)+import qualified Data.Aeson as JSON import qualified Data.HashMap.Strict as M+import Data.Time.Clock (UTCTime)+import Data.Vector as V+import PostgREST.Types import Protolude import qualified Crypto.JOSE.Types as JOSE.Types@@ -31,47 +35,56 @@ -} data JWTAttempt = JWTInvalid JWTError | JWTMissingSecret- | JWTClaims (M.HashMap Text Value)+ | JWTClaims (M.HashMap Text JSON.Value) deriving (Eq, Show) {-| Receives the JWT secret and audience (from config) and a JWT and returns a map of JWT claims. -}-jwtClaims :: Maybe JWK -> Maybe StringOrURI -> LByteString -> IO JWTAttempt-jwtClaims _ _ "" = return $ JWTClaims M.empty-jwtClaims secret audience payload =+jwtClaims :: Maybe JWK -> Maybe StringOrURI -> LByteString -> UTCTime -> Maybe JSPath -> IO JWTAttempt+jwtClaims _ _ "" _ _ = return $ JWTClaims M.empty+jwtClaims secret audience payload time jspath = case secret of Nothing -> return JWTMissingSecret Just s -> do let validation = defaultJWTValidationSettings (maybe (const True) (==) audience) eJwt <- runExceptT $ do jwt <- decodeCompact payload- verifyClaims validation s jwt+ verifyClaimsAt validation s time jwt return $ case eJwt of Left e -> JWTInvalid e- Right jwt -> JWTClaims . claims2map $ jwt+ Right jwt -> JWTClaims $ claims2map jwt jspath {-|+ Turn JWT ClaimSet into something easier to work with,+ also here the jspath is applied to put the "role" in the map+-}+claims2map :: ClaimsSet -> Maybe JSPath -> M.HashMap Text JSON.Value+claims2map claims jspath = (\case+ val@(JSON.Object o) ->+ let role = maybe M.empty (M.singleton "role") $+ walkJSPath (Just val) =<< jspath in+ M.delete "role" o `M.union` role -- mutating the map+ _ -> M.empty+ ) $ JSON.toJSON claims++walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value+walkJSPath x [] = x+walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest+walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest+walkJSPath _ _ = Nothing++{-| Whether a response from jwtClaims contains a role claim -} containsRole :: JWTAttempt -> Bool containsRole (JWTClaims claims) = M.member "role" claims containsRole _ = False -{-|- Internal helper used to turn JWT ClaimSet into something- easier to work with--}-claims2map :: ClaimsSet -> M.HashMap Text Value-claims2map = val2map . toJSON- where- val2map (Object o) = o- val2map _ = M.empty- parseJWK :: ByteString -> JWK parseJWK str =- fromMaybe (hs256jwk str) (decode (toS str) :: Maybe JWK)+ fromMaybe (hs256jwk str) (JSON.decode (toS str) :: Maybe JWK) {-| Internal helper to generate HMAC-SHA256. When the jwt key in the
src/PostgREST/Config.hs view
@@ -19,12 +19,12 @@ , readOptions , corsPolicy , minimumPgVersion+ , pgVersion95 , pgVersion96 , AppConfig (..) ) where -import PostgREST.Types (PgVersion(..)) import Control.Applicative import Control.Monad (fail) import Control.Lens (preview)@@ -51,6 +51,9 @@ import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) import Options.Applicative hiding (str) import Paths_postgrest (version)+import PostgREST.Parsers (pRoleClaimKey)+import PostgREST.Types (PgVersion(..), ApiRequestError(..),+ JSPath, JSPathExp(..)) import Protolude hiding (hPutStrLn, take, intercalate, (<>)) import System.IO (hPrint)@@ -76,6 +79,8 @@ , configMaxRows :: Maybe Integer , configReqCheck :: Maybe Text , configQuiet :: Bool+ , configSettings :: [(Text, Text)]+ , configRoleClaimKey :: Either ApiRequestError JSPath } defaultCorsPolicy :: CorsResourcePolicy@@ -136,6 +141,8 @@ <*> (join . fmap coerceInt <$> C.key "max-rows") <*> (mfilter (/= "") <$> C.key "pre-request") <*> pure False+ <*> (fmap parsedPairToTextPair <$> C.subassocs "app.settings")+ <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> C.key "role-claim-key") case mAppConf of Nothing -> do@@ -145,6 +152,13 @@ return appConf where+ parsedPairToTextPair :: (Name, Value) -> (Text, Text)+ parsedPairToTextPair (k, v) = (k, newValue)+ where+ newValue = case v of+ String textVal -> textVal+ _ -> show v+ parseJwtAudience :: Name -> C.ConfigParserM (Maybe StringOrURI) parseJwtAudience k = C.key k >>= \case@@ -159,11 +173,15 @@ coerceInt (String x) = readMaybe $ toS x coerceInt _ = Nothing - coerceBool :: Value -> Maybe Bool+ coerceBool :: Value -> Maybe Bool coerceBool (Bool b) = Just b- coerceBool (String x) = readMaybe $ toS x+ coerceBool (String b) = readMaybe $ toS b coerceBool _ = Nothing + parseRoleClaimKey :: Value -> Either ApiRequestError JSPath+ parseRoleClaimKey (String s) = pRoleClaimKey s+ parseRoleClaimKey v = pRoleClaimKey $ show v+ opts = info (helper <*> pathParser) $ fullDesc <> progDesc (@@ -208,6 +226,9 @@ | |## stored proc to exec immediately after auth |# pre-request = "stored_proc_name"+ |+ |## jspath to the role claim key+ |# role-claim-key = ".role" |] pathParser :: Parser FilePath@@ -218,7 +239,10 @@ -- | Tells the minimum PostgreSQL version required by this version of PostgREST minimumPgVersion :: PgVersion-minimumPgVersion = PgVersion 90300 "9.3"+minimumPgVersion = PgVersion 90400 "9.4" pgVersion96 :: PgVersion pgVersion96 = PgVersion 90600 "9.6"++pgVersion95 :: PgVersion+pgVersion95 = PgVersion 90500 "9.5"
src/PostgREST/DbRequestBuilder.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DuplicateRecordFields#-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} module PostgREST.DbRequestBuilder ( readRequest , mutateRequest-, readRpcRequest , fieldNames ) where @@ -14,6 +16,7 @@ import qualified Data.ByteString.Char8 as BS import Data.List (delete) import Data.Maybe (fromJust)+import qualified Data.Set as S import Data.Text (isInfixOf) import Data.Tree import Data.Either.Combinators (mapLeft)@@ -30,45 +33,50 @@ ) import PostgREST.Error (apiRequestError) import PostgREST.Parsers-import PostgREST.RangeQuery (NonnegRange, restrictRange)+import PostgREST.RangeQuery (NonnegRange, restrictRange, allRange) import PostgREST.Types import Protolude hiding (from, dropWhile, drop) import Text.Regex.TDFA ((=~)) import Unsafe (unsafeHead) -readRequest :: Maybe Integer -> [Relation] -> M.HashMap Text ProcDescription -> ApiRequest -> Either Response ReadRequest-readRequest maxRows allRels allProcs apiRequest =+readRequest :: Maybe Integer -> [Relation] -> Maybe ProcDescription -> ApiRequest -> Either Response ReadRequest+readRequest maxRows allRels proc apiRequest = mapLeft apiRequestError $ treeRestrictRange maxRows =<< augumentRequestWithJoin schema relations =<<- parseReadRequest+ addFiltersOrdersRanges apiRequest <*>+ (buildReadRequest <$> pRequestSelect (iSelect apiRequest)) where+ action = iAction apiRequest (schema, rootTableName) = fromJust $ -- Make it safe let target = iTarget apiRequest in case target of (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)- (TargetProc (QualifiedIdentifier s proc) ) -> Just (s, tName)+ (TargetProc (QualifiedIdentifier s pName) ) -> Just (s, tName) where- retType = pdReturnType <$> M.lookup proc allProcs- tName = case retType of+ tName = case pdReturnType <$> proc of Just (SetOf (Composite qi)) -> qiName qi Just (Single (Composite qi)) -> qiName qi- _ -> proc+ _ -> pName _ -> Nothing - action :: Action- action = iAction apiRequest-- parseReadRequest :: Either ApiRequestError ReadRequest- parseReadRequest = addFiltersOrdersRanges apiRequest <*>- pRequestSelect rootName selStr+ -- Build tree with a Depth attribute so when a self join occurs we can differentiate the parent and child tables by having+ -- an alias like "table_depth", this is related to issue #987.+ buildReadRequest :: [Tree SelectItem] -> ReadRequest+ buildReadRequest fieldTree =+ let rootDepth = 0+ rootNodeName = if action == ActionRead then rootTableName else sourceCTEName in+ foldr (treeEntry rootDepth) (Node (Select [] [rootNodeName] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing, rootDepth)) []) fieldTree where- selStr = iSelect apiRequest- rootName = if action == ActionRead- then rootTableName- else sourceCTEName+ treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest+ treeEntry depth (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) =+ let nxtDepth = succ depth in+ case fldForest of+ [] -> Node (q {select=fld:select q}, i) rForest+ _ -> Node (q, i) $+ foldr (treeEntry nxtDepth) (Node (Select [] [fn] [] [] [] allRange, (fn, Nothing, alias, relationDetail, nxtDepth)) []) fldForest:rForest relations :: [Relation] relations = case action of@@ -77,8 +85,20 @@ ActionDelete -> fakeSourceRelations ++ allRels ActionInvoke _ -> fakeSourceRelations ++ allRels _ -> allRels- where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation+ where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels +-- in a relation where one of the tables matches "TableName"+-- replace the name to that table with pg_source+-- this "fake" relations is needed so that in a mutate query+-- we can look a the "returning *" part which is wrapped with a "with"+-- as just another table that has relations with other tables+toSourceRelation :: TableName -> Relation -> Maybe Relation+toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)+ | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}+ | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}+ | Just mt == (tableName <$> rt) = Just $ r {relLinkTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}+ | otherwise = Nothing+ treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request where@@ -88,136 +108,135 @@ augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest augumentRequestWithJoin schema allRels request = addRelations schema allRels Nothing request- >>= addJoinFilters schema+ >>= addJoinConditions schema addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest-addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias, relationDetail)) forest) =+addRelations schema allRelations parentNode (Node (query, (nodeName, _, alias, relationDetail, depth)) forest) = case parentNode of- (Just (Node (Select{from=[parentNodeTable]}, (_, _, _, _)) _)) ->- Node <$> readNode' <*> forest'- where- forest' = updateForest $ hush node'- node' = Node <$> readNode' <*> pure forest- readNode' = addRel readNode <$> rel- rel :: Either ApiRequestError Relation- rel = note (NoRelationBetween parentNodeTable name)- $ findRelation schema name parentNodeTable relationDetail- where- - findRelation s nodeTableName parentNodeTableName Nothing =- find (\r ->- s == tableSchema (relTable r) && -- match schema for relation table- s == tableSchema (relFTable r) && -- match schema for relation foriegn table- (+ Just (Node (Select{from=[parentNodeTable]}, _) _) ->+ let newFrom r = (\tName -> if tName == nodeName then tableName (relTable r) else tName) <$> from query+ newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel+ rel :: Either ApiRequestError Relation+ rel = note (NoRelationBetween parentNodeTable nodeName) $+ findRelation schema allRelations nodeName parentNodeTable relationDetail in+ Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest)+ _ ->+ let rn = (query, (nodeName, Just r, alias, Nothing, depth))+ r = Relation t [] t [] Root Nothing Nothing Nothing+ t = Table schema nodeName Nothing True in -- !!! TODO find another way to get the table from the query+ Node rn <$> updateForest (Just $ Node rn forest)+ where+ updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]+ updateForest rq = mapM (addRelations schema allRelations rq) forest - -- (request) => projects { ..., clients{...} }- -- will match- -- (relation type) => parent- -- (entity) => clients {id}- -- (foriegn entity) => projects {client_id}- (- nodeTableName == tableName (relTable r) && -- match relation table name- parentNodeTableName == tableName (relFTable r) -- match relation foreign table name- ) ||+findRelation :: Schema -> [Relation] -> NodeName -> TableName -> Maybe RelationDetail -> Maybe Relation+findRelation schema allRelations nodeTableName parentNodeTableName relationDetail =+ find (\Relation{relTable, relColumns, relFTable, relFColumns, relType, relLinkTable} ->+ -- Both relation ends need to be on the exposed schema+ schema == tableSchema relTable && schema == tableSchema relFTable &&+ case relationDetail of+ Nothing -> + -- (request) => projects { ..., clients{...} }+ -- will match+ -- (relation type) => parent+ -- (entity) => clients {id}+ -- (foriegn entity) => projects {client_id}+ (+ nodeTableName == tableName relTable && -- match relation table name+ parentNodeTableName == tableName relFTable -- match relation foreign table name+ ) || - -- (request) => projects { ..., client_id{...} }- -- will match- -- (relation type) => parent- -- (entity) => clients {id}- -- (foriegn entity) => projects {client_id}- (- parentNodeTableName == tableName (relFTable r) &&- length (relFColumns r) == 1 &&- nodeTableName `colMatches` (colName . unsafeHead . relFColumns) r- )+ -- (request) => projects { ..., client_id{...} }+ -- will match+ -- (relation type) => parent+ -- (entity) => clients {id}+ -- (foriegn entity) => projects {client_id}+ (+ parentNodeTableName == tableName relFTable &&+ length relFColumns == 1 &&+ -- match common foreign key names(table_name_id, table_name_fk) to table_name+ (toS ("^" <> colName (unsafeHead relFColumns) <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS nodeTableName :: BS.ByteString)+ ) - -- (request) => project_id { ..., client_id{...} }- -- will match- -- (relation type) => parent- -- (entity) => clients {id}- -- (foriegn entity) => projects {client_id}- -- this case works becasue before reaching this place- -- addRelation will turn project_id to project so the above condition will match- )- ) allRelations- - findRelation s nodeTableName parentNodeTableName (Just rd) = - find (\r ->- s == tableSchema (relTable r) && -- match schema for relation table- s == tableSchema (relFTable r) && -- match schema for relation foriegn table- (+ -- (request) => project_id { ..., client_id{...} }+ -- will match+ -- (relation type) => parent+ -- (entity) => clients {id}+ -- (foriegn entity) => projects {client_id}+ -- this case works becasue before reaching this place+ -- addRelation will turn project_id to project so the above condition will match - -- (request) => clients { ..., project.client_id{...} }- -- will match- -- (relation type) => parent- -- (entity) => clients {id}- -- (foriegn entity) => projects {client_id}- (- nodeTableName == tableName (relTable r) && -- match relation table name- parentNodeTableName == tableName (relFTable r) && -- && -- match relation foreign table name- length (relColumns r) == 1 &&- rd == (colName . unsafeHead . relColumns) r- ) - ||+ Just rd -> + -- (request) => clients { ..., projects.client_id{...} }+ -- will match+ -- (relation type) => child+ -- (entity) => clients {id}+ -- (foriegn entity) => projects {client_id}+ (+ relType == Child &&+ nodeTableName == tableName relTable && -- match relation table name+ parentNodeTableName == tableName relFTable && -- match relation foreign table name+ length relColumns == 1 &&+ rd == colName (unsafeHead relColumns)+ ) || - -- (request) => tasks { ..., users.tasks_users{...} }- -- will match- -- (relation type) => many- -- (entity) => users- -- (foriegn entity) => tasks- (- relType r == Many &&- nodeTableName == tableName (relTable r) && -- match relation table name- parentNodeTableName == tableName (relFTable r) && -- match relation foreign table name- rd == tableName (fromJust (relLTable r))- ) - )- ) allRelations- n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString)- addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail))- addRel (query', (n, _, a, _)) r = (query' {from=fromRelation}, (n, Just r, a, Nothing))- where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query')+ -- (request) => message { ..., person_detail.sender{...} }+ -- will match+ -- (relation type) => parent+ -- (entity) => message {sender}+ -- (foriegn entity) => person_detail {id}+ (+ relType == Parent &&+ nodeTableName == tableName relTable && -- match relation table name+ parentNodeTableName == tableName relFTable && -- match relation foreign table name+ length relFColumns == 1 &&+ rd == colName (unsafeHead relFColumns)+ ) || - _ -> n' <$> updateForest (Just (n' forest))- where- n' = Node (query, (name, Just r, alias, Nothing))- t = Table schema name Nothing True -- !!! TODO find another way to get the table from the query- r = Relation t [] t [] Root Nothing Nothing Nothing- where- updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]- updateForest n = mapM (addRelations schema allRelations n) forest+ -- (request) => tasks { ..., users.tasks_users{...} }+ -- will match+ -- (relation type) => many+ -- (entity) => users+ -- (foriegn entity) => tasks+ (+ relType == Many &&+ nodeTableName == tableName relTable && -- match relation table name+ parentNodeTableName == tableName relFTable && -- match relation foreign table name+ rd == tableName (fromJust relLinkTable)+ )+ ) allRelations -addJoinFilters :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest-addJoinFilters schema (Node node@(query, nodeProps@(_, relation, _, _)) forest) =+addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest+addJoinConditions schema (Node node@(query, nodeProps@(_, relation, _, _, _)) forest) = case relation of Just Relation{relType=Root} -> Node node <$> updatedForest -- this is the root node Just rel@Relation{relType=Parent} -> Node (augmentQuery rel, nodeProps) <$> updatedForest Just rel@Relation{relType=Child} -> Node (augmentQuery rel, nodeProps) <$> updatedForest- Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->+ Just rel@Relation{relType=Many, relLinkTable=(Just linkTable)} -> let rq = augmentQuery rel in Node (rq{from=tableName linkTable:from rq}, nodeProps) <$> updatedForest _ -> Left UnknownRelation where- updatedForest = mapM (addJoinFilters schema) forest- augmentQuery rel = foldr addFilterToReadQuery query (getJoinFilters rel)- addFilterToReadQuery flt rq@Select{where_=lf} = rq{where_=addFilterToLogicForest flt lf}::ReadQuery+ updatedForest = mapM (addJoinConditions schema) forest+ augmentQuery rel = foldr addJoinCond query (getJoinConditions rel)+ addJoinCond :: JoinCondition -> ReadQuery -> ReadQuery+ addJoinCond jc rq@Select{joinConditions=jcs} = rq{joinConditions=jc:jcs} -getJoinFilters :: Relation -> [Filter]-getJoinFilters (Relation t cols ft fcs typ lt lc1 lc2) =- case typ of- Child -> zipWith (toFilter tN ftN) cols fcs- Parent -> zipWith (toFilter tN ftN) cols fcs- Many -> zipWith (toFilter tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toFilter ftN ltN) fcs (fromMaybe [] lc2)- Root -> undefined --error "undefined getJoinFilters"+getJoinConditions :: Relation -> [JoinCondition]+getJoinConditions (Relation Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fcs typ lt lc1 lc2) =+ if | typ == Child || typ == Parent ->+ zipWith (toJoinCondition tN ftN) cols fcs+ | typ == Many ->+ let ltN = fromMaybe "" (tableName <$> lt) in+ zipWith (toJoinCondition tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toJoinCondition ftN ltN) fcs (fromMaybe [] lc2)+ | typ == Root -> undefined where- s = if typ == Parent then "" else tableSchema t- tN = tableName t- ftN = tableName ft- ltN = fromMaybe "" (tableName <$> lt)- toFilter :: Text -> Text -> Column -> Column -> Filter- toFilter tb ftb c fc = Filter (colName c, Nothing) (OpExpr False (Join (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})))+ toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition+ toJoinCondition tb ftb c fc =+ JoinCondition (QualifiedIdentifier tSchema tb, Nothing, colName c)+ (QualifiedIdentifier tSchema ftb, Nothing, colName fc) addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest) addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [@@ -254,7 +273,7 @@ addFilter = addProperty addFilterToNode addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest-addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f+addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest addOrder = addProperty addOrderToNode@@ -272,53 +291,35 @@ addLogicTree = addProperty addLogicTreeToNode addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest-addProperty f ([], a) n = f a n-addProperty f (path, a) (Node rn forest) =- case targetNode of+addProperty f ([], a) rr = f a rr+addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =+ case pathNode of Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path- Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest)+ Just tn -> Node rn (addProperty f (remainingPath, a) tn:delete tn forest) where- targetNodeName:remainingPath = path- (targetNode,restForest) = splitForest targetNodeName forest- splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode)- splitForest name forst =- case maybeNode of- Nothing -> (Nothing,forest)- Just node -> (Just node, delete node forest)- where- maybeNode :: Maybe ReadRequest- maybeNode = find fnd forst- where- fnd :: ReadRequest -> Bool- fnd (Node (_,(n,_,_,_)) _) = n == name---- in a relation where one of the tables mathces "TableName"--- replace the name to that table with pg_source--- this "fake" relations is needed so that in a mutate query--- we can look a the "returning *" part which is wrapped with a "with"--- as just another table that has relations with other tables-toSourceRelation :: TableName -> Relation -> Maybe Relation-toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)- | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}}- | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}}- | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}- | otherwise = Nothing+ pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest -mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest-mutateRequest apiRequest fldNames = mapLeft apiRequestError $+mutateRequest :: ApiRequest -> TableName -> [Text] -> [FieldName] -> Either Response MutateRequest+mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $ case action of- ActionCreate -> Right $ Insert rootTableName payload returnings- ActionUpdate -> Update rootTableName <$> pure payload <*> combinedLogic <*> pure returnings- ActionDelete -> Delete rootTableName <$> combinedLogic <*> pure returnings- _ -> Left UnsupportedVerb+ ActionCreate -> Right $ Insert tName pkCols payload (iPreferResolution apiRequest) [] returnings+ ActionUpdate -> Update tName payload <$> combinedLogic <*> pure returnings+ ActionSingleUpsert ->+ (\flts ->+ if null (iLogic apiRequest) &&+ S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols &&+ not (null (S.fromList pkCols)) &&+ all (\case+ Filter _ (OpExpr False (Op "eq" _)) -> True+ _ -> False) flts+ then Insert tName pkCols payload (Just MergeDuplicates) <$> combinedLogic <*> pure returnings+ else+ Left InvalidFilters) =<< filters+ ActionDelete -> Delete tName <$> combinedLogic <*> pure returnings+ _ -> Left UnsupportedVerb where action = iAction apiRequest payload = fromJust $ iPayload apiRequest- rootTableName = -- TODO: Make it safe- let target = iTarget apiRequest in- case target of- (TargetIdent (QualifiedIdentifier _ t) ) -> t- _ -> undefined returnings = if iPreferRepresentation apiRequest == None then [] else fldNames filters = map snd <$> mapM pRequestFilter mutateFilters logic = map snd <$> mapM pRequestLogicTree logicFilters@@ -327,17 +328,12 @@ (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest) onlyRoot = filter (not . ( "." `isInfixOf` ) . fst) -readRpcRequest :: ApiRequest -> Either Response [RpcQParam]-readRpcRequest apiRequest = mapLeft apiRequestError rpcQParams- where- rpcQParams = mapM pRequestRpcQParam $ iRpcQParams apiRequest- fieldNames :: ReadRequest -> [FieldName] fieldNames (Node (sel, _) forest) = map (fst . view _1) (select sel) ++ map colName fks where fks = concatMap (fromMaybe [] . f) forest- f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _, _)) _) = Just cols+ f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _, _, _)) _) = Just cols f _ = Nothing -- Traditional filters(e.g. id=eq.1) are added as root nodes of the LogicTree
src/PostgREST/DbStructure.hs view
@@ -3,12 +3,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE NamedFieldPuns #-} module PostgREST.DbStructure ( getDbStructure , accessibleTables , accessibleProcs , schemaDescription , getPgVersion+, fillSessionWithSettings ) where import qualified Hasql.Decoders as HD@@ -17,10 +19,11 @@ import Control.Applicative import qualified Data.HashMap.Strict as M-import Data.List (elemIndex)-import Data.Maybe (fromJust)+import qualified Data.List as L+import Data.Set as S (fromList) import Data.Text (split, strip,- breakOn, dropAround, splitOn)+ breakOn, dropAround,+ splitOn) import qualified Data.Text as T import qualified Hasql.Session as H import PostgREST.Types@@ -30,23 +33,26 @@ import Protolude import Unsafe (unsafeHead) +import Data.Functor.Contravariant (contramap)+import Contravariant.Extras (contrazip2)+ getDbStructure :: Schema -> PgVersion -> H.Session DbStructure getDbStructure schema pgVer = do- tabs <- H.query () allTables- cols <- H.query schema $ allColumns tabs- syns <- H.query () $ allSynonyms cols- rels <- H.query () $ allRelations tabs cols- keys <- H.query () $ allPrimaryKeys tabs- procs <- H.query schema allProcs+ tabs <- H.query () allTables+ cols <- H.query schema $ allColumns tabs+ syns <- H.query () $ allSynonyms cols+ childRels <- H.query () $ allChildRelations tabs cols+ keys <- H.query () $ allPrimaryKeys tabs+ procs <- H.query schema allProcs - let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels- cols' = addForeignKeys rels' cols- keys' = synonymousPrimaryKeys syns keys+ let rels = addManyToManyRelations . addParentRelations $ addViewRelations syns childRels+ cols' = addForeignKeys rels cols+ keys' = addViewPrimaryKeys syns keys return DbStructure { dbTables = tabs , dbColumns = cols'- , dbRelations = rels'+ , dbRelations = rels , dbPrimaryKeys = keys' , dbProcs = procs , pgVersion = pgVer@@ -94,7 +100,7 @@ where pkRow = (,,) <$> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text -decodeSynonyms :: [Column] -> HD.Result [(Column,Column)]+decodeSynonyms :: [Column] -> HD.Result [Synonym] decodeSynonyms cols = mapMaybe (synonymFromRow cols) <$> HD.rowsList synRow where@@ -103,9 +109,10 @@ <*> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text <*> HD.value HD.text -decodeProcs :: HD.Result (M.HashMap Text ProcDescription)+decodeProcs :: HD.Result (M.HashMap Text [ProcDescription]) decodeProcs =- M.fromList . map addName <$> HD.rowsList tblRow+ -- Duplicate rows for a function means they're overloaded, order these by least args according to ProcDescription Ord instance+ map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowsList tblRow where tblRow = ProcDescription <$> HD.value HD.text@@ -152,10 +159,10 @@ | v == 's' = Stable | otherwise = Volatile -- only 'v' can happen here -allProcs :: H.Query Schema (M.HashMap Text ProcDescription)+allProcs :: H.Query Schema (M.HashMap Text [ProcDescription]) allProcs = H.statement (toS procsSqlQuery) (HE.value HE.text) decodeProcs True -accessibleProcs :: H.Query Schema (M.HashMap Text ProcDescription)+accessibleProcs :: H.Query Schema (M.HashMap Text [ProcDescription]) accessibleProcs = H.statement (toS sql) (HE.value HE.text) decodeProcs True where sql = procsSqlQuery <> " AND has_function_privilege(p.oid, 'execute')"@@ -212,7 +219,7 @@ join pg_namespace n on n.oid = c.relnamespace left join pg_catalog.pg_description as d on d.objoid = c.oid and d.objsubid = 0 where- c.relkind in ('v', 'r', 'm')+ c.relkind in ('v', 'r', 'm', 'f') and n.nspname = $1 and ( pg_has_role(c.relowner, 'USAGE'::text)@@ -221,18 +228,6 @@ ) order by relname |] -synonymousColumns :: [(Column,Column)] -> [Column] -> [[Column]]-synonymousColumns allSyns cols = synCols'- where- syns = case headMay cols of- Just firstCol -> sort $ filter ((== colTable firstCol) . colTable . fst) allSyns- Nothing -> []- synCols = transpose $ map (\c -> map snd $ filter ((== c) . fst) syns) cols- synCols' = (filter sameTable . filter matchLength) synCols- matchLength cs = length cols == length cs- sameTable (c:cs) = all (\cc -> colTable c == colTable cc) (c:cs)- sameTable [] = False- addForeignKeys :: [Relation] -> [Column] -> [Column] addForeignKeys rels = map addFk where@@ -241,35 +236,84 @@ lookupFn :: Column -> Relation -> Bool lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child relToFk col Relation{relColumns=cols, relFColumns=colsF} = do- pos <- elemIndex col cols+ pos <- L.elemIndex col cols colF <- atMay colsF pos return $ ForeignKey colF -addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation]-addSynonymousRelations _ [] = []-addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynonymousRelations syns rels- where- synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs})- synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs})- synRels cols mapFn = map (\cs -> mapFn (colTable $ unsafeHead cs) cs) $ synonymousColumns syns cols+{-+Adds Views Child Relations based on Synonyms found, the logic is as follows: +Having a Relation{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relType=Child} represented by:++t1.c1------t2.c2++When only having a t1_view.c1 synonym, we need to add a View to Table Relation++ t1.c1----t2.c2 t1.c1----------t2.c2+ -> --------/+ /+ t1_view.c1 t1_view.c1+++When only having a t2_view.c2 synonym, we need to add a Table to View Relation++ t1.c1----t2.c2 t1.c1----------t2.c2+ -> \--------+ \+ t2_view.c2 t2_view.c1++When having t1_view.c1 and a t2_view.c2 synonyms, we need to add a View to View Relation in addition to the prior++ t1.c1----t2.c2 t1.c1----------t2.c2+ -> \--------/+ / \+ t1_view.c1 t2_view.c2 t1_view.c1-------t2_view.c1++The logic for composite pks is similar just need to make sure all the Relation columns have synonyms.+-}+addViewRelations :: [Synonym] -> [Relation] -> [Relation]+addViewRelations allSyns = concatMap (\rel ->+ rel : case rel of+ Relation{relType=Child, relTable, relColumns, relFTable, relFColumns} ->++ let colSynsGroupedByView :: [Column] -> [[Synonym]]+ colSynsGroupedByView relCols = L.groupBy (\(_, viewCol1) (_, viewCol2) -> colTable viewCol1 == colTable viewCol2) $+ filter (\(c, _) -> c `elem` relCols) allSyns+ colsSyns = colSynsGroupedByView relColumns+ fColsSyns = colSynsGroupedByView relFColumns+ getView :: [Synonym] -> Table+ getView = colTable . snd . unsafeHead+ syns `allSynsOf` cols = S.fromList (fst <$> syns) == S.fromList cols in++ -- View Table Relations+ [Relation (getView syns) (snd <$> syns) relFTable relFColumns Child Nothing Nothing Nothing+ | syns <- colsSyns, syns `allSynsOf` relColumns] ++++ -- Table View Relations+ [Relation relTable relColumns (getView fSyns) (snd <$> fSyns) Child Nothing Nothing Nothing+ | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns] ++++ -- View View Relations+ [Relation (getView syns) (snd <$> syns) (getView fSyns) (snd <$> fSyns) Child Nothing Nothing Nothing+ | syns <- colsSyns, fSyns <- fColsSyns, syns `allSynsOf` relColumns, fSyns `allSynsOf` relFColumns]++ _ -> [])+ addParentRelations :: [Relation] -> [Relation]-addParentRelations [] = []-addParentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : addParentRelations rels+addParentRelations = concatMap (\rel@(Relation t c ft fc _ _ _ _) -> [rel, Relation ft fc t c Parent Nothing Nothing Nothing]) addManyToManyRelations :: [Relation] -> [Relation] addManyToManyRelations rels = rels ++ addMirrorRelation (mapMaybe link2Relation links) where links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels groupFn :: Relation -> Text- groupFn Relation{relTable=Table{tableSchema=s, tableName=t}} = s<>"_"<>t+ groupFn Relation{relTable=Table{tableSchema=s, tableName=t}} = s <> "_" <> t -- Reference : https://wiki.haskell.org/99_questions/Solutions/26 combinations :: Int -> [a] -> [[a]] combinations 0 _ = [ [] ] combinations n xs = [ y:ys | y:xs' <- tails xs , ys <- combinations (n-1) xs']- addMirrorRelation [] = []- addMirrorRelation (rel@(Relation t c ft fc _ lt lc1 lc2):rels') = Relation ft fc t c Many lt lc2 lc1 : rel : addMirrorRelation rels'+ addMirrorRelation = concatMap (\rel@(Relation t c ft fc _ lt lc1 lc2) -> [rel, Relation ft fc t c Many lt lc2 lc1]) link2Relation [ Relation{relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c}, Relation{ relColumns=lc2, relFTable=ft, relFColumns=fc}@@ -278,25 +322,11 @@ | otherwise = Nothing link2Relation _ = Nothing -raiseRelations :: Schema -> [(Column,Column)] -> [Relation] -> [Relation]-raiseRelations schema syns = map raiseRel- where- raiseRel rel- | tableSchema table == schema = rel- | isJust newCols = rel{relFTable=fromJust newTable,relFColumns=fromJust newCols}- | otherwise = rel- where- cols = relFColumns rel- table = relFTable rel- newCols = listToMaybe $ filter ((== schema) . tableSchema . colTable . unsafeHead) (synonymousColumns syns cols)- newTable = (colTable . unsafeHead) <$> newCols--synonymousPrimaryKeys :: [(Column,Column)] -> [PrimaryKey] -> [PrimaryKey]-synonymousPrimaryKeys _ [] = []-synonymousPrimaryKeys syns (key:keys) = key : newKeys ++ synonymousPrimaryKeys syns keys- where- keySyns = filter ((\c -> colTable c == pkTable key && colName c == pkName key) . fst) syns- newKeys = map ((\c -> PrimaryKey{pkTable=colTable c,pkName=colName c}) . snd) keySyns+addViewPrimaryKeys :: [Synonym] -> [PrimaryKey] -> [PrimaryKey]+addViewPrimaryKeys syns = concatMap (\pk ->+ let viewPks = (\(_, viewCol) -> PrimaryKey{pkTable=colTable viewCol, pkName=colName viewCol}) <$>+ filter (\(col, _) -> colTable col == pkTable pk && colName col == pkName pk) syns in+ pk : viewPks) allTables :: H.Query () [Table] allTables =@@ -316,7 +346,7 @@ AND (pg_trigger.tgtype::integer & 69) = 69) ) AS insertable FROM pg_class c JOIN pg_namespace n ON n.oid = c.relnamespace- WHERE c.relkind IN ('v','r','m')+ WHERE c.relkind IN ('v','r','m','f') AND n.nspname NOT IN ('pg_catalog', 'information_schema') GROUP BY table_schema, table_name, insertable ORDER BY table_schema, table_name |]@@ -508,8 +538,8 @@ parseEnum :: Maybe Text -> [Text] parseEnum str = fromMaybe [] $ split (==',') <$> str -allRelations :: [Table] -> [Column] -> H.Query () [Relation]-allRelations tabs cols =+allChildRelations :: [Table] -> [Column] -> H.Query () [Relation]+allChildRelations tabs cols = H.statement sql HE.unit (decodeRelations tabs cols) True where sql = [q|@@ -659,7 +689,7 @@ pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs -allSynonyms :: [Column] -> H.Query () [(Column,Column)]+allSynonyms :: [Column] -> H.Query () [Synonym] allSynonyms cols = H.statement sql HE.unit (decodeSynonyms cols) True where@@ -734,7 +764,7 @@ order by c.view_schema, c.view_name, c.table_name, c.view_column_name |] -synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe (Column,Column)+synonymFromRow :: [Column] -> (Text,Text,Text,Text,Text,Text) -> Maybe Synonym synonymFromRow allCols (s1,t1,c1,s2,t2,c2) = (,) <$> col1 <*> col2 where col1 = findCol s1 t1 c1@@ -746,3 +776,17 @@ where sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')" versionRow = HD.singleRow $ PgVersion <$> HD.value HD.int4 <*> HD.value HD.text++fillSessionWithSettings :: [(Text, Text)] -> H.Session ()+fillSessionWithSettings settings =+ -- Send all of the config settings to the set_config function, using pgsql's `unnest` to transform arrays of values+ H.query settings $ H.statement "SELECT set_config(k, v, false) FROM unnest($1, $2) AS f1(k, v)" encoder HD.unit False++ where+ -- Take a list of (key, value) pairs and encode each as an array to later bind to the query+ -- see Insert Many section at https://hackage.haskell.org/package/hasql-1.1.1/docs/Hasql-Encoders.html+ encoder = contramap L.unzip $ contrazip2 (vector HE.text) (vector HE.text)+ where+ vector value =+ HE.value $ HE.array $ HE.arrayDimension foldl' $ HE.arrayValue value+
src/PostgREST/Error.hs view
@@ -39,6 +39,7 @@ NoRelationBetween _ _ -> HT.status400 InvalidRange -> HT.status416 UnknownRelation -> HT.status404+ InvalidFilters -> HT.status405 simpleError :: HT.Status -> [Header] -> Text -> Response simpleError status hdrs message =@@ -107,6 +108,8 @@ "message" .= ("Could not find foreign keys between these entities, No relation found between " <> parent <> " and " <> child :: Text)] toJSON UnsupportedVerb = JSON.object [ "message" .= ("Unsupported HTTP verb" :: Text)]+ toJSON InvalidFilters = JSON.object [+ "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)] instance JSON.ToJSON P.UsageError where toJSON (P.ConnectionError e) = JSON.object [
src/PostgREST/Middleware.hs view
@@ -5,7 +5,7 @@ module PostgREST.Middleware where import Crypto.JWT-import Data.Aeson (Value (..))+import qualified Data.Aeson as JSON import qualified Data.HashMap.Strict as M import qualified Hasql.Transaction as H @@ -32,7 +32,7 @@ JWTInvalid e -> return $ unauthed $ show e JWTMissingSecret -> return $ simpleError status500 [] "Server lacks JWT secret" JWTClaims claims -> do- H.sql $ toS.mconcat $ setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql+ H.sql $ toS.mconcat $ setSchemaSql ++ setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql mapM_ H.sql customReqCheck app req where@@ -41,9 +41,10 @@ claimsSql = map (pgFmtEnvVar "request.jwt.claim.") [(c,unquoted v) | (c,v) <- M.toList claimsWithRole] setRoleSql = maybeToList $ (\r -> "set local role " <> r <> ";") . toS . pgFmtLit . unquoted <$> M.lookup "role" claimsWithRole+ setSchemaSql = ["set schema " <> pgFmtLit (configSchema conf) <> ";"] :: [Text] -- role claim defaults to anon if not specified in jwt claimsWithRole = M.union claims (M.singleton "role" anon)- anon = String . toS $ configAnonRole conf+ anon = JSON.String . toS $ configAnonRole conf customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf where unauthed message = simpleError
src/PostgREST/OpenAPI.hs view
@@ -260,7 +260,7 @@ & description ?~ d) & externalDocs ?~ ((mempty :: ExternalDocs) & description ?~ "PostgREST Documentation"- & url .~ URL ("https://postgrest.com/en/" <> docsVersion <> "/api.html"))+ & url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html")) & host .~ h' & definitions .~ fromList (map (makeTableDef pks) ti) & parameters .~ fromList (makeParamDefs ti)
src/PostgREST/Parsers.hs view
@@ -8,20 +8,21 @@ import Data.List (init, last) import Data.Tree import Data.Either.Combinators (mapLeft)-import PostgREST.RangeQuery (NonnegRange,allRange)+import PostgREST.RangeQuery (NonnegRange) import PostgREST.Types import Text.ParserCombinators.Parsec hiding (many, (<|>)) import Text.Parsec.Error+import Text.Read (read) -pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest-pRequestSelect rootName selStr =- mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)+pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]+pRequestSelect selStr =+ mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper) where treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k- oper = parse (pOpExpr pSingleVal pListVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v+ oper = parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v path = fst <$> treePath fld = snd <$> treePath @@ -47,33 +48,12 @@ -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v) -pRequestRpcQParam :: (Text, Text) -> Either ApiRequestError RpcQParam-pRequestRpcQParam (k, v) = mapError $ (,) <$> name <*> val- where- name = parse pFieldName ("failed to parse rpc arg name (" ++ toS k ++ ")") $ toS k- val = toS <$> parse (many anyChar) ("failed to parse rpc arg value (" ++ toS v ++ ")") v- ws :: Parser Text ws = toS <$> many (oneOf " \t") lexeme :: Parser a -> Parser a lexeme p = ws *> p <* ws -pReadRequest :: Text -> Parser ReadRequest-pReadRequest rootNodeName = do- fieldTree <- pFieldForest- return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing, Nothing)) []) fieldTree- where- readQuery = Select [] [rootNodeName] [] Nothing allRange- treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest- treeEntry (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) =- case fldForest of- [] -> Node (q {select=fld:select q}, i) rForest- _ -> Node (q, i) newForest- where- newForest =- foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias, relationDetail)) []) fldForest:rForest- pTreePath :: Parser (EmbedPath, Field) pTreePath = do p <- pFieldName `sepBy1` pDelimiter@@ -82,16 +62,14 @@ pFieldForest :: Parser [Tree SelectItem] pFieldForest = pFieldTree `sepBy1` lexeme (char ',')--pFieldTree :: Parser (Tree SelectItem)-pFieldTree = try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest) -- TODO: "{}" deprecated- <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest)- <|> Node <$> pFieldSelect <*> pure []+ where+ pFieldTree :: Parser (Tree SelectItem)+ pFieldTree = try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|>+ Node <$> pFieldSelect <*> pure [] pStar :: Parser Text pStar = toS <$> (string "*" *> pure ("*"::ByteString)) - pFieldName :: Parser Text pFieldName = do matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])"@@ -136,13 +114,13 @@ s <- pStar return ((s, Nothing), Nothing, Nothing, Nothing) -pOpExpr :: Parser SingleVal -> Parser ListVal -> Parser OpExpr-pOpExpr pSVal pLVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation+pOpExpr :: Parser SingleVal -> Parser OpExpr+pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation where pOperation :: Parser Operation pOperation = Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal- <|> In <$> (string "in" *> pDelimiter *> pLVal)+ <|> In <$> (try (string "in" *> pDelimiter) *> pListVal) <|> pFts <?> "operator (eq, gt, ...)" @@ -158,8 +136,7 @@ pSingleVal = toS <$> many anyChar pListVal :: Parser ListVal-pListVal = try (lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')'))- <|> lexeme pListElement `sepBy1` char ',' -- TODO: "in.3,4,5" deprecated, parens e.g. "in.(3,4,5)" should be used+pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')') pListElement :: Parser Text pListElement = try pQuotedValue <|> (toS <$> many (noneOf ",)"))@@ -171,30 +148,29 @@ pDelimiter = char '.' <?> "delimiter (.)" pOrder :: Parser [OrderTerm]-pOrder = lexeme pOrderTerm `sepBy` char ','+pOrder = lexeme pOrderTerm `sepBy1` char ',' pOrderTerm :: Parser OrderTerm-pOrderTerm =- try ( do- c <- pField- d <- optionMaybe (try $ pDelimiter *> (- try(string "asc" *> pure OrderAsc)- <|> try(string "desc" *> pure OrderDesc)- ))- nls <- optionMaybe (pDelimiter *> (- try(string "nullslast" *> pure OrderNullsLast)- <|> try(string "nullsfirst" *> pure OrderNullsFirst)- ))- return $ OrderTerm c d nls- )- <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing+pOrderTerm = do+ fld <- pField+ dir <- optionMaybe $+ try (pDelimiter *> string "asc" $> OrderAsc) <|>+ try (pDelimiter *> string "desc" $> OrderDesc)+ nls <- optionMaybe pNulls <* pEnd <|>+ pEnd $> Nothing+ return $ OrderTerm fld dir nls+ where+ pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>+ try (pDelimiter *> string "nullslast" $> OrderNullsLast)+ pEnd = try (void $ lookAhead (char ',')) <|>+ try eof pLogicTree :: Parser LogicTree pLogicTree = Stmnt <$> try pLogicFilter <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')')) where pLogicFilter :: Parser Filter- pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal pLogicListVal+ pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal pNot :: Parser Bool pNot = try (string "not" *> pDelimiter *> pure True) <|> pure False@@ -207,7 +183,6 @@ pLogicSingleVal :: Parser SingleVal pLogicSingleVal = try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)")) where- -- TODO: "{}" deprecated, after removal pPgArray can be removed pPgArray :: Parser Text pPgArray = do a <- string "{"@@ -215,9 +190,6 @@ c <- string "}" toS <$> pure (a ++ b ++ c) -pLogicListVal :: Parser ListVal-pLogicListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')- pLogicPath :: Parser (EmbedPath, Text) pLogicPath = do path <- pFieldName `sepBy1` pDelimiter@@ -234,3 +206,25 @@ message = show $ errorPos e details = strip $ replace "\n" " " $ toS $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)++-- Used for the config value "role-claim-key"+pRoleClaimKey :: Text -> Either ApiRequestError JSPath+pRoleClaimKey selStr =+ mapError $ parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr)++pJSPath :: Parser JSPath+pJSPath = toJSPath <$> (period *> pPath `sepBy` period <* eof)+ where+ toJSPath :: [(Text, Maybe Int)] -> JSPath+ toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx))+ period = char '.' <?> "period (.)"+ pPath :: Parser (Text, Maybe Int)+ pPath = (,) <$> pJSPKey <*> optionMaybe pJSPIdx++pJSPKey :: Parser Text+pJSPKey = toS <$> (many1 (alphaNum <|> oneOf "_$@") <|> pQuoted) <?> "attribute name [a..z0..9_$@])"+ where+ pQuoted = char '"' *> many (noneOf "\"") <* char '"'++pJSPIdx :: Parser Int+pJSPIdx = char '[' *> (read <$> many1 digit) <* char ']' <?> "array index [0..n]"
src/PostgREST/QueryBuilder.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module : PostgREST.QueryBuilder@@ -30,15 +32,14 @@ import qualified Data.Aeson as JSON import PostgREST.Config (pgVersion96)-import PostgREST.RangeQuery (NonnegRange, rangeLimit, rangeOffset, allRange)-import Data.Functor.Contravariant (contramap)+import PostgREST.RangeQuery (rangeLimit, rangeOffset, allRange) import qualified Data.HashMap.Strict as HM import Data.Maybe+import qualified Data.Set as S import Data.Text (intercalate, unwords, replace, isInfixOf, toLower) import qualified Data.Text as T (map, takeWhile, null) import qualified Data.Text.Encoding as T import Data.Tree (Tree(..))-import qualified Data.Vector as V import PostgREST.Types import Text.InterpolatedString.Perl6 (qc) import qualified Data.ByteString.Char8 as BS@@ -76,14 +77,6 @@ decodeStandardMay = HD.maybeRow standardRow -{-| JSON and CSV payloads from the client are given to us as- PayloadJSON (objects who all have the same keys),- and we turn this into an old fasioned JSON array--}-encodeUniformObjs :: HE.Params PayloadJSON-encodeUniformObjs =- contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json)- createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> H.Query () ResultsWithCount createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField =@@ -105,11 +98,12 @@ | isJust binaryField = asBinaryF $ fromJust binaryField | otherwise = asJsonF + createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> PreferRepresentation -> [Text] ->- H.Query PayloadJSON (Maybe ResultsWithCount)+ H.Query ByteString (Maybe ResultsWithCount) createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys =- unicodeStatement sql encodeUniformObjs decodeStandardMay True+ unicodeStatement sql (HE.value HE.unknown) decodeStandardMay True where sql = case rep of@@ -129,7 +123,7 @@ "'' AS total_result_set", -- when updateing it does not make sense "pg_catalog.count(_postgrest_t) AS page_total", if wantHdrs- then locationF pKeys+ then "coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")" else noLocationF <> " AS header", if rep == Full then bodyF <> " AS body"@@ -142,14 +136,18 @@ | otherwise = asJsonF type ProcResults = (Maybe Int64, Int64, ByteString, ByteString)-callProc :: QualifiedIdentifier -> JSON.Object -> Bool -> SqlQuery -> SqlQuery -> Bool ->- Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> H.Query () (Maybe ProcResults)-callProc qi params returnsScalar selectQuery countQuery countTotal isSingle paramsAsJson asCsv asBinary isReadOnly binaryField pgVer =- unicodeStatement sql HE.unit decodeProc True+callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool ->+ Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool -> PgVersion ->+ H.Query ByteString (Maybe ProcResults)+callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField isObject pgVer =+ unicodeStatement sql (HE.value HE.unknown) decodeProc True where sql = if returnsScalar then [qc|- WITH {sourceCTEName} AS (select {fromQi qi}({_args}))+ WITH {argsRecord},+ {sourceCTEName} AS (+ SELECT {fromQi qi}({args})+ ) SELECT {countResultF} AS total_result_set, 1 AS page_total,@@ -157,7 +155,10 @@ {responseHeaders} AS response_headers FROM ({selectQuery}) _postgrest_t;|] else [qc|- WITH {sourceCTEName} AS (select * from {fromQi qi}({_args}))+ WITH {argsRecord},+ {sourceCTEName} AS (+ SELECT * FROM {fromQi qi}({args})+ ) SELECT {countResultF} AS total_result_set, pg_catalog.count(_postgrest_t) AS page_total,@@ -165,12 +166,17 @@ {responseHeaders} AS response_headers FROM ({selectQuery}) _postgrest_t;|] + (argsRecord, args) | paramsAsSingleObject = ("_args_record AS (SELECT NULL)", "$1::json")+ | null pgArgs = (ignoredBody, "")+ | otherwise = (+ unwords [+ "_args_record AS (",+ "SELECT * FROM " <> (if isObject then "json_to_record" else "json_to_recordset") <> "($1)",+ "AS _(" <> intercalate ", " ((\a -> pgaName a <> " " <> pgaType a) <$> pgArgs) <> ")",+ ")"]+ , intercalate ", " ((\a -> pgaName a <> " := (SELECT " <> pgaName a <> " FROM _args_record)") <$> pgArgs)) countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text- _args = if paramsAsJson && not isReadOnly- then insertableValueWithType "json" $ JSON.Object params- else intercalate "," $ map _assignment (HM.toList params) _procName = qiName qi- _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v responseHeaders = if pgVer >= pgVersion96 then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15@@ -202,65 +208,61 @@ requestToCountQuery :: Schema -> DbRequest -> SqlQuery requestToCountQuery _ (DbMutate _) = undefined-requestToCountQuery schema (DbRead (Node (Select _ _ logicForest _ _, (mainTbl, _, _, _)) _)) =+requestToCountQuery schema (DbRead (Node (Select{where_=logicForest}, (mainTbl, _, _, _, _)) _)) = unwords [ "SELECT pg_catalog.count(*)", "FROM ", fromQi qi,- ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) filteredLogic)) `emptyOnFalse` null filteredLogic+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest ] where qi = removeSourceCTESchema schema mainTbl- -- all foreing key filters are root nodes(see addFilterToLogicForest), only those are filtered- nonFKRoot :: LogicTree -> Bool- nonFKRoot (Stmnt (Filter _ (OpExpr _ (Join _ _)))) = False- nonFKRoot (Stmnt _) = True- nonFKRoot Expr{} = True- filteredLogic = filter nonFKRoot logicForest requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery-requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest ord range, (nodeName, maybeRelation, _, _)) forest)) =- query+requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest joinConditions_ ordts range, (nodeName, maybeRelation, _, _, depth)) forest)) =+ unwords [+ "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),+ "FROM " <> intercalate ", " tables,+ unwords joins,+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConds))+ `emptyOnFalse` (null logicForest && null joinConds),+ ("ORDER BY " <> intercalate ", " (map (pgFmtOrderTerm qi) ordts)) `emptyOnFalse` null ordts,+ ("LIMIT " <> maybe "ALL" show (rangeLimit range) <> " OFFSET " <> show (rangeOffset range)) `emptyOnFalse` (isParent || range == allRange) ]+ where mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)- qi = removeSourceCTESchema schema mainTbl- toQi = removeSourceCTESchema schema- query = unwords [- "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),- "FROM ", intercalate ", " (map (fromQi . toQi) tbls),- unwords joins,- ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,- orderF (fromMaybe [] ord),- if isParent then "" else limitF range- ]- orderF ts =- if null ts- then ""- else "ORDER BY " <> clause- where- clause = intercalate "," (map queryTerm ts)- queryTerm :: OrderTerm -> Text- queryTerm t = " "- <> toS (pgFmtField qi $ otTerm t) <> " "- <> maybe "" show (otDirection t) <> " "- <> maybe "" show (otNullOrder t) <> " "+ isSelfJoin = maybe False (\r -> relType r /= Root && relTable r == relFTable r) maybeRelation+ (qi, tables, joinConds) =+ let depthAlias name dpth = if dpth /= 0 then name <> "_" <> show dpth else name in -- Root node doesn't get aliased+ if isSelfJoin+ then (+ QualifiedIdentifier "" (depthAlias mainTbl depth),+ (\t -> fromQi (removeSourceCTESchema schema t) <> " AS " <> pgFmtIdent (depthAlias t depth)) <$> tbls,+ (\(JoinCondition (qi1, _, c1) (qi2, _, c2)) ->+ JoinCondition (qi1, Just $ depthAlias (qiName qi1) depth, c1)+ (qi2, Just $ depthAlias (qiName qi2) (depth - 1), c2)) <$> joinConditions_)+ else (+ removeSourceCTESchema schema mainTbl,+ fromQi . removeSourceCTESchema schema <$> tbls,+ joinConditions_)+ (joins, selects) = foldr getQueryParts ([],[]) forest 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)+ getQueryParts (Node n@(_, (name, Just Relation{relType=Child,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (j,sel:s) where sel = "COALESCE((" <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) " <> "FROM (" <> subquery <> ") " <> pgFmtIdent table <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias) where subquery = requestToQuery schema False (DbRead (Node n forst))- getQueryParts (Node n@(_, (name, Just Relation{relType=Parent,relTable=Table{tableName=table}}, alias, _)) forst) (j,s) = (joi:j,sel:s)+ getQueryParts (Node n@(_, (name, Just Relation{relType=Parent,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (joi:j,sel:s) where aliasOrName = fromMaybe name alias localTableName = pgFmtIdent $ table <> "_" <> aliasOrName sel = "row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> localTableName <> " ON TRUE " where subquery = requestToQuery schema True (DbRead (Node n forst))- getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias, _)) forst) (j,s) = (j,sel:s)+ getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias, _, _)) forst) (j,s) = (j,sel:s) where sel = "COALESCE ((" <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) "@@ -271,45 +273,65 @@ --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts _ _ = undefined-requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) =- insInto <> vals <> ret- where qi = QualifiedIdentifier schema mainTbl- cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))- colsString = intercalate ", " cols- insInto = unwords [ "INSERT INTO" , fromQi qi,- if T.null colsString then "" else "(" <> colsString <> ")"- ]- vals = unwords $- if T.null colsString- then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"]- else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"]- ret = if null returnings- then ""- else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)]-requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) logicForest returnings)) =- case rows V.!? 0 of- Just obj ->- let assignments = map- (\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in+requestToQuery schema _ (DbMutate (Insert mainTbl pkCols p@(PayloadJSON _ pType pKeys) onConflct logicForest returnings)) =+ unwords [+ ("WITH " <> ignoredBody) `emptyOnFalse` not payloadIsEmpty,+ "INSERT INTO ", fromQi qi, if payloadIsEmpty then " " else "(" <> cols <> ")",+ case (pType, payloadIsEmpty) of+ (PJArray _, True) -> "SELECT null WHERE false"+ (PJObject, True) -> "DEFAULT VALUES"+ _ -> unwords [+ "SELECT " <> cols <> " FROM",+ case pType of+ PJObject -> "json_populate_record"+ PJArray _ -> "json_populate_recordset", "(null::", fromQi qi, ", $1) _",+ -- Only used for PUT+ ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier "" "_") <$> logicForest)) `emptyOnFalse` null logicForest],+ maybe "" (\x -> (+ "ON CONFLICT(" <> intercalate ", " pkCols <> ") " <> case x of+ IgnoreDuplicates ->+ "DO NOTHING"+ MergeDuplicates ->+ "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList pKeys)+ ) `emptyOnFalse` null pkCols) onConflct,+ ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings]+ where+ qi = QualifiedIdentifier schema mainTbl+ cols = intercalate ", " $ pgFmtIdent <$> S.toList pKeys+ payloadIsEmpty = pjIsEmpty p+requestToQuery schema _ (DbMutate (Update mainTbl p@(PayloadJSON _ pType keys) logicForest returnings)) =+ if pjIsEmpty p+ then "WITH " <> ignoredBody <> "SELECT ''"+ else unwords [- "UPDATE ", fromQi qi,- " SET " <> intercalate "," assignments <> " ",+ "UPDATE " <> fromQi qi <> " SET " <> cols,+ "FROM (SELECT * FROM ",+ case pType of+ PJObject -> " json_populate_record"+ PJArray _ -> " json_populate_recordset", "(null::", fromQi qi, ", $1)) _ ", ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest, ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings ]- Nothing -> undefined where qi = QualifiedIdentifier schema mainTbl+ cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList keys) requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) =- query+ unwords [+ "WITH " <> ignoredBody,+ "DELETE FROM ", fromQi qi,+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,+ ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings+ ] where qi = QualifiedIdentifier schema mainTbl- query = unwords [- "DELETE FROM ", fromQi qi,- ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest,- ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings- ] +-- Due to the use of the `unknown` encoder we need to cast '$1' when the value is not used in the main query+-- otherwise the query will err with a `could not determine data type of parameter $1`.+-- This happens because `unknown` relies on the context to determine the value type.+-- The error also happens on raw libpq used with C.+ignoredBody :: SqlFragment+ignoredBody = "ignored_body AS (SELECT $1::text) "+ removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl @@ -345,24 +367,12 @@ asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')" locationF :: [Text] -> SqlFragment-locationF pKeys =- "(" <>- " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceCTEName <> " as ss limit 1)" <>- " 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- then ""- else " WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')"- ) <> ")"--limitF :: NonnegRange -> SqlFragment-limitF r = if r == allRange- then ""- else "LIMIT " <> limit <> " OFFSET " <> offset- where- limit = maybe "ALL" show $ rangeLimit r- offset = show $ rangeOffset r+locationF pKeys = [qc|(+ WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1)+ SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null'))+ FROM data CROSS JOIN json_each_text(data.row) AS json_data+ {("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys}+)|] fromQi :: QualifiedIdentifier -> SqlFragment fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n@@ -376,14 +386,6 @@ emptyOnFalse :: Text -> Bool -> Text emptyOnFalse val cond = if cond then "" else val -insertableValue :: JSON.Value -> SqlFragment-insertableValue JSON.Null = "null"-insertableValue v = (<> "::unknown") . pgFmtLit $ unquoted v--insertableValueWithType :: Text -> JSON.Value -> SqlFragment-insertableValueWithType t v =- pgFmtLit (unquoted v) <> "::" <> t- pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment pgFmtColumn table "*" = fromQi table <> ".*" pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c@@ -395,6 +397,12 @@ 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 +pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment+pgFmtOrderTerm qi ot = unwords [+ toS . pgFmtField qi $ otTerm ot,+ maybe "" show $ otDirection ot,+ maybe "" show $ otNullOrder ot]+ pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of Op op val -> pgFmtFieldOp op <> " " <> case op of@@ -416,9 +424,6 @@ <> maybe "" ((<> ", ") . pgFmtLit) lang <> unknownLiteral val <> ") "-- Join fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName}) ->- pgFmtField fQi fld <> " = " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName where pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op sqlOperator o = HM.lookupDefault "=" o operators@@ -429,6 +434,13 @@ whiteList v = fromMaybe (toS (pgFmtLit v) <> "::unknown ") (find ((==) . toLower $ v) ["null","true","false"])++pgFmtJoinCondition :: JoinCondition -> SqlFragment+pgFmtJoinCondition (JoinCondition (qi, al1, col1) (QualifiedIdentifier schema fTable, al2, col2)) =+ pgFmtColumn (fromMaybe qi $ aliasToQi al1) col1 <> " = " <>+ pgFmtColumn (fromMaybe (removeSourceCTESchema schema fTable) $ aliasToQi al2) col2+ where+ aliasToQi al = QualifiedIdentifier "" <$> al pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")"
src/PostgREST/Types.hs view
@@ -2,12 +2,12 @@ module PostgREST.Types where import Protolude import qualified GHC.Show-import Data.Aeson+import qualified Data.Aeson as JSON import qualified Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI import qualified Data.HashMap.Strict as M+import qualified Data.Set as S import Data.Tree-import qualified Data.Vector as V import PostgREST.RangeQuery (NonnegRange) import Network.HTTP.Types.Header (hContentType, Header) @@ -23,29 +23,44 @@ | UnknownRelation | NoRelationBetween Text Text | UnsupportedVerb+ | InvalidFilters deriving (Show, Eq) +data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq+instance Show PreferResolution where+ show MergeDuplicates = "resolution=merge-duplicates"+ show IgnoreDuplicates = "resolution=ignore-duplicates"+ data DbStructure = DbStructure { dbTables :: [Table] , dbColumns :: [Column] , dbRelations :: [Relation] , dbPrimaryKeys :: [PrimaryKey]-, dbProcs :: M.HashMap Text ProcDescription+-- ProcDescription is a list because a function can be overloaded+, dbProcs :: M.HashMap Text [ProcDescription] , pgVersion :: PgVersion } deriving (Show, Eq) +-- TODO Table could hold references to all its Columns+tableCols :: DbStructure -> Schema -> TableName -> [Column]+tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs++-- TODO Table could hold references to all its PrimaryKeys+tablePKCols :: DbStructure -> Schema -> TableName -> [Text]+tablePKCols dbs tSchema tName = pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)+ data PgArg = PgArg { pgaName :: Text , pgaType :: Text , pgaReq :: Bool-} deriving (Show, Eq)+} deriving (Show, Eq, Ord) -data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show)+data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show, Ord) -data RetType = Single PgType | SetOf PgType deriving (Eq, Show)+data RetType = Single PgType | SetOf PgType deriving (Eq, Show, Ord) data ProcVolatility = Volatile | Stable | Immutable- deriving (Eq, Show)+ deriving (Eq, Show, Ord) data ProcDescription = ProcDescription { pdName :: Text@@ -55,11 +70,17 @@ , pdVolatility :: ProcVolatility } deriving (Show, Eq) +-- Order by least number of args in the case of overloaded functions+instance Ord ProcDescription where+ ProcDescription name1 des1 args1 rt1 vol1 `compare` ProcDescription name2 des2 args2 rt2 vol2+ | name1 == name2 && length args1 < length args2 = LT+ | name1 == name2 && length args1 > length args2 = GT+ | otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2)+ type Schema = Text type TableName = Text type SqlQuery = Text type SqlFragment = Text-type RequestBody = BL.ByteString data Table = Table { tableSchema :: Schema@@ -86,7 +107,9 @@ , colFK :: Maybe ForeignKey } deriving (Show, Ord) -type Synonym = (Column,Column)+-- | A view column that refers to a table column+type Synonym = (Column, ViewColumn)+type ViewColumn = Column data PrimaryKey = PrimaryKey { pkTable :: Table@@ -95,13 +118,13 @@ data OrderDirection = OrderAsc | OrderDesc deriving (Eq) instance Show OrderDirection where- show OrderAsc = "asc"- show OrderDesc = "desc"+ show OrderAsc = "ASC"+ show OrderDesc = "DESC" data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq) instance Show OrderNulls where- show OrderNullsFirst = "nulls first"- show OrderNullsLast = "nulls last"+ show OrderNullsFirst = "NULLS FIRST"+ show OrderNullsLast = "NULLS LAST" data OrderTerm = OrderTerm { otTerm :: Field@@ -112,7 +135,7 @@ data QualifiedIdentifier = QualifiedIdentifier { qiSchema :: Schema , qiName :: TableName-} deriving (Show, Eq)+} deriving (Show, Eq, Ord) data RelationType = Child | Parent | Many | Root deriving (Show, Eq)@@ -128,19 +151,30 @@ , relFTable :: Table , relFColumns :: [Column] , relType :: RelationType-, relLTable :: Maybe Table-, relLCols1 :: Maybe [Column]-, relLCols2 :: Maybe [Column]+-- The Link attrs are used when RelationType == Many+, relLinkTable :: Maybe Table+, relLinkCols1 :: Maybe [Column]+, relLinkCols2 :: Maybe [Column] } deriving (Show, Eq) --- | An array of JSON objects that has been verified to have--- the same keys in every object-newtype PayloadJSON = PayloadJSON (V.Vector Object)- deriving (Show, Eq)+-- | Cached attributes of a JSON payload+data PayloadJSON = PayloadJSON {+-- | This is the raw ByteString that comes from the request body.+-- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding+-- had high memory usage, see #1005 for more details+ pjRaw :: BL.ByteString+, pjType :: PJType+-- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects+, pjKeys :: S.Set Text+} deriving (Show, Eq) -unPayloadJSON :: PayloadJSON -> V.Vector Object-unPayloadJSON (PayloadJSON objs) = objs+data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq) +-- | e.g. whether it is []/{} or not+pjIsEmpty :: PayloadJSON -> Bool+pjIsEmpty (PayloadJSON _ PJObject keys) = S.size keys == 0+pjIsEmpty (PayloadJSON _ (PJArray l) _) = l == 0+ data Proxy = Proxy { proxyScheme :: Text , proxyHost :: Text@@ -168,14 +202,10 @@ ("sr", ">>"), ("nxr", "&<"), ("nxl", "&>"),- ("adj", "-|-"),- -- TODO: these are deprecated and should be removed in v0.5.0.0- ("@>", "@>"),- ("<@", "<@")]) ftsOperators+ ("adj", "-|-")]) ftsOperators ftsOperators :: M.HashMap Operator SqlFragment ftsOperators = M.fromList [- ("@@", "@@ to_tsquery"), -- TODO: '@@' deprecated ("fts", "@@ to_tsquery"), ("plfts", "@@ plainto_tsquery"), ("phfts", "@@ phraseto_tsquery")@@ -184,8 +214,7 @@ data OpExpr = OpExpr Bool Operation deriving (Eq, Show) data Operation = Op Operator SingleVal | In ListVal |- Fts Operator (Maybe Language) SingleVal |- Join QualifiedIdentifier ForeignKey deriving (Eq, Show)+ Fts Operator (Maybe Language) SingleVal deriving (Eq, Show) type Language = Text -- | Represents a single value in a filter, e.g. id=eq.singleval@@ -224,10 +253,10 @@ -} newtype GucHeader = GucHeader (Text, Text) -instance FromJSON GucHeader where- parseJSON (Object o) = case headMay (M.toList o) of- Just (k, String s) | M.size o == 1 -> pure $ GucHeader (k, s)- | otherwise -> mzero+instance JSON.FromJSON GucHeader where+ parseJSON (JSON.Object o) = case headMay (M.toList o) of+ Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (k, s)+ | otherwise -> mzero _ -> mzero parseJSON _ = mzero @@ -243,13 +272,17 @@ -- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"] type EmbedPath = [Text] data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq)+data JoinCondition = JoinCondition (QualifiedIdentifier, Maybe Alias, FieldName)+ (QualifiedIdentifier, Maybe Alias, FieldName) deriving (Show, Eq) -data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)-data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }+data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], joinConditions::[JoinCondition], order::[OrderTerm], range_::NonnegRange } deriving (Show, Eq)+data MutateQuery = Insert { in_::TableName, insPkCols::[Text], qPayload::PayloadJSON, onConflict:: Maybe PreferResolution, where_::[LogicTree], returning::[FieldName] } | Delete { in_::TableName, where_::[LogicTree], returning::[FieldName] } | Update { in_::TableName, qPayload::PayloadJSON, where_::[LogicTree], returning::[FieldName] } deriving (Show, Eq)-type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail))+type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail, Depth)) type ReadRequest = Tree ReadNode+-- Depth of the ReadRequest tree+type Depth = Integer type MutateRequest = MutateQuery data DbRequest = DbRead ReadRequest | DbMutate MutateRequest @@ -280,3 +313,8 @@ sourceCTEName :: SqlFragment sourceCTEName = "pg_source"++-- | full jspath, e.g. .property[0].attr.detail+type JSPath = [JSPathExp]+-- | jspath expression, e.g. .property, .property[0] or ."property-dash"+data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show)
test/Feature/AndOrParamsSpec.hs view
@@ -27,13 +27,13 @@ context "embedded levels" $ do it "can do logic on the second level" $- get "/entities?child_entities.or=(id.eq.1,name.eq.child entity 2)&select=id,child_entities{id}" `shouldRespondWith`+ get "/entities?child_entities.or=(id.eq.1,name.eq.child entity 2)&select=id,child_entities(id)" `shouldRespondWith` [json|[ {"id": 1, "child_entities": [ { "id": 1 }, { "id": 2 } ] }, { "id": 2, "child_entities": []}, {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []} ]|] { matchHeaders = [matchContentTypeJson] } it "can do logic on the third level" $- get "/entities?child_entities.grandchild_entities.or=(id.eq.1,id.eq.2)&select=id,child_entities{id,grandchild_entities{id}}" `shouldRespondWith`+ get "/entities?child_entities.grandchild_entities.or=(id.eq.1,id.eq.2)&select=id,child_entities(id,grandchild_entities(id))" `shouldRespondWith` [json|[ {"id": 1, "child_entities": [ { "id": 1, "grandchild_entities": [ { "id": 1 }, { "id": 2 } ]}, { "id": 2, "grandchild_entities": []}]}, {"id": 2, "child_entities": [ { "id": 3, "grandchild_entities": []} ]},@@ -79,15 +79,9 @@ {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4" }, {"text_search_vector": "'art':4 'spass':5 'unmog':7"} ]|] { matchHeaders = [matchContentTypeJson] }- -- TODO: remove in 0.5.0 as deprecated- get "/entities?or=(text_search_vector.@@.bar,text_search_vector.@@.baz)&select=id" `shouldRespondWith`- [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }- it "can handle cs and cd" $ do+ it "can handle cs and cd" $ get "/entities?or=(arr.cs.{1,2,3},arr.cd.{1})&select=id" `shouldRespondWith` [json|[{ "id": 1 },{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }- -- TODO: remove in 0.5.0 as deprecated- get "/entities?or=(arr.@>.{1,2,3},arr.<@.{1})&select=id" `shouldRespondWith`- [json|[{ "id": 1 },{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] } it "can handle range operators" $ do get "/ranges?range=eq.[1,3]&select=id" `shouldRespondWith`@@ -120,24 +114,15 @@ [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] } context "operators with not" $ do- it "eq, cs, like can be negated" $ do+ it "eq, cs, like can be negated" $ get "/entities?and=(arr.not.cs.{1,2,3},and(id.not.eq.2,name.not.like.*3))&select=id" `shouldRespondWith` [json|[{ "id": 1}]|] { matchHeaders = [matchContentTypeJson] }- -- TODO: remove in 0.5.0 as deprecated- get "/entities?and=(arr.not.@>.{1,2,3},and(id.not.eq.2,name.not.like.*3))&select=id" `shouldRespondWith`- [json|[{ "id": 1}]|] { matchHeaders = [matchContentTypeJson] }- it "in, is, fts can be negated" $ do+ it "in, is, fts can be negated" $ get "/entities?and=(id.not.in.(1,3),and(name.not.is.null,text_search_vector.not.fts.foo))&select=id" `shouldRespondWith` [json|[{ "id": 2}]|] { matchHeaders = [matchContentTypeJson] }- -- TODO: remove in 0.5.0 as deprecated- get "/entities?and=(id.not.in.(1,3),and(name.not.is.null,text_search_vector.not.@@.foo))&select=id" `shouldRespondWith`- [json|[{ "id": 2}]|] { matchHeaders = [matchContentTypeJson] }- it "lt, gte, cd can be negated" $ do+ it "lt, gte, cd can be negated" $ get "/entities?and=(arr.not.cd.{1},or(id.not.lt.1,id.not.gte.3))&select=id" `shouldRespondWith` [json|[{"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }- -- TODO: remove in 0.5.0 as deprecated- get "/entities?and=(arr.not.<@.{1},or(id.not.lt.1,id.not.gte.3))&select=id" `shouldRespondWith`- [json|[{"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] } it "gt, lte, ilike can be negated" $ get "/entities?and=(name.not.ilike.*ITY2,or(id.not.gt.4,id.not.lte.1))&select=id" `shouldRespondWith` [json|[{"id": 1}, {"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }@@ -182,7 +167,7 @@ context "used with POST" $ it "includes related data with filters" $- request methodPost "/child_entities?entities.or=(id.eq.2,id.eq.3)&select=id,entities{id}"+ request methodPost "/child_entities?entities.or=(id.eq.2,id.eq.3)&select=id,entities(id)" [("Prefer", "return=representation")] [json|[{"id":4,"name":"entity 4","parent_id":1}, {"id":5,"name":"entity 5","parent_id":2},
test/Feature/DeleteSpec.hs view
@@ -36,7 +36,7 @@ request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] "" `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|] it "can embed (parent) entities" $- request methodDelete "/tasks?id=eq.8&select=id,name,project{id}" [("Prefer", "return=representation")] ""+ request methodDelete "/tasks?id=eq.8&select=id,name,project(id)" [("Prefer", "return=representation")] "" `shouldRespondWith` [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "*/*"]
test/Feature/InsertSpec.hs view
@@ -49,9 +49,15 @@ , matchHeaders = [matchContentTypeJson] } + context "non uniform json array" $ do+ it "rejects json array that isn't exclusivily composed of objects" $+ post "/articles" [json| [{"id": 100, "body": "xxxxx"}, 123, "xxxx", {"id": 111, "body": "xxxx"}] |] `shouldRespondWith` 400+ it "rejects json array that has objects with different keys" $+ post "/articles" [json| [{"id": 100, "body": "xxxxx"}, {"id": 111, "body": "xxxx", "owner": "me"}] |] `shouldRespondWith` 400+ context "requesting full representation" $ do it "includes related data after insert" $- request methodPost "/projects?select=id,name,clients{id,name}"+ request methodPost "/projects?select=id,name,clients(id,name)" [("Prefer", "return=representation"), ("Prefer", "count=exact")] [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` [str|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|] { matchStatus = 201@@ -416,13 +422,21 @@ -- put value back for other tests void $ request methodPatch "/items?id=eq.99" [] [json| { "id":1 } |] - it "makes no updates and returns 204, when patching with an empty json object" $ do+ it "makes no updates and returns 204, when patching with an empty json object/array" $ do request methodPatch "/items" [] [json| {} |] `shouldRespondWith` "" { matchStatus = 204, matchHeaders = ["Content-Range" <:> "*/*"] }++ request methodPatch "/items" [] [json| [] |]+ `shouldRespondWith` ""+ {+ matchStatus = 204,+ matchHeaders = ["Content-Range" <:> "*/*"]+ }+ get "/items" `shouldRespondWith` [json|[{"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},{id:16},{"id":2},{"id":1}]|] { matchHeaders = [matchContentTypeJson] }
test/Feature/QueryLimitedSpec.hs view
@@ -29,14 +29,14 @@ simpleStatus r `shouldBe` ok200 it "limit works on all levels" $- get "/users?select=id,tasks{id}&order=id.asc&tasks.order=id.asc"+ get "/users?select=id,tasks(id)&order=id.asc&tasks.order=id.asc" `shouldRespondWith` [json|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "0-1/*"] } it "limit is not applied to parent embeds" $- get "/tasks?select=id,project{id}&id=gt.5"+ get "/tasks?select=id,project(id)&id=gt.5" `shouldRespondWith` [json|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "0-1/*"]
test/Feature/QuerySpec.hs view
@@ -50,12 +50,12 @@ { matchHeaders = ["Content-Range" <:> "0-1/*"] } it "matches items IN" $- get "/items?id=in.1,3,5"+ get "/items?id=in.(1,3,5)" `shouldRespondWith` [json| [{"id":1},{"id":3},{"id":5}] |] { matchHeaders = ["Content-Range" <:> "0-2/*"] } it "matches items NOT IN using not operator" $- get "/items?id=not.in.2,4,6,7,8,9,10,11,12,13,14,15"+ get "/items?id=not.in.(2,4,6,7,8,9,10,11,12,13,14,15)" `shouldRespondWith` [json| [{"id":1},{"id":3},{"id":5}] |] { matchHeaders = ["Content-Range" <:> "0-2/*"] } @@ -145,22 +145,6 @@ {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|] { matchHeaders = [matchContentTypeJson] } - -- TODO: remove in 0.5.0 as deprecated- it "Deprecated @@ operator, pending to remove" $ do- get "/tsearch?text_search_vector=@@.impossible" `shouldRespondWith`- [json| [{"text_search_vector": "'fun':5 'imposs':9 'kind':3" }] |]- { matchHeaders = [matchContentTypeJson] }- get "/tsearch?text_search_vector=not.@@.impossible%7Cfat%7Cfun" `shouldRespondWith`- [json| [- {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4"},- {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|]- { matchHeaders = [matchContentTypeJson] }- get "/tsearch?text_search_vector=not.@@(english).impossible%7Cfat%7Cfun" `shouldRespondWith`- [json| [- {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4"},- {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|]- { matchHeaders = [matchContentTypeJson] }- it "matches with computed column" $ get "/items?always_true=eq.true&order=id.asc" `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |]@@ -171,37 +155,31 @@ [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] { matchHeaders = [matchContentTypeJson] } + it "cannot access a computed column that is outside of the config schema" $+ get "/items?always_false=is.false" `shouldRespondWith` 400+ it "matches filtering nested items 2" $- get "/clients?select=id,projects{id,tasks2{id,name}}&projects.tasks.name=like.Design*"+ get "/clients?select=id,projects(id,tasks2(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith` [json| {"message":"Could not find foreign keys between these entities, No relation found between projects and tasks2"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "matches filtering nested items" $- get "/clients?select=id,projects{id,tasks{id,name}}&projects.tasks.name=like.Design*" `shouldRespondWith`+ get "/clients?select=id,projects(id,tasks(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith` [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1,"name":"Design w7"}]},{"id":2,"tasks":[{"id":3,"name":"Design w10"}]}]},{"id":2,"projects":[{"id":3,"tasks":[{"id":5,"name":"Design IOS"}]},{"id":4,"tasks":[{"id":7,"name":"Design OSX"}]}]}]|] { matchHeaders = [matchContentTypeJson] } - it "matches with cs operator" $ do+ it "matches with cs operator" $ get "/complex_items?select=id&arr_data=cs.{2}" `shouldRespondWith` [json|[{"id":2},{"id":3}]|] { matchHeaders = [matchContentTypeJson] }- -- TODO: remove in 0.5.0 as deprecated- get "/complex_items?select=id&arr_data=@>.{2}" `shouldRespondWith`- [json|[{"id":2},{"id":3}]|]- { matchHeaders = [matchContentTypeJson] } - it "matches with cd operator" $ do+ it "matches with cd operator" $ get "/complex_items?select=id&arr_data=cd.{1,2,4}" `shouldRespondWith` [json|[{"id":1},{"id":2}]|] { matchHeaders = [matchContentTypeJson] }- -- TODO: remove in 0.5.0 as deprecated- get "/complex_items?select=id&arr_data=<@.{1,2,4}" `shouldRespondWith`- [json|[{"id":1},{"id":2}]|]- { matchHeaders = [matchContentTypeJson] } - describe "Shaping response with select parameter" $ do it "selectStar works in absense of parameter" $@@ -285,12 +263,12 @@ { matchHeaders = [matchContentTypeJson] } it "requesting parents and children" $- get "/projects?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`+ get "/projects?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] { matchHeaders = [matchContentTypeJson] } it "requesting parent without specifying primary key" $ do- get "/projects?select=name,client{name}" `shouldRespondWith`+ get "/projects?select=name,client(name)" `shouldRespondWith` [json|[ {"name":"Windows 7","client":{"name": "Microsoft"}}, {"name":"Windows 10","client":{"name": "Microsoft"}},@@ -299,12 +277,12 @@ {"name":"Orphan","client":null} ]|] { matchHeaders = [matchContentTypeJson] }- get "/articleStars?select=createdAt,article{owner},user{name}&limit=1" `shouldRespondWith`+ get "/articleStars?select=createdAt,article(owner),user(name)&limit=1" `shouldRespondWith` [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"owner": "postgrest_test_authenticator"},"user":{"name": "Angela Martin"}}]|] { matchHeaders = [matchContentTypeJson] } it "requesting parent and renaming primary key" $- get "/projects?select=name,client{clientId:id,name}" `shouldRespondWith`+ get "/projects?select=name,client(clientId:id,name)" `shouldRespondWith` [json|[ {"name":"Windows 7","client":{"name": "Microsoft", "clientId": 1}}, {"name":"Windows 10","client":{"name": "Microsoft", "clientId": 1}},@@ -315,116 +293,270 @@ { matchHeaders = [matchContentTypeJson] } it "requesting parent and specifying/renaming one key of the composite primary key" $ do- get "/comments?select=*,users_tasks{userId:user_id}" `shouldRespondWith`+ get "/comments?select=*,users_tasks(userId:user_id)" `shouldRespondWith` [json|[{"id":1,"commenter_id":1,"user_id":2,"task_id":6,"content":"Needs to be delivered ASAP","users_tasks":{"userId": 2}}]|] { matchHeaders = [matchContentTypeJson] }- get "/comments?select=*,users_tasks{taskId:task_id}" `shouldRespondWith`+ get "/comments?select=*,users_tasks(taskId:task_id)" `shouldRespondWith` [json|[{"id":1,"commenter_id":1,"user_id":2,"task_id":6,"content":"Needs to be delivered ASAP","users_tasks":{"taskId": 6}}]|] { matchHeaders = [matchContentTypeJson] } 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`+ 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`+ get "/projects?id=eq.1&select=myId:id, name, project_client:client_id(*), project_tasks:tasks(id, name)" `shouldRespondWith` [json|[{"myId":1,"name":"Windows 7","project_client":{"id":1,"name":"Microsoft"},"project_tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] { matchHeaders = [matchContentTypeJson] } it "requesting parents two levels up while using FK to specify the link" $- get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith`+ get "/tasks?id=eq.1&select=id,name,project:project_id(id,name,client:client_id(id,name))" `shouldRespondWith` [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] it "requesting parents two levels up while using FK to specify the link (with rename)" $- get "/tasks?id=eq.1&select=id,name,project:project_id{id,name,client:client_id{id,name}}" `shouldRespondWith`+ get "/tasks?id=eq.1&select=id,name,project:project_id(id,name,client:client_id(id,name))" `shouldRespondWith` [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] - it "requesting parents and filtering parent columns" $- get "/projects?id=eq.1&select=id, name, clients{id}" `shouldRespondWith`+ get "/projects?id=eq.1&select=id, name, clients(id)" `shouldRespondWith` [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|] it "rows with missing parents are included" $- get "/projects?id=in.1,5&select=id,clients{id}" `shouldRespondWith`+ get "/projects?id=in.(1,5)&select=id,clients(id)" `shouldRespondWith` [json|[{"id":1,"clients":{"id":1}},{"id":5,"clients":null}]|] { matchHeaders = [matchContentTypeJson] } it "rows with no children return [] instead of null" $- get "/projects?id=in.5&select=id,tasks{id}" `shouldRespondWith`+ get "/projects?id=in.(5)&select=id,tasks(id)" `shouldRespondWith` [str|[{"id":5,"tasks":[]}]|] it "requesting children 2 levels" $- get "/clients?id=eq.1&select=id,projects{id,tasks{id}}" `shouldRespondWith`- [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|]- { matchHeaders = [matchContentTypeJson] }-- it "requesting children 2 levels (with relation path fixed)" $- get "/clients?id=eq.1&select=id,projects:projects.client_id{id,tasks{id}}" `shouldRespondWith`+ get "/clients?id=eq.1&select=id,projects(id,tasks(id))" `shouldRespondWith` [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|] { matchHeaders = [matchContentTypeJson] } it "requesting many<->many relation" $- get "/tasks?select=id,users{id}" `shouldRespondWith`- [json|[{"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":[]}]|]- { matchHeaders = [matchContentTypeJson] }-- it "requesting many<->many relation (with relation path fixed)" $- get "/tasks?select=id,users:users.users_tasks{id}" `shouldRespondWith`+ get "/tasks?select=id,users(id)" `shouldRespondWith` [json|[{"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":[]}]|] { matchHeaders = [matchContentTypeJson] } it "requesting many<->many relation with rename" $- get "/tasks?id=eq.1&select=id,theUsers:users{id}" `shouldRespondWith`+ get "/tasks?id=eq.1&select=id,theUsers:users(id)" `shouldRespondWith` [json|[{"id":1,"theUsers":[{"id":1},{"id":3}]}]|] { matchHeaders = [matchContentTypeJson] } - it "requesting many<->many relation reverse" $- get "/users?select=id,tasks{id}" `shouldRespondWith`+ get "/users?select=id,tasks(id)" `shouldRespondWith` [json|[{"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}]}]|] { matchHeaders = [matchContentTypeJson] } it "requesting parents and children on views" $- get "/projects_view?id=eq.1&select=id, name, clients{*}, tasks{id, name}" `shouldRespondWith`+ get "/projects_view?id=eq.1&select=id, name, clients(*), tasks(id, name)" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] { matchHeaders = [matchContentTypeJson] } it "requesting parents and children on views with renamed keys" $- get "/projects_view_alt?t_id=eq.1&select=t_id, name, clients{*}, tasks{id, name}" `shouldRespondWith`+ get "/projects_view_alt?t_id=eq.1&select=t_id, name, clients(*), tasks(id, name)" `shouldRespondWith` [json|[{"t_id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}]|] { matchHeaders = [matchContentTypeJson] } + it "detects parent relations when having many views of a private table" $ do+ get "/books?select=title,author(name)&id=eq.5" `shouldRespondWith`+ [json|[ { "title": "Farenheit 451", "author": { "name": "Ray Bradbury" } } ]|]+ { matchHeaders = [matchContentTypeJson] }+ get "/forties_books?select=title,author(name)&limit=1" `shouldRespondWith`+ [json|[ { "title": "1984", "author": { "name": "George Orwell" } } ]|]+ { matchHeaders = [matchContentTypeJson] }+ get "/fifties_books?select=title,author(name)&limit=1" `shouldRespondWith`+ [json|[ { "title": "The Catcher in the Rye", "author": { "name": "J.D. Salinger" } } ]|]+ { matchHeaders = [matchContentTypeJson] }+ get "/sixties_books?select=title,author(name)&limit=1" `shouldRespondWith`+ [json|[ { "title": "To Kill a Mockingbird", "author": { "name": "Harper Lee" } } ]|]+ { matchHeaders = [matchContentTypeJson] } it "requesting children with composite key" $- get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments{content}" `shouldRespondWith`+ get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments(content)" `shouldRespondWith` [json|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|] { matchHeaders = [matchContentTypeJson] } it "detect relations in views from exposed schema that are based on tables in private schema and have columns renames" $- get "/articles?id=eq.1&select=id,articleStars{users{*}}" `shouldRespondWith`+ get "/articles?id=eq.1&select=id,articleStars(users(*))" `shouldRespondWith` [json|[{"id":1,"articleStars":[{"users":{"id":1,"name":"Angela Martin"}},{"users":{"id":2,"name":"Michael Scott"}},{"users":{"id":3,"name":"Dwight Schrute"}}]}]|] { matchHeaders = [matchContentTypeJson] } it "can embed by FK column name" $- get "/projects?id=in.1,3&select=id,name,client_id{id,name}" `shouldRespondWith`+ get "/projects?id=in.(1,3)&select=id,name,client_id(id,name)" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client_id":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":{"id":2,"name":"Apple"}}]|] { matchHeaders = [matchContentTypeJson] }- + it "can embed by FK column name and select the FK value at the same time, if aliased" $- get "/projects?id=in.1,3&select=id,name,client_id,client:client_id{id,name}" `shouldRespondWith`+ get "/projects?id=in.(1,3)&select=id,name,client_id,client:client_id(id,name)" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|] { matchHeaders = [matchContentTypeJson] } it "can select by column name sans id" $- get "/projects?id=in.1,3&select=id,name,client_id,client{id,name}" `shouldRespondWith`+ get "/projects?id=in.(1,3)&select=id,name,client_id,client(id,name)" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|] { matchHeaders = [matchContentTypeJson] } it "can detect fk relations through views to tables in the public schema" $- get "/consumers_view?select=*,orders_view{*}" `shouldRespondWith` 200+ get "/consumers_view?select=*,orders_view(*)" `shouldRespondWith` 200 + describe "path fixed" $ do+ it "works when requesting children 2 levels" $+ get "/clients?id=eq.1&select=id,projects:projects.client_id(id,tasks(id))" `shouldRespondWith`+ [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|]+ { matchHeaders = [matchContentTypeJson] } + it "works with parent relation" $ do+ get "/message?select=id,body,sender:person_detail.sender(name,sent),recipient:person_detail.recipient(name,received)&id=lt.4" `shouldRespondWith`+ [json|+ [{"id":1,"body":"Hello Jane","sender":{"name":"John","sent":2},"recipient":{"name":"Jane","received":2}},+ {"id":2,"body":"Hi John","sender":{"name":"Jane","sent":1},"recipient":{"name":"John","received":1}},+ {"id":3,"body":"How are you doing?","sender":{"name":"John","sent":2},"recipient":{"name":"Jane","received":2}}] |]+ { matchHeaders = [matchContentTypeJson] }+ get "/message?select=id,body,sender:person.sender(name),recipient:person.recipient(name)&id=lt.4" `shouldRespondWith`+ [json|+ [{"id":1,"body":"Hello Jane","sender":{"name":"John"},"recipient":{"name":"Jane"}},+ {"id":2,"body":"Hi John","sender":{"name":"Jane"},"recipient":{"name":"John"}},+ {"id":3,"body":"How are you doing?","sender":{"name":"John"},"recipient":{"name":"Jane"}}] |]+ { matchHeaders = [matchContentTypeJson] }++ it "works with many<->many relation" $+ get "/tasks?select=id,users:users.users_tasks(id)" `shouldRespondWith`+ [json|[{"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":[]}]|]+ { matchHeaders = [matchContentTypeJson] }++ describe "aliased embeds" $ do+ it "works with child relation" $+ get "/space?select=id,zones:zone(id,name),stores:zone(id,name)&zones.zone_type_id=eq.2&stores.zone_type_id=eq.3" `shouldRespondWith`+ [json|[+ { "id":1,+ "zones": [ {"id":1,"name":"zone 1"}, {"id":2,"name":"zone 2"}],+ "stores": [ {"id":3,"name":"store 3"}, {"id":4,"name":"store 4"}]}+ ]|] { matchHeaders = [matchContentTypeJson] }++ it "works with many to many relation" $+ get "/users?select=id,designTasks:tasks(id,name),codeTasks:tasks(id,name)&designTasks.name=like.*Design*&codeTasks.name=like.*Code*" `shouldRespondWith`+ [json|[+ { "id":1,+ "designTasks":[ { "id":1, "name":"Design w7" }, { "id":3, "name":"Design w10" } ],+ "codeTasks":[ { "id":2, "name":"Code w7" }, { "id":4, "name":"Code w10" } ] },+ { "id":2,+ "designTasks":[ { "id":5, "name":"Design IOS" }, { "id":7, "name":"Design OSX" } ],+ "codeTasks":[ { "id":6, "name":"Code IOS" } ] },+ { "id":3,+ "designTasks":[ { "id":1, "name":"Design w7" }, { "id":5, "name":"Design IOS" } ],+ "codeTasks":[ ] }+ ]|] { matchHeaders = [matchContentTypeJson] }++ it "works with an aliased child plus non aliased child" $+ get "/projects?select=id,name,designTasks:tasks(name,users(id,name))&designTasks.name=like.*Design*&designTasks.users.id=in.(1,2)" `shouldRespondWith`+ [json|[+ {+ "id":1, "name":"Windows 7",+ "designTasks":[ { "name":"Design w7", "users":[ { "id":1, "name":"Angela Martin" } ] } ] },+ {+ "id":2, "name":"Windows 10",+ "designTasks":[ { "name":"Design w10", "users":[ { "id":1, "name":"Angela Martin" } ] } ] },+ {+ "id":3, "name":"IOS",+ "designTasks":[ { "name":"Design IOS", "users":[ { "id":2, "name":"Michael Scott" } ] } ] },+ {+ "id":4, "name":"OSX",+ "designTasks":[ { "name":"Design OSX", "users":[ { "id":2, "name":"Michael Scott" } ] } ] },+ {+ "id":5, "name":"Orphan",+ "designTasks":[ ] }+ ]|] { matchHeaders = [matchContentTypeJson] }++ it "works with two aliased childs embeds plus and/or" $+ get "/entities?select=id,childs:child_entities(id,gChilds:grandchild_entities(id))&childs.and=(id.in.(1,2,3))&childs.gChilds.or=(id.eq.1,id.eq.2)" `shouldRespondWith`+ [json|[+ { "id":1,+ "childs":[+ {"id":1,"gChilds":[{"id":1}, {"id":2}]},+ {"id":2,"gChilds":[]}]},+ { "id":2,+ "childs":[+ {"id":3,"gChilds":[]}]},+ { "id":3,"childs":[]},+ { "id":4,"childs":[]}+ ]|] { matchHeaders = [matchContentTypeJson] }++ describe "tables with self reference foreign keys" $ do+ context "one self reference foreign key" $ do+ it "embeds parents recursively" $+ get "/family_tree?id=in.(3,4)&select=id,parent(id,name,parent(*))" `shouldRespondWith`+ [json|[+ { "id": "3", "parent": { "id": "1", "name": "Parental Unit", "parent": null } },+ { "id": "4", "parent": { "id": "2", "name": "Kid One", "parent": { "id": "1", "name": "Parental Unit", "parent": null } } }+ ]|]+ { matchHeaders = [matchContentTypeJson] }++ it "embeds childs recursively" $+ get "/family_tree?id=eq.1&select=id,name, childs:family_tree.parent(id,name,childs:family_tree.parent(id,name))" `shouldRespondWith`+ [json|[{+ "id": "1", "name": "Parental Unit", "childs": [+ { "id": "2", "name": "Kid One", "childs": [ { "id": "4", "name": "Grandkid One" } ] },+ { "id": "3", "name": "Kid Two", "childs": [ { "id": "5", "name": "Grandkid Two" } ] }+ ]+ }]|] { matchHeaders = [matchContentTypeJson] }++ it "embeds parent and then embeds childs" $+ get "/family_tree?id=eq.2&select=id,name,parent(id,name,childs:family_tree.parent(id,name))" `shouldRespondWith`+ [json|[{+ "id": "2", "name": "Kid One", "parent": {+ "id": "1", "name": "Parental Unit", "childs": [ { "id": "2", "name": "Kid One" }, { "id": "3", "name": "Kid Two"} ]+ }+ }]|] { matchHeaders = [matchContentTypeJson] }++ context "two self reference foreign keys" $ do+ it "embeds parents" $+ get "/organizations?select=id,name,referee(id,name),auditor(id,name)&id=eq.3" `shouldRespondWith`+ [json|[{+ "id": 3, "name": "Acme",+ "referee": {+ "id": 1,+ "name": "Referee Org"+ },+ "auditor": {+ "id": 2,+ "name": "Auditor Org"+ }+ }]|] { matchHeaders = [matchContentTypeJson] }++ it "embeds childs" $ do+ get "/organizations?select=id,name,refereeds:organizations.referee(id,name)&id=eq.1" `shouldRespondWith`+ [json|[{+ "id": 1, "name": "Referee Org",+ "refereeds": [+ {+ "id": 3,+ "name": "Acme"+ },+ {+ "id": 4,+ "name": "Umbrella"+ }+ ]+ }]|] { matchHeaders = [matchContentTypeJson] }+ get "/organizations?select=id,name,auditees:organizations.auditor(id,name)&id=eq.2" `shouldRespondWith`+ [json|[{+ "id": 2, "name": "Auditor Org",+ "auditees": [+ {+ "id": 3,+ "name": "Acme"+ },+ {+ "id": 4,+ "name": "Umbrella"+ }+ ]+ }]|] { matchHeaders = [matchContentTypeJson] }+ describe "ordering response" $ do it "by a column asc" $ get "/items?id=lte.2&order=id.asc"@@ -432,6 +564,8 @@ { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "0-1/*"] }++ it "by a column desc" $ get "/items?id=lte.2&order=id.desc" `shouldRespondWith` [json| [{"id":2},{"id":1}] |]@@ -476,6 +610,26 @@ , matchHeaders = ["Content-Range" <:> "0-2/*"] } + it "by two columns with nulls and direction specified" $+ get "/projects?select=client_id,id,name&order=client_id.desc.nullslast,id.desc"+ `shouldRespondWith` [json|+ [{"client_id":2,"id":4,"name":"OSX"},+ {"client_id":2,"id":3,"name":"IOS"},+ {"client_id":1,"id":2,"name":"Windows 10"},+ {"client_id":1,"id":1,"name":"Windows 7"},+ {"client_id":null,"id":5,"name":"Orphan"}]+ |]+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-4/*"]+ }++ it "by a column with no direction or nulls specified" $+ get "/items?id=lte.2&order=id"+ `shouldRespondWith` [json| [{"id":1},{"id":2}] |]+ { matchStatus = 200+ , matchHeaders = ["Content-Range" <:> "0-1/*"]+ }+ it "by a json column property asc" $ get "/json?order=data->>id.asc" `shouldRespondWith` [json| [{"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}, {"data": {"id": 3}}] |]@@ -490,29 +644,72 @@ 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`+ get "/projects?id=eq.1&select=id, name, tasks(id, name)&tasks.order=name.asc" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|] { matchHeaders = [matchContentTypeJson] } it "ordering embeded entities with alias" $- get "/projects?id=eq.1&select=id, name, the_tasks:tasks{id, name}&tasks.order=name.asc" `shouldRespondWith`+ get "/projects?id=eq.1&select=id, name, the_tasks:tasks(id, name)&tasks.order=name.asc" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","the_tasks":[{"id":2,"name":"Code w7"},{"id":1,"name":"Design w7"}]}]|] { matchHeaders = [matchContentTypeJson] } 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`+ get "/projects?id=eq.1&select=id, name, tasks(id, name, users(id, name))&tasks.order=name.asc&tasks.users.order=name.desc" `shouldRespondWith` [json|[{"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"}]}]}]|] { matchHeaders = [matchContentTypeJson] } it "ordering embeded parents does not break things" $- get "/projects?id=eq.1&select=id, name, clients{id, name}&clients.order=name.asc" `shouldRespondWith`+ 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`+ 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"}}]|] + context "order syntax errors" $ do+ it "gives meaningful error messages when asc/desc/nulls{first,last} are misspelled" $ do+ get "/items?order=id.ac" `shouldRespondWith`+ [json|{"details":"unexpected \"c\" expecting \"asc\", \"desc\", \"nullsfirst\" or \"nullslast\"","message":"\"failed to parse order (id.ac)\" (line 1, column 4)"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ }+ get "/items?order=id.descc" `shouldRespondWith`+ [json|{"details":"unexpected 'c' expecting delimiter (.), \",\" or end of input","message":"\"failed to parse order (id.descc)\" (line 1, column 8)"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ }+ get "/items?order=id.nulsfist" `shouldRespondWith`+ [json|{"details":"unexpected \"n\" expecting \"asc\", \"desc\", \"nullsfirst\" or \"nullslast\"","message":"\"failed to parse order (id.nulsfist)\" (line 1, column 4)"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ }+ get "/items?order=id.nullslasttt" `shouldRespondWith`+ [json|{"details":"unexpected 't' expecting \",\" or end of input","message":"\"failed to parse order (id.nullslasttt)\" (line 1, column 13)"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ }+ get "/items?order=id.smth34" `shouldRespondWith`+ [json|{"details":"unexpected \"s\" expecting \"asc\", \"desc\", \"nullsfirst\" or \"nullslast\"","message":"\"failed to parse order (id.smth34)\" (line 1, column 4)"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ } + it "gives meaningful error messages when nulls{first,last} are misspelled after asc/desc" $ do+ get "/items?order=id.asc.nlsfst" `shouldRespondWith`+ [json|{"details":"unexpected \"l\" expecting \"nullsfirst\" or \"nullslast\"","message":"\"failed to parse order (id.asc.nlsfst)\" (line 1, column 8)"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ }+ get "/items?order=id.asc.nullslasttt" `shouldRespondWith`+ [json|{"details":"unexpected 't' expecting \",\" or end of input","message":"\"failed to parse order (id.asc.nullslasttt)\" (line 1, column 17)"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ }+ get "/items?order=id.asc.smth34" `shouldRespondWith`+ [json|{"details":"unexpected \"s\" expecting \"nullsfirst\" or \"nullslast\"","message":"\"failed to parse order (id.asc.smth34)\" (line 1, column 8)"}|]+ { matchStatus = 400+ , matchHeaders = [matchContentTypeJson]+ } describe "Accept headers" $ do it "should respond an unknown accept type with 415" $@@ -607,12 +804,12 @@ } it "will embed a collection" $- get "/Escap3e;?select=ghostBusters{*}" `shouldRespondWith`+ get "/Escap3e;?select=ghostBusters(*)" `shouldRespondWith` [json| [{"ghostBusters":[{"escapeId":1}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":3}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":5}]}] |] { matchHeaders = [matchContentTypeJson] } it "will embed using a column" $- get "/ghostBusters?select=escapeId{*}" `shouldRespondWith`+ get "/ghostBusters?select=escapeId(*)" `shouldRespondWith` [json| [{"escapeId":{"so6meIdColumn":1}},{"escapeId":{"so6meIdColumn":3}},{"escapeId":{"so6meIdColumn":5}}] |] { matchHeaders = [matchContentTypeJson] } @@ -634,7 +831,7 @@ `shouldRespondWith` 406 it "concatenates results if more than one row is returned" $- request methodGet "/images_base64?select=img&name=in.A.png,B.png" (acceptHdrs "application/octet-stream") ""+ request methodGet "/images_base64?select=img&name=in.(A.png,B.png)" (acceptHdrs "application/octet-stream") "" `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII=" { matchStatus = 200 , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]@@ -696,7 +893,6 @@ { matchStatus = 200 , matchHeaders = [] }- it "multiple cookies ends up as claims" $ request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue;secondcookie=anothervalue")] [json| {"name":"request.cookie.secondcookie"} |]@@ -705,99 +901,82 @@ { matchStatus = 200 , matchHeaders = [] }+ it "app settings available" $+ request methodPost "/rpc/get_guc_value" []+ [json| { "name": "app.settings.app_host" } |]+ `shouldRespondWith`+ [str|"localhost"|]+ { matchStatus = 200+ , matchHeaders = [ matchContentTypeJson ]+ } describe "values with quotes in IN and NOT IN" $ do it "succeeds when only quoted values are present" $ do- get "/w_or_wo_comma_names?name=in.\"Hebdon, John\"" `shouldRespondWith`+ get "/w_or_wo_comma_names?name=in.(\"Hebdon, John\")" `shouldRespondWith` [json| [{"name":"Hebdon, John"}] |] { matchHeaders = [matchContentTypeJson] }- get "/w_or_wo_comma_names?name=in.\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\"" `shouldRespondWith`+ get "/w_or_wo_comma_names?name=in.(\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\")" `shouldRespondWith` [json| [{"name":"Hebdon, John"},{"name":"Williams, Mary"},{"name":"Smith, Joseph"}] |] { matchHeaders = [matchContentTypeJson] }- get "/w_or_wo_comma_names?name=not.in.\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\"" `shouldRespondWith`+ get "/w_or_wo_comma_names?name=not.in.(\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\")" `shouldRespondWith` [json| [{"name":"David White"},{"name":"Larry Thompson"}] |] { matchHeaders = [matchContentTypeJson] } it "succeeds w/ and w/o quoted values" $ do- get "/w_or_wo_comma_names?name=in.David White,\"Hebdon, John\"" `shouldRespondWith`+ get "/w_or_wo_comma_names?name=in.(David White,\"Hebdon, John\")" `shouldRespondWith` [json| [{"name":"Hebdon, John"},{"name":"David White"}] |] { matchHeaders = [matchContentTypeJson] }- get "/w_or_wo_comma_names?name=not.in.\"Hebdon, John\",Larry Thompson,\"Smith, Joseph\"" `shouldRespondWith`+ get "/w_or_wo_comma_names?name=not.in.(\"Hebdon, John\",Larry Thompson,\"Smith, Joseph\")" `shouldRespondWith` [json| [{"name":"Williams, Mary"},{"name":"David White"}] |] { matchHeaders = [matchContentTypeJson] } it "checks well formed quoted values" $ do- get "/w_or_wo_comma_names?name=in.\"\"Hebdon, John\"" `shouldRespondWith`+ get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\")" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] }- get "/w_or_wo_comma_names?name=in.\"\"Hebdon, John\"\"Mary" `shouldRespondWith`+ get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\"\"Mary)" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] }- get "/w_or_wo_comma_names?name=in.Williams\"Hebdon, John\"" `shouldRespondWith`+ get "/w_or_wo_comma_names?name=in.(Williams\"Hebdon, John\")" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } describe "IN and NOT IN empty set" $ do context "returns an empty result for IN when no value is present" $ do it "works for integer" $- get "/items_with_different_col_types?int_data=in." `shouldRespondWith`+ get "/items_with_different_col_types?int_data=in.()" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "works for text" $- get "/items_with_different_col_types?text_data=in." `shouldRespondWith`+ get "/items_with_different_col_types?text_data=in.()" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "works for bool" $- get "/items_with_different_col_types?bool_data=in." `shouldRespondWith`+ get "/items_with_different_col_types?bool_data=in.()" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "works for bytea" $- get "/items_with_different_col_types?bin_data=in." `shouldRespondWith`+ get "/items_with_different_col_types?bin_data=in.()" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "works for char" $- get "/items_with_different_col_types?char_data=in." `shouldRespondWith`+ get "/items_with_different_col_types?char_data=in.()" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "works for date" $- get "/items_with_different_col_types?date_data=in." `shouldRespondWith`+ get "/items_with_different_col_types?date_data=in.()" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "works for real" $- get "/items_with_different_col_types?real_data=in." `shouldRespondWith`+ get "/items_with_different_col_types?real_data=in.()" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "works for time" $- get "/items_with_different_col_types?time_data=in." `shouldRespondWith`+ get "/items_with_different_col_types?time_data=in.()" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "returns all results for not.in when no value is present" $- get "/items_with_different_col_types?int_data=not.in.&select=int_data" `shouldRespondWith`+ get "/items_with_different_col_types?int_data=not.in.()&select=int_data" `shouldRespondWith` [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] } it "returns an empty result ignoring spaces" $- get "/items_with_different_col_types?int_data=in. " `shouldRespondWith`+ get "/items_with_different_col_types?int_data=in.( )" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "only returns an empty result set if the in value is empty" $- get "/items_with_different_col_types?int_data=in. ,3,4" `shouldRespondWith` 400-- it "returns empty result when the in value is empty between parentheses" $- get "/items_with_different_col_types?int_data=in.()" `shouldRespondWith`- [json| [] |] { matchHeaders = [matchContentTypeJson] }-- it "returns all results when the not.in value is empty between parentheses" $- get "/items_with_different_col_types?int_data=not.in.()&select=int_data" `shouldRespondWith`- [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }-- describe "Transition to url safe characters" $ do- context "top level in operator" $ do- it "works with parentheses" $- get "/entities?id=in.(1,2,3)&select=id" `shouldRespondWith`- [json| [{"id": 1}, {"id": 2}, {"id": 3}] |] { matchHeaders = [matchContentTypeJson] }- it "works without parentheses" $- get "/entities?id=in.1,2,3&select=id" `shouldRespondWith`- [json| [{"id": 1}, {"id": 2}, {"id": 3}] |] { matchHeaders = [matchContentTypeJson] }-- context "select query param" $ do- it "works with parentheses" $- get "/entities?id=eq.2&select=id,child_entities(id)" `shouldRespondWith`- [json| [{"id": 2, "child_entities": [{"id": 3}]}] |] { matchHeaders = [matchContentTypeJson] }- it "works with brackets" $- get "/entities?id=eq.2&select=id,child_entities{id}" `shouldRespondWith`- [json| [{"id": 2, "child_entities": [{"id": 3}]}] |] { matchHeaders = [matchContentTypeJson] }+ get "/items_with_different_col_types?int_data=in.( ,3,4)" `shouldRespondWith` 400 - context "Embedding when column name = table name" $ do+ describe "Embedding when column name = table name" $ do it "works with child embeds" $ get "/being?select=*,descendant(*)&limit=1" `shouldRespondWith` [json|[{"being":1,"descendant":[{"descendant":1,"being":1},{"descendant":2,"being":1},{"descendant":3,"being":1}]}]|]@@ -805,4 +984,14 @@ it "works with many to many embeds" $ get "/being?select=*,part(*)&limit=1" `shouldRespondWith` [json|[{"being":1,"part":[{"part":1}]}]|]+ { matchHeaders = [matchContentTypeJson] }++ describe "Foreign table" $ do+ it "can be queried by using regular filters" $+ get "/projects_dump?id=in.(1,2,3)" `shouldRespondWith`+ [json| [{"id":1,"name":"Windows 7","client_id":1}, {"id":2,"name":"Windows 10","client_id":1}, {"id":3,"name":"IOS","client_id":2}]|]+ { matchHeaders = [matchContentTypeJson] }+ it "can be queried with select, order and limit" $+ get "/projects_dump?select=id,name&order=id.desc&limit=3" `shouldRespondWith`+ [json| [{"id":5,"name":"Orphan"}, {"id":4,"name":"OSX"}, {"id":3,"name":"IOS"}] |] { matchHeaders = [matchContentTypeJson] }
test/Feature/RangeSpec.hs view
@@ -149,7 +149,7 @@ } 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=2&projects.tasks.order=id.asc&projects.tasks.limit=1"+ get "/clients?select=id,projects(id,tasks(id))&order=id.asc&limit=1&projects.order=id.asc&projects.limit=2&projects.tasks.order=id.asc&projects.tasks.limit=1" `shouldRespondWith` [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1}]},{"id":2,"tasks":[{"id":3}]}]}]|] { matchStatus = 200
test/Feature/RpcSpec.hs view
@@ -111,24 +111,24 @@ context "foreign entities embedding" $ do it "can embed if related tables are in the exposed schema" $ do- post "/rpc/getproject?select=id,name,client{id},tasks{id}" [json| { "id": 1} |] `shouldRespondWith`+ post "/rpc/getproject?select=id,name,client(id),tasks(id)" [json| { "id": 1} |] `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|] { matchHeaders = [matchContentTypeJson] }- get "/rpc/getproject?id=1&select=id,name,client{id},tasks{id}" `shouldRespondWith`+ get "/rpc/getproject?id=1&select=id,name,client(id),tasks(id)" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|] { matchHeaders = [matchContentTypeJson] } it "cannot embed if the related table is not in the exposed schema" $ do- post "/rpc/single_article?select=*,article_stars{*}" [json|{ "id": 1}|]+ post "/rpc/single_article?select=*,article_stars(*)" [json|{ "id": 1}|] `shouldRespondWith` 400- get "/rpc/single_article?id=1&select=*,article_stars{*}"+ get "/rpc/single_article?id=1&select=*,article_stars(*)" `shouldRespondWith` 400 it "can embed if the related tables are in a hidden schema but exposed as views" $ do- post "/rpc/single_article?select=id,articleStars{userId}" [json|{ "id": 2}|]+ post "/rpc/single_article?select=id,articleStars(userId)" [json|{ "id": 2}|] `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|] { matchHeaders = [matchContentTypeJson] }- get "/rpc/single_article?id=2&select=id,articleStars{userId}"+ get "/rpc/single_article?id=2&select=id,articleStars(userId)" `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|] { matchHeaders = [matchContentTypeJson] } @@ -275,9 +275,15 @@ [json|[{"my_json":{"a": 1, "b": "two"},"num":3,"str":"four"}]|] { matchHeaders = [matchContentTypeJson] } it "returns a row result when there are many INOUT params" $- get "/rpc/many_inout_params?num=1&str=two" `shouldRespondWith`- [json| [{"num":1,"str":"two","b":true}]|] { matchHeaders = [matchContentTypeJson] }+ get "/rpc/many_inout_params?num=1&str=two&b=false" `shouldRespondWith`+ [json| [{"num":1,"str":"two","b":false}]|] { matchHeaders = [matchContentTypeJson] } + it "can handle procs with args that have a DEFAULT value" $ do+ get "/rpc/many_inout_params?num=1&str=two" `shouldRespondWith`+ [json| [{"num":1,"str":"two","b":true}]|] { matchHeaders = [matchContentTypeJson] }+ get "/rpc/three_defaults?b=4" `shouldRespondWith`+ [json|8|] { matchHeaders = [matchContentTypeJson] }+ it "can map a RAISE error code and message to a http status" $ get "/rpc/raise_pt402" `shouldRespondWith` [json|{ "hint": "Upgrade your plan", "details": "Quota exceeded" }|]@@ -288,23 +294,42 @@ it "defaults to status 500 if RAISE code is PT not followed by a number" $ get "/rpc/raise_bad_pt" `shouldRespondWith` 500 - context "only for POST rpc" $ do- context "expects a single json object" $ do- it "does not expand posted json into parameters" $- request methodPost "/rpc/singlejsonparam"- [("Prefer","params=single-object")] [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] `shouldRespondWith`- [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |]- { matchHeaders = [matchContentTypeJson] }+ context "expects a single json object" $ do+ it "does not expand posted json into parameters" $+ request methodPost "/rpc/singlejsonparam"+ [("prefer","params=single-object")] [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] `shouldRespondWith`+ [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |]+ { matchHeaders = [matchContentTypeJson] } - it "accepts parameters from an html form" $- request methodPost "/rpc/singlejsonparam"- [("Prefer","params=single-object"),("Content-Type", "application/x-www-form-urlencoded")]- ("integer=7&double=2.71828&varchar=forms+are+fun&" <>- "boolean=false&date=1900-01-01&money=$3.99&enum=foo") `shouldRespondWith`- [json| { "integer": "7", "double": "2.71828", "varchar" : "forms are fun"- , "boolean":"false", "date":"1900-01-01", "money":"$3.99", "enum":"foo" } |]- { matchHeaders = [matchContentTypeJson] }+ it "accepts parameters from an html form" $+ request methodPost "/rpc/singlejsonparam"+ [("Prefer","params=single-object"),("Content-Type", "application/x-www-form-urlencoded")]+ ("integer=7&double=2.71828&varchar=forms+are+fun&" <>+ "boolean=false&date=1900-01-01&money=$3.99&enum=foo") `shouldRespondWith`+ [json| { "integer": "7", "double": "2.71828", "varchar" : "forms are fun"+ , "boolean":"false", "date":"1900-01-01", "money":"$3.99", "enum":"foo" } |]+ { matchHeaders = [matchContentTypeJson] } + it "works with GET" $+ request methodGet "/rpc/singlejsonparam?p1=1&p2=text" [("Prefer","params=single-object")] ""+ `shouldRespondWith` [json|{ "p1": "1", "p2": "text"}|]+ { matchHeaders = [matchContentTypeJson] }++ it "should work with an overloaded function" $ do+ get "/rpc/overloaded" `shouldRespondWith`+ [json|[{ "overloaded": 1 },+ { "overloaded": 2 },+ { "overloaded": 3 }]|]+ { matchHeaders = [matchContentTypeJson] }+ request methodPost "/rpc/overloaded" [("Prefer","params=single-object")]+ [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]+ `shouldRespondWith`+ [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]+ { matchHeaders = [matchContentTypeJson] }+ get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|]+ get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [str|"123"|]++ context "only for POST rpc" $ it "gives a parse filter error if GET style proc args are specified" $ post "/rpc/sayhello?name=John" [json|{}|] `shouldRespondWith` 400 @@ -334,12 +359,5 @@ [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|] { matchHeaders = [matchContentTypeJson] } get "/rpc/get_tsearch?text_search_vector=not.fts(english).fun%7Crat" `shouldRespondWith`- [json|[{"text_search_vector":"'amus':5 'fair':7 'impossibl':9 'peu':4"},{"text_search_vector":"'art':4 'spass':5 'unmog':7"}]|]- { matchHeaders = [matchContentTypeJson] }- -- TODO: '@@' deprecated- get "/rpc/get_tsearch?text_search_vector=@@(english).impossible" `shouldRespondWith`- [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|]- { matchHeaders = [matchContentTypeJson] }- get "/rpc/get_tsearch?text_search_vector=not.@@(english).fun%7Crat" `shouldRespondWith` [json|[{"text_search_vector":"'amus':5 'fair':7 'impossibl':9 'peu':4"},{"text_search_vector":"'art':4 'spass':5 'unmog':7"}]|] { matchHeaders = [matchContentTypeJson] }
test/Feature/SingularSpec.hs view
@@ -37,7 +37,7 @@ `shouldRespondWith` [str|{"id":5}|] it "can shape plurality singular object routes" $- request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [singular] ""+ request methodGet "/projects_view?id=eq.1&select=id,name,clients(*),tasks(id,name)" [singular] "" `shouldRespondWith` [json|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|] { matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] }
test/Feature/StructureSpec.hs view
@@ -29,12 +29,12 @@ (acceptHdrs "application/openapi+json") "" `shouldRespondWith` 415 - it "includes postgrest.com current version api docs" $ do+ it "includes postgrest.org current version api docs" $ do r <- simpleBody <$> get "/" let docsUrl = r ^? key "externalDocs" . key "url" - liftIO $ docsUrl `shouldBe` Just (String ("https://postgrest.com/en/" <> docsVersion <> "/api.html"))+ liftIO $ docsUrl `shouldBe` Just (String ("https://postgrest.org/en/" <> docsVersion <> "/api.html")) describe "table" $ do @@ -131,6 +131,38 @@ . nth 0 liftIO $ tableTag `shouldBe` Just [aesonQQ|"authors_only"|] + describe "Foreign table" $++ it "includes foreign table properties" $ do+ r <- simpleBody <$> get "/"++ let method s = key "paths" . key "/projects_dump" . key s+ getSummary = r ^? method "get" . key "summary"+ getDescription = r ^? method "get" . key "description"+ getParameters = r ^? method "get" . key "parameters"++ liftIO $ do++ getSummary `shouldBe` Just "A temporary projects dump"++ getDescription `shouldBe` Just "Just a test for foreign tables"++ getParameters `shouldBe` Just+ [aesonQQ|+ [+ { "$ref": "#/parameters/rowFilter.projects_dump.id" },+ { "$ref": "#/parameters/rowFilter.projects_dump.name" },+ { "$ref": "#/parameters/rowFilter.projects_dump.client_id" },+ { "$ref": "#/parameters/select" },+ { "$ref": "#/parameters/order" },+ { "$ref": "#/parameters/range" },+ { "$ref": "#/parameters/rangeUnit" },+ { "$ref": "#/parameters/offset" },+ { "$ref": "#/parameters/limit" },+ { "$ref": "#/parameters/preferCount" }+ ]+ |]+ describe "RPC" $ do it "includes body schema for arguments" $ do@@ -173,7 +205,7 @@ "type": "string" }, "enum": {- "format": "test.enum_menagerie_type",+ "format": "enum_menagerie_type", "type": "string" }, "integer": {
+ test/Feature/UpsertSpec.hs view
@@ -0,0 +1,200 @@+module Feature.UpsertSpec where++import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON+import Network.HTTP.Types++import SpecHelper+import Network.Wai (Application)++import Protolude hiding (get, put)+import Text.Heredoc++spec :: SpecWith Application+spec =+ describe "UPSERT" $ do+ context "with POST" $ do+ context "when Prefer: resolution=merge-duplicates is specified" $ do+ it "INSERTs and UPDATEs rows on pk conflict" $+ request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]+ [json| [+ { "name": "Javascript", "rank": 6 },+ { "name": "Java", "rank": 2 },+ { "name": "C", "rank": 1 }+ ]|] `shouldRespondWith` [json| [+ { "name": "Javascript", "rank": 6 },+ { "name": "Java", "rank": 2 },+ { "name": "C", "rank": 1 }+ ]|]+ { matchStatus = 201+ , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson]+ }++ it "INSERTs and UPDATEs row on composite pk conflict" $+ request methodPost "/employees" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]+ [json| [+ { "first_name": "Frances M.", "last_name": "Roe", "salary": "30000" },+ { "first_name": "Peter S.", "last_name": "Yang", "salary": 42000 }+ ]|] `shouldRespondWith` [json| [+ { "first_name": "Frances M.", "last_name": "Roe", "salary": "$30,000.00", "company": "One-Up Realty", "occupation": "Author" },+ { "first_name": "Peter S.", "last_name": "Yang", "salary": "$42,000.00", "company": null, "occupation": null }+ ]|]+ { matchStatus = 201+ , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson]+ }++ context "when Prefer: resolution=ignore-duplicates is specified" $ do+ it "INSERTs and ignores rows on pk conflict" $+ request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]+ [json|[+ { "name": "PHP", "rank": 9 },+ { "name": "Python", "rank": 10 }+ ]|] `shouldRespondWith` [json|[+ { "name": "PHP", "rank": 9 }+ ]|]+ { matchStatus = 201+ , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson]+ }++ it "INSERTs and ignores rows on composite pk conflict" $+ request methodPost "/employees" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]+ [json|[+ { "first_name": "Daniel B.", "last_name": "Lyon", "salary": "72000", "company": null, "occupation": null },+ { "first_name": "Sara M.", "last_name": "Torpey", "salary": 60000, "company": "Burstein-Applebee", "occupation": "Soil scientist" }+ ]|] `shouldRespondWith` [json|[+ { "first_name": "Sara M.", "last_name": "Torpey", "salary": "$60,000.00", "company": "Burstein-Applebee", "occupation": "Soil scientist" }+ ]|]+ { matchStatus = 201+ , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson]+ }++ it "succeeds if the table has only PK cols and no other cols" $ do+ request methodPost "/only_pk" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]+ [json|[ { "id": 1 }, { "id": 2 }, { "id": 3} ]|]+ `shouldRespondWith`+ [json|[ { "id": 3} ]|]+ { matchStatus = 201 ,+ matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates",+ matchContentTypeJson] }++ request methodPost "/only_pk" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]+ [json|[ { "id": 1 }, { "id": 2 }, { "id": 4} ]|]+ `shouldRespondWith`+ [json|[ { "id": 1 }, { "id": 2 }, { "id": 4} ]|]+ { matchStatus = 201 ,+ matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates",+ matchContentTypeJson] }++ it "succeeds and ignores the Prefer: resolution header(no Preference-Applied present) if the table has no PK" $+ request methodPost "/no_pk" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")]+ [json|[ { "a": "1", "b": "0" } ]|]+ `shouldRespondWith`+ [json|[ { "a": "1", "b": "0" } ]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] }++ it "succeeds if not a single resource is created" $ do+ request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]+ [json|[ { "name": "Java", "rank": 1 } ]|] `shouldRespondWith`+ [json|[]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] }+ request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")]+ [json|[ { "name": "Java", "rank": 1 }, { "name": "C", "rank": 2 } ]|] `shouldRespondWith`+ [json|[]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] }++ context "with PUT" $ do+ context "Restrictions" $ do+ it "fails if Range is specified" $+ request methodPut "/tiobe_pls?name=eq.Javascript" [("Range", "0-5")]+ [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400++ it "fails if limit is specified" $+ put "/tiobe_pls?name=eq.Javascript&limit=1"+ [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400++ it "fails if offset is specified" $+ put "/tiobe_pls?name=eq.Javascript&offset=1"+ [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400++ it "fails if the payload has more than one row" $+ put "/tiobe_pls?name=eq.Go"+ [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ]|] `shouldRespondWith` 400++ it "fails if not all columns are specified" $ do+ put "/tiobe_pls?name=eq.Go"+ [str| [ { "name": "Go" } ]|] `shouldRespondWith` 400+ put "/employees?first_name=eq.Susan&last_name=eq.Heidt"+ [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000" } ]|] `shouldRespondWith` 400++ it "rejects every other filter than pk cols eq's" $ do+ put "/tiobe_pls?rank=eq.19" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405+ put "/tiobe_pls?id=not.eq.Java" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405+ put "/tiobe_pls?id=in.(Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405+ put "/tiobe_pls?and=(id.eq.Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405++ it "fails if not all composite key cols are specified as eq filters" $ do+ put "/employees?first_name=eq.Susan"+ [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]+ `shouldRespondWith` 405+ put "/employees?last_name=eq.Heidt"+ [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]+ `shouldRespondWith` 405++ it "fails if the uri primary key doesn't match the payload primary key" $ do+ put "/tiobe_pls?name=eq.MATLAB"+ [str| [ { "name": "Perl", "rank": 17 } ]|] `shouldRespondWith` 400+ put "/employees?first_name=eq.Wendy&last_name=eq.Anderson"+ [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] `shouldRespondWith` 400++ it "fails if the table has no PK" $+ put "/no_pk?a=eq.one&b=eq.two" [str| [ { "a": "one", "b": "two" } ]|] `shouldRespondWith` 405++ context "Inserting row" $ do+ it "succeeds on table with single pk col" $ do+ get "/tiobe_pls?name=eq.Go" `shouldRespondWith` "[]"+ put "/tiobe_pls?name=eq.Go" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 204+ get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json| [ { "name": "Go", "rank": 19 } ]|] { matchHeaders = [matchContentTypeJson] }++ it "succeeds on table with composite pk" $ do+ get "/employees?first_name=eq.Susan&last_name=eq.Heidt"+ `shouldRespondWith` "[]"+ put "/employees?first_name=eq.Susan&last_name=eq.Heidt"+ [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]+ `shouldRespondWith` 204+ get "/employees?first_name=eq.Susan&last_name=eq.Heidt"+ `shouldRespondWith`+ [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$48,000.00", "company": "GEX", "occupation": "Railroad engineer" } ]|]+ { matchHeaders = [matchContentTypeJson] }++ it "succeeds if the table has only PK cols and no other cols" $ do+ get "/only_pk?id=eq.10" `shouldRespondWith` "[]"+ put "/only_pk?id=eq.10" [str|[ { "id": 10 } ]|] `shouldRespondWith` 204+ get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] }++ context "Updating row" $ do+ it "succeeds on table with single pk col" $ do+ get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json|[ { "name": "Go", "rank": 19 } ]|] { matchHeaders = [matchContentTypeJson] }+ put "/tiobe_pls?name=eq.Go" [str| [ { "name": "Go", "rank": 13 } ]|] `shouldRespondWith` 204+ get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json| [ { "name": "Go", "rank": 13 } ]|] { matchHeaders = [matchContentTypeJson] }++ it "succeeds on table with composite pk" $ do+ get "/employees?first_name=eq.Susan&last_name=eq.Heidt"+ `shouldRespondWith`+ [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$48,000.00", "company": "GEX", "occupation": "Railroad engineer" } ]|]+ { matchHeaders = [matchContentTypeJson] }+ put "/employees?first_name=eq.Susan&last_name=eq.Heidt"+ [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "60000", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|]+ `shouldRespondWith` 204+ get "/employees?first_name=eq.Susan&last_name=eq.Heidt"+ `shouldRespondWith`+ [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$60,000.00", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|]+ { matchHeaders = [matchContentTypeJson] }++ it "succeeds if the table has only PK cols and no other cols" $ do+ get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] }+ put "/only_pk?id=eq.10" [str|[ { "id": 10 } ]|] `shouldRespondWith` 204+ get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] }++ it "works with return=representation and vnd.pgrst.object+json" $+ request methodPut "/tiobe_pls?name=eq.Ruby"+ [("Prefer", "return=representation"), ("Accept", "application/vnd.pgrst.object+json")]+ [str| [ { "name": "Ruby", "rank": 11 } ]|]+ `shouldRespondWith` [json|{ "name": "Ruby", "rank": 11 }|] { matchHeaders = [matchContentTypeSingular] }
test/Main.hs view
@@ -6,11 +6,13 @@ import qualified Hasql.Pool as P import PostgREST.App (postgrest)-import PostgREST.Config (pgVersion96)-import PostgREST.DbStructure (getDbStructure, getPgVersion)+import PostgREST.Config (pgVersion95, pgVersion96, configSettings)+import PostgREST.DbStructure (getDbStructure, getPgVersion, fillSessionWithSettings) import PostgREST.Types (DbStructure(..))+import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction) import Data.Function (id) import Data.IORef+import Data.Time.Clock (getCurrentTime) import qualified Feature.AuthSpec import qualified Feature.AsymmetricJwtSpec@@ -32,6 +34,7 @@ import qualified Feature.RpcSpec import qualified Feature.NonexistentSchemaSpec import qualified Feature.PgVersion96Spec+import qualified Feature.UpsertSpec import Protolude @@ -46,22 +49,27 @@ dbStructure <- pure $ either (panic.show) id result + getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }+ refDbStructure <- newIORef $ Just dbStructure - let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool $ pure ()- ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool $ pure ()- unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool $ pure ()- proxyApp = return $ postgrest (testProxyCfg testDbConn) refDbStructure pool $ pure ()- noJwtApp = return $ postgrest (testCfgNoJWT testDbConn) refDbStructure pool $ pure ()- binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool $ pure ()- audJwtApp = return $ postgrest (testCfgAudienceJWT testDbConn) refDbStructure pool $ pure ()- asymJwkApp = return $ postgrest (testCfgAsymJWK testDbConn) refDbStructure pool $ pure ()- nonexistentSchemaApp = return $ postgrest (testNonexistentSchemaCfg testDbConn) refDbStructure pool $ pure ()+ let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool getTime $ pure ()+ ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool getTime $ pure ()+ unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool getTime $ pure ()+ proxyApp = return $ postgrest (testProxyCfg testDbConn) refDbStructure pool getTime $ pure ()+ noJwtApp = return $ postgrest (testCfgNoJWT testDbConn) refDbStructure pool getTime $ pure ()+ binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime $ pure ()+ audJwtApp = return $ postgrest (testCfgAudienceJWT testDbConn) refDbStructure pool getTime $ pure ()+ asymJwkApp = return $ postgrest (testCfgAsymJWK testDbConn) refDbStructure pool getTime $ pure ()+ nonexistentSchemaApp = return $ postgrest (testNonexistentSchemaCfg testDbConn) refDbStructure pool getTime $ pure () - let reset = resetDb testDbConn+ let reset :: IO ()+ reset = P.use pool (fillSessionWithSettings (configSettings $ testCfg testDbConn)) >> resetDb testDbConn+ actualPgVersion = pgVersion dbStructure- pg96spec | actualPgVersion >= pgVersion96 = [("Feature.PgVersion96Spec" , Feature.PgVersion96Spec.spec)]- | otherwise = []+ extraSpecs =+ [("Feature.UpsertSpec", Feature.UpsertSpec.spec) | actualPgVersion >= pgVersion95] +++ [("Feature.PgVersion96Spec", Feature.PgVersion96Spec.spec) | actualPgVersion >= pgVersion96] specs = uncurry describe <$> [ ("Feature.AuthSpec" , Feature.AuthSpec.spec)@@ -76,7 +84,7 @@ , ("Feature.StructureSpec" , Feature.StructureSpec.spec) , ("Feature.AndOrParamsSpec" , Feature.AndOrParamsSpec.spec) , ("Feature.NonexistentSchemaSpec" , Feature.NonexistentSchemaSpec.spec)- ] ++ pg96spec+ ] ++ extraSpecs hspec $ do mapM_ (beforeAll_ reset . before withApp) specs
test/SpecHelper.hs view
@@ -17,6 +17,7 @@ import Text.Heredoc import PostgREST.Config (AppConfig(..))+import PostgREST.Types (JSPathExp(..)) import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai@@ -73,6 +74,11 @@ 10 Nothing (Just "test.switch_role") -- Debug Settings True+ [ ("app.settings.app_host", "localhost")+ , ("app.settings.external_api_secret", "0123456789abcdef")+ ]+ -- Default role claim key+ (Right [JSPKey "role"]) testCfg :: Text -> AppConfig testCfg testDbConn = _baseCfg { configDatabase = testDbConn }