diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,66 @@ ### Fixed +## [8.0.0] - 2021-07-25 + +### Added + + - #1525, Allow http status override through response.status guc - @steve-chavez + - #1512, Allow schema cache reloading with NOTIFY - @steve-chavez + - #1119, Allow config file reloading with SIGUSR2 - @steve-chavez + - #1558, Allow 'Bearer' with and without capitalization as authentication schema - @wolfgangwalther + - #1470, Allow calling RPC with variadic argument by passing repeated params - @wolfgangwalther + - #1559, No downtime when reloading the schema cache with SIGUSR1 - @steve-chavez + - #504, Add `log-level` config option. The admitted levels are: crit, error, warn and info - @steve-chavez + - #1607, Enable embedding through multiple views recursively - @wolfgangwalther + - #1598, Allow rollback of the transaction with Prefer tx=rollback - @wolfgangwalther + - #1633, Enable prepared statements for GET filters. When behind a connection pooler, you can disable preparing with `db-prepared-statements=false` + + This increases throughput by around 30% for simple GET queries(no embedding, with filters applied). + - #1729, #1760, Get configuration parameters from the db and allow reloading config with NOTIFY - @steve-chavez + - #1824, Allow OPTIONS to generate certain HTTP methods for a DB view - @laurenceisla + - #1872, Show timestamps in startup/worker logs - @steve-chavez + - #1881, Add `openapi-mode` config option that allows ignoring roles privileges when showing the OpenAPI output - @steve-chavez + - CLI options(for debugging): + + #1678, Add --dump-config CLI option that prints loaded config and exits - @wolfgangwalther + + #1691, Add --example CLI option to show example config file - @wolfgangwalther + + #1697, #1723, Add --dump-schema CLI option for debugging purposes - @monacoremo, @wolfgangwalther + - #1794, (Experimental) Add `request.spec` GUC for db-root-spec - @steve-chavez + +### Fixed + + - #1592, Removed single column restriction to allow composite foreign keys in join tables - @goteguru + - #1530, Fix how the PostgREST version is shown in the help text when the `.git` directory is not available - @monacoremo + - #1094, Fix expired JWTs starting an empty transaction on the db - @steve-chavez + - #1162, Fix location header for POST request with select= without PK - @wolfgangwalther + - #1585, Fix error messages on connection failure for localized postgres on Windows - @wolfgangwalther + - #1636, Fix `application/octet-stream` appending `charset=utf-8` - @steve-chavez + - #1469, #1638 Fix overloading of functions with unnamed arguments - @wolfgangwalther + - #1560, Return 405 Method not Allowed for GET of volatile RPC instead of 500 - @wolfgangwalther + - #1584, Fix RPC return type handling and embedding for domains with composite base type (#1615) - @wolfgangwalther + - #1608, #1635, Fix embedding through views that have COALESCE with subselect - @wolfgangwalther + - #1572, Fix parsing of boolean config values for Docker environment variables, now it accepts double quoted truth values ("true", "false") and numbers("1", "0") - @wolfgangwalther + - #1624, Fix using `app.settings.xxx` config options in Docker, now they can be used as `PGRST_APP_SETTINGS_xxx` - @wolfgangwalther + - #1814, Fix panic when attempting to run with unix socket on non-unix host and properly close unix domain socket on exit - @monacoremo + - #1825, Disregard internal junction(in non-exposed schema) when embedding - @steve-chavez + - #1846, Fix requests for overloaded functions from html forms to no longer hang (#1848) - @laurenceisla + - #1858, Add a hint and clarification to the no relationship found error - @laurenceisla + - #1841, Show comprehensive error when an RPC is not found in a stale schema cache - @laurenceisla + - #1875, Fix Location headers in headers only representation for null PK inserts on views - @laurenceisla + +### Changed + + - #1522, #1528, #1535, Docker images are now built from scratch based on a the static PostgREST executable (#1494) and with Nix instead of a `Dockerfile`. This reduces the compressed image size from over 30mb to about 4mb - @monacoremo + - #1461, Location header for POST request is only included when PK is available on the table - @wolfgangwalther + - #1560, Volatile RPC called with GET now returns 405 Method not Allowed instead of 500 - @wolfgangwalther + - #1584, #1849 Functions that declare `returns composite_type` no longer return a single object array by default, only functions with `returns setof composite_type` return an array of objects - @wolfgangwalther + - #1604, Change the default logging level to `log-level=error`. Only requests with a status greater or equal than 500 will be logged. If you wish to go back to the previous behaviour and log all the requests, use `log-level=info` - @steve-chavez + + Because currently there's no buffering for logging, defaulting to the `error` level(minimum logging) increases throughput by around 15% for simple GET queries(no embedding, with filters applied). + - #1617, Dropped support for PostgreSQL 9.4 - @wolfgangwalther + - #1679, Renamed config settings with fallback aliases. e.g. `max-rows` is now `db-max-rows`, but `max-rows` is still accepted - @wolfgangwalther + - #1656, Allow `Prefer=headers-only` on POST requests and change default to `minimal` (#1813) - @laurenceisla + - #1854, Dropped undocumented support for gzip compression (which was surprisingly slow and easily enabled by mistake). In some use-cases this makes Postgres up to 3x faster - @aljungberg + - #1872, Send startup/worker logs to stderr to differentiate from access logs on stdout - @steve-chavez + ## [7.0.1] - 2020-05-18 ### Fixed @@ -18,6 +78,10 @@ - #1500, Fix missing `openapi-server-proxy-uri` config option - @steve-chavez - #1508, Fix `Content-Profile` not working for POST RPC - @steve-chavez - #1452, Fix PUT restriction for all columns - @steve-chavez + +### Changed + +- From this version onwards, the release page will only include a single Linux static executable that can be run on any Linux distribution. ## [7.0.0] - 2020-04-03 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ +-- This file is required by Hackage. import Distribution.Simple main = defaultMain diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,330 +1,47 @@ {-# LANGUAGE CPP #-} -module Main where +module Main (main) where -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import qualified Hasql.Pool as P -import qualified Hasql.Transaction.Sessions as HT +import qualified Data.Map.Strict as M -import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, - updateAction) -import Control.Retry (RetryStatus, capDelay, - exponentialBackoff, retrying, - rsPreviousDelay) -import Data.Either.Combinators (whenLeft) -import Data.IORef (IORef, atomicWriteIORef, newIORef, - readIORef) -import Data.String (IsString (..)) -import Data.Text (pack, replace, strip, stripPrefix) -import Data.Text.IO (hPutStrLn) -import Data.Time.Clock (getCurrentTime) -import Network.Wai.Handler.Warp (defaultSettings, runSettings, - setHost, setPort, setServerName) -import System.IO (BufferMode (..), hSetBuffering) +import System.IO (BufferMode (..), hSetBuffering) -import PostgREST.App (postgrest) -import PostgREST.Config (AppConfig (..), configPoolTimeout', - prettyVersion, readOptions) -import PostgREST.DbStructure (getDbStructure, getPgVersion) -import PostgREST.Error (PgError (PgError), checkIsFatal, - errorPayload) -import PostgREST.OpenAPI (isMalformedProxyUri) -import PostgREST.Types (ConnectionStatus (..), DbStructure, - PgVersion (..), Schema, - minimumPgVersion) -import Protolude hiding (hPutStrLn, head, replace, toS) -import Protolude.Conv (toS) +import qualified PostgREST.App as App +import qualified PostgREST.CLI as CLI +import PostgREST.Config (readPGRSTEnvironment) +import Protolude + #ifndef mingw32_HOST_OS -import System.Posix.Signals -import UnixSocket +import qualified PostgREST.Unix as Unix #endif - -{-| - 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. - 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. --} -connectionWorker - :: ThreadId -- ^ This thread is killed if pg version is unsupported - -> P.Pool -- ^ The PostgreSQL connection pool - -> [Schema] -- ^ Schemas PostgREST is serving up - -> IORef (Maybe DbStructure) -- ^ mutable reference to 'DbStructure' - -> IORef Bool -- ^ Used as a binary Semaphore - -> IO () -connectionWorker mainTid pool schemas refDbStructure refIsWorkerOn = do - isWorkerOn <- readIORef refIsWorkerOn - unless isWorkerOn $ do - atomicWriteIORef refIsWorkerOn True - void $ forkIO work - where - work = do - atomicWriteIORef refDbStructure Nothing - putStrLn ("Attempting to connect to the database..." :: Text) - connected <- connectionStatus pool - case connected of - FatalConnectionError reason -> hPutStrLn stderr reason - >> killThread mainTid -- Fatal error when connecting - NotConnected -> return () -- Unreachable - Connected actualPgVersion -> do -- Procede with initialization - result <- P.use pool $ do - dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schemas actualPgVersion - liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure - case result of - Left e -> do - putStrLn ("Failed to query the database. Retrying." :: Text) - hPutStrLn stderr . toS . errorPayload $ PgError False e - work - - Right _ -> do - atomicWriteIORef refIsWorkerOn False - putStrLn ("Connection successful" :: Text) - -{-| - 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. --} -connectionStatus :: P.Pool -> IO ConnectionStatus -connectionStatus pool = - retrying (capDelay 32000000 $ exponentialBackoff 1000000) - shouldRetry - (const $ P.release pool >> getConnectionStatus) - where - getConnectionStatus :: IO ConnectionStatus - getConnectionStatus = do - pgVersion <- P.use pool getPgVersion - case pgVersion of - Left e -> do - let err = PgError False e - hPutStrLn stderr . toS $ errorPayload err - case checkIsFatal err of - Just reason -> return $ FatalConnectionError reason - Nothing -> return NotConnected - - Right version -> - if version < minimumPgVersion - then return . FatalConnectionError $ "Cannot run in this PostgreSQL version, PostgREST needs at least " <> pgvName minimumPgVersion - else return . Connected $ version - - shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool - shouldRetry rs isConnSucc = do - let delay = fromMaybe 0 (rsPreviousDelay rs) `div` 1000000 - itShould = NotConnected == isConnSucc - when itShould $ - 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 stderr NoBuffering - -- - -- readOptions builds the 'AppConfig' from the config file specified on the - -- command line - conf <- loadDbUriFile =<< loadSecretFile =<< readOptions - let schemas = toList $ configSchemas conf - host = configHost conf - port = configPort conf - proxy = configOpenAPIProxyUri conf - maybeSocketAddr = configSocket conf - socketFileMode = configSocketMode conf - pgSettings = toS (configDatabase conf) -- is the db-uri - roleClaimKey = configRoleClaimKey conf - appSettings = - setHost ((fromString . toS) host) -- Warp settings - . setPort port - . setServerName (toS $ "postgrest/" <> prettyVersion) $ - defaultSettings - - - whenLeft socketFileMode panic - - -- Checks that the provided proxy uri is formated correctly - when (isMalformedProxyUri $ toS <$> proxy) $ - panic - "Malformed proxy uri, a correct example: https://example.com:8443/basePath" - - -- Checks that the provided jspath is valid - whenLeft roleClaimKey $ - panic $ show roleClaimKey + setBuffering + hasPGRSTEnv <- not . M.null <$> readPGRSTEnvironment + opts <- CLI.readCLIShowHelp hasPGRSTEnv + CLI.main installSignalHandlers runAppInSocket opts - -- create connection pool with the provided settings, returns either - -- a 'Connection' or a 'ConnectionError'. Does not throw. - pool <- P.acquire (configPool conf, configPoolTimeout' conf, 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 - -- - -- Sets the refDbStructure - connectionWorker - mainTid - pool - schemas - 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. +installSignalHandlers :: App.SignalHandlerInstaller #ifndef mingw32_HOST_OS - forM_ [sigINT, sigTERM] $ \sig -> - void $ installHandler sig (Catch $ do - P.release pool - throwTo mainTid UserInterrupt - ) Nothing - - void $ installHandler sigUSR1 ( - Catch $ connectionWorker - mainTid - pool - schemas - refDbStructure - refIsWorkerOn - ) Nothing +installSignalHandlers = Unix.installSignalHandlers +#else +installSignalHandlers _ = pass #endif - - -- ask for the OS time at most once per second - getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} - - let postgrestApplication = - postgrest - conf - refDbStructure - pool - getTime - (connectionWorker - mainTid - pool - schemas - refDbStructure - refIsWorkerOn) - - -- run the postgrest application with user defined socket. Only for UNIX systems. +runAppInSocket :: Maybe App.SocketRunner #ifndef mingw32_HOST_OS - whenJust maybeSocketAddr $ - runAppInSocket appSettings postgrestApplication socketFileMode +runAppInSocket = Just Unix.runAppWithSocket +#else +runAppInSocket = Nothing #endif - -- run the postgrest application - whenNothing maybeSocketAddr $ do - putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) - runSettings appSettings postgrestApplication - -{-| - 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 - -- - -- 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 secret) = - fmap setSecret $ - transformString isB64 =<< - case stripPrefix "@" secret of - Nothing -> return . encodeUtf8 $ secret - Just filename -> chomp <$> BS.readFile (toS filename) - where - chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs) - -- - -- Turns the Base64url encoded JWT into Base64 - transformString :: Bool -> ByteString -> IO ByteString - transformString False t = return t - transformString True t = - case B64.decode $ encodeUtf8 $ strip $ replaceUrlChars $ decodeUtf8 t of - Left errMsg -> panic $ pack errMsg - Right bs -> return bs - setSecret bs = conf {configJwtSecret = Just bs} - -- - -- replace: Replace every occurrence of one substring with another - replaceUrlChars = - replace "_" "/" . replace "-" "+" . replace "." "=" - -{- - Load database uri from a separate file if `db-uri` is a filepath. --} -loadDbUriFile :: AppConfig -> IO AppConfig -loadDbUriFile conf = extractDbUri mDbUri - where - mDbUri = configDatabase conf - extractDbUri :: Text -> IO AppConfig - extractDbUri dbUri = - fmap setDbUri $ - case stripPrefix "@" dbUri of - Nothing -> return dbUri - Just filename -> strip <$> readFile (toS filename) - setDbUri dbUri = conf {configDatabase = dbUri} - --- Utilitarian functions. -whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f () -whenJust (Just x) f = f x -whenJust Nothing _ = pass - -whenNothing :: Applicative f => Maybe a -> f () -> f () -whenNothing Nothing f = f -whenNothing _ _ = pass +setBuffering :: IO () +setBuffering = 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 + hSetBuffering stdout LineBuffering + hSetBuffering stdin LineBuffering + hSetBuffering stderr LineBuffering diff --git a/main/UnixSocket.hs b/main/UnixSocket.hs deleted file mode 100644 --- a/main/UnixSocket.hs +++ /dev/null @@ -1,40 +0,0 @@ -module UnixSocket ( - runAppInSocket -)where - -import Network.Socket (Family (AF_UNIX), - SockAddr (SockAddrUnix), Socket, - SocketType (Stream), bind, close, - defaultProtocol, listen, - maxListenQueue, socket) -import Network.Wai (Application) -import Network.Wai.Handler.Warp -import System.Directory (removeFile) -import System.IO.Error (isDoesNotExistError) -import System.Posix.Files (setFileMode) -import System.Posix.Types (FileMode) - -import Protolude - -createAndBindSocket :: FilePath -> Maybe FileMode -> IO Socket -createAndBindSocket socketFilePath maybeSocketFileMode = do - deleteSocketFileIfExist socketFilePath - sock <- socket AF_UNIX Stream defaultProtocol - bind sock $ SockAddrUnix socketFilePath - mapM_ (setFileMode socketFilePath) maybeSocketFileMode - return sock - where - deleteSocketFileIfExist path = removeFile path `catch` handleDoesNotExist - handleDoesNotExist e - | isDoesNotExistError e = return () - | otherwise = throwIO e - --- run the postgrest application with user defined socket. -runAppInSocket :: Settings -> Application -> Either Text FileMode -> FilePath -> IO () -runAppInSocket settings app socketFileMode sockPath = do - sock <- createAndBindSocket sockPath (rightToMaybe socketFileMode) - putStrLn $ ("Listening on unix socket " :: Text) <> show sockPath - listen sock maxListenQueue - runSettingsSocket settings sock app - -- clean socket up when done - close sock diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -1,5 +1,5 @@ name: postgrest -version: 7.0.1 +version: 8.0.0 synopsis: REST API for any Postgres database description: Reads the schema of a PostgreSQL database and creates RESTful routes for the tables and views, supporting all HTTP verbs that security @@ -19,36 +19,59 @@ type: git location: git://github.com/PostgREST/postgrest.git -flag FailOnWarn +flag dev default: False manual: True - description: No warnings allowed + description: Development flags +flag hpc + default: True + manual: True + description: Enable HPC (dev only) + library - exposed-modules: PostgREST.ApiRequest - PostgREST.App + default-language: Haskell2010 + default-extensions: OverloadedStrings + NoImplicitPrelude + hs-source-dirs: src + exposed-modules: PostgREST.App + PostgREST.AppState PostgREST.Auth + PostgREST.CLI PostgREST.Config - PostgREST.DbRequestBuilder + PostgREST.Config.Database + PostgREST.Config.JSPath + PostgREST.Config.PgVersion + PostgREST.Config.Proxy + PostgREST.ContentType PostgREST.DbStructure + PostgREST.DbStructure.Identifiers + PostgREST.DbStructure.Proc + PostgREST.DbStructure.Relationship + PostgREST.DbStructure.Table PostgREST.Error + PostgREST.GucHeader PostgREST.Middleware PostgREST.OpenAPI - PostgREST.Parsers - PostgREST.QueryBuilder - PostgREST.Statements + PostgREST.Query.QueryBuilder + PostgREST.Query.SqlFragment + PostgREST.Query.Statements PostgREST.RangeQuery - PostgREST.Types + PostgREST.Request.ApiRequest + PostgREST.Request.DbRequestBuilder + PostgREST.Request.Parsers + PostgREST.Request.Preferences + PostgREST.Request.Types + PostgREST.Version + PostgREST.Workers other-modules: Paths_postgrest - PostgREST.Private.Common - PostgREST.Private.QueryFragment - hs-source-dirs: src build-depends: base >= 4.9 && < 4.15 , HTTP >= 4000.3.7 && < 4000.4 , Ranged-sets >= 0.3 && < 0.5 - , aeson >= 1.4.7 && < 1.5 + , aeson >= 1.4.7 && < 1.6 , ansi-wl-pprint >= 0.6.7 && < 0.7 - , base64-bytestring >= 1 && < 1.2 + , auto-update >= 0.1.4 && < 0.2 + , base64-bytestring >= 1 && < 1.3 , bytestring >= 0.10.8 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , cassava >= 0.4.5 && < 0.6 @@ -58,22 +81,27 @@ , contravariant-extras >= 0.3.3 && < 0.4 , cookie >= 0.4.2 && < 0.5 , either >= 4.4.1 && < 5.1 + , fast-logger >= 2.4.5 , gitrev >= 1.2 && < 1.4 , hasql >= 1.4 && < 1.5 + , hasql-dynamic-statements == 0.3.1 + , hasql-notifications >= 0.1 && < 0.3 , hasql-pool >= 0.5 && < 0.6 - , hasql-transaction >= 0.7.2 && < 1.1 + , hasql-transaction >= 1.0.1 && < 1.1 , heredoc >= 0.2 && < 0.3 , http-types >= 0.12.2 && < 0.13 , insert-ordered-containers >= 0.2.2 && < 0.3 , interpolatedstring-perl6 >= 1 && < 1.1 , jose >= 0.8.1 && < 0.9 - , lens >= 4.14 && < 4.20 + , lens >= 4.14 && < 5.1 , lens-aeson >= 1.0.1 && < 1.2 + , mtl >= 2.2.2 && < 2.3 , network-uri >= 2.6.1 && < 2.8 - , optparse-applicative >= 0.13 && < 0.16 + , optparse-applicative >= 0.13 && < 0.17 , parsec >= 3.1.11 && < 3.2 , protolude >= 0.3 && < 0.4 , regex-tdfa >= 1.2.2 && < 1.4 + , retry >= 0.7.4 && < 0.9 , scientific >= 0.3.4 && < 0.4 , swagger2 >= 2.4 && < 2.7 , text >= 1.2.2 && < 1.3 @@ -82,63 +110,61 @@ , vector >= 0.11 && < 0.13 , wai >= 3.2.1 && < 3.3 , wai-cors >= 0.2.5 && < 0.3 - , wai-extra >= 3.0.19 && < 3.1 - , wai-middleware-static >= 0.8.1 && < 0.9 - default-language: Haskell2010 - default-extensions: OverloadedStrings - QuasiQuotes - NoImplicitPrelude - if flag(FailOnWarn) - ghc-options: -O2 -Werror -Wall -fwarn-identities - -fno-spec-constr -optP-Wno-nonportable-include-path + , wai-extra >= 3.0.19 && < 3.2 + , wai-logger >= 2.3.2 + , wai-middleware-static >= 0.8.1 && < 0.10 + , warp >= 3.2.12 && < 3.4 + -- -fno-spec-constr may help keep compile time memory use in check, + -- see https://gitlab.haskell.org/ghc/ghc/issues/16017#note_219304 + -- -optP-Wno-nonportable-include-path + -- prevents build failures on case-insensitive filesystems (macos), + -- see https://github.com/commercialhaskell/stack/issues/3918 + ghc-options: -Wall -fwarn-identities + -fno-spec-constr -optP-Wno-nonportable-include-path + + if flag(dev) + ghc-options: --disable-optimizations + if flag(hpc) + ghc-options: --enable-coverage -hpcdir .hpc else - ghc-options: -O2 -Wall -fwarn-identities - -fno-spec-constr -optP-Wno-nonportable-include-path - -- -fno-spec-constr may help keep compile time memory use in check, - -- see https://gitlab.haskell.org/ghc/ghc/issues/16017#note_219304 - -- -optP-Wno-nonportable-include-path - -- prevents build failures on case-insensitive filesystems (macos), - -- see https://github.com/commercialhaskell/stack/issues/3918 + ghc-options: -O2 + if !os(windows) + build-depends: + unix + , directory >= 1.2.6 && < 1.4 + , network >= 2.6 && < 3.2 + exposed-modules: + PostgREST.Unix + executable postgrest - main-is: Main.hs - hs-source-dirs: main - build-depends: base >= 4.9 && < 4.15 - , auto-update >= 0.1.4 && < 0.2 - , base64-bytestring >= 1 && < 1.2 - , bytestring >= 0.10.8 && < 0.11 - , directory >= 1.2.6 && < 1.4 - , either >= 4.4.1 && < 5.1 - , hasql >= 1.4 && < 1.5 - , hasql-pool >= 0.5 && < 0.6 - , hasql-transaction >= 0.7.2 && < 1.1 - , network < 3.2 - , postgrest - , protolude >= 0.3 && < 0.4 - , retry >= 0.7.4 && < 0.9 - , text >= 1.2.2 && < 1.3 - , time >= 1.6 && < 1.11 - , wai >= 3.2.1 && < 3.3 - , warp >= 3.2.12 && < 3.4 default-language: Haskell2010 default-extensions: OverloadedStrings - QuasiQuotes NoImplicitPrelude - if flag(FailOnWarn) - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -I2" - -O2 -Werror -Wall -fwarn-identities - -fno-spec-constr -optP-Wno-nonportable-include-path - else - ghc-options: -threaded -rtsopts "-with-rtsopts=-N -I2" + hs-source-dirs: main + main-is: Main.hs + build-depends: base >= 4.9 && < 4.15 + , containers >= 0.5.7 && < 0.7 + , postgrest + , protolude >= 0.3 && < 0.4 + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -I2" -O2 -Wall -fwarn-identities -fno-spec-constr -optP-Wno-nonportable-include-path - if !os(windows) - build-depends: unix - other-modules: UnixSocket + if flag(dev) + ghc-options: --disable-optimizations + if flag(hpc) + ghc-options: --enable-coverage -hpcdir .hpc + else + ghc-options: -O2 test-suite spec type: exitcode-stdio-1.0 + default-language: Haskell2010 + default-extensions: OverloadedStrings + QuasiQuotes + NoImplicitPrelude + hs-source-dirs: test main-is: Main.hs other-modules: Feature.AndOrParamsSpec Feature.AsymmetricJwtSpec @@ -148,36 +174,39 @@ Feature.ConcurrentSpec Feature.CorsSpec Feature.DeleteSpec + Feature.DisabledOpenApiSpec Feature.EmbedDisambiguationSpec Feature.ExtraSearchPathSpec + Feature.HtmlRawOutputSpec Feature.InsertSpec + Feature.IgnorePrivOpenApiSpec Feature.JsonOperatorSpec + Feature.MultipleSchemaSpec Feature.NoJwtSpec Feature.NonexistentSchemaSpec - Feature.PgVersion95Spec - Feature.PgVersion96Spec + Feature.OpenApiSpec + Feature.OptionsSpec Feature.ProxySpec Feature.QueryLimitedSpec Feature.QuerySpec Feature.RangeSpec + Feature.RawOutputTypesSpec + Feature.RollbackSpec Feature.RootSpec + Feature.RpcPreRequestGucsSpec Feature.RpcSpec Feature.SingularSpec - Feature.StructureSpec Feature.UnicodeSpec + Feature.UpdateSpec Feature.UpsertSpec - Feature.RawOutputTypesSpec - Feature.HtmlRawOutputSpec - Feature.MultipleSchemaSpec SpecHelper TestTypes - hs-source-dirs: test build-depends: base >= 4.9 && < 4.15 - , aeson >= 1.4.7 && < 1.5 + , aeson >= 1.4.7 && < 1.6 , aeson-qq >= 0.8.1 && < 0.9 , async >= 2.1.1 && < 2.3 , auto-update >= 0.1.4 && < 0.2 - , base64-bytestring >= 1 && < 1.2 + , base64-bytestring >= 1 && < 1.3 , bytestring >= 0.10.8 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , cassava >= 0.4.5 && < 0.6 @@ -185,13 +214,13 @@ , contravariant >= 1.4 && < 1.6 , hasql >= 1.4 && < 1.5 , hasql-pool >= 0.5 && < 0.6 - , hasql-transaction >= 0.7.2 && < 1.1 + , hasql-transaction >= 1.0.1 && < 1.1 , heredoc >= 0.2 && < 0.3 , hspec >= 2.3 && < 2.8 - , hspec-wai >= 0.10 && < 0.11 - , hspec-wai-json >= 0.10 && < 0.11 + , hspec-wai >= 0.10 && < 0.12 + , hspec-wai-json >= 0.10 && < 0.12 , http-types >= 0.12.3 && < 0.13 - , lens >= 4.14 && < 4.20 + , lens >= 4.14 && < 5.1 , lens-aeson >= 1.0.1 && < 1.2 , monad-control >= 1.0.1 && < 1.1 , postgrest @@ -202,40 +231,41 @@ , time >= 1.6 && < 1.11 , transformers-base >= 0.4.4 && < 0.5 , wai >= 3.2.1 && < 3.3 - , wai-extra >= 3.0.19 && < 3.1 - default-language: Haskell2010 - default-extensions: OverloadedStrings - QuasiQuotes - NoImplicitPrelude - ghc-options: -threaded -rtsopts -with-rtsopts=-N + , wai-extra >= 3.0.19 && < 3.2 + ghc-options: --disable-optimizations -Wall -fwarn-identities + -fno-spec-constr -optP-Wno-nonportable-include-path + -fno-warn-missing-signatures -Test-Suite spec-querycost - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude - Hs-Source-Dirs: test - Main-Is: QueryCost.hs - Other-Modules: SpecHelper - Build-Depends: base >= 4.9 && < 4.15 - , aeson >= 1.4.7 && < 1.5 +test-suite spec-querycost + type: exitcode-stdio-1.0 + default-language: Haskell2010 + default-extensions: OverloadedStrings + QuasiQuotes + NoImplicitPrelude + hs-source-dirs: test + main-is: QueryCost.hs + other-modules: SpecHelper + build-depends: base >= 4.9 && < 4.15 + , aeson >= 1.4.7 && < 1.6 , aeson-qq >= 0.8.1 && < 0.9 , async >= 2.1.1 && < 2.3 , auto-update >= 0.1.4 && < 0.2 - , base64-bytestring >= 1 && < 1.2 + , base64-bytestring >= 1 && < 1.3 , bytestring >= 0.10.8 && < 0.11 , case-insensitive >= 1.2 && < 1.3 , cassava >= 0.4.5 && < 0.6 , containers >= 0.5.7 && < 0.7 , contravariant >= 1.4 && < 1.6 , hasql >= 1.4 && < 1.5 + , hasql-dynamic-statements == 0.3.1 , hasql-pool >= 0.5 && < 0.6 - , hasql-transaction >= 0.7.2 && < 1.1 + , hasql-transaction >= 1.0.1 && < 1.1 , heredoc >= 0.2 && < 0.3 , hspec >= 2.3 && < 2.8 - , hspec-wai >= 0.10 && < 0.11 - , hspec-wai-json >= 0.10 && < 0.11 + , hspec-wai >= 0.10 && < 0.12 + , hspec-wai-json >= 0.10 && < 0.12 , http-types >= 0.12.3 && < 0.13 - , lens >= 4.14 && < 4.20 + , lens >= 4.14 && < 5.1 , lens-aeson >= 1.0.1 && < 1.2 , monad-control >= 1.0.1 && < 1.1 , postgrest @@ -246,4 +276,6 @@ , time >= 1.6 && < 1.11 , transformers-base >= 0.4.4 && < 0.5 , wai >= 3.2.1 && < 3.3 - , wai-extra >= 3.0.19 && < 3.1 + , wai-extra >= 3.0.19 && < 3.2 + ghc-options: --disable-optimizations -Wall -fwarn-identities + -fno-spec-constr -optP-Wno-nonportable-include-path diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs deleted file mode 100644 --- a/src/PostgREST/ApiRequest.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-| -Module : PostgREST.ApiRequest -Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. --} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} - -module PostgREST.ApiRequest ( - ApiRequest(..) -, InvokeMethod(..) -, ContentType(..) -, Action(..) -, Target(..) -, mutuallyAgreeable -, userApiRequest -) where - -import qualified Data.Aeson as JSON -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI -import qualified Data.Csv as CSV -import qualified Data.HashMap.Strict as M -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Vector as V - -import Control.Arrow ((***)) -import Data.Aeson.Types (emptyArray, emptyObject) -import Data.List (last, lookup, partition) -import Data.List.NonEmpty (head) -import Data.Maybe (fromJust) -import Data.Ranged.Ranges (Range (..), emptyRange, - rangeIntersection) -import Network.HTTP.Base (urlEncodeVars) -import Network.HTTP.Types.Header (hAuthorization, hCookie) -import Network.HTTP.Types.URI (parseQueryReplacePlus, - parseSimpleQuery) -import Network.Wai (Request (..)) -import Network.Wai.Parse (parseHttpAccept) -import Web.Cookie (parseCookiesText) - - -import Data.Ranged.Boundaries - -import PostgREST.Error (ApiRequestError (..)) -import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq, - rangeLimit, rangeOffset, rangeRequested, - restrictRange) -import PostgREST.Types -import Protolude hiding (head, toS) -import Protolude.Conv (toS) - -type RequestBody = BL.ByteString - -data InvokeMethod = InvHead | InvGet | InvPost deriving Eq --- | Types of things a user wants to do to tables/views/procs -data Action = ActionCreate | ActionRead{isHead :: Bool} - | ActionUpdate | ActionDelete - | ActionSingleUpsert | ActionInvoke InvokeMethod - | ActionInfo | ActionInspect{isHead :: Bool} - deriving Eq --- | The target db object of a user action -data Target = TargetIdent QualifiedIdentifier - | TargetProc{tpQi :: QualifiedIdentifier, tpIsRootSpec :: Bool} - | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/" - | TargetUnknown [Text] - deriving Eq - -{-| - Describes what the user wants to do. This data type is a - translation of the raw elements of an HTTP request into domain - specific language. There is no guarantee that the intent is - sensible, it is up to a later stage of processing to determine - if it is an action we are able to perform. --} -data ApiRequest = ApiRequest { - iAction :: Action -- ^ Similar but not identical to HTTP verb, e.g. Create/Invoke both POST - , iRange :: M.HashMap ByteString NonnegRange -- ^ Requested range of rows within response - , iTopLevelRange :: NonnegRange -- ^ Requested range of rows from the top level - , iTarget :: Target -- ^ The target, be it calling a proc or accessing a table - , iAccepts :: [ContentType] -- ^ Content types the client will accept, [CTAny] if no Accept header - , iPayload :: Maybe PayloadJSON -- ^ Data sent by client and used for mutation actions - , iPreferRepresentation :: PreferRepresentation -- ^ If client wants created items echoed back - , iPreferParameters :: Maybe PreferParameters -- ^ How to pass parameters to a stored procedure - , iPreferCount :: Maybe PreferCount -- ^ Whether the client wants a result count - , iPreferResolution :: Maybe PreferResolution -- ^ Whether the client wants to UPSERT or ignore records on PK conflict - , iFilters :: [(Text, Text)] -- ^ Filters on the result ("id", "eq.10") - , iLogic :: [(Text, Text)] -- ^ &and and &or parameters used for complex boolean logic - , iSelect :: Maybe Text -- ^ &select parameter used to shape the response - , iOnConflict :: Maybe Text -- ^ &on_conflict parameter used to upsert on specific unique keys - , iColumns :: Maybe Text -- ^ &columns parameter used to shape the payload - , iOrder :: [(Text, Text)] -- ^ &order parameters for each level - , iCanonicalQS :: ByteString -- ^ Alphabetized (canonical) request query string for response URLs - , iJWT :: Text -- ^ JSON Web Token - , iHeaders :: [(Text, Text)] -- ^ HTTP request headers - , iCookies :: [(Text, Text)] -- ^ Request Cookies - , iPath :: ByteString -- ^ Raw request path - , iMethod :: ByteString -- ^ Raw request method - , iProfile :: Maybe Schema -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/. - , iSchema :: Schema -- ^ The request schema. Can vary depending on iProfile. - } - --- | Examines HTTP request and translates it into user intent. -userApiRequest :: NonEmpty Schema -> Maybe Text -> Request -> RequestBody -> Either ApiRequestError ApiRequest -userApiRequest confSchemas rootSpec req reqBody - | isJust profile && fromJust profile `notElem` confSchemas = Left $ UnacceptableSchema $ toList confSchemas - | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate - | topLevelRange == emptyRange = Left InvalidRange - | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload - | otherwise = Right ApiRequest { - iAction = action - , iTarget = target - , iRange = ranges - , iTopLevelRange = topLevelRange - , iAccepts = maybe [CTAny] (map decodeContentType . parseHttpAccept) $ lookupHeader "accept" - , iPayload = relevantPayload - , iPreferRepresentation = representation - , iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject - | hasPrefer (show MultipleObjects) -> Just MultipleObjects - | otherwise -> Nothing - , iPreferCount = if | hasPrefer (show ExactCount) -> Just ExactCount - | hasPrefer (show PlannedCount) -> Just PlannedCount - | hasPrefer (show EstimatedCount) -> Just EstimatedCount - | otherwise -> Nothing - , iPreferResolution = if | hasPrefer (show MergeDuplicates) -> Just MergeDuplicates - | hasPrefer (show IgnoreDuplicates) -> Just IgnoreDuplicates - | otherwise -> Nothing - , iFilters = filters - , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ] - , iSelect = toS <$> join (lookup "select" qParams) - , iOnConflict = toS <$> join (lookup "on_conflict" qParams) - , iColumns = columns - , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] - , iCanonicalQS = toS $ urlEncodeVars - . L.sortOn fst - . map (join (***) toS . second (fromMaybe BS.empty)) - $ qString - , iJWT = tokenStr - , iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hCookie] - , iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie" - , iPath = rawPathInfo req - , iMethod = method - , iProfile = profile - , iSchema = schema - } - where - -- queryString with '+' converted to ' '(space) - qString = parseQueryReplacePlus True $ rawQueryString req - -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..) - (filters, rpcQParams) = - case action of - ActionInvoke InvGet -> partitionFlts - ActionInvoke InvHead -> partitionFlts - _ -> (flts, []) - partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts - flts = - [ (toS k, toS $ fromJust v) | - (k,v) <- qParams, isJust v, - k `notElem` ["select", "columns"], - not (endingIn ["order", "limit", "offset", "and", "or"] k) ] - hasOperator val = any (`T.isPrefixOf` val) $ - ((<> ".") <$> "not":M.keys operators) ++ - ((<> "(") <$> M.keys ftsOperators) - isEmbedPath = T.isInfixOf "." - isTargetingProc = case target of - TargetProc _ _ -> True - _ -> False - isTargetingDefaultSpec = case target of - TargetDefaultSpec _ -> True - _ -> False - contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" - columns - | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams) - | otherwise = Nothing - payload = - case (contentType, action) of - (_, ActionInvoke InvGet) -> Right rpcPrmsToJson - (_, ActionInvoke InvHead) -> Right rpcPrmsToJson - (CTApplicationJSON, _) -> - if isJust columns - then Right $ RawJSON reqBody - else note "All object keys must match" . payloadAttributes reqBody - =<< if BL.null reqBody && isTargetingProc - then Right emptyObject - else JSON.eitherDecode reqBody - (CTTextCSV, _) -> do - json <- csvToJson <$> CSV.decodeByName reqBody - note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json - (CTOther "application/x-www-form-urlencoded", _) -> - let json = M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody - keys = S.fromList $ M.keys json in - Right $ ProcessedJSON (JSON.encode json) keys - (ct, _) -> - Left $ toS $ "Content-Type not acceptable: " <> toMime ct - rpcPrmsToJson = ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) (S.fromList $ fst <$> rpcQParams) - topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows - action = - case method of - -- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response - -- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4 - "HEAD" | isTargetingDefaultSpec -> ActionInspect{isHead=True} - | isTargetingProc -> ActionInvoke InvHead - | otherwise -> ActionRead{isHead=True} - "GET" | isTargetingDefaultSpec -> ActionInspect{isHead=False} - | isTargetingProc -> ActionInvoke InvGet - | otherwise -> ActionRead{isHead=False} - "POST" -> if isTargetingProc - then ActionInvoke InvPost - else ActionCreate - "PATCH" -> ActionUpdate - "PUT" -> ActionSingleUpsert - "DELETE" -> ActionDelete - "OPTIONS" -> ActionInfo - _ -> ActionInspect{isHead=False} - - defaultSchema = head confSchemas - profile - | length confSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config - = Nothing - | action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionDelete, ActionInvoke InvPost] -- POST/PATCH/PUT/DELETE don't use the same header as per the spec - = Just $ maybe defaultSchema toS $ lookupHeader "Content-Profile" - | action `elem` [ActionRead True, ActionRead False, ActionInvoke InvGet, ActionInvoke InvHead, - ActionInspect False, ActionInspect True, ActionInfo] - = Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile" - | otherwise = Nothing - schema = fromMaybe defaultSchema profile - target = case path of - [] -> case rootSpec of - Just pName -> TargetProc (QualifiedIdentifier schema pName) True - Nothing -> TargetDefaultSpec schema - [table] -> TargetIdent $ QualifiedIdentifier schema table - ["rpc", proc] -> TargetProc (QualifiedIdentifier schema proc) False - other -> TargetUnknown other - - shouldParsePayload = - action `elem` - [ActionCreate, ActionUpdate, ActionSingleUpsert, - ActionInvoke InvPost, - -- Though ActionInvoke{isGet=True}(a GET /rpc/..) doesn't really have a payload, we use the payload variable as a way - -- to store the query string arguments to the function. - ActionInvoke InvGet, - ActionInvoke InvHead] - relevantPayload | shouldParsePayload = rightToMaybe payload - | otherwise = Nothing - path = pathInfo req - method = requestMethod req - hdrs = requestHeaders req - qParams = [(toS k, v)|(k,v) <- qString] - lookupHeader = flip lookup hdrs - hasPrefer :: Text -> Bool - hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs - where - split :: BS.ByteString -> [Text] - split = map T.strip . T.split (==',') . toS - representation - | hasPrefer (show Full) = Full - | hasPrefer (show None) = None - | otherwise = if action == ActionCreate - then HeadersOnly -- Assume the user wants the Location header(for POST) by default - else None - auth = fromMaybe "" $ lookupHeader hAuthorization - tokenStr = case T.split (== ' ') (toS auth) of - ("Bearer" : t : _) -> t - _ -> "" - endingIn:: [Text] -> Text -> Bool - endingIn xx key = lastWord `elem` xx - where lastWord = last $ T.split (=='.') key - - headerRange = rangeRequested hdrs - replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x] - limitParams :: M.HashMap ByteString NonnegRange - limitParams = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k] - offsetParams :: M.HashMap ByteString NonnegRange - offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe =<< (toS <$> v))) | (k,v) <- qParams, isJust v, endingIn ["offset"] k] - - urlRange = M.unionWith f limitParams offsetParams - where - f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1) - where - l = fromMaybe 0 $ rangeLimit rl - o = rangeOffset ro - ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange - -{-| - Find the best match from a list of content types accepted by the - client in order of decreasing preference and a list of types - producible by the server. If there is no match but the client - accepts */* then return the top server pick. --} -mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType -mutuallyAgreeable sProduces cAccepts = - let exact = listToMaybe $ L.intersect cAccepts sProduces in - if isNothing exact && CTAny `elem` cAccepts - then listToMaybe sProduces - else exact - -type CsvData = V.Vector (M.HashMap Text BL.ByteString) - -{-| - Converts CSV like - a,b - 1,hi - 2,bye - - into a JSON array like - [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ] - - The reason for its odd signature is so that it can compose - directly with CSV.decodeByName --} -csvToJson :: (CSV.Header, CsvData) -> JSON.Value -csvToJson (_, vals) = - JSON.Array $ V.map rowToJsonObj vals - where - rowToJsonObj = JSON.Object . - M.map (\str -> - if str == "NULL" - then JSON.Null - else JSON.String $ toS str - ) - -payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON -payloadAttributes raw json = - -- Test that Array contains only Objects having the same keys - case json of - JSON.Array arr -> - case arr V.!? 0 of - Just (JSON.Object o) -> - let canonicalKeys = S.fromList $ M.keys o - areKeysUniform = all (\case - JSON.Object x -> S.fromList (M.keys x) == canonicalKeys - _ -> False) arr in - if areKeysUniform - then Just $ ProcessedJSON raw canonicalKeys - else Nothing - Just _ -> Nothing - Nothing -> Just emptyPJArray - - JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ M.keys o) - - -- truncate everything else to an empty array. - _ -> Just emptyPJArray - where - emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -9,411 +9,608 @@ - Producing HTTP Headers according to RFCs. - Content Negotiation -} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +module PostgREST.App + ( SignalHandlerInstaller + , SocketRunner + , postgrest + , run + ) where -module PostgREST.App ( - postgrest -) where +import Control.Monad.Except (liftEither) +import Data.Either.Combinators (mapLeft) +import Data.List (union) +import Data.String (IsString (..)) +import Data.Time.Clock (UTCTime) +import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort, + setServerName) +import System.Posix.Types (FileMode) -import qualified Data.ByteString.Char8 as BS -import qualified Data.HashMap.Strict as M -import qualified Data.List as L (union) -import qualified Data.Set as S -import qualified Hasql.Pool as P -import qualified Hasql.Transaction as H -import qualified Hasql.Transaction as HT -import qualified Hasql.Transaction.Sessions as HT +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as Map +import qualified Data.Set as Set +import qualified Hasql.DynamicStatements.Snippet as SQL +import qualified Hasql.Pool as SQL +import qualified Hasql.Transaction as SQL +import qualified Hasql.Transaction.Sessions as SQL +import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.HTTP.Types.Status as HTTP +import qualified Network.HTTP.Types.URI as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp -import Data.Function (id) -import Data.IORef (IORef, readIORef) -import Data.Time.Clock (UTCTime) -import Network.HTTP.Types.URI (renderSimpleQuery) -import Network.Wai.Middleware.RequestLogger (logStdout) +import qualified PostgREST.AppState as AppState +import qualified PostgREST.Auth as Auth +import qualified PostgREST.DbStructure as DbStructure +import qualified PostgREST.Error as Error +import qualified PostgREST.Middleware as Middleware +import qualified PostgREST.OpenAPI as OpenAPI +import qualified PostgREST.Query.QueryBuilder as QueryBuilder +import qualified PostgREST.Query.Statements as Statements +import qualified PostgREST.RangeQuery as RangeQuery +import qualified PostgREST.Request.ApiRequest as ApiRequest +import qualified PostgREST.Request.DbRequestBuilder as ReqBuilder -import Control.Applicative -import Data.Maybe -import Network.HTTP.Types.Header -import Network.HTTP.Types.Status -import Network.Wai +import PostgREST.AppState (AppState) +import PostgREST.Config (AppConfig (..), + LogLevel (..), + OpenAPIMode (..)) +import PostgREST.Config.PgVersion (PgVersion (..)) +import PostgREST.ContentType (ContentType (..)) +import PostgREST.DbStructure (DbStructure (..), + tablePKCols) +import PostgREST.DbStructure.Identifiers (FieldName, + QualifiedIdentifier (..), + Schema) +import PostgREST.DbStructure.Proc (ProcDescription (..), + ProcVolatility (..)) +import PostgREST.DbStructure.Table (Table (..)) +import PostgREST.Error (Error) +import PostgREST.GucHeader (GucHeader, + addHeadersIfNotIncluded, + unwrapGucHeader) +import PostgREST.Request.ApiRequest (Action (..), + ApiRequest (..), + InvokeMethod (..), + Target (..)) +import PostgREST.Request.Preferences (PreferCount (..), + PreferParameters (..), + PreferRepresentation (..)) +import PostgREST.Request.Types (ReadRequest, fstFieldNames) +import PostgREST.Version (prettyVersion) +import PostgREST.Workers (connectionWorker, listener) -import PostgREST.ApiRequest (Action (..), ApiRequest (..), - InvokeMethod (..), Target (..), - mutuallyAgreeable, userApiRequest) -import PostgREST.Auth (containsRole, jwtClaims, - parseSecret) -import PostgREST.Config (AppConfig (..)) -import PostgREST.DbRequestBuilder (mutateRequest, readRequest, - returningCols) -import PostgREST.DbStructure -import PostgREST.Error (PgError (..), SimpleError (..), - errorResponseFor, singularityError) -import PostgREST.Middleware -import PostgREST.OpenAPI -import PostgREST.Parsers (pRequestColumns) -import PostgREST.QueryBuilder (limitedQuery, mutateRequestToQuery, - readRequestToCountQuery, - readRequestToQuery, - requestToCallProcQuery) -import PostgREST.RangeQuery (allRange, contentRangeH, - rangeStatusHeader) -import PostgREST.Statements (callProcStatement, - createExplainStatement, - createReadStatement, - createWriteStatement) -import PostgREST.Types -import Protolude hiding (Proxy, intercalate, toS) -import Protolude.Conv (toS) +import qualified PostgREST.ContentType as ContentType +import qualified PostgREST.DbStructure.Proc as Proc -postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application -postgrest conf refDbStructure pool getTime worker = - let middle = (if configQuiet conf then id else logStdout) . defaultMiddle - jwtSecret = parseSecret <$> configJwtSecret conf in - middle $ \ req respond -> do - time <- getTime - body <- strictRequestBody req - maybeDbStructure <- readIORef refDbStructure - case maybeDbStructure of - Nothing -> respond . errorResponseFor $ ConnectionLostError - Just dbStructure -> do - response <- do - -- Need to parse ?columns early because findProc needs it to solve overloaded functions. - -- TODO: move this logic to the app function - let apiReq = userApiRequest (configSchemas conf) (configRootSpec conf) req body - apiReqCols = (,) <$> apiReq <*> (pRequestColumns =<< iColumns <$> apiReq) - case apiReqCols of - Left err -> return . errorResponseFor $ err - Right (apiRequest, maybeCols) -> do - eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf) - let authed = containsRole eClaims - cols = case (iPayload apiRequest, maybeCols) of - (Just ProcessedJSON{pjKeys}, _) -> pjKeys - (Just RawJSON{}, Just cls) -> cls - _ -> S.empty - proc = case iTarget apiRequest of - TargetProc qi _ -> findProc qi cols (iPreferParameters apiRequest == Just SingleObject) $ dbProcs dbStructure - _ -> Nothing - handleReq = runWithClaims conf eClaims (app dbStructure proc cols conf) apiRequest - txMode = transactionMode proc (iAction apiRequest) - response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq - return $ either (errorResponseFor . PgError authed) identity response - when (responseStatus response == status503) worker - respond response +import Protolude hiding (Handler, toS) +import Protolude.Conv (toS) -transactionMode :: Maybe ProcDescription -> Action -> HT.Mode -transactionMode proc action = - case action of - ActionRead _ -> HT.Read - ActionInfo -> HT.Read - ActionInspect _ -> HT.Read - ActionInvoke InvGet -> HT.Read - ActionInvoke InvHead -> HT.Read - ActionInvoke InvPost -> - let v = maybe Volatile pdVolatility proc in - if v == Stable || v == Immutable - then HT.Read - else HT.Write - _ -> HT.Write -app :: DbStructure -> Maybe ProcDescription -> S.Set FieldName -> AppConfig -> ApiRequest -> H.Transaction Response -app dbStructure proc cols conf apiRequest = - let rawContentTypes = (decodeContentType <$> configRawMediaTypes conf) `L.union` [ CTOctetStream, CTTextPlain ] in - case responseContentTypeOrError (iAccepts apiRequest) rawContentTypes (iAction apiRequest) (iTarget apiRequest) of - Left errorResponse -> return errorResponse - Right contentType -> - case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of +data RequestContext = RequestContext + { ctxConfig :: AppConfig + , ctxDbStructure :: DbStructure + , ctxApiRequest :: ApiRequest + , ctxPgVersion :: PgVersion + } - (ActionRead headersOnly, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) -> - case readSqlParts tSchema tName of - Left errorResponse -> return errorResponse - Right (q, cq, bField, _) -> do - let cQuery = if estimatedCount - then limitedQuery cq ((+ 1) <$> maxRows) -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed - else cq - stm = createReadStatement q cQuery (contentType == CTSingularJSON) shouldCount - (contentType == CTTextCSV) bField pgVer - explStm = createExplainStatement cq - row <- H.statement () stm - let (tableTotal, queryTotal, _ , body, gucHeaders) = row - case gucHeaders of - Left _ -> return . errorResponseFor $ GucHeadersError - Right ghdrs -> do - total <- if | plannedCount -> H.statement () explStm - | estimatedCount -> if tableTotal > (fromIntegral <$> maxRows) - then do estTotal <- H.statement () explStm - pure $ if estTotal > tableTotal then estTotal else tableTotal - else pure tableTotal - | otherwise -> pure tableTotal - let (status, contentRange) = rangeStatusHeader topLevelRange queryTotal total - headers = addHeadersIfNotIncluded (catMaybes [ - Just $ toHeader contentType, Just contentRange, - Just $ contentLocationH tName (iCanonicalQS apiRequest), profileH]) - (unwrapGucHeader <$> ghdrs) - rBody = if headersOnly then mempty else toS body - return $ - if contentType == CTSingularJSON && queryTotal /= 1 - then errorResponseFor . singularityError $ queryTotal - else responseLBS status headers rBody +type Handler = ExceptT Error - (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> - case mutateSqlParts tSchema tName of - Left errorResponse -> return errorResponse - Right (sq, mq) -> do - let pkCols = tablePKCols dbStructure tSchema tName - stm = createWriteStatement sq mq - (contentType == CTSingularJSON) True - (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols pgVer - row <- H.statement (toS $ pjRaw pJson) stm - let (_, queryTotal, fields, body, gucHeaders) = row - case gucHeaders of - Left _ -> return . errorResponseFor $ GucHeadersError - Right ghdrs -> do - let - (ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full - then ([Just $ toHeader contentType, profileH], toS body) - else ([], mempty) - headers = addHeadersIfNotIncluded (catMaybes ([ - if null fields - then Nothing - else Just $ locationH tName fields - , Just $ contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing - , if null pkCols && isNothing (iOnConflict apiRequest) - then Nothing - else (\x -> ("Preference-Applied", encodeUtf8 (show x))) <$> iPreferResolution apiRequest - ] ++ ctHeaders)) (unwrapGucHeader <$> ghdrs) - if contentType == CTSingularJSON && queryTotal /= 1 - then do - HT.condemn - return . errorResponseFor . singularityError $ queryTotal - else - return $ responseLBS status201 headers rBody +type DbHandler = Handler SQL.Transaction - (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> - case mutateSqlParts tSchema tName of - Left errorResponse -> return errorResponse - Right (sq, mq) -> do - let stm = createWriteStatement sq mq - (contentType == CTSingularJSON) False (contentType == CTTextCSV) - (iPreferRepresentation apiRequest) [] pgVer - row <- H.statement (toS $ pjRaw pJson) stm - let (_, queryTotal, _, body, gucHeaders) = row - case gucHeaders of - Left _ -> return . errorResponseFor $ GucHeadersError - Right ghdrs -> do - let - updateIsNoOp = S.null cols - status | queryTotal == 0 && not updateIsNoOp = status404 - | iPreferRepresentation apiRequest == Full = status200 - | otherwise = status204 - contentRangeHeader = contentRangeH 0 (queryTotal - 1) $ if shouldCount then Just queryTotal else Nothing - (ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full - then ([Just $ toHeader contentType, profileH], toS body) - else ([], mempty) - headers = addHeadersIfNotIncluded (catMaybes ctHeaders ++ [contentRangeHeader]) (unwrapGucHeader <$> ghdrs) - if contentType == CTSingularJSON && queryTotal /= 1 - then do - HT.condemn - return . errorResponseFor . singularityError $ queryTotal - else - return $ responseLBS status headers rBody +type SignalHandlerInstaller = AppState -> IO() - (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> - case mutateSqlParts tSchema tName of - Left errorResponse -> return errorResponse - Right (sq, mq) -> - if topLevelRange /= allRange - then return . errorResponseFor $ PutRangeNotAllowedError - else do - row <- H.statement (toS $ pjRaw pJson) $ - createWriteStatement sq mq (contentType == CTSingularJSON) False - (contentType == CTTextCSV) (iPreferRepresentation apiRequest) [] pgVer - let (_, queryTotal, _, body, gucHeaders) = row - case gucHeaders of - Left _ -> return . errorResponseFor $ GucHeadersError - Right ghdrs -> do - let headers = addHeadersIfNotIncluded (catMaybes [Just $ toHeader contentType, profileH]) (unwrapGucHeader <$> ghdrs) - (status, rBody) = if iPreferRepresentation apiRequest == Full then (status200, toS body) else (status204, mempty) - -- Makes sure the querystring pk matches the payload pk - -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, PUT /items?id=eq.14 { "id" : 2, .. } is rejected - -- If this condition is not satisfied then nothing is inserted, check the WHERE for INSERT in QueryBuilder.hs to see how it's done - if queryTotal /= 1 - then do - HT.condemn - return . errorResponseFor $ PutMatchingPkError - else - return $ responseLBS status headers rBody +type SocketRunner = Warp.Settings -> Wai.Application -> FileMode -> FilePath -> IO() - (ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) -> - case mutateSqlParts tSchema tName of - Left errorResponse -> return errorResponse - Right (sq, mq) -> do - let stm = createWriteStatement sq mq - (contentType == CTSingularJSON) False - (contentType == CTTextCSV) - (iPreferRepresentation apiRequest) [] pgVer - row <- H.statement mempty stm - let (_, queryTotal, _, body, gucHeaders) = row - case gucHeaders of - Left _ -> return . errorResponseFor $ GucHeadersError - Right ghdrs -> do - let - status = if iPreferRepresentation apiRequest == Full then status200 else status204 - contentRangeHeader = contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing - (ctHeaders, rBody) = if iPreferRepresentation apiRequest == Full - then ([Just $ toHeader contentType, profileH], toS body) - else ([], mempty) - headers = addHeadersIfNotIncluded (catMaybes ctHeaders ++ [contentRangeHeader]) (unwrapGucHeader <$> ghdrs) - if contentType == CTSingularJSON - && queryTotal /= 1 - then do - HT.condemn - return . errorResponseFor . singularityError $ queryTotal - else - return $ responseLBS status headers rBody - (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> - let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in - case mTable of - Nothing -> return notFound - Just table -> - let allowH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in - return $ responseLBS status200 [allOrigins, allowH] mempty +run :: SignalHandlerInstaller -> Maybe SocketRunner -> AppState -> IO () +run installHandlers maybeRunWithSocket appState = do + conf@AppConfig{..} <- AppState.getConfig appState + connectionWorker appState -- Loads the initial DbStructure + installHandlers appState + -- reload schema cache + config on NOTIFY + when configDbChannelEnabled $ listener appState - (ActionInvoke invMethod, TargetProc qi@(QualifiedIdentifier tSchema pName) _, Just pJson) -> - let tName = fromMaybe pName $ procTableName =<< proc in - case readSqlParts tSchema tName of - Left errorResponse -> return errorResponse - Right (q, cq, bField, returning) -> do - let - preferParams = iPreferParameters apiRequest - pq = requestToCallProcQuery qi (specifiedProcArgs cols proc) returnsScalar preferParams returning - stm = callProcStatement returnsScalar pq q cq shouldCount (contentType == CTSingularJSON) - (contentType == CTTextCSV) (contentType `elem` rawContentTypes) (preferParams == Just MultipleObjects) - bField pgVer - row <- H.statement (toS $ pjRaw pJson) stm - let (tableTotal, queryTotal, body, gucHeaders) = row - case gucHeaders of - Left _ -> return . errorResponseFor $ GucHeadersError - Right ghdrs -> do - let (status, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal - headers = addHeadersIfNotIncluded - (catMaybes [Just $ toHeader contentType, Just contentRange, profileH]) - (unwrapGucHeader <$> ghdrs) - rBody = if invMethod == InvHead then mempty else toS body - if contentType == CTSingularJSON && queryTotal /= 1 - then do - HT.condemn - return . errorResponseFor . singularityError $ queryTotal - else - return $ responseLBS status headers rBody + let app = postgrest configLogLevel appState (connectionWorker appState) - (ActionInspect headersOnly, TargetDefaultSpec tSchema, Nothing) -> do - let host = configHost conf - port = toInteger $ configPort conf - proxy = pickProxy $ toS <$> configOpenAPIProxyUri conf - uri Nothing = ("http", host, port, "/") - uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) - uri' = uri proxy - toTableInfo :: [Table] -> [(Table, [Column], [Text])] - toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn)) - encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure + case configServerUnixSocket of + Just socket -> + -- run the postgrest application with user defined socket. Only for UNIX systems + case maybeRunWithSocket of + Just runWithSocket -> do + AppState.logWithZTime appState $ "Listening on unix socket " <> show socket + runWithSocket (serverSettings conf) app configServerUnixSocketMode socket + Nothing -> + panic "Cannot run with socket on non-unix plattforms." + Nothing -> + do + AppState.logWithZTime appState $ "Listening on port " <> show configServerPort + Warp.runSettings (serverSettings conf) app - body <- encodeApi <$> - H.statement tSchema accessibleTables <*> - H.statement tSchema schemaDescription <*> - H.statement tSchema accessibleProcs - return $ responseLBS status200 (catMaybes [Just $ toHeader CTOpenAPI, profileH]) (if headersOnly then mempty else toS body) +serverSettings :: AppConfig -> Warp.Settings +serverSettings AppConfig{..} = + defaultSettings + & setHost (fromString $ toS configServerHost) + & setPort configServerPort + & setServerName (toS $ "postgrest/" <> prettyVersion) - _ -> return notFound +-- | PostgREST application +postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application +postgrest logLev appState connWorker = + Middleware.pgrstMiddleware logLev $ + \req respond -> do + time <- AppState.getTime appState + conf <- AppState.getConfig appState + maybeDbStructure <- AppState.getDbStructure appState + pgVer <- AppState.getPgVersion appState + jsonDbS <- AppState.getJsonDbS appState - where - notFound = responseLBS status404 [] "" - maxRows = configMaxRows conf - exactCount = iPreferCount apiRequest == Just ExactCount - estimatedCount = iPreferCount apiRequest == Just EstimatedCount - plannedCount = iPreferCount apiRequest == Just PlannedCount - shouldCount = exactCount || estimatedCount - topLevelRange = iTopLevelRange apiRequest - returnsScalar = maybe False procReturnsScalar proc - pgVer = pgVersion dbStructure - profileH = contentProfileH <$> iProfile apiRequest + let + eitherResponse :: IO (Either Error Wai.Response) + eitherResponse = + runExceptT $ postgrestResponse conf maybeDbStructure jsonDbS pgVer (AppState.getPool appState) time req - readSqlParts s t = - let - readReq = readRequest s t maxRows (dbRelations dbStructure) apiRequest - returnings :: ReadRequest -> Either Response [FieldName] - returnings rr = Right (returningCols rr) - in - (,,,) <$> - (readRequestToQuery <$> readReq) <*> - (readRequestToCountQuery <$> readReq) <*> - (binaryField contentType rawContentTypes returnsScalar =<< readReq) <*> - (returnings =<< readReq) + response <- either Error.errorResponseFor identity <$> eitherResponse - mutateSqlParts s t = - let - readReq = readRequest s t maxRows (dbRelations dbStructure) apiRequest - mutReq = mutateRequest s t apiRequest cols (tablePKCols dbStructure s t) =<< readReq - in - (,) <$> - (readRequestToQuery <$> readReq) <*> - (mutateRequestToQuery <$> mutReq) + -- Launch the connWorker when the connection is down. The postgrest + -- function can respond successfully (with a stale schema cache) before + -- the connWorker is done. + when (Wai.responseStatus response == HTTP.status503) connWorker -responseContentTypeOrError :: [ContentType] -> [ContentType] -> Action -> Target -> Either Response ContentType -responseContentTypeOrError accepts rawContentTypes action target = serves contentTypesForRequest accepts - where - contentTypesForRequest = case action of - ActionRead _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - ++ rawContentTypes - ActionCreate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - ActionUpdate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - ActionDelete -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - ActionInvoke _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - ++ rawContentTypes - ++ [CTOpenAPI | tpIsRootSpec target] - ActionInspect _ -> [CTOpenAPI, CTApplicationJSON] - ActionInfo -> [CTTextCSV] - ActionSingleUpsert -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - serves sProduces cAccepts = - case mutuallyAgreeable sProduces cAccepts of - Nothing -> Left . errorResponseFor . ContentTypeError . map toMime $ cAccepts - Just ct -> Right ct + respond response -{- - | If raw(binary) output is requested, check that ContentType is one of the admitted rawContentTypes and that - | `?select=...` contains only one field other than `*` --} -binaryField :: ContentType -> [ContentType] -> Bool -> ReadRequest -> Either Response (Maybe FieldName) -binaryField ct rawContentTypes isScalarProc readReq - | isScalarProc = Right Nothing - | ct `elem` rawContentTypes = - let fieldName = headMay fldNames in - if length fldNames == 1 && fieldName /= Just "*" - then Right fieldName - else Left . errorResponseFor $ BinaryFieldError ct - | otherwise = Right Nothing +postgrestResponse + :: AppConfig + -> Maybe DbStructure + -> ByteString + -> PgVersion + -> SQL.Pool + -> UTCTime + -> Wai.Request + -> Handler IO Wai.Response +postgrestResponse conf maybeDbStructure jsonDbS pgVer pool time req = do + body <- lift $ Wai.strictRequestBody req + + dbStructure <- + case maybeDbStructure of + Just dbStructure -> + return dbStructure + Nothing -> + throwError Error.ConnectionLostError + + apiRequest@ApiRequest{..} <- + liftEither . mapLeft Error.ApiRequestError $ + ApiRequest.userApiRequest conf dbStructure req body + + -- The JWT must be checked before touching the db + jwtClaims <- Auth.jwtClaims conf (toS iJWT) time + + let + handleReq apiReq = + handleRequest $ RequestContext conf dbStructure apiReq pgVer + + runDbHandler pool (txMode apiRequest) jwtClaims (configDbPreparedStatements conf) . + Middleware.optionalRollback conf apiRequest $ + Middleware.runPgLocals conf jwtClaims handleReq apiRequest jsonDbS + +runDbHandler :: SQL.Pool -> SQL.Mode -> Auth.JWTClaims -> Bool -> DbHandler a -> Handler IO a +runDbHandler pool mode jwtClaims prepared handler = do + dbResp <- + let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction in + lift . SQL.use pool . transaction SQL.ReadCommitted mode $ runExceptT handler + + resp <- + liftEither . mapLeft Error.PgErr $ + mapLeft (Error.PgError $ Auth.containsRole jwtClaims) dbResp + + liftEither resp + +handleRequest :: RequestContext -> DbHandler Wai.Response +handleRequest context@(RequestContext _ _ ApiRequest{..} _) = + case (iAction, iTarget) of + (ActionRead headersOnly, TargetIdent identifier) -> + handleRead headersOnly identifier context + (ActionCreate, TargetIdent identifier) -> + handleCreate identifier context + (ActionUpdate, TargetIdent identifier) -> + handleUpdate identifier context + (ActionSingleUpsert, TargetIdent identifier) -> + handleSingleUpsert identifier context + (ActionDelete, TargetIdent identifier) -> + handleDelete identifier context + (ActionInfo, TargetIdent identifier) -> + handleInfo identifier context + (ActionInvoke invMethod, TargetProc proc _) -> + handleInvoke invMethod proc context + (ActionInspect headersOnly, TargetDefaultSpec tSchema) -> + handleOpenApi headersOnly tSchema context + _ -> + throwError Error.NotFound + +handleRead :: Bool -> QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response +handleRead headersOnly identifier context@RequestContext{..} = do + req <- readRequest identifier context + bField <- binaryField context req + + let + ApiRequest{..} = ctxApiRequest + AppConfig{..} = ctxConfig + countQuery = QueryBuilder.readRequestToCountQuery req + + (tableTotal, queryTotal, _ , body, gucHeaders, gucStatus) <- + lift . SQL.statement mempty $ + Statements.createReadStatement + (QueryBuilder.readRequestToQuery req) + (if iPreferCount == Just EstimatedCount then + -- LIMIT maxRows + 1 so we can determine below that maxRows was surpassed + QueryBuilder.limitedQuery countQuery ((+ 1) <$> configDbMaxRows) + else + countQuery + ) + (iAcceptContentType == CTSingularJSON) + (shouldCount iPreferCount) + (iAcceptContentType == CTTextCSV) + bField + ctxPgVersion + configDbPreparedStatements + + total <- readTotal ctxConfig ctxApiRequest tableTotal countQuery + response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders + + let + (status, contentRange) = RangeQuery.rangeStatusHeader iTopLevelRange queryTotal total + headers = + [ contentRange + , ( "Content-Location" + , "/" + <> toS (qiName identifier) + <> if BS8.null iCanonicalQS then mempty else "?" <> toS iCanonicalQS + ) + ] + ++ contentTypeHeaders context + + failNotSingular iAcceptContentType queryTotal . response status headers $ + if headersOnly then mempty else toS body + +readTotal :: AppConfig -> ApiRequest -> Maybe Int64 -> SQL.Snippet -> DbHandler (Maybe Int64) +readTotal AppConfig{..} ApiRequest{..} tableTotal countQuery = + case iPreferCount of + Just PlannedCount -> + explain + Just EstimatedCount -> + if tableTotal > (fromIntegral <$> configDbMaxRows) then + max tableTotal <$> explain + else + return tableTotal + _ -> + return tableTotal where - fldNames = fstFieldNames readReq + explain = + lift . SQL.statement mempty . Statements.createExplainStatement countQuery $ + configDbPreparedStatements -locationH :: TableName -> [BS.ByteString] -> Header -locationH tName fields = +handleCreate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response +handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do let - locationFields = renderSimpleQuery True $ splitKeyValue <$> fields - in - (hLocation, "/" <> toS tName <> locationFields) + ApiRequest{..} = ctxApiRequest + pkCols = tablePKCols ctxDbStructure qiSchema qiName + + WriteQueryResult{..} <- writeQuery identifier True pkCols context + + let + response = gucResponse resGucStatus resGucHeaders + headers = + catMaybes + [ if null resFields then + Nothing + else + Just + ( HTTP.hLocation + , "/" + <> toS qiName + <> HTTP.renderSimpleQuery True (splitKeyValue <$> resFields) + ) + , Just . RangeQuery.contentRangeH 1 0 $ + if shouldCount iPreferCount then Just resQueryTotal else Nothing + , if null pkCols && isNothing iOnConflict then + Nothing + else + (\x -> ("Preference-Applied", BS8.pack $ show x)) <$> iPreferResolution + ] + + failNotSingular iAcceptContentType resQueryTotal $ + if iPreferRepresentation == Full then + response HTTP.status201 (headers ++ contentTypeHeaders context) (toS resBody) + else + response HTTP.status201 headers mempty + +handleUpdate :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response +handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do + WriteQueryResult{..} <- writeQuery identifier False mempty context + + let + response = gucResponse resGucStatus resGucHeaders + fullRepr = iPreferRepresentation == Full + updateIsNoOp = Set.null iColumns + status + | resQueryTotal == 0 && not updateIsNoOp = HTTP.status404 + | fullRepr = HTTP.status200 + | otherwise = HTTP.status204 + contentRangeHeader = + RangeQuery.contentRangeH 0 (resQueryTotal - 1) $ + if shouldCount iPreferCount then Just resQueryTotal else Nothing + + failNotSingular iAcceptContentType resQueryTotal $ + if fullRepr then + response status (contentTypeHeaders context ++ [contentRangeHeader]) (toS resBody) + else + response status [contentRangeHeader] mempty + +handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response +handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do + when (iTopLevelRange /= RangeQuery.allRange) $ + throwError Error.PutRangeNotAllowedError + + WriteQueryResult{..} <- writeQuery identifier False mempty context + + let response = gucResponse resGucStatus resGucHeaders + + -- Makes sure the querystring pk matches the payload pk + -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, + -- PUT /items?id=eq.14 { "id" : 2, .. } is rejected. + -- If this condition is not satisfied then nothing is inserted, + -- check the WHERE for INSERT in QueryBuilder.hs to see how it's done + when (resQueryTotal /= 1) $ do + lift SQL.condemn + throwError Error.PutMatchingPkError + + return $ + if iPreferRepresentation == Full then + response HTTP.status200 (contentTypeHeaders context) (toS resBody) + else + response HTTP.status204 (contentTypeHeaders context) mempty + +handleDelete :: QualifiedIdentifier -> RequestContext -> DbHandler Wai.Response +handleDelete identifier context@(RequestContext _ _ ApiRequest{..} _) = do + WriteQueryResult{..} <- writeQuery identifier False mempty context + + let + response = gucResponse resGucStatus resGucHeaders + contentRangeHeader = + RangeQuery.contentRangeH 1 0 $ + if shouldCount iPreferCount then Just resQueryTotal else Nothing + + failNotSingular iAcceptContentType resQueryTotal $ + if iPreferRepresentation == Full then + response HTTP.status200 + (contentTypeHeaders context ++ [contentRangeHeader]) + (toS resBody) + else + response HTTP.status204 [contentRangeHeader] mempty + +handleInfo :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m Wai.Response +handleInfo identifier RequestContext{..} = + case find tableMatches $ dbTables ctxDbStructure of + Just table -> + return $ Wai.responseLBS HTTP.status200 [allOrigins, allowH table] mempty + Nothing -> + throwError Error.NotFound where - splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) - splitKeyValue kv = - let (k, v) = BS.break (== '=') kv - in (k, BS.tail v) + allOrigins = ("Access-Control-Allow-Origin", "*") + allowH table = + ( HTTP.hAllow + , BS8.intercalate "," $ + ["OPTIONS,GET,HEAD"] + ++ ["POST" | tableInsertable table] + ++ ["PUT" | tableInsertable table && tableUpdatable table && hasPK] + ++ ["PATCH" | tableUpdatable table] + ++ ["DELETE" | tableDeletable table] + ) + tableMatches table = + tableName table == qiName identifier + && tableSchema table == qiSchema identifier + hasPK = + not $ null $ tablePKCols ctxDbStructure (qiSchema identifier) (qiName identifier) -contentLocationH :: TableName -> ByteString -> Header -contentLocationH tName qString = - ("Content-Location", "/" <> toS tName <> if BS.null qString then mempty else "?" <> toS qString) +handleInvoke :: InvokeMethod -> ProcDescription -> RequestContext -> DbHandler Wai.Response +handleInvoke invMethod proc context@RequestContext{..} = do + let + ApiRequest{..} = ctxApiRequest -contentProfileH :: Schema -> Header -contentProfileH schema = - ("Content-Profile", toS schema) + identifier = + QualifiedIdentifier + (pdSchema proc) + (fromMaybe (pdName proc) $ Proc.procTableName proc) + + returnsSingle (ApiRequest.TargetProc target _) = Proc.procReturnsSingle target + returnsSingle _ = False + + req <- readRequest identifier context + bField <- binaryField context req + + (tableTotal, queryTotal, body, gucHeaders, gucStatus) <- + lift . SQL.statement mempty $ + Statements.callProcStatement + (returnsScalar iTarget) + (returnsSingle iTarget) + (QueryBuilder.requestToCallProcQuery + (QualifiedIdentifier (pdSchema proc) (pdName proc)) + (Proc.specifiedProcArgs iColumns proc) + iPayload + (returnsScalar iTarget) + iPreferParameters + (ReqBuilder.returningCols req []) + ) + (QueryBuilder.readRequestToQuery req) + (QueryBuilder.readRequestToCountQuery req) + (shouldCount iPreferCount) + (iAcceptContentType == CTSingularJSON) + (iAcceptContentType == CTTextCSV) + (iPreferParameters == Just MultipleObjects) + bField + ctxPgVersion + (configDbPreparedStatements ctxConfig) + + response <- liftEither $ gucResponse <$> gucStatus <*> gucHeaders + + let + (status, contentRange) = + RangeQuery.rangeStatusHeader iTopLevelRange queryTotal tableTotal + + failNotSingular iAcceptContentType queryTotal $ + response status + (contentTypeHeaders context ++ [contentRange]) + (if invMethod == InvHead then mempty else toS body) + +handleOpenApi :: Bool -> Schema -> RequestContext -> DbHandler Wai.Response +handleOpenApi headersOnly tSchema (RequestContext conf@AppConfig{..} dbStructure apiRequest _) = do + body <- + lift $ case configOpenApiMode of + OAFollowPriv -> + OpenAPI.encode conf dbStructure + <$> SQL.statement tSchema (DbStructure.accessibleTables configDbPreparedStatements) + <*> SQL.statement tSchema (DbStructure.accessibleProcs configDbPreparedStatements) + <*> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements) + OAIgnorePriv -> + OpenAPI.encode conf dbStructure + (filter (\x -> tableSchema x == tSchema) $ DbStructure.dbTables dbStructure) + (Map.filterWithKey (\(QualifiedIdentifier sch _) _ -> sch == tSchema) $ DbStructure.dbProcs dbStructure) + <$> SQL.statement tSchema (DbStructure.schemaDescription configDbPreparedStatements) + OADisabled -> + pure mempty + + return $ + Wai.responseLBS HTTP.status200 + (ContentType.toHeader CTOpenAPI : maybeToList (profileHeader apiRequest)) + (if headersOnly then mempty else toS body) + +txMode :: ApiRequest -> SQL.Mode +txMode ApiRequest{..} = + case (iAction, iTarget) of + (ActionRead _, _) -> + SQL.Read + (ActionInfo, _) -> + SQL.Read + (ActionInspect _, _) -> + SQL.Read + (ActionInvoke InvGet, _) -> + SQL.Read + (ActionInvoke InvHead, _) -> + SQL.Read + (ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Stable} _) -> + SQL.Read + (ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Immutable} _) -> + SQL.Read + _ -> + SQL.Write + +-- | Result from executing a write query on the database +data WriteQueryResult = WriteQueryResult + { resQueryTotal :: Int64 + , resFields :: [ByteString] + , resBody :: ByteString + , resGucStatus :: Maybe HTTP.Status + , resGucHeaders :: [GucHeader] + } + +writeQuery :: QualifiedIdentifier -> Bool -> [Text] -> RequestContext -> DbHandler WriteQueryResult +writeQuery identifier@QualifiedIdentifier{..} isInsert pkCols context@RequestContext{..} = do + readReq <- readRequest identifier context + + mutateReq <- + liftEither $ + ReqBuilder.mutateRequest qiSchema qiName ctxApiRequest + (tablePKCols ctxDbStructure qiSchema qiName) + readReq + + (_, queryTotal, fields, body, gucHeaders, gucStatus) <- + lift . SQL.statement mempty $ + Statements.createWriteStatement + (QueryBuilder.readRequestToQuery readReq) + (QueryBuilder.mutateRequestToQuery mutateReq) + (iAcceptContentType ctxApiRequest == CTSingularJSON) + isInsert + (iAcceptContentType ctxApiRequest == CTTextCSV) + (iPreferRepresentation ctxApiRequest) + pkCols + ctxPgVersion + (configDbPreparedStatements ctxConfig) + + liftEither $ WriteQueryResult queryTotal fields body <$> gucStatus <*> gucHeaders + +-- | Response with headers and status overridden from GUCs. +gucResponse + :: Maybe HTTP.Status + -> [GucHeader] + -> HTTP.Status + -> [HTTP.Header] + -> LBS.ByteString + -> Wai.Response +gucResponse gucStatus gucHeaders status headers = + Wai.responseLBS (fromMaybe status gucStatus) $ + addHeadersIfNotIncluded headers (map unwrapGucHeader gucHeaders) + +-- | +-- Fail a response if a single JSON object was requested and not exactly one +-- was found. +failNotSingular :: ContentType -> Int64 -> Wai.Response -> DbHandler Wai.Response +failNotSingular contentType queryTotal response = + if contentType == CTSingularJSON && queryTotal /= 1 then + do + lift SQL.condemn + throwError $ Error.singularityError queryTotal + else + return response + +shouldCount :: Maybe PreferCount -> Bool +shouldCount preferCount = + preferCount == Just ExactCount || preferCount == Just EstimatedCount + +returnsScalar :: ApiRequest.Target -> Bool +returnsScalar (TargetProc proc _) = Proc.procReturnsScalar proc +returnsScalar _ = False + +readRequest :: Monad m => QualifiedIdentifier -> RequestContext -> Handler m ReadRequest +readRequest QualifiedIdentifier{..} (RequestContext AppConfig{..} dbStructure apiRequest _) = + liftEither $ + ReqBuilder.readRequest qiSchema qiName configDbMaxRows + (dbRelationships dbStructure) + apiRequest + +contentTypeHeaders :: RequestContext -> [HTTP.Header] +contentTypeHeaders RequestContext{..} = + ContentType.toHeader (iAcceptContentType ctxApiRequest) : maybeToList (profileHeader ctxApiRequest) + +-- | If raw(binary) output is requested, check that ContentType is one of the +-- admitted rawContentTypes and that`?select=...` contains only one field other +-- than `*` +binaryField :: Monad m => RequestContext -> ReadRequest -> Handler m (Maybe FieldName) +binaryField RequestContext{..} readReq + | returnsScalar (iTarget ctxApiRequest) && iAcceptContentType ctxApiRequest `elem` rawContentTypes ctxConfig = + return $ Just "pgrst_scalar" + | iAcceptContentType ctxApiRequest `elem` rawContentTypes ctxConfig = + let + fldNames = fstFieldNames readReq + fieldName = headMay fldNames + in + if length fldNames == 1 && fieldName /= Just "*" then + return fieldName + else + throwError $ Error.BinaryFieldError (iAcceptContentType ctxApiRequest) + | otherwise = + return Nothing + +rawContentTypes :: AppConfig -> [ContentType] +rawContentTypes AppConfig{..} = + (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain] + +profileHeader :: ApiRequest -> Maybe HTTP.Header +profileHeader ApiRequest{..} = + (,) "Content-Profile" <$> (toS <$> iProfile) + +splitKeyValue :: ByteString -> (ByteString, ByteString) +splitKeyValue kv = + (k, BS8.tail v) + where + (k, v) = BS8.break (== '=') kv diff --git a/src/PostgREST/AppState.hs b/src/PostgREST/AppState.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/AppState.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE RecordWildCards #-} + +module PostgREST.AppState + ( AppState + , getConfig + , getDbStructure + , getIsWorkerOn + , getJsonDbS + , getMainThreadId + , getPgVersion + , getPool + , getTime + , init + , initWithPool + , logWithZTime + , putConfig + , putDbStructure + , putIsWorkerOn + , putJsonDbS + , putPgVersion + , releasePool + , signalListener + , waitListener + ) where + +import qualified Hasql.Pool as P + +import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, + updateAction) +import Data.IORef (IORef, atomicWriteIORef, newIORef, + readIORef) +import Data.Time (ZonedTime, defaultTimeLocale, formatTime, + getZonedTime) +import Data.Time.Clock (UTCTime, getCurrentTime) + +import PostgREST.Config (AppConfig (..)) +import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion) +import PostgREST.DbStructure (DbStructure) + +import Protolude hiding (toS) +import Protolude.Conv (toS) + + +data AppState = AppState + { statePool :: P.Pool -- | Connection pool, either a 'Connection' or a 'ConnectionError' + , statePgVersion :: IORef PgVersion + -- | No schema cache at the start. Will be filled in by the connectionWorker + , stateDbStructure :: IORef (Maybe DbStructure) + -- | Cached DbStructure in json + , stateJsonDbS :: IORef ByteString + -- | Helper ref to make sure just one connectionWorker can run at a time + , stateIsWorkerOn :: IORef Bool + -- | Binary semaphore used to sync the listener(NOTIFY reload) with the connectionWorker. + , stateListener :: MVar () + -- | Config that can change at runtime + , stateConf :: IORef AppConfig + -- | Time used for verifying JWT expiration + , stateGetTime :: IO UTCTime + -- | Time with time zone used for worker logs + , stateGetZTime :: IO ZonedTime + -- | Used for killing the main thread in case a subthread fails + , stateMainThreadId :: ThreadId + } + +init :: AppConfig -> IO AppState +init conf = do + newPool <- initPool conf + initWithPool newPool conf + +initWithPool :: P.Pool -> AppConfig -> IO AppState +initWithPool newPool conf = + AppState newPool + <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step + <*> newIORef Nothing + <*> newIORef mempty + <*> newIORef False + <*> newEmptyMVar + <*> newIORef conf + <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime } + <*> mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime } + <*> myThreadId + +initPool :: AppConfig -> IO P.Pool +initPool AppConfig{..} = + P.acquire (configDbPoolSize, configDbPoolTimeout, toS configDbUri) + +getPool :: AppState -> P.Pool +getPool = statePool + +releasePool :: AppState -> IO () +releasePool AppState{..} = P.release statePool >> throwTo stateMainThreadId UserInterrupt + +getPgVersion :: AppState -> IO PgVersion +getPgVersion = readIORef . statePgVersion + +putPgVersion :: AppState -> PgVersion -> IO () +putPgVersion = atomicWriteIORef . statePgVersion + +getDbStructure :: AppState -> IO (Maybe DbStructure) +getDbStructure = readIORef . stateDbStructure + +putDbStructure :: AppState -> DbStructure -> IO () +putDbStructure appState structure = + atomicWriteIORef (stateDbStructure appState) $ Just structure + +getJsonDbS :: AppState -> IO ByteString +getJsonDbS = readIORef . stateJsonDbS + +putJsonDbS :: AppState -> ByteString -> IO () +putJsonDbS appState = atomicWriteIORef (stateJsonDbS appState) + +getIsWorkerOn :: AppState -> IO Bool +getIsWorkerOn = readIORef . stateIsWorkerOn + +putIsWorkerOn :: AppState -> Bool -> IO () +putIsWorkerOn = atomicWriteIORef . stateIsWorkerOn + +getConfig :: AppState -> IO AppConfig +getConfig = readIORef . stateConf + +putConfig :: AppState -> AppConfig -> IO () +putConfig = atomicWriteIORef . stateConf + +getTime :: AppState -> IO UTCTime +getTime = stateGetTime + +-- | Log to stderr with local time +logWithZTime :: AppState -> Text -> IO () +logWithZTime appState txt = do + zTime <- stateGetZTime appState + hPutStrLn stderr $ toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <> txt + +getMainThreadId :: AppState -> ThreadId +getMainThreadId = stateMainThreadId + +-- | As this IO action uses `takeMVar` internally, it will only return once +-- `stateListener` has been set using `signalListener`. This is currently used +-- to syncronize workers. +waitListener :: AppState -> IO () +waitListener = takeMVar . stateListener + +-- tryPutMVar doesn't lock the thread. It should always succeed since +-- the connectionWorker is the only mvar producer. +signalListener :: AppState -> IO () +signalListener appState = void $ tryPutMVar (stateListener appState) () diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-| Module : PostgREST.Auth Description : PostgREST authorization functions. @@ -12,103 +10,73 @@ In the test suite there is an example of simple login function that can be used for a very simple authentication system inside the PostgreSQL database. -} -module PostgREST.Auth ( - containsRole +{-# LANGUAGE RecordWildCards #-} +module PostgREST.Auth + ( containsRole , jwtClaims - , JWTAttempt(..) - , parseSecret + , JWTClaims ) where -import qualified Crypto.JOSE.Types as JOSE.Types +import qualified Crypto.JWT as JWT import qualified Data.Aeson as JSON import qualified Data.HashMap.Strict as M -import Data.Vector as V +import qualified Data.Vector as V -import Control.Lens (set) -import Data.Time.Clock (UTCTime) +import Control.Lens (set) +import Control.Monad.Except (liftEither) +import Data.Either.Combinators (mapLeft) +import Data.Time.Clock (UTCTime) -import Control.Lens.Operators -import Crypto.JWT +import PostgREST.Config (AppConfig (..), JSPath, JSPathExp (..)) +import PostgREST.Error (Error (..)) -import PostgREST.Types -import Protolude hiding (toS) -import Protolude.Conv (toS) +import Protolude -{-| - Possible situations encountered with client JWTs --} -data JWTAttempt = JWTInvalid JWTError - | JWTMissingSecret - | JWTClaims (M.HashMap Text JSON.Value) - deriving (Eq, Show) -{-| - Receives the JWT secret and audience (from config) and a JWT and returns a map - of JWT claims. --} -jwtClaims :: Maybe JWKSet -> Maybe StringOrURI -> LByteString -> UTCTime -> Maybe JSPath -> IO JWTAttempt -jwtClaims _ _ "" _ _ = return $ JWTClaims M.empty -jwtClaims secret audience payload time jspath = - case secret of - Nothing -> return JWTMissingSecret - Just s -> do - let validation = set allowedSkew 1 $ defaultJWTValidationSettings (maybe (const True) (==) audience) - eJwt <- runExceptT $ do - jwt <- decodeCompact payload - verifyClaimsAt validation s time jwt - return $ case eJwt of - Left e -> JWTInvalid e - Right jwt -> JWTClaims $ claims2map jwt jspath +type JWTClaims = M.HashMap Text JSON.Value -{-| - Turn JWT ClaimSet into something easier to work with, - also here the jspath is applied to put the "role" in the map --} -claims2map :: ClaimsSet -> Maybe JSPath -> M.HashMap Text JSON.Value -claims2map claims jspath = (\case - val@(JSON.Object o) -> - let role = maybe M.empty (M.singleton "role") $ - walkJSPath (Just val) =<< jspath in - M.delete "role" o `M.union` role -- mutating the map - _ -> M.empty - ) $ JSON.toJSON claims +-- | Receives the JWT secret and audience (from config) and a JWT and returns a +-- map of JWT claims. +jwtClaims :: Monad m => + AppConfig -> LByteString -> UTCTime -> ExceptT Error m JWTClaims +jwtClaims _ "" _ = return M.empty +jwtClaims AppConfig{..} payload time = do + secret <- liftEither . maybeToRight JwtTokenMissing $ configJWKS + eitherClaims <- + lift . runExceptT $ + JWT.verifyClaimsAt validation secret time =<< JWT.decodeCompact payload + liftEither . mapLeft jwtClaimsError $ claimsMap configJwtRoleClaimKey <$> eitherClaims + where + validation = + JWT.defaultJWTValidationSettings audienceCheck & set JWT.allowedSkew 1 -walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value -walkJSPath x [] = x -walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest -walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest -walkJSPath _ _ = Nothing + audienceCheck :: JWT.StringOrURI -> Bool + audienceCheck = maybe (const True) (==) configJwtAudience -{-| - Whether a response from jwtClaims contains a role claim --} -containsRole :: JWTAttempt -> Bool -containsRole (JWTClaims claims) = M.member "role" claims -containsRole _ = False + jwtClaimsError :: JWT.JWTError -> Error + jwtClaimsError JWT.JWTExpired = JwtTokenInvalid "JWT expired" + jwtClaimsError e = JwtTokenInvalid $ show e -{-| - Parse `jwt-secret` configuration option and turn into a JWKSet. +-- | Turn JWT ClaimSet into something easier to work with. +-- +-- Also, here the jspath is applied to put the "role" in the map. +claimsMap :: JSPath -> JWT.ClaimsSet -> JWTClaims +claimsMap jspath claims = + case JSON.toJSON claims of + val@(JSON.Object o) -> + M.delete "role" o `M.union` role val + _ -> + M.empty + where + role value = + maybe M.empty (M.singleton "role") $ walkJSPath (Just value) jspath - There are three ways to specify `jwt-secret`: text secret, JSON Web Key - (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JWKSet - with one key and the last is converted as is. --} -parseSecret :: ByteString -> JWKSet -parseSecret str = - fromMaybe (maybe secret (\jwk' -> JWKSet [jwk']) maybeJWK) - maybeJWKSet - where - maybeJWKSet = JSON.decode (toS str) :: Maybe JWKSet - maybeJWK = JSON.decode (toS str) :: Maybe JWK - secret = JWKSet [jwkFromSecret str] + walkJSPath :: Maybe JSON.Value -> JSPath -> Maybe JSON.Value + walkJSPath x [] = x + walkJSPath (Just (JSON.Object o)) (JSPKey key:rest) = walkJSPath (M.lookup key o) rest + walkJSPath (Just (JSON.Array ar)) (JSPIdx idx:rest) = walkJSPath (ar V.!? idx) rest + walkJSPath _ _ = Nothing -{-| - Internal helper to generate a symmetric HMAC-SHA256 JWK from a text secret. --} -jwkFromSecret :: ByteString -> JWK -jwkFromSecret key = - fromKeyMaterial km - & jwkUse ?~ Sig - & jwkAlg ?~ JWSAlg HS256 - where - km = OctKeyMaterial (OctKeyParameters (JOSE.Types.Base64Octets key)) +-- | Whether a response from jwtClaims contains a role claim +containsRole :: JWTClaims -> Bool +containsRole = M.member "role" diff --git a/src/PostgREST/CLI.hs b/src/PostgREST/CLI.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/CLI.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +module PostgREST.CLI + ( main + , CLI (..) + , Command (..) + , readCLIShowHelp + ) where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import qualified Hasql.Pool as P +import qualified Hasql.Transaction.Sessions as HT +import qualified Options.Applicative as O +import qualified Protolude.Conv as Conv + +import Data.Text.IO (hPutStrLn) +import Text.Heredoc (str) + +import PostgREST.AppState (AppState) +import PostgREST.Config (AppConfig (..)) +import PostgREST.DbStructure (queryDbStructure) +import PostgREST.Version (prettyVersion) +import PostgREST.Workers (reReadConfig) + +import qualified PostgREST.App as App +import qualified PostgREST.AppState as AppState +import qualified PostgREST.Config as Config + +import Protolude hiding (hPutStrLn) + + +main :: App.SignalHandlerInstaller -> Maybe App.SocketRunner -> CLI -> IO () +main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do + conf@AppConfig{..} <- + either panic identity <$> Config.readAppConfig mempty cliPath Nothing + appState <- AppState.init conf + + -- Override the config with config options from the db + -- TODO: the same operation is repeated on connectionWorker, ideally this + -- would be done only once, but dump CmdDumpConfig needs it for tests. + when configDbConfig $ reReadConfig True appState + + exec cliCommand appState + where + exec :: Command -> AppState -> IO () + exec CmdDumpConfig appState = putStr . Config.toText =<< AppState.getConfig appState + exec CmdDumpSchema appState = putStrLn =<< dumpSchema appState + exec CmdRun appState = App.run installSignalHandlers runAppWithSocket appState + +-- | Dump DbStructure schema to JSON +dumpSchema :: AppState -> IO LBS.ByteString +dumpSchema appState = do + AppConfig{..} <- AppState.getConfig appState + result <- + let transaction = if configDbPreparedStatements then HT.transaction else HT.unpreparedTransaction in + P.use (AppState.getPool appState) $ + transaction HT.ReadCommitted HT.Read $ + queryDbStructure + (toList configDbSchemas) + configDbExtraSearchPath + configDbPreparedStatements + P.release $ AppState.getPool appState + case result of + Left e -> do + hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e + exitFailure + Right dbStructure -> return $ Aeson.encode dbStructure + +-- | Command line interface options +data CLI = CLI + { cliCommand :: Command + , cliPath :: Maybe FilePath + } + +data Command + = CmdRun + | CmdDumpConfig + | CmdDumpSchema + +-- | Read command line interface options. Also prints help. +readCLIShowHelp :: Bool -> IO CLI +readCLIShowHelp hasEnvironment = + O.customExecParser prefs opts + where + prefs = O.prefs $ O.showHelpOnError <> O.showHelpOnEmpty + opts = O.info parser $ O.fullDesc <> progDesc <> footer + parser = O.helper <*> exampleParser <*> cliParser + + progDesc = + O.progDesc $ + "PostgREST " + <> Conv.toS prettyVersion + <> " / create a REST API to an existing Postgres database" + + footer = + O.footer $ + "To run PostgREST, please pass the FILENAME argument" + <> " or set PGRST_ environment variables." + + exampleParser = + O.infoOption exampleConfigFile $ + O.long "example" + <> O.short 'e' + <> O.help "Show an example configuration file" + + cliParser :: O.Parser CLI + cliParser = + CLI + <$> (dumpConfigFlag <|> dumpSchemaFlag) + <*> optionalIf hasEnvironment configFileOption + + configFileOption = + O.strArgument $ + O.metavar "FILENAME" + <> O.help "Path to configuration file (optional with PGRST_ environment variables)" + + dumpConfigFlag = + O.flag CmdRun CmdDumpConfig $ + O.long "dump-config" + <> O.help "Dump loaded configuration and exit" + + dumpSchemaFlag = + O.flag CmdRun CmdDumpSchema $ + O.long "dump-schema" + <> O.help "Dump loaded schema as JSON and exit (for debugging, output structure is unstable)" + + optionalIf :: Alternative f => Bool -> f a -> f (Maybe a) + optionalIf True = O.optional + optionalIf False = fmap Just + +exampleConfigFile :: [Char] +exampleConfigFile = + [str|### REQUIRED: + |db-uri = "postgres://user:pass@localhost:5432/dbname" + |db-schema = "public" + |db-anon-role = "postgres" + | + |### OPTIONAL: + |## number of open connections in the pool + |db-pool = 10 + | + |## Time to live, in seconds, for an idle database pool connection. + |db-pool-timeout = 10 + | + |## extra schemas to add to the search_path of every request + |db-extra-search-path = "public" + | + |## limit rows in response + |# db-max-rows = 1000 + | + |## stored proc to exec immediately after auth + |# db-pre-request = "stored_proc_name" + | + |## stored proc that overrides the root "/" spec + |## it must be inside the db-schema + |# db-root-spec = "stored_proc_name" + | + |## Notification channel for reloading the schema cache + |db-channel = "pgrst" + | + |## Enable or disable the notification channel + |db-channel-enabled = true + | + |## Enable in-database configuration + |db-config = true + | + |## how to terminate database transactions + |## possible values are: + |## commit (default) + |## transaction is always committed, this can not be overriden + |## commit-allow-override + |## transaction is committed, but can be overriden with Prefer tx=rollback header + |## rollback + |## transaction is always rolled back, this can not be overriden + |## rollback-allow-override + |## transaction is rolled back, but can be overriden with Prefer tx=commit header + |db-tx-end = "commit" + | + |## enable or disable prepared statements. disabling is only necessary when behind a connection pooler. + |## when disabled, statements will be parametrized but won't be prepared. + |db-prepared-statements = true + | + |server-host = "!4" + |server-port = 3000 + | + |## unix socket location + |## if specified it takes precedence over server-port + |# server-unix-socket = "/tmp/pgrst.sock" + | + |## unix socket file mode + |## when none is provided, 660 is applied by default + |# server-unix-socket-mode = "660" + | + |## determine if the OpenAPI output should follow or ignore role privileges or be disabled entirely + |## admitted values: follow-privileges, ignore-privileges, disabled + |openapi-mode = "follow-privileges" + | + |## base url for the OpenAPI output + |openapi-server-proxy-uri = "" + | + |## choose a secret, JSON Web Key (or set) to enable JWT auth + |## (use "@filename" to load from separate file) + |# jwt-secret = "secret_with_at_least_32_characters" + |# jwt-aud = "your_audience_claim" + |jwt-secret-is-base64 = false + | + |## jspath to the role claim key + |jwt-role-claim-key = ".role" + | + |## content types to produce raw output + |# raw-media-types="image/png, image/jpg" + | + |## logging level, the admitted values are: crit, error, warn and info. + |log-level = "error" + |] diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -1,218 +1,364 @@ {-| Module : PostgREST.Config -Description : Manages PostgREST configuration options. - -This module provides a helper function to read the command line -arguments using the optparse-applicative and the AppConfig type to store -them. It also can be used to define other middleware configuration that -may be delegated to some sort of external configuration. - -It currently includes a hardcoded CORS policy but this could easly be -turned in configurable behaviour if needed. +Description : Manages PostgREST configuration type and parser. -Other hardcoded options such as the minimum version number also belong here. -} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -module PostgREST.Config ( prettyVersion - , docsVersion - , readOptions - , corsPolicy - , AppConfig (..) - , configPoolTimeout' - ) - where +module PostgREST.Config + ( AppConfig (..) + , Environment + , JSPath + , JSPathExp(..) + , LogLevel(..) + , OpenAPIMode(..) + , Proxy(..) + , toText + , isMalformedProxyUri + , readAppConfig + , readPGRSTEnvironment + , toURI + , parseSecret + ) where -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BS -import qualified Data.CaseInsensitive as CI -import qualified Data.Configurator as C -import qualified Text.PrettyPrint.ANSI.Leijen as L +import qualified Crypto.JOSE.Types as JOSE +import qualified Crypto.JWT as JWT +import qualified Data.Aeson as JSON +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BS +import qualified Data.Configurator as C +import qualified Data.Map.Strict as M +import qualified Data.Text as T -import Control.Lens (preview) -import Control.Monad (fail) -import Crypto.JWT (StringOrURI, stringOrUri) -import Data.List (lookup) -import Data.List.NonEmpty (fromList) -import Data.Scientific (floatingOrInteger) -import Data.Text (dropEnd, dropWhileEnd, - intercalate, splitOn, strip, take, - unpack) -import Data.Text.IO (hPutStrLn) -import Data.Version (versionBranch) -import Development.GitRev (gitHash) -import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) -import Numeric (readOct) -import Paths_postgrest (version) -import System.IO.Error (IOError) -import System.Posix.Types (FileMode) +import qualified GHC.Show (show) -import Control.Applicative -import Data.Monoid -import Network.Wai -import Options.Applicative hiding (str) -import Text.Heredoc -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) +import Control.Lens (preview) +import Control.Monad (fail) +import Crypto.JWT (JWK, JWKSet, StringOrURI, stringOrUri) +import Data.Aeson (encode, toJSON) +import Data.Either.Combinators (mapLeft) +import Data.List (lookup) +import Data.List.NonEmpty (fromList, toList) +import Data.Maybe (fromJust) +import Data.Scientific (floatingOrInteger) +import Data.Time.Clock (NominalDiffTime) +import Numeric (readOct, showOct) +import System.Environment (getEnvironment) +import System.Posix.Types (FileMode) -import PostgREST.Error (ApiRequestError (..)) -import PostgREST.Parsers (pRoleClaimKey) -import PostgREST.Types (JSPath, JSPathExp (..)) -import Protolude hiding (concat, hPutStrLn, intercalate, null, - take, toS, (<>)) -import Protolude.Conv (toS) +import PostgREST.Config.JSPath (JSPath, JSPathExp (..), + pRoleClaimKey) +import PostgREST.Config.Proxy (Proxy (..), + isMalformedProxyUri, toURI) +import PostgREST.DbStructure.Identifiers (QualifiedIdentifier, toQi) +import Protolude hiding (Proxy, toList, toS) +import Protolude.Conv (toS) --- | Config file settings for the server -data AppConfig = AppConfig { - configDatabase :: Text - , configAnonRole :: Text - , configOpenAPIProxyUri :: Maybe Text - , configSchemas :: NonEmpty Text - , configHost :: Text - , configPort :: Int - , configSocket :: Maybe FilePath - , configSocketMode :: Either Text FileMode - , configJwtSecret :: Maybe B.ByteString - , configJwtSecretIsBase64 :: Bool - , configJwtAudience :: Maybe StringOrURI - - , configPool :: Int - , configPoolTimeout :: Int - , configMaxRows :: Maybe Integer - , configReqCheck :: Maybe Text - , configQuiet :: Bool - , configSettings :: [(Text, Text)] - , configRoleClaimKey :: Either ApiRequestError JSPath - , configExtraSearchPath :: [Text] - - , configRootSpec :: Maybe Text - , configRawMediaTypes :: [B.ByteString] +data AppConfig = AppConfig + { configAppSettings :: [(Text, Text)] + , configDbAnonRole :: Text + , configDbChannel :: Text + , configDbChannelEnabled :: Bool + , configDbExtraSearchPath :: [Text] + , configDbMaxRows :: Maybe Integer + , configDbPoolSize :: Int + , configDbPoolTimeout :: NominalDiffTime + , configDbPreRequest :: Maybe QualifiedIdentifier + , configDbPreparedStatements :: Bool + , configDbRootSpec :: Maybe QualifiedIdentifier + , configDbSchemas :: NonEmpty Text + , configDbConfig :: Bool + , configDbTxAllowOverride :: Bool + , configDbTxRollbackAll :: Bool + , configDbUri :: Text + , configFilePath :: Maybe FilePath + , configJWKS :: Maybe JWKSet + , configJwtAudience :: Maybe StringOrURI + , configJwtRoleClaimKey :: JSPath + , configJwtSecret :: Maybe B.ByteString + , configJwtSecretIsBase64 :: Bool + , configLogLevel :: LogLevel + , configOpenApiMode :: OpenAPIMode + , configOpenApiServerProxyUri :: Maybe Text + , configRawMediaTypes :: [B.ByteString] + , configServerHost :: Text + , configServerPort :: Int + , configServerUnixSocket :: Maybe FilePath + , configServerUnixSocketMode :: FileMode } -configPoolTimeout' :: (Fractional a) => AppConfig -> a -configPoolTimeout' = - fromRational . toRational . configPoolTimeout +data LogLevel = LogCrit | LogError | LogWarn | LogInfo +instance Show LogLevel where + show LogCrit = "crit" + show LogError = "error" + show LogWarn = "warn" + show LogInfo = "info" -defaultCorsPolicy :: CorsResourcePolicy -defaultCorsPolicy = CorsResourcePolicy Nothing - ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing - (Just $ 60*60*24) False False True +data OpenAPIMode = OAFollowPriv | OAIgnorePriv | OADisabled + deriving Eq --- | CORS policy to be used in by Wai Cors middleware -corsPolicy :: Request -> Maybe CorsResourcePolicy -corsPolicy req = case lookup "origin" headers of - Just origin -> Just defaultCorsPolicy { - corsOrigins = Just ([origin], True) - , corsRequestHeaders = "Authentication":accHeaders - , corsExposedHeaders = Just [ - "Content-Encoding", "Content-Location", "Content-Range", "Content-Type" - , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit" - ] - } - Nothing -> Nothing +instance Show OpenAPIMode where + show OAFollowPriv = "follow-privileges" + show OAIgnorePriv = "ignore-privileges" + show OADisabled = "disabled" + +-- | Dump the config +toText :: AppConfig -> Text +toText conf = + unlines $ (\(k, v) -> k <> " = " <> v) <$> pgrstSettings ++ appSettings where - headers = requestHeaders req - accHeaders = case lookup "access-control-request-headers" headers of - Just hdrs -> map (CI.mk . toS . strip . toS) $ BS.split ',' hdrs - Nothing -> [] + -- apply conf to all pgrst settings + pgrstSettings = (\(k, v) -> (k, v conf)) <$> + [("db-anon-role", q . configDbAnonRole) + ,("db-channel", q . configDbChannel) + ,("db-channel-enabled", T.toLower . show . configDbChannelEnabled) + ,("db-extra-search-path", q . T.intercalate "," . configDbExtraSearchPath) + ,("db-max-rows", maybe "\"\"" show . configDbMaxRows) + ,("db-pool", show . configDbPoolSize) + ,("db-pool-timeout", show . floor . configDbPoolTimeout) + ,("db-pre-request", q . maybe mempty show . configDbPreRequest) + ,("db-prepared-statements", T.toLower . show . configDbPreparedStatements) + ,("db-root-spec", q . maybe mempty show . configDbRootSpec) + ,("db-schemas", q . T.intercalate "," . toList . configDbSchemas) + ,("db-config", q . T.toLower . show . configDbConfig) + ,("db-tx-end", q . showTxEnd) + ,("db-uri", q . configDbUri) + ,("jwt-aud", toS . encode . maybe "" toJSON . configJwtAudience) + ,("jwt-role-claim-key", q . T.intercalate mempty . fmap show . configJwtRoleClaimKey) + ,("jwt-secret", q . toS . showJwtSecret) + ,("jwt-secret-is-base64", T.toLower . show . configJwtSecretIsBase64) + ,("log-level", q . show . configLogLevel) + ,("openapi-mode", q . show . configOpenApiMode) + ,("openapi-server-proxy-uri", q . fromMaybe mempty . configOpenApiServerProxyUri) + ,("raw-media-types", q . toS . B.intercalate "," . configRawMediaTypes) + ,("server-host", q . configServerHost) + ,("server-port", show . configServerPort) + ,("server-unix-socket", q . maybe mempty T.pack . configServerUnixSocket) + ,("server-unix-socket-mode", q . T.pack . showSocketMode) + ] --- | User friendly version number -prettyVersion :: Text -prettyVersion = - intercalate "." (map show $ versionBranch version) - <> " (" <> take 7 $(gitHash) <> ")" + -- quote all app.settings + appSettings = second q <$> configAppSettings conf --- | Version number used in docs -docsVersion :: Text -docsVersion = "v" <> dropEnd 1 (dropWhileEnd (/= '.') prettyVersion) + -- quote strings and replace " with \" + q s = "\"" <> T.replace "\"" "\\\"" s <> "\"" --- | Function to read and parse options from the command line -readOptions :: IO AppConfig -readOptions = do - -- First read the config file path from command line - cfgPath <- customExecParser parserPrefs opts - -- Now read the actual config file - conf <- catches (C.load cfgPath) - [ Handler (\(ex :: IOError) -> exitErr $ "Cannot open config file:\n\t" <> show ex) - , Handler (\(C.ParseError err) -> exitErr $ "Error parsing config file:\n" <> err) - ] + showTxEnd c = case (configDbTxRollbackAll c, configDbTxAllowOverride c) of + ( False, False ) -> "commit" + ( False, True ) -> "commit-allow-override" + ( True , False ) -> "rollback" + ( True , True ) -> "rollback-allow-override" + showJwtSecret c + | configJwtSecretIsBase64 c = B64.encode secret + | otherwise = toS secret + where + secret = fromMaybe mempty $ configJwtSecret c + showSocketMode c = showOct (configServerUnixSocketMode c) mempty - case C.runParser parseConfig conf of +-- This class is needed for the polymorphism of overrideFromDbOrEnvironment +-- because C.required and C.optional have different signatures +class JustIfMaybe a b where + justIfMaybe :: a -> b + +instance JustIfMaybe a a where + justIfMaybe a = a + +instance JustIfMaybe a (Maybe a) where + justIfMaybe a = Just a + +-- | Reads and parses the config and overrides its parameters from env vars, +-- files or db settings. +readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> IO (Either Text AppConfig) +readAppConfig dbSettings optPath prevDbUri = do + env <- readPGRSTEnvironment + -- if no filename provided, start with an empty map to read config from environment + conf <- maybe (return $ Right M.empty) loadConfig optPath + + case C.runParser (parser optPath env dbSettings) =<< mapLeft show conf of Left err -> - exitErr $ "Error parsing config file:\n\t" <> err - Right appConf -> - return appConf + return . Left $ "Error in config " <> err + Right parsedConfig -> + Right <$> decodeLoadFiles parsedConfig + where + -- Both C.ParseError and IOError are shown here + loadConfig :: FilePath -> IO (Either SomeException C.Config) + loadConfig = try . C.load + decodeLoadFiles :: AppConfig -> IO AppConfig + decodeLoadFiles parsedConfig = + decodeJWKS <$> + (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig) + +parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> C.Parser C.Config AppConfig +parser optPath env dbSettings = + AppConfig + <$> parseAppSettings "app.settings" + <*> reqString "db-anon-role" + <*> (fromMaybe "pgrst" <$> optString "db-channel") + <*> (fromMaybe True <$> optBool "db-channel-enabled") + <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path") + <*> optWithAlias (optInt "db-max-rows") + (optInt "max-rows") + <*> (fromMaybe 10 <$> optInt "db-pool") + <*> (fromIntegral . fromMaybe 10 <$> optInt "db-pool-timeout") + <*> (fmap toQi <$> optWithAlias (optString "db-pre-request") + (optString "pre-request")) + <*> (fromMaybe True <$> optBool "db-prepared-statements") + <*> (fmap toQi <$> optWithAlias (optString "db-root-spec") + (optString "root-spec")) + <*> (fromList . splitOnCommas <$> reqWithAlias (optValue "db-schemas") + (optValue "db-schema") + "missing key: either db-schemas or db-schema must be set") + <*> (fromMaybe True <$> optBool "db-config") + <*> parseTxEnd "db-tx-end" snd + <*> parseTxEnd "db-tx-end" fst + <*> reqString "db-uri" + <*> pure optPath + <*> pure Nothing + <*> parseJwtAudience "jwt-aud" + <*> parseRoleClaimKey "jwt-role-claim-key" "role-claim-key" + <*> (fmap encodeUtf8 <$> optString "jwt-secret") + <*> (fromMaybe False <$> optWithAlias + (optBool "jwt-secret-is-base64") + (optBool "secret-is-base64")) + <*> parseLogLevel "log-level" + <*> parseOpenAPIMode "openapi-mode" + <*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri" + <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types") + <*> (fromMaybe "!4" <$> optString "server-host") + <*> (fromMaybe 3000 <$> optInt "server-port") + <*> (fmap T.unpack <$> optString "server-unix-socket") + <*> parseSocketFileMode "server-unix-socket-mode" where - parseConfig = - AppConfig - <$> reqString "db-uri" - <*> reqString "db-anon-role" - <*> optString "openapi-server-proxy-uri" - <*> (fromList . splitOnCommas <$> reqValue "db-schema") - <*> (fromMaybe "!4" <$> optString "server-host") - <*> (fromMaybe 3000 <$> optInt "server-port") - <*> (fmap unpack <$> optString "server-unix-socket") - <*> parseSocketFileMode "server-unix-socket-mode" - <*> (fmap encodeUtf8 <$> optString "jwt-secret") - <*> (fromMaybe False <$> optBool "secret-is-base64") - <*> parseJwtAudience "jwt-aud" - <*> (fromMaybe 10 <$> optInt "db-pool") - <*> (fromMaybe 10 <$> optInt "db-pool-timeout") - <*> optInt "max-rows" - <*> optString "pre-request" - <*> pure False - <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings" C.value) - <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key") - <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path") - <*> optString "root-spec" - <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types") + parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)] + parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value + where + addFromEnv f = M.toList $ M.union fromEnv $ M.fromList f + fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env + normalize k = ("app.settings." <>) <$> T.stripPrefix "PGRST_APP_SETTINGS_" (toS k) - parseSocketFileMode :: C.Key -> C.Parser C.Config (Either Text FileMode) + parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode parseSocketFileMode k = - C.optional k C.string >>= \case - Nothing -> pure $ Right 432 -- return default 660 mode if no value was provided + optString k >>= \case + Nothing -> pure 432 -- return default 660 mode if no value was provided Just fileModeText -> - case (readOct . unpack) fileModeText of + case readOct $ T.unpack fileModeText of [] -> - pure $ Left "Invalid server-unix-socket-mode: not an octal" + fail "Invalid server-unix-socket-mode: not an octal" (fileMode, _):_ -> if fileMode < 384 || fileMode > 511 - then pure $ Left "Invalid server-unix-socket-mode: needs to be between 600 and 777" - else pure $ Right fileMode + then fail "Invalid server-unix-socket-mode: needs to be between 600 and 777" + else pure fileMode + parseOpenAPIMode :: C.Key -> C.Parser C.Config OpenAPIMode + parseOpenAPIMode k = + optString k >>= \case + Nothing -> pure OAFollowPriv + Just "follow-privileges" -> pure OAFollowPriv + Just "ignore-privileges" -> pure OAIgnorePriv + Just "disabled" -> pure OADisabled + Just _ -> fail "Invalid openapi-mode. Check your configuration." + + parseOpenAPIServerProxyURI :: C.Key -> C.Parser C.Config (Maybe Text) + parseOpenAPIServerProxyURI k = + optString k >>= \case + Nothing -> pure Nothing + Just val | isMalformedProxyUri val -> fail "Malformed proxy uri, a correct example: https://example.com:8443/basePath" + | otherwise -> pure $ Just val + parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI) parseJwtAudience k = - C.optional k C.string >>= \case + optString k >>= \case Nothing -> pure Nothing -- no audience in config file - Just aud -> case preview stringOrUri (unpack aud) of + Just aud -> case preview stringOrUri (T.unpack aud) of Nothing -> fail "Invalid Jwt audience. Check your configuration." - (Just "") -> pure Nothing aud' -> pure aud' - reqString :: C.Key -> C.Parser C.Config Text - reqString k = C.required k C.string + parseLogLevel :: C.Key -> C.Parser C.Config LogLevel + parseLogLevel k = + optString k >>= \case + Nothing -> pure LogError + Just "crit" -> pure LogCrit + Just "error" -> pure LogError + Just "warn" -> pure LogWarn + Just "info" -> pure LogInfo + Just _ -> fail "Invalid logging level. Check your configuration." - reqValue :: C.Key -> C.Parser C.Config C.Value - reqValue k = C.required k C.value + parseTxEnd :: C.Key -> ((Bool, Bool) -> Bool) -> C.Parser C.Config Bool + parseTxEnd k f = + optString k >>= \case + -- RollbackAll AllowOverride + Nothing -> pure $ f (False, False) + Just "commit" -> pure $ f (False, False) + Just "commit-allow-override" -> pure $ f (False, True) + Just "rollback" -> pure $ f (True, False) + Just "rollback-allow-override" -> pure $ f (True, True) + Just _ -> fail "Invalid transaction termination. Check your configuration." + parseRoleClaimKey :: C.Key -> C.Key -> C.Parser C.Config JSPath + parseRoleClaimKey k al = + optWithAlias (optString k) (optString al) >>= \case + Nothing -> pure [JSPKey "role"] + Just rck -> either (fail . show) pure $ pRoleClaimKey rck + + reqWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> [Char] -> C.Parser C.Config a + reqWithAlias orig alias err = + orig >>= \case + Just v -> pure v + Nothing -> + alias >>= \case + Just v -> pure v + Nothing -> fail err + + optWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) + optWithAlias orig alias = + orig >>= \case + Just v -> pure $ Just v + Nothing -> alias + + reqString :: C.Key -> C.Parser C.Config Text + reqString k = overrideFromDbOrEnvironment C.required k coerceText + optString :: C.Key -> C.Parser C.Config (Maybe Text) - optString k = mfilter (/= "") <$> C.optional k C.string + optString k = mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText optValue :: C.Key -> C.Parser C.Config (Maybe C.Value) - optValue k = C.optional k C.value + optValue k = overrideFromDbOrEnvironment C.optional k identity optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i) - optInt k = join <$> C.optional k (coerceInt <$> C.value) + optInt k = join <$> overrideFromDbOrEnvironment C.optional k coerceInt optBool :: C.Key -> C.Parser C.Config (Maybe Bool) - optBool k = join <$> C.optional k (coerceBool <$> C.value) + optBool k = join <$> overrideFromDbOrEnvironment C.optional k coerceBool + overrideFromDbOrEnvironment :: JustIfMaybe a b => + (C.Key -> C.Parser C.Value a -> C.Parser C.Config b) -> + C.Key -> (C.Value -> a) -> C.Parser C.Config b + overrideFromDbOrEnvironment necessity key coercion = + case reloadableDbSetting <|> M.lookup envVarName env of + Just dbOrEnvVal -> pure $ justIfMaybe $ coercion $ C.String dbOrEnvVal + Nothing -> necessity key (coercion <$> C.value) + where + dashToUnderscore '-' = '_' + dashToUnderscore c = c + envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key) + reloadableDbSetting = + let dbSettingName = T.pack $ dashToUnderscore <$> toS key in + if dbSettingName `notElem` [ + "server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "log_level", + "db_anon_role", "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_timeout", "db_config"] + then lookup dbSettingName dbSettings + else Nothing + coerceText :: C.Value -> Text coerceText (C.String s) = s coerceText v = show v @@ -224,85 +370,77 @@ coerceBool :: C.Value -> Maybe Bool coerceBool (C.Bool b) = Just b - coerceBool (C.String b) = readMaybe $ toS b + coerceBool (C.String s) = + -- parse all kinds of text: True, true, TRUE, "true", ... + case readMaybe . toS $ T.toTitle $ T.filter isAlpha $ toS s of + Just b -> Just b + -- numeric instead? + Nothing -> (> 0) <$> (readMaybe $ toS s :: Maybe Integer) coerceBool _ = Nothing - parseRoleClaimKey :: C.Value -> Either ApiRequestError JSPath - parseRoleClaimKey (C.String s) = pRoleClaimKey s - parseRoleClaimKey v = pRoleClaimKey $ show v - splitOnCommas :: C.Value -> [Text] - splitOnCommas (C.String s) = strip <$> splitOn "," s + splitOnCommas (C.String s) = T.strip <$> T.splitOn "," s splitOnCommas _ = [] - opts = info (helper <*> pathParser) $ - fullDesc - <> progDesc ( - "PostgREST " - <> toS prettyVersion - <> " / create a REST API to an existing Postgres database" - ) - <> footerDoc (Just $ - text "Example Config File:" - L.<> nest 2 (hardline L.<> exampleCfg) - ) +-- | Read the JWT secret from a file if configJwtSecret is actually a +-- filepath(has @ as its prefix). To check if the JWT secret is provided is +-- in fact a file path, it must be decoded as 'Text' to be processed. +readSecretFile :: AppConfig -> IO AppConfig +readSecretFile conf = + maybe (return conf) readSecret maybeFilename + where + maybeFilename = T.stripPrefix "@" . decodeUtf8 =<< configJwtSecret conf + readSecret filename = do + jwtSecret <- chomp <$> BS.readFile (toS filename) + return $ conf { configJwtSecret = Just jwtSecret } + chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs) - parserPrefs = prefs showHelpOnError +decodeSecret :: AppConfig -> IO AppConfig +decodeSecret conf@AppConfig{..} = + case (configJwtSecretIsBase64, configJwtSecret) of + (True, Just secret) -> + either fail (return . updateSecret) $ decodeB64 secret + _ -> return conf + where + updateSecret bs = conf { configJwtSecret = Just bs } + decodeB64 = B64.decode . encodeUtf8 . T.strip . replaceUrlChars . decodeUtf8 + replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "=" - exitErr :: Text -> IO a - exitErr err = do - hPutStrLn stderr err - exitFailure +-- | Parse `jwt-secret` configuration option and turn into a JWKSet. +-- +-- There are three ways to specify `jwt-secret`: text secret, JSON Web Key +-- (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JWKSet +-- with one key and the last is converted as is. +decodeJWKS :: AppConfig -> AppConfig +decodeJWKS conf = + conf { configJWKS = parseSecret <$> configJwtSecret conf } - exampleCfg :: Doc - exampleCfg = vsep . map (text . toS) . lines $ - [str|db-uri = "postgres://user:pass@localhost:5432/dbname" - |db-schema = "public" # this schema gets added to the search_path of every request - |db-anon-role = "postgres" - |db-pool = 10 - |db-pool-timeout = 10 - | - |server-host = "!4" - |server-port = 3000 - | - |## unix socket location - |## if specified it takes precedence over server-port - |# server-unix-socket = "/tmp/pgrst.sock" - |## unix socket file mode - |## when none is provided, 660 is applied by default - |# server-unix-socket-mode = "660" - | - |## base url for swagger output - |# openapi-server-proxy-uri = "" - | - |## choose a secret, JSON Web Key (or set) to enable JWT auth - |## (use "@filename" to load from separate file) - |# jwt-secret = "secret_with_at_least_32_characters" - |# secret-is-base64 = false - |# jwt-aud = "your_audience_claim" - | - |## limit rows in response - |# max-rows = 1000 - | - |## stored proc to exec immediately after auth - |# pre-request = "stored_proc_name" - | - |## jspath to the role claim key - |# role-claim-key = ".role" - | - |## extra schemas to add to the search_path of every request - |# db-extra-search-path = "extensions, util" - | - |## stored proc that overrides the root "/" spec - |## it must be inside the db-schema - |# root-spec = "stored_proc_name" - | - |## content types to produce raw output - |# raw-media-types="image/png, image/jpg" - |] +parseSecret :: ByteString -> JWKSet +parseSecret bytes = + fromMaybe (maybe secret (\jwk' -> JWT.JWKSet [jwk']) maybeJWK) + maybeJWKSet + where + maybeJWKSet = JSON.decode (toS bytes) :: Maybe JWKSet + maybeJWK = JSON.decode (toS bytes) :: Maybe JWK + secret = JWT.JWKSet [JWT.fromKeyMaterial keyMaterial] + keyMaterial = JWT.OctKeyMaterial . JWT.OctKeyParameters $ JOSE.Base64Octets bytes -pathParser :: Parser FilePath -pathParser = - strArgument $ - metavar "FILENAME" <> - help "Path to configuration file" +-- | Read database uri from a separate file if `db-uri` is a filepath. +readDbUriFile :: Maybe Text -> AppConfig -> IO AppConfig +readDbUriFile maybeDbUri conf = + case maybeDbUri of + Just prevDbUri -> + pure $ conf { configDbUri = prevDbUri } + Nothing -> + case T.stripPrefix "@" $ configDbUri conf of + Nothing -> return conf + Just filename -> do + dbUri <- T.strip <$> readFile (toS filename) + return $ conf { configDbUri = dbUri } + +type Environment = M.Map [Char] Text + +-- | Read environment variables that start with PGRST_ +readPGRSTEnvironment :: IO Environment +readPGRSTEnvironment = + M.map T.pack . M.fromList . filter (isPrefixOf "PGRST_" . fst) <$> getEnvironment diff --git a/src/PostgREST/Config/Database.hs b/src/PostgREST/Config/Database.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Config/Database.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE QuasiQuotes #-} + +module PostgREST.Config.Database + ( queryDbSettings + , queryPgVersion + ) where + +import PostgREST.Config.PgVersion (PgVersion (..)) + +import qualified Hasql.Decoders as HD +import qualified Hasql.Encoders as HE +import qualified Hasql.Pool as P +import qualified Hasql.Session as H +import qualified Hasql.Statement as H +import qualified Hasql.Transaction as HT +import qualified Hasql.Transaction.Sessions as HT + +import Text.InterpolatedString.Perl6 (q) + +import Protolude + +queryPgVersion :: H.Session PgVersion +queryPgVersion = H.statement mempty $ H.Statement sql HE.noParams versionRow False + where + sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')" + versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text + +queryDbSettings :: P.Pool -> Bool -> IO (Either P.UsageError [(Text, Text)]) +queryDbSettings pool prepared = + let transaction = if prepared then HT.transaction else HT.unpreparedTransaction in + P.use pool . transaction HT.ReadCommitted HT.Read $ + HT.statement mempty dbSettingsStatement + +-- | Get db settings from the connection role. Global settings will be overridden by database specific settings. +dbSettingsStatement :: H.Statement () [(Text, Text)] +dbSettingsStatement = H.Statement sql HE.noParams decodeSettings False + where + sql = [q| + with + role_setting as ( + select setdatabase, unnest(setconfig) as setting from pg_catalog.pg_db_role_setting + where setrole = current_user::regrole::oid + and setdatabase in (0, (select oid from pg_catalog.pg_database where datname = current_catalog)) + ), + kv_settings as ( + select setdatabase, split_part(setting, '=', 1) as k, split_part(setting, '=', 2) as value from role_setting + where setting like 'pgrst.%' + ) + select distinct on (key) replace(k, 'pgrst.', '') as key, value + from kv_settings + order by key, setdatabase desc; + |] + decodeSettings = HD.rowList $ (,) <$> column HD.text <*> column HD.text + +column :: HD.Value a -> HD.Row a +column = HD.column . HD.nonNullable diff --git a/src/PostgREST/Config/JSPath.hs b/src/PostgREST/Config/JSPath.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Config/JSPath.hs @@ -0,0 +1,59 @@ +{-| +Module : PostgREST.Types +Description : PostgREST common types and functions used by the rest of the modules +-} +{-# LANGUAGE DuplicateRecordFields #-} + +module PostgREST.Config.JSPath + ( JSPath + , JSPathExp(..) + , pRoleClaimKey + ) where + +import qualified Text.ParserCombinators.Parsec as P + +import Data.Either.Combinators (mapLeft) +import Text.ParserCombinators.Parsec (()) +import Text.Read (read) + +import qualified GHC.Show (show) + +import Protolude hiding (toS) +import Protolude.Conv (toS) + + +-- | full jspath, e.g. .property[0].attr.detail +type JSPath = [JSPathExp] + +-- | jspath expression, e.g. .property, .property[0] or ."property-dash" +data JSPathExp + = JSPKey Text + | JSPIdx Int + +instance Show JSPathExp where + -- TODO: this needs to be quoted properly for special chars + show (JSPKey k) = "." <> show k + show (JSPIdx i) = "[" <> show i <> "]" + +-- Used for the config value "role-claim-key" +pRoleClaimKey :: Text -> Either Text JSPath +pRoleClaimKey selStr = + mapLeft show $ P.parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr) + +pJSPath :: P.Parser JSPath +pJSPath = toJSPath <$> (period *> pPath `P.sepBy` period <* P.eof) + where + toJSPath :: [(Text, Maybe Int)] -> JSPath + toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx)) + period = P.char '.' "period (.)" + pPath :: P.Parser (Text, Maybe Int) + pPath = (,) <$> pJSPKey <*> P.optionMaybe pJSPIdx + +pJSPKey :: P.Parser Text +pJSPKey = toS <$> P.many1 (P.alphaNum <|> P.oneOf "_$@") <|> pQuotedValue "attribute name [a..z0..9_$@])" + +pJSPIdx :: P.Parser Int +pJSPIdx = P.char '[' *> (read <$> P.many1 P.digit) <* P.char ']' "array index [0..n]" + +pQuotedValue :: P.Parser Text +pQuotedValue = toS <$> (P.char '"' *> P.many (P.noneOf "\"") <* P.char '"') diff --git a/src/PostgREST/Config/PgVersion.hs b/src/PostgREST/Config/PgVersion.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Config/PgVersion.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +module PostgREST.Config.PgVersion + ( PgVersion(..) + , minimumPgVersion + , pgVersion95 + , pgVersion96 + , pgVersion100 + , pgVersion109 + , pgVersion110 + , pgVersion112 + , pgVersion114 + , pgVersion121 + , pgVersion130 + ) where + +import qualified Data.Aeson as JSON + +import Protolude + + +data PgVersion = PgVersion + { pgvNum :: Int32 + , pgvName :: Text + } + deriving (Eq, Generic, JSON.ToJSON) + +instance Ord PgVersion where + (PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2 + +-- | Tells the minimum PostgreSQL version required by this version of PostgREST +minimumPgVersion :: PgVersion +minimumPgVersion = pgVersion95 + +pgVersion95 :: PgVersion +pgVersion95 = PgVersion 90500 "9.5" + +pgVersion96 :: PgVersion +pgVersion96 = PgVersion 90600 "9.6" + +pgVersion100 :: PgVersion +pgVersion100 = PgVersion 100000 "10" + +pgVersion109 :: PgVersion +pgVersion109 = PgVersion 100009 "10.9" + +pgVersion110 :: PgVersion +pgVersion110 = PgVersion 110000 "11.0" + +pgVersion112 :: PgVersion +pgVersion112 = PgVersion 110002 "11.2" + +pgVersion114 :: PgVersion +pgVersion114 = PgVersion 110004 "11.4" + +pgVersion121 :: PgVersion +pgVersion121 = PgVersion 120001 "12.1" + +pgVersion130 :: PgVersion +pgVersion130 = PgVersion 130000 "13.0" diff --git a/src/PostgREST/Config/Proxy.hs b/src/PostgREST/Config/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Config/Proxy.hs @@ -0,0 +1,78 @@ +{-| +Module : PostgREST.Private.ProxyUri +Description : Proxy Uri validator +-} +module PostgREST.Config.Proxy + ( Proxy(..) + , isMalformedProxyUri + , toURI + ) where + +import Data.Maybe (fromJust) +import Data.Text (pack, toLower) +import Network.URI (URI (..), URIAuth (..), isAbsoluteURI, parseURI) + +import Protolude hiding (Proxy, dropWhile, get, intercalate, + toLower, toS, (&)) +import Protolude.Conv (toS) + +data Proxy = Proxy + { proxyScheme :: Text + , proxyHost :: Text + , proxyPort :: Integer + , proxyPath :: Text + } + +{-| + Test whether a proxy uri is malformed or not. + A valid proxy uri should be an absolute uri without query and user info, + only http(s) schemes are valid, port number range is 1-65535. + + For example + http://postgrest.com/openapi.json + https://postgrest.com:8080/openapi.json +-} +isMalformedProxyUri :: Text -> Bool +isMalformedProxyUri uri + | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri + | otherwise = True + +toURI :: Text -> URI +toURI uri = fromJust $ parseURI (toS uri) + +isUriValid:: URI -> Bool +isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid] + +fAnd :: [a -> Bool] -> a -> Bool +fAnd fs x = all ($ x) fs + +isSchemeValid :: URI -> Bool +isSchemeValid URI {uriScheme = s} + | toLower (pack s) == "https:" = True + | toLower (pack s) == "http:" = True + | otherwise = False + +isQueryValid :: URI -> Bool +isQueryValid URI {uriQuery = ""} = True +isQueryValid _ = False + +isAuthorityValid :: URI -> Bool +isAuthorityValid URI {uriAuthority = a} + | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a + | otherwise = False + +isUserInfoValid :: URIAuth -> Bool +isUserInfoValid URIAuth {uriUserInfo = ""} = True +isUserInfoValid _ = False + +isHostValid :: URIAuth -> Bool +isHostValid URIAuth {uriRegName = ""} = False +isHostValid _ = True + +isPortValid :: URIAuth -> Bool +isPortValid URIAuth {uriPort = ""} = True +isPortValid URIAuth {uriPort = (':':p)} = + case readMaybe p of + Just i -> i > (0 :: Integer) && i < 65536 + Nothing -> False +isPortValid _ = False diff --git a/src/PostgREST/ContentType.hs b/src/PostgREST/ContentType.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/ContentType.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module PostgREST.ContentType + ( ContentType(..) + , toHeader + , toMime + , decodeContentType + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS (c2w) + +import Network.HTTP.Types.Header (Header, hContentType) + +import Protolude + +-- | Enumeration of currently supported response content types +data ContentType + = CTApplicationJSON + | CTSingularJSON + | CTTextCSV + | CTTextPlain + | CTOpenAPI + | CTUrlEncoded + | CTOctetStream + | CTAny + | CTOther ByteString + deriving (Eq) + +-- | Convert from ContentType to a full HTTP Header +toHeader :: ContentType -> Header +toHeader ct = (hContentType, toMime ct <> charset) + where + charset = case ct of + CTOctetStream -> mempty + CTOther _ -> mempty + _ -> "; charset=utf-8" + +-- | Convert from ContentType to a ByteString representing the mime type +toMime :: ContentType -> ByteString +toMime CTApplicationJSON = "application/json" +toMime CTTextCSV = "text/csv" +toMime CTTextPlain = "text/plain" +toMime CTOpenAPI = "application/openapi+json" +toMime CTSingularJSON = "application/vnd.pgrst.object+json" +toMime CTUrlEncoded = "application/x-www-form-urlencoded" +toMime CTOctetStream = "application/octet-stream" +toMime CTAny = "*/*" +toMime (CTOther ct) = ct + +-- | Convert from ByteString to ContentType. Warning: discards MIME parameters +decodeContentType :: BS.ByteString -> ContentType +decodeContentType ct = + case BS.takeWhile (/= BS.c2w ';') ct of + "application/json" -> CTApplicationJSON + "text/csv" -> CTTextCSV + "text/plain" -> CTTextPlain + "application/openapi+json" -> CTOpenAPI + "application/vnd.pgrst.object+json" -> CTSingularJSON + "application/vnd.pgrst.object" -> CTSingularJSON + "application/x-www-form-urlencoded" -> CTUrlEncoded + "application/octet-stream" -> CTOctetStream + "*/*" -> CTAny + ct' -> CTOther ct' diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs deleted file mode 100644 --- a/src/PostgREST/DbRequestBuilder.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-| -Module : PostgREST.DbRequestBuilder -Description : PostgREST database request builder - -This module is in charge of building an intermediate representation(ReadRequest, MutateRequest) between the HTTP request and the final resulting SQL query. - -A query tree is built in case of resource embedding. By inferring the relationship between tables, join conditions are added for every embedded resource. --} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} - -module PostgREST.DbRequestBuilder ( - readRequest -, mutateRequest -, returningCols -) where - -import qualified Data.HashMap.Strict as M -import qualified Data.Set as S - -import Control.Arrow ((***)) -import Data.Either.Combinators (mapLeft) -import Data.Foldable (foldr1) -import Data.List (delete) -import Data.Text (isInfixOf) - -import Control.Applicative -import Data.Tree -import Network.Wai - -import PostgREST.ApiRequest (Action (..), ApiRequest (..)) -import PostgREST.Error (ApiRequestError (..), errorResponseFor) -import PostgREST.Parsers -import PostgREST.RangeQuery (NonnegRange, allRange, restrictRange) -import PostgREST.Types -import Protolude hiding (from) - -readRequest :: Schema -> TableName -> Maybe Integer -> [Relation] -> ApiRequest -> Either Response ReadRequest -readRequest schema rootTableName maxRows allRels apiRequest = - mapLeft errorResponseFor $ - treeRestrictRange maxRows =<< - augmentRequestWithJoin schema rootRels =<< - addFiltersOrdersRanges apiRequest <*> - (initReadRequest rootName <$> pRequestSelect sel) - where - sel = fromMaybe "*" $ iSelect apiRequest -- default to all columns requested (SELECT *) for a non existent ?select querystring param - (rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest) - --- Get the root table name with its relationships according to the Action type. --- This is done because of the shape of the final SQL Query. The mutation cases are wrapped in a WITH {sourceCTEName}(see Statements.hs). --- So we need a FROM {sourceCTEName} instead of FROM {tableName}. -rootWithRels :: Schema -> TableName -> [Relation] -> Action -> (QualifiedIdentifier, [Relation]) -rootWithRels schema rootTableName allRels action = case action of - ActionRead _ -> (QualifiedIdentifier schema rootTableName, allRels) -- normal read case - _ -> (QualifiedIdentifier mempty sourceCTEName, mapMaybe toSourceRel allRels ++ allRels) -- mutation cases and calling proc - where - -- To enable embedding in the sourceCTEName cases we need to replace the foreign key tableName in the Relation - -- with {sourceCTEName}. This way findRel can find relationships with sourceCTEName. - toSourceRel :: Relation -> Maybe Relation - toSourceRel r@Relation{relTable=t} - | rootTableName == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}} - | otherwise = Nothing - --- Build the initial tree with a Depth attribute so when a self join occurs we can differentiate the parent and child tables by having --- an alias like "table_depth", this is related to http://github.com/PostgREST/postgrest/issues/987. -initReadRequest :: QualifiedIdentifier -> [Tree SelectItem] -> ReadRequest -initReadRequest rootQi = - foldr (treeEntry rootDepth) initial - where - rootDepth = 0 - rootSchema = qiSchema rootQi - rootName = qiName rootQi - initial = Node (Select [] rootQi Nothing [] [] [] [] allRange, (rootName, Nothing, Nothing, Nothing, rootDepth)) [] - treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest - treeEntry depth (Node fld@((fn, _),_,alias, embedHint) fldForest) (Node (q, i) rForest) = - let nxtDepth = succ depth in - case fldForest of - [] -> Node (q {select=fld:select q}, i) rForest - _ -> Node (q, i) $ - foldr (treeEntry nxtDepth) - (Node (Select [] (QualifiedIdentifier rootSchema fn) Nothing [] [] [] [] allRange, - (fn, Nothing, alias, embedHint, nxtDepth)) []) - fldForest:rForest - -treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest -treeRestrictRange maxRows request = pure $ nodeRestrictRange maxRows <$> request - where - nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode - nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) - -augmentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest -augmentRequestWithJoin schema allRels request = - addRels schema allRels Nothing request - >>= addJoinConditions Nothing - -addRels :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest -addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, hint, depth)) forest) = - case parentNode of - Just (Node (Select{from=parentNodeQi}, _) _) -> - let newFrom r = if qiName tbl == nodeName then tableQi (relFTable r) else tbl - newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel - rel = findRel schema allRels (qiName parentNodeQi) nodeName hint - in - Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest) - _ -> - let rn = (query, (nodeName, Nothing, alias, Nothing, depth)) in - Node rn <$> updateForest (Just $ Node rn forest) - where - updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest] - updateForest rq = mapM (addRels schema allRels rq) forest - --- Finds a relationship between an origin and a target in the request: /origin?select=target(*) --- If more than one relationship is found then the request is ambiguous and we return an error. --- In that case the request can be disambiguated by adding precision to the target or by using a hint: /origin?select=target!hint(*) --- The elements will be matched according to these rules: --- origin = table / view --- target = table / view / constraint / column-from-origin --- hint = table / view / constraint / column-from-origin / column-from-target --- (hint can take table / view values to aid in finding the junction in an m2m relationship) -findRel :: Schema -> [Relation] -> NodeName -> NodeName -> Maybe EmbedHint -> Either ApiRequestError Relation -findRel schema allRels origin target hint = - case rel of - [] -> Left $ NoRelBetween origin target - [r] -> Right r - rs -> - -- Return error if more than one relationship is found, unless we're in a self reference case. - -- - -- Here we handle a self reference relationship to not cause a breaking change: - -- In a self reference we get two relationships with the same foreign key and relTable/relFtable but with different cardinalities(m2o/o2m) - -- We output the O2M rel, the M2O rel can be obtained by using the origin column as an embed hint. - let [rel0, rel1] = take 2 rs in - if length rs == 2 && relConstraint rel0 == relConstraint rel1 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1 - then note (NoRelBetween origin target) (find (\r -> relType r == O2M) rs) - else Left $ AmbiguousRelBetween origin target rs - where - matchFKSingleCol hint_ cols = length cols == 1 && hint_ == (colName <$> head cols) - rel = filter ( - \Relation{relTable, relColumns, relConstraint, relFTable, relFColumns, relType, relJunction} -> - -- Both relationship ends need to be on the exposed schema - schema == tableSchema relTable && schema == tableSchema relFTable && - ( - -- /projects?select=clients(*) - origin == tableName relTable && -- projects - target == tableName relFTable || -- clients - - -- /projects?select=projects_client_id_fkey(*) - ( - origin == tableName relTable && -- projects - Just target == relConstraint -- projects_client_id_fkey - ) || - -- /projects?select=client_id(*) - ( - origin == tableName relTable && -- projects - matchFKSingleCol (Just target) relColumns -- client_id - ) - ) && ( - isNothing hint || -- hint is optional - - -- /projects?select=clients!projects_client_id_fkey(*) - hint == relConstraint || -- projects_client_id_fkey - - -- /projects?select=clients!client_id(*) or /projects?select=clients!id(*) - matchFKSingleCol hint relColumns || -- client_id - matchFKSingleCol hint relFColumns || -- id - - -- /users?select=tasks!users_tasks(*) - ( - relType == M2M && -- many-to-many between users and tasks - hint == (tableName . junTable <$> relJunction) -- users_tasks - ) - ) - ) allRels - --- previousAlias is only used for the case of self joins -addJoinConditions :: Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest -addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, rel, _, _, depth)) forest) = - case rel of - Just r@Relation{relType=O2M} -> Node (augmentQuery r, nodeProps) <$> updatedForest - Just r@Relation{relType=M2O} -> Node (augmentQuery r, nodeProps) <$> updatedForest - Just r@Relation{relType=M2M, relJunction=junction} -> - case junction of - Just Junction{junTable} -> - let rq = augmentQuery r in - Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest - Nothing -> - Left UnknownRelation - Nothing -> Node node <$> updatedForest - where - newAlias = case isSelfReference <$> rel of - Just True - | depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased - | otherwise -> Nothing - _ -> Nothing - augmentQuery r = - foldr - (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs}) - query{fromAlias=newAlias} - (getJoinConditions previousAlias newAlias r) - updatedForest = mapM (addJoinConditions newAlias) forest - --- previousAlias and newAlias are used in the case of self joins -getJoinConditions :: Maybe Alias -> Maybe Alias -> Relation -> [JoinCondition] -getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, tableName=tN} cols _ Table{tableName=ftN} fCols typ jun) = - case typ of - O2M -> - zipWith (toJoinCondition tN ftN) cols fCols - M2O -> - zipWith (toJoinCondition tN ftN) cols fCols - M2M -> case jun of - Just (Junction jt _ jc1 _ jc2) -> - let jtn = tableName jt in - zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2 - Nothing -> [] - where - toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition - toJoinCondition tb ftb c fc = - let qi1 = removeSourceCTESchema tSchema tb - qi2 = removeSourceCTESchema tSchema ftb in - JoinCondition (maybe qi1 (QualifiedIdentifier mempty) previousAlias, colName c) - (maybe qi2 (QualifiedIdentifier mempty) newAlias, colName fc) - - -- On mutation and calling proc cases we wrap the target table in a WITH {sourceCTEName} - -- if this happens remove the schema `FROM "schema"."{sourceCTEName}"` and use only the - -- `FROM "{sourceCTEName}"`. If the schema remains the FROM would be invalid. - removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier - removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then mempty else schema) tbl - -addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest) -addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ - flip (foldr addFilter) <$> filters, - flip (foldr addOrder) <$> orders, - flip (foldr addRange) <$> ranges, - flip (foldr addLogicTree) <$> logicForest - ] - {- - The esence of what is going on above is that we are composing tree functions - of type (ReadRequest->ReadRequest) that are in (Either ApiRequestError a) context - -} - where - filters :: Either ApiRequestError [(EmbedPath, Filter)] - filters = mapM pRequestFilter flts - logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)] - logicForest = mapM pRequestLogicTree logFrst - action = iAction apiRequest - -- there can be no filters on the root table when we are doing insert/update/delete - (flts, logFrst) = - case action of - ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest) - ActionRead _ -> (iFilters apiRequest, iLogic apiRequest) - _ -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest) - orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])] - orders = mapM pRequestOrder $ iOrder apiRequest - ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)] - ranges = mapM pRequestRange $ M.toList $ iRange apiRequest - -addFilterToNode :: Filter -> ReadRequest -> ReadRequest -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 - -addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest -addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f - -addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest -addOrder = addProperty addOrderToNode - -addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest -addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f - -addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest -addRange = addProperty addRangeToNode - -addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest -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 - -addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest -addProperty f ([], a) rr = f a rr -addProperty f (targetNodeName:remainingPath, a) (Node rn forest) = - case pathNode of - Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path - Just tn -> Node rn (addProperty f (remainingPath, a) tn:delete tn forest) - where - pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest - -mutateRequest :: Schema -> TableName -> ApiRequest -> S.Set FieldName -> [FieldName] -> ReadRequest -> Either Response MutateRequest -mutateRequest schema tName apiRequest cols pkCols readReq = mapLeft errorResponseFor $ - case action of - ActionCreate -> do - confCols <- case iOnConflict apiRequest of - Nothing -> pure pkCols - Just param -> pRequestOnConflict param - pure $ Insert qi cols ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings - ActionUpdate -> Update qi cols <$> combinedLogic <*> pure returnings - ActionSingleUpsert -> - (\flts -> - if null (iLogic apiRequest) && - S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols && - not (null (S.fromList pkCols)) && - all (\case - Filter _ (OpExpr False (Op "eq" _)) -> True - _ -> False) flts - then Insert qi cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings - else - Left InvalidFilters) =<< filters - ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings - _ -> Left UnsupportedVerb - where - qi = QualifiedIdentifier schema tName - action = iAction apiRequest - returnings = - if iPreferRepresentation apiRequest == None - then [] - else returningCols readReq - filters = map snd <$> mapM pRequestFilter mutateFilters - logic = map snd <$> mapM pRequestLogicTree logicFilters - combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters - -- update/delete filters can be only on the root table - (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest) - onlyRoot = filter (not . ( "." `isInfixOf` ) . fst) - -returningCols :: ReadRequest -> [FieldName] -returningCols rr@(Node _ forest) = returnings - where - fldNames = fstFieldNames rr - -- Without fkCols, when a mutateRequest to /projects?select=name,clients(name) occurs, the RETURNING SQL part would be - -- `RETURNING name`(see QueryBuilder). - -- This would make the embedding fail because the following JOIN would need the "client_id" column from projects. - -- So this adds the foreign key columns to ensure the embedding succeeds, result would be `RETURNING name, client_id`. - -- This also works for the other relType's. - fkCols = concat $ mapMaybe (\case - Node (_, (_, Just Relation{relColumns=cols, relType=relTyp}, _, _, _)) _ -> case relTyp of - O2M -> Just cols - M2O -> Just cols - M2M -> Just cols - _ -> Nothing - ) forest - -- However if the "client_id" is present, e.g. mutateRequest to /projects?select=client_id,name,clients(name) - -- we would get `RETURNING client_id, name, client_id` and then we would produce the "column reference \"client_id\" is ambiguous" - -- error from PostgreSQL. So we deduplicate with Set: - returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols) - --- 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 diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -8,64 +8,118 @@ These queries are executed once at startup or when PostgREST is reloaded. -} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.DbStructure ( - getDbStructure -, accessibleTables -, accessibleProcs -, schemaDescription -, getPgVersion -) where +module PostgREST.DbStructure + ( DbStructure(..) + , queryDbStructure + , accessibleTables + , accessibleProcs + , schemaDescription + , tableCols + , tablePKCols + ) where + +import qualified Data.Aeson as JSON import qualified Data.HashMap.Strict as M import qualified Data.List as L -import qualified Data.Text as T import qualified Hasql.Decoders as HD import qualified Hasql.Encoders as HE -import qualified Hasql.Session as H import qualified Hasql.Statement as H import qualified Hasql.Transaction as HT +import Contravariant.Extras (contrazip2) import Data.Set as S (fromList) -import Data.Text (breakOn, dropAround, split, - splitOn, strip) -import GHC.Exts (groupWith) -import Protolude hiding (toS) -import Protolude.Conv (toS) -import Protolude.Unsafe (unsafeHead) -import Text.InterpolatedString.Perl6 (q, qc) +import Data.Text (split) +import Text.InterpolatedString.Perl6 (q) -import PostgREST.Private.Common -import PostgREST.Types +import PostgREST.DbStructure.Identifiers (QualifiedIdentifier (..), + Schema, TableName) +import PostgREST.DbStructure.Proc (PgArg (..), PgType (..), + ProcDescription (..), + ProcVolatility (..), + ProcsMap, RetType (..)) +import PostgREST.DbStructure.Relationship (Cardinality (..), + Junction (..), + PrimaryKey (..), + Relationship (..)) +import PostgREST.DbStructure.Table (Column (..), Table (..)) -getDbStructure :: [Schema] -> PgVersion -> HT.Transaction DbStructure -getDbStructure schemas pgVer = do +import Protolude hiding (toS) +import Protolude.Conv (toS) +import Protolude.Unsafe (unsafeHead) + + +data DbStructure = DbStructure + { dbTables :: [Table] + , dbColumns :: [Column] + , dbRelationships :: [Relationship] + , dbPrimaryKeys :: [PrimaryKey] + , dbProcs :: ProcsMap + } + deriving (Generic, JSON.ToJSON) + +-- TODO Table could hold references to all its Columns +tableCols :: DbStructure -> Schema -> TableName -> [Column] +tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs + +-- TODO Table could hold references to all its PrimaryKeys +tablePKCols :: DbStructure -> Schema -> TableName -> [Text] +tablePKCols dbs tSchema tName = pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs) + +-- | The source table column a view column refers to +type SourceColumn = (Column, ViewColumn) +type ViewColumn = Column + +-- | A SQL query that can be executed independently +type SqlQuery = ByteString + +queryDbStructure :: [Schema] -> [Schema] -> Bool -> HT.Transaction DbStructure +queryDbStructure schemas extraSearchPath prepared = do HT.sql "set local schema ''" -- This voids the search path. The following queries need this for getting the fully qualified name(schema.name) of every db object - tabs <- HT.statement () allTables - cols <- HT.statement schemas $ allColumns tabs - srcCols <- HT.statement schemas $ allSourceColumns cols pgVer - m2oRels <- HT.statement () $ allM2ORels tabs cols - keys <- HT.statement () $ allPrimaryKeys tabs - procs <- HT.statement schemas allProcs + tabs <- HT.statement mempty $ allTables prepared + cols <- HT.statement schemas $ allColumns tabs prepared + srcCols <- HT.statement (schemas, extraSearchPath) $ pfkSourceColumns cols prepared + m2oRels <- HT.statement mempty $ allM2ORels tabs cols prepared + keys <- HT.statement mempty $ allPrimaryKeys tabs prepared + procs <- HT.statement schemas $ allProcs prepared - let rels = addM2MRels . addO2MRels $ addViewM2ORels srcCols m2oRels - cols' = addForeignKeys rels cols + let rels = addO2MRels . addM2MRels $ addViewM2ORels srcCols m2oRels keys' = addViewPrimaryKeys srcCols keys - return DbStructure { + return $ removeInternal schemas $ DbStructure { dbTables = tabs - , dbColumns = cols' - , dbRelations = rels + , dbColumns = cols + , dbRelationships = rels , dbPrimaryKeys = keys' , dbProcs = procs - , pgVersion = pgVer } +-- | Remove db objects that belong to an internal schema(not exposed through the API) from the DbStructure. +removeInternal :: [Schema] -> DbStructure -> DbStructure +removeInternal schemas dbStruct = + DbStructure { + dbTables = filter (\x -> tableSchema x `elem` schemas) $ dbTables dbStruct + , dbColumns = filter (\x -> tableSchema (colTable x) `elem` schemas) (dbColumns dbStruct) + , dbRelationships = filter (\x -> tableSchema (relTable x) `elem` schemas && + tableSchema (relForeignTable x) `elem` schemas && + not (hasInternalJunction x)) $ dbRelationships dbStruct + , dbPrimaryKeys = filter (\x -> tableSchema (pkTable x) `elem` schemas) $ dbPrimaryKeys dbStruct + , dbProcs = dbProcs dbStruct -- procs are only obtained from the exposed schemas, no need to filter them. + } + where + hasInternalJunction rel = case relCardinality rel of + M2M Junction{junTable} -> tableSchema junTable `notElem` schemas + _ -> False + decodeTables :: HD.Result [Table] decodeTables = HD.rowList tblRow @@ -74,23 +128,26 @@ <*> column HD.text <*> nullableColumn HD.text <*> column HD.bool + <*> column HD.bool + <*> column HD.bool decodeColumns :: [Table] -> HD.Result [Column] decodeColumns tables = mapMaybe (columnFromRow tables) <$> HD.rowList colRow where colRow = - (,,,,,,,,,,,) - <$> column HD.text <*> column HD.text - <*> column HD.text <*> nullableColumn HD.text - <*> column HD.int4 <*> column HD.bool - <*> column HD.text <*> column HD.bool - <*> nullableColumn HD.int4 + (,,,,,,,,) + <$> column HD.text + <*> column HD.text + <*> column HD.text + <*> nullableColumn HD.text + <*> column HD.bool + <*> column HD.text <*> nullableColumn HD.int4 <*> nullableColumn HD.text <*> nullableColumn HD.text -decodeRels :: [Table] -> [Column] -> HD.Result [Relation] +decodeRels :: [Table] -> [Column] -> HD.Result [Relationship] decodeRels tables cols = mapMaybe (relFromRow tables cols) <$> HD.rowList relRow where @@ -98,10 +155,10 @@ <$> column HD.text <*> column HD.text <*> column HD.text - <*> column (HD.array (HD.dimension replicateM (element HD.text))) + <*> arrayColumn HD.text <*> column HD.text <*> column HD.text - <*> column (HD.array (HD.dimension replicateM (element HD.text))) + <*> arrayColumn HD.text decodePks :: [Table] -> HD.Result [PrimaryKey] decodePks tables = @@ -134,81 +191,118 @@ <$> column HD.text <*> column HD.text <*> nullableColumn HD.text - <*> (parseArgs <$> column HD.text) + <*> compositeArrayColumn + (PgArg + <$> compositeField HD.text + <*> compositeField HD.text + <*> compositeField HD.bool + <*> compositeField HD.bool) <*> (parseRetType <$> column HD.text <*> column HD.text <*> column HD.bool - <*> column HD.char) + <*> column HD.bool) <*> (parseVolatility <$> column HD.char) + <*> column HD.bool addKey :: ProcDescription -> (QualifiedIdentifier, ProcDescription) addKey pd = (QualifiedIdentifier (pdSchema pd) (pdName pd), pd) - parseArgs :: Text -> [PgArg] - parseArgs = mapMaybe parseArg . filter (not . isPrefixOf "OUT" . toS) . map strip . split (==',') - - parseArg :: Text -> Maybe PgArg - parseArg a = - let arg = lastDef "" $ splitOn "INOUT " a - (body, def) = breakOn " DEFAULT " arg - (name, typ) = breakOn " " body in - if T.null typ - then Nothing - else Just $ - PgArg (dropAround (== '"') name) (strip typ) (T.null def) - - parseRetType :: Text -> Text -> Bool -> Char -> RetType - parseRetType schema name isSetOf typ + parseRetType :: Text -> Text -> Bool -> Bool -> RetType + parseRetType schema name isSetOf isComposite | isSetOf = SetOf pgType | otherwise = Single pgType where qi = QualifiedIdentifier schema name - pgType = case typ of - 'c' -> Composite qi - '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 + pgType + | isComposite = Composite qi + | otherwise = Scalar parseVolatility :: Char -> ProcVolatility parseVolatility v | v == 'i' = Immutable | v == 's' = Stable | otherwise = Volatile -- only 'v' can happen here -allProcs :: H.Statement [Schema] ProcsMap -allProcs = H.Statement (toS sql) (arrayParam HE.text) decodeProcs True +allProcs :: Bool -> H.Statement [Schema] ProcsMap +allProcs = H.Statement (toS sql) (arrayParam HE.text) decodeProcs where sql = procsSqlQuery <> " WHERE pn.nspname = ANY($1)" -accessibleProcs :: H.Statement Schema ProcsMap -accessibleProcs = H.Statement (toS sql) (param HE.text) decodeProcs True +accessibleProcs :: Bool -> H.Statement Schema ProcsMap +accessibleProcs = H.Statement (toS sql) (param HE.text) decodeProcs where sql = procsSqlQuery <> " WHERE pn.nspname = $1 AND has_function_privilege(p.oid, 'execute')" procsSqlQuery :: SqlQuery procsSqlQuery = [q| + -- Recursively get the base types of domains + WITH + base_types AS ( + WITH RECURSIVE + recurse AS ( + SELECT + oid, + typbasetype, + COALESCE(NULLIF(typbasetype, 0), oid) AS base + FROM pg_type + UNION + SELECT + t.oid, + b.typbasetype, + COALESCE(NULLIF(b.typbasetype, 0), b.oid) AS base + FROM recurse t + JOIN pg_type b ON t.typbasetype = b.oid + ) + SELECT + oid, + base + FROM recurse + WHERE typbasetype = 0 + ), + arguments AS ( + SELECT + oid, + array_agg(( + COALESCE(name, ''), -- name + type::regtype::text, -- type + idx <= (pronargs - pronargdefaults), -- is_required + COALESCE(mode = 'v', FALSE) -- is_variadic + ) ORDER BY idx) AS args + FROM pg_proc, + unnest(proargnames, proargtypes, proargmodes) + WITH ORDINALITY AS _ (name, type, mode, idx) + WHERE type IS NOT NULL -- only input arguments + GROUP BY oid + ) SELECT - pn.nspname as proc_schema, - 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, - p.proretset as rettype_is_setof, - t.typtype as rettype_typ, - p.provolatile + pn.nspname AS proc_schema, + p.proname AS proc_name, + d.description AS proc_description, + COALESCE(a.args, '{}') AS args, + tn.nspname AS schema, + COALESCE(comp.relname, t.typname) AS name, + p.proretset AS rettype_is_setof, + (t.typtype = 'c' + -- Only pg pseudo type that is a row type is 'record' + or t.typtype = 'p' and t.typname = 'record' + -- if any INOUT or OUT arguments present, treat as composite + or COALESCE(proargmodes::text[] && '{b,o}', false) + ) AS rettype_is_composite, + p.provolatile, + p.provariadic > 0 as hasvariadic FROM pg_proc p - JOIN pg_namespace pn ON pn.oid = p.pronamespace - 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 + LEFT JOIN arguments a ON a.oid = p.oid + JOIN pg_namespace pn ON pn.oid = p.pronamespace + JOIN base_types bt ON bt.oid = p.prorettype + JOIN pg_type t ON t.oid = bt.base + 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 |] -schemaDescription :: H.Statement Schema (Maybe Text) +schemaDescription :: Bool -> H.Statement Schema (Maybe Text) schemaDescription = - H.Statement sql (param HE.text) (join <$> HD.rowMaybe (nullableColumn HD.text)) True + H.Statement sql (param HE.text) (join <$> HD.rowMaybe (nullableColumn HD.text)) where sql = [q| select @@ -219,9 +313,9 @@ where n.nspname = $1 |] -accessibleTables :: H.Statement Schema [Table] +accessibleTables :: Bool -> H.Statement Schema [Table] accessibleTables = - H.Statement sql (param HE.text) decodeTables True + H.Statement sql (param HE.text) decodeTables where sql = [q| select @@ -229,22 +323,40 @@ relname as table_name, d.description as table_description, ( - c.relkind in ('r', 'v', 'f') - and (pg_relation_is_updatable(c.oid::regclass, false) & 8) = 8 - -- The function `pg_relation_is_updateable` returns a bitmask where 8 - -- corresponds to `1 << CMD_INSERT` in the PostgreSQL source code, i.e. - -- it's possible to insert into the relation. - or (exists ( - select 1 - from pg_trigger - where + c.relkind IN ('r', 'v','f') + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 + OR EXISTS ( + SELECT 1 + FROM pg_trigger + WHERE pg_trigger.tgrelid = c.oid - and (pg_trigger.tgtype::integer & 69) = 69) - -- The trigger type `tgtype` is a bitmask where 69 corresponds to - -- TRIGGER_TYPE_ROW + TRIGGER_TYPE_INSTEAD + TRIGGER_TYPE_INSERT - -- in the PostgreSQL source code. + AND (pg_trigger.tgtype::integer & 69) = 69 ) - ) as insertable + ) AS insertable, + ( + c.relkind IN ('r', 'v','f') + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 4) = 4 + -- CMD_UPDATE + OR EXISTS ( + SELECT 1 + FROM pg_trigger + WHERE + pg_trigger.tgrelid = c.oid + and (pg_trigger.tgtype::integer & 81) = 81 + ) + ) as updatable, + ( + c.relkind IN ('r', 'v','f') + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 16) = 16 + -- CMD_DELETE + OR EXISTS ( + SELECT 1 + FROM pg_trigger + WHERE + pg_trigger.tgrelid = c.oid + and (pg_trigger.tgtype::integer & 73) = 73 + ) + ) as deletable from pg_class c join pg_namespace n on n.oid = c.relnamespace @@ -259,26 +371,14 @@ ) order by relname |] -addForeignKeys :: [Relation] -> [Column] -> [Column] -addForeignKeys rels = map addFk - where - addFk col = col { colFK = fk col } - fk col = find (lookupFn col) rels >>= relToFk col - lookupFn :: Column -> Relation -> Bool - lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==M2O - relToFk col Relation{relColumns=cols, relFColumns=colsF} = do - pos <- L.elemIndex col cols - colF <- atMay colsF pos - return $ ForeignKey colF - {- -Adds Views M2O Relations based on SourceColumns found, the logic is as follows: +Adds Views M2O Relationships based on SourceColumns found, the logic is as follows: -Having a Relation{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relType=M2O} represented by: +Having a Relationship{relTable=t1, relColumns=[c1], relFTable=t2, relFColumns=[c2], relCardinality=M2O} represented by: t1.c1------t2.c2 -When only having a t1_view.c1 source column, we need to add a View-Table M2O Relation +When only having a t1_view.c1 source column, we need to add a View-Table M2O Relationship t1.c1----t2.c2 t1.c1----------t2.c2 -> ________/ @@ -286,88 +386,71 @@ t1_view.c1 t1_view.c1 -When only having a t2_view.c2 source column, we need to add a Table-View M2O Relation +When only having a t2_view.c2 source column, we need to add a Table-View M2O Relationship t1.c1----t2.c2 t1.c1----------t2.c2 -> \________ \ t2_view.c2 t2_view.c1 -When having t1_view.c1 and a t2_view.c2 source columns, we need to add a View-View M2O Relation in addition to the prior +When having t1_view.c1 and a t2_view.c2 source columns, we need to add a View-View M2O Relationship in addition to the prior t1.c1----t2.c2 t1.c1----------t2.c2 -> \________/ / \ t1_view.c1 t2_view.c2 t1_view.c1-------t2_view.c1 -The logic for composite pks is similar just need to make sure all the Relation columns have source columns. +The logic for composite pks is similar just need to make sure all the Relationship columns have source columns. -} -addViewM2ORels :: [SourceColumn] -> [Relation] -> [Relation] -addViewM2ORels allSrcCols = concatMap (\rel -> - rel : case rel of - Relation{relType=M2O, relTable, relColumns, relConstraint, relFTable, relFColumns} -> - - let srcColsGroupedByView :: [Column] -> [[SourceColumn]] - srcColsGroupedByView relCols = L.groupBy (\(_, viewCol1) (_, viewCol2) -> colTable viewCol1 == colTable viewCol2) $ - filter (\(c, _) -> c `elem` relCols) allSrcCols - relSrcCols = srcColsGroupedByView relColumns - relFSrcCols = srcColsGroupedByView relFColumns - getView :: [SourceColumn] -> Table - getView = colTable . snd . unsafeHead - srcCols `allSrcColsOf` cols = S.fromList (fst <$> srcCols) == S.fromList cols - -- Relation is dependent on the order of relColumns and relFColumns to get the join conditions right in the generated query. - -- So we need to change the order of the SourceColumns to match the relColumns - -- TODO: This could be avoided if the Relation type is improved with a structure that maintains the association of relColumns and relFColumns - srcCols `sortAccordingTo` cols = sortOn (\(k, _) -> L.lookup k $ zip cols [0::Int ..]) srcCols - - viewTableM2O = - [ Relation (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns) - relConstraint relFTable relFColumns - M2O Nothing - | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns ] +addViewM2ORels :: [SourceColumn] -> [Relationship] -> [Relationship] +addViewM2ORels allSrcCols = concatMap (\rel@Relationship{..} -> rel : + let + srcColsGroupedByView :: [Column] -> [[SourceColumn]] + srcColsGroupedByView relCols = L.groupBy (\(_, viewCol1) (_, viewCol2) -> colTable viewCol1 == colTable viewCol2) $ + filter (\(c, _) -> c `elem` relCols) allSrcCols + relSrcCols = srcColsGroupedByView relColumns + relFSrcCols = srcColsGroupedByView relForeignColumns + getView :: [SourceColumn] -> Table + getView = colTable . snd . unsafeHead + srcCols `allSrcColsOf` cols = S.fromList (fst <$> srcCols) == S.fromList cols + -- Relationship is dependent on the order of relColumns and relFColumns to get the join conditions right in the generated query. + -- So we need to change the order of the SourceColumns to match the relColumns + -- TODO: This could be avoided if the Relationship type is improved with a structure that maintains the association of relColumns and relFColumns + srcCols `sortAccordingTo` cols = sortOn (\(k, _) -> L.lookup k $ zip cols [0::Int ..]) srcCols - tableViewM2O = - [ Relation relTable relColumns - relConstraint - (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns) - M2O Nothing - | fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relFColumns ] + viewTableM2O = + [ Relationship + (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns) + relForeignTable relForeignColumns relCardinality + | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns ] - viewViewM2O = - [ Relation (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns) - relConstraint - (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relFColumns) - M2O Nothing - | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns - , fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relFColumns ] + tableViewM2O = + [ Relationship + relTable relColumns + (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relForeignColumns) + relCardinality + | fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relForeignColumns ] - in viewTableM2O ++ tableViewM2O ++ viewViewM2O + viewViewM2O = + [ Relationship + (getView srcCols) (snd <$> srcCols `sortAccordingTo` relColumns) + (getView fSrcCols) (snd <$> fSrcCols `sortAccordingTo` relForeignColumns) + relCardinality + | srcCols <- relSrcCols, srcCols `allSrcColsOf` relColumns + , fSrcCols <- relFSrcCols, fSrcCols `allSrcColsOf` relForeignColumns ] - _ -> []) + in viewTableM2O ++ tableViewM2O ++ viewViewM2O) -addO2MRels :: [Relation] -> [Relation] -addO2MRels = concatMap (\rel@(Relation t c cn ft fc _ _) -> [rel, Relation ft fc cn t c O2M Nothing]) +addO2MRels :: [Relationship] -> [Relationship] +addO2MRels rels = rels ++ [ Relationship ft fc t c (O2M cons) + | Relationship t c ft fc (M2O cons) <- rels ] -addM2MRels :: [Relation] -> [Relation] -addM2MRels rels = rels ++ addMirrorRel (mapMaybe junction2Rel junctions) - where - junctions = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==M2O). relType) rels - groupFn :: Relation -> Text - groupFn Relation{relTable=Table{tableSchema=s, tableName=t}} = s <> "_" <> t - -- Reference : https://wiki.haskell.org/99_questions/Solutions/26 - combinations :: Int -> [a] -> [[a]] - combinations 0 _ = [ [] ] - combinations n xs = [ y:ys | y:xs' <- tails xs - , ys <- combinations (n-1) xs'] - junction2Rel [ - Relation{relTable=jt, relColumns=jc1, relConstraint=const1, relFTable=t, relFColumns=c}, - Relation{ relColumns=jc2, relConstraint=const2, relFTable=ft, relFColumns=fc} - ] - | jc1 /= jc2 && length jc1 == 1 && length jc2 == 1 = Just $ Relation t c Nothing ft fc M2M (Just $ Junction jt const1 jc1 const2 jc2) - | otherwise = Nothing - junction2Rel _ = Nothing - addMirrorRel = concatMap (\rel@(Relation t c _ ft fc _ (Just (Junction jt const1 jc1 const2 jc2))) -> - [rel, Relation ft fc Nothing t c M2M (Just (Junction jt const2 jc2 const1 jc1))]) +addM2MRels :: [Relationship] -> [Relationship] +addM2MRels rels = rels ++ [ Relationship t c ft fc (M2M $ Junction jt1 cons1 jc1 cons2 jc2) + | Relationship jt1 jc1 t c (M2O cons1) <- rels + , Relationship jt2 jc2 ft fc (M2O cons2) <- rels + , jt1 == jt2 + , cons1 /= cons2] addViewPrimaryKeys :: [SourceColumn] -> [PrimaryKey] -> [PrimaryKey] addViewPrimaryKeys srcCols = concatMap (\pk -> @@ -375,36 +458,77 @@ filter (\(col, _) -> colTable col == pkTable pk && colName col == pkName pk) srcCols in pk : viewPks) -allTables :: H.Statement () [Table] +allTables :: Bool -> H.Statement () [Table] allTables = - H.Statement sql HE.noParams decodeTables True + H.Statement sql HE.noParams decodeTables where sql = [q| SELECT n.nspname AS table_schema, c.relname AS table_name, - NULL AS table_description, + d.description AS table_description, ( - c.relkind IN ('r', 'v','f') - AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 - OR EXISTS ( - SELECT 1 - FROM pg_trigger - WHERE - pg_trigger.tgrelid = c.oid + c.relkind = 'r' + OR ( + c.relkind in ('v','f') + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 8) = 8 + -- The function `pg_relation_is_updateable` returns a bitmask where 8 + -- corresponds to `1 << CMD_INSERT` in the PostgreSQL source code, i.e. + -- it's possible to insert into the relation. + OR EXISTS ( + SELECT 1 + FROM pg_trigger + WHERE + pg_trigger.tgrelid = c.oid AND (pg_trigger.tgtype::integer & 69) = 69 + -- The trigger type `tgtype` is a bitmask where 69 corresponds to + -- TRIGGER_TYPE_ROW + TRIGGER_TYPE_INSTEAD + TRIGGER_TYPE_INSERT + -- in the PostgreSQL source code. + ) ) - ) AS insertable + ) AS insertable, + ( + c.relkind = 'r' + OR ( + c.relkind in ('v','f') + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 4) = 4 + -- CMD_UPDATE + OR EXISTS ( + SELECT 1 + FROM pg_trigger + WHERE + pg_trigger.tgrelid = c.oid + and (pg_trigger.tgtype::integer & 81) = 81 + -- TRIGGER_TYPE_ROW + TRIGGER_TYPE_INSTEAD + TRIGGER_TYPE_UPDATE + ) + ) + ) AS updatable, + ( + c.relkind = 'r' + OR ( + c.relkind in ('v','f') + AND (pg_relation_is_updatable(c.oid::regclass, FALSE) & 16) = 16 + -- CMD_DELETE + OR EXISTS ( + SELECT 1 + FROM pg_trigger + WHERE + pg_trigger.tgrelid = c.oid + and (pg_trigger.tgtype::integer & 73) = 73 + -- TRIGGER_TYPE_ROW + TRIGGER_TYPE_INSTEAD + TRIGGER_TYPE_DELETE + ) + ) + ) AS deletable 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','f') AND n.nspname NOT IN ('pg_catalog', 'information_schema') - GROUP BY table_schema, table_name, insertable ORDER BY table_schema, table_name |] -allColumns :: [Table] -> H.Statement [Schema] [Column] +allColumns :: [Table] -> Bool -> H.Statement [Schema] [Column] allColumns tabs = - H.Statement sql (arrayParam HE.text) (decodeColumns tabs) True + H.Statement sql (arrayParam HE.text) (decodeColumns tabs) where sql = [q| SELECT DISTINCT @@ -412,14 +536,12 @@ 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, - info.is_updatable::boolean AS updatable, info.character_maximum_length AS max_len, - info.numeric_precision AS precision, info.column_default AS default_value, - array_to_string(enum_info.vals, ',') AS enum + array_to_string(enum_info.vals, ',') AS enum, + info.position FROM ( -- CTE based on pg_catalog to get PRIMARY/FOREIGN key and UNIQUE columns outside api schema WITH key_columns AS ( @@ -454,7 +576,6 @@ c.relname::name AS table_name, a.attname::name AS column_name, d.description AS description, - a.attnum::integer AS ordinal_position, pg_get_expr(ad.adbin, ad.adrelid)::text AS column_default, not (a.attnotnull OR t.typtype = 'd' AND t.typnotnull) AS is_nullable, CASE @@ -475,15 +596,8 @@ information_schema._pg_truetypid(a.*, t.*), information_schema._pg_truetypmod(a.*, t.*) )::integer AS character_maximum_length, - information_schema._pg_numeric_precision( - information_schema._pg_truetypid(a.*, t.*), - information_schema._pg_truetypmod(a.*, t.*) - )::integer AS numeric_precision, COALESCE(bt.typname, t.typname)::name AS udt_name, - ( - c.relkind in ('r', 'v', 'f') - AND pg_column_is_updatable(c.oid::regclass, a.attnum, false) - )::bool is_updatable + a.attnum::integer AS position FROM pg_attribute a LEFT JOIN key_columns kc ON kc.conkey = a.attnum AND kc.c_oid = a.attrelid @@ -512,14 +626,12 @@ table_name, column_name, description, - ordinal_position, is_nullable, data_type, - is_updatable, character_maximum_length, - numeric_precision, column_default, - udt_name + udt_name, + position FROM columns WHERE table_schema NOT IN ('pg_catalog', 'information_schema') ) AS info @@ -537,20 +649,19 @@ columnFromRow :: [Table] -> (Text, Text, Text, - Maybe Text, Int32, Bool, - Text, Bool, Maybe Int32, + Maybe Text, Bool, Text, Maybe Int32, Maybe Text, Maybe Text) -> Maybe Column -columnFromRow tabs (s, t, n, desc, pos, nul, typ, u, l, p, d, e) = buildColumn <$> table +columnFromRow tabs (s, t, n, desc, nul, typ, l, d, e) = buildColumn <$> table where - buildColumn tbl = Column tbl n desc pos nul typ u l p d (parseEnum e) Nothing + buildColumn tbl = Column tbl n desc nul typ l d (parseEnum e) table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs parseEnum :: Maybe Text -> [Text] parseEnum = maybe [] (split (==',')) -allM2ORels :: [Table] -> [Column] -> H.Statement () [Relation] +allM2ORels :: [Table] -> [Column] -> Bool -> H.Statement () [Relationship] allM2ORels tabs cols = - H.Statement sql HE.noParams (decodeRels tabs cols) True + H.Statement sql HE.noParams (decodeRels tabs cols) where sql = [q| SELECT ns1.nspname AS table_schema, @@ -575,9 +686,9 @@ WHERE confrelid != 0 ORDER BY (conrelid, column_info.nums) |] -relFromRow :: [Table] -> [Column] -> (Text, Text, Text, [Text], Text, Text, [Text]) -> Maybe Relation +relFromRow :: [Table] -> [Column] -> (Text, Text, Text, [Text], Text, Text, [Text]) -> Maybe Relationship relFromRow allTabs allCols (rs, rt, cn, rcs, frs, frt, frcs) = - Relation <$> table <*> cols <*> pure (Just cn) <*> tableF <*> colsF <*> pure M2O <*> pure Nothing + Relationship <$> table <*> cols <*> tableF <*> colsF <*> pure (M2O cn) where findTable s t = find (\tbl -> tableSchema tbl == s && tableName tbl == t) allTabs findCol s t c = find (\col -> tableSchema (colTable col) == s && tableName (colTable col) == t && colName col == c) allCols @@ -586,9 +697,9 @@ cols = mapM (findCol rs rt) rcs colsF = mapM (findCol frs frt) frcs -allPrimaryKeys :: [Table] -> H.Statement () [PrimaryKey] +allPrimaryKeys :: [Table] -> Bool -> H.Statement () [PrimaryKey] allPrimaryKeys tabs = - H.Statement sql HE.noParams (decodePks tabs) True + H.Statement sql HE.noParams (decodePks tabs) where sql = [q| -- CTE to replace information_schema.table_constraints to remove owner limit @@ -666,77 +777,181 @@ pkFromRow tabs (s, t, n) = PrimaryKey <$> table <*> pure n where table = find (\tbl -> tableSchema tbl == s && tableName tbl == t) tabs -allSourceColumns :: [Column] -> PgVersion -> H.Statement [Schema] [SourceColumn] -allSourceColumns cols pgVer = - H.Statement sql (arrayParam HE.text) (decodeSourceColumns cols) True - -- query explanation at https://gist.github.com/steve-chavez/7ee0e6590cddafb532e5f00c46275569 +-- returns all the primary and foreign key columns which are referenced in views +pfkSourceColumns :: [Column] -> Bool -> H.Statement ([Schema], [Schema]) [SourceColumn] +pfkSourceColumns cols = + H.Statement sql (contrazip2 (arrayParam HE.text) (arrayParam HE.text)) (decodeSourceColumns cols) + -- query explanation at: + -- * rationale: https://gist.github.com/wolfgangwalther/5425d64e7b0d20aad71f6f68474d9f19 + -- * json transformation: https://gist.github.com/wolfgangwalther/3a8939da680c24ad767e93ad2c183089 where - subselectRegex :: Text - -- "result" appears when the subselect is used inside "case when", see `authors_have_book_in_decade` fixture - -- "resno" appears in every other case - -- when copying the query into pg make sure you omit one backslash from \\d+, it should be like `\d+` for the regex - subselectRegex | pgVer < pgVersion100 = ":subselect {.*?:constraintDeps <>} :location \\d+} :res(no|ult)" - | otherwise = ":subselect {.*?:stmt_len 0} :location \\d+} :res(no|ult)" - sql = [qc| - with + sql = [q| + with recursive + pks_fks as ( + -- pk + fk referencing col + select + conrelid as resorigtbl, + unnest(conkey) as resorigcol + from pg_constraint + where contype IN ('p', 'f') + union + -- fk referenced col + select + confrelid, + unnest(confkey) + from pg_constraint + where contype='f' + ), views as ( select + c.oid as view_id, n.nspname as view_schema, c.relname as view_name, r.ev_action as view_definition from pg_class c join pg_namespace n on n.oid = c.relnamespace join pg_rewrite r on r.ev_class = c.oid - where c.relkind in ('v', 'm') and n.nspname = ANY ($1) + where c.relkind in ('v', 'm') and n.nspname = ANY($1 || $2) ), - removed_subselects as( + transform_json as ( select - view_schema, view_name, - regexp_replace(view_definition, '{subselectRegex}', '', 'g') as x + view_id, view_schema, view_name, + -- the following formatting is without indentation on purpose + -- to allow simple diffs, with less whitespace noise + replace( + replace( + replace( + replace( + replace( + replace( + replace( + replace( + regexp_replace( + replace( + replace( + replace( + replace( + replace( + replace( + replace( + replace( + replace( + replace( + view_definition::text, + -- This conversion to json is heavily optimized for performance. + -- The general idea is to use as few regexp_replace() calls as possible. + -- Simple replace() is a lot faster, so we jump through some hoops + -- to be able to use regexp_replace() only once. + -- This has been tested against a huge schema with 250+ different views. + -- The unit tests do NOT reflect all possible inputs. Be careful when changing this! + -- ----------------------------------------------- + -- pattern | replacement | flags + -- ----------------------------------------------- + -- `,` is not part of the pg_node_tree format, but used in the regex. + -- This removes all `,` that might be part of column names. + ',' , '' + -- The same applies for `{` and `}`, although those are used a lot in pg_node_tree. + -- We remove the escaped ones, which might be part of column names again. + ), '\{' , '' + ), '\}' , '' + -- The fields we need are formatted as json manually to protect them from the regex. + ), ' :targetList ' , ',"targetList":' + ), ' :resno ' , ',"resno":' + ), ' :resorigtbl ' , ',"resorigtbl":' + ), ' :resorigcol ' , ',"resorigcol":' + -- Make the regex also match the node type, e.g. `{QUERY ...`, to remove it in one pass. + ), '{' , '{ :' + -- Protect node lists, which start with `({` or `((` from the greedy regex. + -- The extra `{` is removed again later. + ), '((' , '{((' + ), '({' , '{({' + -- This regex removes all unused fields to avoid the need to format all of them correctly. + -- This leads to a smaller json result as well. + -- Removal stops at `,` for used fields (see above) and `}` for the end of the current node. + -- Nesting can't be parsed correctly with a regex, so we stop at `{` as well and + -- add an empty key for the followig node. + ), ' :[^}{,]+' , ',"":' , 'g' + -- For performance, the regex also added those empty keys when hitting a `,` or `}`. + -- Those are removed next. + ), ',"":}' , '}' + ), ',"":,' , ',' + -- This reverses the "node list protection" from above. + ), '{(' , '(' + -- Every key above has been added with a `,` so far. The first key in an object doesn't need it. + ), '{,' , '{' + -- pg_node_tree has `()` around lists, but JSON uses `[]` + ), '(' , '[' + ), ')' , ']' + -- pg_node_tree has ` ` between list items, but JSON uses `,` + ), ' ' , ',' + -- `<>` in pg_node_tree is the same as `null` in JSON, but due to very poor performance of json_typeof + -- we need to make this an empty array here to prevent json_array_elements from throwing an error + -- when the targetList is null. + ), '<>' , '[]' + )::json as view_definition from views ), - target_lists as( - select - view_schema, view_name, - regexp_split_to_array(x, 'targetList') as x - from removed_subselects - ), - last_target_list_wo_tail as( - select - view_schema, view_name, - (regexp_split_to_array(x[array_upper(x, 1)], ':onConflict'))[1] as x - from target_lists - ), target_entries as( select - view_schema, view_name, - unnest(regexp_split_to_array(x, 'TARGETENTRY')) as entry - from last_target_list_wo_tail + view_id, view_schema, view_name, + json_array_elements(view_definition->0->'targetList') as entry + from transform_json ), results as( select - view_schema, view_name, - substring(entry from ':resname (.*?) :') as view_colum_name, - substring(entry from ':resorigtbl (.*?) :') as resorigtbl, - substring(entry from ':resorigcol (.*?) :') as resorigcol + view_id, view_schema, view_name, + (entry->>'resno')::int as view_column, + (entry->>'resorigtbl')::oid as resorigtbl, + (entry->>'resorigcol')::int as resorigcol from target_entries + ), + recursion as( + select r.* + from results r + where view_schema = ANY ($1) + union all + select + view.view_id, + view.view_schema, + view.view_name, + view.view_column, + tab.resorigtbl, + tab.resorigcol + from recursion view + join results tab on view.resorigtbl=tab.view_id and view.resorigcol=tab.view_column ) select sch.nspname as table_schema, tbl.relname as table_name, col.attname as table_column_name, - res.view_schema, - res.view_name, - res.view_colum_name - from results res - join pg_class tbl on tbl.oid::text = res.resorigtbl - join pg_attribute col on col.attrelid = tbl.oid and col.attnum::text = res.resorigcol + rec.view_schema, + rec.view_name, + vcol.attname as view_column_name + from recursion rec + join pg_class tbl on tbl.oid = rec.resorigtbl + join pg_attribute col on col.attrelid = tbl.oid and col.attnum = rec.resorigcol + join pg_attribute vcol on vcol.attrelid = rec.view_id and vcol.attnum = rec.view_column join pg_namespace sch on sch.oid = tbl.relnamespace - where resorigtbl <> '0' - order by view_schema, view_name, view_colum_name; |] + join pks_fks using (resorigtbl, resorigcol) + order by view_schema, view_name, view_column_name; |] -getPgVersion :: H.Session PgVersion -getPgVersion = H.statement () $ H.Statement sql HE.noParams versionRow False - where - sql = "SELECT current_setting('server_version_num')::integer, current_setting('server_version')" - versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text +param :: HE.Value a -> HE.Params a +param = HE.param . HE.nonNullable + +arrayParam :: HE.Value a -> HE.Params [a] +arrayParam = param . HE.foldableArray . HE.nonNullable + +compositeArrayColumn :: HD.Composite a -> HD.Row [a] +compositeArrayColumn = arrayColumn . HD.composite + +compositeField :: HD.Value a -> HD.Composite a +compositeField = HD.field . HD.nonNullable + +column :: HD.Value a -> HD.Row a +column = HD.column . HD.nonNullable + +nullableColumn :: HD.Value a -> HD.Row (Maybe a) +nullableColumn = HD.column . HD.nullable + +arrayColumn :: HD.Value a -> HD.Row [a] +arrayColumn = column . HD.listArray . HD.nonNullable diff --git a/src/PostgREST/DbStructure/Identifiers.hs b/src/PostgREST/DbStructure/Identifiers.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/DbStructure/Identifiers.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module PostgREST.DbStructure.Identifiers + ( QualifiedIdentifier(..) + , Schema + , TableName + , FieldName + , toQi + ) where + +import qualified Data.Aeson as JSON +import qualified Data.Text as T +import qualified GHC.Show + +import Protolude + + +-- | Represents a pg identifier with a prepended schema name "schema.table". +-- When qiSchema is "", the schema is defined by the pg search_path. +data QualifiedIdentifier = QualifiedIdentifier + { qiSchema :: Schema + , qiName :: TableName + } + deriving (Eq, Ord, Generic, JSON.ToJSON, JSON.ToJSONKey) + +instance Hashable QualifiedIdentifier + +instance Show QualifiedIdentifier where + show (QualifiedIdentifier s i) = + (if T.null s then mempty else toS s <> ".") <> toS i + +-- TODO: Handle a case where the QI comes like this: "my.fav.schema"."my.identifier" +-- Right now it only handles the schema.identifier case +toQi :: Text -> QualifiedIdentifier +toQi txt = case T.drop 1 <$> T.breakOn "." txt of + (i, "") -> QualifiedIdentifier mempty i + (s, i) -> QualifiedIdentifier s i + +type Schema = Text +type TableName = Text +type FieldName = Text diff --git a/src/PostgREST/DbStructure/Proc.hs b/src/PostgREST/DbStructure/Proc.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/DbStructure/Proc.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module PostgREST.DbStructure.Proc + ( PgArg(..) + , PgType(..) + , ProcDescription(..) + , ProcVolatility(..) + , ProcsMap + , RetType(..) + , procReturnsScalar + , procReturnsSingle + , procTableName + , specifiedProcArgs + ) where + +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S + +import PostgREST.DbStructure.Identifiers (FieldName, + QualifiedIdentifier (..), + Schema, TableName) + +import Protolude + + +data PgArg = PgArg + { pgaName :: Text + , pgaType :: Text + , pgaReq :: Bool + , pgaVar :: Bool + } + deriving (Eq, Ord, Generic, JSON.ToJSON) + +data PgType + = Scalar + | Composite QualifiedIdentifier + deriving (Eq, Ord, Generic, JSON.ToJSON) + +data RetType + = Single PgType + | SetOf PgType + deriving (Eq, Ord, Generic, JSON.ToJSON) + +data ProcVolatility + = Volatile + | Stable + | Immutable + deriving (Eq, Ord, Generic, JSON.ToJSON) + +data ProcDescription = ProcDescription + { pdSchema :: Schema + , pdName :: Text + , pdDescription :: Maybe Text + , pdArgs :: [PgArg] + , pdReturnType :: RetType + , pdVolatility :: ProcVolatility + , pdHasVariadic :: Bool + } + deriving (Eq, Generic, JSON.ToJSON) + +-- Order by least number of args in the case of overloaded functions +instance Ord ProcDescription where + ProcDescription schema1 name1 des1 args1 rt1 vol1 hasVar1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2 hasVar2 + | schema1 == schema2 && name1 == name2 && length args1 < length args2 = LT + | schema2 == schema2 && name1 == name2 && length args1 > length args2 = GT + | otherwise = (schema1, name1, des1, args1, rt1, vol1, hasVar1) `compare` (schema2, name2, des2, args2, rt2, vol2, hasVar2) + +-- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription). +-- | It uses a HashMap for a faster lookup. +type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription] + +{-| + Search the procedure parameters by matching them with the specified keys. + If the key doesn't match a parameter, a parameter with a default type "text" is assumed. +-} +specifiedProcArgs :: S.Set FieldName -> ProcDescription -> [PgArg] +specifiedProcArgs keys proc = + (\k -> fromMaybe (PgArg k "text" True False) (find ((==) k . pgaName) (pdArgs proc))) <$> S.toList keys + +procReturnsScalar :: ProcDescription -> Bool +procReturnsScalar proc = case proc of + ProcDescription{pdReturnType = (Single Scalar)} -> True + ProcDescription{pdReturnType = (SetOf Scalar)} -> True + _ -> False + +procReturnsSingle :: ProcDescription -> Bool +procReturnsSingle proc = case proc of + ProcDescription{pdReturnType = (Single _)} -> True + _ -> False + +procTableName :: ProcDescription -> Maybe TableName +procTableName proc = case pdReturnType proc of + SetOf (Composite qi) -> Just $ qiName qi + Single (Composite qi) -> Just $ qiName qi + _ -> Nothing diff --git a/src/PostgREST/DbStructure/Relationship.hs b/src/PostgREST/DbStructure/Relationship.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/DbStructure/Relationship.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module PostgREST.DbStructure.Relationship + ( Cardinality(..) + , PrimaryKey(..) + , Relationship(..) + , Junction(..) + , isSelfReference + ) where + +import qualified Data.Aeson as JSON + +import PostgREST.DbStructure.Table (Column (..), Table (..)) + +import Protolude + + +-- | Relationship between two tables. +-- +-- The order of the relColumns and relForeignColumns should be maintained to get the +-- join conditions right. +-- +-- TODO merge relColumns and relForeignColumns to a tuple or Data.Bimap +data Relationship = Relationship + { relTable :: Table + , relColumns :: [Column] + , relForeignTable :: Table + , relForeignColumns :: [Column] + , relCardinality :: Cardinality + } + deriving (Eq, Generic, JSON.ToJSON) + +-- | The relationship cardinality +-- | https://en.wikipedia.org/wiki/Cardinality_(data_modeling) +-- TODO: missing one-to-one +data Cardinality + = O2M FKConstraint -- ^ one-to-many cardinality + | M2O FKConstraint -- ^ many-to-one cardinality + | M2M Junction -- ^ many-to-many cardinality + deriving (Eq, Generic, JSON.ToJSON) + +type FKConstraint = Text + +-- | Junction table on an M2M relationship +data Junction = Junction + { junTable :: Table + , junConstraint1 :: FKConstraint + , junColumns1 :: [Column] + , junConstraint2 :: FKConstraint + , junColumns2 :: [Column] + } + deriving (Eq, Generic, JSON.ToJSON) + +isSelfReference :: Relationship -> Bool +isSelfReference r = relTable r == relForeignTable r + +data PrimaryKey = PrimaryKey + { pkTable :: Table + , pkName :: Text + } + deriving (Generic, JSON.ToJSON) diff --git a/src/PostgREST/DbStructure/Table.hs b/src/PostgREST/DbStructure/Table.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/DbStructure/Table.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module PostgREST.DbStructure.Table + ( Column(..) + , Table(..) + , tableQi + ) where + +import qualified Data.Aeson as JSON + +import PostgREST.DbStructure.Identifiers (FieldName, + QualifiedIdentifier (..), + Schema, TableName) + +import Protolude + + +data Table = Table + { tableSchema :: Schema + , tableName :: TableName + , tableDescription :: Maybe Text + -- The following fields identify what can be done on the table/view, they're not related to the privileges granted to it + , tableInsertable :: Bool + , tableUpdatable :: Bool + , tableDeletable :: Bool + } + deriving (Show, Ord, Generic, JSON.ToJSON) + +instance Eq Table where + Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2 + +tableQi :: Table -> QualifiedIdentifier +tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n + +data Column = Column + { colTable :: Table + , colName :: FieldName + , colDescription :: Maybe Text + , colNullable :: Bool + , colType :: Text + , colMaxLen :: Maybe Int32 + , colDefault :: Maybe Text + , colEnum :: [Text] + } + deriving (Ord, Generic, JSON.ToJSON) + +instance Eq Column where + Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2 + +data PrimaryKey = PrimaryKey + { pkTable :: Table + , pkName :: Text + } + deriving (Generic, JSON.ToJSON) diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -3,17 +3,17 @@ Description : PostgREST error HTTP responses -} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} -module PostgREST.Error ( - errorResponseFor -, ApiRequestError(..) -, PgError(..) -, SimpleError(..) -, errorPayload -, checkIsFatal -, singularityError -) where +module PostgREST.Error + ( errorResponseFor + , ApiRequestError(..) + , PgError(..) + , Error(..) + , errorPayload + , checkIsFatal + , singularityError + ) where import qualified Data.Aeson as JSON import qualified Data.Text as T @@ -24,13 +24,22 @@ import Data.Aeson ((.=)) import Network.Wai (Response, responseLBS) -import Network.HTTP.Types.Header +import Network.HTTP.Types.Header (Header) -import PostgREST.Types -import Protolude hiding (toS) -import Protolude.Conv (toS) +import PostgREST.ContentType (ContentType (..)) +import qualified PostgREST.ContentType as ContentType +import PostgREST.DbStructure.Proc (PgArg (..), + ProcDescription (..)) +import PostgREST.DbStructure.Relationship (Cardinality (..), + Junction (..), + Relationship (..)) +import PostgREST.DbStructure.Table (Column (..), Table (..)) +import Protolude hiding (toS) +import Protolude.Conv (toS, toSL) + + class (JSON.ToJSON a) => PgrstError a where status :: a -> HT.Status headers :: a -> [Header] @@ -49,26 +58,29 @@ | InvalidBody ByteString | ParseRequestError Text Text | NoRelBetween Text Text - | AmbiguousRelBetween Text Text [Relation] + | AmbiguousRelBetween Text Text [Relationship] + | AmbiguousRpc [ProcDescription] + | NoRpc Text Text [Text] Bool | InvalidFilters | UnacceptableSchema [Text] - | UnknownRelation -- Unreachable? + | ContentTypeError [ByteString] | UnsupportedVerb -- Unreachable? - deriving (Show, Eq) instance PgrstError ApiRequestError where status InvalidRange = HT.status416 status InvalidFilters = HT.status405 status (InvalidBody _) = HT.status400 status UnsupportedVerb = HT.status405 - status UnknownRelation = HT.status404 status ActionInappropriate = HT.status405 status (ParseRequestError _ _) = HT.status400 status (NoRelBetween _ _) = HT.status400 status AmbiguousRelBetween{} = HT.status300 + status (AmbiguousRpc _) = HT.status300 + status NoRpc{} = HT.status404 status (UnacceptableSchema _) = HT.status406 + status (ContentTypeError _) = HT.status415 - headers _ = [toHeader CTApplicationJSON] + headers _ = [ContentType.toHeader CTApplicationJSON] instance JSON.ToJSON ApiRequestError where toJSON (ParseRequestError message details) = JSON.object [ @@ -79,41 +91,51 @@ "message" .= (toS errorMessage :: Text)] toJSON InvalidRange = JSON.object [ "message" .= ("HTTP Range error" :: Text)] - toJSON UnknownRelation = JSON.object [ - "message" .= ("Unknown relation" :: Text)] toJSON (NoRelBetween parent child) = JSON.object [ - "message" .= ("Could not find foreign keys between these entities. No relationship found between " <> parent <> " and " <> child :: Text)] + "hint" .= ("If a new foreign key between these entities was created in the database, try reloading the schema cache." :: Text), + "message" .= ("Could not find a relationship between " <> parent <> " and " <> child <> " in the schema cache" :: Text)] toJSON (AmbiguousRelBetween parent child rels) = JSON.object [ "hint" .= ("By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)" :: Text), "message" .= ("More than one relationship was found for " <> parent <> " and " <> child :: Text), "details" .= (compressedRel <$> rels) ] + toJSON (AmbiguousRpc procs) = JSON.object [ + "hint" .= ("Overloaded functions with the same argument name but different types are not supported" :: Text), + "message" .= ("Could not choose the best candidate function between: " <> T.intercalate ", " [pdSchema p <> "." <> pdName p <> "(" <> T.intercalate ", " [pgaName a <> " => " <> pgaType a | a <- pdArgs p] <> ")" | p <- procs])] + toJSON (NoRpc schema procName payloadKeys hasPreferSingleObject) = JSON.object [ + "hint" .= ("If a new function was created in the database with this name and arguments, try reloading the schema cache." :: Text), + "message" .= ("Could not find the " <> schema <> "." <> procName <> (if hasPreferSingleObject then " function with a single json or jsonb argument" else "(" <> T.intercalate ", " payloadKeys <> ")" <> " function") <> " in the schema cache")] toJSON UnsupportedVerb = JSON.object [ "message" .= ("Unsupported HTTP verb" :: Text)] toJSON InvalidFilters = JSON.object [ "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)] toJSON (UnacceptableSchema schemas) = JSON.object [ "message" .= ("The schema must be one of the following: " <> T.intercalate ", " schemas)] + toJSON (ContentTypeError cts) = JSON.object [ + "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)] -compressedRel :: Relation -> JSON.Value -compressedRel rel = +compressedRel :: Relationship -> JSON.Value +compressedRel Relationship{..} = let - fmtTbl tbl = tableSchema tbl <> "." <> tableName tbl + fmtTbl Table{..} = tableSchema <> "." <> tableName fmtEls els = "[" <> T.intercalate ", " els <> "]" in JSON.object $ [ - "origin" .= fmtTbl (relTable rel) - , "target" .= fmtTbl (relFTable rel) - , "cardinality" .= (show $ relType rel :: Text) + "origin" .= fmtTbl relTable + , "target" .= fmtTbl relForeignTable ] ++ - case (relType rel, relJunction rel, relConstraint rel) of - (M2M, Just (Junction jt (Just const1) _ (Just const2) _), _) -> [ - "relationship" .= (fmtTbl jt <> fmtEls [const1] <> fmtEls [const2]) + case relCardinality of + M2M Junction{..} -> [ + "cardinality" .= ("m2m" :: Text) + , "relationship" .= (fmtTbl junTable <> fmtEls [junConstraint1] <> fmtEls [junConstraint2]) ] - (_, _, Just relCon) -> [ - "relationship" .= (relCon <> fmtEls (colName <$> relColumns rel) <> fmtEls (colName <$> relFColumns rel)) + M2O cons -> [ + "cardinality" .= ("m2o" :: Text) + , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns)) ] - (_, _, _) -> - mempty + O2M cons -> [ + "cardinality" .= ("o2m" :: Text) + , "relationship" .= (cons <> fmtEls (colName <$> relColumns) <> fmtEls (colName <$> relForeignColumns)) + ] data PgError = PgError Authenticated P.UsageError type Authenticated = Bool @@ -123,8 +145,8 @@ headers err = if status err == HT.status401 - then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header] - else [toHeader CTApplicationJSON] + then [ContentType.toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header] + else [ContentType.toHeader CTApplicationJSON] instance JSON.ToJSON PgError where toJSON (PgError _ usageError) = JSON.toJSON usageError @@ -132,8 +154,8 @@ instance JSON.ToJSON P.UsageError where toJSON (P.ConnectionError e) = JSON.object [ "code" .= ("" :: Text), - "message" .= ("Database connection error" :: Text), - "details" .= (toS $ fromMaybe "" e :: Text)] + "message" .= ("Database connection error. Retrying the connection." :: Text), + "details" .= (toSL $ fromMaybe "" e :: Text)] toJSON (P.SessionError e) = JSON.toJSON e -- H.Error instance JSON.ToJSON H.QueryError where @@ -169,7 +191,7 @@ "message" .= ("Unexpected amount of rows" :: Text), "details" .= i] toJSON (H.ClientError d) = JSON.object [ - "message" .= ("Database client error" :: Text), + "message" .= ("Database client error. Retrying the connection." :: Text), "details" .= (fmap toS d :: Maybe Text)] pgErrorStatus :: Bool -> P.UsageError -> HT.Status @@ -185,6 +207,7 @@ '0':'P':_ -> HT.status403 -- invalid role specification "23503" -> HT.status409 -- foreign_key_violation "23505" -> HT.status409 -- unique_violation + "25006" -> HT.status405 -- read_only_sql_transaction '2':'5':_ -> HT.status500 -- invalid tx state '2':'8':_ -> HT.status403 -- invalid auth specification '2':'D':_ -> HT.status500 -- invalid tx termination @@ -215,12 +238,29 @@ | isAuthFailureMessage = Just $ toS failureMessage | otherwise = Nothing where isAuthFailureMessage = "FATAL: password authentication failed" `isPrefixOf` toS failureMessage - failureMessage = fromMaybe "" e + failureMessage = fromMaybe mempty e +checkIsFatal (PgError _ (P.SessionError (H.QueryError _ _ (H.ResultError serverError)))) + = case serverError of + -- Check for a syntax error (42601 is the pg code). This would mean the error is on our part somehow, so we treat it as fatal. + H.ServerError "42601" _ _ _ + -> Just "Hint: This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues" + -- Check for a "prepared statement already exists" error (Code 42P05: duplicate_prepared_statement). + -- This would mean that a connection pooler in transaction mode is being used + -- while prepared statements are enabled in the PostgREST configuration, + -- both of which are incompatible with each other. + H.ServerError "42P05" _ _ _ + -> Just "Hint: If you are using connection poolers in transaction mode, try setting db-prepared-statements to false." + -- Check for a "transaction blocks not allowed in statement pooling mode" error (Code 08P01: protocol_violation). + -- This would mean that a connection pooler in statement mode is being used which is not supported in PostgREST. + H.ServerError "08P01" "transaction blocks not allowed in statement pooling mode" _ _ + -> Just "Hint: Connection poolers in statement mode are not supported." + _ -> Nothing checkIsFatal _ = Nothing -data SimpleError +data Error = GucHeadersError + | GucStatusError | BinaryFieldError ContentType | ConnectionLostError | PutMatchingPkError @@ -228,11 +268,13 @@ | JwtTokenMissing | JwtTokenInvalid Text | SingularityError Integer - | ContentTypeError [ByteString] - deriving (Show, Eq) + | NotFound + | ApiRequestError ApiRequestError + | PgErr PgError -instance PgrstError SimpleError where +instance PgrstError Error where status GucHeadersError = HT.status500 + status GucStatusError = HT.status500 status (BinaryFieldError _) = HT.status406 status ConnectionLostError = HT.status503 status PutMatchingPkError = HT.status400 @@ -240,39 +282,46 @@ status JwtTokenMissing = HT.status500 status (JwtTokenInvalid _) = HT.unauthorized401 status (SingularityError _) = HT.status406 - status (ContentTypeError _) = HT.status415 + status NotFound = HT.status404 + status (PgErr err) = status err + status (ApiRequestError err) = status err - headers (SingularityError _) = [toHeader CTSingularJSON] - headers (JwtTokenInvalid m) = [toHeader CTApplicationJSON, invalidTokenHeader m] - headers _ = [toHeader CTApplicationJSON] + headers (SingularityError _) = [ContentType.toHeader CTSingularJSON] + headers (JwtTokenInvalid m) = [ContentType.toHeader CTApplicationJSON, invalidTokenHeader m] + headers (PgErr err) = headers err + headers (ApiRequestError err) = headers err + headers _ = [ContentType.toHeader CTApplicationJSON] -instance JSON.ToJSON SimpleError where +instance JSON.ToJSON Error where toJSON GucHeadersError = JSON.object [ "message" .= ("response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)] + toJSON GucStatusError = JSON.object [ + "message" .= ("response.status guc must be a valid status code" :: Text)] toJSON (BinaryFieldError ct) = JSON.object [ - "message" .= ((toS (toMime ct) <> " requested but more than one column was selected") :: Text)] + "message" .= ((toS (ContentType.toMime ct) <> " requested but more than one column was selected") :: Text)] toJSON ConnectionLostError = JSON.object [ - "message" .= ("Database connection lost, retrying the connection." :: Text)] + "message" .= ("Database connection lost. Retrying the connection." :: Text)] toJSON PutRangeNotAllowedError = JSON.object [ "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)] toJSON PutMatchingPkError = JSON.object [ "message" .= ("Payload values do not match URL in primary key column(s)" :: Text)] - toJSON (ContentTypeError cts) = JSON.object [ - "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)] toJSON (SingularityError n) = JSON.object [ "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text), - "details" .= T.unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]] + "details" .= T.unwords ["Results contain", show n, "rows,", toS (ContentType.toMime CTSingularJSON), "requires 1 row"]] toJSON JwtTokenMissing = JSON.object [ "message" .= ("Server lacks JWT secret" :: Text)] toJSON (JwtTokenInvalid message) = JSON.object [ "message" .= (message :: Text)] + toJSON NotFound = JSON.object [] + toJSON (PgErr err) = JSON.toJSON err + toJSON (ApiRequestError err) = JSON.toJSON err invalidTokenHeader :: Text -> Header invalidTokenHeader m = ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m)) -singularityError :: (Integral a) => a -> SimpleError +singularityError :: (Integral a) => a -> Error singularityError = SingularityError . toInteger diff --git a/src/PostgREST/GucHeader.hs b/src/PostgREST/GucHeader.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/GucHeader.hs @@ -0,0 +1,37 @@ +module PostgREST.GucHeader + ( GucHeader + , unwrapGucHeader + , addHeadersIfNotIncluded + ) where + +import qualified Data.Aeson as JSON +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as M + +import Network.HTTP.Types.Header (Header) + +import Protolude hiding (toS) +import Protolude.Conv (toS) + + +{-| + Custom guc header, it's obtained by parsing the json in a: + `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]' +-} +newtype GucHeader = GucHeader (CI.CI ByteString, ByteString) + +instance JSON.FromJSON GucHeader where + parseJSON (JSON.Object o) = case headMay (M.toList o) of + Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s) + | otherwise -> mzero + _ -> mzero + parseJSON _ = mzero + +unwrapGucHeader :: GucHeader -> Header +unwrapGucHeader (GucHeader (k, v)) = (k, v) + +-- | Add headers not already included to allow the user to override them instead of duplicating them +addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header] +addHeadersIfNotIncluded newHeaders initialHeaders = + filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++ + initialHeaders diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -1,71 +1,183 @@ {-| Module : PostgREST.Middleware -Description : Sets the PostgreSQL GUCs, role, search_path and pre-request function. Validates JWT. +Description : Sets CORS policy. Also the PostgreSQL GUCs, role, search_path and pre-request function. -} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +module PostgREST.Middleware + ( runPgLocals + , pgrstFormat + , pgrstMiddleware + , defaultCorsPolicy + , corsPolicy + , optionalRollback + ) where -module PostgREST.Middleware where +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T +import qualified Hasql.Decoders as HD +import qualified Hasql.DynamicStatements.Snippet as H hiding + (sql) +import qualified Hasql.DynamicStatements.Statement as H +import qualified Hasql.Transaction as H +import qualified Network.HTTP.Types.Header as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Logger as Wai +import qualified Network.Wai.Middleware.Cors as Wai +import qualified Network.Wai.Middleware.Gzip as Wai +import qualified Network.Wai.Middleware.RequestLogger as Wai +import qualified Network.Wai.Middleware.Static as Wai -import qualified Data.Aeson as JSON -import qualified Data.HashMap.Strict as M -import Data.Scientific (FPFormat (..), formatScientific, - isInteger) -import qualified Hasql.Transaction as H +import Data.Function (id) +import Data.List (lookup) +import Data.Scientific (FPFormat (..), formatScientific, + isInteger) +import Network.HTTP.Types.Status (Status, status400, status500, + statusCode) +import System.IO.Unsafe (unsafePerformIO) +import System.Log.FastLogger (toLogStr) -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) +import PostgREST.Config (AppConfig (..), LogLevel (..)) +import PostgREST.Error (Error, errorResponseFor) +import PostgREST.GucHeader (addHeadersIfNotIncluded) +import PostgREST.Query.SqlFragment (fromQi, intercalateSnippet, + unknownEncoder) +import PostgREST.Request.ApiRequest (ApiRequest (..), Target (..)) -import Crypto.JWT +import PostgREST.Request.Preferences -import PostgREST.ApiRequest (ApiRequest (..)) -import PostgREST.Auth (JWTAttempt (..)) -import PostgREST.Config (AppConfig (..), corsPolicy) -import PostgREST.Error (SimpleError (JwtTokenInvalid, JwtTokenMissing), - errorResponseFor) -import PostgREST.QueryBuilder (setLocalQuery, setLocalSearchPathQuery) -import Protolude hiding (head, toS) -import Protolude.Conv (toS) +import Protolude hiding (head, toS) +import Protolude.Conv (toS) -runWithClaims :: AppConfig -> JWTAttempt -> - (ApiRequest -> H.Transaction Response) -> - ApiRequest -> H.Transaction Response -runWithClaims conf eClaims app req = - case eClaims of - JWTMissingSecret -> return . errorResponseFor $ JwtTokenMissing - JWTInvalid JWTExpired -> return . errorResponseFor . JwtTokenInvalid $ "JWT expired" - JWTInvalid e -> return . errorResponseFor . JwtTokenInvalid . show $ e - JWTClaims claims -> do - H.sql $ toS . mconcat $ setSearchPathSql : setRoleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql - mapM_ H.sql customReqCheck - app req - where - methodSql = setLocalQuery mempty ("request.method", toS $ iMethod req) - pathSql = setLocalQuery mempty ("request.path", toS $ iPath req) - headersSql = setLocalQuery "request.header." <$> iHeaders req - cookiesSql = setLocalQuery "request.cookie." <$> iCookies req - claimsSql = setLocalQuery "request.jwt.claim." <$> [(c,unquoted v) | (c,v) <- M.toList claimsWithRole] - appSettingsSql = setLocalQuery mempty <$> configSettings conf - setRoleSql = maybeToList $ (\x -> - setLocalQuery mempty ("role", unquoted x)) <$> M.lookup "role" claimsWithRole - setSearchPathSql = setLocalSearchPathQuery (iSchema req : configExtraSearchPath conf) - -- role claim defaults to anon if not specified in jwt - claimsWithRole = M.union claims (M.singleton "role" anon) - anon = JSON.String . toS $ configAnonRole conf - customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf +-- | Runs local(transaction scoped) GUCs for every request, plus the pre-request function +runPgLocals :: AppConfig -> M.HashMap Text JSON.Value -> + (ApiRequest -> ExceptT Error H.Transaction Wai.Response) -> + ApiRequest -> ByteString -> ExceptT Error H.Transaction Wai.Response +runPgLocals conf claims app req jsonDbS = do + lift $ H.statement mempty $ H.dynamicallyParameterized + ("select " <> intercalateSnippet ", " (searchPathSql : roleSql ++ claimsSql ++ [methodSql, pathSql] ++ headersSql ++ cookiesSql ++ appSettingsSql ++ specSql)) + HD.noResult (configDbPreparedStatements conf) + lift $ traverse_ H.sql preReqSql + app req + where + methodSql = setConfigLocal mempty ("request.method", iMethod req) + pathSql = setConfigLocal mempty ("request.path", iPath req) + headersSql = setConfigLocal "request.header." <$> iHeaders req + cookiesSql = setConfigLocal "request.cookie." <$> iCookies req + claimsWithRole = + let anon = JSON.String . toS $ configDbAnonRole conf in -- role claim defaults to anon if not specified in jwt + M.union claims (M.singleton "role" anon) + claimsSql = setConfigLocal "request.jwt.claim." <$> [(toS c, toS $ unquoted v) | (c,v) <- M.toList claimsWithRole] + roleSql = maybeToList $ (\x -> setConfigLocal mempty ("role", toS $ unquoted x)) <$> M.lookup "role" claimsWithRole + appSettingsSql = setConfigLocal mempty <$> (join bimap toS <$> configAppSettings conf) + searchPathSql = + let schemas = T.intercalate ", " (iSchema req : configDbExtraSearchPath conf) in + setConfigLocal mempty ("search_path", toS schemas) + preReqSql = (\f -> "select " <> fromQi f <> "();") <$> configDbPreRequest conf + specSql = case iTarget req of + TargetProc{tpIsRootSpec=True} -> [setConfigLocal mempty ("request.spec", jsonDbS)] + _ -> mempty + -- | Do a pg set_config(setting, value, true) call. This is equivalent to a SET LOCAL. + setConfigLocal :: ByteString -> (ByteString, ByteString) -> H.Snippet + setConfigLocal prefix (k, v) = + "set_config(" <> unknownEncoder (prefix <> k) <> ", " <> unknownEncoder v <> ", true)" -defaultMiddle :: Application -> Application -defaultMiddle = - gzip def - . cors corsPolicy - . staticPolicy (only [("favicon.ico", "static/favicon.ico")]) +-- | Log in apache format. Only requests that have a status greater than minStatus are logged. +-- | There's no way to filter logs in the apache format on wai-extra: https://hackage.haskell.org/package/wai-extra-3.0.29.2/docs/Network-Wai-Middleware-RequestLogger.html#t:OutputFormat. +-- | So here we copy wai-logger apacheLogStr function: https://github.com/kazu-yamamoto/logger/blob/a4f51b909a099c51af7a3f75cf16e19a06f9e257/wai-logger/Network/Wai/Logger/Apache.hs#L45 +-- | TODO: Add the ability to filter apache logs on wai-extra and remove this function. +pgrstFormat :: Status -> Wai.OutputFormatter +pgrstFormat minStatus date req status responseSize = + if status < minStatus + then mempty + else toLogStr (getSourceFromSocket req) + <> " - - [" + <> toLogStr date + <> "] \"" + <> toLogStr (Wai.requestMethod req) + <> " " + <> toLogStr (Wai.rawPathInfo req <> Wai.rawQueryString req) + <> " " + <> toLogStr (show (Wai.httpVersion req)::Text) + <> "\" " + <> toLogStr (show (statusCode status)::Text) + <> " " + <> toLogStr (maybe "-" show responseSize::Text) + <> " \"" + <> toLogStr (fromMaybe mempty $ Wai.requestHeaderReferer req) + <> "\" \"" + <> toLogStr (fromMaybe mempty $ Wai.requestHeaderUserAgent req) + <> "\"\n" + where + getSourceFromSocket = BS.pack . Wai.showSockAddr . Wai.remoteHost +pgrstMiddleware :: LogLevel -> Wai.Application -> Wai.Application +pgrstMiddleware logLevel = + logger + . Wai.cors corsPolicy + . Wai.staticPolicy (Wai.only [("favicon.ico", "static/favicon.ico")]) + where + logger = case logLevel of + LogCrit -> id + LogError -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status500} + LogWarn -> unsafePerformIO $ Wai.mkRequestLogger Wai.def { Wai.outputFormat = Wai.CustomOutputFormat $ pgrstFormat status400} + LogInfo -> Wai.logStdout + +defaultCorsPolicy :: Wai.CorsResourcePolicy +defaultCorsPolicy = Wai.CorsResourcePolicy Nothing + ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing + (Just $ 60*60*24) False False True + +-- | CORS policy to be used in by Wai Cors middleware +corsPolicy :: Wai.Request -> Maybe Wai.CorsResourcePolicy +corsPolicy req = case lookup "origin" headers of + Just origin -> Just defaultCorsPolicy { + Wai.corsOrigins = Just ([origin], True) + , Wai.corsRequestHeaders = "Authentication" : accHeaders + , Wai.corsExposedHeaders = Just [ + "Content-Encoding", "Content-Location", "Content-Range", "Content-Type" + , "Date", "Location", "Server", "Transfer-Encoding", "Range-Unit" + ] + } + Nothing -> Nothing + where + headers = Wai.requestHeaders req + accHeaders = case lookup "access-control-request-headers" headers of + Just hdrs -> map (CI.mk . toS . T.strip . toS) $ BS.split ',' hdrs + Nothing -> [] + unquoted :: JSON.Value -> Text unquoted (JSON.String t) = t unquoted (JSON.Number n) = toS $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n unquoted (JSON.Bool b) = show b unquoted v = toS $ JSON.encode v + +-- | Set a transaction to eventually roll back if requested and set respective +-- headers on the response. +optionalRollback + :: AppConfig + -> ApiRequest + -> ExceptT Error H.Transaction Wai.Response + -> ExceptT Error H.Transaction Wai.Response +optionalRollback AppConfig{..} ApiRequest{..} transaction = do + resp <- catchError transaction $ return . errorResponseFor + when (shouldRollback || (configDbTxRollbackAll && not shouldCommit)) + (lift H.condemn) + return $ Wai.mapResponseHeaders preferenceApplied resp + where + shouldCommit = + configDbTxAllowOverride && iPreferTransaction == Just Commit + shouldRollback = + configDbTxAllowOverride && iPreferTransaction == Just Rollback + preferenceApplied + | shouldCommit = + addHeadersIfNotIncluded + [(HTTP.hPreferenceApplied, BS.pack (show Commit))] + | shouldRollback = + addHeadersIfNotIncluded + [(HTTP.hPreferenceApplied, BS.pack (show Rollback))] + | otherwise = + identity diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -2,41 +2,57 @@ Module : PostgREST.OpenAPI Description : Generates the OpenAPI output -} -{-# LANGUAGE OverloadedStrings #-} - -module PostgREST.OpenAPI ( - encodeOpenAPI -, isMalformedProxyUri -, pickProxy -) where +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +module PostgREST.OpenAPI (encode) where -import qualified Data.HashSet.InsOrd as Set +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Lazy as LBS +import qualified Data.HashMap.Strict as HashMap +import qualified Data.HashSet.InsOrd as Set +import qualified Data.Text as T import Control.Arrow ((&&&)) -import Data.Aeson (decode, encode) import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList) import Data.Maybe (fromJust) import Data.String (IsString (..)) -import Data.Text (append, breakOn, dropWhile, init, - intercalate, pack, tail, toLower, - unpack) -import Network.URI (URI (..), URIAuth (..), - isAbsoluteURI, parseURI) +import Network.URI (URI (..), URIAuth (..)) -import Control.Lens +import Control.Lens (at, (.~), (?~)) + import Data.Swagger -import PostgREST.ApiRequest (ContentType (..)) -import PostgREST.Config (docsVersion, prettyVersion) -import PostgREST.Types (Column (..), ForeignKey (..), PgArg (..), - PrimaryKey (..), ProcDescription (..), - Proxy (..), Table (..), toMime) -import Protolude hiding (Proxy, dropWhile, get, - intercalate, toLower, toS, (&)) -import Protolude.Conv (toS) +import PostgREST.Config (AppConfig (..), Proxy (..), + isMalformedProxyUri, toURI) +import PostgREST.DbStructure (DbStructure (..), + tableCols, tablePKCols) +import PostgREST.DbStructure.Proc (PgArg (..), + ProcDescription (..)) +import PostgREST.DbStructure.Relationship (Cardinality (..), + PrimaryKey (..), + Relationship (..)) +import PostgREST.DbStructure.Table (Column (..), Table (..)) +import PostgREST.Version (docsVersion, prettyVersion) +import PostgREST.ContentType + +import Protolude hiding (Proxy, get, toS) +import Protolude.Conv (toS) + +encode :: AppConfig -> DbStructure -> [Table] -> HashMap.HashMap k [ProcDescription] -> Maybe Text -> LBS.ByteString +encode conf dbStructure tables procs schemaDescription = + JSON.encode $ + postgrestSpec + (dbRelationships dbStructure) + (concat $ HashMap.elems procs) + (openApiTableInfo dbStructure <$> tables) + (proxyUri conf) + schemaDescription + (dbPrimaryKeys dbStructure) + makeMimeList :: [ContentType] -> MimeList -makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs +makeMimeList cs = MimeList $ fmap (fromString . toS . toMime) cs toSwaggerType :: Text -> SwaggerType t toSwaggerType "character varying" = SwaggerString @@ -51,36 +67,47 @@ toSwaggerType "double precision" = SwaggerNumber toSwaggerType _ = SwaggerString -makeTableDef :: [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema) -makeTableDef pks (t, cs, _) = +makeTableDef :: [Relationship] -> [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema) +makeTableDef rels pks (t, cs, _) = let tn = tableName t in (tn, (mempty :: Schema) & description .~ tableDescription t & type_ ?~ SwaggerObject - & properties .~ fromList (map (makeProperty pks) cs) - & required .~ map colName (filter (not . colNullable) cs)) + & properties .~ fromList (fmap (makeProperty rels pks) cs) + & required .~ fmap colName (filter (not . colNullable) cs)) -makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema) -makeProperty pks c = (colName c, Inline s) +makeProperty :: [Relationship] -> [PrimaryKey] -> Column -> (Text, Referenced Schema) +makeProperty rels pks c = (colName c, Inline s) where - 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, "`."] + e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c + fk :: Maybe Text + fk = + let + -- Finds the relationship that has a single column foreign key + rel = find (\case + Relationship{relColumns, relCardinality=M2O _} -> [c] == relColumns + _ -> False + ) rels + fCol = colName <$> (headMay . relForeignColumns =<< rel) + fTbl = tableName . relForeignTable <$> rel + fTblCol = (,) <$> fTbl <*> fCol + in + (\(a, b) -> T.intercalate "" ["This is a Foreign Key to `", a, ".", b, "`."]) <$> fTblCol 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." else Nothing - , fk <$> colFK c + , fk ] d = if length n > 1 then - Just $ append (maybe "" (`append` "\n\n") $ colDescription c) (intercalate "\n" n) + Just $ T.append (maybe "" (`T.append` "\n\n") $ colDescription c) (T.intercalate "\n" n) else colDescription c s = (mempty :: Schema) - & default_ .~ (decode . toS =<< colDefault c) + & default_ .~ (JSON.decode . toS =<< colDefault c) & description .~ d & enum_ .~ e & format ?~ colType c @@ -92,11 +119,11 @@ (mempty :: Schema) & description .~ pdDescription pd & type_ ?~ SwaggerObject - & properties .~ fromList (map makeProcProperty (pdArgs pd)) - & required .~ map pgaName (filter pgaReq (pdArgs pd)) + & properties .~ fromList (fmap makeProcProperty (pdArgs pd)) + & required .~ fmap pgaName (filter pgaReq (pdArgs pd)) makeProcProperty :: PgArg -> (Text, Referenced Schema) -makeProcProperty (PgArg n t _) = (n, Inline s) +makeProcProperty (PgArg n t _ _) = (n, Inline s) where s = (mempty :: Schema) & type_ ?~ toSwaggerType t @@ -111,7 +138,7 @@ & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamHeader & type_ ?~ SwaggerString - & enum_ .~ decode (encode ts)) + & enum_ .~ JSON.decode (JSON.encode ts)) makeProcParam :: ProcDescription -> [Referenced Param] makeProcParam pd = @@ -162,7 +189,7 @@ & schema .~ ParamOther ((mempty :: ParamOtherSchema) & in_ .~ ParamHeader & type_ ?~ SwaggerString - & default_ .~ decode "\"items\"")) + & default_ .~ JSON.decode "\"items\"")) , ("offset", (mempty :: Param) & name .~ "offset" & description ?~ "Limiting and Pagination" @@ -192,7 +219,7 @@ makeRowFilter :: Text -> Column -> (Text, Param) makeRowFilter tn c = - (intercalate "." ["rowFilter", tn, colName c], (mempty :: Param) + (T.intercalate "." ["rowFilter", tn, colName c], (mempty :: Param) & name .~ colName c & description .~ colDescription c & required ?~ False @@ -202,21 +229,21 @@ & format ?~ colType c)) makeRowFilters :: Text -> [Column] -> [(Text, Param)] -makeRowFilters tn = map (makeRowFilter tn) +makeRowFilters tn = fmap (makeRowFilter tn) makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem) -makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t) +makePathItem (t, cs, _) = ("/" ++ T.unpack tn, p $ tableInsertable t || tableUpdatable t || tableDeletable 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 + (tSum, tDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $ + T.breakOn "\n" <$> tableDescription t tOp = (mempty :: Operation) & tags .~ Set.fromList [tn] & summary .~ tSum & description .~ mfilter (/="") tDesc getOp = tOp - & parameters .~ map ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"]) + & parameters .~ fmap ref (rs <> ["select", "order", "range", "rangeUnit", "offset", "limit", "preferCount"]) & at 206 ?~ "Partial Content" & at 200 ?~ Inline ((mempty :: Response) & description .~ "OK" @@ -226,20 +253,20 @@ ) ) postOp = tOp - & parameters .~ map ref ["body." <> tn, "select", "preferReturn"] + & parameters .~ fmap ref ["body." <> tn, "select", "preferReturn"] & at 201 ?~ "Created" patchOp = tOp - & parameters .~ map ref (rs <> ["body." <> tn, "preferReturn"]) + & parameters .~ fmap ref (rs <> ["body." <> tn, "preferReturn"]) & at 204 ?~ "No Content" deletOp = tOp - & parameters .~ map ref (rs <> ["preferReturn"]) + & parameters .~ fmap 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 tn = tableName t - rs = [ intercalate "." ["rowFilter", tn, colName c ] | c <- cs ] + rs = [ T.intercalate "." ["rowFilter", tn, colName c ] | c <- cs ] ref = Ref . Reference makeProcPathItem :: ProcDescription -> (FilePath, PathItem) @@ -247,8 +274,8 @@ where -- Use first line of proc 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 - (pSum, pDesc) = fmap fst &&& fmap (dropWhile (=='\n') . snd) $ - breakOn "\n" <$> pdDescription pd + (pSum, pDesc) = fmap fst &&& fmap (T.dropWhile (=='\n') . snd) $ + T.breakOn "\n" <$> pdDescription pd postOp = (mempty :: Operation) & summary .~ pSum & description .~ mfilter (/="") pDesc @@ -271,7 +298,7 @@ makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem makePathItems pds ti = fromList $ makeRootPathItem : - map makePathItem ti ++ map makeProcPathItem pds + fmap makePathItem ti ++ fmap makeProcPathItem pds escapeHostName :: Text -> Text escapeHostName "*" = "0.0.0.0" @@ -281,9 +308,9 @@ escapeHostName "!6" = "0.0.0.0" escapeHostName h = h -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 +postgrestSpec :: [Relationship] -> [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] -> Swagger +postgrestSpec rels pds ti (s, h, p, b) sd pks = (mempty :: Swagger) + & basePath ?~ T.unpack b & schemes ?~ [s'] & info .~ ((mempty :: Info) & version .~ prettyVersion @@ -293,44 +320,23 @@ & description ?~ "PostgREST Documentation" & url .~ URL ("https://postgrest.org/en/" <> docsVersion <> "/api.html")) & host .~ h' - & definitions .~ fromList (map (makeTableDef pks) ti) + & definitions .~ fromList (makeTableDef rels 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)) + h' = Just $ Host (T.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) -> 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. - A valid proxy uri should be an absolute uri without query and user info, - only http(s) schemes are valid, port number range is 1-65535. - - For example - http://postgrest.com/openapi.json - https://postgrest.com:8080/openapi.json --} -isMalformedProxyUri :: Maybe Text -> Bool -isMalformedProxyUri Nothing = False -isMalformedProxyUri (Just uri) - | isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri - | otherwise = True - -toURI :: Text -> URI -toURI uri = fromJust $ parseURI (toS uri) - pickProxy :: Maybe Text -> Maybe Proxy pickProxy proxy | isNothing proxy = Nothing -- should never happen -- since the request would have been rejected by the middleware if proxy uri -- is malformed - | isMalformedProxyUri proxy = Nothing + | isMalformedProxyUri $ fromMaybe mempty proxy = Nothing | otherwise = Just Proxy { proxyScheme = scheme , proxyHost = host' @@ -339,53 +345,31 @@ } where uri = toURI $ fromJust proxy - scheme = init $ toLower $ pack $ uriScheme uri + scheme = T.init $ T.toLower $ T.pack $ uriScheme uri path URI {uriPath = ""} = "/" path URI {uriPath = p} = p - path' = pack $ path uri + path' = T.pack $ path uri authority = fromJust $ uriAuthority uri - host' = pack $ uriRegName authority + host' = T.pack $ uriRegName authority port' = uriPort authority readPort = fromMaybe 80 . readMaybe port'' :: Integer port'' = case (port', scheme) of ("", "http") -> 80 ("", "https") -> 443 - _ -> readPort $ unpack $ tail $ pack port' - -isUriValid:: URI -> Bool -isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid] - -fAnd :: [a -> Bool] -> a -> Bool -fAnd fs x = all ($ x) fs - -isSchemeValid :: URI -> Bool -isSchemeValid URI {uriScheme = s} - | toLower (pack s) == "https:" = True - | toLower (pack s) == "http:" = True - | otherwise = False - -isQueryValid :: URI -> Bool -isQueryValid URI {uriQuery = ""} = True -isQueryValid _ = False - -isAuthorityValid :: URI -> Bool -isAuthorityValid URI {uriAuthority = a} - | isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a - | otherwise = False - -isUserInfoValid :: URIAuth -> Bool -isUserInfoValid URIAuth {uriUserInfo = ""} = True -isUserInfoValid _ = False + _ -> readPort $ T.unpack $ T.tail $ T.pack port' -isHostValid :: URIAuth -> Bool -isHostValid URIAuth {uriRegName = ""} = False -isHostValid _ = True +proxyUri :: AppConfig -> (Text, Text, Integer, Text) +proxyUri AppConfig{..} = + case pickProxy $ toS <$> configOpenApiServerProxyUri of + Just Proxy{..} -> + (proxyScheme, proxyHost, proxyPort, proxyPath) + Nothing -> + ("http", configServerHost, toInteger configServerPort, "/") -isPortValid :: URIAuth -> Bool -isPortValid URIAuth {uriPort = ""} = True -isPortValid URIAuth {uriPort = (':':p)} = - case readMaybe p of - Just i -> i > (0 :: Integer) && i < 65536 - Nothing -> False -isPortValid _ = False +openApiTableInfo :: DbStructure -> Table -> (Table, [Column], [Text]) +openApiTableInfo dbStructure table = + ( table + , tableCols dbStructure (tableSchema table) (tableName table) + , tablePKCols dbStructure (tableSchema table) (tableName table) + ) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs deleted file mode 100644 --- a/src/PostgREST/Parsers.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-| -Module : PostgREST.Parsers -Description : PostgREST parser combinators - -This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`. --} -module PostgREST.Parsers where - -import qualified Data.HashMap.Strict as M -import qualified Data.Set as S - -import Data.Either.Combinators (mapLeft) -import Data.Foldable (foldl1) -import Data.List (init, last) -import Data.Text (intercalate, replace, strip) -import Text.Read (read) - -import Data.Tree -import Text.Parsec.Error -import Text.ParserCombinators.Parsec hiding (many, (<|>)) - -import PostgREST.Error (ApiRequestError (ParseRequestError)) -import PostgREST.RangeQuery (NonnegRange) -import PostgREST.Types -import Protolude hiding (intercalate, option, replace, toS, - try) -import Protolude.Conv (toS) - -pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem] -pRequestSelect selStr = - mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) - -pRequestOnConflict :: Text -> Either ApiRequestError [FieldName] -pRequestOnConflict oncStr = - mapError $ parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr) - -pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) -pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper) - where - treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k - oper = parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v - path = fst <$> treePath - fld = snd <$> treePath - -pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm]) -pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord' - where - treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k - path = fst <$> treePath - ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v - -pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange) -pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v - where - treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k - path = fst <$> treePath - -pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree) -pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree - where - path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k - embedPath = fst <$> path - logicTree = do - op <- snd <$> path - -- Concat op and v to make pLogicTree argument regular, - -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" - parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v) - -pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName)) -pRequestColumns colStr = - case colStr of - Just str -> - mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str) - _ -> Right Nothing - -ws :: Parser Text -ws = toS <$> many (oneOf " \t") - -lexeme :: Parser a -> Parser a -lexeme p = ws *> p <* ws - -pTreePath :: Parser (EmbedPath, Field) -pTreePath = do - p <- pFieldName `sepBy1` pDelimiter - jp <- option [] pJsonPath - return (init p, (last p, jp)) - -pFieldForest :: Parser [Tree SelectItem] -pFieldForest = pFieldTree `sepBy1` lexeme (char ',') - where - pFieldTree :: Parser (Tree SelectItem) - pFieldTree = try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|> - Node <$> pFieldSelect <*> pure [] - -pStar :: Parser Text -pStar = toS <$> (string "*" $> ("*"::ByteString)) - -pFieldName :: Parser Text -pFieldName = - pQuotedValue <|> - intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) - "field name (* or [a..z0..9_])" - where - isDash :: GenParser Char st () - isDash = try ( char '-' >> notFollowedBy (char '>') ) - dash :: Parser Char - dash = isDash $> '-' - -pJsonPath :: Parser JsonPath -pJsonPath = many pJsonOperation - where - pJsonOperation :: Parser JsonOperation - pJsonOperation = pJsonArrow <*> pJsonOperand - - pJsonArrow = - try (string "->>" $> J2Arrow) <|> - try (string "->" $> JArrow) - - pJsonOperand = - let pJKey = JKey . toS <$> pFieldName - pJIdx = JIdx . toS <$> ((:) <$> option '+' (char '-') <*> many1 digit) <* pEnd - pEnd = try (void $ lookAhead (string "->")) <|> - try (void $ lookAhead (string "::")) <|> - try eof in - try pJIdx <|> try pJKey - -pField :: Parser Field -pField = lexeme $ (,) <$> pFieldName <*> option [] pJsonPath - -aliasSeparator :: Parser () -aliasSeparator = char ':' >> notFollowedBy (char ':') - -pRelationSelect :: Parser SelectItem -pRelationSelect = lexeme $ try ( do - alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) - fld <- pField - hint <- optionMaybe ( - try ( char '!' *> pFieldName) <|> - -- deprecated, remove in next major version - try ( char '.' *> pFieldName) - ) - return (fld, Nothing, alias, hint) - ) - -pFieldSelect :: Parser SelectItem -pFieldSelect = lexeme $ - try ( - do - alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) - fld <- pField - cast' <- optionMaybe (string "::" *> many letter) - return (fld, toS <$> cast', alias, Nothing) - ) - <|> do - s <- pStar - return ((s, []), Nothing, Nothing, Nothing) - -pOpExpr :: Parser SingleVal -> Parser OpExpr -pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation - where - pOperation :: Parser Operation - pOperation = - Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal - <|> In <$> (try (string "in" *> pDelimiter) *> pListVal) - <|> pFts - "operator (eq, gt, ...)" - - pFts = do - op <- foldl1 (<|>) (try . string . toS <$> ftsOps) - lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_"))) - pDelimiter >> Fts (toS op) (toS <$> lang) <$> pSVal - - ops = M.filterWithKey (const . flip notElem ("in":ftsOps)) operators - ftsOps = M.keys ftsOperators - -pSingleVal :: Parser SingleVal -pSingleVal = toS <$> many anyChar - -pListVal :: Parser ListVal -pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')') - -pListElement :: Parser Text -pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)")) - -pQuotedValue :: Parser Text -pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"') - -pDelimiter :: Parser Char -pDelimiter = char '.' "delimiter (.)" - -pOrder :: Parser [OrderTerm] -pOrder = lexeme pOrderTerm `sepBy1` char ',' - -pOrderTerm :: Parser OrderTerm -pOrderTerm = do - fld <- pField - dir <- optionMaybe $ - try (pDelimiter *> string "asc" $> OrderAsc) <|> - try (pDelimiter *> string "desc" $> OrderDesc) - nls <- optionMaybe pNulls <* pEnd <|> - pEnd $> Nothing - return $ OrderTerm fld dir nls - where - pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|> - try (pDelimiter *> string "nullslast" $> OrderNullsLast) - pEnd = try (void $ lookAhead (char ',')) <|> - try eof - -pLogicTree :: Parser LogicTree -pLogicTree = Stmnt <$> try pLogicFilter - <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')')) - where - pLogicFilter :: Parser Filter - pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal - pNot :: Parser Bool - pNot = try (string "not" *> pDelimiter $> True) - <|> pure False - "negation operator (not)" - pLogicOp :: Parser LogicOperator - pLogicOp = try (string "and" $> And) - <|> string "or" $> Or - "logic operator (and, or)" - -pLogicSingleVal :: Parser SingleVal -pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)")) - where - pPgArray :: Parser Text - pPgArray = do - a <- string "{" - b <- many (noneOf "{}") - c <- string "}" - toS <$> pure (a ++ b ++ c) - -pLogicPath :: Parser (EmbedPath, Text) -pLogicPath = do - path <- pFieldName `sepBy1` pDelimiter - let op = last path - notOp = "not." <> op - return (filter (/= "not") (init path), if "not" `elem` path then notOp else op) - -pColumns :: Parser [FieldName] -pColumns = pFieldName `sepBy1` lexeme (char ',') - -mapError :: Either ParseError a -> Either ApiRequestError a -mapError = mapLeft translateError - where - translateError e = - ParseRequestError message details - where - message = show $ errorPos e - details = strip $ replace "\n" " " $ toS - $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) - --- Used for the config value "role-claim-key" -pRoleClaimKey :: Text -> Either ApiRequestError JSPath -pRoleClaimKey selStr = - mapError $ parse pJSPath ("failed to parse role-claim-key value (" <> toS selStr <> ")") (toS selStr) - -pJSPath :: Parser JSPath -pJSPath = toJSPath <$> (period *> pPath `sepBy` period <* eof) - where - toJSPath :: [(Text, Maybe Int)] -> JSPath - toJSPath = concatMap (\(key, idx) -> JSPKey key : maybeToList (JSPIdx <$> idx)) - period = char '.' "period (.)" - pPath :: Parser (Text, Maybe Int) - pPath = (,) <$> pJSPKey <*> optionMaybe pJSPIdx - -pJSPKey :: Parser Text -pJSPKey = toS <$> many1 (alphaNum <|> oneOf "_$@") <|> pQuotedValue "attribute name [a..z0..9_$@])" - -pJSPIdx :: Parser Int -pJSPIdx = char '[' *> (read <$> many1 digit) <* char ']' "array index [0..n]" diff --git a/src/PostgREST/Private/Common.hs b/src/PostgREST/Private/Common.hs deleted file mode 100644 --- a/src/PostgREST/Private/Common.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-| -Module : PostgREST.Common -Description : Common helper functions. --} -module PostgREST.Private.Common where - -import Data.Maybe -import qualified Hasql.Decoders as HD -import qualified Hasql.Encoders as HE -import Protolude - -column :: HD.Value a -> HD.Row a -column = HD.column . HD.nonNullable - -nullableColumn :: HD.Value a -> HD.Row (Maybe a) -nullableColumn = HD.column . HD.nullable - -element :: HD.Value a -> HD.Array a -element = HD.element . HD.nonNullable - -param :: HE.Value a -> HE.Params a -param = HE.param . HE.nonNullable - -arrayParam :: HE.Value a -> HE.Params [a] -arrayParam = param . HE.array . HE.dimension foldl' . HE.element . HE.nonNullable diff --git a/src/PostgREST/Private/QueryFragment.hs b/src/PostgREST/Private/QueryFragment.hs deleted file mode 100644 --- a/src/PostgREST/Private/QueryFragment.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-| -Module : PostgREST.Private.QueryFragment -Description : Helper functions for PostgREST.QueryBuilder. - -Any function that outputs a SqlFragment should be in this module. --} -module PostgREST.Private.QueryFragment where - -import qualified Data.HashMap.Strict as HM -import Data.Maybe -import Data.Text (intercalate, - isInfixOf, replace, - toLower) -import qualified Data.Text as T (map, null, - takeWhile) -import PostgREST.Types -import Protolude hiding (cast, - intercalate, replace, - toLower) -import Text.InterpolatedString.Perl6 (qc) - -noLocationF :: SqlFragment -noLocationF = "array[]::text[]" - --- Due to the use of the `unknown` encoder we need to cast '$1' when the value is not used in the main query --- otherwise the query will err with a `could not determine data type of parameter $1`. --- This happens because `unknown` relies on the context to determine the value type. --- The error also happens on raw libpq used with C. -ignoredBody :: SqlFragment -ignoredBody = "pgrst_ignored_body AS (SELECT $1::text) " - --- | --- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads --- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays --- We do this in SQL to avoid processing the JSON in application code -normalizedBody :: SqlFragment -normalizedBody = - unwords [ - "pgrst_payload AS (SELECT $1::json AS json_data),", - "pgrst_body AS (", - "SELECT", - "CASE WHEN json_typeof(json_data) = 'array'", - "THEN json_data", - "ELSE json_build_array(json_data)", - "END AS val", - "FROM pgrst_payload)"] - -selectBody :: SqlFragment -selectBody = "(SELECT val FROM pgrst_body)" - -pgFmtLit :: SqlFragment -> SqlFragment -pgFmtLit x = - let trimmed = trimNullChars x - escaped = "'" <> replace "'" "''" trimmed <> "'" - slashed = replace "\\" "\\\\" escaped in - if "\\" `isInfixOf` escaped - then "E" <> slashed - else slashed - -pgFmtIdent :: SqlFragment -> SqlFragment -pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\"" - -asCsvF :: SqlFragment -asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF - where - asCsvHeaderF = - "(SELECT coalesce(string_agg(a.k, ','), '')" <> - " FROM (" <> - " SELECT json_object_keys(r)::TEXT as k" <> - " FROM ( " <> - " SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <> - " ) s" <> - " ) a" <> - ")" - asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')" - -asJsonF :: SqlFragment -asJsonF = "coalesce(json_agg(_postgrest_t), '[]')::character varying" - -asJsonSingleF :: SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element -asJsonSingleF = "coalesce(string_agg(row_to_json(_postgrest_t)::text, ','), '')::character varying " - -asBinaryF :: FieldName -> SqlFragment -asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')" - -locationF :: [Text] -> SqlFragment -locationF pKeys = [qc|( - WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1) - SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null')) - FROM data CROSS JOIN json_each_text(data.row) AS json_data - {("WHERE json_data.key IN ('" <> intercalate "','" pKeys <> "')") `emptyOnFalse` null pKeys} -)|] - -fromQi :: QualifiedIdentifier -> SqlFragment -fromQi t = (if s == "" then "" else pgFmtIdent s <> ".") <> pgFmtIdent n - where - n = qiName t - s = qiSchema t - -emptyOnFalse :: Text -> Bool -> Text -emptyOnFalse val cond = if cond then "" else val - -pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment -pgFmtColumn table "*" = fromQi table <> ".*" -pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c - -pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment -pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp - -pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> SqlFragment -pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> pgFmtAs fName jp alias -pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs fName jp alias - -pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> SqlFragment -pgFmtOrderTerm qi ot = unwords [ - toS . pgFmtField qi $ otTerm ot, - maybe "" show $ otDirection ot, - maybe "" show $ otNullOrder ot] - -pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment -pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of - Op op val -> pgFmtFieldOp op <> " " <> case op of - "like" -> unknownLiteral (T.map star val) - "ilike" -> unknownLiteral (T.map star val) - "is" -> whiteList val - _ -> unknownLiteral val - - In vals -> pgFmtField table fld <> " " <> - let emptyValForIn = "= any('{}') " in -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')" - case (&&) (length vals == 1) . T.null <$> headMay vals of - Just False -> sqlOperator "in" <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") " - Just True -> emptyValForIn - Nothing -> emptyValForIn - - Fts op lang val -> - pgFmtFieldOp op - <> "(" - <> maybe "" ((<> ", ") . pgFmtLit) lang - <> unknownLiteral val - <> ") " - where - pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op - sqlOperator o = HM.lookupDefault "=" o operators - notOp = if hasNot then "NOT" else "" - star c = if c == '*' then '%' else c - unknownLiteral = (<> "::unknown ") . pgFmtLit - whiteList :: Text -> SqlFragment - whiteList v = fromMaybe - (toS (pgFmtLit v) <> "::unknown ") - (find ((==) . toLower $ v) ["null","true","false"]) - -pgFmtJoinCondition :: JoinCondition -> SqlFragment -pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) = - pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2 - -pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment -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 - -pgFmtJsonPath :: JsonPath -> SqlFragment -pgFmtJsonPath = \case - [] -> "" - (JArrow x:xs) -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs - (J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs - where - pgFmtJsonOperand (JKey k) = pgFmtLit k - pgFmtJsonOperand (JIdx i) = pgFmtLit i <> "::int" - -pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment -pgFmtAs _ [] Nothing = "" -pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of - Just (JKey key) -> " AS " <> pgFmtIdent key - Just (JIdx _) -> " AS " <> pgFmtIdent (fromMaybe fName lastKey) - -- We get the lastKey because on: - -- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ] - -- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ] - where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp) - Nothing -> "" -pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias - -trimNullChars :: Text -> Text -trimNullChars = T.takeWhile (/= '\x0') - -countF :: SqlQuery -> Bool -> (SqlFragment, SqlFragment) -countF countQuery shouldCount = - if shouldCount - then ( - ", pgrst_source_count AS (" <> countQuery <> ")" - , "(SELECT pg_catalog.count(*) FROM pgrst_source_count)" ) - else ( - mempty - , "null::bigint") - -returningF :: QualifiedIdentifier -> [FieldName] -> SqlFragment -returningF qi returnings = - if null returnings - then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified - else "RETURNING " <> intercalate ", " (pgFmtColumn qi <$> returnings) - -responseHeadersF :: PgVersion -> SqlFragment -responseHeadersF pgVer = - if pgVer >= pgVersion96 - then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15 - else "'[]'" :: Text diff --git a/src/PostgREST/Query/QueryBuilder.hs b/src/PostgREST/Query/QueryBuilder.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Query/QueryBuilder.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-| +Module : PostgREST.Query.QueryBuilder +Description : PostgREST SQL queries generating functions. + +This module provides functions to consume data types that +represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment +to produce SqlQuery type outputs. +-} +module PostgREST.Query.QueryBuilder + ( readRequestToQuery + , mutateRequestToQuery + , readRequestToCountQuery + , requestToCallProcQuery + , limitedQuery + ) where + +import qualified Data.ByteString.Char8 as BS +import qualified Data.Set as S +import qualified Hasql.DynamicStatements.Snippet as H + +import Data.Tree (Tree (..)) + +import PostgREST.DbStructure.Identifiers (FieldName, + QualifiedIdentifier (..)) +import PostgREST.DbStructure.Proc (PgArg (..)) +import PostgREST.DbStructure.Relationship (Cardinality (..), + Relationship (..)) +import PostgREST.DbStructure.Table (Table (..)) +import PostgREST.Request.ApiRequest (PayloadJSON (..)) +import PostgREST.Request.Preferences (PreferParameters (..), + PreferResolution (..)) + +import PostgREST.Query.SqlFragment +import PostgREST.Request.Types + +import Protolude + +readRequestToQuery :: ReadRequest -> H.Snippet +readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) = + "SELECT " <> + intercalateSnippet ", " ((pgFmtSelectItem qi <$> colSelects) ++ selects) <> + "FROM " <> H.sql (BS.intercalate ", " (tabl : implJs)) <> " " <> + intercalateSnippet " " joins <> " " <> + (if null logicForest && null joinConditions_ then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_)) + <> " " <> + (if null ordts then mempty else "ORDER BY " <> intercalateSnippet ", " (map (pgFmtOrderTerm qi) ordts)) <> " " <> + limitOffsetF range + where + implJs = fromQi <$> implJoins + tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias + qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias + (joins, selects) = foldr getJoinsSelects ([],[]) forest + +getJoinsSelects :: ReadRequest -> ([H.Snippet], [H.Snippet]) -> ([H.Snippet], [H.Snippet]) +getJoinsSelects rr@(Node (_, (name, Just Relationship{relCardinality=card,relTable=Table{tableName=table}}, alias, _, _)) _) (j,s) = + let subquery = readRequestToQuery rr in + case card of + M2O _ -> + let aliasOrName = fromMaybe name alias + localTableName = pgFmtIdent $ table <> "_" <> aliasOrName + sel = H.sql ("row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName) + joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> H.sql localTableName <> " ON TRUE " in + (joi:j,sel:s) + _ -> + let sel = "COALESCE ((" + <> "SELECT json_agg(" <> H.sql (pgFmtIdent table) <> ".*) " + <> "FROM (" <> subquery <> ") " <> H.sql (pgFmtIdent table) <> " " + <> "), '[]') AS " <> H.sql (pgFmtIdent (fromMaybe name alias)) in + (j,sel:s) +getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], []) + +mutateRequestToQuery :: MutateRequest -> H.Snippet +mutateRequestToQuery (Insert mainQi iCols body onConflct putConditions returnings) = + "WITH " <> normalizedBody body <> " " <> + "INSERT INTO " <> H.sql (fromQi mainQi) <> H.sql (if S.null iCols then " " else "(" <> cols <> ") ") <> + "SELECT " <> H.sql cols <> " " <> + H.sql ("FROM json_populate_recordset (null::" <> fromQi mainQi <> ", " <> selectBody <> ") _ ") <> + -- Only used for PUT + (if null putConditions then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) <> + H.sql (BS.unwords [ + maybe "" (\(oncDo, oncCols) -> + if null oncCols then + mempty + else + "ON CONFLICT(" <> BS.intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of + IgnoreDuplicates -> + "DO NOTHING" + MergeDuplicates -> + if S.null iCols + then "DO NOTHING" + else "DO UPDATE SET " <> BS.intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols) + ) onConflct, + returningF mainQi returnings + ]) + where + cols = BS.intercalate ", " $ pgFmtIdent <$> S.toList iCols +mutateRequestToQuery (Update mainQi uCols body logicForest returnings) = + if S.null uCols + -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax + -- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select= + -- the select has to be based on "returnings" to make computed overloaded functions not throw + then H.sql ("SELECT " <> emptyBodyReturnedColumns <> " FROM " <> fromQi mainQi <> " WHERE false") + else + "WITH " <> normalizedBody body <> " " <> + "UPDATE " <> H.sql (fromQi mainQi) <> " SET " <> H.sql cols <> " " <> + "FROM (SELECT * FROM json_populate_recordset (null::" <> H.sql (fromQi mainQi) <> " , " <> H.sql selectBody <> " )) _ " <> + (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)) <> " " <> + H.sql (returningF mainQi returnings) + where + cols = BS.intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols) + emptyBodyReturnedColumns :: SqlFragment + emptyBodyReturnedColumns + | null returnings = "NULL" + | otherwise = BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings) +mutateRequestToQuery (Delete mainQi logicForest returnings) = + "DELETE FROM " <> H.sql (fromQi mainQi) <> " " <> + (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree mainQi) logicForest)) <> " " <> + H.sql (returningF mainQi returnings) + +requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Maybe PayloadJSON -> Bool -> Maybe PreferParameters -> [FieldName] -> H.Snippet +requestToCallProcQuery qi pgArgs pj returnsScalar preferParams returnings = + argsCTE <> sourceBody + where + body = pjRaw <$> pj + paramsAsSingleObject = preferParams == Just SingleObject + paramsAsMultipleObjects = preferParams == Just MultipleObjects + + (argsCTE, args) + | null pgArgs = (mempty, mempty) + | paramsAsSingleObject = ("WITH pgrst_args AS (SELECT NULL)", jsonPlaceHolder body) + | otherwise = ( + "WITH " <> normalizedBody body <> ", " <> + H.sql ( + BS.unwords [ + "pgrst_args AS (", + "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (const mempty) (\a -> " " <> encodeUtf8 (pgaType a)) <> ")", + ")"]) + , H.sql $ if paramsAsMultipleObjects + then fmtArgs varadicPrefix (\a -> " := pgrst_args." <> pgFmtIdent (pgaName a)) + else fmtArgs varadicPrefix (\a -> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM pgrst_args LIMIT 1)") + ) + + fmtArgs :: (PgArg -> SqlFragment) -> (PgArg -> SqlFragment) -> SqlFragment + fmtArgs argFragPre argFragSuf = BS.intercalate ", " ((\a -> argFragPre a <> pgFmtIdent (pgaName a) <> argFragSuf a) <$> pgArgs) + + varadicPrefix :: PgArg -> SqlFragment + varadicPrefix a = if pgaVar a then "VARIADIC " else mempty + + sourceBody :: H.Snippet + sourceBody + | paramsAsMultipleObjects = + if returnsScalar + then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args" + else "SELECT pgrst_lat_args.* FROM pgrst_args, " <> + "LATERAL ( SELECT " <> returnedColumns <> " FROM " <> callIt <> " ) pgrst_lat_args" + | otherwise = + if returnsScalar + then "SELECT " <> callIt <> " AS pgrst_scalar" + else "SELECT " <> returnedColumns <> " FROM " <> callIt + + callIt :: H.Snippet + callIt = H.sql (fromQi qi) <> "(" <> args <> ")" + + returnedColumns :: H.Snippet + returnedColumns + | null returnings = "*" + | otherwise = H.sql $ BS.intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings) + + +-- | SQL query meant for COUNTing the root node of the Tree. +-- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT. +-- SELECT 1 is done instead of SELECT * to prevent doing expensive operations(like functions based on the columns) +-- inside the FROM target. +readRequestToCountQuery :: ReadRequest -> H.Snippet +readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) = + "SELECT 1 " <> "FROM " <> H.sql (fromQi qi) <> " " <> + if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree qi) logicForest) + +limitedQuery :: H.Snippet -> Maybe Integer -> H.Snippet +limitedQuery query maxRows = query <> H.sql (maybe mempty (\x -> " LIMIT " <> BS.pack (show x)) maxRows) diff --git a/src/PostgREST/Query/SqlFragment.hs b/src/PostgREST/Query/SqlFragment.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Query/SqlFragment.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-| +Module : PostgREST.Query.SqlFragment +Description : Helper functions for PostgREST.QueryBuilder. + +Any function that outputs a SqlFragment should be in this module. +-} +module PostgREST.Query.SqlFragment + ( noLocationF + , SqlFragment + , asBinaryF + , asCsvF + , asJsonF + , asJsonSingleF + , countF + , fromQi + , ftsOperators + , jsonPlaceHolder + , limitOffsetF + , locationF + , normalizedBody + , operators + , pgFmtColumn + , pgFmtIdent + , pgFmtJoinCondition + , pgFmtLogicTree + , pgFmtOrderTerm + , pgFmtSelectItem + , responseHeadersF + , responseStatusF + , returningF + , selectBody + , sourceCTEName + , unknownEncoder + , intercalateSnippet + ) where + +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Hasql.DynamicStatements.Snippet as H +import qualified Hasql.Encoders as HE + +import Data.Foldable (foldr1) +import Text.InterpolatedString.Perl6 (qc) + +import PostgREST.Config.PgVersion (PgVersion, pgVersion96) +import PostgREST.DbStructure.Identifiers (FieldName, + QualifiedIdentifier (..)) +import PostgREST.RangeQuery (NonnegRange, allRange, + rangeLimit, rangeOffset) +import PostgREST.Request.Types (Alias, Field, Filter (..), + JoinCondition (..), + JsonOperand (..), + JsonOperation (..), + JsonPath, LogicTree (..), + OpExpr (..), Operation (..), + OrderTerm (..), SelectItem) + +import Protolude hiding (cast, toS) +import Protolude.Conv (toS) + + +-- | A part of a SQL query that cannot be executed independently +type SqlFragment = ByteString + +noLocationF :: SqlFragment +noLocationF = "array[]::text[]" + +sourceCTEName :: SqlFragment +sourceCTEName = "pgrst_source" + +operators :: HM.HashMap Text SqlFragment +operators = HM.union (HM.fromList [ + ("eq", "="), + ("gte", ">="), + ("gt", ">"), + ("lte", "<="), + ("lt", "<"), + ("neq", "<>"), + ("like", "LIKE"), + ("ilike", "ILIKE"), + ("in", "IN"), + ("is", "IS"), + ("cs", "@>"), + ("cd", "<@"), + ("ov", "&&"), + ("sl", "<<"), + ("sr", ">>"), + ("nxr", "&<"), + ("nxl", "&>"), + ("adj", "-|-")]) ftsOperators + +ftsOperators :: HM.HashMap Text SqlFragment +ftsOperators = HM.fromList [ + ("fts", "@@ to_tsquery"), + ("plfts", "@@ plainto_tsquery"), + ("phfts", "@@ phraseto_tsquery"), + ("wfts", "@@ websearch_to_tsquery") + ] + +-- | +-- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads +-- Otherwise we'd have to use json_populate_record for json objects and json_populate_recordset for json arrays +-- We do this in SQL to avoid processing the JSON in application code +normalizedBody :: Maybe BL.ByteString -> H.Snippet +normalizedBody body = + "pgrst_payload AS (SELECT " <> jsonPlaceHolder body <> " AS json_data), " <> + H.sql (BS.unwords [ + "pgrst_body AS (", + "SELECT", + "CASE WHEN json_typeof(json_data) = 'array'", + "THEN json_data", + "ELSE json_build_array(json_data)", + "END AS val", + "FROM pgrst_payload)"]) + +-- | Equivalent to "$1::json" +-- | TODO: At this stage there shouldn't be a Maybe since ApiRequest should ensure that an INSERT/UPDATE has a body +jsonPlaceHolder :: Maybe BL.ByteString -> H.Snippet +jsonPlaceHolder body = + H.encoderAndParam (HE.nullable HE.unknown) (toS <$> body) <> "::json" + +selectBody :: SqlFragment +selectBody = "(SELECT val FROM pgrst_body)" + +pgFmtLit :: Text -> SqlFragment +pgFmtLit x = + let trimmed = trimNullChars x + escaped = "'" <> T.replace "'" "''" trimmed <> "'" + slashed = T.replace "\\" "\\\\" escaped in + encodeUtf8 $ if "\\" `T.isInfixOf` escaped + then "E" <> slashed + else slashed + +-- TODO: refactor by following https://github.com/PostgREST/postgrest/pull/1631#issuecomment-711070833 +pgFmtIdent :: Text -> SqlFragment +pgFmtIdent x = encodeUtf8 $ "\"" <> T.replace "\"" "\"\"" (trimNullChars x) <> "\"" + +trimNullChars :: Text -> Text +trimNullChars = T.takeWhile (/= '\x0') + +asCsvF :: SqlFragment +asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF + where + asCsvHeaderF = + "(SELECT coalesce(string_agg(a.k, ','), '')" <> + " FROM (" <> + " SELECT json_object_keys(r)::text as k" <> + " FROM ( " <> + " SELECT row_to_json(hh) as r from " <> sourceCTEName <> " as hh limit 1" <> + " ) s" <> + " ) a" <> + ")" + asCsvBodyF = "coalesce(string_agg(substring(_postgrest_t::text, 2, length(_postgrest_t::text) - 2), '\n'), '')" + +asJsonF :: Bool -> SqlFragment +asJsonF returnsScalar + | returnsScalar = "coalesce(json_agg(_postgrest_t.pgrst_scalar), '[]')::character varying" + | otherwise = "coalesce(json_agg(_postgrest_t), '[]')::character varying" + +asJsonSingleF :: Bool -> SqlFragment --TODO! unsafe when the query actually returns multiple rows, used only on inserting and returning single element +asJsonSingleF returnsScalar + | returnsScalar = "coalesce(string_agg(to_json(_postgrest_t.pgrst_scalar)::text, ','), 'null')::character varying" + | otherwise = "coalesce(string_agg(to_json(_postgrest_t)::text, ','), '')::character varying" + +asBinaryF :: FieldName -> SqlFragment +asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')" + +locationF :: [Text] -> SqlFragment +locationF pKeys = [qc|( + WITH data AS (SELECT row_to_json(_) AS row FROM {sourceCTEName} AS _ LIMIT 1) + SELECT array_agg(json_data.key || '=' || coalesce('eq.' || json_data.value, 'is.null')) + FROM data CROSS JOIN json_each_text(data.row) AS json_data + WHERE json_data.key IN ('{fmtPKeys}') +)|] + where + fmtPKeys = T.intercalate "','" pKeys + +fromQi :: QualifiedIdentifier -> SqlFragment +fromQi t = (if T.null s then mempty else pgFmtIdent s <> ".") <> pgFmtIdent n + where + n = qiName t + s = qiSchema t + +pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment +pgFmtColumn table "*" = fromQi table <> ".*" +pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c + +pgFmtField :: QualifiedIdentifier -> Field -> H.Snippet +pgFmtField table (c, jp) = H.sql (pgFmtColumn table c) <> pgFmtJsonPath jp + +pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> H.Snippet +pgFmtSelectItem table (f@(fName, jp), Nothing, alias, _) = pgFmtField table f <> H.sql (pgFmtAs fName jp alias) +-- Ideally we'd quote the cast with "pgFmtIdent cast". However, that would invalidate common casts such as "int", "bigint", etc. +-- Try doing: `select 1::"bigint"` - it'll err, using "int8" will work though. There's some parser magic that pg does that's invalidated when quoting. +-- Not quoting should be fine, we validate the input on Parsers. +pgFmtSelectItem table (f@(fName, jp), Just cast, alias, _) = "CAST (" <> pgFmtField table f <> " AS " <> H.sql (encodeUtf8 cast) <> " )" <> H.sql (pgFmtAs fName jp alias) + +pgFmtOrderTerm :: QualifiedIdentifier -> OrderTerm -> H.Snippet +pgFmtOrderTerm qi ot = + pgFmtField qi (otTerm ot) <> " " <> + H.sql (BS.unwords [ + BS.pack $ maybe mempty show $ otDirection ot, + BS.pack $ maybe mempty show $ otNullOrder ot]) + +pgFmtFilter :: QualifiedIdentifier -> Filter -> H.Snippet +pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper of + Op op val -> pgFmtFieldOp op <> " " <> case op of + "like" -> unknownLiteral (T.map star val) + "ilike" -> unknownLiteral (T.map star val) + "is" -> isAllowed val + _ -> unknownLiteral val + + -- We don't use "IN", we use "= ANY". IN has the following disadvantages: + -- + No way to use an empty value on IN: "col IN ()" is invalid syntax. With ANY we can do "= ANY('{}')" + -- + Can invalidate prepared statements: multiple parameters on an IN($1, $2, $3) will lead to using different prepared statements and not take advantage of caching. + In vals -> pgFmtField table fld <> " " <> + case vals of + [""] -> "= ANY('{}') " + -- Here we build the pg array, e.g '{"Hebdon, John","Other","Another"}', manually. We quote the values to prevent the "," being treated as an element separator. + -- TODO: Ideally this would be done on Hasql with an encoder, but the "array unknown" is not working(Hasql doesn't pass any value). + _ -> "= ANY (" <> unknownLiteral ("{" <> T.intercalate "," ((\x -> "\"" <> x <> "\"") <$> vals) <> "}") <> ")" + + Fts op lang val -> + pgFmtFieldOp op <> "(" <> ftsLang lang <> unknownLiteral val <> ") " + where + ftsLang = maybe mempty (\l -> unknownLiteral l <> ", ") + pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op + sqlOperator o = H.sql $ HM.lookupDefault "=" o operators + notOp = if hasNot then "NOT" else mempty + star c = if c == '*' then '%' else c + -- IS cannot be prepared. `PREPARE boolplan AS SELECT * FROM projects where id IS $1` will give a syntax error. + -- The above can be fixed by using `PREPARE boolplan AS SELECT * FROM projects where id IS NOT DISTINCT FROM $1;` + -- However that would not accept the TRUE/FALSE/NULL keywords. See: https://stackoverflow.com/questions/6133525/proper-way-to-set-preparedstatement-parameter-to-null-under-postgres. + isAllowed :: Text -> H.Snippet + isAllowed v = H.sql $ maybe + (pgFmtLit v <> "::unknown") encodeUtf8 + (find ((==) . T.toLower $ v) ["null","true","false"]) + +pgFmtJoinCondition :: JoinCondition -> H.Snippet +pgFmtJoinCondition (JoinCondition (qi1, col1) (qi2, col2)) = + H.sql $ pgFmtColumn qi1 col1 <> " = " <> pgFmtColumn qi2 col2 + +pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> H.Snippet +pgFmtLogicTree qi (Expr hasNot op forest) = H.sql notOp <> " (" <> intercalateSnippet (" " <> BS.pack (show op) <> " ") (pgFmtLogicTree qi <$> forest) <> ")" + where notOp = if hasNot then "NOT" else mempty +pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt + +pgFmtJsonPath :: JsonPath -> H.Snippet +pgFmtJsonPath = \case + [] -> mempty + (JArrow x:xs) -> "->" <> pgFmtJsonOperand x <> pgFmtJsonPath xs + (J2Arrow x:xs) -> "->>" <> pgFmtJsonOperand x <> pgFmtJsonPath xs + where + pgFmtJsonOperand (JKey k) = unknownLiteral k + pgFmtJsonOperand (JIdx i) = unknownLiteral i <> "::int" + +pgFmtAs :: FieldName -> JsonPath -> Maybe Alias -> SqlFragment +pgFmtAs _ [] Nothing = mempty +pgFmtAs fName jp Nothing = case jOp <$> lastMay jp of + Just (JKey key) -> " AS " <> pgFmtIdent key + Just (JIdx _) -> " AS " <> pgFmtIdent (fromMaybe fName lastKey) + -- We get the lastKey because on: + -- `select=data->1->mycol->>2`, we need to show the result as [ {"mycol": ..}, {"mycol": ..} ] + -- `select=data->3`, we need to show the result as [ {"data": ..}, {"data": ..} ] + where lastKey = jVal <$> find (\case JKey{} -> True; _ -> False) (jOp <$> reverse jp) + Nothing -> mempty +pgFmtAs _ _ (Just alias) = " AS " <> pgFmtIdent alias + +countF :: H.Snippet -> Bool -> (H.Snippet, SqlFragment) +countF countQuery shouldCount = + if shouldCount + then ( + ", pgrst_source_count AS (" <> countQuery <> ")" + , "(SELECT pg_catalog.count(*) FROM pgrst_source_count)" ) + else ( + mempty + , "null::bigint") + +returningF :: QualifiedIdentifier -> [FieldName] -> SqlFragment +returningF qi returnings = + if null returnings + then "RETURNING 1" -- For mutation cases where there's no ?select, we return 1 to know how many rows were modified + else "RETURNING " <> BS.intercalate ", " (pgFmtColumn qi <$> returnings) + +limitOffsetF :: NonnegRange -> H.Snippet +limitOffsetF range = + if range == allRange then mempty else "LIMIT " <> limit <> " OFFSET " <> offset + where + limit = maybe "ALL" (\l -> unknownEncoder (BS.pack $ show l)) $ rangeLimit range + offset = unknownEncoder (BS.pack . show $ rangeOffset range) + +responseHeadersF :: PgVersion -> SqlFragment +responseHeadersF pgVer = + if pgVer >= pgVersion96 + then currentSettingF "response.headers" + else "null" + +responseStatusF :: PgVersion -> SqlFragment +responseStatusF pgVer = + if pgVer >= pgVersion96 + then currentSettingF "response.status" + else "null" + +currentSettingF :: Text -> SqlFragment +currentSettingF setting = + -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15 + "nullif(current_setting(" <> pgFmtLit setting <> ", true), '')" + +-- Hasql Snippet utilities +unknownEncoder :: ByteString -> H.Snippet +unknownEncoder = H.encoderAndParam (HE.nonNullable HE.unknown) + +unknownLiteral :: Text -> H.Snippet +unknownLiteral = unknownEncoder . encodeUtf8 + +intercalateSnippet :: ByteString -> [H.Snippet] -> H.Snippet +intercalateSnippet _ [] = mempty +intercalateSnippet frag snippets = foldr1 (\a b -> a <> H.sql frag <> b) snippets diff --git a/src/PostgREST/Query/Statements.hs b/src/PostgREST/Query/Statements.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Query/Statements.hs @@ -0,0 +1,204 @@ +{-| +Module : PostgREST.Query.Statements +Description : PostgREST single SQL statements. + +This module constructs single SQL statements that can be parametrized and prepared. + +- It consumes the SqlQuery types generated by the QueryBuilder module. +- It generates the body format and some headers of the final HTTP response. + +TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718. +-} +module PostgREST.Query.Statements + ( createWriteStatement + , createReadStatement + , callProcStatement + , createExplainStatement + ) where + +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Lens as L +import qualified Data.ByteString.Char8 as BS +import qualified Hasql.Decoders as HD +import qualified Hasql.DynamicStatements.Snippet as H +import qualified Hasql.DynamicStatements.Statement as H +import qualified Hasql.Statement as H + +import Control.Lens ((^?)) +import Data.Maybe (fromJust) +import Data.Text.Read (decimal) +import Network.HTTP.Types.Status (Status) + +import PostgREST.Config.PgVersion (PgVersion) +import PostgREST.Error (Error (..)) +import PostgREST.GucHeader (GucHeader) + +import PostgREST.DbStructure.Identifiers (FieldName) +import PostgREST.Query.SqlFragment +import PostgREST.Request.Preferences + +import Protolude hiding (toS) +import Protolude.Conv (toS) + +{-| The generic query result format used by API responses. The location header + is represented as a list of strings containing variable bindings like + @"k1=eq.42"@, or the empty list if there is no location header. +-} +type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString, Either Error [GucHeader], Either Error (Maybe Status)) + +createWriteStatement :: H.Snippet -> H.Snippet -> Bool -> Bool -> Bool -> + PreferRepresentation -> [Text] -> PgVersion -> Bool -> + H.Statement () ResultsWithCount +createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer = + H.dynamicallyParameterized snippet decodeStandard + where + snippet = + "WITH " <> H.sql sourceCTEName <> " AS (" <> mutateQuery <> ") " <> + H.sql ( + "SELECT " <> + "'' AS total_result_set, " <> + "pg_catalog.count(_postgrest_t) AS page_total, " <> + locF <> " AS header, " <> + bodyF <> " AS body, " <> + responseHeadersF pgVer <> " AS response_headers, " <> + responseStatusF pgVer <> " AS response_status " + ) <> + "FROM (" <> selectF <> ") _postgrest_t" + + locF = + if isInsert && rep `elem` [Full, HeadersOnly] + then BS.unwords [ + "CASE WHEN pg_catalog.count(_postgrest_t) = 1", + "THEN coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")", + "ELSE " <> noLocationF, + "END"] + else noLocationF + + bodyF + | rep `elem` [None, HeadersOnly] = "''" + | asCsv = asCsvF + | wantSingle = asJsonSingleF False + | otherwise = asJsonF False + + selectF + -- prevent using any of the column names in ?select= when no response is returned from the CTE + | rep `elem` [None, HeadersOnly] = H.sql ("SELECT * FROM " <> sourceCTEName) + | otherwise = selectQuery + + decodeStandard :: HD.Result ResultsWithCount + decodeStandard = + fromMaybe (Nothing, 0, [], mempty, Right [], Right Nothing) <$> HD.rowMaybe standardRow + +createReadStatement :: H.Snippet -> H.Snippet -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> Bool -> + H.Statement () ResultsWithCount +createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField pgVer = + H.dynamicallyParameterized snippet decodeStandard + where + snippet = + "WITH " <> + H.sql sourceCTEName <> " AS ( " <> selectQuery <> " ) " <> + countCTEF <> " " <> + H.sql ("SELECT " <> + countResultF <> " AS total_result_set, " <> + "pg_catalog.count(_postgrest_t) AS page_total, " <> + noLocationF <> " AS header, " <> + bodyF <> " AS body, " <> + responseHeadersF pgVer <> " AS response_headers, " <> + responseStatusF pgVer <> " AS response_status " <> + "FROM ( SELECT * FROM " <> sourceCTEName <> " ) _postgrest_t") + + (countCTEF, countResultF) = countF countQuery countTotal + + bodyF + | asCsv = asCsvF + | isSingle = asJsonSingleF False + | isJust binaryField = asBinaryF $ fromJust binaryField + | otherwise = asJsonF False + + decodeStandard :: HD.Result ResultsWithCount + decodeStandard = + HD.singleRow standardRow + +{-| Read and Write api requests use a similar response format which includes + various record counts and possible location header. This is the decoder + for that common type of query. +-} +standardRow :: HD.Row ResultsWithCount +standardRow = (,,,,,) <$> nullableColumn HD.int8 <*> column HD.int8 + <*> arrayColumn HD.bytea <*> column HD.bytea + <*> (fromMaybe (Right []) <$> nullableColumn decodeGucHeaders) + <*> (fromMaybe (Right Nothing) <$> nullableColumn decodeGucStatus) + +type ProcResults = (Maybe Int64, Int64, ByteString, Either Error [GucHeader], Either Error (Maybe Status)) + +callProcStatement :: Bool -> Bool -> H.Snippet -> H.Snippet -> H.Snippet -> Bool -> + Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> Bool -> + H.Statement () ProcResults +callProcStatement returnsScalar returnsSingle callProcQuery selectQuery countQuery countTotal asSingle asCsv multObjects binaryField pgVer = + H.dynamicallyParameterized snippet decodeProc + where + snippet = + "WITH " <> H.sql sourceCTEName <> " AS (" <> callProcQuery <> ") " <> + countCTEF <> + H.sql ( + "SELECT " <> + countResultF <> " AS total_result_set, " <> + "pg_catalog.count(_postgrest_t) AS page_total, " <> + bodyF <> " AS body, " <> + responseHeadersF pgVer <> " AS response_headers, " <> + responseStatusF pgVer <> " AS response_status ") <> + "FROM (" <> selectQuery <> ") _postgrest_t" + + (countCTEF, countResultF) = countF countQuery countTotal + + bodyF + | asSingle = asJsonSingleF returnsScalar + | asCsv = asCsvF + | isJust binaryField = asBinaryF $ fromJust binaryField + | returnsSingle + && not multObjects = asJsonSingleF returnsScalar + | otherwise = asJsonF returnsScalar + + decodeProc :: HD.Result ProcResults + decodeProc = + fromMaybe (Just 0, 0, mempty, defGucHeaders, defGucStatus) <$> HD.rowMaybe procRow + where + defGucHeaders = Right [] + defGucStatus = Right Nothing + procRow = (,,,,) <$> nullableColumn HD.int8 <*> column HD.int8 + <*> column HD.bytea + <*> (fromMaybe defGucHeaders <$> nullableColumn decodeGucHeaders) + <*> (fromMaybe defGucStatus <$> nullableColumn decodeGucStatus) + +createExplainStatement :: H.Snippet -> Bool -> H.Statement () (Maybe Int64) +createExplainStatement countQuery = + H.dynamicallyParameterized snippet decodeExplain + where + snippet = "EXPLAIN (FORMAT JSON) " <> countQuery + -- | + -- An `EXPLAIN (FORMAT JSON) select * from items;` output looks like this: + -- [{ + -- "Plan": { + -- "Node Type": "Seq Scan", "Parallel Aware": false, "Relation Name": "items", + -- "Alias": "items", "Startup Cost": 0.00, "Total Cost": 32.60, + -- "Plan Rows": 2260,"Plan Width": 8} }] + -- We only obtain the Plan Rows here. + decodeExplain :: HD.Result (Maybe Int64) + decodeExplain = + let row = HD.singleRow $ column HD.bytea in + (^? L.nth 0 . L.key "Plan" . L.key "Plan Rows" . L._Integral) <$> row + +decodeGucHeaders :: HD.Value (Either Error [GucHeader]) +decodeGucHeaders = first (const GucHeadersError) . JSON.eitherDecode . toS <$> HD.bytea + +decodeGucStatus :: HD.Value (Either Error (Maybe Status)) +decodeGucStatus = first (const GucStatusError) . fmap (Just . toEnum . fst) . decimal <$> HD.text + +column :: HD.Value a -> HD.Row a +column = HD.column . HD.nonNullable + +nullableColumn :: HD.Value a -> HD.Row (Maybe a) +nullableColumn = HD.column . HD.nullable + +arrayColumn :: HD.Value a -> HD.Row [a] +arrayColumn = column . HD.listArray . HD.nonNullable diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs deleted file mode 100644 --- a/src/PostgREST/QueryBuilder.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-| -Module : PostgREST.QueryBuilder -Description : PostgREST SQL queries generating functions. - -This module provides functions to consume data types that -represent database queries (e.g. ReadRequest, MutateRequest) and SqlFragment -to produce SqlQuery type outputs. --} -module PostgREST.QueryBuilder ( - readRequestToQuery - , mutateRequestToQuery - , readRequestToCountQuery - , requestToCallProcQuery - , limitedQuery - , setLocalQuery - , setLocalSearchPathQuery - ) where - -import qualified Data.Set as S - -import Data.Text (intercalate) -import Data.Tree (Tree (..)) - -import Data.Maybe - -import PostgREST.Private.QueryFragment -import PostgREST.RangeQuery (allRange, rangeLimit, - rangeOffset) -import PostgREST.Types -import Protolude hiding (cast, intercalate, - replace) - -readRequestToQuery :: ReadRequest -> SqlQuery -readRequestToQuery (Node (Select colSelects mainQi tblAlias implJoins logicForest joinConditions_ ordts range, _) forest) = - unwords [ - "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), - "FROM " <> intercalate ", " (tabl : implJs), - unwords joins, - ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConditions_)) - `emptyOnFalse` (null logicForest && null joinConditions_), - ("ORDER BY " <> intercalate ", " (map (pgFmtOrderTerm qi) ordts)) `emptyOnFalse` null ordts, - ("LIMIT " <> maybe "ALL" show (rangeLimit range) <> " OFFSET " <> show (rangeOffset range)) `emptyOnFalse` (range == allRange) - ] - where - implJs = fromQi <$> implJoins - tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias - qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias - (joins, selects) = foldr getJoinsSelects ([],[]) forest - -getJoinsSelects :: ReadRequest -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment]) -getJoinsSelects rr@(Node (_, (name, Just Relation{relType=relTyp,relTable=Table{tableName=table}}, alias, _, _)) _) (j,s) = - let subquery = readRequestToQuery rr in - case relTyp of - M2O -> - let aliasOrName = fromMaybe name alias - localTableName = pgFmtIdent $ table <> "_" <> aliasOrName - sel = "row_to_json(" <> localTableName <> ".*) AS " <> pgFmtIdent aliasOrName - joi = " LEFT JOIN LATERAL( " <> subquery <> " ) AS " <> localTableName <> " ON TRUE " in - (joi:j,sel:s) - _ -> - let sel = "COALESCE ((" - <> "SELECT json_agg(" <> pgFmtIdent table <> ".*) " - <> "FROM (" <> subquery <> ") " <> pgFmtIdent table - <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias) in - (j,sel:s) -getJoinsSelects (Node (_, (_, Nothing, _, _, _)) _) _ = ([], []) - -mutateRequestToQuery :: MutateRequest -> SqlQuery -mutateRequestToQuery (Insert mainQi iCols onConflct putConditions returnings) = - unwords [ - "WITH " <> normalizedBody, - "INSERT INTO ", fromQi mainQi, if S.null iCols then " " else "(" <> cols <> ")", - unwords [ - "SELECT " <> cols <> " FROM", - "json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ") _", - -- Only used for PUT - ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier mempty "_") <$> putConditions)) `emptyOnFalse` null putConditions], - maybe "" (\(oncDo, oncCols) -> ( - "ON CONFLICT(" <> intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of - IgnoreDuplicates -> - "DO NOTHING" - MergeDuplicates -> - if S.null iCols - then "DO NOTHING" - else "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols) - ) `emptyOnFalse` null oncCols) onConflct, - returningF mainQi returnings - ] - where - cols = intercalate ", " $ pgFmtIdent <$> S.toList iCols -mutateRequestToQuery (Update mainQi uCols logicForest returnings) = - if S.null uCols - -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax - -- selecting an empty resultset from mainQi gives us the column names to prevent errors when using &select= - -- the select has to be based on "returnings" to make computed overloaded functions not throw - then "WITH " <> ignoredBody <> "SELECT " <> empty_body_returned_columns <> " FROM " <> fromQi mainQi <> " WHERE false" - else - unwords [ - "WITH " <> normalizedBody, - "UPDATE " <> fromQi mainQi <> " SET " <> cols, - "FROM (SELECT * FROM json_populate_recordset", "(null::", fromQi mainQi, ", " <> selectBody <> ")) _ ", - ("WHERE " <> intercalate " AND " (pgFmtLogicTree mainQi <$> logicForest)) `emptyOnFalse` null logicForest, - returningF mainQi returnings - ] - where - cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols) - empty_body_returned_columns :: SqlFragment - empty_body_returned_columns - | null returnings = "NULL" - | otherwise = intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings) -mutateRequestToQuery (Delete mainQi logicForest returnings) = - unwords [ - "WITH " <> ignoredBody, - "DELETE FROM ", fromQi mainQi, - ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree mainQi) logicForest)) `emptyOnFalse` null logicForest, - returningF mainQi returnings - ] - -requestToCallProcQuery :: QualifiedIdentifier -> [PgArg] -> Bool -> Maybe PreferParameters -> [FieldName] -> SqlQuery -requestToCallProcQuery qi pgArgs returnsScalar preferParams returnings = - unwords [ - "WITH", - argsCTE, - sourceBody ] - where - paramsAsSingleObject = preferParams == Just SingleObject - paramsAsMultipleObjects = preferParams == Just MultipleObjects - - (argsCTE, args) - | null pgArgs = (ignoredBody, "") - | paramsAsSingleObject = ("pgrst_args AS (SELECT NULL)", "$1::json") - | otherwise = ( - unwords [ - normalizedBody <> ",", - "pgrst_args AS (", - "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtArgs (\a -> " " <> pgaType a) <> ")", - ")"] - , if paramsAsMultipleObjects - then fmtArgs (\a -> " := pgrst_args." <> pgFmtIdent (pgaName a)) - else fmtArgs (\a -> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM pgrst_args LIMIT 1)") - ) - - fmtArgs :: (PgArg -> SqlFragment) -> SqlFragment - fmtArgs argFrag = intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> argFrag a) <$> pgArgs) - - sourceBody :: SqlFragment - sourceBody - | paramsAsMultipleObjects = - if returnsScalar - then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args" - else unwords [ "SELECT pgrst_lat_args.*" - , "FROM pgrst_args," - , "LATERAL ( SELECT " <> returned_columns <> " FROM " <> callIt <> " ) pgrst_lat_args" ] - | otherwise = - if returnsScalar - then "SELECT " <> callIt <> " AS pgrst_scalar" - else "SELECT " <> returned_columns <> " FROM " <> callIt - - callIt :: SqlFragment - callIt = fromQi qi <> "(" <> args <> ")" - - returned_columns :: SqlFragment - returned_columns - | null returnings = "*" - | otherwise = intercalate ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName qi) <$> returnings) - - --- | SQL query meant for COUNTing the root node of the Tree. --- It only takes WHERE into account and doesn't include LIMIT/OFFSET because it would reduce the COUNT. --- SELECT 1 is done instead of SELECT * to prevent doing expensive operations(like functions based on the columns) --- inside the FROM target. -readRequestToCountQuery :: ReadRequest -> SqlQuery -readRequestToCountQuery (Node (Select{from=qi, where_=logicForest}, _) _) = - unwords [ - "SELECT 1", - "FROM " <> fromQi qi, - ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest - ] - -limitedQuery :: SqlQuery -> Maybe Integer -> SqlQuery -limitedQuery query maxRows = query <> maybe mempty (\x -> " LIMIT " <> show x) maxRows - -setLocalQuery :: Text -> (Text, Text) -> SqlQuery -setLocalQuery prefix (k, v) = - "SET LOCAL " <> pgFmtIdent (prefix <> k) <> " = " <> pgFmtLit v <> ";" - -setLocalSearchPathQuery :: [Text] -> SqlQuery -setLocalSearchPathQuery vals = - "SET LOCAL search_path = " <> intercalate ", " (pgFmtLit <$> vals) <> ";" diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -99,5 +99,5 @@ | totalNotZero && fromInRange = show lower <> "-" <> show upper | otherwise = "*" totalString = maybe "*" show total - totalNotZero = maybe True (0 /=) total + totalNotZero = Just 0 /= total fromInRange = lower <= upper diff --git a/src/PostgREST/Request/ApiRequest.hs b/src/PostgREST/Request/ApiRequest.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Request/ApiRequest.hs @@ -0,0 +1,516 @@ +{-| +Module : PostgREST.Request.ApiRequest +Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. +-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module PostgREST.Request.ApiRequest + ( ApiRequest(..) + , InvokeMethod(..) + , ContentType(..) + , Action(..) + , Target(..) + , PayloadJSON(..) + , userApiRequest + ) where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import qualified Data.Csv as CSV +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Text as T +import qualified Data.Vector as V + +import Control.Arrow ((***)) +import Data.Aeson.Types (emptyArray, emptyObject) +import Data.List (last, lookup, partition, union) +import Data.List.NonEmpty (head) +import Data.Maybe (fromJust) +import Data.Ranged.Boundaries (Boundary (..)) +import Data.Ranged.Ranges (Range (..), emptyRange, + rangeIntersection) +import Network.HTTP.Base (urlEncodeVars) +import Network.HTTP.Types.Header (hAuthorization, hCookie) +import Network.HTTP.Types.URI (parseQueryReplacePlus, + parseSimpleQuery) +import Network.Wai (Request (..)) +import Network.Wai.Parse (parseHttpAccept) +import Web.Cookie (parseCookies) + +import PostgREST.Config (AppConfig (..), + OpenAPIMode (..)) +import PostgREST.ContentType (ContentType (..)) +import PostgREST.DbStructure (DbStructure (..)) +import PostgREST.DbStructure.Identifiers (FieldName, + QualifiedIdentifier (..), + Schema) +import PostgREST.DbStructure.Proc (PgArg (..), + ProcDescription (..), + ProcsMap) +import PostgREST.Error (ApiRequestError (..)) +import PostgREST.Query.SqlFragment (ftsOperators, operators) +import PostgREST.RangeQuery (NonnegRange, allRange, + rangeGeq, rangeLimit, + rangeOffset, rangeRequested, + restrictRange) +import PostgREST.Request.Parsers (pRequestColumns) +import PostgREST.Request.Preferences (PreferCount (..), + PreferParameters (..), + PreferRepresentation (..), + PreferResolution (..), + PreferTransaction (..)) + +import qualified PostgREST.ContentType as ContentType + +import Protolude hiding (head, toS) +import Protolude.Conv (toS) + + +type RequestBody = BL.ByteString + +data PayloadJSON + = ProcessedJSON -- ^ Cached attributes of a JSON payload + { pjRaw :: BL.ByteString + -- ^ This is the raw ByteString that comes from the request body. We + -- cache this instead of an Aeson Value because it was detected that for + -- large payloads the encoding had high memory usage, see + -- https://github.com/PostgREST/postgrest/pull/1005 for more details + , pjKeys :: S.Set Text + -- ^ Keys of the object or if it's an array these keys are guaranteed to + -- be the same across all its objects + } + | RawJSON { pjRaw :: BL.ByteString } + +data InvokeMethod = InvHead | InvGet | InvPost deriving Eq +-- | Types of things a user wants to do to tables/views/procs +data Action = ActionCreate | ActionRead{isHead :: Bool} + | ActionUpdate | ActionDelete + | ActionSingleUpsert | ActionInvoke InvokeMethod + | ActionInfo | ActionInspect{isHead :: Bool} + deriving Eq +-- | The path info that will be mapped to a target (used to handle validations and errors before defining the Target) +data Path + = PathInfo + { pSchema :: Schema, + pName :: Text, + pHasRpc :: Bool, + pIsDefaultSpec :: Bool, + pIsRootSpec :: Bool + } + | PathUnknown +-- | The target db object of a user action +data Target = TargetIdent QualifiedIdentifier + | TargetProc{tProc :: ProcDescription, tpIsRootSpec :: Bool} + | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/" + | TargetUnknown + +-- | RPC query param value `/rpc/func?v=`, used for VARIADIC functions on form-urlencoded POST and GETs +-- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3. +data RpcParamValue = Fixed Text | Variadic [Text] +instance JSON.ToJSON RpcParamValue where + toJSON (Fixed v) = JSON.toJSON v + toJSON (Variadic v) = JSON.toJSON v + +toRpcParamValue :: ProcDescription -> (Text, Text) -> (Text, RpcParamValue) +toRpcParamValue proc (k, v) | argIsVariadic k = (k, Variadic [v]) + | otherwise = (k, Fixed v) + where + argIsVariadic arg = isJust $ find (\PgArg{pgaName, pgaVar} -> pgaName == arg && pgaVar) $ pdArgs proc + +-- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"} +jsonRpcParams :: ProcDescription -> [(Text, Text)] -> PayloadJSON +jsonRpcParams proc prms = + if not $ pdHasVariadic proc then -- if proc has no variadic arg, save steps and directly convert to json + ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> prms) (S.fromList $ fst <$> prms) + else + let paramsMap = M.fromListWith mergeParams $ toRpcParamValue proc <$> prms in + ProcessedJSON (JSON.encode paramsMap) (S.fromList $ M.keys paramsMap) + where + mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue + mergeParams (Variadic a) (Variadic b) = Variadic $ b ++ a + mergeParams v _ = v -- repeated params for non-variadic arguments are not merged + +targetToJsonRpcParams :: Maybe Target -> [(Text, Text)] -> Maybe PayloadJSON +targetToJsonRpcParams target params = + case target of + Just TargetProc{tProc} -> Just $ jsonRpcParams tProc params + _ -> Nothing + +{-| + Describes what the user wants to do. This data type is a + translation of the raw elements of an HTTP request into domain + specific language. There is no guarantee that the intent is + sensible, it is up to a later stage of processing to determine + if it is an action we are able to perform. +-} +data ApiRequest = ApiRequest { + iAction :: Action -- ^ Similar but not identical to HTTP verb, e.g. Create/Invoke both POST + , iRange :: M.HashMap ByteString NonnegRange -- ^ Requested range of rows within response + , iTopLevelRange :: NonnegRange -- ^ Requested range of rows from the top level + , iTarget :: Target -- ^ The target, be it calling a proc or accessing a table + , iPayload :: Maybe PayloadJSON -- ^ Data sent by client and used for mutation actions + , iPreferRepresentation :: PreferRepresentation -- ^ If client wants created items echoed back + , iPreferParameters :: Maybe PreferParameters -- ^ How to pass parameters to a stored procedure + , iPreferCount :: Maybe PreferCount -- ^ Whether the client wants a result count + , iPreferResolution :: Maybe PreferResolution -- ^ Whether the client wants to UPSERT or ignore records on PK conflict + , iPreferTransaction :: Maybe PreferTransaction -- ^ Whether the clients wants to commit or rollback the transaction + , iFilters :: [(Text, Text)] -- ^ Filters on the result ("id", "eq.10") + , iLogic :: [(Text, Text)] -- ^ &and and &or parameters used for complex boolean logic + , iSelect :: Maybe Text -- ^ &select parameter used to shape the response + , iOnConflict :: Maybe Text -- ^ &on_conflict parameter used to upsert on specific unique keys + , iColumns :: S.Set FieldName -- ^ parsed colums from &columns parameter and payload + , iOrder :: [(Text, Text)] -- ^ &order parameters for each level + , iCanonicalQS :: ByteString -- ^ Alphabetized (canonical) request query string for response URLs + , iJWT :: Text -- ^ JSON Web Token + , iHeaders :: [(ByteString, ByteString)] -- ^ HTTP request headers + , iCookies :: [(ByteString, ByteString)] -- ^ Request Cookies + , iPath :: ByteString -- ^ Raw request path + , iMethod :: ByteString -- ^ Raw request method + , iProfile :: Maybe Schema -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/. + , iSchema :: Schema -- ^ The request schema. Can vary depending on iProfile. + , iAcceptContentType :: ContentType + } + +-- | Examines HTTP request and translates it into user intent. +userApiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest +userApiRequest conf@AppConfig{..} dbStructure req reqBody + | isJust profile && fromJust profile `notElem` configDbSchemas = Left $ UnacceptableSchema $ toList configDbSchemas + | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate + | topLevelRange == emptyRange = Left InvalidRange + | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload + | isLeft parsedColumns = either Left witness parsedColumns + | otherwise = do + acceptContentType <- findAcceptContentType conf action path accepts + checkedTarget <- target + return ApiRequest { + iAction = action + , iTarget = checkedTarget + , iRange = ranges + , iTopLevelRange = topLevelRange + , iPayload = relevantPayload + , iPreferRepresentation = representation + , iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject + | hasPrefer (show MultipleObjects) -> Just MultipleObjects + | otherwise -> Nothing + , iPreferCount = if | hasPrefer (show ExactCount) -> Just ExactCount + | hasPrefer (show PlannedCount) -> Just PlannedCount + | hasPrefer (show EstimatedCount) -> Just EstimatedCount + | otherwise -> Nothing + , iPreferResolution = if | hasPrefer (show MergeDuplicates) -> Just MergeDuplicates + | hasPrefer (show IgnoreDuplicates) -> Just IgnoreDuplicates + | otherwise -> Nothing + , iPreferTransaction = if | hasPrefer (show Commit) -> Just Commit + | hasPrefer (show Rollback) -> Just Rollback + | otherwise -> Nothing + , iFilters = filters + , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ] + , iSelect = toS <$> join (lookup "select" qParams) + , iOnConflict = toS <$> join (lookup "on_conflict" qParams) + , iColumns = payloadColumns + , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] + , iCanonicalQS = toS $ urlEncodeVars + . L.sortOn fst + . map (join (***) toS . second (fromMaybe BS.empty)) + $ qString + , iJWT = tokenStr + , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie] + , iCookies = maybe [] parseCookies $ lookupHeader "Cookie" + , iPath = rawPathInfo req + , iMethod = method + , iProfile = profile + , iSchema = schema + , iAcceptContentType = acceptContentType + } + where + accepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept" + -- queryString with '+' converted to ' '(space) + qString = parseQueryReplacePlus True $ rawQueryString req + -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..) + (filters, rpcQParams) = + case action of + ActionInvoke InvGet -> partitionFlts + ActionInvoke InvHead -> partitionFlts + _ -> (flts, []) + partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts + flts = + [ (toS k, toS $ fromJust v) | + (k,v) <- qParams, isJust v, + k `notElem` ["select", "columns"], + not (endingIn ["order", "limit", "offset", "and", "or"] k) ] + hasOperator val = any (`T.isPrefixOf` val) $ + ((<> ".") <$> "not":M.keys operators) ++ + ((<> "(") <$> M.keys ftsOperators) + isEmbedPath = T.isInfixOf "." + isTargetingProc = case path of + PathInfo{pHasRpc, pIsRootSpec} -> pHasRpc || pIsRootSpec + _ -> False + isTargetingDefaultSpec = case path of + PathInfo{pIsDefaultSpec=True} -> True + _ -> False + contentType = ContentType.decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" + columns + | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams) + | otherwise = Nothing + parsedColumns = pRequestColumns columns + payloadColumns = + case (contentType, action) of + (_, ActionInvoke InvGet) -> S.fromList $ fst <$> rpcQParams + (_, ActionInvoke InvHead) -> S.fromList $ fst <$> rpcQParams + (CTUrlEncoded, _) -> S.fromList $ map (toS . fst) $ parseSimpleQuery $ toS reqBody + _ -> case (relevantPayload, fromRight Nothing parsedColumns) of + (Just ProcessedJSON{pjKeys}, _) -> pjKeys + (Just RawJSON{}, Just cls) -> cls + _ -> S.empty + payload = case contentType of + CTApplicationJSON -> + if isJust columns + then Right $ RawJSON reqBody + else note "All object keys must match" . payloadAttributes reqBody + =<< if BL.null reqBody && isTargetingProc + then Right emptyObject + else JSON.eitherDecode reqBody + CTTextCSV -> do + json <- csvToJson <$> CSV.decodeByName reqBody + note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json + CTUrlEncoded -> + let paramsMap = M.fromList $ (toS *** JSON.String . toS) <$> parseSimpleQuery (toS reqBody) in + Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (M.keys paramsMap) + ct -> + Left $ toS $ "Content-Type not acceptable: " <> ContentType.toMime ct + topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows + action = + case method of + -- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response + -- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4 + "HEAD" | isTargetingDefaultSpec -> ActionInspect{isHead=True} + | isTargetingProc -> ActionInvoke InvHead + | otherwise -> ActionRead{isHead=True} + "GET" | isTargetingDefaultSpec -> ActionInspect{isHead=False} + | isTargetingProc -> ActionInvoke InvGet + | otherwise -> ActionRead{isHead=False} + "POST" -> if isTargetingProc + then ActionInvoke InvPost + else ActionCreate + "PATCH" -> ActionUpdate + "PUT" -> ActionSingleUpsert + "DELETE" -> ActionDelete + "OPTIONS" -> ActionInfo + _ -> ActionInspect{isHead=False} + + defaultSchema = head configDbSchemas + profile + | length configDbSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config + = Nothing + | otherwise = case action of + -- POST/PATCH/PUT/DELETE don't use the same header as per the spec + ActionCreate -> contentProfile + ActionUpdate -> contentProfile + ActionSingleUpsert -> contentProfile + ActionDelete -> contentProfile + ActionInvoke InvPost -> contentProfile + _ -> acceptProfile + where + contentProfile = Just $ maybe defaultSchema toS $ lookupHeader "Content-Profile" + acceptProfile = Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile" + schema = fromMaybe defaultSchema profile + target = + let + callFindProc procSch procNam = findProc (QualifiedIdentifier procSch procNam) payloadColumns (hasPrefer (show SingleObject)) $ dbProcs dbStructure + in + case path of + PathInfo{pSchema, pName, pHasRpc, pIsRootSpec, pIsDefaultSpec} + | pHasRpc || pIsRootSpec -> (`TargetProc` pIsRootSpec) <$> callFindProc pSchema pName + | pIsDefaultSpec -> Right $ TargetDefaultSpec pSchema + | otherwise -> Right $ TargetIdent $ QualifiedIdentifier pSchema pName + PathUnknown -> Right TargetUnknown + + shouldParsePayload = case (contentType, action) of + (CTUrlEncoded, ActionInvoke InvPost) -> False + (_, act) -> act `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke InvPost] + relevantPayload = case (contentType, action) of + -- Though ActionInvoke GET/HEAD doesn't really have a payload, we use the payload variable as a way + -- to store the query string arguments to the function. + (_, ActionInvoke InvGet) -> targetToJsonRpcParams (rightToMaybe target) rpcQParams + (_, ActionInvoke InvHead) -> targetToJsonRpcParams (rightToMaybe target) rpcQParams + (CTUrlEncoded, ActionInvoke InvPost) -> targetToJsonRpcParams (rightToMaybe target) $ (toS *** toS) <$> parseSimpleQuery (toS reqBody) + _ | shouldParsePayload -> rightToMaybe payload + | otherwise -> Nothing + path = + case pathInfo req of + [] -> case configDbRootSpec of + Just (QualifiedIdentifier pSch pName) -> PathInfo (if pSch == mempty then schema else pSch) pName False False True + Nothing | configOpenApiMode == OADisabled -> PathUnknown + | otherwise -> PathInfo schema "" False True False + [table] -> PathInfo schema table False False False + ["rpc", pName] -> PathInfo schema pName True False False + _ -> PathUnknown + method = requestMethod req + hdrs = requestHeaders req + qParams = [(toS k, v)|(k,v) <- qString] + lookupHeader = flip lookup hdrs + hasPrefer :: Text -> Bool + hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs + where + split :: BS.ByteString -> [Text] + split = map T.strip . T.split (==',') . toS + representation + | hasPrefer (show Full) = Full + | hasPrefer (show None) = None + | hasPrefer (show HeadersOnly) = HeadersOnly + | otherwise = None + auth = fromMaybe "" $ lookupHeader hAuthorization + tokenStr = case T.split (== ' ') (toS auth) of + ("Bearer" : t : _) -> t + ("bearer" : t : _) -> t + _ -> "" + endingIn:: [Text] -> Text -> Bool + endingIn xx key = lastWord `elem` xx + where lastWord = last $ T.split (=='.') key + + headerRange = rangeRequested hdrs + replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x] + limitParams :: M.HashMap ByteString NonnegRange + limitParams = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe . toS =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k] + offsetParams :: M.HashMap ByteString NonnegRange + offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe . toS =<< v)) | (k,v) <- qParams, isJust v, endingIn ["offset"] k] + + urlRange = M.unionWith f limitParams offsetParams + where + f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1) + where + l = fromMaybe 0 $ rangeLimit rl + o = rangeOffset ro + ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange + +{-| + Find the best match from a list of content types accepted by the + client in order of decreasing preference and a list of types + producible by the server. If there is no match but the client + accepts */* then return the top server pick. +-} +mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType +mutuallyAgreeable sProduces cAccepts = + let exact = listToMaybe $ L.intersect cAccepts sProduces in + if isNothing exact && CTAny `elem` cAccepts + then listToMaybe sProduces + else exact + +type CsvData = V.Vector (M.HashMap Text BL.ByteString) + +{-| + Converts CSV like + a,b + 1,hi + 2,bye + + into a JSON array like + [ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ] + + The reason for its odd signature is so that it can compose + directly with CSV.decodeByName +-} +csvToJson :: (CSV.Header, CsvData) -> JSON.Value +csvToJson (_, vals) = + JSON.Array $ V.map rowToJsonObj vals + where + rowToJsonObj = JSON.Object . + M.map (\str -> + if str == "NULL" + then JSON.Null + else JSON.String $ toS str + ) + +payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON +payloadAttributes raw json = + -- Test that Array contains only Objects having the same keys + case json of + JSON.Array arr -> + case arr V.!? 0 of + Just (JSON.Object o) -> + let canonicalKeys = S.fromList $ M.keys o + areKeysUniform = all (\case + JSON.Object x -> S.fromList (M.keys x) == canonicalKeys + _ -> False) arr in + if areKeysUniform + then Just $ ProcessedJSON raw canonicalKeys + else Nothing + Just _ -> Nothing + Nothing -> Just emptyPJArray + + JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ M.keys o) + + -- truncate everything else to an empty array. + _ -> Just emptyPJArray + where + emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty + +findAcceptContentType :: AppConfig -> Action -> Path -> [ContentType] -> Either ApiRequestError ContentType +findAcceptContentType conf action path accepts = + case mutuallyAgreeable (requestContentTypes conf action path) accepts of + Just ct -> + Right ct + Nothing -> + Left . ContentTypeError $ map ContentType.toMime accepts + +requestContentTypes :: AppConfig -> Action -> Path -> [ContentType] +requestContentTypes conf action path = + case action of + ActionRead _ -> defaultContentTypes ++ rawContentTypes conf + ActionInvoke _ -> invokeContentTypes + ActionInspect _ -> [CTOpenAPI, CTApplicationJSON] + ActionInfo -> [CTTextCSV] + _ -> defaultContentTypes + where + invokeContentTypes = + defaultContentTypes + ++ rawContentTypes conf + ++ [CTOpenAPI | pIsRootSpec path] + defaultContentTypes = + [CTApplicationJSON, CTSingularJSON, CTTextCSV] + +rawContentTypes :: AppConfig -> [ContentType] +rawContentTypes AppConfig{..} = + (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain] + +{-| + Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it. + An overloaded function can have a different volatility or even a different return type. +-} +findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> Either ApiRequestError ProcDescription +findProc qi payloadKeys paramsAsSingleObject allProcs = + case bestMatch of + [] -> Left $ NoRpc (qiSchema qi) (qiName qi) (S.toList payloadKeys) paramsAsSingleObject + [proc] -> Right proc + procs -> Left $ AmbiguousRpc (toList procs) + where + bestMatch = + case M.lookup qi allProcs of + Nothing -> [] + Just [proc] -> [proc | matches proc] + Just procs -> filter matches procs + -- Find the exact arguments match + matches proc + | paramsAsSingleObject = case pdArgs proc of + [arg] -> pgaType arg `elem` ["json", "jsonb"] + _ -> False + | otherwise = case pdArgs proc of + [] -> null payloadKeys + args -> matchesArg args + matchesArg args = + -- The function's required arguments are separated from the ones with a default value assigned. + -- The set of names of those arguments is compared to the set of keys supplied by the client + -- 1. If only required arguments are found, the keys must be exactly the same as those arguments + -- 2. If only optional arguments are found, the keys must be a subset of those arguments + -- 3. If both required and optional arguments are found, the result of taking away the optional arguments + -- from the keys must be exactly the same as the required arguments + case L.partition pgaReq args of + (reqArgs, []) -> payloadKeys == S.fromList (pgaName <$> reqArgs) + ([], defArgs) -> payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> defArgs) + (reqArgs, defArgs) -> payloadKeys `S.difference` S.fromList (pgaName <$> defArgs) == S.fromList (pgaName <$> reqArgs) diff --git a/src/PostgREST/Request/DbRequestBuilder.hs b/src/PostgREST/Request/DbRequestBuilder.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Request/DbRequestBuilder.hs @@ -0,0 +1,376 @@ +{-| +Module : PostgREST.Request.DbRequestBuilder +Description : PostgREST database request builder + +This module is in charge of building an intermediate +representation(ReadRequest, MutateRequest) between the HTTP request and the +final resulting SQL query. + +A query tree is built in case of resource embedding. By inferring the +relationship between tables, join conditions are added for every embedded +resource. +-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module PostgREST.Request.DbRequestBuilder + ( readRequest + , mutateRequest + , returningCols + ) where + +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S + +import Control.Arrow ((***)) +import Data.Either.Combinators (mapLeft) +import Data.List (delete) +import Data.Text (isInfixOf) +import Data.Tree (Tree (..)) + +import PostgREST.DbStructure.Identifiers (FieldName, + QualifiedIdentifier (..), + Schema, TableName) +import PostgREST.DbStructure.Relationship (Cardinality (..), + Junction (..), + Relationship (..)) +import PostgREST.DbStructure.Table (Column (..), Table (..), + tableQi) +import PostgREST.Error (ApiRequestError (..), + Error (..)) +import PostgREST.Query.SqlFragment (sourceCTEName) +import PostgREST.RangeQuery (NonnegRange, allRange, + restrictRange) +import PostgREST.Request.ApiRequest (Action (..), + ApiRequest (..), + PayloadJSON (..)) + +import PostgREST.Request.Parsers +import PostgREST.Request.Preferences +import PostgREST.Request.Types + +import qualified PostgREST.DbStructure.Relationship as Relationship + +import Protolude hiding (from) + +-- | Builds the ReadRequest tree on a number of stages. +-- | Adds filters, order, limits on its respective nodes. +-- | Adds joins conditions obtained from resource embedding. +readRequest :: Schema -> TableName -> Maybe Integer -> [Relationship] -> ApiRequest -> Either Error ReadRequest +readRequest schema rootTableName maxRows allRels apiRequest = + mapLeft ApiRequestError $ + treeRestrictRange maxRows =<< + augmentRequestWithJoin schema rootRels =<< + (addFiltersOrdersRanges apiRequest . initReadRequest rootName =<< pRequestSelect sel) + where + sel = fromMaybe "*" $ iSelect apiRequest -- default to all columns requested (SELECT *) for a non existent ?select querystring param + (rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest) + +-- Get the root table name with its relationships according to the Action type. +-- This is done because of the shape of the final SQL Query. The mutation cases +-- are wrapped in a WITH {sourceCTEName}(see Statements.hs). So we need a FROM +-- {sourceCTEName} instead of FROM {tableName}. +rootWithRels :: Schema -> TableName -> [Relationship] -> Action -> (QualifiedIdentifier, [Relationship]) +rootWithRels schema rootTableName allRels action = case action of + ActionRead _ -> (QualifiedIdentifier schema rootTableName, allRels) -- normal read case + _ -> (QualifiedIdentifier mempty _sourceCTEName, mapMaybe toSourceRel allRels ++ allRels) -- mutation cases and calling proc + where + _sourceCTEName = decodeUtf8 sourceCTEName + -- To enable embedding in the sourceCTEName cases we need to replace the + -- foreign key tableName in the Relationship with {sourceCTEName}. This way + -- findRel can find relationships with sourceCTEName. + toSourceRel :: Relationship -> Maybe Relationship + toSourceRel r@Relationship{relTable=t} + | rootTableName == tableName t = Just $ r {relTable=t {tableName=_sourceCTEName}} + | otherwise = Nothing + +-- Build the initial tree with a Depth attribute so when a self join occurs we +-- can differentiate the parent and child tables by having an alias like +-- "table_depth", this is related to +-- http://github.com/PostgREST/postgrest/issues/987. +initReadRequest :: QualifiedIdentifier -> [Tree SelectItem] -> ReadRequest +initReadRequest rootQi = + foldr (treeEntry rootDepth) initial + where + rootDepth = 0 + rootSchema = qiSchema rootQi + rootName = qiName rootQi + initial = Node (Select [] rootQi Nothing [] [] [] [] allRange, (rootName, Nothing, Nothing, Nothing, rootDepth)) [] + treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest + treeEntry depth (Node fld@((fn, _),_,alias, embedHint) fldForest) (Node (q, i) rForest) = + let nxtDepth = succ depth in + case fldForest of + [] -> Node (q {select=fld:select q}, i) rForest + _ -> Node (q, i) $ + foldr (treeEntry nxtDepth) + (Node (Select [] (QualifiedIdentifier rootSchema fn) Nothing [] [] [] [] allRange, + (fn, Nothing, alias, embedHint, nxtDepth)) []) + fldForest:rForest + +-- | Enforces the `max-rows` config on the result +treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest +treeRestrictRange maxRows request = pure $ nodeRestrictRange maxRows <$> request + where + nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode + nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) + +augmentRequestWithJoin :: Schema -> [Relationship] -> ReadRequest -> Either ApiRequestError ReadRequest +augmentRequestWithJoin schema allRels request = + addRels schema allRels Nothing request + >>= addJoinConditions Nothing + +addRels :: Schema -> [Relationship] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest +addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, hint, depth)) forest) = + case parentNode of + Just (Node (Select{from=parentNodeQi}, _) _) -> + let newFrom r = if qiName tbl == nodeName then tableQi (relForeignTable r) else tbl + newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel + rel = findRel schema allRels (qiName parentNodeQi) nodeName hint + in + Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest) + _ -> + let rn = (query, (nodeName, Nothing, alias, Nothing, depth)) in + Node rn <$> updateForest (Just $ Node rn forest) + where + updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest] + updateForest rq = addRels schema allRels rq `traverse` forest + +-- Finds a relationship between an origin and a target in the request: +-- /origin?select=target(*) If more than one relationship is found then the +-- request is ambiguous and we return an error. In that case the request can +-- be disambiguated by adding precision to the target or by using a hint: +-- /origin?select=target!hint(*) The elements will be matched according to +-- these rules: +-- origin = table / view +-- target = table / view / constraint / column-from-origin +-- hint = table / view / constraint / column-from-origin / column-from-target +-- (hint can take table / view values to aid in finding the junction in an m2m relationship) +findRel :: Schema -> [Relationship] -> NodeName -> NodeName -> Maybe EmbedHint -> Either ApiRequestError Relationship +findRel schema allRels origin target hint = + case rel of + [] -> Left $ NoRelBetween origin target + [r] -> Right r + -- Here we handle a self reference relationship to not cause a breaking + -- change: In a self reference we get two relationships with the same + -- foreign key and relTable/relFtable but with different + -- cardinalities(m2o/o2m) We output the O2M rel, the M2O rel can be + -- obtained by using the origin column as an embed hint. + rs@[rel0, rel1] -> case (relCardinality rel0, relCardinality rel1, relTable rel0 == relTable rel1 && relForeignTable rel0 == relForeignTable rel1) of + (O2M cons1, M2O cons2, True) -> if cons1 == cons2 then Right rel0 else Left $ AmbiguousRelBetween origin target rs + (M2O cons1, O2M cons2, True) -> if cons1 == cons2 then Right rel1 else Left $ AmbiguousRelBetween origin target rs + _ -> Left $ AmbiguousRelBetween origin target rs + rs -> Left $ AmbiguousRelBetween origin target rs + where + matchFKSingleCol hint_ cols = length cols == 1 && hint_ == (colName <$> head cols) + matchConstraint tar card = case card of + O2M cons -> tar == Just cons + M2O cons -> tar == Just cons + _ -> False + matchJunction hint_ card = case card of + M2M Junction{junTable} -> hint_ == Just (tableName junTable) + _ -> False + rel = filter ( + \Relationship{..} -> + -- Both relationship ends need to be on the exposed schema + schema == tableSchema relTable && schema == tableSchema relForeignTable && + ( + -- /projects?select=clients(*) + origin == tableName relTable && -- projects + target == tableName relForeignTable || -- clients + + -- /projects?select=projects_client_id_fkey(*) + ( + origin == tableName relTable && -- projects + matchConstraint (Just target) relCardinality -- projects_client_id_fkey + ) || + -- /projects?select=client_id(*) + ( + origin == tableName relTable && -- projects + matchFKSingleCol (Just target) relColumns -- client_id + ) + ) && ( + isNothing hint || -- hint is optional + + -- /projects?select=clients!projects_client_id_fkey(*) + matchConstraint hint relCardinality || -- projects_client_id_fkey + + -- /projects?select=clients!client_id(*) or /projects?select=clients!id(*) + matchFKSingleCol hint relColumns || -- client_id + matchFKSingleCol hint relForeignColumns || -- id + + -- /users?select=tasks!users_tasks(*) many-to-many between users and tasks + matchJunction hint relCardinality -- users_tasks + ) + ) allRels + +-- previousAlias is only used for the case of self joins +addJoinConditions :: Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest +addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, rel, _, _, depth)) forest) = + case rel of + Just r@Relationship{relCardinality=M2M Junction{junTable}} -> + let rq = augmentQuery r in + Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest + Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest + Nothing -> Node node <$> updatedForest + where + newAlias = case Relationship.isSelfReference <$> rel of + Just True + | depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased + | otherwise -> Nothing + _ -> Nothing + augmentQuery r = + foldr + (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs}) + query{fromAlias=newAlias} + (getJoinConditions previousAlias newAlias r) + updatedForest = addJoinConditions newAlias `traverse` forest + +-- previousAlias and newAlias are used in the case of self joins +getJoinConditions :: Maybe Alias -> Maybe Alias -> Relationship -> [JoinCondition] +getJoinConditions previousAlias newAlias (Relationship Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols card) = + case card of + M2M (Junction Table{tableName=jtn} _ jc1 _ jc2) -> + zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2 + _ -> + zipWith (toJoinCondition tN ftN) cols fCols + where + toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition + toJoinCondition tb ftb c fc = + let qi1 = removeSourceCTESchema tSchema tb + qi2 = removeSourceCTESchema tSchema ftb in + JoinCondition (maybe qi1 (QualifiedIdentifier mempty) previousAlias, colName c) + (maybe qi2 (QualifiedIdentifier mempty) newAlias, colName fc) + + -- On mutation and calling proc cases we wrap the target table in a WITH + -- {sourceCTEName} if this happens remove the schema `FROM + -- "schema"."{sourceCTEName}"` and use only the `FROM "{sourceCTEName}"`. + -- If the schema remains the FROM would be invalid. + removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier + removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == decodeUtf8 sourceCTEName then mempty else schema) tbl + +addFiltersOrdersRanges :: ApiRequest -> ReadRequest -> Either ApiRequestError ReadRequest +addFiltersOrdersRanges apiRequest rReq = do + rFlts <- foldr addFilter rReq <$> filters + rOrds <- foldr addOrder rFlts <$> orders + rRngs <- foldr addRange rOrds <$> ranges + foldr addLogicTree rRngs <$> logicForest + where + filters :: Either ApiRequestError [(EmbedPath, Filter)] + filters = pRequestFilter `traverse` flts + orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])] + orders = pRequestOrder `traverse` iOrder apiRequest + ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)] + ranges = pRequestRange `traverse` M.toList (iRange apiRequest) + logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)] + logicForest = pRequestLogicTree `traverse` logFrst + action = iAction apiRequest + -- there can be no filters on the root table when we are doing insert/update/delete + (flts, logFrst) = + case action of + ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest) + ActionRead _ -> (iFilters apiRequest, iLogic apiRequest) + _ -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest) + +addFilterToNode :: Filter -> ReadRequest -> ReadRequest +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 + +addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest +addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f + +addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest +addOrder = addProperty addOrderToNode + +addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest +addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f + +addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest +addRange = addProperty addRangeToNode + +addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest +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 + +addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest +addProperty f ([], a) rr = f a rr +addProperty f (targetNodeName:remainingPath, a) (Node rn forest) = + case pathNode of + Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path + Just tn -> Node rn (addProperty f (remainingPath, a) tn:delete tn forest) + where + pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest + +mutateRequest :: Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Error MutateRequest +mutateRequest schema tName apiRequest pkCols readReq = mapLeft ApiRequestError $ + case action of + ActionCreate -> do + confCols <- case iOnConflict apiRequest of + Nothing -> pure pkCols + Just param -> pRequestOnConflict param + pure $ Insert qi (iColumns apiRequest) body ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings + ActionUpdate -> Update qi (iColumns apiRequest) body <$> combinedLogic <*> pure returnings + ActionSingleUpsert -> + (\flts -> + if null (iLogic apiRequest) && + S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols && + not (null (S.fromList pkCols)) && + all (\case + Filter _ (OpExpr False (Op "eq" _)) -> True + _ -> False) flts + then Insert qi (iColumns apiRequest) body (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings + else + Left InvalidFilters) =<< filters + ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings + _ -> Left UnsupportedVerb + where + qi = QualifiedIdentifier schema tName + action = iAction apiRequest + returnings = + if iPreferRepresentation apiRequest == None + then [] + else returningCols readReq pkCols + filters = map snd <$> pRequestFilter `traverse` mutateFilters + logic = map snd <$> pRequestLogicTree `traverse` logicFilters + combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters + -- update/delete filters can be only on the root table + (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest) + onlyRoot = filter (not . ( "." `isInfixOf` ) . fst) + body = pjRaw <$> iPayload apiRequest + +returningCols :: ReadRequest -> [FieldName] -> [FieldName] +returningCols rr@(Node _ forest) pkCols + -- if * is part of the select, we must not add pk or fk columns manually - + -- otherwise those would be selected and output twice + | "*" `elem` fldNames = ["*"] + | otherwise = returnings + where + fldNames = fstFieldNames rr + -- Without fkCols, when a mutateRequest to + -- /projects?select=name,clients(name) occurs, the RETURNING SQL part would + -- be `RETURNING name`(see QueryBuilder). This would make the embedding + -- fail because the following JOIN would need the "client_id" column from + -- projects. So this adds the foreign key columns to ensure the embedding + -- succeeds, result would be `RETURNING name, client_id`. + fkCols = concat $ mapMaybe (\case + Node (_, (_, Just Relationship{relColumns=cols}, _, _, _)) _ -> Just cols + _ -> Nothing + ) forest + -- However if the "client_id" is present, e.g. mutateRequest to + -- /projects?select=client_id,name,clients(name) we would get `RETURNING + -- client_id, name, client_id` and then we would produce the "column + -- reference \"client_id\" is ambiguous" error from PostgreSQL. So we + -- deduplicate with Set: We are adding the primary key columns as well to + -- make sure, that a proper location header can always be built for + -- INSERT/POST + returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols) ++ pkCols + +-- 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 diff --git a/src/PostgREST/Request/Parsers.hs b/src/PostgREST/Request/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Request/Parsers.hs @@ -0,0 +1,276 @@ +{-| +Module : PostgREST.Request.Parsers +Description : PostgREST parser combinators + +This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`. +-} +module PostgREST.Request.Parsers + ( pColumns + , pLogicPath + , pLogicSingleVal + , pLogicTree + , pOrder + , pOrderTerm + , pRequestColumns + , pRequestFilter + , pRequestLogicTree + , pRequestOnConflict + , pRequestOrder + , pRequestRange + , pRequestSelect + , pSingleVal + , pTreePath + ) where + +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S + +import Data.Either.Combinators (mapLeft) +import Data.Foldable (foldl1) +import Data.List (init, last) +import Data.Text (intercalate, replace, strip) +import Data.Tree (Tree (..)) +import Text.Parsec.Error (errorMessages, + showErrorMessages) +import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser, + anyChar, between, char, digit, + eof, errorPos, letter, + lookAhead, many1, noneOf, + notFollowedBy, oneOf, option, + optionMaybe, parse, sepBy1, + string, try, ()) + +import PostgREST.DbStructure.Identifiers (FieldName) +import PostgREST.Error (ApiRequestError (ParseRequestError)) +import PostgREST.Query.SqlFragment (ftsOperators, operators) +import PostgREST.RangeQuery (NonnegRange) + +import PostgREST.Request.Types + +import Protolude hiding (intercalate, option, replace, toS, try) +import Protolude.Conv (toS) + +pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem] +pRequestSelect selStr = + mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) + +pRequestOnConflict :: Text -> Either ApiRequestError [FieldName] +pRequestOnConflict oncStr = + mapError $ parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr) + +pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) +pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper) + where + treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k + oper = parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v + path = fst <$> treePath + fld = snd <$> treePath + +pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm]) +pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord' + where + treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k + path = fst <$> treePath + ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v + +pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange) +pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v + where + treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k + path = fst <$> treePath + +pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree) +pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree + where + path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k + embedPath = fst <$> path + logicTree = do + op <- snd <$> path + -- Concat op and v to make pLogicTree argument regular, + -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" + parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v) + +pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName)) +pRequestColumns colStr = + case colStr of + Just str -> + mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str) + _ -> Right Nothing + +ws :: Parser Text +ws = toS <$> many (oneOf " \t") + +lexeme :: Parser a -> Parser a +lexeme p = ws *> p <* ws + +pTreePath :: Parser (EmbedPath, Field) +pTreePath = do + p <- pFieldName `sepBy1` pDelimiter + jp <- option [] pJsonPath + return (init p, (last p, jp)) + +pFieldForest :: Parser [Tree SelectItem] +pFieldForest = pFieldTree `sepBy1` lexeme (char ',') + where + pFieldTree :: Parser (Tree SelectItem) + pFieldTree = try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|> + Node <$> pFieldSelect <*> pure [] + +pStar :: Parser Text +pStar = toS <$> (string "*" $> ("*"::ByteString)) + +pFieldName :: Parser Text +pFieldName = + pQuotedValue <|> + intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) + "field name (* or [a..z0..9_])" + where + isDash :: GenParser Char st () + isDash = try ( char '-' >> notFollowedBy (char '>') ) + dash :: Parser Char + dash = isDash $> '-' + +pJsonPath :: Parser JsonPath +pJsonPath = many pJsonOperation + where + pJsonOperation :: Parser JsonOperation + pJsonOperation = pJsonArrow <*> pJsonOperand + + pJsonArrow = + try (string "->>" $> J2Arrow) <|> + try (string "->" $> JArrow) + + pJsonOperand = + let pJKey = JKey . toS <$> pFieldName + pJIdx = JIdx . toS <$> ((:) <$> option '+' (char '-') <*> many1 digit) <* pEnd + pEnd = try (void $ lookAhead (string "->")) <|> + try (void $ lookAhead (string "::")) <|> + try eof in + try pJIdx <|> try pJKey + +pField :: Parser Field +pField = lexeme $ (,) <$> pFieldName <*> option [] pJsonPath + +aliasSeparator :: Parser () +aliasSeparator = char ':' >> notFollowedBy (char ':') + +pRelationSelect :: Parser SelectItem +pRelationSelect = lexeme $ try ( do + alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) + fld <- pField + hint <- optionMaybe ( + try ( char '!' *> pFieldName) <|> + -- deprecated, remove in next major version + try ( char '.' *> pFieldName) + ) + return (fld, Nothing, alias, hint) + ) + +pFieldSelect :: Parser SelectItem +pFieldSelect = lexeme $ + try ( + do + alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) + fld <- pField + cast' <- optionMaybe (string "::" *> many letter) + return (fld, toS <$> cast', alias, Nothing) + ) + <|> do + s <- pStar + return ((s, []), Nothing, Nothing, Nothing) + +pOpExpr :: Parser SingleVal -> Parser OpExpr +pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation + where + pOperation :: Parser Operation + pOperation = + Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal + <|> In <$> (try (string "in" *> pDelimiter) *> pListVal) + <|> pFts + "operator (eq, gt, ...)" + + pFts = do + op <- foldl1 (<|>) (try . string . toS <$> ftsOps) + lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_"))) + pDelimiter >> Fts (toS op) (toS <$> lang) <$> pSVal + + ops = M.filterWithKey (const . flip notElem ("in":ftsOps)) operators + ftsOps = M.keys ftsOperators + +pSingleVal :: Parser SingleVal +pSingleVal = toS <$> many anyChar + +pListVal :: Parser ListVal +pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')') + +pListElement :: Parser Text +pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)")) + +pQuotedValue :: Parser Text +pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"') + +pDelimiter :: Parser Char +pDelimiter = char '.' "delimiter (.)" + +pOrder :: Parser [OrderTerm] +pOrder = lexeme pOrderTerm `sepBy1` char ',' + +pOrderTerm :: Parser OrderTerm +pOrderTerm = do + fld <- pField + dir <- optionMaybe $ + try (pDelimiter *> string "asc" $> OrderAsc) <|> + try (pDelimiter *> string "desc" $> OrderDesc) + nls <- optionMaybe pNulls <* pEnd <|> + pEnd $> Nothing + return $ OrderTerm fld dir nls + where + pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|> + try (pDelimiter *> string "nullslast" $> OrderNullsLast) + pEnd = try (void $ lookAhead (char ',')) <|> + try eof + +pLogicTree :: Parser LogicTree +pLogicTree = Stmnt <$> try pLogicFilter + <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')')) + where + pLogicFilter :: Parser Filter + pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal + pNot :: Parser Bool + pNot = try (string "not" *> pDelimiter $> True) + <|> pure False + "negation operator (not)" + pLogicOp :: Parser LogicOperator + pLogicOp = try (string "and" $> And) + <|> string "or" $> Or + "logic operator (and, or)" + +pLogicSingleVal :: Parser SingleVal +pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)")) + where + pPgArray :: Parser Text + pPgArray = do + a <- string "{" + b <- many (noneOf "{}") + c <- string "}" + pure (toS $ a ++ b ++ c) + +pLogicPath :: Parser (EmbedPath, Text) +pLogicPath = do + path <- pFieldName `sepBy1` pDelimiter + let op = last path + notOp = "not." <> op + return (filter (/= "not") (init path), if "not" `elem` path then notOp else op) + +pColumns :: Parser [FieldName] +pColumns = pFieldName `sepBy1` lexeme (char ',') + +mapError :: Either ParseError a -> Either ApiRequestError a +mapError = mapLeft translateError + where + translateError e = + ParseRequestError message details + where + message = show $ errorPos e + details = strip $ replace "\n" " " $ toS + $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) diff --git a/src/PostgREST/Request/Preferences.hs b/src/PostgREST/Request/Preferences.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Request/Preferences.hs @@ -0,0 +1,54 @@ +module PostgREST.Request.Preferences where + +import GHC.Show +import Protolude + + +data PreferResolution + = MergeDuplicates + | IgnoreDuplicates + +instance Show PreferResolution where + show MergeDuplicates = "resolution=merge-duplicates" + show IgnoreDuplicates = "resolution=ignore-duplicates" + +-- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2 +data PreferRepresentation + = Full -- ^ Return the body plus the Location header(in case of POST). + | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk. + | None -- ^ Return nothing from the mutated data. + deriving Eq + +instance Show PreferRepresentation where + show Full = "return=representation" + show None = "return=minimal" + show HeadersOnly = "return=headers-only" + +data PreferParameters + = SingleObject -- ^ Pass all parameters as a single json object to a stored procedure + | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure + deriving Eq + +instance Show PreferParameters where + show SingleObject = "params=single-object" + show MultipleObjects = "params=multiple-objects" + +data PreferCount + = ExactCount -- ^ exact count(slower) + | PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}. + | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count. + deriving Eq + +instance Show PreferCount where + show ExactCount = "count=exact" + show PlannedCount = "count=planned" + show EstimatedCount = "count=estimated" + +data PreferTransaction + = Commit -- Commit transaction - the default. + | Rollback -- Rollback transaction after sending the response - does not persist changes, e.g. for running tests. + deriving Eq + +instance Show PreferTransaction where + show Commit = "tx=commit" + show Rollback = "tx=rollback" diff --git a/src/PostgREST/Request/Types.hs b/src/PostgREST/Request/Types.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Request/Types.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module PostgREST.Request.Types + ( Alias + , Depth + , EmbedHint + , EmbedPath + , Field + , Filter(..) + , JoinCondition(..) + , JsonOperand(..) + , JsonOperation(..) + , JsonPath + , ListVal + , LogicOperator(..) + , LogicTree(..) + , MutateQuery(..) + , MutateRequest + , NodeName + , OpExpr(..) + , Operation (..) + , OrderDirection(..) + , OrderNulls(..) + , OrderTerm(..) + , ReadNode + , ReadQuery(..) + , ReadRequest + , SelectItem + , SingleVal + , fstFieldNames + ) where + +import qualified Data.ByteString.Lazy as BL +import qualified Data.Set as S + +import Data.Tree (Tree (..)) + +import qualified GHC.Show (show) + +import PostgREST.DbStructure.Identifiers (FieldName, + QualifiedIdentifier) +import PostgREST.DbStructure.Relationship (Relationship) +import PostgREST.RangeQuery (NonnegRange) +import PostgREST.Request.Preferences (PreferResolution) + +import Protolude + + +type ReadRequest = Tree ReadNode +type MutateRequest = MutateQuery + +type ReadNode = + (ReadQuery, (NodeName, Maybe Relationship, Maybe Alias, Maybe EmbedHint, Depth)) + +type NodeName = Text +type Depth = Integer + +data ReadQuery = Select + { select :: [SelectItem] + , from :: QualifiedIdentifier + -- ^ A table alias is used in case of self joins + , fromAlias :: Maybe Alias + -- ^ Only used for Many to Many joins. Parent and Child joins use explicit joins. + , implicitJoins :: [QualifiedIdentifier] + , where_ :: [LogicTree] + , joinConditions :: [JoinCondition] + , order :: [OrderTerm] + , range_ :: NonnegRange + } + deriving (Eq) + +data JoinCondition = + JoinCondition + (QualifiedIdentifier, FieldName) + (QualifiedIdentifier, FieldName) + deriving (Eq) + +data OrderTerm = OrderTerm + { otTerm :: Field + , otDirection :: Maybe OrderDirection + , otNullOrder :: Maybe OrderNulls + } + deriving (Eq) + +data OrderDirection + = OrderAsc + | OrderDesc + deriving (Eq) + +instance Show OrderDirection where + show OrderAsc = "ASC" + show OrderDesc = "DESC" + +data OrderNulls + = OrderNullsFirst + | OrderNullsLast + deriving (Eq) + +instance Show OrderNulls where + show OrderNullsFirst = "NULLS FIRST" + show OrderNullsLast = "NULLS LAST" + +data MutateQuery + = Insert + { in_ :: QualifiedIdentifier + , insCols :: S.Set FieldName + , insBody :: Maybe BL.ByteString + , onConflict :: Maybe (PreferResolution, [FieldName]) + , where_ :: [LogicTree] + , returning :: [FieldName] + } + | Update + { in_ :: QualifiedIdentifier + , updCols :: S.Set FieldName + , updBody :: Maybe BL.ByteString + , where_ :: [LogicTree] + , returning :: [FieldName] + } + | Delete + { in_ :: QualifiedIdentifier + , where_ :: [LogicTree] + , returning :: [FieldName] + } + +-- | The select value in `/tbl?select=alias:field::cast` +type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint) + +type Field = (FieldName, JsonPath) +type Cast = Text +type Alias = Text + +-- | Disambiguates an embedding operation when there's multiple relationships +-- between two tables. Can be the name of a foreign key constraint, column +-- name or the junction in an m2m relationship. +type EmbedHint = Text + +-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path +-- ["clients", "projects"] +type EmbedPath = [Text] + +-- | Json path operations as specified in +-- https://www.postgresql.org/docs/current/static/functions-json.html +type JsonPath = [JsonOperation] + +-- | Represents the single arrow `->` or double arrow `->>` operators +data JsonOperation + = JArrow { jOp :: JsonOperand } + | J2Arrow { jOp :: JsonOperand } + deriving (Eq) + +-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text +-- because we reuse our escaping functons and let pg do the casting with +-- '1'::int +data JsonOperand + = JKey { jVal :: Text } + | JIdx { jVal :: Text } + deriving (Eq) + +-- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d)) +fstFieldNames :: ReadRequest -> [FieldName] +fstFieldNames (Node (sel, _) _) = + fst . (\(f, _, _, _) -> f) <$> select sel + + +-- | Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is: +-- +-- And +-- / \ +-- name.eq.N Or +-- / \ +-- id.eq.1 id.eq.2 +data LogicTree + = Expr Bool LogicOperator [LogicTree] + | Stmnt Filter + deriving (Eq) + +data LogicOperator + = And + | Or + deriving Eq + +instance Show LogicOperator where + show And = "AND" + show Or = "OR" + +data Filter = Filter + { field :: Field + , opExpr :: OpExpr + } + deriving (Eq) + +data OpExpr = + OpExpr Bool Operation + deriving (Eq) + +data Operation + = Op Operator SingleVal + | In ListVal + | Fts Operator (Maybe Language) SingleVal + deriving (Eq) + +type Operator = Text +type Language = Text + +-- | Represents a single value in a filter, e.g. id=eq.singleval +type SingleVal = Text + +-- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3) +type ListVal = [Text] diff --git a/src/PostgREST/Statements.hs b/src/PostgREST/Statements.hs deleted file mode 100644 --- a/src/PostgREST/Statements.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-| -Module : PostgREST.Statements -Description : PostgREST single SQL statements. - -This module constructs single SQL statements that can be parametrized and prepared. - -- It consumes the SqlQuery types generated by the QueryBuilder module. -- It generates the body format and some headers of the final HTTP response. - -TODO: Currently, createReadStatement is not using prepared statements. See https://github.com/PostgREST/postgrest/issues/718. --} -module PostgREST.Statements ( - createWriteStatement - , createReadStatement - , callProcStatement - , createExplainStatement -) where - - -import Control.Lens ((^?)) -import Data.Aeson as JSON -import qualified Data.Aeson.Lens as L -import qualified Data.ByteString.Char8 as BS -import Data.Maybe -import qualified Hasql.Decoders as HD -import qualified Hasql.Encoders as HE -import qualified Hasql.Statement as H -import PostgREST.Private.Common -import PostgREST.Private.QueryFragment -import PostgREST.Types -import Protolude hiding (cast, - replace, toS) -import Protolude.Conv (toS) -import Text.InterpolatedString.Perl6 (qc) - -{-| The generic query result format used by API responses. The location header - is represented as a list of strings containing variable bindings like - @"k1=eq.42"@, or the empty list if there is no location header. --} -type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString, Either Text [GucHeader]) - -createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> - PreferRepresentation -> [Text] -> PgVersion -> - H.Statement ByteString ResultsWithCount -createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys pgVer = - unicodeStatement sql (param HE.unknown) decodeStandard True - where - sql = [qc| - WITH - {sourceCTEName} AS ({mutateQuery}) - SELECT - '' AS total_result_set, - pg_catalog.count(_postgrest_t) AS page_total, - {locF} AS header, - {bodyF} AS body, - {responseHeadersF pgVer} AS response_headers - FROM ({selectF}) _postgrest_t |] - - locF = - if isInsert && rep `elem` [Full, HeadersOnly] - then unwords [ - "CASE WHEN pg_catalog.count(_postgrest_t) = 1", - "THEN coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")", - "ELSE " <> noLocationF, - "END"] - else noLocationF - - bodyF - | rep `elem` [None, HeadersOnly] = "''" - | asCsv = asCsvF - | wantSingle = asJsonSingleF - | otherwise = asJsonF - - selectF - -- prevent using any of the column names in ?select= when no response is returned from the CTE - | rep `elem` [None, HeadersOnly] = "SELECT * FROM " <> sourceCTEName - | otherwise = selectQuery - - decodeStandard :: HD.Result ResultsWithCount - decodeStandard = - fromMaybe (Nothing, 0, [], mempty, Right []) <$> HD.rowMaybe standardRow - -createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> - H.Statement () ResultsWithCount -createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField pgVer = - unicodeStatement sql HE.noParams decodeStandard False - where - sql = [qc| - WITH - {sourceCTEName} AS ({selectQuery}) - {countCTEF} - SELECT - {countResultF} AS total_result_set, - pg_catalog.count(_postgrest_t) AS page_total, - {noLocationF} AS header, - {bodyF} AS body, - {responseHeadersF pgVer} AS response_headers - FROM ( SELECT * FROM {sourceCTEName}) _postgrest_t |] - - (countCTEF, countResultF) = countF countQuery countTotal - - bodyF - | asCsv = asCsvF - | isSingle = asJsonSingleF - | isJust binaryField = asBinaryF $ fromJust binaryField - | otherwise = asJsonF - - decodeStandard :: HD.Result ResultsWithCount - decodeStandard = - HD.singleRow standardRow - -{-| Read and Write api requests use a similar response format which includes - various record counts and possible location header. This is the decoder - for that common type of query. --} -standardRow :: HD.Row ResultsWithCount -standardRow = (,,,,) <$> nullableColumn HD.int8 <*> column HD.int8 - <*> column header <*> column HD.bytea <*> column decodeGucHeaders - where - header = HD.array $ HD.dimension replicateM $ element HD.bytea - -type ProcResults = (Maybe Int64, Int64, ByteString, Either Text [GucHeader]) - -callProcStatement :: Bool -> SqlQuery -> SqlQuery -> SqlQuery -> Bool -> - Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> - H.Statement ByteString ProcResults -callProcStatement returnsScalar callProcQuery selectQuery countQuery countTotal isSingle asCsv asBinary multObjects binaryField pgVer = - unicodeStatement sql (param HE.unknown) decodeProc True - where - sql = [qc| - WITH {sourceCTEName} AS ({callProcQuery}) - {countCTEF} - SELECT - {countResultF} AS total_result_set, - pg_catalog.count(_postgrest_t) AS page_total, - {bodyF} AS body, - {responseHeadersF pgVer} AS response_headers - FROM ({selectQuery}) _postgrest_t;|] - - (countCTEF, countResultF) = countF countQuery countTotal - - bodyF - | returnsScalar = scalarBodyF - | isSingle = asJsonSingleF - | asCsv = asCsvF - | isJust binaryField = asBinaryF $ fromJust binaryField - | otherwise = asJsonF - - scalarBodyF - | asBinary = asBinaryF "pgrst_scalar" - | multObjects = "json_agg(_postgrest_t.pgrst_scalar)::character varying" - | otherwise = "(json_agg(_postgrest_t.pgrst_scalar)->0)::character varying" - - decodeProc :: HD.Result ProcResults - decodeProc = - fromMaybe (Just 0, 0, mempty, Right []) <$> HD.rowMaybe procRow - where - procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8 - <*> column HD.bytea <*> column decodeGucHeaders - -createExplainStatement :: SqlQuery -> H.Statement () (Maybe Int64) -createExplainStatement countQuery = - unicodeStatement sql HE.noParams decodeExplain False - where - sql = [qc| EXPLAIN (FORMAT JSON) {countQuery} |] - -- | - -- An `EXPLAIN (FORMAT JSON) select * from items;` output looks like this: - -- [{ - -- "Plan": { - -- "Node Type": "Seq Scan", "Parallel Aware": false, "Relation Name": "items", - -- "Alias": "items", "Startup Cost": 0.00, "Total Cost": 32.60, - -- "Plan Rows": 2260,"Plan Width": 8} }] - -- We only obtain the Plan Rows here. - decodeExplain :: HD.Result (Maybe Int64) - decodeExplain = - let row = HD.singleRow $ column HD.bytea in - (^? L.nth 0 . L.key "Plan" . L.key "Plan Rows" . L._Integral) <$> row - -unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Statement a b -unicodeStatement = H.Statement . encodeUtf8 - -decodeGucHeaders :: HD.Value (Either Text [GucHeader]) -decodeGucHeaders = first toS . JSON.eitherDecode . toS <$> HD.bytea diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs deleted file mode 100644 --- a/src/PostgREST/Types.hs +++ /dev/null @@ -1,537 +0,0 @@ -{-| -Module : PostgREST.Types -Description : PostgREST common types and functions used by the rest of the modules --} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} - -module PostgREST.Types where - -import Control.Lens.Getter (view) -import Control.Lens.Tuple (_1) - -import qualified Data.Aeson as JSON -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS (c2w) -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as M -import qualified Data.Set as S -import qualified GHC.Show - -import Network.HTTP.Types.Header (Header, hContentType) - -import Data.Tree - -import PostgREST.RangeQuery (NonnegRange) -import Protolude hiding (toS) -import Protolude.Conv (toS) - --- | Enumeration of currently supported response content types -data ContentType = CTApplicationJSON | CTSingularJSON - | CTTextCSV | CTTextPlain - | CTOpenAPI | CTOctetStream - | CTAny | CTOther ByteString deriving (Show, Eq) - --- | Convert from ContentType to a full HTTP Header -toHeader :: ContentType -> Header -toHeader ct = (hContentType, toMime ct <> "; charset=utf-8") - --- | Convert from ContentType to a ByteString representing the mime type -toMime :: ContentType -> ByteString -toMime CTApplicationJSON = "application/json" -toMime CTTextCSV = "text/csv" -toMime CTTextPlain = "text/plain" -toMime CTOpenAPI = "application/openapi+json" -toMime CTSingularJSON = "application/vnd.pgrst.object+json" -toMime CTOctetStream = "application/octet-stream" -toMime CTAny = "*/*" -toMime (CTOther ct) = ct - --- | Convert from ByteString to ContentType. Warning: discards MIME parameters -decodeContentType :: BS.ByteString -> ContentType -decodeContentType ct = case BS.takeWhile (/= BS.c2w ';') ct of - "application/json" -> CTApplicationJSON - "text/csv" -> CTTextCSV - "text/plain" -> CTTextPlain - "application/openapi+json" -> CTOpenAPI - "application/vnd.pgrst.object+json" -> CTSingularJSON - "application/vnd.pgrst.object" -> CTSingularJSON - "application/octet-stream" -> CTOctetStream - "*/*" -> CTAny - ct' -> CTOther ct' - --- | A SQL query that can be executed independently -type SqlQuery = Text - --- | A part of a SQL query that cannot be executed independently -type SqlFragment = Text - -data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq -instance Show PreferResolution where - show MergeDuplicates = "resolution=merge-duplicates" - show IgnoreDuplicates = "resolution=ignore-duplicates" - --- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2 -data PreferRepresentation = Full -- ^ Return the body plus the Location header(in case of POST). - | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk. - | None -- ^ Return nothing from the mutated data. - deriving Eq -instance Show PreferRepresentation where - show Full = "return=representation" - show None = "return=minimal" - show HeadersOnly = mempty - -data PreferParameters - = SingleObject -- ^ Pass all parameters as a single json object to a stored procedure - | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure - deriving Eq - -instance Show PreferParameters where - show SingleObject = "params=single-object" - show MultipleObjects = "params=multiple-objects" - -data PreferCount - = ExactCount -- ^ exact count(slower) - | PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}. - | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count. - deriving Eq - -instance Show PreferCount where - show ExactCount = "count=exact" - show PlannedCount = "count=planned" - show EstimatedCount = "count=estimated" - -data DbStructure = DbStructure { - dbTables :: [Table] -, dbColumns :: [Column] -, dbRelations :: [Relation] -, dbPrimaryKeys :: [PrimaryKey] -, dbProcs :: ProcsMap -, pgVersion :: PgVersion -} deriving (Show, Eq) - --- TODO Table could hold references to all its Columns -tableCols :: DbStructure -> Schema -> TableName -> [Column] -tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs - --- TODO Table could hold references to all its PrimaryKeys -tablePKCols :: DbStructure -> Schema -> TableName -> [Text] -tablePKCols dbs tSchema tName = pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs) - -data PgArg = PgArg { - pgaName :: Text -, pgaType :: Text -, pgaReq :: Bool -} deriving (Show, Eq, Ord) - -data PgType = Scalar QualifiedIdentifier | Composite QualifiedIdentifier deriving (Eq, Show, Ord) - -data RetType = Single PgType | SetOf PgType deriving (Eq, Show, Ord) - -data ProcVolatility = Volatile | Stable | Immutable - deriving (Eq, Show, Ord) - -data ProcDescription = ProcDescription { - pdSchema :: Schema -, pdName :: Text -, pdDescription :: Maybe Text -, pdArgs :: [PgArg] -, pdReturnType :: RetType -, pdVolatility :: ProcVolatility -} deriving (Show, Eq) - --- Order by least number of args in the case of overloaded functions -instance Ord ProcDescription where - ProcDescription schema1 name1 des1 args1 rt1 vol1 `compare` ProcDescription schema2 name2 des2 args2 rt2 vol2 - | schema1 == schema2 && name1 == name2 && length args1 < length args2 = LT - | schema2 == schema2 && name1 == name2 && length args1 > length args2 = GT - | otherwise = (schema1, name1, des1, args1, rt1, vol1) `compare` (schema2, name2, des2, args2, rt2, vol2) - --- | A map of all procs, all of which can be overloaded(one entry will have more than one ProcDescription). --- | It uses a HashMap for a faster lookup. -type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription] - -{-| - Search a pg procedure by its parameters. Since a function can be overloaded, the name is not enough to find it. - An overloaded function can have a different volatility or even a different return type. - Ideally, handling overloaded functions should be left to pg itself. But we need to know certain proc attributes in advance. --} -findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> Maybe ProcDescription -findProc qi payloadKeys paramsAsSingleObject allProcs = - case M.lookup qi allProcs of - Nothing -> Nothing - Just [proc] -> Just proc -- if it's not an overloaded function then immediately get the ProcDescription - Just procs -> find matches procs -- Handle overloaded functions case - where - matches proc = - if paramsAsSingleObject - -- if the arg is not of json type let the db give the err - then length (pdArgs proc) == 1 - else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs proc) - -{-| - Search the procedure parameters by matching them with the specified keys. - If the key doesn't match a parameter, a parameter with a default type "text" is assumed. --} -specifiedProcArgs :: S.Set FieldName -> Maybe ProcDescription -> [PgArg] -specifiedProcArgs keys proc = - let - args = maybe [] pdArgs proc - in - (\k -> fromMaybe (PgArg k "text" True) (find ((==) k . pgaName) args)) <$> S.toList keys - -procReturnsScalar :: ProcDescription -> Bool -procReturnsScalar proc = case proc of - ProcDescription{pdReturnType = (Single (Scalar _))} -> True - _ -> False - -procTableName :: ProcDescription -> Maybe TableName -procTableName proc = case pdReturnType proc of - SetOf (Composite qi) -> Just $ qiName qi - Single (Composite qi) -> Just $ qiName qi - _ -> Nothing - -type Schema = Text -type TableName = Text - -data Table = Table { - tableSchema :: Schema -, tableName :: TableName -, tableDescription :: Maybe Text -, tableInsertable :: Bool -} deriving (Show, Ord) - -instance Eq Table where - Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2 - -tableQi :: Table -> QualifiedIdentifier -tableQi Table{tableSchema=s, tableName=n} = QualifiedIdentifier s n - -newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord) - -data Column = - Column { - colTable :: Table - , colName :: FieldName - , 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) - -instance Eq Column where - Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2 - --- | The source table column a view column refers to -type SourceColumn = (Column, ViewColumn) -type ViewColumn = Column - -data PrimaryKey = PrimaryKey { - pkTable :: Table - , pkName :: Text -} deriving (Show, Eq) - -data OrderDirection = OrderAsc | OrderDesc deriving (Eq) -instance Show OrderDirection where - show OrderAsc = "ASC" - show OrderDesc = "DESC" - -data OrderNulls = OrderNullsFirst | OrderNullsLast deriving (Eq) -instance Show OrderNulls where - show OrderNullsFirst = "NULLS FIRST" - show OrderNullsLast = "NULLS LAST" - -data OrderTerm = OrderTerm { - otTerm :: Field -, otDirection :: Maybe OrderDirection -, otNullOrder :: Maybe OrderNulls -} deriving (Show, Eq) - -{-| - Represents a pg identifier with a prepended schema name "schema.table" - When qiSchema is "", the schema is defined by the pg search_path --} -data QualifiedIdentifier = QualifiedIdentifier { - qiSchema :: Schema -, qiName :: TableName -} deriving (Show, Eq, Ord, Generic) -instance Hashable QualifiedIdentifier - --- | The relationship [cardinality](https://en.wikipedia.org/wiki/Cardinality_(data_modeling)). --- | TODO: missing one-to-one -data Cardinality = O2M -- ^ one-to-many, previously known as Parent - | M2O -- ^ many-to-one, previously known as Child - | M2M -- ^ many-to-many, previously known as Many - deriving Eq -instance Show Cardinality where - show O2M = "o2m" - show M2O = "m2o" - show M2M = "m2m" - -type ConstraintName = Text - -{-| - "Relation"ship between two tables. - The order of the relColumns and relFColumns should be maintained to get the join conditions right. - TODO merge relColumns and relFColumns to a tuple or Data.Bimap --} -data Relation = Relation { - relTable :: Table -, relColumns :: [Column] -, relConstraint :: Maybe ConstraintName -- ^ Just on O2M/M2O, Nothing on M2M -, relFTable :: Table -, relFColumns :: [Column] -, relType :: Cardinality -, relJunction :: Maybe Junction -- ^ Junction for M2M Cardinality -} deriving (Show, Eq) - --- | Junction table on an M2M relationship -data Junction = Junction { - junTable :: Table -, junConstraint1 :: Maybe ConstraintName -, junCols1 :: [Column] -, junConstraint2 :: Maybe ConstraintName -, junCols2 :: [Column] -} deriving (Show, Eq) - -isSelfReference :: Relation -> Bool -isSelfReference r = relTable r == relFTable r - -data PayloadJSON = - -- | Cached attributes of a JSON payload - ProcessedJSON { - -- | This is the raw ByteString that comes from the request body. - -- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding - -- had high memory usage, see https://github.com/PostgREST/postgrest/pull/1005 for more details - pjRaw :: BL.ByteString - -- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects - , pjKeys :: S.Set Text - }| - RawJSON { - pjRaw :: BL.ByteString - } deriving (Show, Eq) - -data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq) - -data Proxy = Proxy { - proxyScheme :: Text -, proxyHost :: Text -, proxyPort :: Integer -, proxyPath :: Text -} deriving (Show, Eq) - -type Operator = Text -operators :: M.HashMap Operator SqlFragment -operators = M.union (M.fromList [ - ("eq", "="), - ("gte", ">="), - ("gt", ">"), - ("lte", "<="), - ("lt", "<"), - ("neq", "<>"), - ("like", "LIKE"), - ("ilike", "ILIKE"), - ("in", "IN"), - ("is", "IS"), - ("cs", "@>"), - ("cd", "<@"), - ("ov", "&&"), - ("sl", "<<"), - ("sr", ">>"), - ("nxr", "&<"), - ("nxl", "&>"), - ("adj", "-|-")]) ftsOperators - -ftsOperators :: M.HashMap Operator SqlFragment -ftsOperators = M.fromList [ - ("fts", "@@ to_tsquery"), - ("plfts", "@@ plainto_tsquery"), - ("phfts", "@@ phraseto_tsquery"), - ("wfts", "@@ websearch_to_tsquery") - ] - -data OpExpr = OpExpr Bool Operation deriving (Eq, Show) -data Operation = Op Operator SingleVal | - In ListVal | - Fts Operator (Maybe Language) SingleVal deriving (Eq, Show) -type Language = Text - --- | Represents a single value in a filter, e.g. id=eq.singleval -type SingleVal = Text --- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3) -type ListVal = [Text] - -data LogicOperator = And | Or deriving Eq -instance Show LogicOperator where - show And = "AND" - show Or = "OR" -{-| - Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is: - - And - / \ - name.eq.N Or - / \ - id.eq.1 id.eq.2 --} -data LogicTree = Expr Bool LogicOperator [LogicTree] | Stmnt Filter deriving (Show, Eq) - -type FieldName = Text -{-| - Json path operations as specified in https://www.postgresql.org/docs/9.4/static/functions-json.html --} -type JsonPath = [JsonOperation] --- | Represents the single arrow `->` or double arrow `->>` operators -data JsonOperation = JArrow{jOp :: JsonOperand} | J2Arrow{jOp :: JsonOperand} deriving (Show, Eq) --- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text because we reuse our escaping functons and let pg do the casting with '1'::int -data JsonOperand = JKey{jVal :: Text} | JIdx{jVal :: Text} deriving (Show, Eq) - -type Field = (FieldName, JsonPath) -type Alias = Text -type Cast = Text -type NodeName = Text - --- Rpc query param, only used for GET rpcs -type RpcQParam = (Text, Text) - -{-| - Custom guc header, it's obtained by parsing the json in a: - `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]' --} -newtype GucHeader = GucHeader (CI.CI ByteString, ByteString) - deriving (Show, Eq) - -instance JSON.FromJSON GucHeader where - parseJSON (JSON.Object o) = case headMay (M.toList o) of - Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s) - | otherwise -> mzero - _ -> mzero - parseJSON _ = mzero - -unwrapGucHeader :: GucHeader -> Header -unwrapGucHeader (GucHeader (k, v)) = (k, v) - --- | Add headers not already included to allow the user to override them instead of duplicating them -addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header] -addHeadersIfNotIncluded newHeaders initialHeaders = - filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++ - initialHeaders - -{-| - 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 SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint) --- | Disambiguates an embedding operation when there's multiple relationships between two tables. --- | Can be the name of a foreign key constraint, column name or the junction in an m2m relationship. -type EmbedHint = Text --- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"] -type EmbedPath = [Text] -data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq) -data JoinCondition = JoinCondition (QualifiedIdentifier, FieldName) - (QualifiedIdentifier, FieldName) deriving (Show, Eq) - -data ReadQuery = Select { - select :: [SelectItem] - , from :: QualifiedIdentifier --- | A table alias is used in case of self joins - , fromAlias :: Maybe Alias --- | Only used for Many to Many joins. Parent and Child joins use explicit joins. - , implicitJoins :: [QualifiedIdentifier] - , where_ :: [LogicTree] - , joinConditions :: [JoinCondition] - , order :: [OrderTerm] - , range_ :: NonnegRange -} deriving (Show, Eq) - -data MutateQuery = - Insert { - in_ :: QualifiedIdentifier - , insCols :: S.Set FieldName - , onConflict :: Maybe (PreferResolution, [FieldName]) - , where_ :: [LogicTree] - , returning :: [FieldName] - }| - Update { - in_ :: QualifiedIdentifier - , updCols :: S.Set FieldName - , where_ :: [LogicTree] - , returning :: [FieldName] - }| - Delete { - in_ :: QualifiedIdentifier - , where_ :: [LogicTree] - , returning :: [FieldName] - } deriving (Show, Eq) - -type ReadRequest = Tree ReadNode -type MutateRequest = MutateQuery - -type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth)) -type Depth = Integer - --- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d)) -fstFieldNames :: ReadRequest -> [FieldName] -fstFieldNames (Node (sel, _) _) = - fst . view _1 <$> select sel - -data PgVersion = PgVersion { - pgvNum :: Int32 -, pgvName :: Text -} deriving (Eq, Show) - -instance Ord PgVersion where - (PgVersion v1 _) `compare` (PgVersion v2 _) = v1 `compare` v2 - --- | Tells the minimum PostgreSQL version required by this version of PostgREST -minimumPgVersion :: PgVersion -minimumPgVersion = pgVersion94 - -pgVersion94 :: PgVersion -pgVersion94 = PgVersion 90400 "9.4" - -pgVersion95 :: PgVersion -pgVersion95 = PgVersion 90500 "9.5" - -pgVersion96 :: PgVersion -pgVersion96 = PgVersion 90600 "9.6" - -pgVersion100 :: PgVersion -pgVersion100 = PgVersion 100000 "10" - -pgVersion109 :: PgVersion -pgVersion109 = PgVersion 100009 "10.9" - -pgVersion110 :: PgVersion -pgVersion110 = PgVersion 110000 "11.0" - -pgVersion112 :: PgVersion -pgVersion112 = PgVersion 110002 "11.2" - -pgVersion114 :: PgVersion -pgVersion114 = PgVersion 110004 "11.4" - -pgVersion121 :: PgVersion -pgVersion121 = PgVersion 120001 "12.1" - -sourceCTEName :: SqlFragment -sourceCTEName = "pgrst_source" - --- | full jspath, e.g. .property[0].attr.detail -type JSPath = [JSPathExp] --- | jspath expression, e.g. .property, .property[0] or ."property-dash" -data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show) - --- | Current database connection status data ConnectionStatus -data ConnectionStatus - = NotConnected - | Connected PgVersion - | FatalConnectionError Text - deriving (Eq, Show) diff --git a/src/PostgREST/Unix.hs b/src/PostgREST/Unix.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Unix.hs @@ -0,0 +1,59 @@ +module PostgREST.Unix + ( runAppWithSocket + , installSignalHandlers + ) where + +import qualified Network.Socket as Socket +import qualified Network.Wai.Handler.Warp as Warp +import qualified System.Posix.Signals as Signals + +import Network.Wai (Application) +import System.Directory (removeFile) +import System.IO.Error (isDoesNotExistError) +import System.Posix.Files (setFileMode) +import System.Posix.Types (FileMode) + +import qualified PostgREST.AppState as AppState +import qualified PostgREST.Workers as Workers + +import Protolude + + +-- | Run the PostgREST application with user defined socket. +runAppWithSocket :: Warp.Settings -> Application -> FileMode -> FilePath -> IO () +runAppWithSocket settings app socketFileMode socketFilePath = + bracket createAndBindSocket Socket.close $ \socket -> do + Socket.listen socket Socket.maxListenQueue + Warp.runSettingsSocket settings socket app + where + createAndBindSocket = do + deleteSocketFileIfExist socketFilePath + sock <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol + Socket.bind sock $ Socket.SockAddrUnix socketFilePath + setFileMode socketFilePath socketFileMode + return sock + + deleteSocketFileIfExist path = + removeFile path `catch` handleDoesNotExist + + handleDoesNotExist e + | isDoesNotExistError e = return () + | otherwise = throwIO e + +-- | Set signal handlers, only for systems with signals +installSignalHandlers :: AppState.AppState -> IO () +installSignalHandlers appState = do + -- Releases the connection pool whenever the program is terminated, + -- see https://github.com/PostgREST/postgrest/issues/268 + install Signals.sigINT $ AppState.releasePool appState + install Signals.sigTERM $ AppState.releasePool appState + + -- The SIGUSR1 signal updates the internal 'DbStructure' by running + -- 'connectionWorker' exactly as before. + install Signals.sigUSR1 $ Workers.connectionWorker appState + + -- Re-read the config on SIGUSR2 + install Signals.sigUSR2 $ Workers.reReadConfig False appState + where + install signal handler = + void $ Signals.installHandler signal (Signals.Catch handler) Nothing diff --git a/src/PostgREST/Version.hs b/src/PostgREST/Version.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Version.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +module PostgREST.Version + ( docsVersion + , prettyVersion + ) where + +import qualified Data.Text as T + +import Data.Version (versionBranch) +import Development.GitRev (gitHash) +import Paths_postgrest (version) + +import Protolude + + +-- | User friendly version number +prettyVersion :: Text +prettyVersion = + T.intercalate "." (map show $ versionBranch version) <> gitRev + where + gitRev = + if $(gitHash) == "UNKNOWN" + then mempty + else " (" <> T.take 7 $(gitHash) <> ")" + +-- | Version number used in docs +docsVersion :: Text +docsVersion = "v" <> T.dropEnd 1 (T.dropWhileEnd (/= '.') prettyVersion) diff --git a/src/PostgREST/Workers.hs b/src/PostgREST/Workers.hs new file mode 100644 --- /dev/null +++ b/src/PostgREST/Workers.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module PostgREST.Workers + ( connectionWorker + , reReadConfig + , listener + ) where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString as BS +import qualified Hasql.Connection as C +import qualified Hasql.Notifications as N +import qualified Hasql.Pool as P +import qualified Hasql.Transaction.Sessions as HT + +import Control.Retry (RetryStatus, capDelay, exponentialBackoff, + retrying, rsPreviousDelay) + +import PostgREST.AppState (AppState) +import PostgREST.Config (AppConfig (..), readAppConfig) +import PostgREST.Config.Database (queryDbSettings, queryPgVersion) +import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion) +import PostgREST.DbStructure (queryDbStructure) +import PostgREST.Error (PgError (PgError), checkIsFatal, + errorPayload) + +import qualified PostgREST.AppState as AppState + +import Protolude hiding (head, toS) +import Protolude.Conv (toS) + + +-- | Current database connection status data ConnectionStatus +data ConnectionStatus + = NotConnected + | Connected PgVersion + | FatalConnectionError Text + deriving (Eq) + +-- | Schema cache status +data SCacheStatus + = SCLoaded + | SCOnRetry + | SCFatalFail + +-- | The purpose of this worker is to obtain a healthy connection to pg and an +-- up-to-date schema cache(DbStructure). This method is meant to be called +-- 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. +-- +-- 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. +-- 3. Obtains the dbStructure. If this fails, it goes back to 1. +connectionWorker :: AppState -> IO () +connectionWorker appState = do + isWorkerOn <- AppState.getIsWorkerOn appState + -- Prevents multiple workers to be running at the same time. Could happen on + -- too many SIGUSR1s. + unless isWorkerOn $ do + AppState.putIsWorkerOn appState True + void $ forkIO work + where + work = do + AppConfig{..} <- AppState.getConfig appState + AppState.logWithZTime appState "Attempting to connect to the database..." + connected <- connectionStatus appState + case connected of + FatalConnectionError reason -> + -- Fatal error when connecting + AppState.logWithZTime appState reason >> killThread (AppState.getMainThreadId appState) + NotConnected -> + -- Unreachable because connectionStatus will keep trying to connect + return () + Connected actualPgVersion -> do + -- Procede with initialization + AppState.putPgVersion appState actualPgVersion + when configDbChannelEnabled $ + AppState.signalListener appState + AppState.logWithZTime appState "Connection successful" + -- this could be fail because the connection drops, but the + -- loadSchemaCache will pick the error and retry again + when configDbConfig $ reReadConfig False appState + scStatus <- loadSchemaCache appState + case scStatus of + SCLoaded -> + -- do nothing and proceed if the load was successful + return () + SCOnRetry -> + work + SCFatalFail -> + -- die if our schema cache query has an error + killThread $ AppState.getMainThreadId appState + AppState.putIsWorkerOn appState False + +-- | Check if a connection from the pool allows access to the PostgreSQL +-- database. If not, the pool connections are released and a new connection is +-- tried. Releasing the pool is key for rapid recovery. Otherwise, the pool +-- timeout would have to be reached for new healthy connections to be acquired. +-- Which might not happen if the server is busy with requests. No idle +-- connection, no pool timeout. +-- +-- The connection tries are capped, but if the connection times out no error is +-- thrown, just 'False' is returned. +connectionStatus :: AppState -> IO ConnectionStatus +connectionStatus appState = + retrying retrySettings shouldRetry $ + const $ P.release pool >> getConnectionStatus + where + pool = AppState.getPool appState + retrySettings = capDelay delayMicroseconds $ exponentialBackoff backoffMicroseconds + delayMicroseconds = 32000000 -- 32 seconds + backoffMicroseconds = 1000000 -- 1 second + + getConnectionStatus :: IO ConnectionStatus + getConnectionStatus = do + pgVersion <- P.use pool queryPgVersion + case pgVersion of + Left e -> do + let err = PgError False e + AppState.logWithZTime appState . toS $ errorPayload err + case checkIsFatal err of + Just reason -> + return $ FatalConnectionError reason + Nothing -> + return NotConnected + Right version -> + if version < minimumPgVersion then + return . FatalConnectionError $ + "Cannot run in this PostgreSQL version, PostgREST needs at least " + <> pgvName minimumPgVersion + else + return . Connected $ version + + shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool + shouldRetry rs isConnSucc = do + let + delay = fromMaybe 0 (rsPreviousDelay rs) `div` backoffMicroseconds + itShould = NotConnected == isConnSucc + when itShould . AppState.logWithZTime appState $ + "Attempting to reconnect to the database in " + <> (show delay::Text) + <> " seconds..." + return itShould + +-- | Load the DbStructure by using a connection from the pool. +loadSchemaCache :: AppState -> IO SCacheStatus +loadSchemaCache appState = do + AppConfig{..} <- AppState.getConfig appState + result <- + let transaction = if configDbPreparedStatements then HT.transaction else HT.unpreparedTransaction in + P.use (AppState.getPool appState) . transaction HT.ReadCommitted HT.Read $ + queryDbStructure (toList configDbSchemas) configDbExtraSearchPath configDbPreparedStatements + case result of + Left e -> do + let + err = PgError False e + putErr = AppState.logWithZTime appState . toS $ errorPayload err + case checkIsFatal err of + Just hint -> do + AppState.logWithZTime appState "A fatal error ocurred when loading the schema cache" + putErr + AppState.logWithZTime appState hint + return SCFatalFail + Nothing -> do + AppState.logWithZTime appState "An error ocurred when loading the schema cache" + putErr + return SCOnRetry + + Right dbStructure -> do + AppState.putDbStructure appState dbStructure + when (isJust configDbRootSpec) $ + AppState.putJsonDbS appState $ toS $ JSON.encode dbStructure + AppState.logWithZTime appState "Schema cache loaded" + return SCLoaded + +-- | Starts a dedicated pg connection to LISTEN for notifications. When a +-- NOTIFY - with an empty payload - is done, it refills the schema +-- cache. It uses the connectionWorker in case the LISTEN connection dies. +listener :: AppState -> IO () +listener appState = do + AppConfig{..} <- AppState.getConfig appState + let dbChannel = toS configDbChannel + + -- The listener has to wait for a signal from the connectionWorker. + -- This is because when the connection to the db is lost, the listener also + -- tries to recover the connection, but not with the same pace as the connectionWorker. + -- Not waiting makes stderr quickly fill with connection retries messages from the listener. + AppState.waitListener appState + + -- forkFinally allows to detect if the thread dies + void . flip forkFinally (handleFinally dbChannel) $ do + dbOrError <- C.acquire $ toS configDbUri + case dbOrError of + Right db -> do + AppState.logWithZTime appState $ "Listening for notifications on the " <> dbChannel <> " channel" + N.listen db $ N.toPgIdentifier dbChannel + N.waitForNotifications handleNotification db + _ -> + die $ "Could not listen for notifications on the " <> dbChannel <> " channel" + where + handleFinally dbChannel _ = do + -- if the thread dies, we try to recover + AppState.logWithZTime appState $ "Retrying listening for notifications on the " <> dbChannel <> " channel.." + -- assume the pool connection was also lost, call the connection worker + connectionWorker appState + -- retry the listener + listener appState + + handleNotification _ msg + | BS.null msg = scLoader -- reload the schema cache + | msg == "reload schema" = scLoader -- reload the schema cache + | msg == "reload config" = reReadConfig False appState -- reload the config + | otherwise = pure () -- Do nothing if anything else than an empty message is sent + + scLoader = + -- It's not necessary to check the loadSchemaCache success + -- here. If the connection drops, the thread will die and + -- proceed to recover. + void $ loadSchemaCache appState + +-- | Re-reads the config plus config options from the db +reReadConfig :: Bool -> AppState -> IO () +reReadConfig startingUp appState = do + AppConfig{..} <- AppState.getConfig appState + dbSettings <- + if configDbConfig then do + qDbSettings <- queryDbSettings (AppState.getPool appState) configDbPreparedStatements + case qDbSettings of + Left e -> do + let + err = PgError False e + putErr = AppState.logWithZTime appState . toS $ errorPayload err + AppState.logWithZTime appState + "An error ocurred when trying to query database settings for the config parameters" + case checkIsFatal err of + Just hint -> do + putErr + AppState.logWithZTime appState hint + killThread (AppState.getMainThreadId appState) + Nothing -> do + AppState.logWithZTime appState $ show e + pure [] + Right x -> pure x + else + pure mempty + readAppConfig dbSettings configFilePath (Just configDbUri) >>= \case + Left err -> + if startingUp then + panic err -- die on invalid config if the program is starting up + else + AppState.logWithZTime appState $ "Failed re-loading config: " <> err + Right newConf -> do + AppState.putConfig appState newConf + if startingUp then + pass + else + AppState.logWithZTime appState "Config re-loaded" diff --git a/test/Feature/AndOrParamsSpec.hs b/test/Feature/AndOrParamsSpec.hs --- a/test/Feature/AndOrParamsSpec.hs +++ b/test/Feature/AndOrParamsSpec.hs @@ -7,8 +7,9 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import PostgREST.Types (PgVersion, pgVersion112) -import Protolude hiding (get) +import PostgREST.Config.PgVersion (PgVersion, pgVersion112) + +import Protolude hiding (get) import SpecHelper spec :: PgVersion -> SpecWith ((), Application) @@ -33,13 +34,24 @@ {"id": 1, "child_entities": [ { "id": 1 }, { "id": 2 } ] }, { "id": 2, "child_entities": []}, {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []} ]|] { matchHeaders = [matchContentTypeJson] } + it "can do logic on the third level" $ - get "/entities?child_entities.grandchild_entities.or=(id.eq.1,id.eq.2)&select=id,child_entities(id,grandchild_entities(id))" `shouldRespondWith` - [json|[ - {"id": 1, "child_entities": [ { "id": 1, "grandchild_entities": [ { "id": 1 }, { "id": 2 } ]}, { "id": 2, "grandchild_entities": []}]}, - {"id": 2, "child_entities": [ { "id": 3, "grandchild_entities": []} ]}, - {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []} - ]|] { matchHeaders = [matchContentTypeJson] } + get "/entities?child_entities.grandchild_entities.or=(id.eq.1,id.eq.2)&select=id,child_entities(id,grandchild_entities(id))" + `shouldRespondWith` + [json|[ + {"id": 1, "child_entities": [ + { "id": 1, "grandchild_entities": [ { "id": 1 }, { "id": 2 } ]}, + { "id": 2, "grandchild_entities": []}, + { "id": 4, "grandchild_entities": []}, + { "id": 5, "grandchild_entities": []} + ]}, + {"id": 2, "child_entities": [ + { "id": 3, "grandchild_entities": []}, + { "id": 6, "grandchild_entities": []} + ]}, + {"id": 3, "child_entities": []}, + {"id": 4, "child_entities": []} + ]|] context "and/or params combined" $ do it "can be nested inside the same expression" $ @@ -210,12 +222,15 @@ context "used with POST" $ it "includes related data with filters" $ request methodPost "/child_entities?select=id,entities(id)&entities.or=(id.eq.2,id.eq.3)&entities.order=id" - [("Prefer", "return=representation")] - [json|[{"id":4,"name":"entity 4","parent_id":1}, - {"id":5,"name":"entity 5","parent_id":2}, - {"id":6,"name":"entity 6","parent_id":3}]|] `shouldRespondWith` - [json|[{"id": 4, "entities":null}, {"id": 5, "entities": {"id": 2}}, {"id": 6, "entities": {"id": 3}}]|] - { matchStatus = 201, matchHeaders = [matchContentTypeJson] } + [("Prefer", "return=representation")] + [json|[ + {"id":7,"name":"entity 4","parent_id":1}, + {"id":8,"name":"entity 5","parent_id":2}, + {"id":9,"name":"entity 6","parent_id":3} + ]|] + `shouldRespondWith` + [json|[{"id": 7, "entities":null}, {"id": 8, "entities": {"id": 2}}, {"id": 9, "entities": {"id": 3}}]|] + { matchStatus = 201 } context "used with PATCH" $ it "succeeds when using and/or params" $ @@ -228,9 +243,10 @@ context "used with DELETE" $ it "succeeds when using and/or params" $ request methodDelete "/grandchild_entities?or=(id.eq.1,id.eq.2)&select=id,name" - [("Prefer", "return=representation")] "" `shouldRespondWith` - [json|[{ "id": 1, "name" : "updated grandchild entity"},{ "id": 2, "name" : "updated grandchild entity"}]|] - { matchHeaders = [matchContentTypeJson] } + [("Prefer", "return=representation")] + "" + `shouldRespondWith` + [json|[{ "id": 1, "name" : "grandchild entity 1" },{ "id": 2, "name" : "grandchild entity 2" }]|] it "can query columns that begin with and/or reserved words" $ get "/grandchild_entities?or=(and_starting_col.eq.smth, or_starting_col.eq.smth)" `shouldRespondWith` 200 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -6,10 +6,10 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Text.Heredoc -import PostgREST.Types (PgVersion, pgVersion112) -import Protolude hiding (get) +import PostgREST.Config.PgVersion (PgVersion, pgVersion112) + +import Protolude hiding (get) import SpecHelper spec :: PgVersion -> SpecWith ((), Application) @@ -85,7 +85,7 @@ it "sql functions can read custom and standard claims variables" $ do let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwfQ.V5fEpXfpb7feqwVqlcDleFdKu86bdwU2cBRT4fcMhXg" request methodPost "/rpc/reveal_big_jwt" [auth] "{}" - `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|] + `shouldRespondWith` [json|[{"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.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0" @@ -148,7 +148,7 @@ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6MX0.gKw7qI50i9hMrSJW8BlTpdMEVmMXJYxlAqueGqpa_mE" in request methodPost "/rpc/get_current_user" [auth] [json| {} |] - `shouldRespondWith` [str|"postgrest_test_author"|] + `shouldRespondWith` [json|"postgrest_test_author"|] { matchStatus = 200 , matchHeaders = [] } @@ -157,7 +157,7 @@ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpZCI6Mn0.nwzjMI0YLvVGJQTeoCPEBsK983b__gxdpLXisBNaO2A" in request methodPost "/rpc/get_current_user" [auth] [json| {} |] - `shouldRespondWith` [str|"postgrest_test_default_role"|] + `shouldRespondWith` [json|"postgrest_test_default_role"|] { matchStatus = 200 , matchHeaders = [] } @@ -166,7 +166,14 @@ 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"}|] + `shouldRespondWith` [json|{"hint":"Please contact administrator","details":null,"code":"P0001","message":"Disabled ID --> 3"}|] { matchStatus = 400 , matchHeaders = [] } + + it "allows 'Bearer' and 'bearer' as authentication schemes" $ do + let token = "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0" + request methodGet "/authors_only" [authHeader "Bearer" token] "" + `shouldRespondWith` 200 + request methodGet "/authors_only" [authHeader "bearer" token] "" + `shouldRespondWith` 200 diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -6,7 +6,6 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Text.Heredoc import Protolude hiding (get) @@ -23,7 +22,7 @@ it "returns the deleted item and count if requested" $ request methodDelete "/items?id=eq.2" [("Prefer", "return=representation"), ("Prefer", "count=exact")] "" - `shouldRespondWith` [str|[{"id":2}]|] + `shouldRespondWith` [json|[{"id":2}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "*/1"] } @@ -42,28 +41,20 @@ it "returns the deleted item and shapes the response" $ request methodDelete "/complex_items?id=eq.2&select=id,name" [("Prefer", "return=representation")] "" - `shouldRespondWith` [str|[{"id":2,"name":"Two"}]|] + `shouldRespondWith` [json|[{"id":2,"name":"Two"}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "*/*"] } it "can rename and cast the selected columns" $ request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] "" - `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|] + `shouldRespondWith` [json|[{"ciId":"3","ciName":"Three"}]|] it "can embed (parent) entities" $ request methodDelete "/tasks?id=eq.8&select=id,name,project:projects(id)" [("Prefer", "return=representation")] "" - `shouldRespondWith` [str|[{"id":8,"name":"Code OSX","project":{"id":4}}]|] + `shouldRespondWith` [json|[{"id":8,"name":"Code OSX","project":{"id":4}}]|] { matchStatus = 200 , matchHeaders = ["Content-Range" <:> "*/*"] - } - - it "actually clears items ouf the db" $ do - _ <- request methodDelete "/items?id=lt.15" [] "" - get "/items" - `shouldRespondWith` [str|[{"id":15}]|] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-0/*"] } context "known route, no records matched" $ diff --git a/test/Feature/DisabledOpenApiSpec.hs b/test/Feature/DisabledOpenApiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/DisabledOpenApiSpec.hs @@ -0,0 +1,20 @@ +module Feature.DisabledOpenApiSpec where + +import Network.HTTP.Types +import Network.Wai (Application) + +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai + +import Protolude + +spec :: SpecWith ((), Application) +spec = + describe "Disabled OpenApi" $ do + it "does not accept application/openapi+json and responds with 415" $ + request methodGet "/" + [("Accept","application/openapi+json")] "" `shouldRespondWith` 415 + + it "accepts application/json and responds with 404" $ + request methodGet "/" + [("Accept","application/json")] "" `shouldRespondWith` 404 diff --git a/test/Feature/EmbedDisambiguationSpec.hs b/test/Feature/EmbedDisambiguationSpec.hs --- a/test/Feature/EmbedDisambiguationSpec.hs +++ b/test/Feature/EmbedDisambiguationSpec.hs @@ -5,7 +5,6 @@ import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Text.Heredoc import Protolude hiding (get) import SpecHelper @@ -154,7 +153,7 @@ it "can embed parent with view!fk and grandparent by using fk" $ get "/tasks?id=eq.1&select=id,name,projects_view!project(id,name,client(id,name))" `shouldRespondWith` - [str|[{"id":1,"name":"Design w7","projects_view":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] + [json|[{"id":1,"name":"Design w7","projects_view":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] it "can embed by using a composite FK name" $ get "/unit_workdays?select=unit_id,day,fst_shift(car_id,schedule(name)),snd_shift(camera_id,schedule(name))" `shouldRespondWith` @@ -185,7 +184,9 @@ it "fails if the fk is not known" $ get "/message?select=id,sender:person!space(name)&id=lt.4" `shouldRespondWith` - [json|{"message":"Could not find foreign keys between these entities. No relationship found between message and person"}|] + [json|{ + "hint":"If a new foreign key between these entities was created in the database, try reloading the schema cache.", + "message":"Could not find a relationship between message and person in the schema cache"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } @@ -195,9 +196,9 @@ { matchHeaders = [matchContentTypeJson] } it "can request two parents with fks" $ - get "/articleStars?select=createdAt,article(owner),user(name)&limit=1" `shouldRespondWith` - [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"owner": "postgrest_test_authenticator"},"user":{"name": "Angela Martin"}}]|] - { matchHeaders = [matchContentTypeJson] } + get "/articleStars?select=createdAt,article(id),user(name)&limit=1" + `shouldRespondWith` + [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"id": 1},"user":{"name": "Angela Martin"}}]|] it "can specify a view!fk" $ get "/message?select=id,body,sender:person_detail!message_sender_fkey(name,sent),recipient:person_detail!message_recipient_fkey(name,received)&id=lt.4" `shouldRespondWith` @@ -230,7 +231,7 @@ it "can embed parent by using view!column and grandparent by using the column" $ get "/tasks?id=eq.1&select=id,name,project:projects_view!project_id(id,name,client:client_id(id,name))" `shouldRespondWith` - [str|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] + [json|[{"id":1,"name":"Design w7","project":{"id":1,"name":"Windows 7","client":{"id":1,"name":"Microsoft"}}}]|] it "can specify table!column" $ get "/message?select=id,body,sender:person!sender(name),recipient:person!recipient(name)&id=lt.4" `shouldRespondWith` @@ -432,3 +433,29 @@ [json|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|] { matchHeaders = [matchContentTypeJson] } + context "m2m embed when there's a junction in an internal schema" $ do + -- https://github.com/PostgREST/postgrest/issues/1736 + it "works with no ambiguity when there's an exposed view of the junction" $ do + get "/screens?select=labels(name)" `shouldRespondWith` + [json|[{"labels":[{"name":"fruit"}]}, {"labels":[{"name":"vehicles"}]}, {"labels":[{"name":"vehicles"}, {"name":"fruit"}]}]|] + { matchHeaders = [matchContentTypeJson] } + get "/actors?select=*,films(*)" `shouldRespondWith` + [json|[ {"id":1,"name":"john","films":[{"id":12,"title":"douze commandements"}]}, + {"id":2,"name":"mary","films":[{"id":2001,"title":"odyssée de l'espace"}]}]|] + { matchHeaders = [matchContentTypeJson] } + it "doesn't work if the junction is only internal" $ + get "/end_1?select=end_2(*)" `shouldRespondWith` + [json|{ + "hint":"If a new foreign key between these entities was created in the database, try reloading the schema cache.", + "message":"Could not find a relationship between end_1 and end_2 in the schema cache"}|] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] } + it "shouldn't try to embed if the private junction has an exposed homonym" $ + -- ensures the "invalid reference to FROM-clause entry for table "rollen" error doesn't happen. + -- Ref: https://github.com/PostgREST/postgrest/issues/1587#issuecomment-734995669 + get "/schauspieler?select=filme(*)" `shouldRespondWith` + [json|{ + "hint":"If a new foreign key between these entities was created in the database, try reloading the schema cache.", + "message":"Could not find a relationship between schauspieler and filme in the schema cache"}|] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] } diff --git a/test/Feature/ExtraSearchPathSpec.hs b/test/Feature/ExtraSearchPathSpec.hs --- a/test/Feature/ExtraSearchPathSpec.hs +++ b/test/Feature/ExtraSearchPathSpec.hs @@ -6,7 +6,7 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Protolude +import Protolude hiding (get) import SpecHelper spec :: SpecWith ((), Application) @@ -34,3 +34,6 @@ request methodGet "/rpc/is_valid_isbn?input=978-0-393-04002-9" [] "" `shouldRespondWith` [json|true|] { matchHeaders = [matchContentTypeJson] } + + it "can detect fk relations through multiple views recursively when middle views are in extra search path" $ + get "/consumers_extra_view?select=*,orders_view(*)" `shouldRespondWith` 200 diff --git a/test/Feature/HtmlRawOutputSpec.hs b/test/Feature/HtmlRawOutputSpec.hs --- a/test/Feature/HtmlRawOutputSpec.hs +++ b/test/Feature/HtmlRawOutputSpec.hs @@ -26,5 +26,5 @@ | |] { matchStatus = 200 - , matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"] + , matchHeaders = ["Content-Type" <:> "text/html"] } diff --git a/test/Feature/IgnorePrivOpenApiSpec.hs b/test/Feature/IgnorePrivOpenApiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/IgnorePrivOpenApiSpec.hs @@ -0,0 +1,76 @@ +module Feature.IgnorePrivOpenApiSpec where + +import Control.Lens ((^?)) + +import Data.Aeson.Lens +import Data.Aeson.QQ + +import Network.HTTP.Types +import Network.Wai (Application) +import Network.Wai.Test (SResponse (..)) + +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai + +import Protolude hiding (get) +import SpecHelper + +spec :: SpecWith ((), Application) +spec = describe "OpenAPI Ignore Privileges" $ do + it "root path returns a valid openapi spec" $ do + validateOpenApiResponse [("Accept", "application/openapi+json")] + request methodHead "/" (acceptHdrs "application/openapi+json") "" + `shouldRespondWith` "" { matchStatus = 200 } + + describe "table" $ do + + it "includes privileged table even if user does not have permission" $ do + r <- simpleBody <$> get "/" + let tableTag = r ^? key "paths" . key "/authors_only" + . key "post" . key "tags" + . nth 0 + + liftIO $ tableTag `shouldBe` Just [aesonQQ|"authors_only"|] + + it "only includes tables that belong to another schema if the Accept-Profile header is used" $ do + r1 <- simpleBody <$> get "/" + let tableKey1 = r1 ^? key "paths" . key "/children" + + liftIO $ tableKey1 `shouldBe` Nothing + + r2 <- simpleBody <$> request methodGet "/" [("Accept-Profile", "v1")] "" + let tableKey2 = r2 ^? key "paths" . key "/children" + + liftIO $ tableKey2 `shouldNotBe` Nothing + + it "includes comments on tables" $ do + r <- simpleBody <$> get "/" + + let grandChildGet s = key "paths" . key "/grandchild_entities" . key "get" . key s + grandChildGetSummary = r ^? grandChildGet "summary" + grandChildGetDescription = r ^? grandChildGet "description" + + liftIO $ do + grandChildGetSummary `shouldBe` Just "grandchild_entities summary" + grandChildGetDescription `shouldBe` Just "grandchild_entities description\nthat spans\nmultiple lines" + + describe "RPC" $ do + + it "includes privileged function even if user does not have permission" $ do + r <- simpleBody <$> get "/" + let funcTag = r ^? key "paths" . key "/rpc/privileged_hello" + . key "post" . key "tags" + . nth 0 + + liftIO $ funcTag `shouldBe` Just [aesonQQ|"(rpc) privileged_hello"|] + + it "only includes functions that belong to another schema if the Accept-Profile header is used" $ do + r1 <- simpleBody <$> get "/" + let funcKey1 = r1 ^? key "paths" . key "/rpc/get_parents_below" + + liftIO $ funcKey1 `shouldBe` Nothing + + r2 <- simpleBody <$> request methodGet "/" [("Accept-Profile", "v1")] "" + let funcKey2 = r2 ^? key "paths" . key "/rpc/get_parents_below" + + liftIO $ funcKey2 `shouldNotBe` Nothing diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -1,22 +1,20 @@ module Feature.InsertSpec where -import qualified Data.Aeson as JSON - import Data.List (lookup) -import Data.Maybe (fromJust) import Network.Wai (Application) -import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus)) +import Network.Wai.Test (SResponse (simpleHeaders)) import Test.Hspec hiding (pendingWith) import Test.Hspec.Wai.Matcher (bodyEquals) -import TestTypes (CompoundPK (..), IncPK (..)) import Network.HTTP.Types import Test.Hspec.Wai import Test.Hspec.Wai.JSON import Text.Heredoc -import PostgREST.Types (PgVersion, pgVersion112) -import Protolude hiding (get) +import PostgREST.Config.PgVersion (PgVersion, pgVersion112, + pgVersion130) + +import Protolude hiding (get) import SpecHelper spec :: PgVersion -> SpecWith ((), Application) @@ -24,17 +22,16 @@ describe "Posting new record" $ do context "disparate json types" $ do it "accepts disparate json types" $ do - p <- post "/menagerie" + post "/menagerie" [json| { "integer": 13, "double": 3.14159, "varchar": "testing!" , "boolean": false, "date": "1900-01-01", "money": "$3.99" , "enum": "foo" - } |] - liftIO $ do - simpleBody p `shouldBe` "" - simpleStatus p `shouldBe` created201 - -- should not have content type set when body is empty - lookup hContentType (simpleHeaders p) `shouldBe` Nothing + } |] `shouldRespondWith` "" + { matchStatus = 201 + -- should not have content type set when body is empty + , matchHeaders = [matchHeaderAbsent hContentType] + } it "filters columns in result using &select" $ request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")] @@ -42,7 +39,7 @@ "integer": 14, "double": 3.14159, "varchar": "testing!" , "boolean": false, "date": "1900-01-01", "money": "$3.99" , "enum": "foo" - }] |] `shouldRespondWith` [str|[{"integer":14,"varchar":"testing!"}]|] + }] |] `shouldRespondWith` [json|[{"integer":14,"varchar":"testing!"}]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] } @@ -86,7 +83,7 @@ it "includes related data after insert" $ request methodPost "/projects?select=id,name,clients(id,name)" [("Prefer", "return=representation"), ("Prefer", "count=exact")] - [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` [str|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|] + [json|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` [json|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|] { matchStatus = 201 , matchHeaders = [ matchContentTypeJson , "Location" <:> "/projects?id=eq.6" @@ -96,109 +93,141 @@ it "can rename and cast the selected columns" $ request methodPost "/projects?select=pId:id::text,pName:name,cId:client_id::text" [("Prefer", "return=representation")] - [str|{"id":7,"name":"New Project","client_id":2}|] `shouldRespondWith` - [str|[{"pId":"7","pName":"New Project","cId":"2"}]|] + [json|{"id":7,"name":"New Project","client_id":2}|] `shouldRespondWith` + [json|[{"pId":"7","pName":"New Project","cId":"2"}]|] { matchStatus = 201 , matchHeaders = [ matchContentTypeJson , "Location" <:> "/projects?id=eq.7" , "Content-Range" <:> "*/*" ] } + it "should not throw and return location header when selecting without PK" $ + request methodPost "/projects?select=name,client_id" [("Prefer", "return=representation")] + [json|{"id":10,"name":"New Project","client_id":2}|] `shouldRespondWith` + [json|[{"name":"New Project","client_id":2}]|] + { matchStatus = 201 + , matchHeaders = [ matchContentTypeJson + , "Location" <:> "/projects?id=eq.10" + , "Content-Range" <:> "*/*" ] + } + + context "requesting headers only representation" $ + it "should not throw and return location header when selecting without PK" $ + request methodPost "/projects?select=name,client_id" [("Prefer", "return=headers-only")] + [json|{"id":11,"name":"New Project","client_id":2}|] `shouldRespondWith` "" + { matchStatus = 201 + , matchHeaders = [ "Location" <:> "/projects?id=eq.11" + , "Content-Range" <:> "*/*" ] + } + + context "requesting no representation" $ + it "should not throw and return no location header when selecting without PK" $ + request methodPost "/projects?select=name,client_id" [] + [json|{"id":12,"name":"New Project","client_id":2}|] `shouldRespondWith` "" + { matchStatus = 201 + , matchHeaders = [ matchHeaderAbsent hLocation ] + } + context "from an html form" $ it "accepts disparate json types" $ do - p <- request methodPost "/menagerie" - [("Content-Type", "application/x-www-form-urlencoded")] - ("integer=7&double=2.71828&varchar=forms+are+fun&" <> - "boolean=false&date=1900-01-01&money=$3.99&enum=foo") - liftIO $ do - simpleBody p `shouldBe` "" - simpleStatus p `shouldBe` created201 + request methodPost "/menagerie" + [("Content-Type", "application/x-www-form-urlencoded")] + ("integer=7&double=2.71828&varchar=forms+are+fun&" <> + "boolean=false&date=1900-01-01&money=$3.99&enum=foo") + `shouldRespondWith` + "" + { matchStatus = 201 } context "with no pk supplied" $ do context "into a table with auto-incrementing pk" $ - it "succeeds with 201 and link" $ do - p <- post "/auto_incrementing_pk" [json| { "non_nullable_string":"not null"} |] - liftIO $ do - simpleBody p `shouldBe` "" - simpleHeaders p `shouldSatisfy` matchHeader hLocation "/auto_incrementing_pk\\?id=eq\\.[0-9]+" - simpleStatus p `shouldBe` created201 - let Just location = lookup hLocation $ simpleHeaders p - r <- get location - let [record] = fromJust (JSON.decode $ simpleBody r :: Maybe [IncPK]) - liftIO $ do - incStr record `shouldBe` "not null" - incNullableStr record `shouldBe` Nothing + it "succeeds with 201 and location header" $ do + -- reset pk sequence first to make test repeatable + request methodPost "/rpc/reset_sequence" + [("Prefer", "tx=commit")] + [json|{"name": "auto_incrementing_pk_id_seq", "value": 2}|] + `shouldRespondWith` + [json|""|] + request methodPost "/auto_incrementing_pk" [("Prefer", "return=headers-only")] + [json| { "non_nullable_string":"not null"} |] + `shouldRespondWith` + "" + { matchStatus = 201 + , matchHeaders = [ "Location" <:> "/auto_incrementing_pk?id=eq.2" ] + } + context "into a table with simple pk" $ it "fails with 400 and error" $ post "/simple_pk" [json| { "extra":"foo"} |] `shouldRespondWith` - [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" violates not-null constraint"}|] + (if actualPgVersion >= pgVersion130 then + [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" of relation \"simple_pk\" violates not-null constraint"}|] + else + [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" violates not-null constraint"}|] + ) { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } context "into a table with no pk" $ do - it "succeeds with 201 and a link including all fields" $ do - p <- post "/no_pk" [json| { "a":"foo", "b":"bar" } |] - liftIO $ do - simpleBody p `shouldBe` "" - simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.foo&b=eq.bar" - simpleStatus p `shouldBe` created201 + it "succeeds with 201 but no location header" $ do + post "/no_pk" [json| { "a":"foo", "b":"bar" } |] + `shouldRespondWith` + "" + { matchStatus = 201 + , matchHeaders = [matchHeaderAbsent hLocation] + } it "returns full details of inserted record if asked" $ do - p <- request methodPost "/no_pk" - [("Prefer", "return=representation")] - [json| { "a":"bar", "b":"baz" } |] - liftIO $ do - simpleBody p `shouldBe` [json| [{ "a":"bar", "b":"baz" }] |] - simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz" - simpleStatus p `shouldBe` created201 + request methodPost "/no_pk" + [("Prefer", "return=representation")] + [json| { "a":"bar", "b":"baz" } |] + `shouldRespondWith` + [json| [{ "a":"bar", "b":"baz" }] |] + { matchStatus = 201 + , matchHeaders = [matchHeaderAbsent hLocation] + } it "returns empty array when no items inserted, and return=rep" $ do - p <- request methodPost "/no_pk" - [("Prefer", "return=representation")] - [json| [] |] - liftIO $ do - simpleBody p `shouldBe` [json| [] |] - simpleStatus p `shouldBe` created201 + request methodPost "/no_pk" + [("Prefer", "return=representation")] + [json| [] |] + `shouldRespondWith` + [json| [] |] + { matchStatus = 201 } it "can post nulls" $ do - p <- request methodPost "/no_pk" - [("Prefer", "return=representation")] - [json| { "a":null, "b":"foo" } |] - liftIO $ do - simpleBody p `shouldBe` [json| [{ "a":null, "b":"foo" }] |] - simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=is.null&b=eq.foo" - simpleStatus p `shouldBe` created201 + request methodPost "/no_pk" + [("Prefer", "return=representation")] + [json| { "a":null, "b":"foo" } |] + `shouldRespondWith` + [json| [{ "a":null, "b":"foo" }] |] + { matchStatus = 201 + , matchHeaders = [matchHeaderAbsent hLocation] + } context "with compound pk supplied" $ it "builds response location header appropriately" $ do - let inserted = [json| { "k1":12, "k2":"Rock & R+ll" } |] - expectedObj = CompoundPK 12 "Rock & R+ll" Nothing - expectedLoc = "/compound_pk?k1=eq.12&k2=eq.Rock%20%26%20R%2Bll" - p <- request methodPost "/compound_pk" - [("Prefer", "return=representation")] - inserted - liftIO $ do - JSON.decode (simpleBody p) `shouldBe` Just [expectedObj] - simpleStatus p `shouldBe` created201 - lookup hLocation (simpleHeaders p) `shouldBe` Just expectedLoc - - r <- get expectedLoc - liftIO $ do - JSON.decode (simpleBody r) `shouldBe` Just [expectedObj] - simpleStatus r `shouldBe` ok200 + request methodPost "/compound_pk" + [("Prefer", "return=representation")] + [json| { "k1":12, "k2":"Rock & R+ll" } |] + `shouldRespondWith` + [json|[ { "k1":12, "k2":"Rock & R+ll", "extra": null } ]|] + { matchStatus = 201 + , matchHeaders = [ "Location" <:> "/compound_pk?k1=eq.12&k2=eq.Rock%20%26%20R%2Bll" ] + } context "with bulk insert" $ it "returns 201 but no location header" $ do let bulkData = [json| [ {"k1":21, "k2":"hello world"} , {"k1":22, "k2":"bye for now"}] |] - p <- request methodPost "/compound_pk" [] bulkData - liftIO $ do - simpleStatus p `shouldBe` created201 - lookup hLocation (simpleHeaders p) `shouldBe` Nothing + request methodPost "/compound_pk" [] bulkData + `shouldRespondWith` + "" + { matchStatus = 201 + , matchHeaders = [matchHeaderAbsent hLocation] + } context "with invalid json payload" $ it "fails with 400 and error" $ @@ -224,12 +253,11 @@ context "attempting to insert a row with the same primary key" $ it "fails returning a 409 Conflict" $ - post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] + post "/simple_pk" + [json| { "k":"xyyx", "extra":"e1" } |] `shouldRespondWith` - [json|{"hint":null,"details":"Key (k)=(k1) already exists.","code":"23505","message":"duplicate key value violates unique constraint \"contacts_pkey\""}|] - { matchStatus = 409 - , matchHeaders = [matchContentTypeJson] - } + [json|{"hint":null,"details":"Key (k)=(xyyx) already exists.","code":"23505","message":"duplicate key value violates unique constraint \"simple_pk_pkey\""}|] + { matchStatus = 409 } context "attempting to insert a row with conflicting unique constraint" $ it "fails returning a 409 Conflict" $ @@ -238,24 +266,20 @@ context "jsonb" $ do it "serializes nested object" $ do let inserted = [json| { "data": { "foo":"bar" } } |] - location = "/json?data=eq.%7B%22foo%22%3A%22bar%22%7D" - request methodPost "/json" + request methodPost "/json_table" [("Prefer", "return=representation")] inserted - `shouldRespondWith` [str|[{"data":{"foo":"bar"}}]|] + `shouldRespondWith` [json|[{"data":{"foo":"bar"}}]|] { matchStatus = 201 - , matchHeaders = ["Location" <:> location] } it "serializes nested array" $ do let inserted = [json| { "data": [1,2,3] } |] - location = "/json?data=eq.%5B1%2C2%2C3%5D" - request methodPost "/json" + request methodPost "/json_table" [("Prefer", "return=representation")] inserted - `shouldRespondWith` [str|[{"data":[1,2,3]}]|] + `shouldRespondWith` [json|[{"data":[1,2,3]}]|] { matchStatus = 201 - , matchHeaders = ["Location" <:> location] } context "empty objects" $ do @@ -275,20 +299,35 @@ , matchHeaders = [] } - it "successfully inserts a row with all-default columns with prefer=rep" $ - request methodPost "/items" [("Prefer", "return=representation")] "{}" - `shouldRespondWith` [json|[{ id: 20 }]|] - { matchStatus = 201, - matchHeaders = [] - } + it "successfully inserts a row with all-default columns with prefer=rep" $ do + -- reset pk sequence first to make test repeatable + request methodPost "/rpc/reset_sequence" + [("Prefer", "tx=commit")] + [json|{"name": "items2_id_seq", "value": 20}|] + `shouldRespondWith` + [json|""|] - it "successfully inserts a row with all-default columns with prefer=rep and &select=" $ - request methodPost "/items?select=id" [("Prefer", "return=representation")] "{}" - `shouldRespondWith` [json|[{ id: 21 }]|] - { matchStatus = 201, - matchHeaders = [] - } + request methodPost "/items2" + [("Prefer", "return=representation")] + [json|{}|] + `shouldRespondWith` + [json|[{ id: 20 }]|] + { matchStatus = 201 } + it "successfully inserts a row with all-default columns with prefer=rep and &select=" $ do + -- reset pk sequence first to make test repeatable + request methodPost "/rpc/reset_sequence" + [("Prefer", "tx=commit")] + [json|{"name": "items3_id_seq", "value": 20}|] + `shouldRespondWith` + [json|""|] + + request methodPost "/items3?select=id" + [("Prefer", "return=representation")] + [json|{}|] + `shouldRespondWith` [json|[{ id: 20 }]|] + { matchStatus = 201 } + context "POST with ?columns parameter" $ do it "ignores json keys not included in ?columns" $ do request methodPost "/articles?columns=id,body" [("Prefer", "return=representation")] @@ -358,8 +397,7 @@ "a,b\nbar,baz" `shouldRespondWith` "a,b\nbar,baz" { matchStatus = 201 - , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8", - "Location" <:> "/no_pk?a=eq.bar&b=eq.baz"] + , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"] } it "can post nulls" $ @@ -368,8 +406,7 @@ "a,b\nNULL,foo" `shouldRespondWith` "a,b\n,foo" { matchStatus = 201 - , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8", - "Location" <:> "/no_pk?a=is.null&b=eq.foo"] + , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"] } it "only returns the requested column header with its associated data" $ @@ -393,294 +430,40 @@ context "with unicode values" $ it "succeeds and returns usable location header" $ do - let payload = [json| { "a":"圍棋", "b":"￥" } |] - p <- request methodPost "/no_pk" - [("Prefer", "return=representation")] - payload - liftIO $ do - simpleBody p `shouldBe` "["<>payload<>"]" - simpleStatus p `shouldBe` created201 + p <- request methodPost "/simple_pk2?select=extra,k" + [("Prefer", "tx=commit"), ("Prefer", "return=representation")] + [json| { "k":"圍棋", "extra":"￥" } |] + pure p `shouldRespondWith` + [json|[ { "k":"圍棋", "extra":"￥" } ]|] + { matchStatus = 201 } let Just location = lookup hLocation $ simpleHeaders p - r <- get location - liftIO $ simpleBody r `shouldBe` "["<>payload<>"]" - - describe "Patching record" $ do - context "to unknown uri" $ - it "indicates no table found by returning 404" $ - request methodPatch "/fake" [] - [json| { "real": false } |] - `shouldRespondWith` 404 - - context "on an empty table" $ - it "indicates no records found to update by returning 404" $ - request methodPatch "/empty_table" [] - [json| { "extra":20 } |] - `shouldRespondWith` "" - { matchStatus = 404, - matchHeaders = [] - } - - context "with invalid json payload" $ - it "fails with 400 and error" $ - request methodPatch "/simple_pk" [] "}{ x = 2" + get location `shouldRespondWith` - [json|{"message":"Error in $: Failed reading: not a valid json value at '}{x=2'"}|] - { matchStatus = 400, - matchHeaders = [matchContentTypeJson] - } + [json|[ { "k":"圍棋", "extra":"￥" } ]|] - context "with no payload" $ - it "fails with 400 and error" $ - request methodPatch "/items" [] "" + request methodDelete location + [("Prefer", "tx=commit")] + "" `shouldRespondWith` - [json|{"message":"Error in $: not enough input"}|] - { matchStatus = 400, - matchHeaders = [matchContentTypeJson] - } - - context "in a nonempty table" $ do - it "can update a single item" $ do - g <- get "/items?id=eq.42" - liftIO $ simpleHeaders g - `shouldSatisfy` matchHeader "Content-Range" "\\*/\\*" - p <- request methodPatch "/items?id=eq.2" [] [json| { "id":42 } |] - pure p `shouldRespondWith` "" - { matchStatus = 204, - matchHeaders = ["Content-Range" <:> "0-0/*"] - } - liftIO $ lookup hContentType (simpleHeaders p) `shouldBe` Nothing - - -- check it really got updated - g' <- get "/items?id=eq.42" - liftIO $ simpleHeaders g' - `shouldSatisfy` matchHeader "Content-Range" "0-0/\\*" - -- put value back for other tests - void $ request methodPatch "/items?id=eq.42" [] [json| { "id":2 } |] - - it "returns empty array when no rows updated and return=rep" $ - request methodPatch "/items?id=eq.999999" - [("Prefer", "return=representation")] [json| { "id":999999 } |] - `shouldRespondWith` "[]" - { - matchStatus = 404, - matchHeaders = [] - } - - it "gives a 404 when no rows updated" $ - request methodPatch "/items?id=eq.99999999" [] - [json| { "id": 42 } |] - `shouldRespondWith` 404 - - it "returns updated object as array when return=rep" $ - request methodPatch "/items?id=eq.2" - [("Prefer", "return=representation")] [json| { "id":2 } |] - `shouldRespondWith` [str|[{"id":2}]|] - { matchStatus = 200, - matchHeaders = ["Content-Range" <:> "0-0/*"] - } - - it "can update multiple items" $ do - replicateM_ 10 $ post "/auto_incrementing_pk" - [json| { non_nullable_string: "a" } |] - replicateM_ 10 $ post "/auto_incrementing_pk" - [json| { non_nullable_string: "b" } |] - _ <- request methodPatch - "/auto_incrementing_pk?non_nullable_string=eq.a" [] - [json| { non_nullable_string: "c" } |] - g <- get "/auto_incrementing_pk?non_nullable_string=eq.c" - liftIO $ simpleHeaders g - `shouldSatisfy` matchHeader "Content-Range" "0-9/\\*" - - it "can set a column to NULL" $ do - _ <- post "/no_pk" [json| { a: "keepme", b: "nullme" } |] - _ <- request methodPatch "/no_pk?b=eq.nullme" [] [json| { b: null } |] - get "/no_pk?a=eq.keepme" `shouldRespondWith` - [json| [{ a: "keepme", b: null }] |] - { matchHeaders = [matchContentTypeJson] } - - context "filtering by a computed column" $ do - it "is successful" $ - request methodPatch - "/items?is_first=eq.true" - [("Prefer", "return=representation")] - [json| { id: 100 } |] - `shouldRespondWith` [json| [{ id: 100 }] |] - { matchStatus = 200, - matchHeaders = [matchContentTypeJson, "Content-Range" <:> "0-0/*"] - } - - it "indicates no records updated by returning 404" $ - request methodPatch - "/items?always_true=eq.false" - [("Prefer", "return=representation")] - [json| { id: 100 } |] - `shouldRespondWith` "[]" - { matchStatus = 404, - matchHeaders = [] - } - - context "with representation requested" $ do - it "can provide a representation" $ do - _ <- post "/items" - [json| { id: 1 } |] - request methodPatch - "/items?id=eq.1" - [("Prefer", "return=representation")] - [json| { id: 99 } |] - `shouldRespondWith` [json| [{id:99}] |] - { matchHeaders = [matchContentTypeJson] } - -- put value back for other tests - void $ request methodPatch "/items?id=eq.99" [] [json| { "id":1 } |] - - it "can return computed columns" $ - request methodPatch - "/items?id=eq.1&select=id,always_true" - [("Prefer", "return=representation")] - [json| { id: 1 } |] - `shouldRespondWith` [json| [{ id: 1, always_true: true }] |] - { matchHeaders = [matchContentTypeJson] } - - it "can select overloaded computed columns" $ do - request methodPatch - "/items?id=eq.1&select=id,computed_overload" - [("Prefer", "return=representation")] - [json| { id: 1 } |] - `shouldRespondWith` [json| [{ id: 1, computed_overload: true }] |] - { matchHeaders = [matchContentTypeJson] } - request methodPatch - "/items2?id=eq.1&select=id,computed_overload" - [("Prefer", "return=representation")] - [json| { id: 1 } |] - `shouldRespondWith` [json| [{ id: 1, computed_overload: true }] |] - { matchHeaders = [matchContentTypeJson] } - - it "ignores ?select= when return not set or return=minimal" $ do - request methodPatch "/items?id=eq.1&select=id" [] [json| { id:1 } |] - `shouldRespondWith` "" - { - matchStatus = 204, - matchHeaders = ["Content-Range" <:> "0-0/*"] - } - request methodPatch "/items?id=eq.1&select=id" [("Prefer", "return=minimal")] [json| { id:1 } |] - `shouldRespondWith` "" - { - matchStatus = 204, - matchHeaders = ["Content-Range" <:> "0-0/*"] - } - - context "when patching with an empty body" $ do - it "makes no updates and returns 204 without return= and without ?select=" $ do - request methodPatch "/items" [] [json| {} |] - `shouldRespondWith` "" - { - matchStatus = 204, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - request methodPatch "/items" [] [json| [] |] - `shouldRespondWith` "" - { - matchStatus = 204, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - request methodPatch "/items" [] [json| [{}] |] - `shouldRespondWith` "" - { - matchStatus = 204, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - it "makes no updates and returns 204 without return= and with ?select=" $ do - request methodPatch "/items?select=id" [] [json| {} |] - `shouldRespondWith` "" - { - matchStatus = 204, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - request methodPatch "/items?select=id" [] [json| [] |] - `shouldRespondWith` "" - { - matchStatus = 204, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - request methodPatch "/items?select=id" [] [json| [{}] |] - `shouldRespondWith` "" - { - matchStatus = 204, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - it "makes no updates and returns 200 with return=rep and without ?select=" $ - request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |] - `shouldRespondWith` "[]" - { - matchStatus = 200, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - it "makes no updates and returns 200 with return=rep and with ?select=" $ - request methodPatch "/items?select=id" [("Prefer", "return=representation")] [json| {} |] - `shouldRespondWith` "[]" - { - matchStatus = 200, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - it "makes no updates and returns 200 with return=rep and with ?select= for overloaded computed columns" $ - request methodPatch "/items?select=id,computed_overload" [("Prefer", "return=representation")] [json| {} |] - `shouldRespondWith` "[]" - { - matchStatus = 200, - matchHeaders = ["Content-Range" <:> "*/*"] - } - - context "with unicode values" $ - it "succeeds and returns values intact" $ do - void $ request methodPost "/no_pk" [] - [json| { "a":"patchme", "b":"patchme" } |] - let payload = [json| { "a":"圍棋", "b":"￥" } |] - p <- request methodPatch "/no_pk?a=eq.patchme&b=eq.patchme" - [("Prefer", "return=representation")] payload - liftIO $ do - simpleBody p `shouldBe` "["<>payload<>"]" - simpleStatus p `shouldBe` ok200 - - context "PATCH with ?columns parameter" $ do - it "ignores json keys not included in ?columns" $ - request methodPatch "/articles?id=eq.200&columns=body" [("Prefer", "return=representation")] - [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith` - [json|[{"id": 200, "body": "Some real content", "owner": "postgrest_test_anonymous"}]|] - { matchStatus = 200 - , matchHeaders = [] } - - it "ignores json keys and gives 404 if no record updated" $ - request methodPatch "/articles?id=eq.2001&columns=body" [("Prefer", "return=representation")] - [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith` 404 + 204 describe "Row level permission" $ it "set user_id when inserting rows" $ do - 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" } |] - - p1 <- request methodPost "/authors_only" - [ auth, ("Prefer", "return=representation") ] - [json| { "secret": "nyancat" } |] - liftIO $ do - simpleBody p1 `shouldBe` [str|[{"owner":"jdoe","secret":"nyancat"}]|] - simpleStatus p1 `shouldBe` created201 + request methodPost "/authors_only" + [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0", ("Prefer", "return=representation") ] + [json| { "secret": "nyancat" } |] + `shouldRespondWith` + [json|[{"owner":"jdoe","secret":"nyancat"}]|] + { matchStatus = 201 } - p2 <- request methodPost "/authors_only" - -- jwt token for jroe - [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.2e7mx0U4uDcInlbJVOBGlrRufwqWLINDIEDC1vS0nw8", ("Prefer", "return=representation") ] - [json| { "secret": "lolcat", "owner": "hacker" } |] - liftIO $ do - simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|] - simpleStatus p2 `shouldBe` created201 + request methodPost "/authors_only" + -- jwt token for jroe + [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.2e7mx0U4uDcInlbJVOBGlrRufwqWLINDIEDC1vS0nw8", ("Prefer", "return=representation") ] + [json| { "secret": "lolcat", "owner": "hacker" } |] + `shouldRespondWith` + [json|[{"owner":"jroe","secret":"lolcat"}]|] + { matchStatus = 201 } context "tables with self reference foreign keys" $ do it "embeds parent after insert" $ @@ -693,75 +476,10 @@ , matchHeaders = [ matchContentTypeJson , "Location" <:> "/web_content?id=eq.6" ] } - it "embeds children after update" $ - request methodPatch "/web_content?id=eq.0&select=id,name,web_content(name)" - [("Prefer", "return=representation")] - [json|{"name": "tardis-patched"}|] - `shouldRespondWith` - [json| - [ { "id": 0, "name": "tardis-patched", "web_content": [ { "name": "fezz" }, { "name": "foo" }, { "name": "bar" } ]} ] - |] - { matchStatus = 200, - matchHeaders = [matchContentTypeJson] - } - - it "embeds parent, children and grandchildren after update" $ - request methodPatch "/web_content?id=eq.0&select=id,name,web_content(name,web_content(name)),parent_content:p_web_id(name)" - [("Prefer", "return=representation")] - [json|{"name": "tardis-patched-2"}|] - `shouldRespondWith` - [json| [ - { - "id": 0, - "name": "tardis-patched-2", - "parent_content": { "name": "wat" }, - "web_content": [ - { "name": "fezz", "web_content": [ { "name": "wut" } ] }, - { "name": "foo", "web_content": [] }, - { "name": "bar", "web_content": [] } - ] - } - ] |] - { matchStatus = 200, - matchHeaders = [matchContentTypeJson] - } - - it "embeds children after update without explicitly including the id in the ?select" $ - request methodPatch "/web_content?id=eq.0&select=name,web_content(name)" - [("Prefer", "return=representation")] - [json|{"name": "tardis-patched"}|] - `shouldRespondWith` - [json| - [ { "name": "tardis-patched", "web_content": [ { "name": "fezz" }, { "name": "foo" }, { "name": "bar" } ]} ] - |] - { matchStatus = 200, - matchHeaders = [matchContentTypeJson] - } - - it "embeds an M2M relationship plus parent after update" $ - request methodPatch "/users?id=eq.1&select=name,tasks(name,project:projects(name))" - [("Prefer", "return=representation")] - [json|{"name": "Kevin Malone"}|] - `shouldRespondWith` - [json|[ - { - "name": "Kevin Malone", - "tasks": [ - { "name": "Design w7", "project": { "name": "Windows 7" } }, - { "name": "Code w7", "project": { "name": "Windows 7" } }, - { "name": "Design w10", "project": { "name": "Windows 10" } }, - { "name": "Code w10", "project": { "name": "Windows 10" } } - ] - } - ]|] - { matchStatus = 200, - matchHeaders = [matchContentTypeJson] - } - context "table with limited privileges" $ do it "succeeds inserting if correct select is applied" $ request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")] - [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` [str|[{"article_id":2,"user_id":1}]|] + [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` [json|[{"article_id":2,"user_id":1}]|] { matchStatus = 201 , matchHeaders = [] } @@ -770,9 +488,9 @@ request methodPost "/limited_article_stars?select=article_id,user_id,created_at" [("Prefer", "return=representation")] [json| {"article_id": 2, "user_id": 2} |] `shouldRespondWith` ( if actualPgVersion >= pgVersion112 then - [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for view limited_article_stars"}|] + [json|{"hint":null,"details":null,"code":"42501","message":"permission denied for view limited_article_stars"}|] else - [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] + [json|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] ) { matchStatus = 401 , matchHeaders = [] @@ -782,28 +500,50 @@ request methodPost "/limited_article_stars" [("Prefer", "return=representation")] [json| {"article_id": 3, "user_id": 1} |] `shouldRespondWith` ( if actualPgVersion >= pgVersion112 then - [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for view limited_article_stars"}|] + [json|{"hint":null,"details":null,"code":"42501","message":"permission denied for view limited_article_stars"}|] else - [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] + [json|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] ) { matchStatus = 401 , matchHeaders = [] } it "can insert in a table with no select and return=minimal" $ do - p <- request methodPost "/insertonly" - [("Prefer", "return=minimal")] - [json| { "v":"some value" } |] - liftIO $ do - simpleBody p `shouldBe` "" - simpleStatus p `shouldBe` created201 + request methodPost "/insertonly" + [("Prefer", "return=minimal")] + [json| { "v":"some value" } |] + `shouldRespondWith` + "" + { matchStatus = 201 } - it "succeeds updating row and gives a 204 when using return=minimal" $ - request methodPatch "/app_users?id=eq.1" [("Prefer", "return=minimal")] - [json| { "password": "passxyz" } |] - `shouldRespondWith` 204 + describe "Inserting into VIEWs" $ do + context "requesting no representation" $ + it "succeeds with 201" $ + post "/compound_pk_view" + [json|{"k1":1,"k2":"test","extra":2}|] + `shouldRespondWith` + "" + { matchStatus = 201 + , matchHeaders = [ matchHeaderAbsent hLocation ] + } - it "can update without return=minimal and no explicit select" $ - request methodPatch "/app_users?id=eq.1" [] - [json| { "password": "passabc" } |] - `shouldRespondWith` 204 + context "requesting header only representation" $ do + it "returns a location header" $ + request methodPost "/compound_pk_view" [("Prefer", "return=headers-only")] + [json|{"k1":1,"k2":"test","extra":2}|] + `shouldRespondWith` + "" + { matchStatus = 201 + , matchHeaders = [ "Location" <:> "/compound_pk_view?k1=eq.1&k2=eq.test" + , "Content-Range" <:> "*/*" ] + } + + it "should not throw and return location header when a PK is null" $ + request methodPost "/test_null_pk_competitors_sponsors" [("Prefer", "return=headers-only")] + [json|{"id":1}|] + `shouldRespondWith` + "" + { matchStatus = 201 + , matchHeaders = [ "Location" <:> "/test_null_pk_competitors_sponsors?id=eq.1&sponsor_id=is.null" + , "Content-Range" <:> "*/*" ] + } diff --git a/test/Feature/JsonOperatorSpec.hs b/test/Feature/JsonOperatorSpec.hs --- a/test/Feature/JsonOperatorSpec.hs +++ b/test/Feature/JsonOperatorSpec.hs @@ -7,8 +7,10 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import PostgREST.Types (PgVersion, pgVersion112, pgVersion121) -import Protolude hiding (get) +import PostgREST.Config.PgVersion (PgVersion, pgVersion112, + pgVersion121, pgVersion95) + +import Protolude hiding (get) import SpecHelper spec :: PgVersion -> SpecWith ((), Application) @@ -139,20 +141,20 @@ context "filtering response" $ do it "can filter by properties inside json column" $ do - get "/json?data->foo->>bar=eq.baz" `shouldRespondWith` + get "/json_table?data->foo->>bar=eq.baz" `shouldRespondWith` [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |] { matchHeaders = [matchContentTypeJson] } - get "/json?data->foo->>bar=eq.fake" `shouldRespondWith` + get "/json_table?data->foo->>bar=eq.fake" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "can filter by properties inside json column using not" $ - get "/json?data->foo->>bar=not.eq.baz" `shouldRespondWith` + get "/json_table?data->foo->>bar=not.eq.baz" `shouldRespondWith` [json| [] |] { matchHeaders = [matchContentTypeJson] } it "can filter by properties inside json column using ->>" $ - get "/json?data->>id=eq.1" `shouldRespondWith` + get "/json_table?data->>id=eq.1" `shouldRespondWith` [json| [{"data": {"id": 1, "foo": {"bar": "baz"}}}] |] { matchHeaders = [matchContentTypeJson] } @@ -190,20 +192,63 @@ context "ordering response" $ do it "orders by a json column property asc" $ - get "/json?order=data->>id.asc" `shouldRespondWith` + get "/json_table?order=data->>id.asc" `shouldRespondWith` [json| [{"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}, {"data": {"id": 3}}] |] { matchHeaders = [matchContentTypeJson] } it "orders by a json column with two level property nulls first" $ - get "/json?order=data->foo->>bar.nullsfirst" `shouldRespondWith` + get "/json_table?order=data->foo->>bar.nullsfirst" `shouldRespondWith` [json| [{"data": {"id": 3}}, {"data": {"id": 0}}, {"data": {"id": 1, "foo": {"bar": "baz"}}}] |] { matchHeaders = [matchContentTypeJson] } context "Patching record, in a nonempty table" $ it "can set a json column to escaped value" $ do - _ <- post "/json" [json| { data: {"escaped":"bar"} } |] - request methodPatch "/json?data->>escaped=eq.bar" - [("Prefer", "return=representation")] - [json| { "data": { "escaped":" \"bar" } } |] - `shouldRespondWith` [json| [{ "data": { "escaped":" \"bar" } }] |] - { matchStatus = 200 , matchHeaders = [] } + request methodPatch "/json_table?data->>id=eq.3" + [("Prefer", "return=representation")] + [json| { "data": { "id":" \"escaped" } } |] + `shouldRespondWith` + [json| [{ "data": { "id":" \"escaped" } }] |] + + when (actualPgVersion >= pgVersion95) $ + context "json array negative index" $ do + it "can select with negative indexes" $ do + get "/json_arr?select=data->>-1::int&id=in.(1,2)" `shouldRespondWith` + [json| [{"data":3}, {"data":6}] |] + { matchHeaders = [matchContentTypeJson] } + get "/json_arr?select=data->0->>-2::int&id=in.(3,4)" `shouldRespondWith` + [json| [{"data":8}, {"data":7}] |] + { matchHeaders = [matchContentTypeJson] } + get "/json_arr?select=data->-2->>a&id=in.(5,6)" `shouldRespondWith` + [json| [{"a":"A"}, {"a":"[1,2,3]"}] |] + { matchHeaders = [matchContentTypeJson] } + + it "can filter with negative indexes" $ do + get "/json_arr?select=data&data->>-3=eq.1" `shouldRespondWith` + [json| [{"data":[1, 2, 3]}] |] + { matchHeaders = [matchContentTypeJson] } + get "/json_arr?select=data&data->-1->>-3=eq.11" `shouldRespondWith` + [json| [{"data":[[9, 8, 7], [11, 12, 13]]}] |] + { matchHeaders = [matchContentTypeJson] } + get "/json_arr?select=data&data->-1->>b=eq.B" `shouldRespondWith` + [json| [{"data":[{"a": "A"}, {"b": "B"}]}] |] + { matchHeaders = [matchContentTypeJson] } + get "/json_arr?select=data&data->-1->b->>-1=eq.5" `shouldRespondWith` + [json| [{"data":[{"a": [1,2,3]}, {"b": [4,5]}]}] |] + { matchHeaders = [matchContentTypeJson] } + + it "should fail on badly formed negatives" $ do + get "/json_arr?select=data->>-78xy" `shouldRespondWith` + [json| + {"details": "unexpected 'x' expecting digit, \"->\", \"::\" or end of input", + "message": "\"failed to parse select parameter (data->>-78xy)\" (line 1, column 11)"} |] + { matchStatus = 400, matchHeaders = [matchContentTypeJson] } + get "/json_arr?select=data->>--34" `shouldRespondWith` + [json| + {"details": "unexpected \"-\" expecting digit", + "message": "\"failed to parse select parameter (data->>--34)\" (line 1, column 9)"} |] + { matchStatus = 400, matchHeaders = [matchContentTypeJson] } + get "/json_arr?select=data->>-xy-4" `shouldRespondWith` + [json| + {"details":"unexpected \"x\" expecting digit", + "message":"\"failed to parse select parameter (data->>-xy-4)\" (line 1, column 9)"} |] + { matchStatus = 400, matchHeaders = [matchContentTypeJson] } diff --git a/test/Feature/MultipleSchemaSpec.hs b/test/Feature/MultipleSchemaSpec.hs --- a/test/Feature/MultipleSchemaSpec.hs +++ b/test/Feature/MultipleSchemaSpec.hs @@ -15,7 +15,7 @@ import Protolude import SpecHelper -import PostgREST.Types (PgVersion, pgVersion96) +import PostgREST.Config.PgVersion (PgVersion, pgVersion96) spec :: PgVersion -> SpecWith ((), Application) spec actualPgVersion = @@ -77,33 +77,37 @@ context "Inserting tables on different schemas" $ do it "succeeds inserting on default schema and returning it" $ - request methodPost "/children" [("Prefer", "return=representation")] [json|{"name": "child v1-1", "parent_id": 1}|] - `shouldRespondWith` - [json|[{"id":1, "name": "child v1-1", "parent_id": 1}]|] - { - matchStatus = 201 - , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"] - } + request methodPost "/children" + [("Prefer", "return=representation")] + [json|{"id": 0, "name": "child v1-1", "parent_id": 1}|] + `shouldRespondWith` + [json|[{"id": 0, "name": "child v1-1", "parent_id": 1}]|] + { + matchStatus = 201 + , matchHeaders = ["Content-Profile" <:> "v1"] + } it "succeeds inserting on the v1 schema and returning its parent" $ - request methodPost "/children?select=id,parent(*)" [("Prefer", "return=representation"), ("Content-Profile", "v1")] - [json|{"name": "child v1-2", "parent_id": 2}|] + request methodPost "/children?select=id,parent(*)" + [("Prefer", "return=representation"), ("Content-Profile", "v1")] + [json|{"id": 0, "name": "child v1-2", "parent_id": 2}|] `shouldRespondWith` - [json|[{"id":2, "parent": {"id": 2, "name": "parent v1-2"}}]|] - { - matchStatus = 201 - , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v1"] - } + [json|[{"id": 0, "parent": {"id": 2, "name": "parent v1-2"}}]|] + { + matchStatus = 201 + , matchHeaders = ["Content-Profile" <:> "v1"] + } it "succeeds inserting on the v2 schema and returning its parent" $ - request methodPost "/children?select=id,parent(*)" [("Prefer", "return=representation"), ("Content-Profile", "v2")] - [json|{"name": "child v2-3", "parent_id": 3}|] + request methodPost "/children?select=id,parent(*)" + [("Prefer", "return=representation"), ("Content-Profile", "v2")] + [json|{"id": 0, "name": "child v2-3", "parent_id": 3}|] `shouldRespondWith` - [json|[{"id":1, "parent": {"id": 3, "name": "parent v2-3"}}]|] - { - matchStatus = 201 - , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"] - } + [json|[{"id": 0, "parent": {"id": 3, "name": "parent v2-3"}}]|] + { + matchStatus = 201 + , matchHeaders = ["Content-Profile" <:> "v2"] + } it "fails when inserting on an unknown schema" $ request methodPost "/children" [("Content-Profile", "unknown")] @@ -180,18 +184,12 @@ } it "succeeds on deleting on the v2 schema" $ do - request methodDelete "/children?id=eq.1" [("Content-Profile", "v2"), ("Prefer", "return=representation")] "" - `shouldRespondWith` [json|[{"id": 1, "name": "child v2-1 updated", "parent_id": 3}]|] - { - matchStatus = 200 - , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"] - } - request methodGet "/children?id=eq.1" [("Accept-Profile", "v2")] "" - `shouldRespondWith` "[]" - { - matchStatus = 200 - , matchHeaders = [matchContentTypeJson, "Content-Profile" <:> "v2"] - } + request methodDelete "/children?id=eq.1" + [("Content-Profile", "v2"), ("Prefer", "return=representation")] + "" + `shouldRespondWith` + [json|[{"id": 1, "name": "child v2-3", "parent_id": 3}]|] + { matchHeaders = ["Content-Profile" <:> "v2"] } when (actualPgVersion >= pgVersion96) $ it "succeeds on PUT on the v2 schema" $ diff --git a/test/Feature/OpenApiSpec.hs b/test/Feature/OpenApiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/OpenApiSpec.hs @@ -0,0 +1,504 @@ +module Feature.OpenApiSpec where + +import Control.Lens ((^?)) +import Data.Aeson.Types (Value (..)) +import Network.Wai (Application) +import Network.Wai.Test (SResponse (..)) + +import Data.Aeson.Lens +import Data.Aeson.QQ +import Network.HTTP.Types +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai + +import PostgREST.Version (docsVersion) +import Protolude hiding (get) +import SpecHelper + +spec :: SpecWith ((), Application) +spec = describe "OpenAPI" $ do + it "root path returns a valid openapi spec" $ do + validateOpenApiResponse [("Accept", "application/openapi+json")] + request methodHead "/" (acceptHdrs "application/openapi+json") "" + `shouldRespondWith` "" { matchStatus = 200 } + + it "should respond to openapi request on none root path with 415" $ + request methodGet "/items" + (acceptHdrs "application/openapi+json") "" + `shouldRespondWith` 415 + + it "includes postgrest.org current version api docs" $ do + r <- simpleBody <$> get "/" + + let docsUrl = r ^? key "externalDocs" . key "url" + + liftIO $ docsUrl `shouldBe` Just (String ("https://postgrest.org/en/" <> docsVersion <> "/api.html")) + + describe "table" $ do + + it "includes paths to tables" $ do + r <- simpleBody <$> get "/" + + 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" + postParameters = r ^? method "post" . 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 + + 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" } + ] + |] + + postParameters `shouldBe` Just + [aesonQQ| + [ + { "$ref": "#/parameters/body.child_entities" }, + { "$ref": "#/parameters/select" }, + { "$ref": "#/parameters/preferReturn" } + ] + |] + + postResponse `shouldBe` Just "Created" + + patchResponse `shouldBe` Just "No Content" + + deleteResponse `shouldBe` Just "No Content" + + it "includes an array type for GET responses" $ do + r <- simpleBody <$> get "/" + + let childGetSchema = r ^? key "paths" + . key "/child_entities" + . key "get" + . key "responses" + . key "200" + . key "schema" + + liftIO $ + childGetSchema `shouldBe` Just + [aesonQQ| + { + "items": { + "$ref": "#/definitions/child_entities" + }, + "type": "array" + } + |] + + 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.", + "format": "integer", + "type": "integer" + }, + "name": { + "description": "child_entities name comment. Can be longer than sixty-three characters long", + "format": "text", + "type": "string" + }, + "parent_id": { + "description": "Note:\nThis is a Foreign Key to `entities.id`.", + "format": "integer", + "type": "integer" + } + }, + "required": [ + "id" + ] + } + |] + + it "doesn't include privileged table for anonymous" $ do + r <- simpleBody <$> get "/" + let tablePath = r ^? key "paths" . key "/authors_only" + + liftIO $ tablePath `shouldBe` Nothing + + it "includes table if user has permission" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" + r <- simpleBody <$> request methodGet "/" [auth] "" + let tableTag = r ^? key "paths" . key "/authors_only" + . key "post" . key "tags" + . nth 0 + liftIO $ tableTag `shouldBe` Just [aesonQQ|"authors_only"|] + + describe "Foreign table" $ + + it "includes foreign table properties" $ do + r <- simpleBody <$> get "/" + + let method s = key "paths" . key "/projects_dump" . key s + getSummary = r ^? method "get" . key "summary" + getDescription = r ^? method "get" . key "description" + getParameters = r ^? method "get" . key "parameters" + + liftIO $ do + + getSummary `shouldBe` Just "A temporary projects dump" + + getDescription `shouldBe` Just "Just a test for foreign tables" + + getParameters `shouldBe` Just + [aesonQQ| + [ + { "$ref": "#/parameters/rowFilter.projects_dump.id" }, + { "$ref": "#/parameters/rowFilter.projects_dump.name" }, + { "$ref": "#/parameters/rowFilter.projects_dump.client_id" }, + { "$ref": "#/parameters/select" }, + { "$ref": "#/parameters/order" }, + { "$ref": "#/parameters/range" }, + { "$ref": "#/parameters/rangeUnit" }, + { "$ref": "#/parameters/offset" }, + { "$ref": "#/parameters/limit" }, + { "$ref": "#/parameters/preferCount" } + ] + |] + + describe "Materialized view" $ + + it "includes materialized view properties" $ do + r <- simpleBody <$> get "/" + + let method s = key "paths" . key "/materialized_projects" . key s + summary = r ^? method "get" . key "summary" + description = r ^? method "get" . key "description" + parameters = r ^? method "get" . key "parameters" + + liftIO $ do + + summary `shouldBe` Just "A materialized view for projects" + + description `shouldBe` Just "Just a test for materialized views" + + parameters `shouldBe` Just + [aesonQQ| + [ + { "$ref": "#/parameters/rowFilter.materialized_projects.id" }, + { "$ref": "#/parameters/rowFilter.materialized_projects.name" }, + { "$ref": "#/parameters/rowFilter.materialized_projects.client_id" }, + { "$ref": "#/parameters/select" }, + { "$ref": "#/parameters/order" }, + { "$ref": "#/parameters/range" }, + { "$ref": "#/parameters/rangeUnit" }, + { "$ref": "#/parameters/offset" }, + { "$ref": "#/parameters/limit" }, + { "$ref": "#/parameters/preferCount" } + ] + |] + + describe "VIEW that has a source FK based on a UNIQUE key" $ + + it "includes fk description" $ do + r <- simpleBody <$> get "/" + + let referralLink = r ^? key "definitions" . key "referrals" . key "properties" . key "link" + + liftIO $ + referralLink `shouldBe` Just + [aesonQQ| + { + "format": "integer", + "type": "integer", + "description": "Note:\nThis is a Foreign Key to `pages.link`." + } + |] + + describe "PostgreSQL to Swagger Type Mapping" $ do + + it "character varying to string" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character_varying" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "character varying", + "type": "string" + } + |] + it "character(1) to string" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "maxLength": 1, + "format": "character", + "type": "string" + } + |] + + it "text to string" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_text" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "text", + "type": "string" + } + |] + + it "boolean to boolean" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_boolean" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "boolean", + "type": "boolean" + } + |] + + it "smallint to integer" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_smallint" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "smallint", + "type": "integer" + } + |] + + it "integer to integer" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_integer" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "integer", + "type": "integer" + } + |] + + it "bigint to integer" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_bigint" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "bigint", + "type": "integer" + } + |] + + it "numeric to number" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_numeric" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "numeric", + "type": "number" + } + |] + + it "real to number" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_real" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "real", + "type": "number" + } + |] + + it "double_precision to number" $ do + r <- simpleBody <$> get "/" + + let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_double_precision" + + liftIO $ + + types `shouldBe` Just + [aesonQQ| + { + "format": "double precision", + "type": "number" + } + |] + + describe "RPC" $ do + + it "includes function summary/description and body schema for arguments" $ do + r <- simpleBody <$> get "/" + + let method s = key "paths" . key "/rpc/varied_arguments" . key s + args = r ^? method "post" . key "parameters" . nth 0 . key "schema" + summary = r ^? method "post" . key "summary" + description = r ^? method "post" . key "description" + + liftIO $ do + + summary `shouldBe` Just "An RPC function" + + description `shouldBe` Just "Just a test for RPC function arguments" + + args `shouldBe` Just + [aesonQQ| + { + "required": [ + "double", + "varchar", + "boolean", + "date", + "money", + "enum", + "arr" + ], + "properties": { + "double": { + "format": "double precision", + "type": "number" + }, + "varchar": { + "format": "character varying", + "type": "string" + }, + "boolean": { + "format": "boolean", + "type": "boolean" + }, + "date": { + "format": "date", + "type": "string" + }, + "money": { + "format": "money", + "type": "string" + }, + "enum": { + "format": "enum_menagerie_type", + "type": "string" + }, + "arr": { + "format": "text[]", + "type": "string" + }, + "integer": { + "format": "integer", + "type": "integer" + }, + "json": { + "format": "json", + "type": "string" + }, + "jsonb": { + "format": "jsonb", + "type": "string" + } + }, + "type": "object", + "description": "An RPC function\n\nJust a test for RPC function arguments" + } + |] + + it "doesn't include privileged function for anonymous" $ do + r <- simpleBody <$> get "/" + let funcPath = r ^? key "paths" . key "/rpc/privileged_hello" + + liftIO $ funcPath `shouldBe` Nothing + + it "includes function if user has permission" $ do + let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" + r <- simpleBody <$> request methodGet "/" [auth] "" + let funcTag = r ^? key "paths" . key "/rpc/privileged_hello" + . key "post" . key "tags" + . nth 0 + + liftIO $ funcTag `shouldBe` Just [aesonQQ|"(rpc) privileged_hello"|] + + it "doesn't include OUT params of function as required parameters" $ do + r <- simpleBody <$> get "/" + let params = r ^? key "paths" . key "/rpc/many_out_params" + . key "post" . key "parameters" . nth 0 + . key "schema". key "required" + + liftIO $ params `shouldBe` Nothing + + it "includes INOUT params(with no DEFAULT) of function as required parameters" $ do + r <- simpleBody <$> get "/" + let params = r ^? key "paths" . key "/rpc/many_inout_params" + . key "post" . key "parameters" . nth 0 + . key "schema". key "required" + + liftIO $ params `shouldBe` Just [aesonQQ|["num", "str"]|] + diff --git a/test/Feature/OptionsSpec.hs b/test/Feature/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/OptionsSpec.hs @@ -0,0 +1,71 @@ +module Feature.OptionsSpec where + +import Network.Wai (Application) +import Network.Wai.Test (SResponse (..)) + +import Network.HTTP.Types +import Test.Hspec +import Test.Hspec.Wai + +import Protolude +import SpecHelper + +spec :: SpecWith ((), Application) +spec = describe "Allow header" $ do + context "a table" $ do + it "includes read/write verbs for writeable table" $ do + r <- request methodOptions "/items" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PUT,PATCH,DELETE" + + context "a view" $ do + context "auto updatable" $ do + it "includes read/write verbs for auto updatable views with pk" $ do + r <- request methodOptions "/projects_auto_updatable_view_with_pk" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PUT,PATCH,DELETE" + + it "includes read/write verbs for auto updatable views without pk" $ do + r <- request methodOptions "/projects_auto_updatable_view_without_pk" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PATCH,DELETE" + + context "non auto updatable" $ do + it "includes read verbs for non auto updatable views" $ do + r <- request methodOptions "/projects_view_without_triggers" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD" + + it "includes read/write verbs for insertable, updatable and deletable views with pk" $ do + r <- request methodOptions "/projects_view_with_all_triggers_with_pk" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PUT,PATCH,DELETE" + + it "includes read/write verbs for insertable, updatable and deletable views without pk" $ do + r <- request methodOptions "/projects_view_with_all_triggers_without_pk" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD,POST,PATCH,DELETE" + + it "includes read and insert verbs for insertable views" $ do + r <- request methodOptions "/projects_view_with_insert_trigger" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD,POST" + + it "includes read and update verbs for updatable views" $ do + r <- request methodOptions "/projects_view_with_update_trigger" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD,PATCH" + + it "includes read and delete verbs for deletable views" $ do + r <- request methodOptions "/projects_view_with_delete_trigger" [] "" + liftIO $ + simpleHeaders r `shouldSatisfy` + matchHeader "Allow" "OPTIONS,GET,HEAD,DELETE" diff --git a/test/Feature/PgVersion95Spec.hs b/test/Feature/PgVersion95Spec.hs deleted file mode 100644 --- a/test/Feature/PgVersion95Spec.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Feature.PgVersion95Spec where - -import Network.Wai (Application) - -import Test.Hspec -import Test.Hspec.Wai -import Test.Hspec.Wai.JSON - -import Protolude hiding (get) -import SpecHelper - -spec :: SpecWith ((), Application) -spec = describe "features supported on PostgreSQL 9.5" $ - context "json array negative index" $ do - it "can select with negative indexes" $ do - get "/json_arr?select=data->>-1::int&id=in.(1,2)" `shouldRespondWith` - [json| [{"data":3}, {"data":6}] |] - { matchHeaders = [matchContentTypeJson] } - get "/json_arr?select=data->0->>-2::int&id=in.(3,4)" `shouldRespondWith` - [json| [{"data":8}, {"data":7}] |] - { matchHeaders = [matchContentTypeJson] } - get "/json_arr?select=data->-2->>a&id=in.(5,6)" `shouldRespondWith` - [json| [{"a":"A"}, {"a":"[1,2,3]"}] |] - { matchHeaders = [matchContentTypeJson] } - - it "can filter with negative indexes" $ do - get "/json_arr?select=data&data->>-3=eq.1" `shouldRespondWith` - [json| [{"data":[1, 2, 3]}] |] - { matchHeaders = [matchContentTypeJson] } - get "/json_arr?select=data&data->-1->>-3=eq.11" `shouldRespondWith` - [json| [{"data":[[9, 8, 7], [11, 12, 13]]}] |] - { matchHeaders = [matchContentTypeJson] } - get "/json_arr?select=data&data->-1->>b=eq.B" `shouldRespondWith` - [json| [{"data":[{"a": "A"}, {"b": "B"}]}] |] - { matchHeaders = [matchContentTypeJson] } - get "/json_arr?select=data&data->-1->b->>-1=eq.5" `shouldRespondWith` - [json| [{"data":[{"a": [1,2,3]}, {"b": [4,5]}]}] |] - { matchHeaders = [matchContentTypeJson] } - - it "should fail on badly formed negatives" $ do - get "/json_arr?select=data->>-78xy" `shouldRespondWith` - [json| - {"details": "unexpected 'x' expecting digit, \"->\", \"::\" or end of input", - "message": "\"failed to parse select parameter (data->>-78xy)\" (line 1, column 11)"} |] - { matchStatus = 400, matchHeaders = [matchContentTypeJson] } - get "/json_arr?select=data->>--34" `shouldRespondWith` - [json| - {"details": "unexpected \"-\" expecting digit", - "message": "\"failed to parse select parameter (data->>--34)\" (line 1, column 9)"} |] - { matchStatus = 400, matchHeaders = [matchContentTypeJson] } - get "/json_arr?select=data->>-xy-4" `shouldRespondWith` - [json| - {"details":"unexpected \"x\" expecting digit", - "message":"\"failed to parse select parameter (data->>-xy-4)\" (line 1, column 9)"} |] - { matchStatus = 400, matchHeaders = [matchContentTypeJson] } diff --git a/test/Feature/PgVersion96Spec.hs b/test/Feature/PgVersion96Spec.hs deleted file mode 100644 --- a/test/Feature/PgVersion96Spec.hs +++ /dev/null @@ -1,195 +0,0 @@ -module Feature.PgVersion96Spec where - -import Network.HTTP.Types -import Network.Wai (Application) -import Network.Wai.Test (SResponse (simpleHeaders)) - -import Test.Hspec -import Test.Hspec.Wai -import Test.Hspec.Wai.JSON - -import Protolude hiding (get) -import SpecHelper - -spec :: SpecWith ((), Application) -spec = - describe "features supported on PostgreSQL 9.6" $ do - context "GUC headers on function calls" $ do - it "succeeds setting the headers" $ do - get "/rpc/get_projects_and_guc_headers?id=eq.2&select=id" - `shouldRespondWith` [json|[{"id": 2}]|] - {matchHeaders = [ - matchContentTypeJson, - "X-Test" <:> "key1=val1; someValue; key2=val2", - "X-Test-2" <:> "key1=val1"]} - get "/rpc/get_int_and_guc_headers?num=1" - `shouldRespondWith` [json|1|] - {matchHeaders = [ - matchContentTypeJson, - "X-Test" <:> "key1=val1; someValue; key2=val2", - "X-Test-2" <:> "key1=val1"]} - post "/rpc/get_int_and_guc_headers" [json|{"num": 1}|] - `shouldRespondWith` [json|1|] - {matchHeaders = [ - matchContentTypeJson, - "X-Test" <:> "key1=val1; someValue; key2=val2", - "X-Test-2" <:> "key1=val1"]} - - it "fails when setting headers with wrong json structure" $ do - get "/rpc/bad_guc_headers_1" - `shouldRespondWith` - [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|] - { matchStatus = 500 - , matchHeaders = [ matchContentTypeJson ] - } - get "/rpc/bad_guc_headers_2" - `shouldRespondWith` - [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|] - { matchStatus = 500 - , matchHeaders = [ matchContentTypeJson ] - } - get "/rpc/bad_guc_headers_3" - `shouldRespondWith` - [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|] - { matchStatus = 500 - , matchHeaders = [ matchContentTypeJson ] - } - post "/rpc/bad_guc_headers_1" [json|{}|] - `shouldRespondWith` - [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|] - { matchStatus = 500 - , matchHeaders = [ matchContentTypeJson ] - } - - it "can set the same http header twice" $ - get "/rpc/set_cookie_twice" - `shouldRespondWith` "null" - {matchHeaders = [ - matchContentTypeJson, - "Set-Cookie" <:> "sessionid=38afes7a8; HttpOnly; Path=/", - "Set-Cookie" <:> "id=a3fWa; Expires=Wed, 21 Oct 2015 07:28:00 GMT; Secure; HttpOnly"]} - - context "GUC headers on all other methods via pre-request" $ do - it "succeeds setting the headers on GET and HEAD" $ do - request methodGet "/items?id=eq.1" [("User-Agent", "MSIE 6.0")] mempty - `shouldRespondWith` [json|[{"id": 1}]|] - {matchHeaders = [ - matchContentTypeJson, - "Cache-Control" <:> "no-cache, no-store, must-revalidate"]} - - request methodHead "/items?id=eq.1" [("User-Agent", "MSIE 7.0")] mempty - `shouldRespondWith` "" - {matchHeaders = ["Cache-Control" <:> "no-cache, no-store, must-revalidate"]} - - request methodHead "/projects" [("Accept", "text/csv")] mempty - `shouldRespondWith` "" - {matchHeaders = ["Content-Disposition" <:> "attachment; filename=projects.csv"]} - - it "succeeds setting the headers on POST" $ - request methodPost "/items" [] [json|[{"id": 11111}]|] - `shouldRespondWith` "" - { matchStatus = 201 - , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"] - } - - it "succeeds setting the headers on PATCH" $ - request methodPatch "/items?id=eq.11111" [] [json|[{"id": 11111}]|] - `shouldRespondWith` "" - { matchStatus = 204 - , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"] - } - - it "succeeds setting the headers on PUT" $ - request methodPut "/items?id=eq.11111" [] [json|[{"id": 11111}]|] - `shouldRespondWith` "" - { matchStatus = 204 - , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"] - } - - it "succeeds setting the headers on DELETE" $ - request methodDelete "/items?id=eq.11111" [] mempty - `shouldRespondWith` "" - { matchStatus = 204 - , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"] - } - - context "Override provided headers by using GUC headers" $ do - it "can override the Content-Type header" $ do - request methodHead "/clients?id=eq.1" [] mempty - `shouldRespondWith` "" - { matchStatus = 200 - , matchHeaders = ["Content-Type" <:> "application/geo+json"] - } - request methodHead "/rpc/getallprojects" [] mempty - `shouldRespondWith` "" - { matchStatus = 200 - , matchHeaders = ["Content-Type" <:> "application/geo+json"] - } - - it "can override the Location header" $ - request methodPost "/stuff" [] [json|[{"id": 1, "name": "stuff 1"}]|] - `shouldRespondWith` "" - { matchStatus = 201 - , matchHeaders = ["Location" <:> "/stuff?id=eq.1&overriden=true"] - } - - -- On https://github.com/PostgREST/postgrest/issues/1427#issuecomment-595907535 - -- it was reported that blank headers ` : ` where added and that cause proxies to fail the requests. - -- These tests are to ensure no blank headers are added. - context "Blank headers bug" $ do - it "shouldn't add blank headers on POST" $ do - r <- request methodPost "/loc_test" [] [json|{"id": "1", "c": "c1"}|] - liftIO $ do - let respHeaders = simpleHeaders r - respHeaders `shouldSatisfy` noBlankHeader - - it "shouldn't add blank headers on PATCH" $ do - r <- request methodPatch "/loc_test?id=eq.1" [] [json|{"c": "c2"}|] - liftIO $ do - let respHeaders = simpleHeaders r - respHeaders `shouldSatisfy` noBlankHeader - - it "shouldn't add blank headers on GET" $ do - r <- request methodGet "/loc_test" [] "" - liftIO $ do - let respHeaders = simpleHeaders r - respHeaders `shouldSatisfy` noBlankHeader - - it "shouldn't add blank headers on DELETE" $ do - r <- request methodDelete "/loc_test?id=eq.1" [] "" - liftIO $ do - let respHeaders = simpleHeaders r - respHeaders `shouldSatisfy` noBlankHeader - - context "Use of the phraseto_tsquery function" $ do - it "finds matches" $ - get "/tsearch?text_search_vector=phfts.The%20Fat%20Cats" `shouldRespondWith` - [json| [{"text_search_vector": "'ate':3 'cat':2 'fat':1 'rat':4" }] |] - { matchHeaders = [matchContentTypeJson] } - - it "finds matches with different dictionaries" $ - get "/tsearch?text_search_vector=phfts(german).Art%20Spass" `shouldRespondWith` - [json| [{"text_search_vector": "'art':4 'spass':5 'unmog':7" }] |] - { matchHeaders = [matchContentTypeJson] } - - it "can be negated with not operator" $ - get "/tsearch?text_search_vector=not.phfts(english).The%20Fat%20Cats" `shouldRespondWith` - [json| [ - {"text_search_vector": "'fun':5 'imposs':9 'kind':3"}, - {"text_search_vector": "'also':2 'fun':3 'possibl':8"}, - {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4"}, - {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|] - { matchHeaders = [matchContentTypeJson] } - - it "can be used with or query param" $ - get "/tsearch?or=(text_search_vector.phfts(german).Art%20Spass, text_search_vector.phfts(french).amusant, text_search_vector.fts(english).impossible)" `shouldRespondWith` - [json|[ - {"text_search_vector": "'fun':5 'imposs':9 'kind':3" }, - {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4" }, - {"text_search_vector": "'art':4 'spass':5 'unmog':7"} - ]|] { matchHeaders = [matchContentTypeJson] } - - it "should work when used with GET RPC" $ - get "/rpc/get_tsearch?text_search_vector=phfts(english).impossible" `shouldRespondWith` - [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|] - { matchHeaders = [matchContentTypeJson] } diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs --- a/test/Feature/QueryLimitedSpec.hs +++ b/test/Feature/QueryLimitedSpec.hs @@ -1,7 +1,6 @@ module Feature.QueryLimitedSpec where -import Network.Wai (Application) -import Network.Wai.Test (SResponse (simpleHeaders, simpleStatus)) +import Network.Wai (Application) import Network.HTTP.Types import Test.Hspec @@ -15,59 +14,56 @@ spec = describe "Requesting many items with server limits(max-rows) enabled" $ do it "restricts results" $ - get "/items" - `shouldRespondWith` [json| [{"id":1},{"id":2}] |] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/*"] - } + get "/items?order=id" + `shouldRespondWith` + [json| [{"id":1},{"id":2}] |] + { matchHeaders = ["Content-Range" <:> "0-1/*"] } it "respects additional client limiting" $ do - r <- request methodGet "/items" - (rangeHdrs $ ByteRangeFromTo 0 0) "" - liftIO $ do - simpleHeaders r `shouldSatisfy` - matchHeader "Content-Range" "0-0/*" - simpleStatus r `shouldBe` ok200 + request methodGet "/items" + (rangeHdrs $ ByteRangeFromTo 0 0) + "" + `shouldRespondWith` + [json| [{"id":1}] |] + { matchHeaders = ["Content-Range" <:> "0-0/*"] } it "works on all levels" $ get "/users?select=id,tasks(id)&order=id.asc&tasks.order=id.asc" - `shouldRespondWith` [json|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/*"] - } + `shouldRespondWith` + [json|[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":5},{"id":6}]}]|] + { matchHeaders = ["Content-Range" <:> "0-1/*"] } it "succeeds in getting parent embeds despite the limit, see #647" $ get "/tasks?select=id,project:projects(id)&id=gt.5" - `shouldRespondWith` [json|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/*"] - } + `shouldRespondWith` + [json|[{"id":6,"project":{"id":3}},{"id":7,"project":{"id":4}}]|] + { matchHeaders = ["Content-Range" <:> "0-1/*"] } it "can offset the parent embed, being consistent with the other embed types" $ get "/tasks?select=id,project:projects(id)&id=gt.5&project.offset=1" - `shouldRespondWith` [json|[{"id":6,"project":null}, {"id":7,"project":null}]|] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/*"] - } + `shouldRespondWith` + [json|[{"id":6,"project":null}, {"id":7,"project":null}]|] + { matchHeaders = ["Content-Range" <:> "0-1/*"] } context "count=estimated" $ do it "uses the query planner guess when query rows > maxRows" $ request methodHead "/getallprojects_view" [("Prefer", "count=estimated")] "" - `shouldRespondWith` "" - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-1/2019"] - } + `shouldRespondWith` + "" + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "0-1/2019"] + } it "gives exact count when query rows <= maxRows" $ request methodHead "/getallprojects_view?id=lt.3" [("Prefer", "count=estimated")] "" - `shouldRespondWith` "" - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-1/2"] - } + `shouldRespondWith` + "" + { matchHeaders = ["Content-Range" <:> "0-1/2"] } it "only uses the query planner guess if it's indeed greater than the exact count" $ request methodHead "/get_projects_above_view" [("Prefer", "count=estimated")] "" - `shouldRespondWith` "" - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-1/3"] - } + `shouldRespondWith` + "" + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "0-1/3"] + } diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -8,10 +8,9 @@ import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Text.Heredoc - -import PostgREST.Types (PgVersion, pgVersion112, pgVersion121) -import Protolude hiding (get) +import PostgREST.Config.PgVersion (PgVersion, pgVersion112, + pgVersion121, pgVersion96) +import Protolude hiding (get) import SpecHelper spec :: PgVersion -> SpecWith ((), Application) @@ -36,7 +35,7 @@ { matchHeaders = ["Content-Range" <:> "0-0/*"] } it "matches with equality using not operator" $ - get "/items?id=not.eq.5" + get "/items?id=not.eq.5&order=id" `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] { matchHeaders = ["Content-Range" <:> "0-13/*"] } @@ -71,19 +70,19 @@ [json| [{"a": null, "b": null}] |] { matchHeaders = [matchContentTypeJson] } - get "/nullable_integer?a=is.null" `shouldRespondWith` [str|[{"a":null}]|] + get "/nullable_integer?a=is.null" `shouldRespondWith` [json|[{"a":null}]|] it "matches with like" $ do get "/simple_pk?k=like.*yx" `shouldRespondWith` - [str|[{"k":"xyyx","extra":"u"}]|] + [json|[{"k":"xyyx","extra":"u"}]|] get "/simple_pk?k=like.xy*" `shouldRespondWith` - [str|[{"k":"xyyx","extra":"u"}]|] + [json|[{"k":"xyyx","extra":"u"}]|] get "/simple_pk?k=like.*YY*" `shouldRespondWith` - [str|[{"k":"xYYx","extra":"v"}]|] + [json|[{"k":"xYYx","extra":"v"}]|] it "matches with like using not operator" $ get "/simple_pk?k=not.like.*yx" `shouldRespondWith` - [str|[{"k":"xYYx","extra":"v"}]|] + [json|[{"k":"xYYx","extra":"v"}]|] it "matches with ilike" $ do get "/simple_pk?k=ilike.xy*&order=extra.asc" `shouldRespondWith` @@ -183,6 +182,35 @@ {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|] { matchHeaders = [matchContentTypeJson] } + when (actualPgVersion >= pgVersion96) $ + context "Use of the phraseto_tsquery function" $ do + it "finds matches" $ + get "/tsearch?text_search_vector=phfts.The%20Fat%20Cats" `shouldRespondWith` + [json| [{"text_search_vector": "'ate':3 'cat':2 'fat':1 'rat':4" }] |] + { matchHeaders = [matchContentTypeJson] } + + it "finds matches with different dictionaries" $ + get "/tsearch?text_search_vector=phfts(german).Art%20Spass" `shouldRespondWith` + [json| [{"text_search_vector": "'art':4 'spass':5 'unmog':7" }] |] + { matchHeaders = [matchContentTypeJson] } + + it "can be negated with not operator" $ + get "/tsearch?text_search_vector=not.phfts(english).The%20Fat%20Cats" `shouldRespondWith` + [json| [ + {"text_search_vector": "'fun':5 'imposs':9 'kind':3"}, + {"text_search_vector": "'also':2 'fun':3 'possibl':8"}, + {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4"}, + {"text_search_vector": "'art':4 'spass':5 'unmog':7"}]|] + { matchHeaders = [matchContentTypeJson] } + + it "can be used with or query param" $ + get "/tsearch?or=(text_search_vector.phfts(german).Art%20Spass, text_search_vector.phfts(french).amusant, text_search_vector.fts(english).impossible)" `shouldRespondWith` + [json|[ + {"text_search_vector": "'fun':5 'imposs':9 'kind':3" }, + {"text_search_vector": "'amus':5 'fair':7 'impossibl':9 'peu':4" }, + {"text_search_vector": "'art':4 'spass':5 'unmog':7"} + ]|] { matchHeaders = [matchContentTypeJson] } + it "matches with computed column" $ get "/items?always_true=eq.true&order=id.asc" `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] @@ -197,8 +225,10 @@ get "/items?always_false=is.false" `shouldRespondWith` 400 it "matches filtering nested items 2" $ - get "/clients?select=id,projects(id,tasks2(id,name))&projects.tasks.name=like.Design*" - `shouldRespondWith` [json| {"message":"Could not find foreign keys between these entities. No relationship found between projects and tasks2"}|] + get "/clients?select=id,projects(id,tasks2(id,name))&projects.tasks.name=like.Design*" `shouldRespondWith` + [json| { + "hint":"If a new foreign key between these entities was created in the database, try reloading the schema cache.", + "message":"Could not find a relationship between projects and tasks2 in the schema cache"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } @@ -221,11 +251,11 @@ describe "Shaping response with select parameter" $ do it "selectStar works in absense of parameter" $ get "/complex_items?id=eq.3" `shouldRespondWith` - [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|] + [json|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|] it "dash `-` in column names is accepted" $ get "/complex_items?id=eq.3&select=id,field-with_sep" `shouldRespondWith` - [str|[{"id":3,"field-with_sep":1}]|] + [json|[{"id":3,"field-with_sep":1}]|] it "one simple column" $ get "/complex_items?select=id" `shouldRespondWith` @@ -290,7 +320,7 @@ it "requesting parents and filtering parent columns" $ get "/projects?id=eq.1&select=id, name, clients(id)" `shouldRespondWith` - [str|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|] + [json|[{"id":1,"name":"Windows 7","clients":{"id":1}}]|] it "rows with missing parents are included" $ get "/projects?id=in.(1,5)&select=id,clients(id)" `shouldRespondWith` @@ -299,7 +329,7 @@ it "rows with no children return [] instead of null" $ get "/projects?id=in.(5)&select=id,tasks(id)" `shouldRespondWith` - [str|[{"id":5,"tasks":[]}]|] + [json|[{"id":5,"tasks":[]}]|] it "requesting children 2 levels" $ get "/clients?id=eq.1&select=id,projects(id,tasks(id))" `shouldRespondWith` @@ -321,6 +351,21 @@ [json|[{"id":1,"tasks":[{"id":1},{"id":2},{"id":3},{"id":4}]},{"id":2,"tasks":[{"id":5},{"id":6},{"id":7}]},{"id":3,"tasks":[{"id":1},{"id":5}]}]|] { matchHeaders = [matchContentTypeJson] } + it "requesting many<->many relation using composite key" $ + get "/files?filename=eq.autoexec.bat&project_id=eq.1&select=filename,users_tasks(user_id,task_id)" `shouldRespondWith` + [json|[{"filename":"autoexec.bat","users_tasks":[{"user_id":1,"task_id":1},{"user_id":3,"task_id":1}]}]|] + { matchHeaders = [matchContentTypeJson] } + + it "requesting data using many<->many relation defined by composite keys" $ + get "/users_tasks?user_id=eq.1&task_id=eq.1&select=user_id,files(filename,content)" `shouldRespondWith` + [json|[{"user_id":1,"files":[{"filename":"command.com","content":"#include "},{"filename":"autoexec.bat","content":"@ECHO OFF"},{"filename":"README.md","content":"# make $$$!"}]}]|] + { matchHeaders = [matchContentTypeJson] } + + it "requesting data using many<->many (composite keys) relation using hint" $ + get "/users_tasks?user_id=eq.1&task_id=eq.1&select=user_id,files!touched_files(filename,content)" `shouldRespondWith` + [json|[{"user_id":1,"files":[{"filename":"command.com","content":"#include "},{"filename":"autoexec.bat","content":"@ECHO OFF"},{"filename":"README.md","content":"# make $$$!"}]}]|] + { matchHeaders = [matchContentTypeJson] } + it "requesting children with composite key" $ get "/users_tasks?user_id=eq.2&task_id=eq.6&select=*, comments(content)" `shouldRespondWith` [json|[{"user_id":2,"task_id":6,"comments":[{"content":"Needs to be delivered ASAP"}]}]|] @@ -358,9 +403,9 @@ get "/materialized_projects?select=*,users(*)" `shouldRespondWith` 200 it "can request two parents" $ - get "/articleStars?select=createdAt,article:articles(owner),user:users(name)&limit=1" `shouldRespondWith` - [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"owner": "postgrest_test_authenticator"},"user":{"name": "Angela Martin"}}]|] - { matchHeaders = [matchContentTypeJson] } + get "/articleStars?select=createdAt,article:articles(id),user:users(name)&limit=1" + `shouldRespondWith` + [json|[{"createdAt":"2015-12-08T04:22:57.472738","article":{"id": 1},"user":{"name": "Angela Martin"}}]|] it "can detect relations in views from exposed schema that are based on tables in private schema and have columns renames" $ get "/articles?id=eq.1&select=id,articleStars(users(*))" `shouldRespondWith` @@ -391,6 +436,9 @@ [json|[ { "title": "To Kill a Mockingbird", "author": { "name": "Harper Lee" } } ]|] { matchHeaders = [matchContentTypeJson] } + it "can detect fk relations through multiple views recursively when all views are in api schema" $ do + get "/consumers_view_view?select=*,orders_view(*)" `shouldRespondWith` 200 + it "works with views that have subselects" $ get "/authors_books_number?select=*,books(title)&id=eq.1" `shouldRespondWith` [json|[ {"id":1, "name":"George Orwell","num_in_forties":1,"num_in_fifties":0,"num_in_sixties":0,"num_in_all_decades":1, @@ -408,6 +456,12 @@ [json|[{"title":"1984","first_publisher":"Secker & Warburg","author":{"name":"George Orwell"}}]|] { matchHeaders = [matchContentTypeJson] } + it "works with views that have subselects in a function call" $ + get "/authors_have_book_in_decade2?select=*,books(title)&id=eq.3" + `shouldRespondWith` + [json|[ {"id":3,"name":"Antoine de Saint-Exupéry","has_book_in_forties":true,"has_book_in_fifties":false, + "has_book_in_sixties":false,"books":[{"title":"The Little Prince"}]} ]|] + it "works with views that have CTE" $ get "/odd_years_publications?select=title,publication_year,first_publisher,author:authors(name)&id=in.(1,2,3)" `shouldRespondWith` [json|[ @@ -612,7 +666,7 @@ it "ordering embeded parents does not break things" $ get "/projects?id=eq.1&select=id, name, clients(id, name)&clients.order=name.asc" `shouldRespondWith` - [str|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"}}]|] + [json|[{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"}}]|] context "order syntax errors" $ do it "gives meaningful error messages when asc/desc/nulls{first,last} are misspelled" $ do @@ -762,7 +816,7 @@ 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"] + , matchHeaders = ["Content-Type" <:> "application/octet-stream"] } it "can get raw output with Accept: text/plain" $ @@ -775,20 +829,28 @@ 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` - [json| {"message":"application/octet-stream requested but more than one column was selected"} |] - { matchStatus = 406 - , matchHeaders = [matchContentTypeJson] - } - 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 + [json| {"message":"application/octet-stream requested but more than one column was selected"} |] + { matchStatus = 406 } + request methodGet "/images?select=*&name=eq.A.png" + (acceptHdrs "application/octet-stream") + "" + `shouldRespondWith` + [json| {"message":"application/octet-stream requested but more than one column was selected"} |] + { matchStatus = 406 } + + request methodGet "/images?name=eq.A.png" + (acceptHdrs "application/octet-stream") + "" + `shouldRespondWith` + [json| {"message":"application/octet-stream requested but more than one column was selected"} |] + { matchStatus = 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"] + , matchHeaders = ["Content-Type" <:> "application/octet-stream"] } describe "values with quotes in IN and NOT IN" $ do @@ -800,7 +862,7 @@ [json| [{"name":"Hebdon, John"},{"name":"Williams, Mary"},{"name":"Smith, Joseph"}] |] { matchHeaders = [matchContentTypeJson] } get "/w_or_wo_comma_names?name=not.in.(\"Hebdon, John\",\"Williams, Mary\",\"Smith, Joseph\")" `shouldRespondWith` - [json| [{"name":"David White"},{"name":"Larry Thompson"}] |] + [json| [{"name":"David White"},{"name":"Larry Thompson"},{"name":"Double O Seven(007)"}] |] { matchHeaders = [matchContentTypeJson] } it "succeeds w/ and w/o quoted values" $ do @@ -808,16 +870,16 @@ [json| [{"name":"Hebdon, John"},{"name":"David White"}] |] { matchHeaders = [matchContentTypeJson] } get "/w_or_wo_comma_names?name=not.in.(\"Hebdon, John\",Larry Thompson,\"Smith, Joseph\")" `shouldRespondWith` - [json| [{"name":"Williams, Mary"},{"name":"David White"}] |] + [json| [{"name":"Williams, Mary"},{"name":"David White"},{"name":"Double O Seven(007)"}] |] { matchHeaders = [matchContentTypeJson] } + get "/w_or_wo_comma_names?name=in.(\"Double O Seven(007)\")" `shouldRespondWith` + [json| [{"name":"Double O Seven(007)"}] |] + { matchHeaders = [matchContentTypeJson] } - it "checks well formed quoted values" $ do - get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\")" `shouldRespondWith` - [json| [] |] { matchHeaders = [matchContentTypeJson] } - get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\"\"Mary)" `shouldRespondWith` - [json| [] |] { matchHeaders = [matchContentTypeJson] } - get "/w_or_wo_comma_names?name=in.(Williams\"Hebdon, John\")" `shouldRespondWith` - [json| [] |] { matchHeaders = [matchContentTypeJson] } + it "fails on malformed quoted values" $ do + get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\")" `shouldRespondWith` 400 + get "/w_or_wo_comma_names?name=in.(\"\"Hebdon, John\"\"Mary)" `shouldRespondWith` 400 + get "/w_or_wo_comma_names?name=in.(Williams\"Hebdon, John\")" `shouldRespondWith` 400 describe "IN and NOT IN empty set" $ do context "returns an empty result for IN when no value is present" $ do diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -33,9 +33,11 @@ `shouldRespondWith` [json| [] |] {matchHeaders = ["Content-Range" <:> "*/*"]} it "returns range Content-Range with range/*" $ - request methodPost "/rpc/getitemrange" [] defaultRange - `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] - { matchHeaders = ["Content-Range" <:> "0-14/*"] } + post "/rpc/getitemrange?order=id" + defaultRange + `shouldRespondWith` + [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}] |] + { matchHeaders = ["Content-Range" <:> "0-14/*"] } context "with range headers" $ do context "of acceptable range" $ do @@ -168,20 +170,16 @@ } it "succeeds if offset equals 0 as a no-op" $ - get "/items?select=id&offset=0" + get "/items?select=id&offset=0&order=id" `shouldRespondWith` - [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-14/*"] - } + [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|] + { matchHeaders = ["Content-Range" <:> "0-14/*"] } it "succeeds if offset is negative as a no-op" $ - get "/items?select=id&offset=-4" + get "/items?select=id&offset=-4&order=id" `shouldRespondWith` - [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-14/*"] - } + [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|] + { matchHeaders = ["Content-Range" <:> "0-14/*"] } it "fails if limit equals 0" $ get "/items?select=id&limit=0" @@ -199,62 +197,98 @@ context "when count=planned" $ do it "obtains a filtered range" $ do - request methodGet "/items?select=id&id=gt.8" [("Prefer", "count=planned")] "" - `shouldRespondWith` [json|[{"id":9}, {"id":10}, {"id":11}, {"id":12}, {"id":13}, {"id":14}, {"id":15}]|] - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-6/8"] - } - request methodGet "/child_entities?select=id&id=gt.3" [("Prefer", "count=planned")] "" - `shouldRespondWith` [json|[{"id":4}, {"id":5}, {"id":6}]|] - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-2/4"] - } - request methodGet "/getallprojects_view?select=id&id=lt.3" [("Prefer", "count=planned")] "" - `shouldRespondWith` [json|[{"id":1}, {"id":2}]|] - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-1/673"] - } + request methodGet "/items?select=id&id=gt.8" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + [json|[{"id":9}, {"id":10}, {"id":11}, {"id":12}, {"id":13}, {"id":14}, {"id":15}]|] + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "0-6/8"] + } + request methodGet "/child_entities?select=id&id=gt.3" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + [json|[{"id":4}, {"id":5}, {"id":6}]|] + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "0-2/4"] + } + + request methodGet "/getallprojects_view?select=id&id=lt.3" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + [json|[{"id":1}, {"id":2}]|] + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "0-1/673"] + } + it "obtains the full range" $ do - request methodHead "/items" [("Prefer", "count=planned")] "" - `shouldRespondWith` "" - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-14/15"] - } - request methodHead "/child_entities" [("Prefer", "count=planned")] "" - `shouldRespondWith` "" - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-5/6"] - } - request methodHead "/getallprojects_view" [("Prefer", "count=planned")] "" - `shouldRespondWith` "" - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-4/2019"] - } + request methodHead "/items" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + "" + { matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-14/15"] + } + request methodHead "/child_entities" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + "" + { matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-5/6"] + } + + request methodHead "/getallprojects_view" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + "" + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "0-4/2019"] + } + it "ignores limit/offset on the planned count" $ do - request methodHead "/items?limit=2&offset=3" [("Prefer", "count=planned")] "" - `shouldRespondWith` "" - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "3-4/15"] - } - request methodHead "/child_entities?limit=2" [("Prefer", "count=planned")] "" - `shouldRespondWith` "" - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-1/6"] - } - request methodHead "/getallprojects_view?limit=2" [("Prefer", "count=planned")] "" - `shouldRespondWith` "" - { matchStatus = 206 - , matchHeaders = ["Content-Range" <:> "0-1/2019"] - } + request methodHead "/items?limit=2&offset=3" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + "" + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "3-4/15"] + } + request methodHead "/child_entities?limit=2" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + "" + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "0-1/6"] + } + + request methodHead "/getallprojects_view?limit=2" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + "" + { matchStatus = 206 + , matchHeaders = ["Content-Range" <:> "0-1/2019"] + } + it "works with two levels" $ - request methodHead "/child_entities?select=*,entities(*)" [("Prefer", "count=planned")] "" - `shouldRespondWith` "" - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-5/6"] - } + request methodHead "/child_entities?select=*,entities(*)" + [("Prefer", "count=planned")] + "" + `shouldRespondWith` + "" + { matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-5/6"] + } context "with range headers" $ do context "of acceptable range" $ do diff --git a/test/Feature/RawOutputTypesSpec.hs b/test/Feature/RawOutputTypesSpec.hs --- a/test/Feature/RawOutputTypesSpec.hs +++ b/test/Feature/RawOutputTypesSpec.hs @@ -24,7 +24,7 @@ { matchHeaders= ["Content-Type" <:> "application/json; charset=utf-8"] } it "responds json to a GET request to RPC with Firefox Accept headers" $ - request methodGet "/rpc/get_projects_below?id=3" chromeAcceptHdrs "" + request methodGet "/rpc/get_projects_below?id=3" firefoxAcceptHdrs "" `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client_id":1}, {"id":2,"name":"Windows 10","client_id":1}]|] { matchHeaders= ["Content-Type" <:> "application/json; charset=utf-8"] } it "responds json to a GET request to RPC with Chrome Accept headers" $ diff --git a/test/Feature/RollbackSpec.hs b/test/Feature/RollbackSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/RollbackSpec.hs @@ -0,0 +1,218 @@ +module Feature.RollbackSpec where + +import Network.Wai (Application) + +import Network.HTTP.Types +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + +import Protolude hiding (get) + +-- two helpers functions to make sure that each test can setup and cleanup properly + +-- creates Item to work with for PATCH and DELETE +postItem = + request methodPost "/items" + [("Prefer", "tx=commit"), ("Prefer", "resolution=ignore-duplicates")] + [json|{"id":0}|] + `shouldRespondWith` + "" + { matchStatus = 201 } + +-- removes Items left over from POST, PUT, and PATCH +deleteItems = + request methodDelete "/items?id=lte.0" + [("Prefer", "tx=commit")] + "" + `shouldRespondWith` + "" + { matchStatus = 204 } + +preferDefault = [("Prefer", "return=representation")] +preferCommit = [("Prefer", "return=representation"), ("Prefer", "tx=commit")] +preferRollback = [("Prefer", "return=representation"), ("Prefer", "tx=rollback")] + +withoutPreferenceApplied = [] +withPreferenceCommitApplied = [ "Preference-Applied" <:> "tx=commit" ] +withPreferenceRollbackApplied = [ "Preference-Applied" <:> "tx=rollback" ] + +shouldRespondToReads reqHeaders respHeaders = do + it "responds to GET" $ do + request methodGet "/items?id=eq.1" + reqHeaders + "" + `shouldRespondWith` + [json|[{"id":1}]|] + { matchHeaders = respHeaders } + + it "responds to HEAD" $ do + request methodHead "/items?id=eq.1" + reqHeaders + "" + `shouldRespondWith` + "" + { matchHeaders = respHeaders } + + it "responds to GET on RPC" $ do + request methodGet "/rpc/search?id=1" + reqHeaders + "" + `shouldRespondWith` + [json|[{"id":1}]|] + { matchHeaders = respHeaders } + + it "responds to POST on RPC" $ do + request methodPost "/rpc/search" + reqHeaders + [json|{"id":1}|] + `shouldRespondWith` + [json|[{"id":1}]|] + { matchHeaders = respHeaders } + +shouldPersistMutations reqHeaders respHeaders = do + it "does persist post" $ do + request methodPost "/items" + reqHeaders + [json|{"id":0}|] + `shouldRespondWith` + [json|[{"id":0}]|] + { matchStatus = 201 + , matchHeaders = respHeaders } + get "/items?id=eq.0" + `shouldRespondWith` + [json|[{"id":0}]|] + deleteItems + + it "does persist put" $ do + request methodPut "/items?id=eq.0" + reqHeaders + [json|{"id":0}|] + `shouldRespondWith` + [json|[{"id":0}]|] + { matchHeaders = respHeaders } + get "/items?id=eq.0" + `shouldRespondWith` + [json|[{"id":0}]|] + deleteItems + + it "does persist patch" $ do + postItem + request methodPatch "/items?id=eq.0" + reqHeaders + [json|{"id":-1}|] + `shouldRespondWith` + [json|[{"id":-1}]|] + { matchHeaders = respHeaders } + get "/items?id=eq.0" + `shouldRespondWith` + [json|[]|] + get "/items?id=eq.-1" + `shouldRespondWith` + [json|[{"id":-1}]|] + deleteItems + + it "does persist delete" $ do + postItem + request methodDelete "/items?id=eq.0" + reqHeaders + "" + `shouldRespondWith` + [json|[{"id":0}]|] + { matchHeaders = respHeaders } + get "/items?id=eq.0" + `shouldRespondWith` + [json|[]|] + +shouldNotPersistMutations reqHeaders respHeaders = do + it "does not persist post" $ do + request methodPost "/items" + reqHeaders + [json|{"id":0}|] + `shouldRespondWith` + [json|[{"id":0}]|] + { matchStatus = 201 + , matchHeaders = respHeaders } + get "/items?id=eq.0" + `shouldRespondWith` + [json|[]|] + + it "does not persist put" $ do + request methodPut "/items?id=eq.0" + reqHeaders + [json|{"id":0}|] + `shouldRespondWith` + [json|[{"id":0}]|] + { matchHeaders = respHeaders } + get "/items?id=eq.0" + `shouldRespondWith` + [json|[]|] + + it "does not persist patch" $ do + request methodPatch "/items?id=eq.1" + reqHeaders + [json|{"id":0}|] + `shouldRespondWith` + [json|[{"id":0}]|] + { matchHeaders = respHeaders } + get "/items?id=eq.0" + `shouldRespondWith` + [json|[]|] + get "items?id=eq.1" + `shouldRespondWith` + [json|[{"id":1}]|] + + it "does not persist delete" $ do + request methodDelete "/items?id=eq.1" + reqHeaders + "" + `shouldRespondWith` + [json|[{"id":1}]|] + { matchHeaders = respHeaders } + get "/items?id=eq.1" + `shouldRespondWith` + [json|[{"id":1}]|] + +allowed :: SpecWith ((), Application) +allowed = describe "tx-allow-override = true" $ do + describe "without Prefer tx" $ do + preferDefault `shouldRespondToReads` withoutPreferenceApplied + preferDefault `shouldNotPersistMutations` withoutPreferenceApplied + + describe "Prefer tx=commit" $ do + preferCommit `shouldRespondToReads` withPreferenceCommitApplied + preferCommit `shouldPersistMutations` withPreferenceCommitApplied + + describe "Prefer tx=rollback" $ do + preferRollback `shouldRespondToReads` withPreferenceRollbackApplied + preferRollback `shouldNotPersistMutations` withPreferenceRollbackApplied + +disallowed :: SpecWith ((), Application) +disallowed = describe "tx-rollback-all = false, tx-allow-override = false" $ do + describe "without Prefer tx" $ do + preferDefault `shouldRespondToReads` withoutPreferenceApplied + preferDefault `shouldPersistMutations` withoutPreferenceApplied + + describe "Prefer tx=commit" $ do + preferCommit `shouldRespondToReads` withoutPreferenceApplied + preferCommit `shouldPersistMutations` withoutPreferenceApplied + + describe "Prefer tx=rollback" $ do + preferRollback `shouldRespondToReads` withoutPreferenceApplied + preferRollback `shouldPersistMutations` withoutPreferenceApplied + + +forced :: SpecWith ((), Application) +forced = describe "tx-rollback-all = true, tx-allow-override = false" $ do + describe "without Prefer tx" $ do + preferDefault `shouldRespondToReads` withoutPreferenceApplied + preferDefault `shouldNotPersistMutations` withoutPreferenceApplied + + describe "Prefer tx=commit" $ do + preferCommit `shouldRespondToReads` withoutPreferenceApplied + preferCommit `shouldNotPersistMutations` withoutPreferenceApplied + + describe "Prefer tx=rollback" $ do + preferRollback `shouldRespondToReads` withoutPreferenceApplied + preferRollback `shouldNotPersistMutations` withoutPreferenceApplied + diff --git a/test/Feature/RootSpec.hs b/test/Feature/RootSpec.hs --- a/test/Feature/RootSpec.hs +++ b/test/Feature/RootSpec.hs @@ -26,5 +26,9 @@ it "accepts application/json" $ request methodGet "/" [("Accept", "application/json")] "" `shouldRespondWith` - [json| [{"table": "items"}, {"table": "subitems"}] |] + [json| { + "tableName": "orders_view", "tableSchema": "test", + "tableDeletable": true, "tableUpdatable": true, + "tableInsertable": true, "tableDescription": null + } |] { matchHeaders = [matchContentTypeJson] } diff --git a/test/Feature/RpcPreRequestGucsSpec.hs b/test/Feature/RpcPreRequestGucsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/RpcPreRequestGucsSpec.hs @@ -0,0 +1,84 @@ +module Feature.RpcPreRequestGucsSpec where + +import Network.Wai (Application) + +import Network.HTTP.Types +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + +import Protolude hiding (get, put) + +spec :: SpecWith ((), Application) +spec = + describe "GUC headers on all methods via pre-request" $ do + it "succeeds setting the headers on POST" $ + post "/items" + [json|[{"id": 11111}]|] + `shouldRespondWith` "" + { matchStatus = 201 + , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"] + } + + it "succeeds setting the headers on GET and HEAD" $ do + request methodGet "/items?id=eq.1" + [("User-Agent", "MSIE 6.0")] + "" + `shouldRespondWith` + [json|[{"id": 1}]|] + { matchHeaders = ["Cache-Control" <:> "no-cache, no-store, must-revalidate"] } + + request methodHead "/items?id=eq.1" + [("User-Agent", "MSIE 7.0")] + "" + `shouldRespondWith` + "" + { matchHeaders = ["Cache-Control" <:> "no-cache, no-store, must-revalidate"] } + + request methodHead "/projects" + [("Accept", "text/csv")] + "" + `shouldRespondWith` + "" + { matchHeaders = ["Content-Disposition" <:> "attachment; filename=projects.csv"] } + + it "succeeds setting the headers on PATCH" $ + patch "/items?id=eq.1" + [json|[{"id": 11111}]|] + `shouldRespondWith` "" + { matchStatus = 204 + , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"] + } + + it "succeeds setting the headers on PUT" $ + put "/items?id=eq.1" + [json|[{"id": 1}]|] + `shouldRespondWith` "" + { matchStatus = 204 + , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"] + } + + it "succeeds setting the headers on DELETE" $ + delete "/items?id=eq.1" + `shouldRespondWith` + "" + { matchStatus = 204 + , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"] + } + it "can override the Content-Type header" $ do + request methodHead "/clients?id=eq.1" + [] + "" + `shouldRespondWith` + "" + { matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "application/custom+json"] + } + request methodHead "/rpc/getallprojects" + [] + "" + `shouldRespondWith` + "" + { matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "application/custom+json"] + } diff --git a/test/Feature/RpcSpec.hs b/test/Feature/RpcSpec.hs --- a/test/Feature/RpcSpec.hs +++ b/test/Feature/RpcSpec.hs @@ -3,7 +3,7 @@ import qualified Data.ByteString.Lazy as BL (empty) import Network.Wai (Application) -import Network.Wai.Test (SResponse (simpleBody, simpleStatus)) +import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus)) import Network.HTTP.Types import Test.Hspec hiding (pendingWith) @@ -11,10 +11,12 @@ import Test.Hspec.Wai.JSON import Text.Heredoc -import PostgREST.Types (PgVersion, pgVersion100, pgVersion109, - pgVersion110, pgVersion112, pgVersion114, - pgVersion95) -import Protolude hiding (get) +import PostgREST.Config.PgVersion (PgVersion, pgVersion100, + pgVersion109, pgVersion110, + pgVersion112, pgVersion114, + pgVersion96) + +import Protolude hiding (get) import SpecHelper spec :: PgVersion -> SpecWith ((), Application) @@ -94,27 +96,61 @@ context "unknown function" $ do it "returns 404" $ post "/rpc/fakefunc" [json| {} |] `shouldRespondWith` 404 + it "should fail with 404 on unknown proc name" $ get "/rpc/fake" `shouldRespondWith` 404 + it "should fail with 404 on unknown proc args" $ do get "/rpc/sayhello" `shouldRespondWith` 404 get "/rpc/sayhello?any_arg=value" `shouldRespondWith` 404 + it "should not ignore unknown args and fail with 404" $ get "/rpc/add_them?a=1&b=2&smthelse=blabla" `shouldRespondWith` - let - message :: Text - message - | actualPgVersion < pgVersion95 = "function test.add_them(a := integer, b := integer, smthelse := text) does not exist" - | otherwise = "function test.add_them(a => integer, b => integer, smthelse => text) does not exist" - in [json| { - "code": "42883", - "details": null, - "hint": "No function matches the given name and argument types. You might need to add explicit type casts.", - "message": #{message} } |] + [json| { + "hint":"If a new function was created in the database with this name and arguments, try reloading the schema cache.", + "message":"Could not find the test.add_them(a, b, smthelse) function in the schema cache" } |] { matchStatus = 404 , matchHeaders = [matchContentTypeJson] } + it "should fail with 404 when no json arg is found with prefer single object" $ + request methodPost "/rpc/sayhello" + [("Prefer","params=single-object")] + [json|{}|] + `shouldRespondWith` + [json| { + "hint":"If a new function was created in the database with this name and arguments, try reloading the schema cache.", + "message":"Could not find the test.sayhello function with a single json or jsonb argument in the schema cache" } |] + { matchStatus = 404 + , matchHeaders = [matchContentTypeJson] + } + + it "should fail with 404 for overloaded functions with unknown args" $ do + get "/rpc/overloaded?wrong_arg=value" `shouldRespondWith` + [json| { + "hint":"If a new function was created in the database with this name and arguments, try reloading the schema cache.", + "message":"Could not find the test.overloaded(wrong_arg) function in the schema cache" } |] + { matchStatus = 404 + , matchHeaders = [matchContentTypeJson] + } + get "/rpc/overloaded?a=1&b=2&wrong_arg=value" `shouldRespondWith` + [json| { + "hint":"If a new function was created in the database with this name and arguments, try reloading the schema cache.", + "message":"Could not find the test.overloaded(a, b, wrong_arg) function in the schema cache" } |] + { matchStatus = 404 + , matchHeaders = [matchContentTypeJson] + } + + context "ambiguous overloaded functions with same arguments but different types" $ do + it "should fail with 300 Multiple Choices without explicit argument type casts" $ + get "/rpc/overloaded_same_args?arg=value" `shouldRespondWith` + [json| { + "hint":"Overloaded functions with the same argument name but different types are not supported", + "message":"Could not choose the best candidate function between: test.overloaded_same_args(arg => integer), test.overloaded_same_args(arg => xml), test.overloaded_same_args(arg => text, num => integer)" } |] + { matchStatus = 300 + , matchHeaders = [matchContentTypeJson] + } + it "works when having uppercase identifiers" $ do get "/rpc/quotedFunction?user=mscott&fullName=Michael Scott&SSN=401-32-XXXX" `shouldRespondWith` [json|{"user": "mscott", "fullName": "Michael Scott", "SSN": "401-32-XXXX"}|] @@ -128,9 +164,9 @@ context "shaping the response returned by a proc" $ do it "returns a project" $ do post "/rpc/getproject" [json| { "id": 1} |] `shouldRespondWith` - [str|[{"id":1,"name":"Windows 7","client_id":1}]|] + [json|[{"id":1,"name":"Windows 7","client_id":1}]|] get "/rpc/getproject?id=1" `shouldRespondWith` - [str|[{"id":1,"name":"Windows 7","client_id":1}]|] + [json|[{"id":1,"name":"Windows 7","client_id":1}]|] it "can filter proc results" $ do post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id" [json| {} |] `shouldRespondWith` @@ -152,9 +188,9 @@ it "select works on the first level" $ do post "/rpc/getproject?select=id,name" [json| { "id": 1} |] `shouldRespondWith` - [str|[{"id":1,"name":"Windows 7"}]|] + [json|[{"id":1,"name":"Windows 7"}]|] get "/rpc/getproject?id=1&select=id,name" `shouldRespondWith` - [str|[{"id":1,"name":"Windows 7"}]|] + [json|[{"id":1,"name":"Windows 7"}]|] context "foreign entities embedding" $ do it "can embed if related tables are in the exposed schema" $ do @@ -172,12 +208,13 @@ `shouldRespondWith` 400 it "can embed if the related tables are in a hidden schema but exposed as views" $ do - post "/rpc/single_article?select=id,articleStars(userId)" [json|{ "id": 2}|] - `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|] - { matchHeaders = [matchContentTypeJson] } + post "/rpc/single_article?select=id,articleStars(userId)" + [json|{ "id": 2}|] + `shouldRespondWith` + [json|{"id": 2, "articleStars": [{"userId": 3}]}|] get "/rpc/single_article?id=2&select=id,articleStars(userId)" - `shouldRespondWith` [json|[{"id": 2, "articleStars": [{"userId": 3}]}]|] - { matchHeaders = [matchContentTypeJson] } + `shouldRespondWith` + [json|{"id": 2, "articleStars": [{"userId": 3}]}|] it "can embed an M2M relationship table" $ get "/rpc/getallusers?select=name,tasks(name)&id=gt.1" @@ -202,6 +239,16 @@ ]|] { matchHeaders = [matchContentTypeJson] } + when (actualPgVersion >= pgVersion110) $ + it "can embed if rpc returns domain of table type" $ do + post "/rpc/getproject_domain?select=id,name,client:clients(id),tasks(id)" + [json| { "id": 1} |] + `shouldRespondWith` + [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|] + get "/rpc/getproject_domain?id=1&select=id,name,client:clients(id),tasks(id)" + `shouldRespondWith` + [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|] + context "a proc that returns an empty rowset" $ it "returns empty json array" $ do post "/rpc/test_empty_rowset" [json| {} |] `shouldRespondWith` @@ -229,11 +276,10 @@ { 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] } + post "/rpc/ret_setof_integers" + [json|{}|] + `shouldRespondWith` + [json|[1,2,3]|] it "returns enum value" $ post "/rpc/ret_enum" [json|{ "val": "foo" }|] `shouldRespondWith` @@ -256,41 +302,154 @@ { matchHeaders = [matchContentTypeJson] } it "returns composite type in exposed schema" $ - post "/rpc/ret_point_2d" [json|{}|] `shouldRespondWith` - [json|[{"x": 10, "y": 5}]|] - { matchHeaders = [matchContentTypeJson] } + post "/rpc/ret_point_2d" + [json|{}|] + `shouldRespondWith` + [json|{"x": 10, "y": 5}|] it "cannot return composite type in hidden schema" $ post "/rpc/ret_point_3d" [json|{}|] `shouldRespondWith` 401 + when (actualPgVersion >= pgVersion110) $ + it "returns domain of composite type" $ + post "/rpc/ret_composite_domain" + [json|{}|] + `shouldRespondWith` + [json|{"x": 10, "y": 5}|] + it "returns single row from table" $ - post "/rpc/single_article?select=id" [json|{"id": 2}|] `shouldRespondWith` - [json|[{"id": 2}]|] - { matchHeaders = [matchContentTypeJson] } + post "/rpc/single_article?select=id" + [json|{"id": 2}|] + `shouldRespondWith` + [json|{"id": 2}|] it "returns null for void" $ - post "/rpc/ret_void" [json|{}|] `shouldRespondWith` - [json|null|] - { matchHeaders = [matchContentTypeJson] } + post "/rpc/ret_void" + [json|{}|] + `shouldRespondWith` + "null" + { matchHeaders = [matchContentTypeJson] } + it "returns null for an integer with null value" $ + post "/rpc/ret_null" + [json|{}|] + `shouldRespondWith` + "null" + { matchHeaders = [matchContentTypeJson] } + + context "different types when overloaded" $ do + it "returns composite type" $ + post "/rpc/ret_point_overloaded" + [json|{"x": 1, "y": 2}|] + `shouldRespondWith` + [json|{"x": 1, "y": 2}|] + + it "returns json scalar with prefer single object" $ + request methodPost "/rpc/ret_point_overloaded" [("Prefer","params=single-object")] + [json|{"x": 1, "y": 2}|] + `shouldRespondWith` + [json|{"x": 1, "y": 2}|] + { matchHeaders = [matchContentTypeJson] } + context "proc argument types" $ do - it "accepts a variety of arguments" $ - post "/rpc/varied_arguments" - [json| { - "double": 3.1, - "varchar": "hello", - "boolean": true, - "date": "20190101", - "money": 0, - "enum": "foo", - "integer": 43, - "json": {"some key": "some value"}, - "jsonb": {"another key": [1, 2, "3"]} - } |] + -- different syntax for array needed for pg<10 + when (actualPgVersion < pgVersion100) $ + it "accepts a variety of arguments (Postgres < 10)" $ + post "/rpc/varied_arguments" + [json| { + "double": 3.1, + "varchar": "hello", + "boolean": true, + "date": "20190101", + "money": 0, + "enum": "foo", + "arr": "{a,b,c}", + "integer": 43, + "json": {"some key": "some value"}, + "jsonb": {"another key": [1, 2, "3"]} + } |] + `shouldRespondWith` + [json| { + "double": 3.1, + "varchar": "hello", + "boolean": true, + "date": "2019-01-01", + "money": "$0.00", + "enum": "foo", + "arr": ["a", "b", "c"], + "integer": 43, + "json": {"some key": "some value"}, + "jsonb": {"another key": [1, 2, "3"]} + } |] + { matchHeaders = [matchContentTypeJson] } + + when (actualPgVersion >= pgVersion100) $ + it "accepts a variety of arguments (Postgres >= 10)" $ + post "/rpc/varied_arguments" + [json| { + "double": 3.1, + "varchar": "hello", + "boolean": true, + "date": "20190101", + "money": 0, + "enum": "foo", + "arr": ["a", "b", "c"], + "integer": 43, + "json": {"some key": "some value"}, + "jsonb": {"another key": [1, 2, "3"]} + } |] + `shouldRespondWith` + [json| { + "double": 3.1, + "varchar": "hello", + "boolean": true, + "date": "2019-01-01", + "money": "$0.00", + "enum": "foo", + "arr": ["a", "b", "c"], + "integer": 43, + "json": {"some key": "some value"}, + "jsonb": {"another key": [1, 2, "3"]} + } |] + { matchHeaders = [matchContentTypeJson] } + + it "accepts a variety of arguments with GET" $ + -- without JSON / JSONB here, because passing those via query string is useless - they just become a "json string" all the time + get "/rpc/varied_arguments?double=3.1&varchar=hello&boolean=true&date=20190101&money=0&enum=foo&arr=%7Ba,b,c%7D&integer=43" `shouldRespondWith` - [json|"Hi"|] + [json| { + "double": 3.1, + "varchar": "hello", + "boolean": true, + "date": "2019-01-01", + "money": "$0.00", + "enum": "foo", + "arr": ["a", "b", "c"], + "integer": 43, + "json": {}, + "jsonb": {} + } |] { matchHeaders = [matchContentTypeJson] } + it "accepts a variety of arguments from an html form" $ + request methodPost "/rpc/varied_arguments" + [("Content-Type", "application/x-www-form-urlencoded")] + "double=3.1&varchar=hello&boolean=true&date=20190101&money=0&enum=foo&arr=%7Ba,b,c%7D&integer=43" + `shouldRespondWith` + [json| { + "double": 3.1, + "varchar": "hello", + "boolean": true, + "date": "2019-01-01", + "money": "$0.00", + "enum": "foo", + "arr": ["a", "b", "c"], + "integer": 43, + "json": {}, + "jsonb": {} + } |] + { matchHeaders = [matchContentTypeJson] } + it "parses embedded JSON arguments as JSON" $ post "/rpc/json_argument" [json| { "arg": { "key": 3 } } |] @@ -352,13 +511,25 @@ `shouldRespondWith` 405 it "executes the proc exactly once per request" $ do - post "/rpc/callcounter" [json| {} |] `shouldRespondWith` - [json|1|] - { matchHeaders = [matchContentTypeJson] } - post "/rpc/callcounter" [json| {} |] `shouldRespondWith` - [json|2|] - { matchHeaders = [matchContentTypeJson] } + -- callcounter is persistent even with rollback, because it uses a sequence + -- reset counter first to make test repeatable + request methodPost "/rpc/reset_sequence" + [("Prefer", "tx=commit")] + [json|{"name": "callcounter_count", "value": 1}|] + `shouldRespondWith` + [json|""|] + -- now the test + post "/rpc/callcounter" + [json|{}|] + `shouldRespondWith` + [json|1|] + + post "/rpc/callcounter" + [json|{}|] + `shouldRespondWith` + [json|2|] + context "a proc that receives no parameters" $ do it "interprets empty string as empty json object on a post request" $ post "/rpc/noparamsproc" BL.empty `shouldRespondWith` @@ -376,29 +547,101 @@ [json|[{"test":"hello","value":1}]|] { matchHeaders = [matchContentTypeJson] } context "procs with OUT/INOUT params" $ do - it "returns a scalar result when there is a single OUT param" $ do - get "/rpc/single_out_param?num=5" `shouldRespondWith` - [json|6|] { matchHeaders = [matchContentTypeJson] } - get "/rpc/single_json_out_param?a=1&b=two" `shouldRespondWith` - [json|{"a": 1, "b": "two"}|] { matchHeaders = [matchContentTypeJson] } + it "returns an object result when there is a single OUT param" $ do + get "/rpc/single_out_param?num=5" + `shouldRespondWith` + [json|{"num_plus_one":6}|] - it "returns a scalar result when there is a single INOUT param" $ - get "/rpc/single_inout_param?num=2" `shouldRespondWith` - [json|3|] { matchHeaders = [matchContentTypeJson] } + get "/rpc/single_json_out_param?a=1&b=two" + `shouldRespondWith` + [json|{"my_json": {"a": 1, "b": "two"}}|] - it "returns a row result when there are many OUT params" $ - get "/rpc/many_out_params" `shouldRespondWith` - [json|[{"my_json":{"a": 1, "b": "two"},"num":3,"str":"four"}]|] { matchHeaders = [matchContentTypeJson] } + it "returns an object result when there is a single INOUT param" $ + get "/rpc/single_inout_param?num=2" + `shouldRespondWith` + [json|{"num":3}|] - it "returns a row result when there are many INOUT params" $ - get "/rpc/many_inout_params?num=1&str=two&b=false" `shouldRespondWith` - [json| [{"num":1,"str":"two","b":false}]|] { matchHeaders = [matchContentTypeJson] } + it "returns an object result when there are many OUT params" $ + get "/rpc/many_out_params" + `shouldRespondWith` + [json|{"my_json":{"a": 1, "b": "two"},"num":3,"str":"four"}|] + it "returns an object result when there are many INOUT params" $ + get "/rpc/many_inout_params?num=1&str=two&b=false" + `shouldRespondWith` + [json|{"num":1,"str":"two","b":false}|] + + context "procs with VARIADIC params" $ do + when (actualPgVersion < pgVersion100) $ + it "works with POST (Postgres < 10)" $ + post "/rpc/variadic_param" + [json| { "v": "{hi,hello,there}" } |] + `shouldRespondWith` + [json|["hi", "hello", "there"]|] + + when (actualPgVersion >= pgVersion100) $ do + it "works with POST (Postgres >= 10)" $ + post "/rpc/variadic_param" + [json| { "v": ["hi", "hello", "there"] } |] + `shouldRespondWith` + [json|["hi", "hello", "there"]|] + + context "works with GET and repeated params" $ do + it "n=0 (through DEFAULT)" $ + get "/rpc/variadic_param" + `shouldRespondWith` + [json|[]|] + + it "n=1" $ + get "/rpc/variadic_param?v=hi" + `shouldRespondWith` + [json|["hi"]|] + + it "n>1" $ + get "/rpc/variadic_param?v=hi&v=there" + `shouldRespondWith` + [json|["hi", "there"]|] + + context "works with POST and repeated params from html form" $ do + it "n=0 (through DEFAULT)" $ + request methodPost "/rpc/variadic_param" + [("Content-Type", "application/x-www-form-urlencoded")] + "" + `shouldRespondWith` + [json|[]|] + + it "n=1" $ + request methodPost "/rpc/variadic_param" + [("Content-Type", "application/x-www-form-urlencoded")] + "v=hi" + `shouldRespondWith` + [json|["hi"]|] + + it "n>1" $ + request methodPost "/rpc/variadic_param" + [("Content-Type", "application/x-www-form-urlencoded")] + "v=hi&v=there" + `shouldRespondWith` + [json|["hi", "there"]|] + + it "returns last value for repeated params without VARIADIC" $ + get "/rpc/sayhello?name=ignored&name=world" + `shouldRespondWith` + [json|"Hello, world"|] + + when (actualPgVersion >= pgVersion100) $ + it "returns last value for repeated non-variadic params in function with other VARIADIC arguments" $ + get "/rpc/sayhello_variadic?name=ignored&name=world&v=unused" + `shouldRespondWith` + [json|"Hello, world"|] + it "can handle procs with args that have a DEFAULT value" $ do - get "/rpc/many_inout_params?num=1&str=two" `shouldRespondWith` - [json| [{"num":1,"str":"two","b":true}]|] { matchHeaders = [matchContentTypeJson] } - get "/rpc/three_defaults?b=4" `shouldRespondWith` - [json|8|] { matchHeaders = [matchContentTypeJson] } + get "/rpc/many_inout_params?num=1&str=two" + `shouldRespondWith` + [json| {"num":1,"str":"two","b":true}|] + get "/rpc/three_defaults?b=4" + `shouldRespondWith` + [json|8|] it "can map a RAISE error code and message to a http status" $ get "/rpc/raise_pt402" @@ -436,23 +679,56 @@ `shouldRespondWith` [json|{ "p1": "1", "p2": "text"}|] { matchHeaders = [matchContentTypeJson] } - it "should work with an overloaded function" $ do - get "/rpc/overloaded" `shouldRespondWith` - [json|[{ "overloaded": 1 }, - { "overloaded": 2 }, - { "overloaded": 3 }]|] - { matchHeaders = [matchContentTypeJson] } - request methodPost "/rpc/overloaded" [("Prefer","params=single-object")] - [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|] - `shouldRespondWith` - [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|] - { matchHeaders = [matchContentTypeJson] } - get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|] - get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [str|"123"|] + context "should work with an overloaded function" $ do + it "overloaded()" $ + get "/rpc/overloaded" + `shouldRespondWith` + [json|[1,2,3]|] + it "overloaded(json) single-object" $ + request methodPost "/rpc/overloaded" + [("Prefer","params=single-object")] + [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|] + `shouldRespondWith` + [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|] + + it "overloaded(int, int)" $ + get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|] + + it "overloaded(text, text, text)" $ + get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [json|"123"|] + + it "overloaded_html_form()" $ + request methodPost "/rpc/overloaded_html_form" + [("Content-Type", "application/x-www-form-urlencoded")] + "" + `shouldRespondWith` + [json|[1,2,3]|] + + it "overloaded_html_form(json) single-object" $ + request methodPost "/rpc/overloaded_html_form" + [("Content-Type", "application/x-www-form-urlencoded"), ("Prefer","params=single-object")] + "a=1&b=2&c=3" + `shouldRespondWith` + [json|{"a": "1", "b": "2", "c": "3"}|] + + it "overloaded_html_form(int, int)" $ + request methodPost "/rpc/overloaded_html_form" + [("Content-Type", "application/x-www-form-urlencoded")] + "a=1&b=2" + `shouldRespondWith` + [str|3|] + + it "overloaded_html_form(text, text, text)" $ + request methodPost "/rpc/overloaded_html_form" + [("Content-Type", "application/x-www-form-urlencoded")] + "a=1&b=2&c=3" + `shouldRespondWith` + [json|"123"|] + context "only for POST rpc" $ do it "gives a parse filter error if GET style proc args are specified" $ - post "/rpc/sayhello?name=John" [json|{}|] `shouldRespondWith` 400 + post "/rpc/sayhello?name=John" [json|{name: "John"}|] `shouldRespondWith` 400 it "ignores json keys not included in ?columns" $ post "/rpc/sayhello?columns=name" @@ -512,7 +788,7 @@ [("Custom-Header", "test")] [json| { "name": "request.header.custom-header" } |] `shouldRespondWith` - [str|"test"|] + [json|"test"|] { matchStatus = 200 , matchHeaders = [ matchContentTypeJson ] } @@ -521,7 +797,7 @@ [("Origin", "http://example.com")] [json| { "name": "request.header.origin" } |] `shouldRespondWith` - [str|"http://example.com"|] + [json|"http://example.com"|] { matchStatus = 200 , matchHeaders = [ matchContentTypeJson ] } @@ -529,7 +805,7 @@ request methodPost "/rpc/get_guc_value" [] [json| { "name": "request.jwt.claim.role" } |] `shouldRespondWith` - [str|"postgrest_test_anonymous"|] + [json|"postgrest_test_anonymous"|] { matchStatus = 200 , matchHeaders = [ matchContentTypeJson ] } @@ -537,7 +813,7 @@ request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue")] [json| {"name":"request.cookie.acookie"} |] `shouldRespondWith` - [str|"cookievalue"|] + [json|"cookievalue"|] { matchStatus = 200 , matchHeaders = [] } @@ -545,7 +821,7 @@ request methodPost "/rpc/get_guc_value" [("Cookie","acookie=cookievalue;secondcookie=anothervalue")] [json| {"name":"request.cookie.secondcookie"} |] `shouldRespondWith` - [str|"anothervalue"|] + [json|"anothervalue"|] { matchStatus = 200 , matchHeaders = [] } @@ -553,7 +829,7 @@ request methodPost "/rpc/get_guc_value" [] [json| { "name": "app.settings.app_host" } |] `shouldRespondWith` - [str|"localhost"|] + [json|"localhost"|] { matchStatus = 200 , matchHeaders = [ matchContentTypeJson ] } @@ -561,7 +837,7 @@ request methodPost "/rpc/get_guc_value" [authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"] [json| {"name":"request.header.authorization"} |] `shouldRespondWith` - [str|"Bearer eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"|] + [json|"Bearer eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA"|] { matchStatus = 200 , matchHeaders = [] } @@ -569,7 +845,7 @@ request methodPost "/rpc/get_guc_value" [] [json| {"name":"request.method"} |] `shouldRespondWith` - [str|"POST"|] + [json|"POST"|] { matchStatus = 200 , matchHeaders = [] } @@ -577,7 +853,7 @@ request methodPost "/rpc/get_guc_value" [] [json| {"name":"request.path"} |] `shouldRespondWith` - [str|"/rpc/get_guc_value"|] + [json|"/rpc/get_guc_value"|] { matchStatus = 200 , matchHeaders = [] } @@ -588,7 +864,7 @@ 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"] + , matchHeaders = ["Content-Type" <:> "application/octet-stream"] } it "can get raw output with Accept: text/plain" $ @@ -598,26 +874,36 @@ , matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"] } + context "Proc that returns set of scalars" $ + it "can query without selecting column" $ + request methodGet "/rpc/welcome_twice" + (acceptHdrs "text/plain") + "" + `shouldRespondWith` + "Welcome to PostgRESTWelcome to PostgREST" + { matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "text/plain; 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"] + , matchHeaders = ["Content-Type" <:> "application/octet-stream"] } it "fails if a single column is not selected" $ - request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") "" + request methodPost "/rpc/ret_rows_with_base64_bin" + (acceptHdrs "application/octet-stream") "" `shouldRespondWith` - [json| {"message":"application/octet-stream requested but more than one column was selected"} |] - { matchStatus = 406 - , matchHeaders = [matchContentTypeJson] - } + [json| {"message":"application/octet-stream requested but more than one column was selected"} |] + { matchStatus = 406 } context "only for GET rpc" $ do it "should fail on mutating procs" $ do - get "/rpc/callcounter" `shouldRespondWith` 500 - get "/rpc/setprojects?id_l=1&id_h=5&name=FreeBSD" `shouldRespondWith` 500 + get "/rpc/callcounter" `shouldRespondWith` 405 + get "/rpc/setprojects?id_l=1&id_h=5&name=FreeBSD" `shouldRespondWith` 405 it "should filter a proc that has arg name = filter name" $ get "/rpc/get_projects_below?id=5&id=gt.2&select=id" `shouldRespondWith` @@ -647,7 +933,129 @@ [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|] { matchHeaders = [matchContentTypeJson] } + when (actualPgVersion >= pgVersion96) $ + it "should work with the phraseto_tsquery function" $ + get "/rpc/get_tsearch?text_search_vector=phfts(english).impossible" `shouldRespondWith` + [json|[{"text_search_vector":"'fun':5 'imposs':9 'kind':3"}]|] + { matchHeaders = [matchContentTypeJson] } + it "should work with an argument of custom type in public schema" $ get "/rpc/test_arg?my_arg=something" `shouldRespondWith` [json|"foobar"|] { matchHeaders = [matchContentTypeJson] } + + when (actualPgVersion >= pgVersion96) $ do + context "GUC headers on function calls" $ do + it "succeeds setting the headers" $ do + get "/rpc/get_projects_and_guc_headers?id=eq.2&select=id" + `shouldRespondWith` [json|[{"id": 2}]|] + {matchHeaders = [ + matchContentTypeJson, + "X-Test" <:> "key1=val1; someValue; key2=val2", + "X-Test-2" <:> "key1=val1"]} + get "/rpc/get_int_and_guc_headers?num=1" + `shouldRespondWith` [json|1|] + {matchHeaders = [ + matchContentTypeJson, + "X-Test" <:> "key1=val1; someValue; key2=val2", + "X-Test-2" <:> "key1=val1"]} + post "/rpc/get_int_and_guc_headers" [json|{"num": 1}|] + `shouldRespondWith` [json|1|] + {matchHeaders = [ + matchContentTypeJson, + "X-Test" <:> "key1=val1; someValue; key2=val2", + "X-Test-2" <:> "key1=val1"]} + + it "fails when setting headers with wrong json structure" $ do + get "/rpc/bad_guc_headers_1" + `shouldRespondWith` + [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|] + { matchStatus = 500 + , matchHeaders = [ matchContentTypeJson ] + } + get "/rpc/bad_guc_headers_2" + `shouldRespondWith` + [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|] + { matchStatus = 500 + , matchHeaders = [ matchContentTypeJson ] + } + get "/rpc/bad_guc_headers_3" + `shouldRespondWith` + [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|] + { matchStatus = 500 + , matchHeaders = [ matchContentTypeJson ] + } + post "/rpc/bad_guc_headers_1" [json|{}|] + `shouldRespondWith` + [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|] + { matchStatus = 500 + , matchHeaders = [ matchContentTypeJson ] + } + + it "can set the same http header twice" $ + get "/rpc/set_cookie_twice" + `shouldRespondWith` + "null" + { matchHeaders = [ matchContentTypeJson + , "Set-Cookie" <:> "sessionid=38afes7a8; HttpOnly; Path=/" + , "Set-Cookie" <:> "id=a3fWa; Expires=Wed, 21 Oct 2015 07:28:00 GMT; Secure; HttpOnly" ]} + + it "can override the Location header on a trigger" $ + post "/stuff" + [json|[{"id": 2, "name": "stuff 2"}]|] + `shouldRespondWith` + "" + { matchStatus = 201 + , matchHeaders = ["Location" <:> "/stuff?id=eq.2&overriden=true"] + } + + -- On https://github.com/PostgREST/postgrest/issues/1427#issuecomment-595907535 + -- it was reported that blank headers ` : ` where added and that cause proxies to fail the requests. + -- These tests are to ensure no blank headers are added. + context "Blank headers bug" $ do + it "shouldn't add blank headers on POST" $ do + r <- request methodPost "/loc_test" [] [json|{"id": "1", "c": "c1"}|] + liftIO $ do + let respHeaders = simpleHeaders r + respHeaders `shouldSatisfy` noBlankHeader + + it "shouldn't add blank headers on PATCH" $ do + r <- request methodPatch "/loc_test?id=eq.1" [] [json|{"c": "c2"}|] + liftIO $ do + let respHeaders = simpleHeaders r + respHeaders `shouldSatisfy` noBlankHeader + + it "shouldn't add blank headers on GET" $ do + r <- request methodGet "/loc_test" [] "" + liftIO $ do + let respHeaders = simpleHeaders r + respHeaders `shouldSatisfy` noBlankHeader + + it "shouldn't add blank headers on DELETE" $ do + r <- request methodDelete "/loc_test?id=eq.1" [] "" + liftIO $ do + let respHeaders = simpleHeaders r + respHeaders `shouldSatisfy` noBlankHeader + + context "GUC status override" $ do + it "can override the status on RPC" $ + get "/rpc/send_body_status_403" + `shouldRespondWith` + [json|{"message" : "invalid user or password"}|] + { matchStatus = 403 + , matchHeaders = [ matchContentTypeJson ] + } + + it "can override the status through trigger" $ + patch "/stuff?id=eq.1" + [json|[{"name": "updated stuff 1"}]|] + `shouldRespondWith` + 205 + + it "fails when setting invalid status guc" $ + get "/rpc/send_bad_status" + `shouldRespondWith` + [json|{"message":"response.status guc must be a valid status code"}|] + { matchStatus = 500 + , matchHeaders = [ matchContentTypeJson ] + } diff --git a/test/Feature/SingularSpec.hs b/test/Feature/SingularSpec.hs --- a/test/Feature/SingularSpec.hs +++ b/test/Feature/SingularSpec.hs @@ -7,7 +7,6 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Text.Heredoc import Protolude hiding (get) import SpecHelper @@ -16,8 +15,7 @@ spec :: SpecWith ((), Application) spec = describe "Requesting singular json object" $ do - let pgrstObj = "application/vnd.pgrst.object+json" - singular = ("Accept", pgrstObj) + let singular = ("Accept", "application/vnd.pgrst.object+json") context "with GET request" $ do it "fails for zero rows" $ @@ -26,140 +24,171 @@ it "will select an existing object" $ do request methodGet "/items?id=eq.5" [singular] "" - `shouldRespondWith` [str|{"id":5}|] + `shouldRespondWith` + [json|{"id":5}|] + { matchHeaders = [matchContentTypeSingular] } -- also test without the +json suffix request methodGet "/items?id=eq.5" - [("Accept", "application/vnd.pgrst.object")] "" - `shouldRespondWith` [str|{"id":5}|] + [("Accept", "application/vnd.pgrst.object")] "" + `shouldRespondWith` + [json|{"id":5}|] + { matchHeaders = [matchContentTypeSingular] } it "can combine multiple prefer values" $ request methodGet "/items?id=eq.5" [singular, ("Prefer","count=none")] "" - `shouldRespondWith` [str|{"id":5}|] + `shouldRespondWith` + [json|{"id":5}|] + { matchHeaders = [matchContentTypeSingular] } it "can shape plurality singular object routes" $ request methodGet "/projects_view?id=eq.1&select=id,name,clients(*),tasks(id,name)" [singular] "" `shouldRespondWith` [json|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|] - { matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] } + { matchHeaders = [matchContentTypeSingular] } context "when updating rows" $ do - it "works for one row" $ do - _ <- post "/addresses" [json| { id: 97, address: "A Street" } |] - request methodPatch - "/addresses?id=eq.97" - [("Prefer", "return=representation"), singular] - [json| { address: "B Street" } |] + it "works for one row with return=rep" $ do + request methodPatch "/addresses?id=eq.1" + [("Prefer", "return=representation"), singular] + [json| { address: "B Street" } |] `shouldRespondWith` - [str|{"id":97,"address":"B Street"}|] + [json|{"id":1,"address":"B Street"}|] + { matchHeaders = [matchContentTypeSingular] } + it "works for one row with return=minimal" $ + request methodPatch "/addresses?id=eq.1" + [("Prefer", "return=minimal"), singular] + [json| { address: "C Street" } |] + `shouldRespondWith` + "" + { matchStatus = 204 } + it "raises an error for multiple rows" $ do - _ <- post "/addresses" [json| { id: 98, address: "xxx" } |] - _ <- post "/addresses" [json| { id: 99, address: "yyy" } |] - p <- request methodPatch "/addresses?id=gt.0" - [singular] - [json| { address: "zzz" } |] - liftIO $ do - simpleStatus p `shouldBe` notAcceptable406 - isErrorFormat (simpleBody p) `shouldBe` True + request methodPatch "/addresses" + [("Prefer", "tx=commit"), singular] + [json| { address: "zzz" } |] + `shouldRespondWith` + [json|{"details":"Results contain 4 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + { matchStatus = 406 + , matchHeaders = [ matchContentTypeSingular + , "Preference-Applied" <:> "tx=commit" ] + } -- the rows should not be updated, either - get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|] + get "/addresses?id=eq.1" + `shouldRespondWith` + [json|[{"id":1,"address":"address 1"}]|] it "raises an error for multiple rows with return=rep" $ do - _ <- post "/addresses" [json| { id: 100, address: "xxx" } |] - _ <- post "/addresses" [json| { id: 101, address: "yyy" } |] - p <- request methodPatch "/addresses?id=gt.0" - [("Prefer", "return=representation"), singular] - [json| { address: "zzz" } |] - liftIO $ do - simpleStatus p `shouldBe` notAcceptable406 - isErrorFormat (simpleBody p) `shouldBe` True + request methodPatch "/addresses" + [("Prefer", "tx=commit"), ("Prefer", "return=representation"), singular] + [json| { address: "zzz" } |] + `shouldRespondWith` + [json|{"details":"Results contain 4 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + { matchStatus = 406 + , matchHeaders = [ matchContentTypeSingular + , "Preference-Applied" <:> "tx=commit" ] + } -- the rows should not be updated, either - get "/addresses?id=eq.100" `shouldRespondWith` [str|[{"id":100,"address":"xxx"}]|] + get "/addresses?id=eq.1" + `shouldRespondWith` + [json|[{"id":1,"address":"address 1"}]|] it "raises an error for zero rows" $ request methodPatch "/items?id=gt.0&id=lt.0" [singular] [json|{"id":1}|] `shouldRespondWith` - [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + [json|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + , matchHeaders = [matchContentTypeSingular] } it "raises an error for zero rows with return=rep" $ request methodPatch "/items?id=gt.0&id=lt.0" [("Prefer", "return=representation"), singular] [json|{"id":1}|] `shouldRespondWith` - [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + [json|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + , matchHeaders = [matchContentTypeSingular] } context "when creating rows" $ do - it "works for one row" $ do - p <- request methodPost - "/addresses" - [("Prefer", "return=representation"), singular] - [json| [ { id: 102, address: "xxx" } ] |] - liftIO $ simpleBody p `shouldBe` [str|{"id":102,"address":"xxx"}|] + it "works for one row with return=rep" $ do + request methodPost "/addresses" + [("Prefer", "return=representation"), singular] + [json| [ { id: 102, address: "xxx" } ] |] + `shouldRespondWith` + [json|{"id":102,"address":"xxx"}|] + { matchStatus = 201 + , matchHeaders = [matchContentTypeSingular] + } - it "works for one row even with return=minimal" $ do + it "works for one row with return=minimal" $ do request methodPost "/addresses" - [("Prefer", "return=minimal"), singular] - [json| [ { id: 103, address: "xxx" } ] |] + [("Prefer", "return=minimal"), singular] + [json| [ { id: 103, address: "xxx" } ] |] `shouldRespondWith` "" - { matchStatus = 201 - , matchHeaders = ["Content-Range" <:> "*/*"] - } - -- and the element should exist - get "/addresses?id=eq.103" - `shouldRespondWith` [str|[{"id":103,"address":"xxx"}]|] - { matchStatus = 200 - , matchHeaders = [] - } + { matchStatus = 201 + , matchHeaders = ["Content-Range" <:> "*/*"] + } it "raises an error when attempting to create multiple entities" $ do - p <- request methodPost - "/addresses" - [singular] - [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |] - liftIO $ simpleStatus p `shouldBe` notAcceptable406 + request methodPost "/addresses" + [("Prefer", "tx=commit"), singular] + [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |] + `shouldRespondWith` + [json|{"details":"Results contain 2 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + { matchStatus = 406 + , matchHeaders = [ matchContentTypeSingular + , "Preference-Applied" <:> "tx=commit" ] + } -- the rows should not exist, either - get "/addresses?id=eq.200" `shouldRespondWith` "[]" + get "/addresses?id=eq.200" + `shouldRespondWith` + "[]" it "raises an error when attempting to create multiple entities with return=rep" $ do - p <- request methodPost - "/addresses" - [("Prefer", "return=representation"), singular] - [json| [ { id: 202, address: "xxx" }, { id: 203, address: "yyy" } ] |] - liftIO $ simpleStatus p `shouldBe` notAcceptable406 + request methodPost "/addresses" + [("Prefer", "tx=commit"), ("Prefer", "return=representation"), singular] + [json| [ { id: 202, address: "xxx" }, { id: 203, address: "yyy" } ] |] + `shouldRespondWith` + [json|{"details":"Results contain 2 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + { matchStatus = 406 + , matchHeaders = [ matchContentTypeSingular + , "Preference-Applied" <:> "tx=commit" ] + } -- the rows should not exist, either - get "/addresses?id=eq.202" `shouldRespondWith` "[]" + get "/addresses?id=eq.202" + `shouldRespondWith` + "[]" it "raises an error regardless of return=minimal" $ do request methodPost "/addresses" - [("Prefer", "return=minimal"), singular] - [json| [ { id: 204, address: "xxx" }, { id: 205, address: "yyy" } ] |] + [("Prefer", "tx=commit"), ("Prefer", "return=minimal"), singular] + [json| [ { id: 204, address: "xxx" }, { id: 205, address: "yyy" } ] |] `shouldRespondWith` - [str|{"details":"Results contain 2 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] - { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] - } + [json|{"details":"Results contain 2 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + { matchStatus = 406 + , matchHeaders = [ matchContentTypeSingular + , "Preference-Applied" <:> "tx=commit" ] + } -- the rows should not exist, either - get "/addresses?id=eq.204" `shouldRespondWith` "[]" + get "/addresses?id=eq.204" + `shouldRespondWith` + "[]" it "raises an error when creating zero entities" $ request methodPost "/addresses" [singular] [json| [ ] |] `shouldRespondWith` - [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + [json|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + , matchHeaders = [matchContentTypeSingular] } it "raises an error when creating zero entities with return=rep" $ @@ -167,58 +196,76 @@ [("Prefer", "return=representation"), singular] [json| [ ] |] `shouldRespondWith` - [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + [json|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + , matchHeaders = [matchContentTypeSingular] } context "when deleting rows" $ do - it "works for one row" $ do + it "works for one row with return=rep" $ do p <- request methodDelete "/items?id=eq.11" [("Prefer", "return=representation"), singular] "" - liftIO $ simpleBody p `shouldBe` [str|{"id":11}|] + liftIO $ simpleBody p `shouldBe` [json|{"id":11}|] + it "works for one row with return=minimal" $ do + p <- request methodDelete + "/items?id=eq.12" + [("Prefer", "return=minimal"), singular] "" + liftIO $ simpleBody p `shouldBe` "" + it "raises an error when attempting to delete multiple entities" $ do - let firstItems = "/items?id=gt.0&id=lt.6" - request methodDelete firstItems - [singular] "" - `shouldRespondWith` 406 + request methodDelete "/items?id=gt.0&id=lt.6" + [("Prefer", "tx=commit"), singular] + "" + `shouldRespondWith` + [json|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + { matchStatus = 406 + , matchHeaders = [ matchContentTypeSingular + , "Preference-Applied" <:> "tx=commit" ] + } - get firstItems - `shouldRespondWith` [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5}] |] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-4/*"] - } + -- the rows should still exist + get "/items?id=gt.0&id=lt.6&order=id" + `shouldRespondWith` + [json| [{"id":1},{"id":2},{"id":3},{"id":4},{"id":5}] |] + { matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-4/*"] + } it "raises an error when attempting to delete multiple entities with return=rep" $ do - let firstItems = "/items?id=gt.5&id=lt.11" - request methodDelete firstItems - [("Prefer", "return=representation"), singular] "" - `shouldRespondWith` 406 + request methodDelete "/items?id=gt.5&id=lt.11" + [("Prefer", "tx=commit"), ("Prefer", "return=representation"), singular] "" + `shouldRespondWith` + [json|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + { matchStatus = 406 + , matchHeaders = [ matchContentTypeSingular + , "Preference-Applied" <:> "tx=commit" ] + } - get firstItems + -- the rows should still exist + get "/items?id=gt.5&id=lt.11" `shouldRespondWith` [json| [{"id":6},{"id":7},{"id":8},{"id":9},{"id":10}] |] - { matchStatus = 200 - , matchHeaders = ["Content-Range" <:> "0-4/*"] - } + { matchStatus = 200 + , matchHeaders = ["Content-Range" <:> "0-4/*"] + } it "raises an error when deleting zero entities" $ request methodDelete "/items?id=lt.0" [singular] "" `shouldRespondWith` - [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + [json|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + , matchHeaders = [matchContentTypeSingular] } it "raises an error when deleting zero entities with return=rep" $ request methodDelete "/items?id=lt.0" [("Prefer", "return=representation"), singular] "" `shouldRespondWith` - [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + [json|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + , matchHeaders = [matchContentTypeSingular] } context "when calling a stored proc" $ do @@ -226,9 +273,9 @@ request methodPost "/rpc/getproject" [singular] [json|{ "id": 9999999}|] `shouldRespondWith` - [str|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + [json|{"details":"Results contain 0 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + , matchHeaders = [matchContentTypeSingular] } -- this one may be controversial, should vnd.pgrst.object include @@ -240,30 +287,38 @@ it "returns a single object for json proc" $ request methodPost "/rpc/getproject" - [singular] [json|{ "id": 1}|] `shouldRespondWith` - [str|{"id":1,"name":"Windows 7","client_id":1}|] + [singular] [json|{ "id": 1}|] + `shouldRespondWith` + [json|{"id":1,"name":"Windows 7","client_id":1}|] + { matchHeaders = [matchContentTypeSingular] } it "fails for multiple rows" $ request methodPost "/rpc/getallprojects" [singular] "{}" `shouldRespondWith` - [str|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + [json|{"details":"Results contain 5 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + , matchHeaders = [matchContentTypeSingular] } - it "executes the proc exactly once per request" $ do - request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |] - `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|] + it "fails for multiple rows with rolled back changes" $ do + post "/rpc/getproject?select=id,name" + [json| {"id": 1} |] + `shouldRespondWith` + [json|[{"id":1,"name":"Windows 7"}]|] - request methodPost "/rpc/setprojects" [singular] - [json| {"id_l": 1, "id_h": 2, "name": "changed"} |] + request methodPost "/rpc/setprojects" + [("Prefer", "tx=commit"), singular] + [json| {"id_l": 1, "id_h": 2, "name": "changed"} |] `shouldRespondWith` - [str|{"details":"Results contain 2 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] - { matchStatus = 406 - , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] - } + [json|{"details":"Results contain 2 rows, application/vnd.pgrst.object+json requires 1 row","message":"JSON object requested, multiple (or no) rows returned"}|] + { matchStatus = 406 + , matchHeaders = [ matchContentTypeSingular + , "Preference-Applied" <:> "tx=commit" ] + } - -- should not actually have executed the function - request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |] - `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|] + -- should rollback function + post "/rpc/getproject?select=id,name" + [json| {"id": 1} |] + `shouldRespondWith` + [json|[{"id":1,"name":"Windows 7"}]|] diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs deleted file mode 100644 --- a/test/Feature/StructureSpec.hs +++ /dev/null @@ -1,516 +0,0 @@ -module Feature.StructureSpec where - -import Control.Lens ((^?)) -import Data.Aeson.Types (Value (..)) -import Network.Wai (Application) -import Network.Wai.Test (SResponse (..)) - -import Data.Aeson.Lens -import Data.Aeson.QQ -import Network.HTTP.Types -import Test.Hspec hiding (pendingWith) -import Test.Hspec.Wai - - - -import PostgREST.Config (docsVersion) -import Protolude hiding (get) -import SpecHelper - -spec :: SpecWith ((), Application) -spec = do - - describe "OpenAPI" $ do - it "root path returns a valid openapi spec" $ do - validateOpenApiResponse [("Accept", "application/openapi+json")] - request methodHead "/" (acceptHdrs "application/openapi+json") "" - `shouldRespondWith` "" { matchStatus = 200 } - - it "should respond to openapi request on none root path with 415" $ - request methodGet "/items" - (acceptHdrs "application/openapi+json") "" - `shouldRespondWith` 415 - - it "includes postgrest.org current version api docs" $ do - r <- simpleBody <$> get "/" - - let docsUrl = r ^? key "externalDocs" . key "url" - - liftIO $ docsUrl `shouldBe` Just (String ("https://postgrest.org/en/" <> docsVersion <> "/api.html")) - - describe "table" $ do - - it "includes paths to tables" $ do - r <- simpleBody <$> get "/" - - 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" - postParameters = r ^? method "post" . 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 - - 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" } - ] - |] - - postParameters `shouldBe` Just - [aesonQQ| - [ - { "$ref": "#/parameters/body.child_entities" }, - { "$ref": "#/parameters/select" }, - { "$ref": "#/parameters/preferReturn" } - ] - |] - - postResponse `shouldBe` Just "Created" - - patchResponse `shouldBe` Just "No Content" - - deleteResponse `shouldBe` Just "No Content" - - it "includes an array type for GET responses" $ do - r <- simpleBody <$> get "/" - - let childGetSchema = r ^? key "paths" - . key "/child_entities" - . key "get" - . key "responses" - . key "200" - . key "schema" - - liftIO $ - childGetSchema `shouldBe` Just - [aesonQQ| - { - "items": { - "$ref": "#/definitions/child_entities" - }, - "type": "array" - } - |] - - 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.", - "format": "integer", - "type": "integer" - }, - "name": { - "description": "child_entities name comment. Can be longer than sixty-three characters long", - "format": "text", - "type": "string" - }, - "parent_id": { - "description": "Note:\nThis is a Foreign Key to `entities.id`.", - "format": "integer", - "type": "integer" - } - }, - "required": [ - "id" - ] - } - |] - - it "doesn't include privileged table for anonymous" $ do - r <- simpleBody <$> get "/" - let tablePath = r ^? key "paths" . key "/authors_only" - - liftIO $ tablePath `shouldBe` Nothing - - it "includes table if user has permission" $ do - let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" - r <- simpleBody <$> request methodGet "/" [auth] "" - let tableTag = r ^? key "paths" . key "/authors_only" - . key "post" . key "tags" - . nth 0 - liftIO $ tableTag `shouldBe` Just [aesonQQ|"authors_only"|] - - describe "Foreign table" $ - - it "includes foreign table properties" $ do - r <- simpleBody <$> get "/" - - let method s = key "paths" . key "/projects_dump" . key s - getSummary = r ^? method "get" . key "summary" - getDescription = r ^? method "get" . key "description" - getParameters = r ^? method "get" . key "parameters" - - liftIO $ do - - getSummary `shouldBe` Just "A temporary projects dump" - - getDescription `shouldBe` Just "Just a test for foreign tables" - - getParameters `shouldBe` Just - [aesonQQ| - [ - { "$ref": "#/parameters/rowFilter.projects_dump.id" }, - { "$ref": "#/parameters/rowFilter.projects_dump.name" }, - { "$ref": "#/parameters/rowFilter.projects_dump.client_id" }, - { "$ref": "#/parameters/select" }, - { "$ref": "#/parameters/order" }, - { "$ref": "#/parameters/range" }, - { "$ref": "#/parameters/rangeUnit" }, - { "$ref": "#/parameters/offset" }, - { "$ref": "#/parameters/limit" }, - { "$ref": "#/parameters/preferCount" } - ] - |] - - describe "Materialized view" $ - - it "includes materialized view properties" $ do - r <- simpleBody <$> get "/" - - let method s = key "paths" . key "/materialized_projects" . key s - summary = r ^? method "get" . key "summary" - description = r ^? method "get" . key "description" - parameters = r ^? method "get" . key "parameters" - - liftIO $ do - - summary `shouldBe` Just "A materialized view for projects" - - description `shouldBe` Just "Just a test for materialized views" - - parameters `shouldBe` Just - [aesonQQ| - [ - { "$ref": "#/parameters/rowFilter.materialized_projects.id" }, - { "$ref": "#/parameters/rowFilter.materialized_projects.name" }, - { "$ref": "#/parameters/rowFilter.materialized_projects.client_id" }, - { "$ref": "#/parameters/select" }, - { "$ref": "#/parameters/order" }, - { "$ref": "#/parameters/range" }, - { "$ref": "#/parameters/rangeUnit" }, - { "$ref": "#/parameters/offset" }, - { "$ref": "#/parameters/limit" }, - { "$ref": "#/parameters/preferCount" } - ] - |] - - describe "VIEW that has a source FK based on a UNIQUE key" $ - - it "includes fk description" $ do - r <- simpleBody <$> get "/" - - let referralLink = r ^? key "definitions" . key "referrals" . key "properties" . key "link" - - liftIO $ - referralLink `shouldBe` Just - [aesonQQ| - { - "format": "integer", - "type": "integer", - "description": "Note:\nThis is a Foreign Key to `pages.link`." - } - |] - - describe "PostgreSQL to Swagger Type Mapping" $ do - - it "character varying to string" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character_varying" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "character varying", - "type": "string" - } - |] - it "character(1) to string" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_character" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "maxLength": 1, - "format": "character", - "type": "string" - } - |] - - it "text to string" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_text" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "text", - "type": "string" - } - |] - - it "boolean to boolean" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_boolean" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "boolean", - "type": "boolean" - } - |] - - it "smallint to integer" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_smallint" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "smallint", - "type": "integer" - } - |] - - it "integer to integer" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_integer" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "integer", - "type": "integer" - } - |] - - it "bigint to integer" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_bigint" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "bigint", - "type": "integer" - } - |] - - it "numeric to number" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_numeric" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "numeric", - "type": "number" - } - |] - - it "real to number" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_real" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "real", - "type": "number" - } - |] - - it "double_precision to number" $ do - r <- simpleBody <$> get "/" - - let types = r ^? key "definitions" . key "openapi_types" . key "properties" . key "a_double_precision" - - liftIO $ - - types `shouldBe` Just - [aesonQQ| - { - "format": "double precision", - "type": "number" - } - |] - - describe "RPC" $ do - - it "includes function summary/description and body schema for arguments" $ do - r <- simpleBody <$> get "/" - - let method s = key "paths" . key "/rpc/varied_arguments" . key s - args = r ^? method "post" . key "parameters" . nth 0 . key "schema" - summary = r ^? method "post" . key "summary" - description = r ^? method "post" . key "description" - - liftIO $ do - - summary `shouldBe` Just "An RPC function" - - description `shouldBe` Just "Just a test for RPC function arguments" - - args `shouldBe` Just - [aesonQQ| - { - "required": [ - "double", - "varchar", - "boolean", - "date", - "money", - "enum" - ], - "properties": { - "double": { - "format": "double precision", - "type": "number" - }, - "varchar": { - "format": "character varying", - "type": "string" - }, - "boolean": { - "format": "boolean", - "type": "boolean" - }, - "date": { - "format": "date", - "type": "string" - }, - "money": { - "format": "money", - "type": "string" - }, - "enum": { - "format": "enum_menagerie_type", - "type": "string" - }, - "integer": { - "format": "integer", - "type": "integer" - }, - "json": { - "format": "json", - "type": "string" - }, - "jsonb": { - "format": "jsonb", - "type": "string" - } - }, - "type": "object", - "description": "An RPC function\n\nJust a test for RPC function arguments" - } - |] - - it "doesn't include privileged function for anonymous" $ do - r <- simpleBody <$> get "/" - let funcPath = r ^? key "paths" . key "/rpc/privileged_hello" - - liftIO $ funcPath `shouldBe` Nothing - - it "includes function if user has permission" $ do - let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" - r <- simpleBody <$> request methodGet "/" [auth] "" - let funcTag = r ^? key "paths" . key "/rpc/privileged_hello" - . key "post" . key "tags" - . nth 0 - - liftIO $ funcTag `shouldBe` Just [aesonQQ|"(rpc) privileged_hello"|] - - it "doesn't include OUT params of function as required parameters" $ do - r <- simpleBody <$> get "/" - let params = r ^? key "paths" . key "/rpc/many_out_params" - . key "post" . key "parameters" . nth 0 - . key "schema". key "required" - - liftIO $ params `shouldBe` Nothing - - it "includes INOUT params(with no DEFAULT) of function as required parameters" $ do - r <- simpleBody <$> get "/" - let params = r ^? key "paths" . key "/rpc/many_inout_params" - . key "post" . key "parameters" . nth 0 - . key "schema". key "required" - - liftIO $ params `shouldBe` Just [aesonQQ|["num", "str"]|] - - describe "Allow header" $ do - - it "includes read/write verbs for writeable table" $ do - r <- request methodOptions "/items" [] "" - liftIO $ - simpleHeaders r `shouldSatisfy` - matchHeader "Allow" "GET,POST,PATCH,DELETE" - - it "includes read verbs for read-only table" $ do - r <- request methodOptions "/has_count_column" [] "" - liftIO $ - simpleHeaders r `shouldSatisfy` - matchHeader "Allow" "GET" diff --git a/test/Feature/UnicodeSpec.hs b/test/Feature/UnicodeSpec.hs --- a/test/Feature/UnicodeSpec.hs +++ b/test/Feature/UnicodeSpec.hs @@ -2,12 +2,12 @@ import Network.Wai (Application) +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Protolude hiding (get) -import SpecHelper +import Protolude hiding (get) spec :: SpecWith ((), Application) spec = @@ -16,9 +16,19 @@ get "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF" `shouldRespondWith` "[]" - void $ post "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF" - [json| { "هویت": 1 } |] + request methodPost "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF" + [("Prefer", "tx=commit"), ("Prefer", "return=representation")] + [json| { "هویت": 1 } |] + `shouldRespondWith` + [json| [{ "هویت": 1 }] |] + { matchStatus = 201 } get "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF" - `shouldRespondWith` [json| [{ "هویت": 1 }] |] - { matchHeaders = [matchContentTypeJson] } + `shouldRespondWith` + [json| [{ "هویت": 1 }] |] + + request methodDelete "/%D9%85%D9%88%D8%A7%D8%B1%D8%AF" + [("Prefer", "tx=commit")] + "" + `shouldRespondWith` + 204 diff --git a/test/Feature/UpdateSpec.hs b/test/Feature/UpdateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/UpdateSpec.hs @@ -0,0 +1,349 @@ +module Feature.UpdateSpec where + +import Network.Wai (Application) +import Test.Hspec hiding (pendingWith) + +import Network.HTTP.Types +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + +import Protolude hiding (get) +import SpecHelper + +spec :: SpecWith ((), Application) +spec = do + describe "Patching record" $ do + context "to unknown uri" $ + it "indicates no table found by returning 404" $ + request methodPatch "/fake" [] + [json| { "real": false } |] + `shouldRespondWith` 404 + + context "on an empty table" $ + it "indicates no records found to update by returning 404" $ + request methodPatch "/empty_table" [] + [json| { "extra":20 } |] + `shouldRespondWith` "" + { matchStatus = 404, + matchHeaders = [] + } + + context "with invalid json payload" $ + it "fails with 400 and error" $ + request methodPatch "/simple_pk" [] "}{ x = 2" + `shouldRespondWith` + [json|{"message":"Error in $: Failed reading: not a valid json value at '}{x=2'"}|] + { matchStatus = 400, + matchHeaders = [matchContentTypeJson] + } + + context "with no payload" $ + it "fails with 400 and error" $ + request methodPatch "/items" [] "" + `shouldRespondWith` + [json|{"message":"Error in $: not enough input"}|] + { matchStatus = 400, + matchHeaders = [matchContentTypeJson] + } + + context "in a nonempty table" $ do + it "can update a single item" $ do + patch "/items?id=eq.2" + [json| { "id":42 } |] + `shouldRespondWith` + "" + { matchStatus = 204 + , matchHeaders = ["Content-Range" <:> "0-0/*"] + } + + it "returns empty array when no rows updated and return=rep" $ + request methodPatch "/items?id=eq.999999" + [("Prefer", "return=representation")] [json| { "id":999999 } |] + `shouldRespondWith` "[]" + { + matchStatus = 404, + matchHeaders = [] + } + + it "gives a 404 when no rows updated" $ + request methodPatch "/items?id=eq.99999999" [] + [json| { "id": 42 } |] + `shouldRespondWith` 404 + + it "returns updated object as array when return=rep" $ + request methodPatch "/items?id=eq.2" + [("Prefer", "return=representation")] [json| { "id":2 } |] + `shouldRespondWith` [json|[{"id":2}]|] + { matchStatus = 200, + matchHeaders = ["Content-Range" <:> "0-0/*"] + } + + it "can update multiple items" $ do + get "/no_pk?select=a&b=eq.1" + `shouldRespondWith` + [json|[]|] + + request methodPatch "/no_pk?b=eq.0" + [("Prefer", "tx=commit")] + [json| { b: "1" } |] + `shouldRespondWith` + "" + { matchStatus = 204 + , matchHeaders = ["Content-Range" <:> "0-1/*" + , "Preference-Applied" <:> "tx=commit" ] + } + + -- check it really got updated + get "/no_pk?select=a&b=eq.1" + `shouldRespondWith` + [json|[ { a: "1" }, { a: "2" } ]|] + + -- put value back for other tests + request methodPatch "/no_pk?b=eq.1" + [("Prefer", "tx=commit")] + [json| { b: "0" } |] + `shouldRespondWith` + 204 + + it "can set a column to NULL" $ do + request methodPatch "/no_pk?a=eq.1" + [("Prefer", "return=representation")] + [json| { b: null } |] + `shouldRespondWith` + [json| [{ a: "1", b: null }] |] + + context "filtering by a computed column" $ do + it "is successful" $ + request methodPatch + "/items?is_first=eq.true" + [("Prefer", "return=representation")] + [json| { id: 100 } |] + `shouldRespondWith` [json| [{ id: 100 }] |] + { matchStatus = 200, + matchHeaders = [matchContentTypeJson, "Content-Range" <:> "0-0/*"] + } + + it "indicates no records updated by returning 404" $ + request methodPatch + "/items?always_true=eq.false" + [("Prefer", "return=representation")] + [json| { id: 100 } |] + `shouldRespondWith` "[]" + { matchStatus = 404, + matchHeaders = [] + } + + context "with representation requested" $ do + it "can provide a representation" $ do + _ <- post "/items" + [json| { id: 1 } |] + request methodPatch + "/items?id=eq.1" + [("Prefer", "return=representation")] + [json| { id: 99 } |] + `shouldRespondWith` [json| [{id:99}] |] + { matchHeaders = [matchContentTypeJson] } + -- put value back for other tests + void $ request methodPatch "/items?id=eq.99" [] [json| { "id":1 } |] + + it "can return computed columns" $ + request methodPatch + "/items?id=eq.1&select=id,always_true" + [("Prefer", "return=representation")] + [json| { id: 1 } |] + `shouldRespondWith` [json| [{ id: 1, always_true: true }] |] + { matchHeaders = [matchContentTypeJson] } + + it "can select overloaded computed columns" $ do + request methodPatch + "/items?id=eq.1&select=id,computed_overload" + [("Prefer", "return=representation")] + [json| { id: 1 } |] + `shouldRespondWith` [json| [{ id: 1, computed_overload: true }] |] + { matchHeaders = [matchContentTypeJson] } + request methodPatch + "/items2?id=eq.1&select=id,computed_overload" + [("Prefer", "return=representation")] + [json| { id: 1 } |] + `shouldRespondWith` [json| [{ id: 1, computed_overload: true }] |] + { matchHeaders = [matchContentTypeJson] } + + it "ignores ?select= when return not set or return=minimal" $ do + request methodPatch "/items?id=eq.1&select=id" [] [json| { id:1 } |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "0-0/*"] + } + request methodPatch "/items?id=eq.1&select=id" [("Prefer", "return=minimal")] [json| { id:1 } |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "0-0/*"] + } + + context "when patching with an empty body" $ do + it "makes no updates and returns 204 without return= and without ?select=" $ do + request methodPatch "/items" [] [json| {} |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + request methodPatch "/items" [] [json| [] |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + request methodPatch "/items" [] [json| [{}] |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + it "makes no updates and returns 204 without return= and with ?select=" $ do + request methodPatch "/items?select=id" [] [json| {} |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + request methodPatch "/items?select=id" [] [json| [] |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + request methodPatch "/items?select=id" [] [json| [{}] |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + it "makes no updates and returns 200 with return=rep and without ?select=" $ + request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |] + `shouldRespondWith` "[]" + { + matchStatus = 200, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + it "makes no updates and returns 200 with return=rep and with ?select=" $ + request methodPatch "/items?select=id" [("Prefer", "return=representation")] [json| {} |] + `shouldRespondWith` "[]" + { + matchStatus = 200, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + it "makes no updates and returns 200 with return=rep and with ?select= for overloaded computed columns" $ + request methodPatch "/items?select=id,computed_overload" [("Prefer", "return=representation")] [json| {} |] + `shouldRespondWith` "[]" + { + matchStatus = 200, + matchHeaders = ["Content-Range" <:> "*/*"] + } + + context "with unicode values" $ + it "succeeds and returns values intact" $ do + request methodPatch "/no_pk?a=eq.1" + [("Prefer", "return=representation")] + [json| { "a":"圍棋", "b":"￥" } |] + `shouldRespondWith` + [json|[ { "a":"圍棋", "b":"￥" } ]|] + + context "PATCH with ?columns parameter" $ do + it "ignores json keys not included in ?columns" $ do + request methodPatch "/articles?id=eq.1&columns=body" + [("Prefer", "return=representation")] + [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] + `shouldRespondWith` + [json|[{"id": 1, "body": "Some real content", "owner": "postgrest_test_anonymous"}]|] + + it "ignores json keys and gives 404 if no record updated" $ + request methodPatch "/articles?id=eq.2001&columns=body" [("Prefer", "return=representation")] + [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith` 404 + + context "tables with self reference foreign keys" $ do + it "embeds children after update" $ + request methodPatch "/web_content?id=eq.0&select=id,name,web_content(name)" + [("Prefer", "return=representation")] + [json|{"name": "tardis-patched"}|] + `shouldRespondWith` + [json| + [ { "id": 0, "name": "tardis-patched", "web_content": [ { "name": "fezz" }, { "name": "foo" }, { "name": "bar" } ]} ] + |] + { matchStatus = 200, + matchHeaders = [matchContentTypeJson] + } + + it "embeds parent, children and grandchildren after update" $ + request methodPatch "/web_content?id=eq.0&select=id,name,web_content(name,web_content(name)),parent_content:p_web_id(name)" + [("Prefer", "return=representation")] + [json|{"name": "tardis-patched-2"}|] + `shouldRespondWith` + [json| [ + { + "id": 0, + "name": "tardis-patched-2", + "parent_content": { "name": "wat" }, + "web_content": [ + { "name": "fezz", "web_content": [ { "name": "wut" } ] }, + { "name": "foo", "web_content": [] }, + { "name": "bar", "web_content": [] } + ] + } + ] |] + { matchStatus = 200, + matchHeaders = [matchContentTypeJson] + } + + it "embeds children after update without explicitly including the id in the ?select" $ + request methodPatch "/web_content?id=eq.0&select=name,web_content(name)" + [("Prefer", "return=representation")] + [json|{"name": "tardis-patched"}|] + `shouldRespondWith` + [json| + [ { "name": "tardis-patched", "web_content": [ { "name": "fezz" }, { "name": "foo" }, { "name": "bar" } ]} ] + |] + { matchStatus = 200, + matchHeaders = [matchContentTypeJson] + } + + it "embeds an M2M relationship plus parent after update" $ + request methodPatch "/users?id=eq.1&select=name,tasks(name,project:projects(name))" + [("Prefer", "return=representation")] + [json|{"name": "Kevin Malone"}|] + `shouldRespondWith` + [json|[ + { + "name": "Kevin Malone", + "tasks": [ + { "name": "Design w7", "project": { "name": "Windows 7" } }, + { "name": "Code w7", "project": { "name": "Windows 7" } }, + { "name": "Design w10", "project": { "name": "Windows 10" } }, + { "name": "Code w10", "project": { "name": "Windows 10" } } + ] + } + ]|] + { matchStatus = 200, + matchHeaders = [matchContentTypeJson] + } + + context "table with limited privileges" $ do + it "succeeds updating row and gives a 204 when using return=minimal" $ + request methodPatch "/app_users?id=eq.1" [("Prefer", "return=minimal")] + [json| { "password": "passxyz" } |] + `shouldRespondWith` 204 + + it "can update without return=minimal and no explicit select" $ + request methodPatch "/app_users?id=eq.1" [] + [json| { "password": "passabc" } |] + `shouldRespondWith` 204 diff --git a/test/Feature/UpsertSpec.hs b/test/Feature/UpsertSpec.hs --- a/test/Feature/UpsertSpec.hs +++ b/test/Feature/UpsertSpec.hs @@ -6,7 +6,6 @@ import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Text.Heredoc import Protolude hiding (get, put) import SpecHelper @@ -101,30 +100,38 @@ } it "INSERTs and ignores rows on single unique key conflict" $ - request methodPost "/single_unique?on_conflict=unique_key" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")] - [json| [ - { "unique_key": 1, "value": "B" }, - { "unique_key": 2, "value": "C" }, - { "unique_key": 3, "value": "D" } - ]|] `shouldRespondWith` [json| [ - { "unique_key": 3, "value": "D" } - ]|] - { matchStatus = 201 - , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson] - } + request methodPost "/single_unique?on_conflict=unique_key" + [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")] + [json| [ + { "unique_key": 1, "value": "B" }, + { "unique_key": 2, "value": "C" }, + { "unique_key": 3, "value": "D" } + ]|] + `shouldRespondWith` + [json| [ + { "unique_key": 2, "value": "C" }, + { "unique_key": 3, "value": "D" } + ]|] + { matchStatus = 201 + , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates"] + } it "INSERTs and UPDATEs rows on compound unique keys conflict" $ - request methodPost "/compound_unique?on_conflict=key1,key2" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")] - [json| [ - { "key1": 1, "key2": 1, "value": "B" }, - { "key1": 1, "key2": 2, "value": "C" }, - { "key1": 1, "key2": 3, "value": "D" } - ]|] `shouldRespondWith` [json| [ - { "key1": 1, "key2": 3, "value": "D" } - ]|] - { matchStatus = 201 - , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson] - } + request methodPost "/compound_unique?on_conflict=key1,key2" + [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")] + [json| [ + { "key1": 1, "key2": 1, "value": "B" }, + { "key1": 1, "key2": 2, "value": "C" }, + { "key1": 1, "key2": 3, "value": "D" } + ]|] + `shouldRespondWith` + [json| [ + { "key1": 1, "key2": 2, "value": "C" }, + { "key1": 1, "key2": 3, "value": "D" } + ]|] + { matchStatus = 201 + , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates"] + } it "succeeds if the table has only PK cols and no other cols" $ do request methodPost "/only_pk" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")] @@ -161,160 +168,205 @@ context "Restrictions" $ do it "fails if Range is specified" $ request methodPut "/tiobe_pls?name=eq.Javascript" [("Range", "0-5")] - [str| [ { "name": "Javascript", "rank": 1 } ]|] + [json| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if limit is specified" $ put "/tiobe_pls?name=eq.Javascript&limit=1" - [str| [ { "name": "Javascript", "rank": 1 } ]|] + [json| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if offset is specified" $ put "/tiobe_pls?name=eq.Javascript&offset=1" - [str| [ { "name": "Javascript", "rank": 1 } ]|] + [json| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "rejects every other filter than pk cols eq's" $ do put "/tiobe_pls?rank=eq.19" - [str| [ { "name": "Go", "rank": 19 } ]|] + [json| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|] { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } put "/tiobe_pls?id=not.eq.Java" - [str| [ { "name": "Go", "rank": 19 } ]|] + [json| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|] { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } put "/tiobe_pls?id=in.(Go)" - [str| [ { "name": "Go", "rank": 19 } ]|] + [json| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|] { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } put "/tiobe_pls?and=(id.eq.Go)" - [str| [ { "name": "Go", "rank": 19 } ]|] + [json| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|] { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } it "fails if not all composite key cols are specified as eq filters" $ do put "/employees?first_name=eq.Susan" - [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] + [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] `shouldRespondWith` [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|] { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } put "/employees?last_name=eq.Heidt" - [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] + [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] `shouldRespondWith` [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|] { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } it "fails if the uri primary key doesn't match the payload primary key" $ do - put "/tiobe_pls?name=eq.MATLAB" [str| [ { "name": "Perl", "rank": 17 } ]|] + put "/tiobe_pls?name=eq.MATLAB" [json| [ { "name": "Perl", "rank": 17 } ]|] `shouldRespondWith` [json|{"message":"Payload values do not match URL in primary key column(s)"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } put "/employees?first_name=eq.Wendy&last_name=eq.Anderson" - [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] + [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] `shouldRespondWith` [json|{"message":"Payload values do not match URL in primary key column(s)"}|] { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if the table has no PK" $ - put "/no_pk?a=eq.one&b=eq.two" [str| [ { "a": "one", "b": "two" } ]|] + put "/no_pk?a=eq.one&b=eq.two" [json| [ { "a": "one", "b": "two" } ]|] `shouldRespondWith` [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|] { matchStatus = 405 , matchHeaders = [matchContentTypeJson] } context "Inserting row" $ do it "succeeds on table with single pk col" $ do - get "/tiobe_pls?name=eq.Go" `shouldRespondWith` "[]" - put "/tiobe_pls?name=eq.Go" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 204 - get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json| [ { "name": "Go", "rank": 19 } ]|] { matchHeaders = [matchContentTypeJson] } + -- assert that the next request will indeed be an insert + get "/tiobe_pls?name=eq.Go" + `shouldRespondWith` + [json|[]|] + request methodPut "/tiobe_pls?name=eq.Go" + [("Prefer", "return=representation")] + [json| [ { "name": "Go", "rank": 19 } ]|] + `shouldRespondWith` + [json| [ { "name": "Go", "rank": 19 } ]|] + it "succeeds on table with composite pk" $ do - get "/employees?first_name=eq.Susan&last_name=eq.Heidt" - `shouldRespondWith` "[]" - put "/employees?first_name=eq.Susan&last_name=eq.Heidt" - [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] - `shouldRespondWith` 204 + -- assert that the next request will indeed be an insert get "/employees?first_name=eq.Susan&last_name=eq.Heidt" `shouldRespondWith` - [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$48,000.00", "company": "GEX", "occupation": "Railroad engineer" } ]|] - { matchHeaders = [matchContentTypeJson] } + [json|[]|] + request methodPut "/employees?first_name=eq.Susan&last_name=eq.Heidt" + [("Prefer", "return=representation")] + [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] + `shouldRespondWith` + [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$48,000.00", "company": "GEX", "occupation": "Railroad engineer" } ]|] + it "succeeds if the table has only PK cols and no other cols" $ do - get "/only_pk?id=eq.10" `shouldRespondWith` "[]" - put "/only_pk?id=eq.10" [str|[ { "id": 10 } ]|] `shouldRespondWith` 204 - get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] } + -- assert that the next request will indeed be an insert + get "/only_pk?id=eq.10" + `shouldRespondWith` + [json|[]|] + request methodPut "/only_pk?id=eq.10" + [("Prefer", "return=representation")] + [json|[ { "id": 10 } ]|] + `shouldRespondWith` + [json|[ { "id": 10 } ]|] + context "Updating row" $ do it "succeeds on table with single pk col" $ do - get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json|[ { "name": "Go", "rank": 19 } ]|] { matchHeaders = [matchContentTypeJson] } - put "/tiobe_pls?name=eq.Go" [str| [ { "name": "Go", "rank": 13 } ]|] `shouldRespondWith` 204 - get "/tiobe_pls?name=eq.Go" `shouldRespondWith` [json| [ { "name": "Go", "rank": 13 } ]|] { matchHeaders = [matchContentTypeJson] } + -- assert that the next request will indeed be an update + get "/tiobe_pls?name=eq.Java" + `shouldRespondWith` + [json|[ { "name": "Java", "rank": 1 } ]|] - it "succeeds if the payload has more than one row, but it only puts the first element" $ - request methodPut "/tiobe_pls?name=eq.Go" - [("Prefer", "return=representation"), ("Accept", "application/vnd.pgrst.object+json")] - [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ] |] + request methodPut "/tiobe_pls?name=eq.Java" + [("Prefer", "return=representation")] + [json| [ { "name": "Java", "rank": 13 } ]|] `shouldRespondWith` - [json|{ "name": "Go", "rank": 19 }|] - { matchStatus = 200 , matchHeaders = [matchContentTypeSingular] } + [json| [ { "name": "Java", "rank": 13 } ]|] + -- TODO: move this to SingularSpec? + it "succeeds if the payload has more than one row, but it only puts the first element" $ do + -- assert that the next request will indeed be an update + get "/tiobe_pls?name=eq.Java" + `shouldRespondWith` + [json|[ { "name": "Java", "rank": 1 } ]|] + + request methodPut "/tiobe_pls?name=eq.Java" + [("Prefer", "return=representation"), ("Accept", "application/vnd.pgrst.object+json")] + [json| [ { "name": "Java", "rank": 19 }, { "name": "Swift", "rank": 12 } ] |] + `shouldRespondWith` + [json|{ "name": "Java", "rank": 19 }|] + { matchHeaders = [matchContentTypeSingular] } + it "succeeds on table with composite pk" $ do - get "/employees?first_name=eq.Susan&last_name=eq.Heidt" + -- assert that the next request will indeed be an update + get "/employees?first_name=eq.Frances M.&last_name=eq.Roe" `shouldRespondWith` - [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$48,000.00", "company": "GEX", "occupation": "Railroad engineer" } ]|] - { matchHeaders = [matchContentTypeJson] } - put "/employees?first_name=eq.Susan&last_name=eq.Heidt" - [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "60000", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|] - `shouldRespondWith` 204 - get "/employees?first_name=eq.Susan&last_name=eq.Heidt" + [json| [ { "first_name": "Frances M.", "last_name": "Roe", "salary": "$24,000.00", "company": "One-Up Realty", "occupation": "Author" } ]|] + + request methodPut "/employees?first_name=eq.Frances M.&last_name=eq.Roe" + [("Prefer", "return=representation")] + [json| [ { "first_name": "Frances M.", "last_name": "Roe", "salary": "60000", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|] `shouldRespondWith` - [json| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "$60,000.00", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|] - { matchHeaders = [matchContentTypeJson] } + [json| [ { "first_name": "Frances M.", "last_name": "Roe", "salary": "$60,000.00", "company": "Gamma Gas", "occupation": "Railroad engineer" } ]|] it "succeeds if the table has only PK cols and no other cols" $ do - get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] } - put "/only_pk?id=eq.10" [str|[ { "id": 10 } ]|] `shouldRespondWith` 204 - get "/only_pk?id=eq.10" `shouldRespondWith` [json|[ { "id": 10 } ]|] { matchHeaders = [matchContentTypeJson] } + -- assert that the next request will indeed be an update + get "/only_pk?id=eq.1" + `shouldRespondWith` + [json|[ { "id": 1 } ]|] + request methodPut "/only_pk?id=eq.1" + [("Prefer", "return=representation")] + [json|[ { "id": 1 } ]|] + `shouldRespondWith` + [json|[ { "id": 1 } ]|] + + -- TODO: move this to SingularSpec? it "works with return=representation and vnd.pgrst.object+json" $ request methodPut "/tiobe_pls?name=eq.Ruby" [("Prefer", "return=representation"), ("Accept", "application/vnd.pgrst.object+json")] - [str| [ { "name": "Ruby", "rank": 11 } ]|] + [json| [ { "name": "Ruby", "rank": 11 } ]|] `shouldRespondWith` [json|{ "name": "Ruby", "rank": 11 }|] { matchHeaders = [matchContentTypeSingular] } context "with a camel case pk column" $ do - it "works with POST and merge-duplicates/ignore-duplicates headers" $ do - request methodPost "/UnitTest" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")] - [json| [ - { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" }, - { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" } - ]|] `shouldRespondWith` [json|[ - { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" }, - { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" } - ]|] - { matchStatus = 201 - , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson] - } - request methodPost "/UnitTest" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")] - [json| [ - { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" }, - { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" } - ]|] `shouldRespondWith` [json|[]|] - { matchStatus = 201 - , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates", matchContentTypeJson] - } + it "works with POST and merge-duplicates" $ do + request methodPost "/UnitTest" + [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")] + [json|[ + { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" }, + { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" } + ]|] + `shouldRespondWith` + [json|[ + { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" }, + { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" } + ]|] + { matchStatus = 201 + , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates"] + } + it "works with POST and ignore-duplicates headers" $ do + request methodPost "/UnitTest" + [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")] + [json|[ + { "idUnitTest": 1, "nameUnitTest": "name of unittest 1" }, + { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" } + ]|] + `shouldRespondWith` + [json|[ + { "idUnitTest": 2, "nameUnitTest": "name of unittest 2" } + ]|] + { matchStatus = 201 + , matchHeaders = ["Preference-Applied" <:> "resolution=ignore-duplicates"] + } + it "works with PUT" $ do - put "/UnitTest?idUnitTest=eq.1" [str| [ { "idUnitTest": 1, "nameUnitTest": "unit test 1" } ]|] `shouldRespondWith` 204 + put "/UnitTest?idUnitTest=eq.1" [json| [ { "idUnitTest": 1, "nameUnitTest": "unit test 1" } ]|] `shouldRespondWith` 204 get "/UnitTest?idUnitTest=eq.1" `shouldRespondWith` - [json| [ { "idUnitTest": 1, "nameUnitTest": "unit test 1" } ]|] { matchHeaders = [matchContentTypeJson] } + [json| [ { "idUnitTest": 1, "nameUnitTest": "unit test 1" } ]|] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,25 +1,25 @@ module Main where +import qualified Data.Aeson as JSON import qualified Hasql.Pool as P import qualified Hasql.Transaction.Sessions as HT -import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, - updateAction) import Data.Function (id) import Data.List.NonEmpty (toList) -import Data.Time.Clock (getCurrentTime) -import Data.IORef import Test.Hspec -import PostgREST.App (postgrest) -import PostgREST.Config (AppConfig (..)) -import PostgREST.DbStructure (getDbStructure, getPgVersion) -import PostgREST.Types (pgVersion95, pgVersion96) -import Protolude hiding (toList, toS) -import Protolude.Conv (toS) +import PostgREST.App (postgrest) +import PostgREST.Config (AppConfig (..), LogLevel (..)) +import PostgREST.Config.Database (queryPgVersion) +import PostgREST.Config.PgVersion (pgVersion96) +import PostgREST.DbStructure (queryDbStructure) +import Protolude hiding (toList, toS) +import Protolude.Conv (toS) import SpecHelper +import qualified PostgREST.AppState as AppState + import qualified Feature.AndOrParamsSpec import qualified Feature.AsymmetricJwtSpec import qualified Feature.AudienceJwtSecretSpec @@ -28,161 +28,200 @@ import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec +import qualified Feature.DisabledOpenApiSpec import qualified Feature.EmbedDisambiguationSpec import qualified Feature.ExtraSearchPathSpec import qualified Feature.HtmlRawOutputSpec +import qualified Feature.IgnorePrivOpenApiSpec import qualified Feature.InsertSpec import qualified Feature.JsonOperatorSpec import qualified Feature.MultipleSchemaSpec import qualified Feature.NoJwtSpec import qualified Feature.NonexistentSchemaSpec -import qualified Feature.PgVersion95Spec -import qualified Feature.PgVersion96Spec +import qualified Feature.OpenApiSpec +import qualified Feature.OptionsSpec import qualified Feature.ProxySpec import qualified Feature.QueryLimitedSpec import qualified Feature.QuerySpec import qualified Feature.RangeSpec import qualified Feature.RawOutputTypesSpec +import qualified Feature.RollbackSpec import qualified Feature.RootSpec +import qualified Feature.RpcPreRequestGucsSpec import qualified Feature.RpcSpec import qualified Feature.SingularSpec -import qualified Feature.StructureSpec import qualified Feature.UnicodeSpec +import qualified Feature.UpdateSpec import qualified Feature.UpsertSpec main :: IO () main = do - getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime } - - testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test" + testDbConn <- getEnvVarWithDefault "PGRST_DB_URI" "postgres://postgrest_test@localhost/postgrest_test" pool <- P.acquire (3, 10, toS testDbConn) - actualPgVersion <- either (panic.show) id <$> P.use pool getPgVersion + actualPgVersion <- either (panic.show) id <$> P.use pool queryPgVersion - refDbStructure <- (newIORef . Just) =<< setupDbStructure pool (configSchemas $ testCfg testDbConn) actualPgVersion + baseDbStructure <- + loadDbStructure pool + (configDbSchemas $ testCfg testDbConn) + (configDbExtraSearchPath $ testCfg testDbConn) let -- For tests that run with the same refDbStructure - app cfg = return ((), postgrest (cfg testDbConn) refDbStructure pool getTime $ pure ()) + app cfg = do + let config = cfg testDbConn + appState <- AppState.initWithPool pool config + AppState.putPgVersion appState actualPgVersion + AppState.putDbStructure appState baseDbStructure + when (isJust $ configDbRootSpec config) $ + AppState.putJsonDbS appState $ toS $ JSON.encode baseDbStructure + return ((), postgrest LogCrit appState $ pure ()) -- For tests that run with a different DbStructure(depends on configSchemas) appDbs cfg = do - dbs <- (newIORef . Just) =<< setupDbStructure pool (configSchemas $ cfg testDbConn) actualPgVersion - return ((), postgrest (cfg testDbConn) dbs pool getTime $ pure ()) + let config = cfg testDbConn + customDbStructure <- + loadDbStructure pool + (configDbSchemas config) + (configDbExtraSearchPath config) + appState <- AppState.initWithPool pool config + AppState.putDbStructure appState customDbStructure + when (isJust $ configDbRootSpec config) $ + AppState.putJsonDbS appState $ toS $ JSON.encode baseDbStructure + return ((), postgrest LogCrit appState $ pure ()) let withApp = app testCfg maxRowsApp = app testMaxRowsCfg + disabledOpenApi = app testDisabledOpenApiCfg proxyApp = app testProxyCfg noJwtApp = app testCfgNoJWT binaryJwtApp = app testCfgBinaryJWT audJwtApp = app testCfgAudienceJWT asymJwkApp = app testCfgAsymJWK asymJwkSetApp = app testCfgAsymJWKSet - extraSearchPathApp = app testCfgExtraSearchPath rootSpecApp = app testCfgRootSpec htmlRawOutputApp = app testCfgHtmlRawOutput responseHeadersApp = app testCfgResponseHeaders + disallowRollbackApp = app testCfgDisallowRollback + forceRollbackApp = app testCfgForceRollback + extraSearchPathApp = appDbs testCfgExtraSearchPath unicodeApp = appDbs testUnicodeCfg nonexistentSchemaApp = appDbs testNonexistentSchemaCfg multipleSchemaApp = appDbs testMultipleSchemaCfg + ignorePrivOpenApi = appDbs testIgnorePrivOpenApiCfg - let reset, analyze :: IO () - reset = resetDb testDbConn + let analyze :: IO () analyze = do analyzeTable testDbConn "items" analyzeTable testDbConn "child_entities" - extraSpecs = - [("Feature.UpsertSpec", Feature.UpsertSpec.spec) | actualPgVersion >= pgVersion95] ++ - [("Feature.PgVersion95Spec", Feature.PgVersion95Spec.spec) | actualPgVersion >= pgVersion95] - specs = uncurry describe <$> [ - ("Feature.AuthSpec" , Feature.AuthSpec.spec actualPgVersion) - , ("Feature.RawOutputTypesSpec" , Feature.RawOutputTypesSpec.spec) + ("Feature.AndOrParamsSpec" , Feature.AndOrParamsSpec.spec actualPgVersion) + , ("Feature.AuthSpec" , Feature.AuthSpec.spec actualPgVersion) , ("Feature.ConcurrentSpec" , Feature.ConcurrentSpec.spec) , ("Feature.CorsSpec" , Feature.CorsSpec.spec) + , ("Feature.DeleteSpec" , Feature.DeleteSpec.spec) + , ("Feature.EmbedDisambiguationSpec" , Feature.EmbedDisambiguationSpec.spec) + , ("Feature.InsertSpec" , Feature.InsertSpec.spec actualPgVersion) , ("Feature.JsonOperatorSpec" , Feature.JsonOperatorSpec.spec actualPgVersion) + , ("Feature.OpenApiSpec" , Feature.OpenApiSpec.spec) + , ("Feature.OptionsSpec" , Feature.OptionsSpec.spec) , ("Feature.QuerySpec" , Feature.QuerySpec.spec actualPgVersion) - , ("Feature.EmbedDisambiguationSpec" , Feature.EmbedDisambiguationSpec.spec) + , ("Feature.RawOutputTypesSpec" , Feature.RawOutputTypesSpec.spec) , ("Feature.RpcSpec" , Feature.RpcSpec.spec actualPgVersion) - , ("Feature.StructureSpec" , Feature.StructureSpec.spec) - , ("Feature.AndOrParamsSpec" , Feature.AndOrParamsSpec.spec actualPgVersion) - ] ++ extraSpecs - - mutSpecs = uncurry describe <$> [ - ("Feature.DeleteSpec" , Feature.DeleteSpec.spec) - , ("Feature.InsertSpec" , Feature.InsertSpec.spec actualPgVersion) - , ("Feature.SingularSpec" , Feature.SingularSpec.spec) + , ("Feature.SingularSpec" , Feature.SingularSpec.spec) + , ("Feature.UpdateSpec" , Feature.UpdateSpec.spec) + , ("Feature.UpsertSpec" , Feature.UpsertSpec.spec) ] hspec $ do - -- Only certain Specs need a database reset, this should be used with care as it slows down the whole test suite. - mapM_ (afterAll_ reset . before withApp) mutSpecs - - mapM_ (before withApp) specs + mapM_ (parallel . before withApp) specs -- we analyze to get accurate results from EXPLAIN - beforeAll_ analyze . before withApp $ + parallel $ beforeAll_ analyze . before withApp $ describe "Feature.RangeSpec" Feature.RangeSpec.spec -- this test runs with a raw-output-media-types set to text/html - before htmlRawOutputApp $ + parallel $ before htmlRawOutputApp $ describe "Feature.HtmlRawOutputSpec" Feature.HtmlRawOutputSpec.spec -- this test runs with a different server flag - before maxRowsApp $ + parallel $ before maxRowsApp $ describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec -- this test runs with a different schema - before unicodeApp $ + parallel $ before unicodeApp $ describe "Feature.UnicodeSpec" Feature.UnicodeSpec.spec + -- this test runs with openapi-mode set to disabled + parallel $ before disabledOpenApi $ + describe "Feature.DisabledOpenApiSpec" Feature.DisabledOpenApiSpec.spec + + -- this test runs with openapi-mode set to ignore-acl + parallel $ before ignorePrivOpenApi $ + describe "Feature.IgnorePrivOpenApiSpec" Feature.IgnorePrivOpenApiSpec.spec + -- this test runs with a proxy - before proxyApp $ + parallel $ before proxyApp $ describe "Feature.ProxySpec" Feature.ProxySpec.spec -- this test runs without a JWT secret - before noJwtApp $ + parallel $ before noJwtApp $ describe "Feature.NoJwtSpec" Feature.NoJwtSpec.spec -- this test runs with a binary JWT secret - before binaryJwtApp $ + parallel $ before binaryJwtApp $ describe "Feature.BinaryJwtSecretSpec" Feature.BinaryJwtSecretSpec.spec -- this test runs with a binary JWT secret and an audience claim - before audJwtApp $ + parallel $ before audJwtApp $ describe "Feature.AudienceJwtSecretSpec" Feature.AudienceJwtSecretSpec.spec -- this test runs with asymmetric JWK - before asymJwkApp $ + parallel $ before asymJwkApp $ describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec -- this test runs with asymmetric JWKSet - before asymJwkSetApp $ + parallel $ before asymJwkSetApp $ describe "Feature.AsymmetricJwtSpec" Feature.AsymmetricJwtSpec.spec -- this test runs with a nonexistent db-schema - before nonexistentSchemaApp $ + parallel $ before nonexistentSchemaApp $ describe "Feature.NonexistentSchemaSpec" Feature.NonexistentSchemaSpec.spec -- this test runs with an extra search path - before extraSearchPathApp $ + parallel $ before extraSearchPathApp $ describe "Feature.ExtraSearchPathSpec" Feature.ExtraSearchPathSpec.spec - -- this test runs with a root spec function override when (actualPgVersion >= pgVersion96) $ do - before rootSpecApp $ + -- this test runs with a root spec function override + parallel $ before rootSpecApp $ describe "Feature.RootSpec" Feature.RootSpec.spec - before responseHeadersApp $ - describe "Feature.PgVersion96Spec" Feature.PgVersion96Spec.spec + parallel $ before responseHeadersApp $ + describe "Feature.RpcPreRequestGucsSpec" Feature.RpcPreRequestGucsSpec.spec -- this test runs with multiple schemas - before multipleSchemaApp $ + parallel $ before multipleSchemaApp $ describe "Feature.MultipleSchemaSpec" $ Feature.MultipleSchemaSpec.spec actualPgVersion + -- Note: the rollback tests can not run in parallel, because they test persistance and + -- this results in race conditions + + -- this test runs with tx-rollback-all = true and tx-allow-override = true + before withApp $ + describe"Feature.RollbackAllowedSpec" Feature.RollbackSpec.allowed + + -- this test runs with tx-rollback-all = false and tx-allow-override = false + before disallowRollbackApp $ + describe "Feature.RollbackDisallowedSpec" Feature.RollbackSpec.disallowed + + -- this test runs with tx-rollback-all = true and tx-allow-override = false + before forceRollbackApp $ + describe "Feature.RollbackForcedSpec" Feature.RollbackSpec.forced + where - setupDbStructure pool schemas ver = - either (panic.show) id <$> P.use pool (HT.transaction HT.ReadCommitted HT.Read $ getDbStructure (toList schemas) ver) + loadDbStructure pool schemas extraSearchPath = + either (panic.show) id <$> P.use pool (HT.transaction HT.ReadCommitted HT.Read $ queryDbStructure (toList schemas) extraSearchPath True) diff --git a/test/QueryCost.hs b/test/QueryCost.hs --- a/test/QueryCost.hs +++ b/test/QueryCost.hs @@ -1,75 +1,85 @@ module Main where -import Control.Lens ((^?)) -import qualified Data.Aeson.Lens as L -import qualified Hasql.Decoders as HD -import qualified Hasql.Encoders as HE -import qualified Hasql.Pool as P -import qualified Hasql.Statement as H -import qualified Hasql.Transaction as HT -import qualified Hasql.Transaction.Sessions as HT +import Control.Lens ((^?)) +import qualified Data.Aeson.Lens as L +import qualified Hasql.Decoders as HD +import qualified Hasql.DynamicStatements.Snippet as H +import qualified Hasql.DynamicStatements.Statement as H +import qualified Hasql.Pool as P +import qualified Hasql.Statement as H +import qualified Hasql.Transaction as HT +import qualified Hasql.Transaction.Sessions as HT import Text.Heredoc import Protolude hiding (get, toS) import Protolude.Conv (toS) -import PostgREST.QueryBuilder (requestToCallProcQuery) -import PostgREST.Types +import PostgREST.Query.QueryBuilder (requestToCallProcQuery) +import PostgREST.Request.ApiRequest (PayloadJSON (..)) +import PostgREST.DbStructure.Identifiers +import PostgREST.DbStructure.Proc +import PostgREST.Request.Preferences + import SpecHelper (getEnvVarWithDefault) import Test.Hspec main :: IO () main = do - testDbConn <- getEnvVarWithDefault "POSTGREST_TEST_CONNECTION" "postgres://postgrest_test@localhost/postgrest_test" + testDbConn <- getEnvVarWithDefault "PGRST_DB_URI" "postgres://postgrest_test@localhost/postgrest_test" pool <- P.acquire (3, 10, toS testDbConn) hspec $ describe "QueryCost" $ context "call proc query" $ do it "should not exceed cost when calling setof composite proc" $ do - cost <- exec pool [str| {"id": 3} |] $ - requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True] False Nothing [] + cost <- exec pool $ + requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False] + (Just $ RawJSON [str| {"id": 3} |]) False Nothing [] liftIO $ cost `shouldSatisfy` (< Just 40) it "should not exceed cost when calling setof composite proc with empty params" $ do - cost <- exec pool mempty $ - requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] False Nothing [] + cost <- exec pool $ + requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] Nothing False Nothing [] liftIO $ cost `shouldSatisfy` (< Just 30) it "should not exceed cost when calling scalar proc" $ do - cost <- exec pool [str| {"a": 3, "b": 4} |] $ - requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True, PgArg "b" "int" True] True Nothing [] + cost <- exec pool $ + requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False] + (Just $ RawJSON [str| {"a": 3, "b": 4} |]) True Nothing [] liftIO $ cost `shouldSatisfy` (< Just 10) context "params=multiple-objects" $ do it "should not exceed cost when calling setof composite proc" $ do - cost <- exec pool [str| [{"id": 1}, {"id": 4}] |] $ - requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True] False (Just MultipleObjects) [] + cost <- exec pool $ + requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [PgArg "id" "int" True False] + (Just $ RawJSON [str| [{"id": 1}, {"id": 4}] |]) False (Just MultipleObjects) [] liftIO $ do + -- lower bound needed for now to make sure that cost is not Nothing cost `shouldSatisfy` (> Just 2000) cost `shouldSatisfy` (< Just 2100) it "should not exceed cost when calling scalar proc" $ do - cost <- exec pool [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |] $ - requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True, PgArg "b" "int" True] True Nothing [] + cost <- exec pool $ + requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [PgArg "a" "int" True False, PgArg "b" "int" True False] + (Just $ RawJSON [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |]) True Nothing [] liftIO $ cost `shouldSatisfy` (< Just 10) -exec :: P.Pool -> ByteString -> SqlQuery -> IO (Maybe Int64) -exec pool input query = +exec :: P.Pool -> H.Snippet -> IO (Maybe Int64) +exec pool query = join . rightToMaybe <$> - P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement input $ explainCost query) + P.use pool (HT.transaction HT.ReadCommitted HT.Read $ HT.statement mempty $ explainCost query) -explainCost :: SqlQuery -> H.Statement ByteString (Maybe Int64) +explainCost :: H.Snippet -> H.Statement () (Maybe Int64) explainCost query = - H.Statement (encodeUtf8 sql) (HE.param $ HE.nonNullable HE.unknown) decodeExplain False + H.dynamicallyParameterized snippet decodeExplain False where - sql = "EXPLAIN (FORMAT JSON) " <> query + snippet = "EXPLAIN (FORMAT JSON) " <> query decodeExplain :: HD.Result (Maybe Int64) decodeExplain = let row = HD.singleRow $ HD.column $ HD.nonNullable HD.bytea in diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -8,7 +8,7 @@ import qualified System.IO.Error as E import Data.Aeson (Value (..), decode, encode) -import Data.CaseInsensitive (CI (..)) +import Data.CaseInsensitive (CI (..), original) import Data.List (lookup) import Data.List.NonEmpty (fromList) import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus)) @@ -22,10 +22,14 @@ import Test.Hspec.Wai import Text.Heredoc -import PostgREST.Config (AppConfig (..)) -import PostgREST.Types (JSPathExp (..)) -import Protolude hiding (toS) -import Protolude.Conv (toS) +import PostgREST.Config (AppConfig (..), + JSPathExp (..), + LogLevel (..), + OpenAPIMode (..), + parseSecret) +import PostgREST.DbStructure.Identifiers (QualifiedIdentifier (..)) +import Protolude hiding (toS) +import Protolude.Conv (toS) matchContentTypeJson :: MatchHeader matchContentTypeJson = "Content-Type" <:> "application/json; charset=utf-8" @@ -33,6 +37,12 @@ matchContentTypeSingular :: MatchHeader matchContentTypeSingular = "Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8" +matchHeaderAbsent :: HeaderName -> MatchHeader +matchHeaderAbsent name = MatchHeader $ \headers _body -> + case lookup name headers of + Just _ -> Just $ "unexpected header: " <> toS (original name) <> "\n" + Nothing -> Nothing + validateOpenApiResponse :: [Header] -> WaiSession () () validateOpenApiResponse headers = do r <- request methodGet "/" headers "" @@ -63,87 +73,117 @@ getEnv (toS var) `E.catchIOError` const (return $ toS def) _baseCfg :: AppConfig -_baseCfg = -- Connection Settings - AppConfig mempty "postgrest_test_anonymous" Nothing (fromList ["test"]) "localhost" 3000 - -- No user configured Unix Socket - Nothing - -- No user configured Unix Socket file mode (defaults to 660) - (Right 432) - -- Jwt settings - (Just $ encodeUtf8 "reallyreallyreallyreallyverysafe") False Nothing - -- Connection Modifiers - 10 10 Nothing (Just "test.switch_role") - -- Debug Settings - True - [ ("app.settings.app_host", "localhost") - , ("app.settings.external_api_secret", "0123456789abcdef") - ] - -- Default role claim key - (Right [JSPKey "role"]) - -- Empty db-extra-search-path - [] - -- No root spec override - Nothing - -- Raw output media types - [] +_baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in + AppConfig { + configAppSettings = [ ("app.settings.app_host", "localhost") , ("app.settings.external_api_secret", "0123456789abcdef") ] + , configDbAnonRole = "postgrest_test_anonymous" + , configDbChannel = mempty + , configDbChannelEnabled = True + , configDbExtraSearchPath = [] + , configDbMaxRows = Nothing + , configDbPoolSize = 10 + , configDbPoolTimeout = 10 + , configDbPreRequest = Just $ QualifiedIdentifier "test" "switch_role" + , configDbPreparedStatements = True + , configDbRootSpec = Nothing + , configDbSchemas = fromList ["test"] + , configDbConfig = False + , configDbUri = mempty + , configFilePath = Nothing + , configJWKS = parseSecret <$> secret + , configJwtAudience = Nothing + , configJwtRoleClaimKey = [JSPKey "role"] + , configJwtSecret = secret + , configJwtSecretIsBase64 = False + , configLogLevel = LogCrit + , configOpenApiMode = OAFollowPriv + , configOpenApiServerProxyUri = Nothing + , configRawMediaTypes = [] + , configServerHost = "localhost" + , configServerPort = 3000 + , configServerUnixSocket = Nothing + , configServerUnixSocketMode = 432 + , configDbTxAllowOverride = True + , configDbTxRollbackAll = True + } testCfg :: Text -> AppConfig -testCfg testDbConn = _baseCfg { configDatabase = testDbConn } +testCfg testDbConn = _baseCfg { configDbUri = testDbConn } +testCfgDisallowRollback :: Text -> AppConfig +testCfgDisallowRollback testDbConn = (testCfg testDbConn) { configDbTxAllowOverride = False, configDbTxRollbackAll = False } + +testCfgForceRollback :: Text -> AppConfig +testCfgForceRollback testDbConn = (testCfg testDbConn) { configDbTxAllowOverride = False, configDbTxRollbackAll = True } + testCfgNoJWT :: Text -> AppConfig -testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing } +testCfgNoJWT testDbConn = (testCfg testDbConn) { configJwtSecret = Nothing, configJWKS = Nothing } testUnicodeCfg :: Text -> AppConfig -testUnicodeCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["تست"] } +testUnicodeCfg testDbConn = (testCfg testDbConn) { configDbSchemas = fromList ["تست"] } testMaxRowsCfg :: Text -> AppConfig -testMaxRowsCfg testDbConn = (testCfg testDbConn) { configMaxRows = Just 2 } +testMaxRowsCfg testDbConn = (testCfg testDbConn) { configDbMaxRows = Just 2 } +testDisabledOpenApiCfg :: Text -> AppConfig +testDisabledOpenApiCfg testDbConn = (testCfg testDbConn) { configOpenApiMode = OADisabled } + +testIgnorePrivOpenApiCfg :: Text -> AppConfig +testIgnorePrivOpenApiCfg testDbConn = (testCfg testDbConn) { configOpenApiMode = OAIgnorePriv, configDbSchemas = fromList ["test", "v1"] } + testProxyCfg :: Text -> AppConfig -testProxyCfg testDbConn = (testCfg testDbConn) { configOpenAPIProxyUri = Just "https://postgrest.com/openapi.json" } +testProxyCfg testDbConn = (testCfg testDbConn) { configOpenApiServerProxyUri = Just "https://postgrest.com/openapi.json" } testCfgBinaryJWT :: Text -> AppConfig -testCfgBinaryJWT testDbConn = (testCfg testDbConn) { - configJwtSecret = Just . B64.decodeLenient $ - "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU=" +testCfgBinaryJWT testDbConn = + let secret = Just . B64.decodeLenient $ "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU=" in + (testCfg testDbConn) { + configJwtSecret = secret + , configJWKS = parseSecret <$> secret } testCfgAudienceJWT :: Text -> AppConfig -testCfgAudienceJWT testDbConn = (testCfg testDbConn) { - configJwtSecret = Just . B64.decodeLenient $ - "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU=", - configJwtAudience = Just "youraudience" +testCfgAudienceJWT testDbConn = + let secret = Just . B64.decodeLenient $ "cmVhbGx5cmVhbGx5cmVhbGx5cmVhbGx5dmVyeXNhZmU=" in + (testCfg testDbConn) { + configJwtSecret = secret + , configJwtAudience = Just "youraudience" + , configJWKS = parseSecret <$> secret } 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"}|] +testCfgAsymJWK testDbConn = + let secret = Just $ encodeUtf8 [str|{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}|] + in (testCfg testDbConn) { + configJwtSecret = secret + , configJWKS = parseSecret <$> secret } testCfgAsymJWKSet :: Text -> AppConfig -testCfgAsymJWKSet testDbConn = (testCfg testDbConn) { - configJwtSecret = Just $ encodeUtf8 - [str|{"keys": [{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}]}|] +testCfgAsymJWKSet testDbConn = + let secret = Just $ encodeUtf8 [str|{"keys": [{"alg":"RS256","e":"AQAB","key_ops":["verify"],"kty":"RSA","n":"0etQ2Tg187jb04MWfpuogYGV75IFrQQBxQaGH75eq_FpbkyoLcEpRUEWSbECP2eeFya2yZ9vIO5ScD-lPmovePk4Aa4SzZ8jdjhmAbNykleRPCxMg0481kz6PQhnHRUv3nF5WP479CnObJKqTVdEagVL66oxnX9VhZG9IZA7k0Th5PfKQwrKGyUeTGczpOjaPqbxlunP73j9AfnAt4XCS8epa-n3WGz1j-wfpr_ys57Aq-zBCfqP67UYzNpeI1AoXsJhD9xSDOzvJgFRvc3vm2wjAW4LEMwi48rCplamOpZToIHEPIaPzpveYQwDnB1HFTR1ove9bpKJsHmi-e2uzQ","use":"sig"}]}|] + in (testCfg testDbConn) { + configJwtSecret = secret + , configJWKS = parseSecret <$> secret } testNonexistentSchemaCfg :: Text -> AppConfig -testNonexistentSchemaCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["nonexistent"] } +testNonexistentSchemaCfg testDbConn = (testCfg testDbConn) { configDbSchemas = fromList ["nonexistent"] } testCfgExtraSearchPath :: Text -> AppConfig -testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configExtraSearchPath = ["public", "extensions"] } +testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configDbExtraSearchPath = ["public", "extensions"] } testCfgRootSpec :: Text -> AppConfig -testCfgRootSpec testDbConn = (testCfg testDbConn) { configRootSpec = Just "root"} +testCfgRootSpec testDbConn = (testCfg testDbConn) { configDbRootSpec = Just $ QualifiedIdentifier mempty "root"} testCfgHtmlRawOutput :: Text -> AppConfig testCfgHtmlRawOutput testDbConn = (testCfg testDbConn) { configRawMediaTypes = ["text/html"] } testCfgResponseHeaders :: Text -> AppConfig -testCfgResponseHeaders testDbConn = (testCfg testDbConn) { configReqCheck = Just "custom_headers" } +testCfgResponseHeaders testDbConn = (testCfg testDbConn) { configDbPreRequest = Just $ QualifiedIdentifier mempty "custom_headers" } testMultipleSchemaCfg :: Text -> AppConfig -testMultipleSchemaCfg testDbConn = (testCfg testDbConn) { configSchemas = fromList ["v1", "v2"] } +testMultipleSchemaCfg testDbConn = (testCfg testDbConn) { configDbSchemas = fromList ["v1", "v2"] } resetDb :: Text -> IO () resetDb dbConn = loadFixture dbConn "data" @@ -178,15 +218,18 @@ noProfileHeader :: [Header] -> Bool noProfileHeader headers = isNothing $ find ((== "Content-Profile") . fst) headers +authHeader :: BS.ByteString -> BS.ByteString -> Header +authHeader typ creds = + (hAuthorization, typ <> " " <> creds) + authHeaderBasic :: BS.ByteString -> BS.ByteString -> Header authHeaderBasic u p = - (hAuthorization, "Basic " <> (toS . B64.encode . toS $ u <> ":" <> p)) + authHeader "Basic" $ toS . B64.encode . toS $ u <> ":" <> p authHeaderJWT :: BS.ByteString -> Header -authHeaderJWT token = - (hAuthorization, "Bearer " <> token) +authHeaderJWT = authHeader "Bearer" --- | Tests whether the text can be parsed as a json object comtaining +-- | Tests whether the text can be parsed as a json object containing -- the key "message", and optional keys "details", "hint", "code", -- and no extraneous keys isErrorFormat :: BL.ByteString -> Bool