postgrest 0.4.2.0 → 0.4.3.0
raw patch · 23 files changed
+1006/−582 lines, 23 filesdep +josedep −auto-updatedep −jwtdep −timedep ~hjsonschemadep ~optparse-applicativedep ~protolude
Dependencies added: jose
Dependencies removed: auto-update, jwt, time
Dependency ranges changed: hjsonschema, optparse-applicative, protolude
Files
- main/Main.hs +175/−75
- postgrest.cabal +8/−11
- src/PostgREST/App.hs +29/−22
- src/PostgREST/Auth.hs +51/−39
- src/PostgREST/Config.hs +9/−4
- src/PostgREST/DbRequestBuilder.hs +71/−33
- src/PostgREST/DbStructure.hs +45/−13
- src/PostgREST/Error.hs +13/−9
- src/PostgREST/Middleware.hs +11/−13
- src/PostgREST/OpenAPI.hs +152/−149
- src/PostgREST/Parsers.hs +19/−17
- src/PostgREST/QueryBuilder.hs +53/−54
- src/PostgREST/Types.hs +50/−56
- test/Feature/AndOrParamsSpec.hs +74/−15
- test/Feature/AsymmetricJwtSpec.hs +21/−0
- test/Feature/AuthSpec.hs +17/−17
- test/Feature/BinaryJwtSecretSpec.hs +1/−1
- test/Feature/InsertSpec.hs +2/−2
- test/Feature/NoJwtSpec.hs +1/−1
- test/Feature/QuerySpec.hs +94/−27
- test/Feature/StructureSpec.hs +86/−8
- test/Main.hs +12/−12
- test/SpecHelper.hs +12/−4
main/Main.hs view
@@ -2,39 +2,46 @@ module Main where -import Protolude-import PostgREST.App-import PostgREST.Config (AppConfig (..),- PgVersion (..),- minimumPgVersion,- prettyVersion,- readOptions)-import PostgREST.Error (encodeError)-import PostgREST.OpenAPI (isMalformedProxyUri)-import PostgREST.DbStructure-import PostgREST.Types (DbStructure, Schema)+import PostgREST.App (postgrest)+import PostgREST.Config (AppConfig (..),+ PgVersion (..),+ minimumPgVersion,+ prettyVersion, readOptions)+import PostgREST.DbStructure (getDbStructure)+import PostgREST.Error (encodeError)+import PostgREST.OpenAPI (isMalformedProxyUri)+import PostgREST.Types (DbStructure, Schema)+import Protolude hiding (replace, hPutStrLn) -import Control.AutoUpdate-import Control.Retry-import Data.ByteString.Base64 (decode)-import Data.String (IsString (..))-import Data.Text (stripPrefix, pack, replace)-import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import Data.Text.IO (hPutStrLn, readFile)-import Data.Time.Clock.POSIX (getPOSIXTime)-import qualified Hasql.Query as H-import qualified Hasql.Session as H-import qualified Hasql.Decoders as HD-import qualified Hasql.Encoders as HE-import qualified Hasql.Pool as P-import Network.Wai.Handler.Warp-import System.IO (BufferMode (..),- hSetBuffering)-import Data.IORef+import Control.Retry (RetryStatus, capDelay,+ exponentialBackoff,+ retrying, rsPreviousDelay)+import Data.ByteString.Base64 (decode)+import Data.IORef (IORef, atomicWriteIORef,+ newIORef, readIORef)+import Data.String (IsString (..))+import Data.Text (pack, replace, stripPrefix, strip)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Text.IO (hPutStrLn, readFile)+import qualified Hasql.Decoders as HD+import qualified Hasql.Encoders as HE+import qualified Hasql.Pool as P+import qualified Hasql.Query as H+import qualified Hasql.Session as H+import Network.Wai.Handler.Warp (defaultSettings,+ runSettings, setHost,+ setPort, setServerName,+ setTimeout)+import System.IO (BufferMode (..),+ hSetBuffering) #ifndef mingw32_HOST_OS import System.Posix.Signals #endif +{-|+ Used by connectionWorker to know if it should throw an error and kill the+ main thread.+-} isServerVersionSupported :: H.Session Bool isServerVersionSupported = do ver <- H.query () pgVersion@@ -45,14 +52,30 @@ HE.unit (HD.singleRow $ HD.value HD.int4) False {-|+ The purpose of this worker is to fill the refDbStructure created in 'main'+ with the 'DbStructure' returned from calling 'getDbStructure'. This method+ is meant to be called by multiple times by the same thread, but does nothing if+ the previous invocation has not terminated. In all cases this method does not+ halt the calling thread, the work is preformed in a separate thread.++ Note: 'atomicWriteIORef' is essentially a lazy semaphore that prevents two+ threads from running 'connectionWorker' at the same time.+ Background thread that does the following : 1. Tries to connect to pg server and will keep trying until success.- 2. Checks if the pg version is supported and if it's not it kills the main program.+ 2. Checks if the pg version is supported and if it's not it kills the main+ program. 3. Obtains the dbStructure.- 4. If 2 or 3 fail to give their result it means the connection is down so it goes back to 1,- otherwise it finishes his work successfully.+ 4. If 2 or 3 fail to give their result it means the connection is down so it+ goes back to 1, otherwise it finishes his work successfully. -}-connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IORef Bool -> IO ()+connectionWorker+ :: ThreadId -- ^ This thread is killed if 'isServerVersionSupported' returns false+ -> P.Pool -- ^ The PostgreSQL connection pool+ -> Schema -- ^ Schema PostgREST is serving up+ -> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure'+ -> IORef Bool -- ^ Used as a binary Semaphore+ -> IO () connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do isWorkerOn <- readIORef refIsWorkerOn unless isWorkerOn $ do@@ -82,7 +105,16 @@ atomicWriteIORef refIsWorkerOn False putStrLn ("Connection successful" :: Text) --- | Connect to pg server if it fails retry with capped exponential backoff until success++{-|+ Used by 'connectionWorker' to check if the provided db-uri lets+ the application access the PostgreSQL database. This method is used+ the first time the connection is tested, but only to test before+ calling 'getDbStructure' inside the 'connectionWorker' method.++ The connection tries are capped, but if the connection times out no error is+ thrown, just 'False' is returned.+-} connectingSucceeded :: P.Pool -> IO Bool connectingSucceeded pool = retrying (capDelay 32000000 $ exponentialBackoff 1000000)@@ -103,39 +135,70 @@ putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..." return itShould +{-|+ This is where everything starts.+-} main :: IO () main = do+ --+ -- LineBuffering: the entire output buffer is flushed whenever a newline is+ -- output, the buffer overflows, a hFlush is issued or the handle is closed+ --+ -- NoBuffering: output is written immediately and never stored in the buffer hSetBuffering stdout LineBuffering- hSetBuffering stdin LineBuffering+ hSetBuffering stdin LineBuffering hSetBuffering stderr NoBuffering-+ --+ -- readOptions builds the 'AppConfig' from the config file specified on the+ -- command line conf <- loadSecretFile =<< readOptions let host = configHost conf port = configPort conf proxy = configProxyUri conf- pgSettings = toS (configDatabase conf)- appSettings = setHost ((fromString . toS) host)- . setPort port- . setServerName (toS $ "postgrest/" <> prettyVersion)- . setTimeout 3600- $ defaultSettings-- when (isMalformedProxyUri $ toS <$> proxy) $ panic- "Malformed proxy uri, a correct example: https://example.com:8443/basePath"-+ pgSettings = toS (configDatabase conf) -- is the db-uri+ 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.+ when (isMalformedProxyUri $ toS <$> proxy) $+ panic+ "Malformed proxy uri, a correct example: https://example.com:8443/basePath" putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)-+ --+ -- create connection pool with the provided settings, returns either+ -- a 'Connection' or a 'ConnectionError'. Does not throw. pool <- P.acquire (configPool conf, 10, pgSettings)-+ --+ -- To be filled in by connectionWorker refDbStructure <- newIORef Nothing-+ -- -- Helper ref to make sure just one connectionWorker can run at a time refIsWorkerOn <- newIORef False-+ --+ -- This is passed to the connectionWorker method so it can kill the main+ -- thread if the PostgreSQL's version is not supported. mainTid <- myThreadId-- connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn-+ --+ -- Sets the refDbStructure+ connectionWorker+ mainTid+ pool+ (configSchema conf)+ refDbStructure+ refIsWorkerOn+ --+ -- Only for systems with signals:+ --+ -- releases the connection pool whenever the program is terminated,+ -- see issue #268+ --+ -- Plus the SIGHUP signal updates the internal 'DbStructure' by running+ -- 'connectionWorker' exactly as before. #ifndef mingw32_HOST_OS forM_ [sigINT, sigTERM] $ \sig -> void $ installHandler sig (Catch $ do@@ -144,38 +207,75 @@ ) Nothing void $ installHandler sigHUP (- Catch $ connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn- ) Nothing+ Catch $ connectionWorker+ mainTid+ pool+ (configSchema conf)+ refDbStructure+ refIsWorkerOn+ ) Nothing #endif - -- ask for the OS time at most once per second- getTime <- mkAutoUpdate- defaultUpdateSettings { updateAction = getPOSIXTime }+ --+ -- run the postgrest application+ runSettings appSettings $+ postgrest+ conf+ refDbStructure+ pool+ (connectionWorker+ mainTid+ pool+ (configSchema conf)+ refDbStructure+ refIsWorkerOn) - runSettings appSettings $ postgrest conf refDbStructure pool getTime- (connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn)+{-|+ The purpose of this function is to load the JWT secret from a file if+ configJwtSecret is actually a filepath and replaces some characters if the JWT+ is base64 encoded. + The reason some characters need to be replaced is because JWT is actually+ base64url encoded which must be turned into just base64 before decoding.++ To check if the JWT secret is provided is in fact a file path, it must be+ decoded as 'Text' to be processed.++ decodeUtf8: Decode a ByteString containing UTF-8 encoded text that is known to+ be valid.+-} loadSecretFile :: AppConfig -> IO AppConfig loadSecretFile conf = extractAndTransform mSecret where- mSecret = decodeUtf8 <$> configJwtSecret conf- isB64 = configJwtSecretIsBase64 conf-+ mSecret = decodeUtf8 <$> configJwtSecret conf+ isB64 = configJwtSecretIsBase64 conf+ --+ -- The Text (variable name secret) here is mSecret from above which is the JWT+ -- decoded as Utf8+ --+ -- stripPrefix: Return the suffix of the second string if its prefix matches+ -- the entire first string.+ --+ -- The configJwtSecret is a filepath instead of the JWT secret itself if the+ -- secret has @ as its prefix. extractAndTransform :: Maybe Text -> IO AppConfig- extractAndTransform Nothing = return conf- extractAndTransform (Just s) =- fmap setSecret $ transformString isB64 =<<- case stripPrefix "@" s of- Nothing -> return s- Just filename -> readFile (toS filename)-+ extractAndTransform Nothing = return conf+ extractAndTransform (Just secret) =+ fmap setSecret $+ transformString isB64 =<<+ case stripPrefix "@" secret of+ Nothing -> return secret+ Just filename -> readFile (toS filename)+ --+ -- Turns the Base64url encoded JWT into Base64 transformString :: Bool -> Text -> IO ByteString transformString False t = return . encodeUtf8 $ t- transformString True t =- case decode (encodeUtf8 $ replaceUrlChars t) of+ transformString True t =+ case decode (encodeUtf8 $ strip $ replaceUrlChars t) of Left errMsg -> panic $ pack errMsg Right bs -> return bs-- setSecret bs = conf { configJwtSecret = Just bs }-- replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="+ setSecret bs = conf {configJwtSecret = Just bs}+ --+ -- replace: Replace every occurrence of one substring with another+ replaceUrlChars =+ replace "_" "/" . replace "-" "+" . replace "." "="
postgrest.cabal view
@@ -2,7 +2,7 @@ description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security permits.-version: 0.4.2.0+version: 0.4.3.0 synopsis: REST API for any Postgres database license: MIT license-file: LICENSE@@ -29,14 +29,12 @@ -rtsopts "-with-rtsopts=-N -I2" default-language: Haskell2010- build-depends: auto-update- , base+ build-depends: base , hasql , hasql-pool , postgrest , protolude , text- , time , warp , bytestring , base64-bytestring@@ -52,6 +50,7 @@ build-depends: aeson , ansi-wl-pprint , base >= 4.8 && < 6+ , base64-bytestring , bytestring , case-insensitive , cassava@@ -67,20 +66,19 @@ , http-types , insert-ordered-containers , interpolatedstring-perl6- , jwt+ , jose , lens , lens-aeson , network-uri- , optparse-applicative >= 0.13 && < 0.14+ , optparse-applicative >= 0.13 && < 0.15 , parsec- , protolude+ , protolude >= 0.2 , Ranged-sets == 0.3.0 , regex-tdfa , safe , scientific , swagger2 , text- , time , unordered-containers , vector , wai@@ -113,6 +111,7 @@ Hs-Source-Dirs: test Main-Is: Main.hs Other-Modules: Feature.AuthSpec+ , Feature.AsymmetricJwtSpec , Feature.BinaryJwtSecretSpec , Feature.ConcurrentSpec , Feature.CorsSpec@@ -132,7 +131,6 @@ Build-Depends: aeson , aeson-qq , async- , auto-update , base , bytestring , base64-bytestring@@ -144,7 +142,7 @@ , hasql-pool , heredoc , hjsonpointer- , hjsonschema+ , hjsonschema == 1.5.0.1 , hspec , hspec-wai >= 0.7.0 , hspec-wai-json@@ -156,7 +154,6 @@ , process , protolude , regex-tdfa- , time , transformers-base , wai , wai-extra
src/PostgREST/App.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}---module PostgREST.App where+ module PostgREST.App ( postgrest ) where@@ -11,7 +10,6 @@ import Data.Maybe import Data.IORef (IORef, readIORef) import Data.Text (intercalate)-import Data.Time.Clock.POSIX (POSIXTime) import qualified Hasql.Pool as P import qualified Hasql.Transaction as HT@@ -22,7 +20,6 @@ import Network.HTTP.Types.URI (renderSimpleQuery) import Network.Wai import Network.Wai.Middleware.RequestLogger (logStdout)-import Web.JWT (binarySecret) import qualified Data.Vector as V import qualified Hasql.Transaction as H@@ -35,7 +32,7 @@ , mutuallyAgreeable , userApiRequest )-import PostgREST.Auth (jwtClaims, containsRole)+import PostgREST.Auth (jwtClaims, containsRole, parseJWK) import PostgREST.Config (AppConfig (..)) import PostgREST.DbStructure import PostgREST.DbRequestBuilder( readRequest@@ -63,13 +60,12 @@ import Protolude hiding (intercalate, Proxy) import Safe (headMay) -postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO POSIXTime ->- IO () -> Application-postgrest conf refDbStructure pool getTime worker =- let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in+postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO () -> Application+postgrest conf refDbStructure pool 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@@ -78,9 +74,9 @@ response <- case userApiRequest (configSchema conf) req body of Left err -> return $ apiRequestError err Right apiRequest -> do- let jwtSecret = binarySecret <$> configJwtSecret conf- eClaims = jwtClaims jwtSecret (iJWT apiRequest) time- authed = containsRole eClaims+ eClaims <- jwtClaims jwtSecret (toS $ iJWT apiRequest)++ let authed = containsRole eClaims handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest txMode = transactionMode dbStructure (iTarget apiRequest) (iAction apiRequest)@@ -232,15 +228,25 @@ return $ responseLBS status200 [allOrigins, acceptH] "" (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->- case readSqlParts of+ let proc = M.lookup (qiName qi) allProcs+ returnsScalar = case proc of+ Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True+ _ -> False+ rpcBinaryField = if returnsScalar+ then Right Nothing+ else binaryField contentType =<< fldNames+ partsField = (,) <$> readSqlParts <*> rpcBinaryField in+ case partsField of Left errorResponse -> return errorResponse- Right (q, cq) -> do+ Right ((q, cq), bField) -> do let p = V.head payload singular = contentType == CTSingularJSON paramsAsSingleObject = iPreferSingleObjectParameter apiRequest row <- H.query () $- callProc qi p q cq topLevelRange shouldCount singular- paramsAsSingleObject (contentType == CTTextCSV)+ callProc qi p returnsScalar q cq topLevelRange shouldCount+ singular paramsAsSingleObject+ (contentType == CTTextCSV)+ (contentType == CTOctetStream) bField let (tableTotal, queryTotal, body) = fromMaybe (Just 0, 0, "[]") row (status, contentRange) = rangeHeader queryTotal tableTotal@@ -257,8 +263,8 @@ uri Nothing = ("http", host, port, "/") uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) uri' = uri proxy- encodeApi ti = encodeOpenAPI (M.elems $ dbProcs dbStructure) ti uri'- body <- encodeApi . toTableInfo <$> H.query schema accessibleTables+ encodeApi ti sd = encodeOpenAPI (M.elems allProcs) (toTableInfo ti) uri' sd (dbPrimaryKeys dbStructure)+ body <- encodeApi <$> H.query schema accessibleTables <*> H.query schema schemaDescription return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body _ -> return notFound@@ -276,6 +282,7 @@ 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@@ -287,7 +294,7 @@ status = rangeStatus lower upper (toInteger <$> tableTotal) in (status, contentRange) - readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) (dbProcs dbStructure) apiRequest+ readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) allProcs apiRequest fldNames = fieldNames <$> readReq readDbRequest = DbRead <$> readReq mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< fldNames)@@ -306,14 +313,14 @@ ActionCreate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] ActionUpdate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] ActionDelete -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]- ActionInvoke -> [CTApplicationJSON, CTSingularJSON, CTTextCSV]+ ActionInvoke -> [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream] ActionInspect -> [CTOpenAPI, CTApplicationJSON] ActionInfo -> [CTTextCSV] serves sProduces cAccepts = case mutuallyAgreeable sProduces cAccepts of Nothing -> do let failed = intercalate ", " $ map (toS . toMime) cAccepts- Left $ simpleError status415 $+ Left $ simpleError status415 [] $ "None of these Content-Types are available: " <> failed Just ct -> Right ct
src/PostgREST/Auth.hs view
@@ -14,63 +14,48 @@ module PostgREST.Auth ( containsRole , jwtClaims- , tokenJWT , JWTAttempt(..)+ , parseJWK ) where -import Protolude+import Protolude hiding ((&)) import Control.Lens-import Data.Aeson (Value (..), parseJSON, toJSON)-import Data.Aeson.Lens-import Data.Aeson.Types (parseMaybe, emptyObject, emptyArray)-import qualified Data.Vector as V+import Data.Aeson (Value (..), decode, toJSON)+import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M-import Data.Maybe (fromJust)-import Data.Time.Clock (NominalDiffTime)-import qualified Web.JWT as JWT +import Crypto.JOSE.Compact+import Crypto.JOSE.JWK+import Crypto.JOSE.JWS+import Crypto.JOSE.Types+import Crypto.JWT {-| Possible situations encountered with client JWTs -}-data JWTAttempt = JWTExpired- | JWTInvalid+data JWTAttempt = JWTInvalid JWTError | JWTMissingSecret | JWTClaims (M.HashMap Text Value)- deriving Eq+ deriving (Eq, Show) {-| Receives the JWT secret (from config) and a JWT and returns a map of JWT claims. -}-jwtClaims :: Maybe JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt-jwtClaims _ "" _ = JWTClaims M.empty-jwtClaims secret jwt time =+jwtClaims :: Maybe JWK -> BL.ByteString -> IO JWTAttempt+jwtClaims _ "" = return $ JWTClaims M.empty+jwtClaims secret payload = case secret of- Nothing -> JWTMissingSecret- Just s ->- let mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature s jwt in- case isExpired <$> mClaims of- Just True -> JWTExpired- Nothing -> JWTInvalid- Just False -> JWTClaims $ value2map $ fromJust mClaims- where- isExpired claims =- let mExp = claims ^? key "exp" . _Integer- in fromMaybe False $ (<= time) . fromInteger <$> mExp- value2map (Object o) = o- value2map _ = M.empty--{-|- Receives the JWT secret (from config) and a JWT and a JSON value- and returns a signed JWT.--}-tokenJWT :: JWT.Secret -> Value -> Text-tokenJWT secret (Array arr) =- let obj = if V.null arr then emptyObject else V.head arr- jcs = parseMaybe parseJSON obj :: Maybe JWT.JWTClaimsSet in- JWT.encodeSigned JWT.HS256 secret $ fromMaybe JWT.def jcs-tokenJWT secret _ = tokenJWT secret emptyArray+ Nothing -> return JWTMissingSecret+ Just jwk -> do+ let validation = defaultJWTValidationSettings+ eJwt <- runExceptT $ do+ jwt <- decodeCompact payload+ validateJWSJWT validation jwk jwt+ return jwt+ return $ case eJwt of+ Left e -> JWTInvalid e+ Right jwt -> JWTClaims . claims2map . jwtClaimsSet $ jwt {-| Whether a response from jwtClaims contains a role claim@@ -78,3 +63,30 @@ 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)++{-|+ Internal helper to generate HMAC-SHA256. When the jwt key in the+ config file is a simple string rather than a JWK object, we'll+ apply this function to it.+-}+hs256jwk :: ByteString -> JWK+hs256jwk key =+ fromKeyMaterial km+ & jwkUse .~ Just Sig+ & jwkAlg .~ (Just $ JWSAlg HS256)+ where+ km = OctKeyMaterial (OctKeyParameters Oct (Base64Octets key))
src/PostgREST/Config.hs view
@@ -45,7 +45,7 @@ import Text.Heredoc import Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>)) import qualified Text.PrettyPrint.ANSI.Leijen as L-import Protolude hiding (intercalate, (<>))+import Protolude hiding (intercalate, (<>), hPutStrLn) -- | Config file settings for the server data AppConfig = AppConfig {@@ -108,13 +108,13 @@ <*> C.key "db-anon-role" <*> C.key "server-proxy-uri" <*> C.key "db-schema"- <*> (fromMaybe "*4" <$> C.key "server-host")+ <*> (fromMaybe "*4" . mfilter (/= "") <$> C.key "server-host") <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port") <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret")- <*> (fromMaybe False <$> C.key "secret-is-base64")+ <*> (fromMaybe False . join . fmap coerceBool <$> C.key "secret-is-base64") <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool") <*> (join . fmap coerceInt <$> C.key "max-rows")- <*> C.key "pre-request"+ <*> (mfilter (/= "") <$> C.key "pre-request") <*> pure False case mAppConf of@@ -129,6 +129,11 @@ coerceInt (Number x) = rightToMaybe $ floatingOrInteger x coerceInt (String x) = readMaybe $ toS x coerceInt _ = Nothing++ coerceBool :: Value -> Maybe Bool+ coerceBool (Bool b) = Just b+ coerceBool (String x) = readMaybe $ toS x+ coerceBool _ = Nothing opts = info (helper <*> pathParser) $ fullDesc
src/PostgREST/DbRequestBuilder.hs view
@@ -30,7 +30,7 @@ import PostgREST.Error (apiRequestError) import PostgREST.Parsers import PostgREST.RangeQuery (NonnegRange, restrictRange)-import PostgREST.QueryBuilder (getJoinConditions, sourceCTEName)+import PostgREST.QueryBuilder (getJoinFilters, sourceCTEName) import PostgREST.Types import Protolude hiding (from, dropWhile, drop)@@ -88,12 +88,12 @@ augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest augumentRequestWithJoin schema allRels request = addRelations schema allRels Nothing request- >>= addJoinConditions schema+ >>= addJoinFilters schema addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest-addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) =+addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias, relationDetail)) forest) = case parentNode of- (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) ->+ (Just (Node (Select{from=[parentNodeTable]}, (_, _, _, _)) _)) -> Node <$> readNode' <*> forest' where forest' = updateForest $ hush node'@@ -101,10 +101,10 @@ readNode' = addRel readNode <$> rel rel :: Either ApiRequestError Relation rel = note (NoRelationBetween parentNodeTable name)- $ findRelation schema name parentNodeTable-+ $ findRelation schema name parentNodeTable relationDetail where- findRelation s nodeTableName parentNodeTableName =+ + 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@@ -141,35 +141,68 @@ -- addRelation will turn project_id to project so the above condition will match ) ) allRelations- where n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString)- addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))- addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a))+ + 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) => 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+ ) + ||+++ -- (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') _ -> n' <$> updateForest (Just (n' forest)) where- n' = Node (query, (name, Just r, alias))- t = Table schema name True -- !!! TODO find another way to get the table from the query+ 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 -addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest-addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =- case r of- Just Relation{relType=Root} -> Node nn <$> updatedForest -- this is the root node- Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest- Just Relation{relType=Parent} -> Node nn <$> updatedForest+addJoinFilters :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest+addJoinFilters schema (Node node@(query, nodeProps@(_, relation, _, _)) forest) =+ case relation of+ Just Relation{relType=Root} -> Node node <$> updatedForest -- this is the root node+ Just Relation{relType=Parent} -> Node node <$> updatedForest+ Just rel@Relation{relType=Child} -> Node (augmentQuery rel, nodeProps) <$> updatedForest Just rel@Relation{relType=Many, relLTable=(Just linkTable)} ->- Node (qq, (n, r, a)) <$> updatedForest- where- query' = addCond query (getJoinConditions rel)- qq = query'{from=tableName linkTable : from query'}+ let rq = augmentQuery rel in+ Node (rq{from=tableName linkTable:from rq}, nodeProps) <$> updatedForest _ -> Left UnknownRelation where- updatedForest = mapM (addJoinConditions schema) forest- addCond query' con = query'{flt_=con ++ flt_ query'}+ updatedForest = mapM (addJoinFilters schema) forest+ augmentQuery rel = foldr addFilterToReadQuery query (getJoinFilters rel)+ addFilterToReadQuery flt rq@Select{where_=lf} = rq{where_=addFilterToLogicForest flt lf}::ReadQuery addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest) addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [@@ -198,7 +231,7 @@ ranges = mapM pRequestRange $ M.toList $ iRange apiRequest addFilterToNode :: Filter -> ReadRequest -> ReadRequest-addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f+addFilterToNode flt (Node (q@Select {where_=lf}, i) f) = Node (q{where_=addFilterToLogicForest flt lf}::ReadQuery, i) f addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest addFilter = addProperty addFilterToNode@@ -216,7 +249,7 @@ addRange = addProperty addRangeToNode addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest-addLogicTreeToNode t (Node (q@Select{logic=l},i) f) = Node (q{logic=t:l}::ReadQuery, i) f+addLogicTreeToNode t (Node (q@Select{where_=lf},i) f) = Node (q{where_=t:lf}::ReadQuery, i) f addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest addLogicTree = addProperty addLogicTreeToNode@@ -240,7 +273,7 @@ maybeNode = find fnd forst where fnd :: ReadRequest -> Bool- fnd (Node (_,(n,_,_)) _) = n == name+ fnd (Node (_,(n,_,_,_)) _) = n == name -- in a relation where one of the tables mathces "TableName" -- replace the name to that table with pg_source@@ -258,8 +291,8 @@ mutateRequest apiRequest fldNames = mapLeft apiRequestError $ case action of ActionCreate -> Right $ Insert rootTableName payload returnings- ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> logic_ <*> pure returnings- ActionDelete -> Delete rootTableName <$> filters <*> logic_ <*> pure returnings+ ActionUpdate -> Update rootTableName <$> pure payload <*> combinedLogic <*> pure returnings+ ActionDelete -> Delete rootTableName <$> combinedLogic <*> pure returnings _ -> Left UnsupportedVerb where action = iAction apiRequest@@ -271,10 +304,10 @@ _ -> undefined returnings = if iPreferRepresentation apiRequest == None then [] else fldNames filters = map snd <$> mapM pRequestFilter mutateFilters- logic_ = map snd <$> mapM pRequestLogicTree logicFilters+ logic = map snd <$> mapM pRequestLogicTree logicFilters+ combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters -- update/delete filters can be only on the root table- mutateFilters = onlyRoot $ iFilters apiRequest- logicFilters = onlyRoot $ iLogic apiRequest+ (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest) onlyRoot = filter (not . ( "." `isInfixOf` ) . fst) fieldNames :: ReadRequest -> [FieldName]@@ -282,5 +315,10 @@ 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+-- they are later concatenated with AND in the QueryBuilder+addFilterToLogicForest :: Filter -> [LogicTree] -> [LogicTree]+addFilterToLogicForest flt lf = Stmnt flt : lf
src/PostgREST/DbStructure.hs view
@@ -6,6 +6,7 @@ module PostgREST.DbStructure ( getDbStructure , accessibleTables+, schemaDescription ) where import qualified Hasql.Decoders as HD@@ -52,7 +53,9 @@ decodeTables = HD.rowsList tblRow where- tblRow = Table <$> HD.value HD.text <*> HD.value HD.text+ tblRow = Table <$> HD.value HD.text+ <*> HD.value HD.text+ <*> HD.nullableValue HD.text <*> HD.value HD.bool decodeColumns :: [Table] -> HD.Result [Column]@@ -60,11 +63,11 @@ mapMaybe (columnFromRow tables) <$> HD.rowsList colRow where colRow =- (,,,,,,,,,,)+ (,,,,,,,,,,,) <$> HD.value HD.text <*> HD.value HD.text- <*> HD.value HD.text <*> HD.value HD.int4- <*> HD.value HD.bool <*> HD.value HD.text- <*> HD.value HD.bool+ <*> HD.value HD.text <*> HD.nullableValue HD.text+ <*> HD.value HD.int4 <*> HD.value HD.bool+ <*> HD.value HD.text <*> HD.value HD.bool <*> HD.nullableValue HD.int4 <*> HD.nullableValue HD.int4 <*> HD.nullableValue HD.text@@ -103,6 +106,7 @@ (M.fromList . map addName <$> HD.rowsList ( ProcDescription <$> HD.value HD.text+ <*> HD.nullableValue HD.text <*> (parseArgs <$> HD.value HD.text) <*> (parseRetType <$> HD.value HD.text <*>@@ -137,7 +141,9 @@ qi = QualifiedIdentifier schema name pgType = case typ of 'c' -> Composite qi- 'p' -> Pseudo name+ 'p' -> if name == "record" -- Only pg pseudo type that is a row type is 'record'+ then Composite qi+ else Scalar qi _ -> Scalar qi -- 'b'ase, 'd'omain, 'e'num, 'r'ange parseVolatility :: Char -> ProcVolatility@@ -148,6 +154,7 @@ sql = [q| SELECT p.proname as "proc_name",+ d.description as "proc_description", pg_get_function_arguments(p.oid) as "args", tn.nspname as "rettype_schema", coalesce(comp.relname, t.typname) as "rettype_name",@@ -159,8 +166,22 @@ JOIN pg_type t ON t.oid = p.prorettype JOIN pg_namespace tn ON tn.oid = t.typnamespace LEFT JOIN pg_class comp ON comp.oid = t.typrelid+ LEFT JOIN pg_catalog.pg_description as d on d.objoid = p.oid WHERE pn.nspname = $1|] +schemaDescription :: H.Query Schema (Maybe Text)+schemaDescription =+ H.statement sql (HE.value HE.text) (HD.singleRow $ HD.nullableValue HD.text) True+ where+ sql = [q|+ select+ description+ from+ pg_catalog.pg_namespace n+ left join pg_catalog.pg_description d on d.objoid = n.oid+ where+ n.nspname = $1 |]+ accessibleTables :: H.Query Schema [Table] accessibleTables = H.statement sql (HE.value HE.text) decodeTables True@@ -169,6 +190,7 @@ select n.nspname as table_schema, relname as table_name,+ d.description as table_description, c.relkind = 'r' or (c.relkind IN ('v', 'f')) and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8 or (exists ( select 1@@ -178,6 +200,7 @@ from pg_class c 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') and n.nspname = $1@@ -230,7 +253,11 @@ 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- combinations k ns = filter ((k==).length) (subsequences ns)+ -- 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' link2Relation [@@ -269,6 +296,7 @@ SELECT n.nspname AS table_schema, c.relname AS table_name,+ NULL AS table_description, c.relkind = 'r' OR (c.relkind IN ('v','f')) AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 OR (EXISTS@@ -292,6 +320,7 @@ info.table_schema AS schema, info.table_name AS table_name, info.column_name AS name,+ info.description AS description, info.ordinal_position AS position, info.is_nullable::boolean AS nullable, info.data_type AS col_type,@@ -309,6 +338,7 @@ nc.nspname::information_schema.sql_identifier AS table_schema, c.relname::information_schema.sql_identifier AS table_name, a.attname::information_schema.sql_identifier AS column_name,+ d.description::information_schema.sql_identifier AS description, a.attnum::information_schema.cardinal_number AS ordinal_position, pg_get_expr(ad.adbin, ad.adrelid)::information_schema.character_data AS column_default, CASE@@ -381,6 +411,7 @@ ELSE 'NO'::text END::information_schema.yes_or_no AS is_updatable FROM pg_attribute a+ LEFT JOIN pg_catalog.pg_description AS d ON d.objoid = a.attrelid and d.objsubid = a.attnum LEFT JOIN pg_attrdef ad ON a.attrelid = ad.adrelid AND a.attnum = ad.adnum JOIN (pg_class c JOIN pg_namespace nc ON c.relnamespace = nc.oid) ON a.attrelid = c.oid@@ -397,6 +428,7 @@ table_schema, table_name, column_name,+ description, ordinal_position, is_nullable, data_type,@@ -422,14 +454,14 @@ ORDER BY schema, position |] columnFromRow :: [Table] ->- (Text, Text, Text,- Int32, Bool, Text,- Bool, Maybe Int32, Maybe Int32,- Maybe Text, Maybe Text)+ (Text, Text, Text,+ Maybe Text, Int32, Bool,+ Text, Bool, Maybe Int32,+ Maybe Int32, Maybe Text, Maybe Text) -> Maybe Column-columnFromRow tabs (s, t, n, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table+columnFromRow tabs (s, t, n, desc, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table where- buildColumn tbl = Column tbl n pos nul typ u l p d (parseEnum e) Nothing+ buildColumn tbl = Column tbl n desc pos nul typ u l p d (parseEnum e) Nothing table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs parseEnum :: Maybe Text -> [Text] parseEnum str = fromMaybe [] $ split (==',') <$> str
src/PostgREST/Error.hs view
@@ -18,12 +18,15 @@ import Data.Text (unwords) import qualified Hasql.Pool as P import qualified Hasql.Session as H+import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT import Network.Wai (Response, responseLBS) import PostgREST.Types apiRequestError :: ApiRequestError -> Response-apiRequestError err = errorResponse status err+apiRequestError err =+ errorResponse status+ [toHeader CTApplicationJSON] err where status = case err of@@ -35,13 +38,14 @@ InvalidRange -> HT.status416 UnknownRelation -> HT.status404 -simpleError :: HT.Status -> Text -> Response-simpleError status message =- errorResponse status $ JSON.object ["message" .= message]+simpleError :: HT.Status -> [Header] -> Text -> Response+simpleError status hdrs message =+ errorResponse status (toHeader CTApplicationJSON : hdrs) $+ JSON.object ["message" .= message] -errorResponse :: JSON.ToJSON a => HT.Status -> a -> Response-errorResponse status e =- responseLBS status [toHeader CTApplicationJSON] $ encodeError e+errorResponse :: JSON.ToJSON a => HT.Status -> [Header] -> a -> Response+errorResponse status hdrs e =+ responseLBS status hdrs $ encodeError e pgError :: Bool -> P.UsageError -> Response pgError authed e =@@ -71,12 +75,12 @@ binaryFieldError :: Response binaryFieldError =- simpleError HT.status406 (toS (toMime CTOctetStream) <>+ simpleError HT.status406 [] (toS (toMime CTOctetStream) <> " requested but a single column was not selected") connectionLostError :: Response connectionLostError =- simpleError HT.status503 "Database connection lost, retrying the connection."+ simpleError HT.status503 [] "Database connection lost, retrying the connection." encodeError :: JSON.ToJSON a => a -> LByteString encodeError = JSON.encode
src/PostgREST/Middleware.hs view
@@ -4,13 +4,13 @@ module PostgREST.Middleware where +import Crypto.JWT import Data.Aeson (Value (..)) import qualified Data.HashMap.Strict as M import qualified Hasql.Transaction as H import Network.HTTP.Types.Status (unauthorized401, status500)-import Network.Wai (Application, Response,- responseLBS)+import Network.Wai (Application, Response) import Network.Wai.Middleware.Cors (cors) import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Static (only, staticPolicy)@@ -19,7 +19,6 @@ import PostgREST.Auth (JWTAttempt(..)) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (simpleError)-import PostgREST.Types (ContentType (..), toHeader) import PostgREST.QueryBuilder (pgFmtLit, unquoted, pgFmtEnvVar) import Protolude hiding (concat, null)@@ -29,9 +28,9 @@ ApiRequest -> H.Transaction Response runWithClaims conf eClaims app req = case eClaims of- JWTExpired -> return $ unauthed "JWT expired"- JWTInvalid -> return $ unauthed "JWT invalid"- JWTMissingSecret -> return $ simpleError status500 "Server lacks JWT secret"+ JWTInvalid JWTExpired -> return $ unauthed "JWT expired"+ 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 mapM_ H.sql customReqCheck@@ -47,14 +46,13 @@ anon = String . toS $ configAnonRole conf customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf where- unauthed message = responseLBS unauthorized401- [ toHeader CTApplicationJSON- , ( "WWW-Authenticate"+ unauthed message = simpleError+ unauthorized401+ [( "WWW-Authenticate" , "Bearer error=\"invalid_token\", " <>- "error_description=\"" <> message <> "\""- )- ]- (toS $ "{\"message\":\""<>message<>"\"}")+ "error_description=" <> show message+ )]+ message defaultMiddle :: Application -> Application defaultMiddle =
src/PostgREST/OpenAPI.hs view
@@ -6,25 +6,25 @@ , pickProxy ) where +import Control.Arrow ((&&&)) import Control.Lens import Data.Aeson (decode, encode)-import qualified Data.HashMap.Strict as M import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList) import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.String (IsString (..))-import Data.Text (unpack, pack, concat, intercalate, init, tail, toLower)+import Data.Text (unpack, pack, init, tail, toLower, intercalate, append, dropWhile, breakOn) import Network.URI (parseURI, isAbsoluteURI, URI (..), URIAuth (..)) -import Protolude hiding (concat, (&), Proxy, get, intercalate)+import Protolude hiding ((&), Proxy, get, intercalate, dropWhile) import Data.Swagger import PostgREST.ApiRequest (ContentType(..)) import PostgREST.Config (prettyVersion)-import PostgREST.Types (Table(..), Column(..), PgArg(..),- Proxy(..), ProcDescription(..), toMime, operators)+import PostgREST.Types (Table(..), Column(..), PgArg(..), ForeignKey(..),+ PrimaryKey(..), Proxy(..), ProcDescription(..), toMime) makeMimeList :: [ContentType] -> MimeList makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs@@ -36,30 +36,48 @@ toSwaggerType "numeric" = SwaggerNumber toSwaggerType _ = SwaggerString -makeTableDef :: (Table, [Column], [Text]) -> (Text, Schema)-makeTableDef (t, cs, _) =+makeTableDef :: [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema)+makeTableDef pks (t, cs, _) = let tn = tableName t in (tn, (mempty :: Schema)+ & description .~ tableDescription t & type_ .~ SwaggerObject- & properties .~ fromList (map makeProperty cs))+ & properties .~ fromList (map (makeProperty pks) cs)) -makeProperty :: Column -> (Text, Referenced Schema)-makeProperty c = (colName c, Inline u)+makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema)+makeProperty pks c = (colName c, Inline s) where- r = mempty :: Schema- s = if null $ colEnum c- then r- else r & enum_ .~ decode (encode (colEnum c))- t = s & type_ .~ toSwaggerType (colType c)- u = t & format ?~ colType c+ e = if null $ colEnum c then Nothing else decode $ encode $ colEnum c+ fk ForeignKey{fkCol=Column{colTable=Table{tableName=a}, colName=b}} =+ intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]+ pk :: Bool+ pk = any (\p -> pkTable p == colTable c && pkName p == colName c) pks+ n = catMaybes+ [ Just "Note:"+ , if pk then Just "This is a Primary Key.<pk/>" else Nothing+ , fk <$> colFK c+ ]+ d =+ if length n > 1 then+ Just $ append (fromMaybe "" ((`append` "\n\n") <$> colDescription c)) (intercalate "\n" n)+ else+ colDescription c+ s =+ (mempty :: Schema)+ & default_ .~ (decode . toS =<< colDefault c)+ & description .~ d+ & enum_ .~ e+ & format ?~ colType c+ & maxLength .~ (fromIntegral <$> colMaxLen c)+ & type_ .~ toSwaggerType (colType c) -makeProcDef :: ProcDescription -> (Text, Schema)-makeProcDef pd = ("(rpc) " <> pdName pd, s)- where- s = (mempty :: Schema)- & type_ .~ SwaggerObject- & properties .~ fromList (map makeProcProperty (pdArgs pd))- & required .~ map pgaName (filter pgaReq (pdArgs pd))+makeProcSchema :: ProcDescription -> Schema+makeProcSchema pd =+ (mempty :: Schema)+ & description .~ pdDescription pd+ & type_ .~ SwaggerObject+ & properties .~ fromList (map makeProcProperty (pdArgs pd))+ & required .~ map pgaName (filter pgaReq (pdArgs pd)) makeProcProperty :: PgArg -> (Text, Referenced Schema) makeProcProperty (PgArg n t _) = (n, Inline s)@@ -68,68 +86,6 @@ & type_ .~ toSwaggerType t & format ?~ t -makeOperatorPattern :: Text-makeOperatorPattern =- intercalate "|"- [ concat ["^", x, y, "[.]"] |- x <- ["not[.]", ""],- y <- M.keys operators ]--makeRowFilter :: Column -> Param-makeRowFilter c =- (mempty :: Param)- & name .~ colName c- & required ?~ False- & schema .~ ParamOther ((mempty :: ParamOtherSchema)- & in_ .~ ParamQuery- & type_ .~ SwaggerString- & format ?~ colType c- & pattern ?~ makeOperatorPattern)--makeRowFilters :: [Column] -> [Param]-makeRowFilters = map makeRowFilter--makeOrderItems :: [Column] -> [Text]-makeOrderItems cs =- [ concat [x, y, z] |- x <- map colName cs,- y <- [".asc", ".desc", ""],- z <- [".nullsfirst", ".nulllast", ""]- ]--makeRangeParams :: [Param]-makeRangeParams =- [ (mempty :: Param)- & name .~ "Range"- & description ?~ "Limiting and Pagination"- & required ?~ False- & schema .~ ParamOther ((mempty :: ParamOtherSchema)- & in_ .~ ParamHeader- & type_ .~ SwaggerString)- , (mempty :: Param)- & name .~ "Range-Unit"- & description ?~ "Limiting and Pagination"- & required ?~ False- & schema .~ ParamOther ((mempty :: ParamOtherSchema)- & in_ .~ ParamHeader- & type_ .~ SwaggerString- & default_ .~ decode "\"items\"")- , (mempty :: Param)- & name .~ "offset"- & description ?~ "Limiting and Pagination"- & required ?~ False- & schema .~ ParamOther ((mempty :: ParamOtherSchema)- & in_ .~ ParamQuery- & type_ .~ SwaggerString)- , (mempty :: Param)- & name .~ "limit"- & description ?~ "Limiting and Pagination"- & required ?~ False- & schema .~ ParamOther ((mempty :: ParamOtherSchema)- & in_ .~ ParamQuery- & type_ .~ SwaggerString)- ]- makePreferParam :: [Text] -> Param makePreferParam ts = (mempty :: Param)@@ -141,92 +97,131 @@ & type_ .~ SwaggerString & enum_ .~ decode (encode ts)) -makeSelectParam :: Param-makeSelectParam =- (mempty :: Param)- & name .~ "select"- & description ?~ "Filtering Columns"- & required ?~ False- & schema .~ ParamOther ((mempty :: ParamOtherSchema)- & in_ .~ ParamQuery- & type_ .~ SwaggerString)+makeProcParam :: ProcDescription -> [Referenced Param]+makeProcParam pd =+ [ Inline $ (mempty :: Param)+ & name .~ "args"+ & required ?~ True+ & schema .~ (ParamBody $ Inline $ makeProcSchema pd)+ , Ref $ Reference "preferParams"+ ] -makeGetParams :: [Column] -> [Param]-makeGetParams [] =- makeRangeParams ++- [ makeSelectParam- , makePreferParam ["count=none"]+makeParamDefs :: [(Table, [Column], [Text])] -> [(Text, Param)]+makeParamDefs ti =+ [ ("preferParams", makePreferParam ["params=single-object"])+ , ("preferReturn", makePreferParam ["return=representation", "return=minimal", "return=none"])+ , ("preferCount", makePreferParam ["count=none"])+ , ("select", (mempty :: Param)+ & name .~ "select"+ & description ?~ "Filtering Columns"+ & required ?~ False+ & schema .~ ParamOther ((mempty :: ParamOtherSchema)+ & in_ .~ ParamQuery+ & type_ .~ SwaggerString))+ , ("order", (mempty :: Param)+ & name .~ "order"+ & description ?~ "Ordering"+ & required ?~ False+ & schema .~ ParamOther ((mempty :: ParamOtherSchema)+ & in_ .~ ParamQuery+ & type_ .~ SwaggerString))+ , ("range", (mempty :: Param)+ & name .~ "Range"+ & description ?~ "Limiting and Pagination"+ & required ?~ False+ & schema .~ ParamOther ((mempty :: ParamOtherSchema)+ & in_ .~ ParamHeader+ & type_ .~ SwaggerString))+ , ("rangeUnit", (mempty :: Param)+ & name .~ "Range-Unit"+ & description ?~ "Limiting and Pagination"+ & required ?~ False+ & schema .~ ParamOther ((mempty :: ParamOtherSchema)+ & in_ .~ ParamHeader+ & type_ .~ SwaggerString+ & default_ .~ decode "\"items\""))+ , ("offset", (mempty :: Param)+ & name .~ "offset"+ & description ?~ "Limiting and Pagination"+ & required ?~ False+ & schema .~ ParamOther ((mempty :: ParamOtherSchema)+ & in_ .~ ParamQuery+ & type_ .~ SwaggerString))+ , ("limit", (mempty :: Param)+ & name .~ "limit"+ & description ?~ "Limiting and Pagination"+ & required ?~ False+ & schema .~ ParamOther ((mempty :: ParamOtherSchema)+ & in_ .~ ParamQuery+ & type_ .~ SwaggerString)) ]-makeGetParams cs =- makeRangeParams ++- [ makeSelectParam- , (mempty :: Param)- & name .~ "order"- & description ?~ "Ordering"- & required ?~ False+ <> concat [ makeObjectBody (tableName t) : makeRowFilters (tableName t) cs+ | (t, cs, _) <- ti+ ]++makeObjectBody :: Text -> (Text, Param)+makeObjectBody tn =+ ("body." <> tn, (mempty :: Param)+ & name .~ tn+ & description ?~ tn+ & required ?~ False+ & schema .~ ParamBody (Ref (Reference tn)))++makeRowFilter :: Text -> Column -> (Text, Param)+makeRowFilter tn c =+ (intercalate "." ["rowFilter", tn, colName c], (mempty :: Param)+ & name .~ colName c+ & description .~ colDescription c+ & required ?~ False & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamQuery & type_ .~ SwaggerString- & enum_ .~ decode (encode $ makeOrderItems cs))- , makePreferParam ["count=none"]- ]--makePostParams :: Text -> [Param]-makePostParams tn =- [ makePreferParam ["return=representation",- "return=minimal", "return=none"]- , (mempty :: Param)- & name .~ "body"- & description ?~ tn- & required ?~ False- & schema .~ ParamBody (Ref (Reference tn))- ]--makeProcParam :: Text -> [Param]-makeProcParam refName =- [ makePreferParam ["params=single-object"]- , (mempty :: Param)- & name .~ "args"- & required ?~ True- & schema .~ ParamBody (Ref (Reference refName))- ]+ & format ?~ colType c)) -makeDeleteParams :: [Param]-makeDeleteParams =- [ makePreferParam ["return=representation", "return=minimal", "return=none"] ]+makeRowFilters :: Text -> [Column] -> [(Text, Param)]+makeRowFilters tn = map (makeRowFilter tn) makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem) makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t) where+ -- Use first line of table description as summary; rest as description (if present)+ -- We strip leading newlines from description so that users can include a blank line between summary and description+ (tSum, tDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $+ breakOn "\n" <$> tableDescription t tOp = (mempty :: Operation) & tags .~ Set.fromList [tn]- & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]- & at 200 ?~ "OK"+ & summary .~ tSum+ & description .~ mfilter (/="") tDesc getOp = tOp- & parameters .~ map Inline (makeGetParams cs ++ rs)+ & parameters .~ map ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"]) & at 206 ?~ "Partial Content"+ & at 200 ?~ Inline ((mempty :: Response)+ & description .~ "OK"+ & schema ?~ (Ref $ Reference $ tableName t)+ ) postOp = tOp- & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]- & parameters .~ map Inline (makePostParams tn)+ & parameters .~ map ref ["body." <> tn, "preferReturn"] & at 201 ?~ "Created" patchOp = tOp- & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]- & parameters .~ map Inline (makePostParams tn ++ rs)+ & parameters .~ map ref (rs <> ["body." <> tn, "preferReturn"]) & at 204 ?~ "No Content" deletOp = tOp- & parameters .~ map Inline (makeDeleteParams ++ rs)+ & parameters .~ map ref (rs <> ["preferReturn"])+ & at 204 ?~ "No Content" pr = (mempty :: PathItem) & get ?~ getOp pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp p False = pr p True = pw- rs = makeRowFilters cs tn = tableName t+ rs = [ intercalate "." ["rowFilter", tn, colName c ] | c <- cs ]+ ref = Ref . Reference makeProcPathItem :: ProcDescription -> (FilePath, PathItem) makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe) where postOp = (mempty :: Operation)- & parameters .~ map Inline (makeProcParam $ "(rpc) " <> pdName pd)+ & description .~ pdDescription pd+ & parameters .~ makeProcParam pd & tags .~ Set.fromList ["(rpc) " <> pdName pd] & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON] & at 200 ?~ "OK"@@ -236,7 +231,8 @@ makeRootPathItem = ("/", p) where getOp = (mempty :: Operation)- & tags .~ Set.fromList ["/"]+ & tags .~ Set.fromList ["Introspection"]+ & summary ?~ "OpenAPI description (this document)" & produces ?~ makeMimeList [CTOpenAPI, CTApplicationJSON] & at 200 ?~ "OK" pr = (mempty :: PathItem) & get ?~ getOp@@ -254,23 +250,30 @@ escapeHostName "!6" = "0.0.0.0" escapeHostName h = h -postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Swagger-postgrestSpec pds ti (s, h, p, b) = (mempty :: Swagger)+postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger+postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger) & basePath ?~ unpack b & schemes ?~ [s'] & info .~ ((mempty :: Info) & version .~ prettyVersion & title .~ "PostgREST API"- & description ?~ "This is a dynamic API generated by PostgREST")+ & description ?~ d)+ & externalDocs ?~ ((mempty :: ExternalDocs)+ & description ?~ "PostgREST Documentation"+ & url .~ URL "https://postgrest.com/en/latest/api.html") & host .~ h'- & definitions .~ fromList (map makeTableDef ti <> map makeProcDef pds)+ & definitions .~ fromList (map (makeTableDef pks) ti)+ & parameters .~ fromList (makeParamDefs ti) & paths .~ makePathItems pds ti+ & produces .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]+ & consumes .~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV] where s' = if s == "http" then Http else Https h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))+ d = fromMaybe "This is a dynamic API generated by PostgREST" sd -encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> LByteString-encodeOpenAPI pds ti uri = encode $ postgrestSpec pds ti uri+encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> LByteString+encodeOpenAPI pds ti uri sd pks = encode $ postgrestSpec pds ti uri sd pks {-| Test whether a proxy uri is malformed or not.
src/PostgREST/Parsers.hs view
@@ -1,6 +1,6 @@ module PostgREST.Parsers where -import Protolude hiding (try, intercalate)+import Protolude hiding (try, intercalate, replace) import Control.Monad ((>>)) import Data.Foldable (foldl1) import qualified Data.HashMap.Strict as M@@ -56,17 +56,17 @@ pReadRequest :: Text -> Parser ReadRequest pReadRequest rootNodeName = do fieldTree <- pFieldForest- return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree+ return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing, Nothing)) []) fieldTree where- readQuery = Select [] [rootNodeName] [] [] Nothing allRange+ readQuery = Select [] [rootNodeName] [] Nothing allRange treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest- treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =+ 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)) []) fldForest:rForest+ foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias, relationDetail)) []) fldForest:rForest pTreePath :: Parser (EmbedPath, Field) pTreePath = do@@ -78,9 +78,9 @@ pFieldForest = pFieldTree `sepBy1` lexeme (char ',') pFieldTree :: Parser (Tree SelectItem)-pFieldTree = try (Node <$> pSimpleSelect <*> between (char '{') (char '}') pFieldForest)- <|> try (Node <$> pSimpleSelect <*> between (char '(') (char ')') pFieldForest)- <|> Node <$> pSelect <*> pure []+pFieldTree = try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest)+ <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest)+ <|> Node <$> pFieldSelect <*> pure [] pStar :: Parser Text pStar = toS <$> (string "*" *> pure ("*"::ByteString))@@ -109,25 +109,27 @@ aliasSeparator :: Parser () aliasSeparator = char ':' >> notFollowedBy (char ':') -pSimpleSelect :: Parser SelectItem-pSimpleSelect = lexeme $ try ( do+pRelationSelect :: Parser SelectItem+pRelationSelect = lexeme $ try ( do alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) fld <- pField- return (fld, Nothing, alias)+ relationDetail <- optionMaybe ( try( char '.' *> pFieldName ) )++ return (fld, Nothing, alias, relationDetail) ) -pSelect :: Parser SelectItem-pSelect = lexeme $+pFieldSelect :: Parser SelectItem+pFieldSelect = lexeme $ try ( do alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) fld <- pField cast' <- optionMaybe (string "::" *> many letter)- return (fld, toS <$> cast', alias)+ return (fld, toS <$> cast', alias, Nothing) ) <|> do s <- pStar- return ((s, Nothing), Nothing, Nothing)+ return ((s, Nothing), Nothing, Nothing, Nothing) pOperation :: Parser Operand -> Parser Operand -> Parser Operation pOperation parserVText parserVTextL = try ( string "not" *> pDelimiter *> (Operation True <$> pExpr)) <|> Operation False <$> pExpr@@ -177,12 +179,12 @@ pLogicTree :: Parser LogicTree pLogicTree = Stmnt <$> try pLogicFilter- <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree) <*> (lexeme (char ',') *> pLogicTree <* lexeme (char ')'))+ <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')')) where pLogicFilter :: Parser Filter pLogicFilter = Filter <$> pField <* pDelimiter <*> pOperation pLogicVText pLogicVTextL pNot :: Parser Bool- pNot = try (string "not" *> pDelimiter *> pure True) + pNot = try (string "not" *> pDelimiter *> pure True) <|> pure False <?> "negation operator (not)" pLogicOp :: Parser LogicOperator
src/PostgREST/QueryBuilder.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Module : PostgREST.QueryBuilder@@ -15,7 +14,7 @@ callProc , createReadStatement , createWriteStatement- , getJoinConditions+ , getJoinFilters , pgFmtIdent , pgFmtLit , requestToQuery@@ -48,7 +47,7 @@ , formatScientific , isInteger )-import Protolude hiding (from, intercalate, ord, cast)+import Protolude hiding (from, intercalate, ord, cast, replace) import PostgREST.ApiRequest (PreferRepresentation (..)) {-| The generic query result format used by API responses. The location header@@ -144,42 +143,45 @@ | otherwise = asJsonF type ProcResults = (Maybe Int64, Int64, ByteString)-callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange ->- Bool -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults)-callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson asCsv =+callProc :: QualifiedIdentifier -> JSON.Object -> Bool -> SqlQuery -> SqlQuery -> NonnegRange ->+ Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> H.Query () (Maybe ProcResults)+callProc qi params returnsScalar selectQuery countQuery _ countTotal isSingle paramsAsJson asCsv asBinary binaryField = unicodeStatement sql HE.unit decodeProc True where- sql = [qc|- WITH {sourceCTEName} AS ({_callSql})- SELECT- {countResultF} AS total_result_set,- pg_catalog.count(_postgrest_t) AS page_total,- case- when pg_catalog.count(*) > 1 then- {bodyF}- else- coalesce(((array_agg(row_to_json(_postgrest_t)))[1]->{_procName})::character varying, {bodyF})+ sql =+ if returnsScalar then [qc|+ WITH {sourceCTEName} AS ({_callSql})+ SELECT+ {countResultF} AS total_result_set,+ 1 AS page_total,+ {scalarBodyF} as body+ FROM ({selectQuery}) _postgrest_t;|]+ else [qc|+ WITH {sourceCTEName} AS ({_callSql})+ SELECT+ {countResultF} AS total_result_set,+ pg_catalog.count(_postgrest_t) AS page_total,+ {bodyF} as body+ FROM ({selectQuery}) _postgrest_t;|] - end as body- FROM ({selectQuery}) _postgrest_t;- |]- -- FROM (select * from {sourceCTEName} {limitF range}) t;- countResultF = if countTotal then "("<>countQuery<>")" else "null::bigint" :: Text+ countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text _args = if paramsAsJson then insertableValueWithType "json" $ JSON.Object params else intercalate "," $ map _assignment (HM.toList params)- _procName = pgFmtLit $ qiName qi+ _procName = qiName qi _assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v _callSql = [qc|select * from {fromQi qi}({_args}) |] :: Text- _countExpr = if countTotal- then [qc|(select pg_catalog.count(*) from {sourceCTEName})|]- else "null::bigint" :: Text decodeProc = HD.maybeRow procRow procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8 <*> HD.value HD.bytea+ scalarBodyF+ | asBinary = asBinaryF _procName+ | otherwise = "(row_to_json(_postgrest_t)->" <> pgFmtLit _procName <> ")::character varying"+ bodyF | isSingle = asJsonSingleF | asCsv = asCsvF+ | isJust binaryField = asBinaryF $ fromJust binaryField | otherwise = asJsonF pgFmtIdent :: SqlFragment -> SqlFragment@@ -196,25 +198,23 @@ requestToCountQuery :: Schema -> DbRequest -> SqlQuery requestToCountQuery _ (DbMutate _) = undefined-requestToCountQuery schema (DbRead (Node (Select _ _ conditions logic_ _ _, (mainTbl, _, _)) _)) =+requestToCountQuery schema (DbRead (Node (Select _ _ logicForest _ _, (mainTbl, _, _, _)) _)) = unwords [ "SELECT pg_catalog.count(*)", "FROM ", fromQi qi,- -- logic_ doesn't not need localFilter filtering because it doesn't have VForeignKey vals- ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) localConditions ++ map (pgFmtLogicTree qi) logic_))- `emptyOnFalse` (null conditions && null logic_)+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) filteredLogic)) `emptyOnFalse` null filteredLogic ] where qi = removeSourceCTESchema schema mainTbl- localFilter :: Filter -> Bool- localFilter Filter{operation=Operation{expr=(_, val)}} = case val of- VText _ -> True- VTextL _ -> True- VForeignKey _ _ -> False- localConditions = filter localFilter conditions+ -- all foreing key filters are root nodes(see addFilterToLogicForest), only those are filtered+ nonFKRoot :: LogicTree -> Bool+ nonFKRoot (Stmnt (Filter _ Operation{expr=(_, VForeignKey _ _)})) = False+ nonFKRoot (Stmnt _) = True+ nonFKRoot Expr{} = True+ filteredLogic = filter nonFKRoot logicForest requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery-requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions logic_ ord range, (nodeName, maybeRelation, _)) forest)) =+requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest ord range, (nodeName, maybeRelation, _, _)) forest)) = query where mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)@@ -224,8 +224,7 @@ "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), "FROM ", intercalate ", " (map (fromQi . toQi) tbls), unwords joins,- ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))- `emptyOnFalse` (null conditions && null logic_),+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest, orderF (fromMaybe [] ord), if isParent then "" else limitF range ]@@ -243,14 +242,14 @@ (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 array_to_json(array_agg(row_to_json("<>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 r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (joi:j,sel:s)+ getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias, _)) forst) (j,s) = (joi:j,sel:s) where node_name = fromMaybe name alias local_table_name = table <> "_" <> node_name@@ -258,9 +257,9 @@ replaceTableName _ x = x sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name <>- " ON " <> intercalate " AND " ( map (pgFmtFilter qi . replaceTableName local_table_name) (getJoinConditions r) )+ " ON " <> intercalate " AND " ( map (pgFmtFilter qi . replaceTableName local_table_name) (getJoinFilters r) ) 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 array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "@@ -286,7 +285,7 @@ ret = if null returnings then "" else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)]-requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions logic_ returnings)) =+requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) logicForest returnings)) = case rows V.!? 0 of Just obj -> let assignments = map@@ -294,21 +293,19 @@ unwords [ "UPDATE ", fromQi qi, " SET " <> intercalate "," assignments <> " ",- ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))- `emptyOnFalse` (null conditions && null logic_),+ ("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-requestToQuery schema _ (DbMutate (Delete mainTbl conditions logic_ returnings)) =+requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) = query where qi = QualifiedIdentifier schema mainTbl query = unwords [ "DELETE FROM ", fromQi qi,- ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))- `emptyOnFalse` (null conditions && null logic_),+ ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest, ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings ] @@ -375,13 +372,13 @@ n = qiName t s = qiSchema t -getJoinConditions :: Relation -> [Filter]-getJoinConditions (Relation t cols ft fcs typ lt lc1 lc2) =+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 getJoinConditions"+ Root -> undefined --error "undefined getJoinFilters" where s = if typ == Parent then "" else tableSchema t tN = tableName t@@ -412,15 +409,17 @@ pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment-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+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 pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment pgFmtFilter table (Filter fld (Operation hasNot_ ex)) = notOp <> " " <> case ex of (op, VText val) -> pgFmtFieldOp op <> " " <> case op of "like" -> unknownLiteral (T.map star val) "ilike" -> unknownLiteral (T.map star val)+ -- TODO: The '@@' was deprecated, remove in v0.5.0.0 "@@" -> "to_tsquery(" <> unknownLiteral val <> ") "+ "fts" -> "to_tsquery(" <> unknownLiteral val <> ") " "is" -> whiteList val "isnot" -> whiteList val _ -> unknownLiteral val@@ -449,7 +448,7 @@ Nothing -> emptyValForIn op pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment-pgFmtLogicTree qi (Expr hasNot_ op lt rt) = notOp <> " (" <> pgFmtLogicTree qi lt <> " " <> show op <> " " <> pgFmtLogicTree qi rt <> ")"+pgFmtLogicTree qi (Expr hasNot_ op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")" where notOp = if hasNot_ then "NOT" else "" pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt
src/PostgREST/Types.hs view
@@ -38,7 +38,7 @@ , pgaReq :: Bool } deriving (Show, Eq) -data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier | Pseudo Text deriving (Eq, Show)+data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show) data RetType = Single PgType | SetOf PgType deriving (Eq, Show) @@ -46,10 +46,11 @@ deriving (Eq, Show) data ProcDescription = ProcDescription {- pdName :: Text-, pdArgs :: [PgArg]-, pdReturnType :: RetType-, pdVolatility :: ProcVolatility+ pdName :: Text+, pdDescription :: Maybe Text+, pdArgs :: [PgArg]+, pdReturnType :: RetType+, pdVolatility :: ProcVolatility } deriving (Show, Eq) type Schema = Text@@ -59,26 +60,28 @@ type RequestBody = BL.ByteString data Table = Table {- tableSchema :: Schema-, tableName :: TableName-, tableInsertable :: Bool+ tableSchema :: Schema+, tableName :: TableName+, tableDescription :: Maybe Text+, tableInsertable :: Bool } deriving (Show, Ord) newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord) data Column = Column {- colTable :: Table- , colName :: Text- , colPosition :: Int32- , colNullable :: Bool- , colType :: Text- , colUpdatable :: Bool- , colMaxLen :: Maybe Int32- , colPrecision :: Maybe Int32- , colDefault :: Maybe Text- , colEnum :: [Text]- , colFK :: Maybe ForeignKey+ colTable :: Table+ , colName :: Text+ , colDescription :: Maybe Text+ , colPosition :: Int32+ , colNullable :: Bool+ , colType :: Text+ , colUpdatable :: Bool+ , colMaxLen :: Maybe Int32+ , colPrecision :: Maybe Int32+ , colDefault :: Maybe Text+ , colEnum :: [Text]+ , colFK :: Maybe ForeignKey } deriving (Show, Ord) type Synonym = (Column,Column)@@ -111,6 +114,12 @@ data RelationType = Child | Parent | Many | Root deriving (Show, Eq)++{-|+ The name 'Relation' here is used with the meaning+ "What is the relation between the current node and the parent node".+ It has nothing to do with PostgreSQL referring to tables/views as relations.+-} data Relation = Relation { relTable :: Table , relColumns :: [Column]@@ -152,6 +161,16 @@ ("notin", "NOT IN"), ("isnot", "IS NOT"), ("is", "IS"),+ ("fts", "@@"),+ ("cs", "@>"),+ ("cd", "<@"),+ ("ov", "&&"),+ ("sl", "<<"),+ ("sr", ">>"),+ ("nxr", "&<"),+ ("nxl", "&>"),+ ("adj", "-|-"),+ -- TODO: these are deprecated and should be removed in v0.5.0.0 ("@@", "@@"), ("@>", "@>"), ("<@", "<@")]@@ -171,7 +190,7 @@ / \ id.eq.1 id.eq.2 -}-data LogicTree = Expr Bool LogicOperator LogicTree LogicTree | Stmnt Filter deriving (Show, Eq)+data LogicTree = Expr Bool LogicOperator [LogicTree] | Stmnt Filter deriving (Show, Eq) type FieldName = Text type JsonPath = [Text]@@ -179,50 +198,25 @@ type Alias = Text type Cast = Text type NodeName = Text-type SelectItem = (Field, Maybe Cast, Maybe Alias)++{-|+ This type will hold information about which particular 'Relation' between two tables to choose when there are multiple ones.+ Specifically, it will contain the name of the foreign key or the join table in many to many relations.+-}+type RelationDetail = Text+type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe RelationDetail) -- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"] type EmbedPath = [Text] data Filter = Filter { field::Field, operation::Operation } deriving (Show, Eq) -data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], logic::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } 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] }- | Delete { in_::TableName, where_::[Filter], logic::[LogicTree], returning::[FieldName] }- | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], logic::[LogicTree], returning::[FieldName] } deriving (Show, Eq)-type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))+ | 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 ReadRequest = Tree ReadNode type MutateRequest = MutateQuery data DbRequest = DbRead ReadRequest | DbMutate MutateRequest--instance ToJSON Column where- toJSON c = object [- "schema" .= tableSchema t- , "name" .= colName c- , "position" .= colPosition c- , "nullable" .= colNullable c- , "type" .= colType c- , "updatable" .= colUpdatable c- , "maxLen" .= colMaxLen c- , "precision" .= colPrecision c- , "references".= colFK c- , "default" .= colDefault c- , "enum" .= colEnum c ]- where- t = colTable c--instance ToJSON ForeignKey where- toJSON fk = object [- "schema" .= tableSchema t- , "table" .= tableName t- , "column" .= colName c ]- where- c = fkCol fk- t = colTable c--instance ToJSON Table where- toJSON v = object [- "schema" .= tableSchema v- , "name" .= tableName v- , "insertable" .= tableInsertable v ] instance Eq Table where Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2
test/Feature/AndOrParamsSpec.hs view
@@ -70,20 +70,66 @@ it "can handle is" $ get "/entities?and=(name.is.null,arr.is.null)&select=id" `shouldRespondWith` [json|[{ "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }- it "can handle @@" $+ it "can handle fts" $ do+ get "/entities?or=(text_search_vector.fts.bar,text_search_vector.fts.baz)&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }, { "id": 2 }]|] { 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 @> and <@" $+ it "can handle cs and cd" $ do+ 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`+ [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=neq.[1,3]&select=id" `shouldRespondWith`+ [json|[{ "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=lt.[1,10]&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=gt.[8,11]&select=id" `shouldRespondWith`+ [json|[{ "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=lte.[1,3]&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=gte.[2,3]&select=id" `shouldRespondWith`+ [json|[{ "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=cs.[1,2]&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=cd.[1,6]&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=ov.[0,4]&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=sl.[9,10]&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=sr.[3,4]&select=id" `shouldRespondWith`+ [json|[{ "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=nxr.[4,7]&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=nxl.[4,7]&select=id" `shouldRespondWith`+ [json|[{ "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+ get "/ranges?range=adj.(3,10]&select=id" `shouldRespondWith`+ [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }+ context "operators with not" $ do- it "eq, @>, like can be negated" $+ it "eq, cs, like can be negated" $ do+ 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, @@ can be negated" $+ it "in, is, fts can be negated" $ do+ 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, <@ can be negated" $+ it "lt, gte, cd can be negated" $ do+ 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" $@@ -105,6 +151,29 @@ get "/entities?and=( and ( id.in.( 1, 2, 3 ) , id.eq.3 ) , or ( id.eq.2 , id.eq.3 ) )&select=id" `shouldRespondWith` [json|[{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] } + context "multiple and/or conditions" $ do+ it "cannot have zero conditions" $+ get "/entities?or=()" `shouldRespondWith`+ [json|{+ "details": "unexpected \")\" expecting field name (* or [a..z0..9_]), negation operator (not) or logic operator (and, or)",+ "message": "\"failed to parse logic tree (())\" (line 1, column 4)"+ }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }+ it "can have a single condition" $ do+ get "/entities?or=(id.eq.1)&select=id" `shouldRespondWith`+ [json|[{"id":1}]|] { matchHeaders = [matchContentTypeJson] }+ get "/entities?and=(id.eq.1)&select=id" `shouldRespondWith`+ [json|[{"id":1}]|] { matchHeaders = [matchContentTypeJson] }+ it "can have three conditions" $ do+ get "/grandchild_entities?or=(id.eq.1, id.eq.2, id.eq.3)&select=id" `shouldRespondWith`+ [json|[{"id":1}, {"id":2}, {"id":3}]|] { matchHeaders = [matchContentTypeJson] }+ get "/grandchild_entities?and=(id.in.(1,2), id.in.(3,1), id.in.(1,4))&select=id" `shouldRespondWith`+ [json|[{"id":1}]|] { matchHeaders = [matchContentTypeJson] }+ it "can have four conditions combining and/or" $ do+ get "/grandchild_entities?or=( id.eq.1, id.eq.2, and(id.in.(1,3), id.in.(2,3)), id.eq.4 )&select=id" `shouldRespondWith`+ [json|[{"id":1}, {"id":2}, {"id":3}, {"id":4}]|] { matchHeaders = [matchContentTypeJson] }+ get "/grandchild_entities?and=( id.eq.1, not.or(id.eq.2, id.eq.3), id.in.(1,4), or(id.eq.1, id.eq.4) )&select=id" `shouldRespondWith`+ [json|[{"id":1}]|] { matchHeaders = [matchContentTypeJson] }+ 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}"@@ -145,20 +214,10 @@ }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] } it "fails on malformed query params and provides meaningful error message" $ do- get "/entities?or=()" `shouldRespondWith`- [json|{- "details": "unexpected \")\" expecting field name (* or [a..z0..9_]), negation operator (not) or logic operator (and, or)",- "message": "\"failed to parse logic tree (())\" (line 1, column 4)"- }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] } get "/entities?or=)(" `shouldRespondWith` [json|{ "details": "unexpected \")\" expecting \"(\"", "message": "\"failed to parse logic tree ()()\" (line 1, column 3)"- }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }- get "/entities?or=(id.eq.1)" `shouldRespondWith`- [json|{- "details": "unexpected \")\" expecting \",\"",- "message": "\"failed to parse logic tree ((id.eq.1))\" (line 1, column 11)" }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] } get "/entities?and=(ord(id.eq.1,id.eq.1),id.eq.2)" `shouldRespondWith` [json|{
+ test/Feature/AsymmetricJwtSpec.hs view
@@ -0,0 +1,21 @@+module Feature.AsymmetricJwtSpec where++-- {{{ Imports+import Test.Hspec+import Test.Hspec.Wai+import Network.HTTP.Types++import SpecHelper+import Network.Wai (Application)++import Protolude hiding (get)+-- }}}++spec :: SpecWith Application+spec = describe "server started with asymmetric JWK" $++ -- this test will stop working 9999999999s after the UNIX EPOCH+ it "succeeds with jwt token signed with an asymmetric key" $ do+ let auth = authHeaderJWT "eyJhbGciOiJSUzI1NiJ9.eyJyb2xlIjogInBvc3RncmVzdF90ZXN0X2F1dGhvciJ9Cg.CBOYWDvqgAR0YYnZnyDGTQi6AJLc2Pds6_eV3YuBG6I36mj_h05eLhkEKNEDA5ZteMzCiY83P60rC_xtxVd7B6vo3BeF5uoanPS3rrbuHzKPwzsrgrD_CqvEuJ4n7Q9epkQiLsNkcexneENZDRqFjbwZx3DrXiCWwlK3Ytr5NAIGxmy0od-0xNpb2U1nXQyO_Q3mumWFViRt4tmFn_3goDHNKG3Ha_AzImfUNvHnWL78kAc4rbn15vLtWXD8PwtSnZaB4lY4V6RfsaW937srQsmRetvytM1i_bHBnjkjQLAqGbXPyItjtlXPs0uGNBadE8-wgkLtfmSCC4v2DjUthw"+ request methodGet "/authors_only" [auth] ""+ `shouldRespondWith` 200
test/Feature/AuthSpec.hs view
@@ -28,7 +28,7 @@ } it "denies access to tables that postgrest_test_author does not own" $- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" in+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" in request methodGet "/private_table" [auth] "" `shouldRespondWith` [json| { "hint":null,@@ -42,41 +42,41 @@ it "returns jwt functions as jwt tokens" $ request methodPost "/rpc/login" [single] [json| { "id": "jdoe", "pass": "1234" } |]- `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xuYW1lIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.P2G9EVSVI22MWxXWFuhEYd9BZerLS1WDlqzdqplM15s"} |]+ `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xuYW1lIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.KO-0PGp_rU-utcDBP6qwdd-Th2Fk-ICVt01I7QtTDWs"} |] { matchStatus = 200 , matchHeaders = [matchContentTypeSingular] } it "sql functions can encode custom and standard claims" $ request methodPost "/rpc/jwt_test" [single] "{}"- `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpc3MiOiJqb2UiLCJzdWIiOiJmdW4iLCJhdWQiOiJldmVyeW9uZSIsImV4cCI6MTMwMDgxOTM4MCwibmJmIjoxMzAwODE5MzgwLCJpYXQiOjEzMDA4MTkzODAsImp0aSI6ImZvbyIsInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdCIsImh0dHA6Ly9wb3N0Z3Jlc3QuY29tL2ZvbyI6dHJ1ZX0.IHF16ZSU6XTbOnUWO8CCpUn2fJwt8P00rlYVyXQjpWc"} |]+ `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpc3MiOiJqb2UiLCJzdWIiOiJmdW4iLCJhdWQiOiJldmVyeW9uZSIsImV4cCI6MTMwMDgxOTM4MCwibmJmIjoxMzAwODE5MzgwLCJpYXQiOjEzMDA4MTkzODAsImp0aSI6ImZvbyIsInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdCIsImh0dHA6Ly9wb3N0Z3Jlc3QuY29tL2ZvbyI6dHJ1ZX0.G2REtPnOQMUrVRDA9OnkPJTd8R0tf4wdYOlauh1E2Ek"} |] { matchStatus = 200 , matchHeaders = [matchContentTypeSingular] } it "sql functions can read custom and standard claims variables" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwLCJhdWQiOiJldmVyeW9uZSJ9.AQmCA7CMScvfaDRMqRPeUY6eNf--69gpW-kxaWfq9X0"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwfQ.V5fEpXfpb7feqwVqlcDleFdKu86bdwU2cBRT4fcMhXg" request methodPost "/rpc/reveal_big_jwt" [auth] "{}"- `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","aud":"everyone","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|]+ `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|] it "allows users with permissions to see their tables" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 200 it "works with tokens which have extra fields" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIiwia2V5MSI6InZhbHVlMSIsImtleTIiOiJ2YWx1ZTIiLCJrZXkzIjoidmFsdWUzIiwiYSI6MSwiYiI6MiwiYyI6M30.GfydCh-F4wnM379xs0n1zUgalwJIsb6YoBapCo8HlFk"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIiwia2V5MSI6InZhbHVlMSIsImtleTIiOiJ2YWx1ZTIiLCJrZXkzIjoidmFsdWUzIiwiYSI6MSwiYiI6MiwiYyI6M30.b0eglDKYEmGi-hCvD-ddSqFl7vnDO5qkUaviaHXm3es" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 200 -- this test will stop working 9999999999s after the UNIX EPOCH it "succeeds with an unexpired token" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.QaPPLWTuyydMu_q7H4noMT7Lk6P4muet1OpJXF6ofhc"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 200 it "fails with an expired token" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjE0NDY2NzgxNDksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.enk_qZ_u6gZsXY4R8bREKB_HNExRpM0lIWSLktk9JJQ"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjE0NDY2NzgxNDksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.f8__E6VQwYcDqwHmr9PG03uaZn8Zh1b0vbJ9DYS0AdM" request methodGet "/authors_only" [auth] "" `shouldRespondWith` [json| {"message":"JWT expired"} |] { matchStatus = 401@@ -89,27 +89,27 @@ it "hides tables from users with invalid JWT" $ do let auth = authHeaderJWT "ey9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0" request methodGet "/authors_only" [auth] ""- `shouldRespondWith` [json| {"message":"JWT invalid"} |]+ `shouldRespondWith` [json| {"message":"JWSError (CompactDecodeError \"expected 3 parts, got 2\")"} |] { matchStatus = 401 , matchHeaders = [ "WWW-Authenticate" <:>- "Bearer error=\"invalid_token\", error_description=\"JWT invalid\""+ "Bearer error=\"invalid_token\", error_description=\"JWSError (CompactDecodeError \\\"expected 3 parts, got 2\\\")\"" ] } it "should fail when jwt contains no claims" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.lu-rG8aSCiw-aOlN0IxpRGz5r7Jwq7K9r3tuMPUpytI"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.e30.CUIP5V9thWsGGFsFyGijSZf1fJMfarLHI9CEJL-TGNk" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 401 it "hides tables from users with JWT that contain no claims about role" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.Jneso9X519Vh0z7i9PbXIu7W1HEoq9RRw9BBbyQKFCQ"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Impkb2UifQ.RVlZDaSyKbFPvxUf3V_NQXybfRB4dlBIkAUQXVXLUAI" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 401 it "recovers after 401 error with logged in user" $ do _ <- post "/authors_only" [json| { "owner": "jdoe", "secret": "test content" } |]- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0" _ <- request methodPost "/rpc/problem" [auth] "" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 200@@ -117,7 +117,7 @@ describe "custom pre-request proc acting on id claim" $ do it "able to switch to postgrest_test_author role (id=1)" $- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6MX0.mI2HNoOum6xM3sc4oHLxU4yLv-_WV5W1kqBfY_wEvLw" in+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6MX0.gKw7qI50i9hMrSJW8BlTpdMEVmMXJYxlAqueGqpa_mE" in request methodPost "/rpc/get_current_user" [auth] [json| {} |] `shouldRespondWith` [str|"postgrest_test_author"|]@@ -126,7 +126,7 @@ } it "able to switch to postgrest_test_default_role (id=2)" $- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Mn0.W7jLsG-zswM91AJkCvZeIMHrnz7_6ceY2jnscVl3Yhk" in+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Mn0.nwzjMI0YLvVGJQTeoCPEBsK983b__gxdpLXisBNaO2A" in request methodPost "/rpc/get_current_user" [auth] [json| {} |] `shouldRespondWith` [str|"postgrest_test_default_role"|]@@ -135,7 +135,7 @@ } it "raises error (id=3)" $- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6M30.15Gy8PezQhJIaHYDJVLa-Gmz9T3sJnW66EKAYIsXc7c" in+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6M30.OGxEJAf60NKZiTn-tIb2jy4rqKs_ZruLGWZ40TjrJsM" in request methodPost "/rpc/get_current_user" [auth] [json| {} |] `shouldRespondWith` [str|{"hint":"Please contact administrator","details":null,"code":"P0001","message":"Disabled ID --> 3"}|]
test/Feature/BinaryJwtSecretSpec.hs view
@@ -16,6 +16,6 @@ -- this test will stop working 9999999999s after the UNIX EPOCH it "succeeds with jwt token encoded with a binary secret" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.l_EcSRWeNtL4OKUTIplrHyioNrff9Rd0MV7RXNCxCyk"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 200
test/Feature/InsertSpec.hs view
@@ -451,7 +451,7 @@ describe "Row level permission" $ it "set user_id when inserting rows" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0" _ <- post "/postgrest/users" [json| { "id":"jdoe", "pass": "1234", "role": "postgrest_test_author" } |] _ <- post "/postgrest/users" [json| { "id":"jroe", "pass": "1234", "role": "postgrest_test_author" } |] @@ -464,7 +464,7 @@ p2 <- request methodPost "/authors_only" -- jwt token for jroe- [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.YuF_VfmyIxWyuceT7crnNKEprIYXsJAyXid3rjPjIow", ("Prefer", "return=representation") ]+ [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.2e7mx0U4uDcInlbJVOBGlrRufwqWLINDIEDC1vS0nw8", ("Prefer", "return=representation") ] [json| { "secret": "lolcat", "owner": "hacker" } |] liftIO $ do simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|]
test/Feature/NoJwtSpec.hs view
@@ -16,7 +16,7 @@ -- this test will stop working 9999999999s after the UNIX EPOCH it "responds with error on attempted auth" $ do- let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.QaPPLWTuyydMu_q7H4noMT7Lk6P4muet1OpJXF6ofhc"+ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA" request methodGet "/authors_only" [auth] "" `shouldRespondWith` 500
test/Feature/QuerySpec.hs view
@@ -98,15 +98,29 @@ it "matches with ilike using not operator" $ get "/simple_pk?k=not.ilike.xy*&order=extra.asc" `shouldRespondWith` "[]" - it "matches with tsearch @@" $- get "/tsearch?text_search_vector=@@.foo" `shouldRespondWith`- [json| [{"text_search_vector":"'bar':2 'foo':1"}] |]+ it "matches with tsearch fts" $ do+ get "/tsearch?text_search_vector=fts.impossible" `shouldRespondWith`+ [json| [{"text_search_vector": "'fun':5 'imposs':9 'kind':3" }] |] { matchHeaders = [matchContentTypeJson] }+ get "/tsearch?text_search_vector=fts.possible" `shouldRespondWith`+ [json| [{"text_search_vector": "'also':2 'fun':3 'possibl':8" }] |]+ { matchHeaders = [matchContentTypeJson] }+ -- TODO: remove in 0.5.0 as deprecated+ get "/tsearch?text_search_vector=@@.impossible" `shouldRespondWith`+ [json| [{"text_search_vector": "'fun':5 'imposs':9 'kind':3" }] |]+ { matchHeaders = [matchContentTypeJson] }+ get "/tsearch?text_search_vector=@@.possible" `shouldRespondWith`+ [json| [{"text_search_vector": "'also':2 'fun':3 'possibl':8" }] |]+ { matchHeaders = [matchContentTypeJson] } - it "matches with tsearch @@ using not operator" $- get "/tsearch?text_search_vector=not.@@.foo" `shouldRespondWith`- [json| [{"text_search_vector":"'baz':1 'qux':2"}] |]+ it "matches with tsearch fts using not operator" $ do+ get "/tsearch?text_search_vector=not.fts.impossible" `shouldRespondWith`+ [json| [{"text_search_vector": "'also':2 'fun':3 'possibl':8" }] |] { matchHeaders = [matchContentTypeJson] }+ -- TODO: remove in 0.5.0 as deprecated+ get "/tsearch?text_search_vector=not.@@.impossible" `shouldRespondWith`+ [json| [{"text_search_vector": "'also':2 'fun':3 'possibl':8" }] |]+ { matchHeaders = [matchContentTypeJson] } it "matches with computed column" $ get "/items?always_true=eq.true&order=id.asc" `shouldRespondWith`@@ -129,11 +143,17 @@ get "/clients?select=id,projects{id,tasks{id,name}}&projects.tasks.name=like.Design*" `shouldRespondWith` [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1,"name":"Design w7"}]},{"id":2,"tasks":[{"id":3,"name":"Design w10"}]}]},{"id":2,"projects":[{"id":3,"tasks":[{"id":5,"name":"Design IOS"}]},{"id":4,"tasks":[{"id":7,"name":"Design OSX"}]}]}]|] - it "matches with @> operator" $+ it "matches with cs operator" $ do+ get "/complex_items?select=id&arr_data=cs.{2}" `shouldRespondWith`+ [str|[{"id":2},{"id":3}]|]+ -- TODO: remove in 0.5.0 as deprecated get "/complex_items?select=id&arr_data=@>.{2}" `shouldRespondWith` [str|[{"id":2},{"id":3}]|] - it "matches with <@ operator" $+ it "matches with cd operator" $ do+ get "/complex_items?select=id&arr_data=cd.{1,2,4}" `shouldRespondWith`+ [str|[{"id":1},{"id":2}]|]+ -- TODO: remove in 0.5.0 as deprecated get "/complex_items?select=id&arr_data=<@.{1,2,4}" `shouldRespondWith` [str|[{"id":1},{"id":2}]|] @@ -258,10 +278,18 @@ get "/clients?id=eq.1&select=id,projects{id,tasks{id}}" `shouldRespondWith` [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|] + it "requesting children 2 levels (with relation path fixed)" $+ get "/clients?id=eq.1&select=id,projects:projects.client_id{id,tasks{id}}" `shouldRespondWith`+ [str|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|]+ it "requesting many<->many relation" $ get "/tasks?select=id,users{id}" `shouldRespondWith` [str|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|] + it "requesting many<->many relation (with relation path fixed)" $+ get "/tasks?select=id,users:users.users_tasks{id}" `shouldRespondWith`+ [str|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|]+ it "requesting many<->many relation with rename" $ get "/tasks?id=eq.1&select=id,theUsers:users{id}" `shouldRespondWith` [str|[{"id":1,"theUsers":[{"id":1},{"id":3}]}]|]@@ -553,6 +581,18 @@ [json|"Hello, ￥"|] { matchHeaders = [matchContentTypeJson] } + it "returns array" $+ post "/rpc/ret_array" [json|{}|] `shouldRespondWith`+ [json|[1, 2, 3]|]+ { matchHeaders = [matchContentTypeJson] }++ it "returns setof integers" $+ post "/rpc/ret_setof_integers" [json|{}|] `shouldRespondWith`+ [json|[{ "ret_setof_integers": 1 },+ { "ret_setof_integers": 2 },+ { "ret_setof_integers": 3 }]|]+ { matchHeaders = [matchContentTypeJson] }+ it "returns enum value" $ post "/rpc/ret_enum" [json|{ "val": "foo" }|] `shouldRespondWith` [json|"foo"|]@@ -655,6 +695,10 @@ [json| "Return value of no parameters procedure." |] { matchHeaders = [matchContentTypeJson] } + it "returns proper output when having the same return col name as the proc name" $+ post "/rpc/test" [json|{}|] `shouldRespondWith`+ [json|[{"test":"hello","value":1}]|] { matchHeaders = [matchContentTypeJson] }+ describe "weird requests" $ do it "can query as normal" $ do get "/Escap3e;" `shouldRespondWith`@@ -681,27 +725,50 @@ { matchHeaders = [matchContentTypeJson] } describe "binary output" $ do- it "can query if a single column is selected" $- request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"- { matchStatus = 200- , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]- }+ context "on GET" $ do+ it "can query if a single column is selected" $+ request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+ } - it "fails if a single column is not selected" $ do- request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` 406- request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` 406- request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") ""- `shouldRespondWith` 406+ it "fails if a single column is not selected" $ do+ request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` 406+ request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` 406+ request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") ""+ `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") ""- `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="- { matchStatus = 200- , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]- }+ 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") ""+ `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII="+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+ }++ context "on RPC" $ do+ context "Proc that returns scalar" $+ it "can query without selecting column" $+ request methodPost "/rpc/ret_base64_bin" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC"+ { matchStatus = 200+ , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]+ }++ context "Proc that returns rows" $ do+ it "can query if a single column is selected" $+ request methodPost "/rpc/ret_rows_with_base64_bin?select=img" (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"]+ }++ it "fails if a single column is not selected" $+ request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") ""+ `shouldRespondWith` 406+ describe "HTTP request env vars" $ do it "custom header is set" $ request methodPost "/rpc/get_guc_value"
test/Feature/StructureSpec.hs view
@@ -27,18 +27,96 @@ (acceptHdrs "application/openapi+json") "" `shouldRespondWith` 415 - describe "RPC" $+ describe "table" $ - it "includes a representative function with parameters" $ do+ it "includes paths to tables" $ do r <- simpleBody <$> get "/"- let ref = r ^? key "paths" . key "/rpc/varied_arguments"- . key "post" . key "parameters"- . nth 1 . key "schema"- . key "$ref" . _String- args = r ^? key "definitions" . key "(rpc) varied_arguments" + let method s = key "paths" . key "/child_entities" . key s+ childGetSummary = r ^? method "get" . key "summary"+ childGetDescription = r ^? method "get" . key "description"+ getParameters = r ^? method "get" . key "parameters"+ postResponse = r ^? method "post" . key "responses" . key "201" . key "description"+ patchResponse = r ^? method "patch" . key "responses" . key "204" . key "description"+ deleteResponse = r ^? method "delete" . key "responses" . key "204" . key "description"++ let grandChildGet s = key "paths" . key "/grandchild_entities" . key "get" . key s+ grandChildGetSummary = r ^? grandChildGet "summary"+ grandChildGetDescription = r ^? grandChildGet "description"+ liftIO $ do- ref `shouldBe` Just "#/definitions/(rpc) varied_arguments"++ childGetSummary `shouldBe` Just "child_entities comment"++ childGetDescription `shouldBe` Nothing++ grandChildGetSummary `shouldBe` Just "grandchild_entities summary"++ grandChildGetDescription `shouldBe` Just "grandchild_entities description\nthat spans\nmultiple lines"++ getParameters `shouldBe` Just+ [aesonQQ|+ [+ { "$ref": "#/parameters/rowFilter.child_entities.id" },+ { "$ref": "#/parameters/rowFilter.child_entities.name" },+ { "$ref": "#/parameters/rowFilter.child_entities.parent_id" },+ { "$ref": "#/parameters/select" },+ { "$ref": "#/parameters/order" },+ { "$ref": "#/parameters/range" },+ { "$ref": "#/parameters/rangeUnit" },+ { "$ref": "#/parameters/offset" },+ { "$ref": "#/parameters/limit" },+ { "$ref": "#/parameters/preferCount" }+ ]+ |]++ postResponse `shouldBe` Just "Created"++ patchResponse `shouldBe` Just "No Content"++ deleteResponse `shouldBe` Just "No Content"++ it "includes definitions to tables" $ do+ r <- simpleBody <$> get "/"++ let def = r ^? key "definitions" . key "child_entities"++ liftIO $++ def `shouldBe` Just+ [aesonQQ|+ {+ "type": "object",+ "description": "child_entities comment",+ "properties": {+ "id": {+ "description": "child_entities id comment\n\nNote:\nThis is a Primary Key.<pk/>",+ "format": "integer",+ "type": "integer"+ },+ "name": {+ "description": "child_entities name comment",+ "format": "text",+ "type": "string"+ },+ "parent_id": {+ "description": "Note:\nThis is a Foreign Key to `entities.id`.<fk table='entities' column='id'/>",+ "format": "integer",+ "type": "integer"+ }+ }+ }+ |]++ describe "RPC" $++ it "includes body schema for arguments" $ do+ r <- simpleBody <$> get "/"+ let args = r ^? key "paths" . key "/rpc/varied_arguments"+ . key "post" . key "parameters"+ . nth 0 . key "schema"++ liftIO $ args `shouldBe` Just [aesonQQ| {
test/Main.hs view
@@ -7,12 +7,11 @@ import PostgREST.DbStructure (getDbStructure) import PostgREST.App (postgrest)-import Control.AutoUpdate import Data.Function (id) import Data.IORef-import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Feature.AuthSpec+import qualified Feature.AsymmetricJwtSpec import qualified Feature.BinaryJwtSecretSpec import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec@@ -36,19 +35,16 @@ setupDb testDbConn pool <- P.acquire (3, 10, toS testDbConn)- -- ask for the OS time at most once per second- getTime <- mkAutoUpdate- defaultUpdateSettings { updateAction = getPOSIXTime } - result <- P.use pool $ getDbStructure "test" refDbStructure <- newIORef $ Just $ either (panic.show) id result- 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 ()+ 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 ()+ asymJwkApp = return $ postgrest (testCfgAsymJWK testDbConn) refDbStructure pool $ pure () let reset = resetDb testDbConn hspec $ do@@ -73,6 +69,10 @@ -- this test runs with a binary JWT secret beforeAll_ reset . before binaryJwtApp $ describe "Feature.BinaryJwtSecretSpec" Feature.BinaryJwtSecretSpec.spec++ -- this test runs with asymmetric JWK+ beforeAll_ reset . before asymJwkApp $+ describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec where specs = map (uncurry describe) [
test/SpecHelper.hs view
@@ -13,7 +13,8 @@ import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL-import System.Process (readProcess)+import System.Process (readProcess)+import Text.Heredoc import PostgREST.Config (AppConfig(..)) @@ -67,7 +68,7 @@ _baseCfg = -- Connection Settings AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000 -- Jwt settings- (Just $ encodeUtf8 "safe") False+ (Just $ encodeUtf8 "reallyreallyreallyreallyverysafe") False -- Connection Modifiers 10 Nothing (Just "test.switch_role") -- Debug Settings@@ -89,9 +90,16 @@ testProxyCfg testDbConn = (testCfg testDbConn) { configProxyUri = Just "https://postgrest.com/openapi.json" } testCfgBinaryJWT :: Text -> AppConfig-testCfgBinaryJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Just secretBs }- where secretBs = B64.decodeLenient "h2CGB1FoBd51aQooCS2g+UmRgYQfTPQ6v3+9ALbaqM4="+testCfgBinaryJWT testDbConn = (testCfg testDbConn) {+ configJwtSecret = Just . B64.decodeLenient $+ "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU="+ } +testCfgAsymJWK :: Text -> AppConfig+testCfgAsymJWK testDbConn = (testCfg testDbConn) {+ configJwtSecret = Just $ encodeUtf8+ [str|{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}|]+ } setupDb :: Text -> IO () setupDb dbConn = do