diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,41 @@ ### Fixed +## [6.0.0] - 2019-06-21 + +### Added + +- #1186, Add support for user defined unix socket via `server-unix-socket` config option +- #690, Add `?columns` query parameter for faster bulk inserts, also ignores unspecified json keys in a payload - @steve-chavez +- #1239, Add support for resource embedding on materialized views - @vitorbaptista +- #1264, Add support for bulk RPC call - @steve-chavez +- #1278, Add db-pool-timeout config option - @qu4tro +- #1285, Abort on wrong database password - @qu4tro +- #790, Allow override of OpenAPI spec through `root-spec` config option - @steve-chavez +- #1308, Accept `text/plain` and `text/html` for raw output - @steve-chavez + +### Fixed + +- #1223, Fix incorrect OpenAPI externalDocs url - @steve-chavez +- #1221, Fix embedding other resources when having a self join - @steve-chavez +- #1242, Fix embedding a view having a select in a where - @steve-chavez +- #1238, Fix PostgreSQL to OpenAPI type mappings for numeric and character types - @fpusch +- #1265, Fix query generated on bulk upsert with an empty array - @qu4tro +- #1273, Fix RPC ignoring unknown arguments by default - @steve-chavez +- #1257, Fix incorrect status when a PATCH request doesn't find rows to change - @qu4tro + +### Changed + +- #1288, Change server-host default of 127.0.0.1 to !4 + +### Deprecated + +- #1288, Deprecate `.` symbol for disambiguating resource embedding(added in #918). '+' should be used instead. Though '+' is url safe, certain clients might need to encode it to '%2B'. + +### Removed + +- #1288, Removed support for schema reloading with SIGHUP, SIGUSR1 should be used instead - @steve-chavez + ## [5.2.0] - 2018-12-12 ### Added diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -2,42 +2,51 @@ module Main where - -import PostgREST.App (postgrest) -import PostgREST.Config (AppConfig (..), - prettyVersion, readOptions) -import PostgREST.DbStructure (getDbStructure, getPgVersion) -import PostgREST.Error (encodeError) -import PostgREST.OpenAPI (isMalformedProxyUri) -import PostgREST.Types (DbStructure, Schema, PgVersion(..), minimumPgVersion) -import Protolude hiding (hPutStrLn, replace) - - -import Control.AutoUpdate (defaultUpdateSettings, - mkAutoUpdate, updateAction) -import Control.Retry (RetryStatus, capDelay, - exponentialBackoff, - retrying, rsPreviousDelay) import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 -import Data.IORef (IORef, atomicWriteIORef, - newIORef, readIORef) -import Data.String (IsString (..)) -import Data.Text (pack, replace, stripPrefix, strip) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Text.IO (hPutStrLn, readFile) -import Data.Time.Clock (getCurrentTime) import qualified Hasql.Pool as P -import qualified Hasql.Session as H import qualified Hasql.Transaction.Sessions as HT -import Network.Wai.Handler.Warp (defaultSettings, - runSettings, setHost, - setPort, setServerName) -import System.IO (BufferMode (..), - hSetBuffering) +import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, + updateAction) +import Control.Retry (RetryStatus, capDelay, + exponentialBackoff, retrying, + rsPreviousDelay) +import Data.IORef (IORef, atomicWriteIORef, newIORef, + readIORef) +import Data.String (IsString (..)) +import Data.Text (pack, replace, strip, stripPrefix, + unpack) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.IO (hPutStrLn, readFile) +import Data.Time.Clock (getCurrentTime) +import Network.Socket (Family (AF_UNIX), + SockAddr (SockAddrUnix), Socket, + SocketType (Stream), bind, close, + defaultProtocol, listen, + maxListenQueue, socket) +import Network.Wai.Handler.Warp (defaultSettings, runSettings, + runSettingsSocket, setHost, setPort, + setServerName) +import System.Directory (removeFile) +import System.IO (BufferMode (..), hSetBuffering) +import System.IO.Error (isDoesNotExistError) + +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, replace) + + #ifndef mingw32_HOST_OS -import System.Posix.Signals +import System.Posix.Signals #endif {-| @@ -74,26 +83,25 @@ work = do atomicWriteIORef refDbStructure Nothing putStrLn ("Attempting to connect to the database..." :: Text) - connected <- connectingSucceeded pool - when connected $ do - result <- P.use pool $ do - actualPgVersion <- getPgVersion - unless (actualPgVersion >= minimumPgVersion) $ liftIO $ do - hPutStrLn stderr - ("Cannot run in this PostgreSQL version, PostgREST needs at least " - <> pgvName minimumPgVersion) - killThread mainTid - dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schema actualPgVersion - liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure - case result of - Left e -> do - putStrLn ("Failed to query the database. Retrying." :: Text) - hPutStrLn stderr (toS $ encodeError e) - work - Right _ -> do - atomicWriteIORef refIsWorkerOn False - putStrLn ("Connection successful" :: 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 schema 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 @@ -103,26 +111,37 @@ The connection tries are capped, but if the connection times out no error is thrown, just 'False' is returned. -} -connectingSucceeded :: P.Pool -> IO Bool -connectingSucceeded pool = +connectionStatus :: P.Pool -> IO ConnectionStatus +connectionStatus pool = retrying (capDelay 32000000 $ exponentialBackoff 1000000) shouldRetry - (const $ P.release pool >> isConnectionSuccessful) + (const $ P.release pool >> getConnectionStatus) where - isConnectionSuccessful :: IO Bool - isConnectionSuccessful = do - testConn <- P.use pool $ H.sql "SELECT 1" - case testConn of - Left e -> hPutStrLn stderr (toS $ encodeError e) >> pure False - _ -> pure True - shouldRetry :: RetryStatus -> Bool -> IO Bool + 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 - delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000 - itShould <- pure $ not isConnSucc + 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. -} @@ -143,6 +162,7 @@ let host = configHost conf port = configPort conf proxy = configProxyUri conf + maybeSocketAddr = configSocket conf pgSettings = toS (configDatabase conf) -- is the db-uri roleClaimKey = configRoleClaimKey conf appSettings = @@ -160,11 +180,10 @@ when (isLeft roleClaimKey) $ panic $ show roleClaimKey - putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) -- -- create connection pool with the provided settings, returns either -- a 'Connection' or a 'ConnectionError'. Does not throw. - pool <- P.acquire (configPool conf, 10, pgSettings) + pool <- P.acquire (configPool conf, configPoolTimeout' conf, pgSettings) -- -- To be filled in by connectionWorker refDbStructure <- newIORef Nothing @@ -198,34 +217,45 @@ throwTo mainTid UserInterrupt ) Nothing - forM_ [sigHUP, sigUSR1] $ \sig -> - void $ installHandler sig ( - Catch $ connectionWorker - mainTid - pool - (configSchema conf) - refDbStructure - refIsWorkerOn - ) Nothing + void $ installHandler sigUSR1 ( + Catch $ connectionWorker + mainTid + pool + (configSchema conf) + refDbStructure + refIsWorkerOn + ) Nothing #endif -- ask for the OS time at most once per second getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} - -- run the postgrest application - runSettings appSettings $ - postgrest - conf - refDbStructure - pool - getTime - (connectionWorker - mainTid - pool - (configSchema conf) - refDbStructure - refIsWorkerOn) + let postgrestApplication = + postgrest + conf + refDbStructure + pool + getTime + (connectionWorker + mainTid + pool + (configSchema conf) + refDbStructure + refIsWorkerOn) + in case maybeSocketAddr of + Nothing -> do + -- run the postgrest application + putStrLn $ ("Listening on port " :: Text) <> show (configPort conf) + runSettings appSettings postgrestApplication + Just socketAddr -> do + -- run postgrest application with user defined socket + sock <- createAndBindSocket (unpack socketAddr) + listen sock maxListenQueue + putStrLn $ ("Listening on unix socket " :: Text) <> show socketAddr + runSettingsSocket appSettings sock postgrestApplication + -- clean socket up when done + close sock {-| The purpose of this function is to load the JWT secret from a file if @@ -290,6 +320,18 @@ extractDbUri dbUri = fmap setDbUri $ case stripPrefix "@" dbUri of - Nothing -> return dbUri + Nothing -> return dbUri Just filename -> strip <$> readFile (toS filename) setDbUri dbUri = conf {configDatabase = dbUri} + +createAndBindSocket :: FilePath -> IO Socket +createAndBindSocket filePath = do + deleteSocketFileIfExist filePath + sock <- socket AF_UNIX Stream defaultProtocol + bind sock $ SockAddrUnix filePath + return sock + where + deleteSocketFileIfExist path = removeFile path `catch` handleDoesNotExist + handleDoesNotExist e + | isDoesNotExistError e = return () + | otherwise = throwIO e diff --git a/postgrest.cabal b/postgrest.cabal --- a/postgrest.cabal +++ b/postgrest.cabal @@ -1,176 +1,182 @@ -name: postgrest -description: Reads the schema of a PostgreSQL database and creates RESTful routes - for the tables and views, supporting all HTTP verbs that security - permits. -version: 5.2.0 -synopsis: REST API for any Postgres database -license: MIT -license-file: LICENSE -author: Joe Nelson, Adam Baker -homepage: https://postgrest.org -maintainer: Steve Chávez -bug-reports: https://github.com/PostgREST/postgrest/issues -category: Executable, PostgreSQL, Network APIs -extra-source-files: CHANGELOG.md -build-type: Simple -cabal-version: >=1.10 +name: postgrest +version: 6.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 + permits. +license: MIT +license-file: LICENSE +author: Joe Nelson, Adam Baker +maintainer: Steve Chávez +category: Executable, PostgreSQL, Network APIs +homepage: https://postgrest.org +bug-reports: https://github.com/PostgREST/postgrest/issues +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >= 1.10 + source-repository head - type: git + type: git location: git://github.com/PostgREST/postgrest.git -Flag CI - Description: No warnings allowed in continuous integration - Manual: True - Default: False - -executable postgrest - main-is: Main.hs - default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude - ghc-options: - -threaded - -rtsopts - "-with-rtsopts=-N -I2" - default-language: Haskell2010 - build-depends: auto-update - , base >= 4.8 && < 4.10 - , hasql >= 1.3 && < 1.4 - , hasql-pool >= 0.5 && < 0.6 - , hasql-transaction >= 0.7 && < 0.8 - , postgrest - , protolude == 0.2.2 - , text - , time - , warp - , bytestring - , base64-bytestring - , retry - if !os(windows) - build-depends: unix - - hs-source-dirs: main +flag ci + default: False + manual: True + description: No warnings allowed in continuous integration library - default-language: Haskell2010 - default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude - build-depends: aeson - , ansi-wl-pprint - , base >= 4.8 && < 4.10 - , base64-bytestring - , bytestring - , case-insensitive - , cassava - , configurator-ng == 0.0.0.1 - , containers - , contravariant - , contravariant-extras - , either - , gitrev - , hasql >= 1.3 && < 1.4 - , hasql-pool >= 0.5 && < 0.6 - , hasql-transaction >= 0.7 && < 0.8 - , heredoc - , HTTP - , http-types - , insert-ordered-containers - , interpolatedstring-perl6 - , jose == 0.7.0.0 - , lens - , lens-aeson - , network-uri - , optparse-applicative >= 0.13 && < 0.15 - , parsec - , protolude == 0.2.2 - , Ranged-sets == 0.3.0 - , regex-tdfa - , scientific - , swagger2 - , text - , time - , unordered-containers - , vector - , wai - , wai-cors - , wai-extra - , wai-middleware-static - , cookie + exposed-modules: PostgREST.ApiRequest + PostgREST.App + PostgREST.Auth + PostgREST.Config + PostgREST.DbRequestBuilder + PostgREST.DbStructure + PostgREST.Error + PostgREST.Middleware + PostgREST.OpenAPI + PostgREST.Parsers + PostgREST.QueryBuilder + PostgREST.RangeQuery + PostgREST.Types + other-modules: Paths_postgrest + hs-source-dirs: src + build-depends: base >= 4.9 && < 4.13 + , HTTP >= 4000.3.7 && < 4000.4 + , Ranged-sets >= 0.3 && < 0.5 + , aeson >= 0.11.3 && < 1.5 + , ansi-wl-pprint >= 0.6.7 && < 0.7 + , base64-bytestring >= 1 && < 1.1 + , bytestring >= 0.10.8 && < 0.11 + , case-insensitive >= 1.2 && < 1.3 + , cassava >= 0.4.5 && < 0.6 + , configurator-pg >= 0.1 && < 0.2 + , containers >= 0.5.7 && < 0.7 + , contravariant >= 1.4 && < 1.6 + , contravariant-extras >= 0.3.3 && < 0.4 + , cookie >= 0.4.2 && < 0.5 + , either >= 4.4.1 && < 5.1 + , gitrev >= 1.2 && < 1.4 + , hasql >= 1.4 && < 1.5 + , hasql-pool >= 0.5 && < 0.6 + , hasql-transaction >= 0.7.2 && < 0.8 + , heredoc >= 0.2 && < 0.3 + , http-types >= 0.12.2 && < 0.13 + , insert-ordered-containers >= 0.1 && < 0.3 + , interpolatedstring-perl6 >= 1 && < 1.1 + , jose >= 0.7 && < 0.8 + , lens >= 4.14 && < 4.18 + , lens-aeson >= 1.0.1 && < 1.1 + , network-uri >= 2.6.1 && < 2.7 + , optparse-applicative >= 0.13 && < 0.15 + , parsec >= 3.1.11 && < 3.2 + , protolude >= 0.2.2 && < 0.3 + , regex-tdfa >= 1.2.2 && < 1.3 + , scientific >= 0.3.4 && < 0.4 + , swagger2 >= 2.1.4 && < 2.4 + , text >= 1.2.2 && < 1.3 + , time >= 1.6 && < 1.9 + , unordered-containers >= 0.2.8 && < 0.3 + , 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 - Other-Modules: Paths_postgrest - Exposed-Modules: PostgREST.ApiRequest - , PostgREST.App - , PostgREST.Auth - , PostgREST.Config - , PostgREST.DbStructure - , PostgREST.DbRequestBuilder - , PostgREST.Error - , PostgREST.Middleware - , PostgREST.OpenAPI - , PostgREST.Parsers - , PostgREST.QueryBuilder - , PostgREST.RangeQuery - , PostgREST.Types - hs-source-dirs: src +executable postgrest + main-is: Main.hs + hs-source-dirs: main + build-depends: base >= 4.9 && < 4.13 + , auto-update >= 0.1.4 && < 0.2 + , base64-bytestring >= 1 && < 1.1 + , bytestring >= 0.10.8 && < 0.11 + , directory >= 1.2.6 && < 1.4 + , hasql >= 1.4 && < 1.5 + , hasql-pool >= 0.5 && < 0.6 + , hasql-transaction >= 0.7.2 && < 0.8 + , network < 2.9 + , postgrest + , protolude >= 0.2.2 && < 0.3 + , retry >= 0.7.4 && < 0.9 + , text >= 1.2.2 && < 1.3 + , time >= 1.6 && < 1.9 + , warp >= 3.2.12 && < 3.3 + default-language: Haskell2010 + default-extensions: OverloadedStrings + QuasiQuotes + NoImplicitPrelude + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -I2" -Test-Suite spec - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - default-extensions: OverloadedStrings, QuasiQuotes, NoImplicitPrelude - ghc-options: -threaded -rtsopts -with-rtsopts=-N - Hs-Source-Dirs: test - Main-Is: Main.hs - Other-Modules: Feature.AudienceJwtSecretSpec - , Feature.AuthSpec - , Feature.AsymmetricJwtSpec - , Feature.BinaryJwtSecretSpec - , Feature.ConcurrentSpec - , Feature.CorsSpec - , Feature.DeleteSpec - , Feature.ExtraSearchPathSpec - , Feature.InsertSpec - , Feature.JsonOperatorSpec - , Feature.NoJwtSpec - , Feature.PgVersion95Spec - , Feature.PgVersion96Spec - , Feature.ProxySpec - , Feature.QueryLimitedSpec - , Feature.QuerySpec - , Feature.RangeSpec - , Feature.SingularSpec - , Feature.StructureSpec - , Feature.UnicodeSpec - , Feature.AndOrParamsSpec - , Feature.RpcSpec - , Feature.NonexistentSchemaSpec - , Feature.UpsertSpec - , SpecHelper - , TestTypes - Build-Depends: aeson - , aeson-qq - , async - , auto-update - , base >= 4.8 && < 4.10 - , bytestring - , base64-bytestring - , case-insensitive - , cassava - , containers - , contravariant - , hasql >= 1.3 && < 1.4 - , hasql-pool >= 0.5 && < 0.6 - , hasql-transaction >= 0.7 && < 0.8 - , heredoc - , hjsonschema == 1.5.0.1 - , hspec - , hspec-wai >= 0.7.0 - , hspec-wai-json - , http-types - , lens - , lens-aeson - , monad-control - , postgrest - , process - , protolude == 0.2.2 - , regex-tdfa - , time - , transformers-base - , wai - , wai-extra + if !os(windows) + build-depends: unix + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Feature.AndOrParamsSpec + Feature.AsymmetricJwtSpec + Feature.AudienceJwtSecretSpec + Feature.AuthSpec + Feature.BinaryJwtSecretSpec + Feature.ConcurrentSpec + Feature.CorsSpec + Feature.DeleteSpec + Feature.ExtraSearchPathSpec + Feature.InsertSpec + Feature.JsonOperatorSpec + Feature.NoJwtSpec + Feature.NonexistentSchemaSpec + Feature.PgVersion95Spec + Feature.PgVersion96Spec + Feature.ProxySpec + Feature.QueryLimitedSpec + Feature.QuerySpec + Feature.RangeSpec + Feature.RootSpec + Feature.RpcSpec + Feature.SingularSpec + Feature.StructureSpec + Feature.UnicodeSpec + Feature.UpsertSpec + SpecHelper + TestTypes + hs-source-dirs: test + build-depends: base >= 4.9 && < 4.13 + , aeson >= 0.11.3 && < 1.5 + , aeson-qq >= 0.8.1 && < 0.9 + , async >= 2.1.1 && < 2.3 + , auto-update >= 0.1.4 && < 0.2 + , base64-bytestring >= 1 && < 1.1 + , 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-pool >= 0.5 && < 0.6 + , hasql-transaction >= 0.7.2 && < 0.8 + , heredoc >= 0.2 && < 0.3 + , hspec >= 2.3 && < 2.8 + , hspec-wai >= 0.7 && < 0.10 + , hspec-wai-json >= 0.7 && < 0.10 + , http-types >= 0.12.3 && < 0.13 + , lens >= 4.14 && < 4.18 + , lens-aeson >= 1.0.1 && < 1.1 + , monad-control >= 1.0.1 && < 1.1 + , postgrest + , process >= 1.4.2 && < 1.7 + , protolude >= 0.2.2 && < 0.3 + , regex-tdfa >= 1.2.2 && < 1.3 + , text >= 1.2.2 && < 1.3 + , time >= 1.6 && < 1.9 + , 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 diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -1,44 +1,54 @@ -{-# LANGUAGE LambdaCase #-} {-| Module : PostgREST.ApiRequest Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. -} -module PostgREST.ApiRequest ( ApiRequest(..) - , ContentType(..) - , Action(..) - , Target(..) - , PreferRepresentation (..) - , mutuallyAgreeable - , userApiRequest - ) where +{-# LANGUAGE LambdaCase #-} -import Protolude -import qualified Data.Aeson as JSON -import Data.Aeson.Types (emptyObject, emptyArray) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS (c2w) -import qualified Data.ByteString.Lazy as BL -import qualified Data.Csv as CSV -import qualified Data.List as L -import Data.List (lookup, last, partition) -import qualified Data.HashMap.Strict as M -import qualified Data.Set as S -import Data.Maybe (fromJust) -import Control.Arrow ((***)) -import qualified Data.Text as T -import qualified Data.Vector as V -import Network.HTTP.Base (urlEncodeVars) -import Network.HTTP.Types.Header (hAuthorization, hCookie) -import Network.HTTP.Types.URI (parseSimpleQuery) -import Network.Wai (Request (..)) -import Network.Wai.Parse (parseHttpAccept) -import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset) -import Data.Ranged.Boundaries -import PostgREST.Types -import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange) -import qualified Data.CaseInsensitive as CI -import Web.Cookie (parseCookiesText) +module PostgREST.ApiRequest ( + ApiRequest(..) +, ContentType(..) +, Action(..) +, Target(..) +, PreferRepresentation (..) +, 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.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 + type RequestBody = BL.ByteString -- | Types of things a user wants to do to tables/views/procs @@ -49,8 +59,8 @@ deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier - | TargetProc QualifiedIdentifier - | TargetRoot + | TargetProc{tpQi :: QualifiedIdentifier, tpIsRootSpec :: Bool} + | TargetDefaultSpec -- The default spec offered at root "/" | TargetUnknown [Text] deriving Eq -- | How to return the inserted data @@ -65,44 +75,46 @@ -} data ApiRequest = ApiRequest { -- | Similar but not identical to HTTP verb, e.g. Create/Invoke both POST - iAction :: Action + iAction :: Action -- | Requested range of rows within response - , iRange :: M.HashMap ByteString NonnegRange + , iRange :: M.HashMap ByteString NonnegRange -- | The target, be it calling a proc or accessing a table - , iTarget :: Target + , iTarget :: Target -- | Content types the client will accept, [CTAny] if no Accept header - , iAccepts :: [ContentType] + , iAccepts :: [ContentType] -- | Data sent by client and used for mutation actions - , iPayload :: Maybe PayloadJSON + , iPayload :: Maybe PayloadJSON -- | If client wants created items echoed back - , iPreferRepresentation :: PreferRepresentation + , iPreferRepresentation :: PreferRepresentation -- | Pass all parameters as a single json object to a stored procedure , iPreferSingleObjectParameter :: Bool -- | Whether the client wants a result count (slower) - , iPreferCount :: Bool + , iPreferCount :: Bool -- | Whether the client wants to UPSERT or ignore records on PK conflict - , iPreferResolution :: Maybe PreferResolution + , iPreferResolution :: Maybe PreferResolution -- | Filters on the result ("id", "eq.10") - , iFilters :: [(Text, Text)] + , iFilters :: [(Text, Text)] -- | &and and &or parameters used for complex boolean logic - , iLogic :: [(Text, Text)] + , iLogic :: [(Text, Text)] -- | &select parameter used to shape the response - , iSelect :: Text + , iSelect :: Text + -- | &columns parameter used to shape the payload + , iColumns :: Maybe Text -- | &order parameters for each level - , iOrder :: [(Text, Text)] + , iOrder :: [(Text, Text)] -- | Alphabetized (canonical) request query string for response URLs - , iCanonicalQS :: ByteString + , iCanonicalQS :: ByteString -- | JSON Web Token - , iJWT :: Text + , iJWT :: Text -- | HTTP request headers - , iHeaders :: [(Text, Text)] + , iHeaders :: [(Text, Text)] -- | Request Cookies - , iCookies :: [(Text, Text)] + , iCookies :: [(Text, Text)] } -- | Examines HTTP request and translates it into user intent. -userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest -userApiRequest schema req reqBody +userApiRequest :: Schema -> Maybe QualifiedIdentifier -> Request -> RequestBody -> Either ApiRequestError ApiRequest +userApiRequest schema rootSpec req reqBody | isTargetingProc && method `notElem` ["GET", "POST"] = Left ActionInappropriate | topLevelRange == emptyRange = Left InvalidRange | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload @@ -120,51 +132,64 @@ else Nothing , iFilters = filters , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ] - , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams + , iSelect = toS $ fromMaybe "*" $ join $ lookup "select" qParams + , iColumns = columns , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] , iCanonicalQS = toS $ urlEncodeVars - . L.sortBy (comparing fst) - . map (join (***) toS) - . parseSimpleQuery - $ rawQueryString req + . L.sortOn fst + . map (join (***) toS . second (fromMaybe BS.empty)) + $ queryStringWPlus , iJWT = tokenStr , iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hAuthorization, k /= hCookie] , iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie" } where + -- queryString with '+' not converted to ' ' + queryStringWPlus = parseQueryReplacePlus False $ 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{isReadOnly=True} -> partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts _ -> (flts, []) - flts = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ] + 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 = (== Just "rpc") $ listToMaybe path + isTargetingProc = case target of + TargetProc _ _ -> True + _ -> False + contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" + columns | action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}] = toS <$> join (lookup "columns" qParams) + | otherwise = Nothing payload = - case (decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type", action) of + case (contentType, action) of (_, ActionInvoke{isReadOnly=True}) -> - Right $ PayloadJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams) + Right $ ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams) (CTApplicationJSON, _) -> - note "All object keys must match" . payloadAttributes reqBody - =<< if BL.null reqBody && isTargetingProc - then Right emptyObject - else JSON.eitherDecode reqBody + 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 $ PayloadJSON (JSON.encode json) PJObject keys + Right $ ProcessedJSON (JSON.encode json) PJObject keys (ct, _) -> Left $ toS $ "Content-Type not acceptable: " <> toMime ct topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges action = case method of - "GET" | target == TargetRoot -> ActionInspect + "GET" | target == TargetDefaultSpec -> ActionInspect | isTargetingProc -> ActionInvoke{isReadOnly=True} | otherwise -> ActionRead @@ -177,19 +202,20 @@ "OPTIONS" -> ActionInfo _ -> ActionInspect target = case path of - [] -> TargetRoot - [table] -> TargetIdent - $ QualifiedIdentifier schema table - ["rpc", proc] -> TargetProc - $ QualifiedIdentifier schema proc - other -> TargetUnknown other + [] -> case rootSpec of + Just rsQi -> TargetProc rsQi True + Nothing -> TargetDefaultSpec + [table] -> TargetIdent $ QualifiedIdentifier schema table + ["rpc", proc] -> TargetProc (QualifiedIdentifier schema proc) False + other -> TargetUnknown other + shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke{isReadOnly=False}, ActionInvoke{isReadOnly=True}] relevantPayload | shouldParsePayload = rightToMaybe payload | otherwise = Nothing path = pathInfo req method = requestMethod req hdrs = requestHeaders req - qParams = [(toS k, v)|(k,v) <- queryString req] + qParams = [(toS k, v)|(k,v) <- queryStringWPlus] lookupHeader = flip lookup hdrs hasPrefer :: Text -> Bool hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs @@ -237,23 +263,6 @@ then listToMaybe sProduces else exact --- PRIVATE --------------------------------------------------------------- - -{-| - Warning: discards MIME parameters --} -decodeContentType :: BS.ByteString -> ContentType -decodeContentType ct = - case BS.takeWhile (/= BS.c2w ';') ct of - "application/json" -> CTApplicationJSON - "text/csv" -> CTTextCSV - "application/openapi+json" -> CTOpenAPI - "application/vnd.pgrst.object+json" -> CTSingularJSON - "application/vnd.pgrst.object" -> CTSingularJSON - "application/octet-stream" -> CTOctetStream - "*/*" -> CTAny - ct' -> CTOther ct' - type CsvData = V.Vector (M.HashMap Text BL.ByteString) {-| @@ -291,14 +300,14 @@ JSON.Object x -> S.fromList (M.keys x) == canonicalKeys _ -> False) arr in if areKeysUniform - then Just $ PayloadJSON raw (PJArray $ V.length arr) canonicalKeys + then Just $ ProcessedJSON raw (PJArray $ V.length arr) canonicalKeys else Nothing Just _ -> Nothing Nothing -> Just emptyPJArray - JSON.Object o -> Just $ PayloadJSON raw PJObject (S.fromList $ M.keys o) + JSON.Object o -> Just $ ProcessedJSON raw PJObject (S.fromList $ M.keys o) -- truncate everything else to an empty array. _ -> Just emptyPJArray where - emptyPJArray = PayloadJSON (JSON.encode emptyArray) (PJArray 0) S.empty + emptyPJArray = ProcessedJSON (JSON.encode emptyArray) (PJArray 0) S.empty diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,66 +1,56 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NamedFieldPuns #-} module PostgREST.App ( postgrest ) where -import Control.Applicative -import Data.Aeson as JSON -import qualified Data.ByteString.Char8 as BS -import Data.Maybe -import Data.IORef (IORef, readIORef) -import Data.Text (intercalate) -import Data.Time.Clock (UTCTime) -import qualified Data.Set as S - +import qualified Data.ByteString.Char8 as BS +import qualified Data.HashMap.Strict as M +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 Network.HTTP.Types.Header -import Network.HTTP.Types.Status -import Network.HTTP.Types.URI (renderSimpleQuery) -import Network.Wai -import Network.Wai.Middleware.RequestLogger (logStdout) - -import qualified Hasql.Transaction as H - -import qualified Data.HashMap.Strict as M +import Data.Aeson as JSON +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 PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) - , Action(..), Target(..) - , PreferRepresentation (..) - , mutuallyAgreeable - , userApiRequest - ) -import PostgREST.Auth (jwtClaims, containsRole, parseSecret) -import PostgREST.Config (AppConfig (..)) -import PostgREST.DbStructure -import PostgREST.DbRequestBuilder( readRequest - , mutateRequest - , fieldNames - ) -import PostgREST.Error ( simpleError, pgError - , apiRequestError - , singularityError, binaryFieldError - , connectionLostError, gucHeadersError - ) -import PostgREST.RangeQuery (allRange, rangeOffset) -import PostgREST.Middleware -import PostgREST.QueryBuilder ( callProc - , requestToQuery - , requestToCountQuery - , createReadStatement - , createWriteStatement - , ResultsWithCount - ) -import PostgREST.Types -import PostgREST.OpenAPI +import Control.Applicative +import Data.Maybe +import Network.HTTP.Types.Header +import Network.HTTP.Types.Status +import Network.Wai -import Data.Function (id) -import Protolude hiding (intercalate, Proxy) +import PostgREST.ApiRequest (Action (..), ApiRequest (..), + ContentType (..), + PreferRepresentation (..), + Target (..), mutuallyAgreeable, + userApiRequest) +import PostgREST.Auth (containsRole, jwtClaims, + parseSecret) +import PostgREST.Config (AppConfig (..)) +import PostgREST.DbRequestBuilder (fieldNames, mutateRequest, + readRequest) +import PostgREST.DbStructure +import PostgREST.Error (PgError (..), SimpleError (..), + errorResponseFor, singularityError) +import PostgREST.Middleware +import PostgREST.OpenAPI +import PostgREST.Parsers (pRequestColumns) +import PostgREST.QueryBuilder (ResultsWithCount, callProc, + createReadStatement, + createWriteStatement, + requestToCountQuery, + requestToQuery) +import PostgREST.RangeQuery (allRange, rangeOffset) +import PostgREST.Types +import Protolude hiding (Proxy, intercalate) postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application postgrest conf refDbStructure pool getTime worker = @@ -72,36 +62,31 @@ body <- strictRequestBody req maybeDbStructure <- readIORef refDbStructure case maybeDbStructure of - Nothing -> respond connectionLostError + Nothing -> respond . errorResponseFor $ ConnectionLostError Just dbStructure -> do - response <- case userApiRequest (configSchema conf) req body of - Left err -> return $ apiRequestError err - Right apiRequest -> do - eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf) - - let authed = containsRole eClaims - proc = case (iTarget apiRequest, iPayload apiRequest, iPreferSingleObjectParameter apiRequest) of - (TargetProc qi, Just PayloadJSON{pjKeys}, s) -> findProc qi pjKeys s $ dbProcs dbStructure - _ -> Nothing - handleReq = runWithClaims conf eClaims (app dbStructure proc conf) apiRequest - txMode = transactionMode proc (iAction apiRequest) - response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq - return $ either (pgError authed) identity response + response <- do + -- Need to parse ?columns early because findProc needs it to solve overloaded functions + let apiReq = userApiRequest (configSchema 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 (iPreferSingleObjectParameter apiRequest) $ 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 -findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription -findProc qi payloadKeys paramsAsSingleObject allProcs = - let procs = M.lookup (qiName qi) allProcs in - -- Handle overloaded functions case - join $ (case length <$> procs of - Just 1 -> headMay -- if it's not an overloaded function then immediatly get the ProcDescription - _ -> find (\x -> - if paramsAsSingleObject - then length (pdArgs x) == 1 -- if the arg is not of json type let the db give the err - else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x)) - ) <$> procs - transactionMode :: Maybe ProcDescription -> Action -> HT.Mode transactionMode proc action = case action of @@ -109,16 +94,16 @@ ActionInfo -> HT.Read ActionInspect -> HT.Read ActionInvoke{isReadOnly=False} -> - let v = maybe Volatile pdVolatility proc in + let v = maybe Volatile pdVolatility proc in if v == Stable || v == Immutable then HT.Read else HT.Write ActionInvoke{isReadOnly=True} -> HT.Read _ -> HT.Write -app :: DbStructure -> Maybe ProcDescription -> AppConfig -> ApiRequest -> H.Transaction Response -app dbStructure proc conf apiRequest = - case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of +app :: DbStructure -> Maybe ProcDescription -> S.Set FieldName -> AppConfig -> ApiRequest -> H.Transaction Response +app dbStructure proc cols conf apiRequest = + case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) (iTarget apiRequest) of Left errorResponse -> return errorResponse Right contentType -> case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of @@ -137,7 +122,7 @@ canonical = iCanonicalQS apiRequest return $ if contentType == CTSingularJSON && queryTotal /= 1 - then singularityError (toInteger queryTotal) + then errorResponseFor . singularityError $ queryTotal else responseLBS status [toHeader contentType, contentRange, ("Content-Location", @@ -146,83 +131,86 @@ ) ] (toS body) - (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType}) -> + (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) -> case mutateSqlParts tSchema tName of Left errorResponse -> return errorResponse Right (sq, mq) -> do - let (isSingle, nRows) = case pjType of - PJArray len -> (len == 1, len) - PJObject -> (True, 1) + let pkCols = tablePKCols dbStructure tSchema tName + stm = createWriteStatement sq mq + (contentType == CTSingularJSON) True + (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols + row <- H.statement (toS $ pjRaw pJson) stm + let (_, queryTotal, fs, body) = extractQueryResult row + headers = catMaybes [ + if null fs + then Nothing + else Just (hLocation, "/" <> toS tName <> renderLocationFields fs) + , if iPreferRepresentation apiRequest == Full + then Just $ toHeader contentType + else Nothing + , Just $ contentRangeH 1 0 $ + if shouldCount then Just queryTotal else Nothing + , if null pkCols + then Nothing + else (\x -> ("Preference-Applied", show x)) <$> iPreferResolution apiRequest + ] if contentType == CTSingularJSON - && not isSingle + && queryTotal /= 1 && iPreferRepresentation apiRequest == Full - then return $ singularityError (toInteger nRows) - else do - let pkCols = tablePKCols dbStructure tSchema tName - stm = createWriteStatement sq mq - (contentType == CTSingularJSON) isSingle - (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols - row <- H.statement (toS pjRaw) stm - let (_, _, fs, body) = extractQueryResult row - headers = catMaybes [ - if null fs - then Nothing - else Just (hLocation, "/" <> toS tName <> renderLocationFields fs) - , if iPreferRepresentation apiRequest == Full - then Just $ toHeader contentType - else Nothing - , Just . contentRangeH 1 0 $ - toInteger <$> if shouldCount then Just nRows else Nothing - , if null pkCols - then Nothing - else (\x -> ("Preference-Applied", show x)) <$> iPreferResolution apiRequest - ] - - return . responseLBS status201 headers $ - if iPreferRepresentation apiRequest == Full - then toS body else "" + then do + HT.condemn + return . errorResponseFor . singularityError $ queryTotal + else + return . responseLBS status201 headers $ + if iPreferRepresentation apiRequest == Full + then toS body else "" - (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just p@PayloadJSON{pjRaw}) -> - case (mutateSqlParts tSchema tName, pjIsEmpty p, iPreferRepresentation apiRequest == Full) of - (Left errorResponse, _, _) -> return errorResponse - (_, True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]" - (_, True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] "" - (Right (sq, mq), _, _) -> do + (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) [] - row <- H.statement (toS pjRaw) stm + row <- H.statement (toS $ pjRaw pJson) stm let (_, queryTotal, _, body) = extractQueryResult row - if contentType == CTSingularJSON - && queryTotal /= 1 - && iPreferRepresentation apiRequest == Full - then do - HT.condemn - return $ singularityError (toInteger queryTotal) - else do - let r = contentRangeH 0 (toInteger $ queryTotal-1) - (toInteger <$> if shouldCount then Just queryTotal else Nothing) - s = if iPreferRepresentation apiRequest == Full - then status200 - else status204 - return $ if iPreferRepresentation apiRequest == Full - then responseLBS s [toHeader contentType, r] (toS body) - else responseLBS s [r] "" - (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType, pjKeys}) -> + updateIsNoOp = S.null cols + contentRangeHeader = contentRangeH 0 (queryTotal - 1) $ + if shouldCount then Just queryTotal else Nothing + minimalHeaders = [contentRangeHeader] + fullHeaders = toHeader contentType : minimalHeaders + + status | queryTotal == 0 && not updateIsNoOp = status404 + | iPreferRepresentation apiRequest == Full = status200 + | otherwise = status204 + + case (contentType, iPreferRepresentation apiRequest) of + (CTSingularJSON, Full) + | queryTotal == 1 -> return $ responseLBS status fullHeaders (toS body) + | otherwise -> HT.condemn >> (return . errorResponseFor . singularityError) queryTotal + + (_, Full) -> + return $ responseLBS status fullHeaders (toS body) + + (_, _) -> + return $ responseLBS status minimalHeaders mempty + + + (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just ProcessedJSON{pjRaw, pjType, pjKeys}) -> case mutateSqlParts tSchema tName of Left errorResponse -> return errorResponse Right (sq, mq) -> do let isSingle = case pjType of PJArray len -> len == 1 - PJObject -> True + PJObject -> True colNames = colName <$> tableCols dbStructure tSchema tName if topLevelRange /= allRange - then return $ simpleError status400 [] "Range header and limit/offset querystring parameters are not allowed for PUT" + then return . errorResponseFor $ PutRangeNotAllowedError else if not isSingle - then return $ simpleError status400 [] "PUT payload must contain a single row" + then return . errorResponseFor $ PutSingletonError else if S.fromList colNames /= pjKeys - then return $ simpleError status400 [] "You must specify all columns in the payload when using PUT" + then return . errorResponseFor $ PutPayloadIncompleteError else do row <- H.statement (toS pjRaw) $ createWriteStatement sq mq (contentType == CTSingularJSON) False @@ -234,7 +222,7 @@ if queryTotal /= 1 then do HT.condemn - return $ simpleError status400 [] "Payload values do not match URL in primary key column(s)" + return . errorResponseFor $ PutMatchingPkError else return $ if iPreferRepresentation apiRequest == Full then responseLBS status200 [toHeader contentType] (toS body) @@ -251,13 +239,13 @@ row <- H.statement mempty stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 1 0 $ - toInteger <$> if shouldCount then Just queryTotal else Nothing + if shouldCount then Just queryTotal else Nothing if contentType == CTSingularJSON && queryTotal /= 1 && iPreferRepresentation apiRequest == Full then do HT.condemn - return $ singularityError (toInteger queryTotal) + return . errorResponseFor . singularityError $ queryTotal else return $ if iPreferRepresentation apiRequest == Full then responseLBS status200 [toHeader contentType, r] (toS body) @@ -271,7 +259,7 @@ let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in return $ responseLBS status200 [allOrigins, acceptH] "" - (ActionInvoke _, TargetProc qi, Just PayloadJSON{pjRaw, pjType, pjKeys}) -> + (ActionInvoke _, TargetProc qi _, Just pJson) -> let returnsScalar = case proc of Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True _ -> False @@ -282,31 +270,27 @@ case parts of Left errorResponse -> return errorResponse Right ((q, cq), bField) -> do - let isObject = case pjType of - PJObject -> True - PJArray _ -> False - singular = contentType == CTSingularJSON - specifiedPgArgs = filter ((`S.member` pjKeys) . pgaName) $ maybe [] pdArgs proc - row <- H.statement (toS pjRaw) $ - callProc qi specifiedPgArgs returnsScalar q cq shouldCount + let singular = contentType == CTSingularJSON + row <- H.statement (toS $ pjRaw pJson) $ + callProc qi (specifiedProcArgs cols proc) returnsScalar q cq shouldCount singular (iPreferSingleObjectParameter apiRequest) (contentType == CTTextCSV) - (contentType == CTOctetStream) bField isObject + (contentType `elem` rawContentTypes) bField (pgVersion dbStructure) let (tableTotal, queryTotal, body, jsonHeaders) = fromMaybe (Just 0, 0, "[]", "[]") row (status, contentRange) = rangeHeader queryTotal tableTotal decodedHeaders = first toS $ JSON.eitherDecode $ toS jsonHeaders :: Either Text [GucHeader] case decodedHeaders of - Left _ -> return gucHeadersError + Left _ -> return . errorResponseFor $ GucHeadersError Right hs -> if singular && queryTotal /= 1 then do HT.condemn - return $ singularityError (toInteger queryTotal) + return . errorResponseFor . singularityError $ queryTotal else return $ responseLBS status ([toHeader contentType, contentRange] ++ toHeaders hs) (toS body) - (ActionInspect, TargetRoot, Nothing) -> do + (ActionInspect, TargetDefaultSpec, Nothing) -> do let host = configHost conf port = toInteger $ configPort conf proxy = pickProxy $ toS <$> configProxyUri conf @@ -316,6 +300,7 @@ toTableInfo :: [Table] -> [(Table, [Column], [Text])] toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn)) encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure + body <- encodeApi <$> H.statement schema accessibleTables <*> H.statement schema schemaDescription <*> H.statement schema accessibleProcs return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body @@ -340,39 +325,41 @@ selectQuery = requestToQuery schema False <$> readDbRequest countQuery = requestToCountQuery schema <$> readDbRequest readSqlParts = (,) <$> selectQuery <*> countQuery + mutationDbRequest s t = mutateRequest apiRequest t cols (tablePKCols dbStructure s t) =<< fldNames mutateSqlParts s t = (,) <$> selectQuery - <*> (requestToQuery schema False . DbMutate <$> (mutateRequest apiRequest t (tablePKCols dbStructure s t) =<< fldNames)) + <*> (requestToQuery schema False . DbMutate <$> mutationDbRequest s t) -responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType -responseContentTypeOrError accepts action = serves contentTypesForRequest accepts +responseContentTypeOrError :: [ContentType] -> Action -> Target -> Either Response ContentType +responseContentTypeOrError accepts action target = serves contentTypesForRequest accepts where - contentTypesForRequest = - case action of - ActionRead -> [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream] - ActionCreate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - ActionUpdate -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - ActionDelete -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] - ActionInvoke _ -> [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream] - ActionInspect -> [CTOpenAPI, CTApplicationJSON] - ActionInfo -> [CTTextCSV] - ActionSingleUpsert -> [CTApplicationJSON, CTSingularJSON, CTTextCSV] + 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 -> do - let failed = intercalate ", " $ map (toS . toMime) cAccepts - Left $ simpleError status415 [] $ - "None of these Content-Types are available: " <> failed + Nothing -> Left . errorResponseFor . ContentTypeError . map toMime $ cAccepts Just ct -> Right ct +{- + | 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 -> [FieldName] -> Either Response (Maybe FieldName) -binaryField CTOctetStream fldNames = - if length fldNames == 1 && fieldName /= Just "*" - then Right fieldName - else Left binaryFieldError - where - fieldName = headMay fldNames -binaryField _ _ = Right Nothing +binaryField ct fldNames + | 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 splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) splitKeyValue kv = (k, BS.tail v) @@ -389,7 +376,7 @@ | (1 + upper - lower) < total = status206 | otherwise = status200 -contentRangeH :: Integer -> Integer -> Maybe Integer -> Header +contentRangeH :: (Integral a, Show a) => a -> a -> Maybe a -> Header contentRangeH lower upper total = ("Content-Range", headerValue) where 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,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-| Module : PostgREST.Auth Description : PostgREST authorization functions. @@ -19,17 +19,19 @@ , parseSecret ) where -import Control.Lens.Operators -import Control.Lens (set) -import qualified Data.Aeson as JSON -import qualified Data.HashMap.Strict as M -import Data.Time.Clock (UTCTime) -import Data.Vector as V -import PostgREST.Types -import Protolude +import qualified Crypto.JOSE.Types as JOSE.Types +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as M +import Data.Vector as V -import qualified Crypto.JOSE.Types as JOSE.Types -import Crypto.JWT +import Control.Lens (set) +import Data.Time.Clock (UTCTime) + +import Control.Lens.Operators +import Crypto.JWT + +import PostgREST.Types +import Protolude {-| Possible situations encountered with client JWTs diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase, TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-type-defaults #-} {-| Module : PostgREST.Config Description : Manages PostgREST configuration options. @@ -14,51 +12,58 @@ Other hardcoded options such as the minimum version number also belong here. -} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + module PostgREST.Config ( prettyVersion , docsVersion , readOptions , corsPolicy , AppConfig (..) + , configPoolTimeout' ) where -import Control.Applicative -import Control.Monad (fail) -import Control.Lens (preview) -import Crypto.JWT (StringOrURI, - stringOrUri) 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 Data.Configurator.Parser as C -import Data.Configurator.Types as C -import Data.List (lookup) -import Data.Monoid -import Data.Scientific (floatingOrInteger) -import Data.String (String) -import Data.Text (dropAround, - intercalate, lines, - strip, take, splitOn) -import Data.Text.Encoding (encodeUtf8) -import Data.Text.IO (hPutStrLn) -import Data.Version (versionBranch) -import Development.GitRev (gitHash) -import Network.Wai -import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) -import Options.Applicative hiding (str) -import Paths_postgrest (version) -import PostgREST.Parsers (pRoleClaimKey) -import PostgREST.Types (ApiRequestError(..), - JSPath, JSPathExp(..)) -import Protolude hiding (hPutStrLn, take, - intercalate, (<>)) -import System.IO (hPrint) -import System.IO.Error (IOError) -import Text.Heredoc -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) import qualified Text.PrettyPrint.ANSI.Leijen as L +import Control.Exception (Handler (..)) +import Control.Lens (preview) +import Control.Monad (fail) +import Crypto.JWT (StringOrURI, stringOrUri) +import Data.List (lookup) +import Data.Scientific (floatingOrInteger) +import Data.Text (dropEnd, dropWhileEnd, + intercalate, lines, splitOn, + strip, take, unpack) +import Data.Text.Encoding (encodeUtf8) +import Data.Text.IO (hPutStrLn) +import Data.Version (versionBranch) +import Development.GitRev (gitHash) +import Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) +import Paths_postgrest (version) +import System.IO.Error (IOError) + +import Control.Applicative +import Data.Monoid +import Network.Wai +import Options.Applicative hiding (str) +import Text.Heredoc +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) + +import PostgREST.Error (ApiRequestError (..)) +import PostgREST.Parsers (pRoleClaimKey) +import PostgREST.Types (JSPath, JSPathExp (..), + QualifiedIdentifier (..)) +import Protolude hiding (concat, hPutStrLn, intercalate, null, + take, (<>)) + + -- | Config file settings for the server data AppConfig = AppConfig { configDatabase :: Text @@ -67,20 +72,29 @@ , configSchema :: Text , configHost :: Text , configPort :: Int + , configSocket :: Maybe Text , 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 QualifiedIdentifier } +configPoolTimeout' :: (Fractional a) => AppConfig -> a +configPoolTimeout' = + fromRational . toRational . configPoolTimeout + + defaultCorsPolicy :: CorsResourcePolicy defaultCorsPolicy = CorsResourcePolicy Nothing ["GET", "POST", "PATCH", "PUT", "DELETE", "OPTIONS"] ["Authorization"] Nothing @@ -112,7 +126,7 @@ -- | Version number used in docs docsVersion :: Text -docsVersion = "v" <> dropAround (== '.') (dropAround (/= '.') prettyVersion) +docsVersion = "v" <> dropEnd 1 (dropWhileEnd (/= '.') prettyVersion) -- | Function to read and parse options from the command line readOptions :: IO AppConfig @@ -120,68 +134,87 @@ -- First read the config file path from command line cfgPath <- customExecParser parserPrefs opts -- Now read the actual config file - conf <- catch - (C.readConfig =<< C.load [C.Required cfgPath]) - configNotfoundHint - - let (mAppConf, errs) = flip C.runParserM conf $ - AppConfig - <$> C.key "db-uri" - <*> C.key "db-anon-role" - <*> (mfilter (/= "") <$> C.key "server-proxy-uri") - <*> C.key "db-schema" - <*> (fromMaybe "127.0.0.1" . mfilter (/= "") <$> C.key "server-host") - <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port") - <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret") - <*> (fromMaybe False . join . fmap coerceBool <$> C.key "secret-is-base64") - <*> parseJwtAudience "jwt-aud" - <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool") - <*> (join . fmap coerceInt <$> C.key "max-rows") - <*> (mfilter (/= "") <$> C.key "pre-request") - <*> pure False - <*> (fmap (fmap coerceText) <$> C.subassocs "app.settings") - <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> C.key "role-claim-key") - <*> (maybe ["public"] splitExtraSearchPath <$> C.key "db-extra-search-path") + 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\t" <> err) + ] - case mAppConf of - Nothing -> do - forM_ errs $ hPrint stderr - exitFailure - Just appConf -> + case C.runParser parseConfig conf of + Left err -> + exitErr $ "Error parsing config file:\n\t" <> err + Right appConf -> return appConf where - parseJwtAudience :: Name -> C.ConfigParserM (Maybe StringOrURI) + dbSchema = reqString "db-schema" + parseConfig = + AppConfig + <$> reqString "db-uri" + <*> reqString "db-anon-role" + <*> optString "server-proxy-uri" + <*> dbSchema + <*> (fromMaybe "!4" <$> optString "server-host") + <*> (fromMaybe 3000 <$> optInt "server-port") + <*> optString "server-unix-socket" + <*> (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"] splitExtraSearchPath <$> optValue "db-extra-search-path") + <*> ((\x y -> QualifiedIdentifier x <$> y) <$> dbSchema <*> optString "root-spec") + + parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI) parseJwtAudience k = - C.key k >>= \case + C.optional k C.string >>= \case Nothing -> pure Nothing -- no audience in config file - Just aud -> case preview stringOrUri (aud :: String) of + Just aud -> case preview stringOrUri (unpack aud) of Nothing -> fail "Invalid Jwt audience. Check your configuration." (Just "") -> pure Nothing aud' -> pure aud' - coerceText :: Value -> Text - coerceText (String s) = s - coerceText v = show v + reqString :: C.Key -> C.Parser C.Config Text + reqString k = C.required k C.string - coerceInt :: (Read i, Integral i) => Value -> Maybe i - coerceInt (Number x) = rightToMaybe $ floatingOrInteger x - coerceInt (String x) = readMaybe $ toS x - coerceInt _ = Nothing + optString :: C.Key -> C.Parser C.Config (Maybe Text) + optString k = mfilter (/= "") <$> C.optional k C.string - coerceBool :: Value -> Maybe Bool - coerceBool (Bool b) = Just b - coerceBool (String b) = readMaybe $ toS b - coerceBool _ = Nothing + optValue :: C.Key -> C.Parser C.Config (Maybe C.Value) + optValue k = C.optional k C.value - parseRoleClaimKey :: Value -> Either ApiRequestError JSPath - parseRoleClaimKey (String s) = pRoleClaimKey s - parseRoleClaimKey v = pRoleClaimKey $ show v + optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i) + optInt k = join <$> C.optional k (coerceInt <$> C.value) - splitExtraSearchPath :: Value -> [Text] - splitExtraSearchPath (String s) = strip <$> splitOn "," s - splitExtraSearchPath _ = [] + optBool :: C.Key -> C.Parser C.Config (Maybe Bool) + optBool k = join <$> C.optional k (coerceBool <$> C.value) + coerceText :: C.Value -> Text + coerceText (C.String s) = s + coerceText v = show v + + coerceInt :: (Read i, Integral i) => C.Value -> Maybe i + coerceInt (C.Number x) = rightToMaybe $ floatingOrInteger x + coerceInt (C.String x) = readMaybe $ toS x + coerceInt _ = Nothing + + coerceBool :: C.Value -> Maybe Bool + coerceBool (C.Bool b) = Just b + coerceBool (C.String b) = readMaybe $ toS b + coerceBool _ = Nothing + + parseRoleClaimKey :: C.Value -> Either ApiRequestError JSPath + parseRoleClaimKey (C.String s) = pRoleClaimKey s + parseRoleClaimKey v = pRoleClaimKey $ show v + + splitExtraSearchPath :: C.Value -> [Text] + splitExtraSearchPath (C.String s) = strip <$> splitOn "," s + splitExtraSearchPath _ = [] + opts = info (helper <*> pathParser) $ fullDesc <> progDesc ( @@ -196,10 +229,9 @@ parserPrefs = prefs showHelpOnError - configNotfoundHint :: IOError -> IO a - configNotfoundHint e = do - hPutStrLn stderr $ - "Cannot open config file:\n\t" <> show e + exitErr :: Text -> IO a + exitErr err = do + hPutStrLn stderr err exitFailure exampleCfg :: Doc @@ -208,10 +240,15 @@ |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 = "127.0.0.1" + |server-host = "!4" |server-port = 3000 | + |## unix socket location + |## if specified it takes precedence over server-port + |# server-unix-socket = "/tmp/pgrst.sock" + | |## base url for swagger output |# server-proxy-uri = "" | @@ -232,6 +269,10 @@ | |## 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" |] pathParser :: Parser FilePath diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs --- a/src/PostgREST/DbRequestBuilder.hs +++ b/src/PostgREST/DbRequestBuilder.hs @@ -1,48 +1,53 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DuplicateRecordFields#-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} +{-| +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 , fieldNames ) where -import Control.Applicative -import Control.Arrow ((***)) -import Control.Lens.Getter (view) -import Control.Lens.Tuple (_1) -import qualified Data.ByteString.Char8 as BS -import Data.List (delete) -import Data.Maybe (fromJust) -import qualified Data.Set as S -import Data.Text (isInfixOf) -import Data.Tree -import Data.Either.Combinators (mapLeft) - -import Network.Wai +import qualified Data.ByteString.Char8 as BS +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S -import Data.Foldable (foldr1) -import qualified Data.HashMap.Strict as M +import Control.Arrow ((***)) +import Control.Lens.Getter (view) +import Control.Lens.Tuple (_1) +import Data.Either.Combinators (mapLeft) +import Data.Foldable (foldr1) +import Data.List (delete) +import Data.Maybe (fromJust) +import Data.Text (isInfixOf) +import Text.Regex.TDFA ((=~)) +import Unsafe (unsafeHead) -import PostgREST.ApiRequest ( ApiRequest(..) - , PreferRepresentation(..) - , Action(..), Target(..) - , PreferRepresentation (..) - ) -import PostgREST.Error (apiRequestError) -import PostgREST.Parsers -import PostgREST.RangeQuery (NonnegRange, restrictRange, allRange) -import PostgREST.Types +import Control.Applicative +import Data.Tree +import Network.Wai -import Protolude hiding (from) -import Text.Regex.TDFA ((=~)) -import Unsafe (unsafeHead) +import PostgREST.ApiRequest (Action (..), ApiRequest (..), + PreferRepresentation (..), + PreferRepresentation (..), Target (..)) +import PostgREST.Error (ApiRequestError (..), errorResponseFor) +import PostgREST.Parsers +import PostgREST.RangeQuery (NonnegRange, allRange, restrictRange) +import PostgREST.Types +import Protolude hiding (from) readRequest :: Maybe Integer -> [Relation] -> Maybe ProcDescription -> ApiRequest -> Either Response ReadRequest readRequest maxRows allRels proc apiRequest = - mapLeft apiRequestError $ + mapLeft errorResponseFor $ treeRestrictRange maxRows =<< augumentRequestWithJoin schema relations =<< addFiltersOrdersRanges apiRequest <*> @@ -53,12 +58,12 @@ let target = iTarget apiRequest in case target of (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t) - (TargetProc (QualifiedIdentifier s pName) ) -> Just (s, tName) + (TargetProc (QualifiedIdentifier s pName) _ ) -> Just (s, tName) where tName = case pdReturnType <$> proc of - Just (SetOf (Composite qi)) -> qiName qi + Just (SetOf (Composite qi)) -> qiName qi Just (Single (Composite qi)) -> qiName qi - _ -> pName + _ -> pName _ -> Nothing @@ -68,7 +73,7 @@ buildReadRequest fieldTree = let rootDepth = 0 rootNodeName = if action == ActionRead then rootTableName else sourceCTEName in - foldr (treeEntry rootDepth) (Node (Select [] [rootNodeName] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing, rootDepth)) []) fieldTree + foldr (treeEntry rootDepth) (Node (Select [] rootNodeName Nothing [] [] [] [] allRange, (rootNodeName, Nothing, Nothing, Nothing, rootDepth)) []) fieldTree where treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest treeEntry depth (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) = @@ -76,7 +81,7 @@ case fldForest of [] -> Node (q {select=fld:select q}, i) rForest _ -> Node (q, i) $ - foldr (treeEntry nxtDepth) (Node (Select [] [fn] [] [] [] allRange, (fn, Nothing, alias, relationDetail, nxtDepth)) []) fldForest:rForest + foldr (treeEntry nxtDepth) (Node (Select [] fn Nothing [] [] [] [] allRange, (fn, Nothing, alias, relationDetail, nxtDepth)) []) fldForest:rForest relations :: [Relation] relations = case action of @@ -84,7 +89,7 @@ ActionUpdate -> fakeSourceRelations ++ allRels ActionDelete -> fakeSourceRelations ++ allRels ActionInvoke _ -> fakeSourceRelations ++ allRels - _ -> allRels + _ -> allRels where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- in a relation where one of the tables matches "TableName" @@ -108,13 +113,13 @@ augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest augumentRequestWithJoin schema allRels request = addRelations schema allRels Nothing request - >>= addJoinConditions schema + >>= addJoinConditions schema Nothing addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest -addRelations schema allRelations parentNode (Node (query, (nodeName, _, alias, relationDetail, depth)) forest) = +addRelations schema allRelations parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, relationDetail, depth)) forest) = case parentNode of - Just (Node (Select{from=[parentNodeTable]}, _) _) -> - let newFrom r = (\tName -> if tName == nodeName then tableName (relTable r) else tName) <$> from query + Just (Node (Select{from=parentNodeTable}, _) _) -> + let newFrom r = if tbl == nodeName then tableName (relTable r) else tbl newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel rel :: Either ApiRequestError Relation rel = note (NoRelationBetween parentNodeTable nodeName) $ @@ -208,35 +213,49 @@ ) ) allRelations -addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest -addJoinConditions schema (Node node@(query, nodeProps@(_, relation, _, _, _)) forest) = +-- previousAlias is only used for the case of self joins +addJoinConditions :: Schema -> Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest +addJoinConditions schema previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, relation, _, _, depth)) forest) = case relation of - Just Relation{relType=Root} -> Node node <$> updatedForest -- this is the root node + Just Relation{relType=Root} -> Node node <$> updatedForest -- this is the root node Just rel@Relation{relType=Parent} -> Node (augmentQuery rel, nodeProps) <$> updatedForest Just rel@Relation{relType=Child} -> Node (augmentQuery rel, nodeProps) <$> updatedForest Just rel@Relation{relType=Many, relLinkTable=(Just linkTable)} -> let rq = augmentQuery rel in - Node (rq{from=tableName linkTable:from rq}, nodeProps) <$> updatedForest + Node (rq{implicitJoins=tableName linkTable:implicitJoins rq}, nodeProps) <$> updatedForest _ -> Left UnknownRelation where - updatedForest = mapM (addJoinConditions schema) forest - augmentQuery rel = foldr addJoinCond query (getJoinConditions rel) - addJoinCond :: JoinCondition -> ReadQuery -> ReadQuery - addJoinCond jc rq@Select{joinConditions=jcs} = rq{joinConditions=jc:jcs} + newAlias = case isSelfJoin <$> relation of + Just True + | depth /= 0 -> Just (tbl <> "_" <> show depth) -- root node doesn't get aliased + | otherwise -> Nothing + _ -> Nothing + augmentQuery rel = + foldr + (\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs}) + query{fromAlias=newAlias} + (getJoinConditions previousAlias newAlias rel) + updatedForest = mapM (addJoinConditions schema newAlias) forest -getJoinConditions :: Relation -> [JoinCondition] -getJoinConditions (Relation Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols typ lt lc1 lc2) = - if | typ == Child || typ == Parent -> +-- 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 lt lc1 lc2) = + case typ of + Child -> zipWith (toJoinCondition tN ftN) cols fCols - | typ == Many -> + Parent -> + zipWith (toJoinCondition tN ftN) cols fCols + Many -> let ltN = maybe "" tableName lt in zipWith (toJoinCondition tN ltN) cols (fromMaybe [] lc1) ++ zipWith (toJoinCondition ftN ltN) fCols (fromMaybe [] lc2) - | typ == Root -> witness + Root -> witness where toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition toJoinCondition tb ftb c fc = - JoinCondition (QualifiedIdentifier tSchema tb, Nothing, colName c) - (QualifiedIdentifier tSchema ftb, Nothing, colName fc) + let qi1 = QualifiedIdentifier tSchema tb + qi2 = QualifiedIdentifier tSchema ftb in + JoinCondition (maybe qi1 (QualifiedIdentifier mempty) newAlias, colName c) + (maybe qi2 (QualifiedIdentifier mempty) previousAlias, colName fc) addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest) addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ @@ -299,11 +318,11 @@ where pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest -mutateRequest :: ApiRequest -> TableName -> [Text] -> [FieldName] -> Either Response MutateRequest -mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $ +mutateRequest :: ApiRequest -> TableName -> S.Set FieldName -> [FieldName] -> [FieldName] -> Either Response MutateRequest +mutateRequest apiRequest tName cols pkCols fldNames = mapLeft errorResponseFor $ case action of - ActionCreate -> Right $ Insert tName pkCols payload (iPreferResolution apiRequest) [] returnings - ActionUpdate -> Update tName payload <$> combinedLogic <*> pure returnings + ActionCreate -> Right $ Insert tName cols ((,) <$> iPreferResolution apiRequest <*> Just pkCols) [] returnings + ActionUpdate -> Update tName cols <$> combinedLogic <*> pure returnings ActionSingleUpsert -> (\flts -> if null (iLogic apiRequest) && @@ -312,14 +331,13 @@ all (\case Filter _ (OpExpr False (Op "eq" _)) -> True _ -> False) flts - then Insert tName pkCols payload (Just MergeDuplicates) <$> combinedLogic <*> pure returnings + then Insert tName cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings else Left InvalidFilters) =<< filters ActionDelete -> Delete tName <$> combinedLogic <*> pure returnings _ -> Left UnsupportedVerb where action = iAction apiRequest - payload = fromJust $ iPayload apiRequest returnings = if iPreferRepresentation apiRequest == None then [] else fldNames filters = map snd <$> mapM pRequestFilter mutateFilters logic = map snd <$> mapM pRequestLogicTree logicFilters diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -1,9 +1,19 @@ +{-| +Module : PostgREST.DbStructure +Description : PostgREST schema cache + +This module contains queries that target PostgreSQL system catalogs, these are used to build the schema cache(DbStructure). + +The schema cache is necessary for resource embedding, foreign keys are used for inferring the relationships between tables. + +These queries are executed once at startup or when PostgREST is reloaded. +-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE NamedFieldPuns #-} module PostgREST.DbStructure ( getDbStructure , accessibleTables @@ -12,27 +22,39 @@ , getPgVersion ) where -import qualified Hasql.Decoders as HD -import qualified Hasql.Encoders as HE -import qualified Hasql.Statement as H +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 Control.Applicative -import qualified Data.HashMap.Strict as M -import qualified Data.List as L -import Data.Set as S (fromList) -import Data.Text (split, strip, - breakOn, dropAround, - splitOn) -import qualified Data.Text as T -import qualified Hasql.Session as H -import qualified Hasql.Transaction as HT -import PostgREST.Types -import Text.InterpolatedString.Perl6 (q, qc) +import Data.Set as S (fromList) +import Data.Text (breakOn, dropAround, split, + splitOn, strip) +import GHC.Exts (groupWith) +import Text.InterpolatedString.Perl6 (q, qc) +import Unsafe (unsafeHead) -import GHC.Exts (groupWith) -import Protolude -import Unsafe (unsafeHead) +import Control.Applicative +import PostgREST.Types +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 + getDbStructure :: Schema -> PgVersion -> HT.Transaction DbStructure getDbStructure schema pgVer = do HT.sql "set local schema ''" -- for getting the fully qualified name(schema.name) of every db object @@ -60,10 +82,10 @@ decodeTables = HD.rowList tblRow where - tblRow = Table <$> HD.column HD.text - <*> HD.column HD.text - <*> HD.nullableColumn HD.text - <*> HD.column HD.bool + tblRow = Table <$> column HD.text + <*> column HD.text + <*> nullableColumn HD.text + <*> column HD.bool decodeColumns :: [Table] -> HD.Result [Column] decodeColumns tables = @@ -71,41 +93,41 @@ where colRow = (,,,,,,,,,,,) - <$> HD.column HD.text <*> HD.column HD.text - <*> HD.column HD.text <*> HD.nullableColumn HD.text - <*> HD.column HD.int4 <*> HD.column HD.bool - <*> HD.column HD.text <*> HD.column HD.bool - <*> HD.nullableColumn HD.int4 - <*> HD.nullableColumn HD.int4 - <*> HD.nullableColumn HD.text - <*> HD.nullableColumn HD.text + <$> 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 + <*> nullableColumn HD.int4 + <*> nullableColumn HD.text + <*> nullableColumn HD.text decodeRelations :: [Table] -> [Column] -> HD.Result [Relation] decodeRelations tables cols = mapMaybe (relationFromRow tables cols) <$> HD.rowList relRow where relRow = (,,,,,) - <$> HD.column HD.text - <*> HD.column HD.text - <*> HD.column (HD.array (HD.dimension replicateM (HD.element HD.text))) - <*> HD.column HD.text - <*> HD.column HD.text - <*> HD.column (HD.array (HD.dimension replicateM (HD.element HD.text))) + <$> column HD.text + <*> column HD.text + <*> column (HD.array (HD.dimension replicateM (element HD.text))) + <*> column HD.text + <*> column HD.text + <*> column (HD.array (HD.dimension replicateM (element HD.text))) decodePks :: [Table] -> HD.Result [PrimaryKey] decodePks tables = mapMaybe (pkFromRow tables) <$> HD.rowList pkRow where - pkRow = (,,) <$> HD.column HD.text <*> HD.column HD.text <*> HD.column HD.text + pkRow = (,,) <$> column HD.text <*> column HD.text <*> column HD.text decodeSynonyms :: [Column] -> HD.Result [Synonym] decodeSynonyms cols = mapMaybe (synonymFromRow cols) <$> HD.rowList synRow where synRow = (,,,,,) - <$> HD.column HD.text <*> HD.column HD.text - <*> HD.column HD.text <*> HD.column HD.text - <*> HD.column HD.text <*> HD.column HD.text + <$> column HD.text <*> column HD.text + <*> column HD.text <*> column HD.text + <*> column HD.text <*> column HD.text decodeProcs :: HD.Result (M.HashMap Text [ProcDescription]) decodeProcs = @@ -113,15 +135,15 @@ map sort . M.fromListWith (++) . map ((\(x,y) -> (x, [y])) . addName) <$> HD.rowList tblRow where tblRow = ProcDescription - <$> HD.column HD.text - <*> HD.nullableColumn HD.text - <*> (parseArgs <$> HD.column HD.text) + <$> column HD.text + <*> nullableColumn HD.text + <*> (parseArgs <$> column HD.text) <*> (parseRetType - <$> HD.column HD.text - <*> HD.column HD.text - <*> HD.column HD.bool - <*> HD.column HD.char) - <*> (parseVolatility <$> HD.column HD.char) + <$> column HD.text + <*> column HD.text + <*> column HD.bool + <*> column HD.char) + <*> (parseVolatility <$> column HD.char) addName :: ProcDescription -> (Text, ProcDescription) addName pd = (pdName pd, pd) @@ -158,10 +180,10 @@ | otherwise = Volatile -- only 'v' can happen here allProcs :: H.Statement Schema (M.HashMap Text [ProcDescription]) -allProcs = H.Statement (toS procsSqlQuery) (HE.param HE.text) decodeProcs True +allProcs = H.Statement (toS procsSqlQuery) (param HE.text) decodeProcs True accessibleProcs :: H.Statement Schema (M.HashMap Text [ProcDescription]) -accessibleProcs = H.Statement (toS sql) (HE.param HE.text) decodeProcs True +accessibleProcs = H.Statement (toS sql) (param HE.text) decodeProcs True where sql = procsSqlQuery <> " AND has_function_privilege(p.oid, 'execute')" @@ -186,7 +208,7 @@ schemaDescription :: H.Statement Schema (Maybe Text) schemaDescription = - H.Statement sql (HE.param HE.text) (join <$> HD.rowMaybe (HD.nullableColumn HD.text)) True + H.Statement sql (param HE.text) (join <$> HD.rowMaybe (nullableColumn HD.text)) True where sql = [q| select @@ -199,7 +221,7 @@ accessibleTables :: H.Statement Schema [Table] accessibleTables = - H.Statement sql (HE.param HE.text) decodeTables True + H.Statement sql (param HE.text) decodeTables True where sql = [q| select @@ -230,7 +252,7 @@ addForeignKeys rels = map addFk where addFk col = col { colFK = fk col } - fk col = join $ relToFk col <$> find (lookupFn col) rels + fk col = find (lookupFn col) rels >>= relToFk col lookupFn :: Column -> Relation -> Bool lookupFn c Relation{relColumns=cs, relType=rty} = c `elem` cs && rty==Child relToFk col Relation{relColumns=cols, relFColumns=colsF} = do @@ -285,20 +307,29 @@ -- 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 synonyms to match the relColumns -- This could be avoided if the Relation type is improved with a structure that maintains the association of relColumns and relFColumns - syns `sortAccordingTo` columns = sortOn (\(k, _) -> L.lookup k $ zip columns [0::Int ..]) syns in + syns `sortAccordingTo` columns = sortOn (\(k, _) -> L.lookup k $ zip columns [0::Int ..]) syns - -- View Table Child Relations - [Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) relFTable relFColumns Child Nothing Nothing Nothing - | syns <- colsSyns, syns `allSynsOf` relColumns] ++ + viewTableChild = + [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) + relFTable relFColumns + Child Nothing Nothing Nothing + | syns <- colsSyns, syns `allSynsOf` relColumns ] - -- Table View Child Relations - [Relation relTable relColumns (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) Child Nothing Nothing Nothing - | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns] ++ + tableViewChild = + [ Relation relTable relColumns + (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) + Child Nothing Nothing Nothing + | fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ] - -- View View Child Relations - [Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) Child Nothing Nothing Nothing - | syns <- colsSyns, fSyns <- fColsSyns, syns `allSynsOf` relColumns, fSyns `allSynsOf` relFColumns] + viewViewChild = + [ Relation (getView syns) (snd <$> syns `sortAccordingTo` relColumns) + (getView fSyns) (snd <$> fSyns `sortAccordingTo` relFColumns) + Child Nothing Nothing Nothing + | syns <- colsSyns, syns `allSynsOf` relColumns + , fSyns <- fColsSyns, fSyns `allSynsOf` relFColumns ] + in viewTableChild ++ tableViewChild ++ viewViewChild + _ -> []) addParentRelations :: [Relation] -> [Relation] @@ -332,7 +363,7 @@ allTables :: H.Statement () [Table] allTables = - H.Statement sql HE.unit decodeTables True + H.Statement sql HE.noParams decodeTables True where sql = [q| SELECT @@ -355,7 +386,7 @@ allColumns :: [Table] -> H.Statement Schema [Column] allColumns tabs = - H.Statement sql (HE.param HE.text) (decodeColumns tabs) True + H.Statement sql (param HE.text) (decodeColumns tabs) True where sql = [q| SELECT DISTINCT @@ -542,7 +573,7 @@ allChildRelations :: [Table] -> [Column] -> H.Statement () [Relation] allChildRelations tabs cols = - H.Statement sql HE.unit (decodeRelations tabs cols) True + H.Statement sql HE.noParams (decodeRelations tabs cols) True where sql = [q| SELECT ns1.nspname AS table_schema, @@ -583,7 +614,7 @@ allPrimaryKeys :: [Table] -> H.Statement () [PrimaryKey] allPrimaryKeys tabs = - H.Statement sql HE.unit (decodePks tabs) True + H.Statement sql HE.noParams (decodePks tabs) True where sql = [q| /* @@ -693,12 +724,15 @@ allSynonyms :: [Column] -> PgVersion -> H.Statement Schema [Synonym] allSynonyms cols pgVer = - H.Statement sql (HE.param HE.text) (decodeSynonyms cols) True + H.Statement sql (param HE.text) (decodeSynonyms cols) True -- query explanation at https://gist.github.com/steve-chavez/7ee0e6590cddafb532e5f00c46275569 where subselectRegex :: Text - subselectRegex | pgVer < pgVersion100 = ":subselect {.*?:constraintDeps <>} :location" - | otherwise = ":subselect {.*?:stmt_len 0} :location" + -- "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 views as ( @@ -709,7 +743,7 @@ 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 = 'v'::char) and n.nspname = $1 + where (c.relkind in ('v', 'm')) and n.nspname = $1 ), removed_subselects as( select @@ -765,7 +799,7 @@ findCol s t c = find (\col -> (tableSchema . colTable) col == s && (tableName . colTable) col == t && colName col == c) allCols getPgVersion :: H.Session PgVersion -getPgVersion = H.statement () $ H.Statement sql HE.unit versionRow False +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 <$> HD.column HD.int4 <*> HD.column HD.text + versionRow = HD.singleRow $ PgVersion <$> column HD.int4 <*> column HD.text diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -1,98 +1,71 @@ +{-| +Module : PostgREST.Error +Description : PostgREST error HTTP responses +-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module PostgREST.Error ( - apiRequestError -, pgError -, simpleError + errorResponseFor +, ApiRequestError(..) +, PgError(..) +, SimpleError(..) +, errorPayload +, checkIsFatal , singularityError -, binaryFieldError -, connectionLostError -, encodeError -, gucHeadersError ) where -import Protolude -import Data.Aeson ((.=)) import qualified Data.Aeson as JSON -import Data.Text (unwords) import qualified Hasql.Pool as P import qualified Hasql.Session as H -import Network.HTTP.Types.Header import qualified Network.HTTP.Types.Status as HT -import Network.Wai (Response, responseLBS) -import PostgREST.Types -import Text.Read (readMaybe) -apiRequestError :: ApiRequestError -> Response -apiRequestError err = - errorResponse status - [toHeader CTApplicationJSON] err - where - status = - case err of - ActionInappropriate -> HT.status405 - UnsupportedVerb -> HT.status405 - InvalidBody _ -> HT.status400 - ParseRequestError _ _ -> HT.status400 - NoRelationBetween _ _ -> HT.status400 - InvalidRange -> HT.status416 - UnknownRelation -> HT.status404 - InvalidFilters -> HT.status405 +import Data.Aeson ((.=)) +import Data.Text (unwords) +import Network.Wai (Response, responseLBS) +import Text.Read (readMaybe) -simpleError :: HT.Status -> [Header] -> Text -> Response -simpleError status hdrs message = - errorResponse status (toHeader CTApplicationJSON : hdrs) $ - JSON.object ["message" .= message] +import Network.HTTP.Types.Header -errorResponse :: JSON.ToJSON a => HT.Status -> [Header] -> a -> Response -errorResponse status hdrs e = - responseLBS status hdrs $ encodeError e +import PostgREST.Types +import Protolude -pgError :: Bool -> P.UsageError -> Response -pgError authed e = - let status = httpStatus authed e - jsonType = toHeader CTApplicationJSON - wwwAuth = ("WWW-Authenticate", "Bearer") - hdrs = if status == HT.status401 - then [jsonType, wwwAuth] - else [jsonType] in - responseLBS status hdrs (encodeError e) -singularityError :: Integer -> Response -singularityError numRows = - responseLBS HT.status406 - [toHeader CTSingularJSON] - $ toS . formatGeneralError - "JSON object requested, multiple (or no) rows returned" - $ unwords - [ "Results contain", show numRows, "rows," - , toS (toMime CTSingularJSON), "requires 1 row" - ] - where - formatGeneralError :: Text -> Text -> Text - formatGeneralError message details = toS . JSON.encode $ - JSON.object ["message" .= message, "details" .= details] +class (JSON.ToJSON a) => PgrstError a where + status :: a -> HT.Status + headers :: a -> [Header] + errorPayload :: a -> LByteString + errorPayload = JSON.encode -binaryFieldError :: Response -binaryFieldError = - simpleError HT.status406 [] (toS (toMime CTOctetStream) <> - " requested but a single column was not selected") + errorResponseFor :: a -> Response + errorResponseFor err = responseLBS (status err) (headers err) $ errorPayload err -gucHeadersError :: Response -gucHeadersError = - simpleError HT.status500 [] - "response.headers guc must be a JSON array composed of objects with a single key and a string value" -connectionLostError :: Response -connectionLostError = - simpleError HT.status503 [] "Database connection lost, retrying the connection." -encodeError :: JSON.ToJSON a => a -> LByteString -encodeError = JSON.encode +data ApiRequestError + = ActionInappropriate + | InvalidRange + | InvalidBody ByteString + | ParseRequestError Text Text + | NoRelationBetween Text Text + | InvalidFilters + | UnknownRelation -- Unreachable? + | 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 (NoRelationBetween _ _) = HT.status400 + + headers _ = [toHeader CTApplicationJSON] + instance JSON.ToJSON ApiRequestError where toJSON (ParseRequestError message details) = JSON.object [ "message" .= message, "details" .= details] @@ -111,9 +84,24 @@ toJSON InvalidFilters = JSON.object [ "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)] + +data PgError = PgError Authenticated P.UsageError +type Authenticated = Bool + +instance PgrstError PgError where + status (PgError authed usageError) = pgErrorStatus authed usageError + + headers err = + if status err == HT.status401 + then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header] + else [toHeader CTApplicationJSON] + +instance JSON.ToJSON PgError where + toJSON (PgError _ usageError) = JSON.toJSON usageError + instance JSON.ToJSON P.UsageError where toJSON (P.ConnectionError e) = JSON.object [ - "code" .= ("" :: Text), + "code" .= ("" :: Text), "message" .= ("Database connection error" :: Text), "details" .= (toS $ fromMaybe "" e :: Text)] toJSON (P.SessionError e) = JSON.toJSON e -- H.Error @@ -123,69 +111,146 @@ instance JSON.ToJSON H.CommandError where toJSON (H.ResultError (H.ServerError c m d h)) = case toS c of - 'P':'T':_ -> - JSON.object [ - "details" .= (fmap toS d::Maybe Text), - "hint" .= (fmap toS h::Maybe Text)] - _ -> - JSON.object [ - "code" .= (toS c::Text), - "message" .= (toS m::Text), - "details" .= (fmap toS d::Maybe Text), - "hint" .= (fmap toS h::Maybe Text)] + 'P':'T':_ -> JSON.object [ + "details" .= (fmap toS d :: Maybe Text), + "hint" .= (fmap toS h :: Maybe Text)] + + _ -> JSON.object [ + "code" .= (toS c :: Text), + "message" .= (toS m :: Text), + "details" .= (fmap toS d :: Maybe Text), + "hint" .= (fmap toS h :: Maybe Text)] + toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [ - "message" .= (m::Text)] + "message" .= (m :: Text)] toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [ - "message" .= ("Row error: end of input"::Text), - "details" .= - ("Attempt to parse more columns than there are in the result"::Text), - "details" .= (("Row number " <> show i)::Text)] + "message" .= ("Row error: end of input" :: Text), + "details" .= ("Attempt to parse more columns than there are in the result" :: Text), + "hint" .= (("Row number " <> show i) :: Text)] toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [ - "message" .= ("Row error: unexpected null"::Text), - "details" .= ("Attempt to parse a NULL as some value."::Text), - "details" .= (("Row number " <> show i)::Text)] + "message" .= ("Row error: unexpected null" :: Text), + "details" .= ("Attempt to parse a NULL as some value." :: Text), + "hint" .= (("Row number " <> show i) :: Text)] toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [ - "message" .= ("Row error: Wrong value parser used"::Text), + "message" .= ("Row error: Wrong value parser used" :: Text), "details" .= d, - "details" .= (("Row number " <> show i)::Text)] + "hint" .= (("Row number " <> show i) :: Text)] toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [ - "message" .= ("Unexpected amount of rows"::Text), + "message" .= ("Unexpected amount of rows" :: Text), "details" .= i] toJSON (H.ClientError d) = JSON.object [ - "message" .= ("Database client error"::Text), - "details" .= (fmap toS d::Maybe Text)] + "message" .= ("Database client error" :: Text), + "details" .= (fmap toS d :: Maybe Text)] -httpStatus :: Bool -> P.UsageError -> HT.Status -httpStatus _ (P.ConnectionError _) = HT.status503 -httpStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError (H.ServerError c m _ _)))) = - case toS c of - '0':'8':_ -> HT.status503 -- pg connection err - '0':'9':_ -> HT.status500 -- triggered action exception - '0':'L':_ -> HT.status403 -- invalid grantor - '0':'P':_ -> HT.status403 -- invalid role specification - "23503" -> HT.status409 -- foreign_key_violation - "23505" -> HT.status409 -- unique_violation - '2':'5':_ -> HT.status500 -- invalid tx state - '2':'8':_ -> HT.status403 -- invalid auth specification - '2':'D':_ -> HT.status500 -- invalid tx termination - '3':'8':_ -> HT.status500 -- external routine exception - '3':'9':_ -> HT.status500 -- external routine invocation - '3':'B':_ -> HT.status500 -- savepoint exception - '4':'0':_ -> HT.status500 -- tx rollback - '5':'3':_ -> HT.status503 -- insufficient resources - '5':'4':_ -> HT.status413 -- too complex - '5':'5':_ -> HT.status500 -- obj not on prereq state - '5':'7':_ -> HT.status500 -- operator intervention - '5':'8':_ -> HT.status500 -- system error - 'F':'0':_ -> HT.status500 -- conf file error - 'H':'V':_ -> HT.status500 -- foreign data wrapper error - "P0001" -> HT.status400 -- default code for "raise" - 'P':'0':_ -> HT.status500 -- PL/pgSQL Error - 'X':'X':_ -> HT.status500 -- internal Error - "42883" -> HT.status404 -- undefined function - "42P01" -> HT.status404 -- undefined table - "42501" -> if authed then HT.status403 else HT.status401 -- insufficient privilege - 'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m) - _ -> HT.status400 -httpStatus _ (P.SessionError (H.QueryError _ _ (H.ResultError _))) = HT.status500 -httpStatus _ (P.SessionError (H.QueryError _ _ (H.ClientError _))) = HT.status503 +pgErrorStatus :: Bool -> P.UsageError -> HT.Status +pgErrorStatus _ (P.ConnectionError _) = HT.status503 +pgErrorStatus _ (P.SessionError (H.QueryError _ _ (H.ClientError _))) = HT.status503 +pgErrorStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError rError))) = + case rError of + (H.ServerError c m _ _) -> + case toS c of + '0':'8':_ -> HT.status503 -- pg connection err + '0':'9':_ -> HT.status500 -- triggered action exception + '0':'L':_ -> HT.status403 -- invalid grantor + '0':'P':_ -> HT.status403 -- invalid role specification + "23503" -> HT.status409 -- foreign_key_violation + "23505" -> HT.status409 -- unique_violation + '2':'5':_ -> HT.status500 -- invalid tx state + '2':'8':_ -> HT.status403 -- invalid auth specification + '2':'D':_ -> HT.status500 -- invalid tx termination + '3':'8':_ -> HT.status500 -- external routine exception + '3':'9':_ -> HT.status500 -- external routine invocation + '3':'B':_ -> HT.status500 -- savepoint exception + '4':'0':_ -> HT.status500 -- tx rollback + '5':'3':_ -> HT.status503 -- insufficient resources + '5':'4':_ -> HT.status413 -- too complex + '5':'5':_ -> HT.status500 -- obj not on prereq state + '5':'7':_ -> HT.status500 -- operator intervention + '5':'8':_ -> HT.status500 -- system error + 'F':'0':_ -> HT.status500 -- conf file error + 'H':'V':_ -> HT.status500 -- foreign data wrapper error + "P0001" -> HT.status400 -- default code for "raise" + 'P':'0':_ -> HT.status500 -- PL/pgSQL Error + 'X':'X':_ -> HT.status500 -- internal Error + "42883" -> HT.status404 -- undefined function + "42P01" -> HT.status404 -- undefined table + "42501" -> if authed then HT.status403 else HT.status401 -- insufficient privilege + 'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m) + _ -> HT.status400 + + _ -> HT.status500 + +checkIsFatal :: PgError -> Maybe Text +checkIsFatal (PgError _ (P.ConnectionError e)) + | isAuthFailureMessage = Just $ toS failureMessage + | otherwise = Nothing + where isAuthFailureMessage = "FATAL: password authentication failed" `isPrefixOf` toS failureMessage + failureMessage = fromMaybe "" e +checkIsFatal _ = Nothing + + +data SimpleError + = GucHeadersError + | BinaryFieldError ContentType + | ConnectionLostError + | PutSingletonError + | PutMatchingPkError + | PutRangeNotAllowedError + | PutPayloadIncompleteError + | JwtTokenMissing + | JwtTokenInvalid Text + | SingularityError Integer + | ContentTypeError [ByteString] + deriving (Show, Eq) + +instance PgrstError SimpleError where + status GucHeadersError = HT.status500 + status (BinaryFieldError _) = HT.status406 + status ConnectionLostError = HT.status503 + status PutSingletonError = HT.status400 + status PutMatchingPkError = HT.status400 + status PutRangeNotAllowedError = HT.status400 + status PutPayloadIncompleteError = HT.status400 + status JwtTokenMissing = HT.status500 + status (JwtTokenInvalid _) = HT.unauthorized401 + status (SingularityError _) = HT.status406 + status (ContentTypeError _) = HT.status415 + + headers (SingularityError _) = [toHeader CTSingularJSON] + headers (JwtTokenInvalid m) = [toHeader CTApplicationJSON, invalidTokenHeader m] + headers _ = [toHeader CTApplicationJSON] + +instance JSON.ToJSON SimpleError 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 (BinaryFieldError ct) = JSON.object [ + "message" .= ((toS (toMime ct) <> " requested but a single column was not selected") :: Text)] + toJSON ConnectionLostError = JSON.object [ + "message" .= ("Database connection lost, retrying the connection." :: Text)] + + toJSON PutSingletonError = JSON.object [ + "message" .= ("PUT payload must contain a single row" :: Text)] + toJSON PutRangeNotAllowedError = JSON.object [ + "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)] + toJSON PutPayloadIncompleteError = JSON.object [ + "message" .= ("You must specify all columns in the payload when using 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" .= unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]] + + toJSON JwtTokenMissing = JSON.object [ + "message" .= ("Server lacks JWT secret" :: Text)] + toJSON (JwtTokenInvalid message) = JSON.object [ + "message" .= (message :: Text)] + +invalidTokenHeader :: Text -> Header +invalidTokenHeader m = + ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> show m) + +singularityError :: (Integral a) => a -> SimpleError +singularityError = SingularityError . toInteger diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -1,37 +1,42 @@ +{-| +Module : PostgREST.Middleware +Description : Sets the PostgreSQL GUCs, role, search_path and pre-request function. Validates JWT. +-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} module PostgREST.Middleware where -import Crypto.JWT -import qualified Data.Aeson as JSON -import qualified Data.HashMap.Strict as M -import qualified Hasql.Transaction as H +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as M +import qualified Hasql.Transaction as H -import Network.HTTP.Types.Status (unauthorized401, status500) -import Network.Wai (Application, Response) -import Network.Wai.Middleware.Cors (cors) -import Network.Wai.Middleware.Gzip (def, gzip) -import Network.Wai.Middleware.Static (only, staticPolicy) +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.ApiRequest (ApiRequest(..)) -import PostgREST.Auth (JWTAttempt(..)) -import PostgREST.Config (AppConfig (..), corsPolicy) -import PostgREST.Error (simpleError) -import PostgREST.QueryBuilder (unquoted, pgFmtSetLocal, pgFmtSetLocalSearchPath) +import Crypto.JWT -import Protolude +import PostgREST.ApiRequest (ApiRequest (..)) +import PostgREST.Auth (JWTAttempt (..)) +import PostgREST.Config (AppConfig (..), corsPolicy) +import PostgREST.Error (SimpleError (JwtTokenInvalid, JwtTokenMissing), + errorResponseFor) +import PostgREST.QueryBuilder (pgFmtSetLocal, pgFmtSetLocalSearchPath, + unquoted) +import Protolude runWithClaims :: AppConfig -> JWTAttempt -> (ApiRequest -> H.Transaction Response) -> ApiRequest -> H.Transaction Response runWithClaims conf eClaims app req = case eClaims of - JWTInvalid JWTExpired -> return $ unauthed "JWT expired" - JWTInvalid e -> return $ unauthed $ show e - JWTMissingSecret -> return $ simpleError status500 [] "Server lacks JWT secret" - JWTClaims claims -> do + 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 ++ headersSql ++ cookiesSql ++ appSettingsSql mapM_ H.sql customReqCheck app req @@ -47,14 +52,6 @@ claimsWithRole = M.union claims (M.singleton "role" anon) anon = JSON.String . toS $ configAnonRole conf customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf - where - unauthed message = simpleError - unauthorized401 - [( "WWW-Authenticate" - , "Bearer error=\"invalid_token\", " <> - "error_description=" <> show message - )] - message defaultMiddle :: Application -> Application defaultMiddle = diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -1,40 +1,54 @@ +{-| +Module : PostgREST.OpenAPI +Description : Generates the OpenAPI output +-} {-# LANGUAGE OverloadedStrings #-} module PostgREST.OpenAPI ( encodeOpenAPI - , isMalformedProxyUri - , pickProxy - ) where +, isMalformedProxyUri +, pickProxy +) where -import Control.Arrow ((&&&)) -import Control.Lens -import Data.Aeson (decode, encode) -import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList) -import Data.Maybe (fromJust) -import qualified Data.Set as Set -import Data.String (IsString (..)) -import Data.Text (unpack, pack, init, tail, toLower, intercalate, append, dropWhile, breakOn) -import Network.URI (parseURI, isAbsoluteURI, - URI (..), URIAuth (..)) +import qualified Data.Set as Set -import Protolude hiding ((&), Proxy, get, intercalate, dropWhile) +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 Data.Swagger +import Control.Lens +import Data.Swagger -import PostgREST.ApiRequest (ContentType(..)) -import PostgREST.Config (prettyVersion, docsVersion) -import PostgREST.Types (Table(..), Column(..), PgArg(..), ForeignKey(..), - PrimaryKey(..), Proxy(..), ProcDescription(..), toMime) +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, (&)) makeMimeList :: [ContentType] -> MimeList makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs toSwaggerType :: Text -> SwaggerType t -toSwaggerType "text" = SwaggerString -toSwaggerType "integer" = SwaggerInteger -toSwaggerType "boolean" = SwaggerBoolean -toSwaggerType "numeric" = SwaggerNumber -toSwaggerType _ = SwaggerString +toSwaggerType "character varying" = SwaggerString +toSwaggerType "character" = SwaggerString +toSwaggerType "text" = SwaggerString +toSwaggerType "boolean" = SwaggerBoolean +toSwaggerType "smallint" = SwaggerInteger +toSwaggerType "integer" = SwaggerInteger +toSwaggerType "bigint" = SwaggerInteger +toSwaggerType "numeric" = SwaggerNumber +toSwaggerType "real" = SwaggerNumber +toSwaggerType "double precision" = SwaggerNumber +toSwaggerType _ = SwaggerString makeTableDef :: [PrimaryKey] -> (Table, [Column], [Text]) -> (Text, Schema) makeTableDef pks (t, cs, _) = @@ -319,7 +333,7 @@ uri = toURI $ fromJust proxy scheme = init $ toLower $ pack $ uriScheme uri path URI {uriPath = ""} = "/" - path URI {uriPath = p} = p + path URI {uriPath = p} = p path' = pack $ path uri authority = fromJust $ uriAuthority uri host' = pack $ uriRegName authority @@ -327,15 +341,15 @@ readPort = fromMaybe 80 . readMaybe port'' :: Integer port'' = case (port', scheme) of - ("", "http") -> 80 + ("", "http") -> 80 ("", "https") -> 443 - _ -> readPort $ unpack $ tail $ pack port' + _ -> readPort $ unpack $ tail $ pack port' isUriValid:: URI -> Bool isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid] fAnd :: [a -> Bool] -> a -> Bool -fAnd fs x = all ($x) fs +fAnd fs x = all ($ x) fs isSchemeValid :: URI -> Bool isSchemeValid URI {uriScheme = s} @@ -345,7 +359,7 @@ isQueryValid :: URI -> Bool isQueryValid URI {uriQuery = ""} = True -isQueryValid _ = False +isQueryValid _ = False isAuthorityValid :: URI -> Bool isAuthorityValid URI {uriAuthority = a} @@ -354,16 +368,16 @@ isUserInfoValid :: URIAuth -> Bool isUserInfoValid URIAuth {uriUserInfo = ""} = True -isUserInfoValid _ = False +isUserInfoValid _ = False isHostValid :: URIAuth -> Bool isHostValid URIAuth {uriRegName = ""} = False -isHostValid _ = True +isHostValid _ = True isPortValid :: URIAuth -> Bool isPortValid URIAuth {uriPort = ""} = True isPortValid URIAuth {uriPort = (':':p)} = case readMaybe p of - Just i -> i > (0 :: Integer) && i < 65536 + Just i -> i > (0 :: Integer) && i < 65536 Nothing -> False isPortValid _ = False diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -1,20 +1,31 @@ +{-| +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 Protolude hiding (try, intercalate, replace, option) -import Control.Monad ((>>)) -import Data.Foldable (foldl1) -import Data.Functor (($>)) -import qualified Data.HashMap.Strict as M -import Data.Text (intercalate, replace, strip) -import Data.List (init, last) -import Data.Tree -import Data.Either.Combinators (mapLeft) -import PostgREST.RangeQuery (NonnegRange) -import PostgREST.Types -import Text.ParserCombinators.Parsec hiding (many, (<|>)) -import Text.Parsec.Error -import Text.Read (read) +import qualified Data.HashMap.Strict as M +import qualified Data.Set as S +import Control.Monad ((>>)) +import Data.Either.Combinators (mapLeft) +import Data.Foldable (foldl1) +import Data.Functor (($>)) +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, try) + pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem] pRequestSelect selStr = mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) @@ -45,10 +56,19 @@ where path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k embedPath = fst <$> path - op = snd <$> path - -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" - logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v) + 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") @@ -110,7 +130,10 @@ pRelationSelect = lexeme $ try ( do alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) fld <- pField - relationDetail <- optionMaybe ( try( char '.' *> pFieldName ) ) + relationDetail <- optionMaybe ( + try ( char '+' *> pFieldName ) <|> + try ( char '.' *> pFieldName ) -- TODO deprecated, remove in next major version + ) return (fld, Nothing, alias, relationDetail) ) @@ -210,6 +233,9 @@ 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 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| @@ -27,30 +27,42 @@ , pgFmtSetLocalSearchPath ) where -import qualified Hasql.Statement as H -import qualified Hasql.Encoders as HE -import qualified Hasql.Decoders as HD +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import qualified Data.HashMap.Strict as HM +import qualified Data.Set as S +import qualified Data.Text as T (map, null, takeWhile) +import qualified Data.Text.Encoding as T +import qualified Hasql.Decoders as HD +import qualified Hasql.Encoders as HE +import qualified Hasql.Statement as H -import qualified Data.Aeson as JSON +import Data.Scientific (FPFormat (..), formatScientific, + isInteger) +import Data.Text (intercalate, isInfixOf, replace, + toLower, unwords) +import Data.Tree (Tree (..)) +import Text.InterpolatedString.Perl6 (qc) -import PostgREST.RangeQuery (rangeLimit, rangeOffset, allRange) -import qualified Data.HashMap.Strict as HM -import Data.Maybe -import qualified Data.Set as S -import Data.Text (intercalate, unwords, replace, isInfixOf, toLower) -import qualified Data.Text as T (map, takeWhile, null) -import qualified Data.Text.Encoding as T -import Data.Tree (Tree(..)) -import PostgREST.Types -import Text.InterpolatedString.Perl6 (qc) -import qualified Data.ByteString.Char8 as BS -import Data.Scientific ( FPFormat (..) - , formatScientific - , isInteger - ) -import Protolude hiding ( intercalate, cast, replace) -import PostgREST.ApiRequest (PreferRepresentation (..)) +import Data.Maybe +import PostgREST.ApiRequest (PreferRepresentation (..)) +import PostgREST.RangeQuery (allRange, rangeLimit, rangeOffset) +import PostgREST.Types +import Protolude hiding (cast, intercalate, replace) + +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 + {-| 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. @@ -58,10 +70,10 @@ type ResultsWithCount = (Maybe Int64, Int64, [BS.ByteString], BS.ByteString) standardRow :: HD.Row ResultsWithCount -standardRow = (,,,) <$> HD.nullableColumn HD.int8 <*> HD.column HD.int8 - <*> HD.column header <*> HD.column HD.bytea +standardRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8 + <*> column header <*> column HD.bytea where - header = HD.array $ HD.dimension replicateM $ HD.element HD.bytea + header = HD.array $ HD.dimension replicateM $ element HD.bytea noLocationF :: Text noLocationF = "array[]::text[]" @@ -81,7 +93,7 @@ createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> Maybe FieldName -> H.Statement () ResultsWithCount createReadStatement selectQuery countQuery isSingle countTotal asCsv binaryField = - unicodeStatement sql HE.unit decodeStandard False + unicodeStatement sql HE.noParams decodeStandard False where sql = [qc| WITH {sourceCTEName} AS ({selectQuery}) SELECT {cols} @@ -103,8 +115,8 @@ createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> PreferRepresentation -> [Text] -> H.Statement ByteString (Maybe ResultsWithCount) -createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys = - unicodeStatement sql (HE.param HE.unknown) decodeStandardMay True +createWriteStatement selectQuery mutateQuery wantSingle isInsert asCsv rep pKeys = + unicodeStatement sql (param HE.unknown) decodeStandardMay True where sql = case rep of @@ -123,9 +135,14 @@ cols = intercalate ", " [ "'' AS total_result_set", -- when updateing it does not make sense "pg_catalog.count(_postgrest_t) AS page_total", - if wantHdrs - then "coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")" - else noLocationF <> " AS header", + if isInsert + then unwords [ + "CASE", + "WHEN pg_catalog.count(_postgrest_t) = 1 THEN", + "coalesce(" <> locationF pKeys <> ", " <> noLocationF <> ")", + "ELSE " <> noLocationF, + "END AS header"] + else noLocationF <> "AS header", if rep == Full then bodyF <> " AS body" else "''" @@ -138,62 +155,75 @@ type ProcResults = (Maybe Int64, Int64, ByteString, ByteString) callProc :: QualifiedIdentifier -> [PgArg] -> Bool -> SqlQuery -> SqlQuery -> Bool -> - Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool -> PgVersion -> + Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> PgVersion -> H.Statement ByteString (Maybe ProcResults) -callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField isObject pgVer = - unicodeStatement sql (HE.param HE.unknown) decodeProc True +callProc qi pgArgs returnsScalar selectQuery countQuery countTotal isSingle paramsAsSingleObject asCsv asBinary binaryField pgVer = + unicodeStatement sql (param HE.unknown) decodeProc True where - sql = - if returnsScalar then [qc| - WITH {argsRecord}, - {sourceCTEName} AS ( - SELECT {fromQi qi}({args}) - ) - SELECT - {countResultF} AS total_result_set, - 1 AS page_total, - {scalarBodyF} AS body, - {responseHeaders} AS response_headers - FROM ({selectQuery}) _postgrest_t;|] - else [qc| - WITH {argsRecord}, - {sourceCTEName} AS ( - SELECT * FROM {fromQi qi}({args}) - ) - SELECT - {countResultF} AS total_result_set, - pg_catalog.count(_postgrest_t) AS page_total, - {bodyF} AS body, - {responseHeaders} AS response_headers - FROM ({selectQuery}) _postgrest_t;|] + sql =[qc| + WITH + {argsRecord}, + {sourceCTEName} AS ( + {sourceBody} + ) + SELECT + {countResultF} AS total_result_set, + pg_catalog.count(_postgrest_t) AS page_total, + {bodyF} AS body, + {responseHeaders} AS response_headers + FROM ({selectQuery}) _postgrest_t;|] - (argsRecord, args) | paramsAsSingleObject = ("_args_record AS (SELECT NULL)", "$1::json") - | null pgArgs = (ignoredBody, "") - | otherwise = ( - unwords [ - "_args_record AS (", - "SELECT * FROM " <> (if isObject then "json_to_record" else "json_to_recordset") <> "($1)", - "AS _(" <> intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " " <> pgaType a) <$> pgArgs) <> ")", - ")"] - , intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " := (SELECT " <> pgFmtIdent (pgaName a) <> " FROM _args_record)") <$> pgArgs)) + (argsRecord, args) + | paramsAsSingleObject = ("_args_record AS (SELECT NULL)", "$1::json") + | null pgArgs = (ignoredBody, "") + | otherwise = ( + unwords [ + normalizedBody <> ",", + "_args_record AS (", + "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> + intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " " <> pgaType a) <$> pgArgs) <> ")", + ")"] + , intercalate ", " ((\a -> pgFmtIdent (pgaName a) <> " := _args_record." <> pgFmtIdent (pgaName a)) <$> pgArgs)) + + sourceBody :: SqlFragment + sourceBody + | paramsAsSingleObject || null pgArgs = + if returnsScalar + then [qc| SELECT {fromQi qi}({args}) |] + else [qc| SELECT * FROM {fromQi qi}({args}) |] + | otherwise = + if returnsScalar + then [qc| SELECT {fromQi qi}({args}) FROM _args_record |] + else [qc| SELECT _.* + FROM _args_record, + LATERAL ( SELECT * FROM {fromQi qi}({args}) ) _ |] + + bodyF + | returnsScalar = scalarBodyF + | isSingle = asJsonSingleF + | asCsv = asCsvF + | isJust binaryField = asBinaryF $ fromJust binaryField + | otherwise = asJsonF + + scalarBodyF + | asBinary = asBinaryF _procName + | otherwise = unwords [ + "CASE", + "WHEN pg_catalog.count(_postgrest_t) = 1", + "THEN (json_agg(_postgrest_t." <> pgFmtIdent _procName <> ")->0)::character varying", + "ELSE (json_agg(_postgrest_t." <> pgFmtIdent _procName <> "))::character varying", + "END"] + countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text _procName = qiName qi responseHeaders = if pgVer >= pgVersion96 then "coalesce(nullif(current_setting('response.headers', true), ''), '[]')" :: Text -- nullif is used because of https://gist.github.com/steve-chavez/8d7033ea5655096903f3b52f8ed09a15 else "'[]'" :: Text - decodeProc = HD.rowMaybe procRow - procRow = (,,,) <$> HD.nullableColumn HD.int8 <*> HD.column HD.int8 - <*> HD.column HD.bytea <*> HD.column HD.bytea - scalarBodyF - | asBinary = asBinaryF _procName - | otherwise = "(row_to_json(_postgrest_t)->" <> pgFmtLit _procName <> ")::character varying" - bodyF - | isSingle = asJsonSingleF - | asCsv = asCsvF - | isJust binaryField = asBinaryF $ fromJust binaryField - | otherwise = asJsonF + decodeProc = HD.rowMaybe procRow + procRow = (,,,) <$> nullableColumn HD.int8 <*> column HD.int8 + <*> column HD.bytea <*> column HD.bytea pgFmtIdent :: SqlFragment -> SqlFragment pgFmtIdent x = "\"" <> replace "\"" "\"\"" (trimNullChars $ toS x) <> "\"" @@ -219,32 +249,21 @@ qi = removeSourceCTESchema schema mainTbl requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery -requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest joinConditions_ ordts range, (nodeName, maybeRelation, _, _, depth)) forest)) = +requestToQuery schema isParent (DbRead (Node (Select colSelects tbl tblAlias implJoins logicForest joinConditions_ ordts range, _) forest)) = unwords [ "SELECT " <> intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects), - "FROM " <> intercalate ", " tables, + "FROM " <> intercalate ", " (tabl : implJs), unwords joins, - ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest ++ map pgFmtJoinCondition joinConds)) - `emptyOnFalse` (null logicForest && null joinConds), + ("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` (isParent || range == allRange) ] where - mainTbl = maybe nodeName (tableName . relTable) maybeRelation - isSelfJoin = maybe False (\r -> relType r /= Root && relTable r == relFTable r) maybeRelation - (qi, tables, joinConds) = - let depthAlias name dpth = if dpth /= 0 then name <> "_" <> show dpth else name in -- Root node doesn't get aliased - if isSelfJoin - then ( - QualifiedIdentifier "" (depthAlias mainTbl depth), - (\t -> fromQi (removeSourceCTESchema schema t) <> " AS " <> pgFmtIdent (depthAlias t depth)) <$> tbls, - (\(JoinCondition (qi1, _, c1) (qi2, _, c2)) -> - JoinCondition (qi1, Just $ depthAlias (qiName qi1) depth, c1) - (qi2, Just $ depthAlias (qiName qi2) (depth - 1), c2)) <$> joinConditions_) - else ( - removeSourceCTESchema schema mainTbl, - fromQi . removeSourceCTESchema schema <$> tbls, - joinConditions_) + implJs = fromQi . QualifiedIdentifier schema <$> implJoins + mainQi = removeSourceCTESchema schema tbl + tabl = fromQi mainQi <> maybe mempty (\a -> " AS " <> pgFmtIdent a) tblAlias + qi = maybe mainQi (QualifiedIdentifier mempty) tblAlias (joins, selects) = foldr getQueryParts ([],[]) forest @@ -274,48 +293,42 @@ --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts _ _ = witness -requestToQuery schema _ (DbMutate (Insert mainTbl pkCols p@(PayloadJSON _ pType pKeys) onConflct logicForest returnings)) = +requestToQuery schema _ (DbMutate (Insert mainTbl iCols onConflct putConditions returnings)) = unwords [ - ("WITH " <> ignoredBody) `emptyOnFalse` not payloadIsEmpty, - "INSERT INTO ", fromQi qi, if payloadIsEmpty then " " else "(" <> cols <> ")", - case (pType, payloadIsEmpty) of - (PJArray _, True) -> "SELECT null WHERE false" - (PJObject, True) -> "DEFAULT VALUES" - _ -> unwords [ - "SELECT " <> cols <> " FROM", - case pType of - PJObject -> "json_populate_record" - PJArray _ -> "json_populate_recordset", "(null::", fromQi qi, ", $1) _", - -- Only used for PUT - ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier "" "_") <$> logicForest)) `emptyOnFalse` null logicForest], - maybe "" (\x -> ( - "ON CONFLICT(" <> intercalate ", " (pgFmtIdent <$> pkCols) <> ") " <> case x of + "WITH " <> normalizedBody, + "INSERT INTO ", fromQi qi, if S.null iCols then " " else "(" <> cols <> ")", + unwords [ + "SELECT " <> cols <> " FROM", + "json_populate_recordset", "(null::", fromQi qi, ", " <> selectBody <> ") _", + -- Only used for PUT + ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier "" "_") <$> putConditions)) `emptyOnFalse` null putConditions], + maybe "" (\(oncDo, oncCols) -> ( + "ON CONFLICT(" <> intercalate ", " (pgFmtIdent <$> oncCols) <> ") " <> case oncDo of IgnoreDuplicates -> "DO NOTHING" MergeDuplicates -> - "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList pKeys) - ) `emptyOnFalse` null pkCols) onConflct, + if S.null iCols + then "DO NOTHING" + else "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList iCols) + ) `emptyOnFalse` null oncCols) onConflct, ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings] where qi = QualifiedIdentifier schema mainTbl - cols = intercalate ", " $ pgFmtIdent <$> S.toList pKeys - payloadIsEmpty = pjIsEmpty p -requestToQuery schema _ (DbMutate (Update mainTbl p@(PayloadJSON _ pType keys) logicForest returnings)) = - if pjIsEmpty p - then "WITH " <> ignoredBody <> "SELECT ''" + cols = intercalate ", " $ pgFmtIdent <$> S.toList iCols +requestToQuery schema _ (DbMutate (Update mainTbl uCols logicForest returnings)) = + if S.null uCols + then "WITH " <> ignoredBody <> "SELECT null WHERE false" -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax else unwords [ + "WITH " <> normalizedBody, "UPDATE " <> fromQi qi <> " SET " <> cols, - "FROM (SELECT * FROM ", - case pType of - PJObject -> " json_populate_record" - PJArray _ -> " json_populate_recordset", "(null::", fromQi qi, ", $1)) _ ", - ("WHERE " <> intercalate " AND " (map (pgFmtLogicTree qi) logicForest)) `emptyOnFalse` null logicForest, - ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings + "FROM (SELECT * FROM json_populate_recordset", "(null::", fromQi qi, ", " <> selectBody <> ")) _ ", + ("WHERE " <> intercalate " AND " (pgFmtLogicTree qi <$> logicForest)) `emptyOnFalse` null logicForest, + ("RETURNING " <> intercalate ", " (pgFmtColumn qi <$> returnings)) `emptyOnFalse` null returnings ] where qi = QualifiedIdentifier schema mainTbl - cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList keys) + cols = intercalate ", " (pgFmtIdent <> const " = _." <> pgFmtIdent <$> S.toList uCols) requestToQuery schema _ (DbMutate (Delete mainTbl logicForest returnings)) = unwords [ "WITH " <> ignoredBody, @@ -333,6 +346,25 @@ ignoredBody :: SqlFragment ignoredBody = "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)" + removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == sourceCTEName then "" else schema) tbl @@ -389,7 +421,7 @@ pgFmtColumn :: QualifiedIdentifier -> Text -> SqlFragment pgFmtColumn table "*" = fromQi table <> ".*" -pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c +pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c pgFmtField :: QualifiedIdentifier -> Field -> SqlFragment pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp @@ -407,10 +439,10 @@ 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 + "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('{}')" @@ -437,11 +469,9 @@ (find ((==) . toLower $ v) ["null","true","false"]) pgFmtJoinCondition :: JoinCondition -> SqlFragment -pgFmtJoinCondition (JoinCondition (qi, al1, col1) (QualifiedIdentifier schema fTable, al2, col2)) = - pgFmtColumn (fromMaybe qi $ aliasToQi al1) col1 <> " = " <> - pgFmtColumn (fromMaybe (removeSourceCTESchema schema fTable) $ aliasToQi al2) col2 - where - aliasToQi al = QualifiedIdentifier "" <$> al +pgFmtJoinCondition (JoinCondition (qi, col1) (QualifiedIdentifier schema fTable, col2)) = + pgFmtColumn qi col1 <> " = " <> + pgFmtColumn (removeSourceCTESchema schema fTable) col2 pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment pgFmtLogicTree qi (Expr hasNot op forest) = notOp <> " (" <> intercalate (" " <> show op <> " ") (pgFmtLogicTree qi <$> forest) <> ")" diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -1,3 +1,7 @@ +{-| +Module : PostgREST.RangeQuery +Description : Logic regarding the `Range` header and `limit`, `offset` querystring arguments. +-} module PostgREST.RangeQuery ( rangeParse , rangeRequested @@ -9,19 +13,17 @@ , NonnegRange ) where - -import Control.Applicative -import Network.HTTP.Types.Header - -import qualified Data.ByteString.Char8 as BS -import Data.Ranged.Boundaries -import Data.Ranged.Ranges +import qualified Data.ByteString.Char8 as BS -import Text.Regex.TDFA ((=~)) +import Data.List (lookup) +import Text.Regex.TDFA ((=~)) -import Data.List (lookup) +import Control.Applicative +import Data.Ranged.Boundaries +import Data.Ranged.Ranges +import Network.HTTP.Types.Header -import Protolude +import Protolude type NonnegRange = Range Integer @@ -56,7 +58,7 @@ rangeOffset range = case rangeLower range of BoundaryBelow lower -> lower - _ -> panic "range without lower bound" -- should never happen + _ -> panic "range without lower bound" -- should never happen rangeGeq :: Integer -> NonnegRange rangeGeq n = diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,31 +1,67 @@ -{-# LANGUAGE DuplicateRecordFields #-} +{-| +Module : PostgREST.Types +Description : PostgREST common types and functions used by the rest of the modules +-} +{-# LANGUAGE DuplicateRecordFields #-} + module PostgREST.Types where -import Protolude + +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 qualified Data.Aeson as JSON -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI -import qualified Data.HashMap.Strict as M -import qualified Data.Set as S -import Data.Tree -import PostgREST.RangeQuery (NonnegRange) -import Network.HTTP.Types.Header (hContentType, Header) +import Network.HTTP.Types.Header (Header, hContentType) + +import Data.Tree + +import PostgREST.RangeQuery (NonnegRange) +import Protolude + -- | Enumeration of currently supported response content types -data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI - | CTSingularJSON | CTOctetStream - | CTAny | CTOther ByteString deriving Eq +data ContentType = CTApplicationJSON | CTSingularJSON + | CTTextCSV | CTTextPlain | CTTextHtml + | CTOpenAPI | CTOctetStream + | CTAny | CTOther ByteString deriving (Show, Eq) -data ApiRequestError = ActionInappropriate - | InvalidBody ByteString - | InvalidRange - | ParseRequestError Text Text - | UnknownRelation - | NoRelationBetween Text Text - | UnsupportedVerb - | InvalidFilters - 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 CTTextHtml = "text/html" +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 + "text/html" -> CTTextHtml + "application/openapi+json" -> CTOpenAPI + "application/vnd.pgrst.object+json" -> CTSingularJSON + "application/vnd.pgrst.object" -> CTSingularJSON + "application/octet-stream" -> CTOctetStream + "*/*" -> CTAny + ct' -> CTOther ct' + +-- | ContentTypes that can get a raw/unwrapped response +rawContentTypes :: [ContentType] +rawContentTypes = [CTOctetStream, CTTextPlain, CTTextHtml] + data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq instance Show PreferResolution where show MergeDuplicates = "resolution=merge-duplicates" @@ -77,6 +113,34 @@ | name1 == name2 && length args1 > length args2 = GT | otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2) +{-| + 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 -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription +findProc qi payloadKeys paramsAsSingleObject allProcs = + case M.lookup (qiName 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 + type Schema = Text type TableName = Text type SqlQuery = Text @@ -89,12 +153,15 @@ , tableInsertable :: Bool } deriving (Show, Ord) +instance Eq Table where + Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2 + newtype ForeignKey = ForeignKey { fkCol :: Column } deriving (Show, Eq, Ord) data Column = Column { colTable :: Table - , colName :: Text + , colName :: FieldName , colDescription :: Maybe Text , colPosition :: Int32 , colNullable :: Bool @@ -107,6 +174,9 @@ , colFK :: Maybe ForeignKey } deriving (Show, Ord) +instance Eq Column where + Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2 + -- | A view column that refers to a table column type Synonym = (Column, ViewColumn) type ViewColumn = Column @@ -132,6 +202,10 @@ , 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 @@ -149,40 +223,42 @@ TODO merge relColumns and relFColumns to a tuple or Data.Bimap -} data Relation = Relation { - relTable :: Table -, relColumns :: [Column] -, relFTable :: Table -, relFColumns :: [Column] -, relType :: RelationType + relTable :: Table +, relColumns :: [Column] +, relFTable :: Table +, relFColumns :: [Column] +, relType :: RelationType -- The Link attrs are used when RelationType == Many -, relLinkTable :: Maybe Table -, relLinkCols1 :: Maybe [Column] -, relLinkCols2 :: Maybe [Column] +, relLinkTable :: Maybe Table +, relLinkCols1 :: Maybe [Column] +, relLinkCols2 :: Maybe [Column] } deriving (Show, Eq) --- | Cached attributes of a JSON payload -data PayloadJSON = PayloadJSON { --- | This is the raw ByteString that comes from the request body. --- We cache this instead of an Aeson Value because it was detected that for large payloads the encoding --- had high memory usage, see #1005 for more details - pjRaw :: BL.ByteString -, pjType :: PJType --- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects -, pjKeys :: S.Set Text -} deriving (Show, Eq) +isSelfJoin :: Relation -> Bool +isSelfJoin r = relType r /= Root && relTable r == relFTable r -data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq) +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 #1005 for more details + pjRaw :: BL.ByteString + , pjType :: PJType + -- | Keys of the object or if it's an array these keys are guaranteed to be the same across all its objects + , pjKeys :: S.Set Text + }| + RawJSON { + pjRaw :: BL.ByteString + } deriving (Show, Eq) --- | e.g. whether it is []/{} or not -pjIsEmpty :: PayloadJSON -> Bool -pjIsEmpty (PayloadJSON _ PJObject keys) = S.size keys == 0 -pjIsEmpty (PayloadJSON _ (PJArray l) _) = l == 0 +data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq) data Proxy = Proxy { - proxyScheme :: Text -, proxyHost :: Text -, proxyPort :: Integer -, proxyPath :: Text + proxyScheme :: Text +, proxyHost :: Text +, proxyPort :: Integer +, proxyPath :: Text } deriving (Show, Eq) type Operator = Text @@ -227,8 +303,8 @@ data LogicOperator = And | Or deriving Eq instance Show LogicOperator where - show And = "AND" - show Or = "OR" + show And = "AND" + show Or = "OR" {-| Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is: @@ -283,40 +359,49 @@ -- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"] type EmbedPath = [Text] data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq) -data JoinCondition = JoinCondition (QualifiedIdentifier, Maybe Alias, FieldName) - (QualifiedIdentifier, Maybe Alias, FieldName) deriving (Show, Eq) +data JoinCondition = JoinCondition (QualifiedIdentifier, FieldName) + (QualifiedIdentifier, FieldName) deriving (Show, Eq) -data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], joinConditions::[JoinCondition], order::[OrderTerm], range_::NonnegRange } deriving (Show, Eq) -data MutateQuery = Insert { in_::TableName, insPkCols::[Text], qPayload::PayloadJSON, onConflict:: Maybe PreferResolution, where_::[LogicTree], returning::[FieldName] } - | Delete { in_::TableName, where_::[LogicTree], returning::[FieldName] } - | Update { in_::TableName, qPayload::PayloadJSON, where_::[LogicTree], returning::[FieldName] } deriving (Show, Eq) -type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail, Depth)) +data ReadQuery = Select { + select :: [SelectItem] + , from :: TableName +-- | 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 :: [TableName] + , where_ :: [LogicTree] + , joinConditions :: [JoinCondition] + , order :: [OrderTerm] + , range_ :: NonnegRange +} deriving (Show, Eq) + +data MutateQuery = + Insert { + in_ :: TableName + , insCols :: S.Set FieldName + , onConflict :: Maybe (PreferResolution, [FieldName]) + , where_ :: [LogicTree] + , returning :: [FieldName] + }| + Update { + in_ :: TableName + , updCols :: S.Set FieldName + , where_ :: [LogicTree] + , returning :: [FieldName] + }| + Delete { + in_ :: TableName + , where_ :: [LogicTree] + , returning :: [FieldName] + } deriving (Show, Eq) + +data DbRequest = DbRead ReadRequest | DbMutate MutateRequest type ReadRequest = Tree ReadNode +type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail, Depth)) -- Depth of the ReadRequest tree type Depth = Integer type MutateRequest = MutateQuery -data DbRequest = DbRead ReadRequest | DbMutate MutateRequest -instance Eq Table where - Table{tableSchema=s1,tableName=n1} == Table{tableSchema=s2,tableName=n2} = s1 == s2 && n1 == n2 - -instance Eq Column where - Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2 - --- | 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 CTOpenAPI = "application/openapi+json" -toMime CTSingularJSON = "application/vnd.pgrst.object+json" -toMime CTOctetStream = "application/octet-stream" -toMime CTAny = "*/*" -toMime (CTOther ct) = ct - data PgVersion = PgVersion { pgvNum :: Int32 , pgvName :: Text @@ -327,8 +412,11 @@ -- | Tells the minimum PostgreSQL version required by this version of PostgREST minimumPgVersion :: PgVersion -minimumPgVersion = PgVersion 90400 "9.4" +minimumPgVersion = pgVersion94 +pgVersion94 :: PgVersion +pgVersion94 = PgVersion 90400 "9.4" + pgVersion95 :: PgVersion pgVersion95 = PgVersion 90500 "9.5" @@ -338,6 +426,9 @@ pgVersion100 :: PgVersion pgVersion100 = PgVersion 100000 "10" +pgVersion112 :: PgVersion +pgVersion112 = PgVersion 110002 "11.2" + sourceCTEName :: SqlFragment sourceCTEName = "pg_source" @@ -345,3 +436,12 @@ 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/test/Feature/AndOrParamsSpec.hs b/test/Feature/AndOrParamsSpec.hs --- a/test/Feature/AndOrParamsSpec.hs +++ b/test/Feature/AndOrParamsSpec.hs @@ -1,13 +1,14 @@ module Feature.AndOrParamsSpec where + +import Network.Wai (Application) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types -import Network.Wai (Application) - +import Protolude hiding (get) import SpecHelper -import Protolude hiding (get) spec :: SpecWith Application diff --git a/test/Feature/AsymmetricJwtSpec.hs b/test/Feature/AsymmetricJwtSpec.hs --- a/test/Feature/AsymmetricJwtSpec.hs +++ b/test/Feature/AsymmetricJwtSpec.hs @@ -1,14 +1,14 @@ module Feature.AsymmetricJwtSpec where -- {{{ Imports +import Network.Wai (Application) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai -import Network.HTTP.Types -import SpecHelper -import Network.Wai (Application) - import Protolude +import SpecHelper -- }}} spec :: SpecWith Application diff --git a/test/Feature/AudienceJwtSecretSpec.hs b/test/Feature/AudienceJwtSecretSpec.hs --- a/test/Feature/AudienceJwtSecretSpec.hs +++ b/test/Feature/AudienceJwtSecretSpec.hs @@ -1,14 +1,14 @@ module Feature.AudienceJwtSecretSpec where -- {{{ Imports +import Network.Wai (Application) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai -import Network.HTTP.Types +import Protolude hiding (get) import SpecHelper -import Network.Wai (Application) - -import Protolude hiding (get) -- }}} spec :: SpecWith Application @@ -44,4 +44,4 @@ `shouldRespondWith` 200 it "requests without JWT token should work" $ - get "/has_count_column" `shouldRespondWith` 200 + get "/has_count_column" `shouldRespondWith` 200 diff --git a/test/Feature/AuthSpec.hs b/test/Feature/AuthSpec.hs --- a/test/Feature/AuthSpec.hs +++ b/test/Feature/AuthSpec.hs @@ -1,26 +1,36 @@ module Feature.AuthSpec where -import Text.Heredoc +import Network.Wai (Application) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types +import Text.Heredoc +import PostgREST.Types (PgVersion, pgVersion112) +import Protolude hiding (get) import SpecHelper -import Network.Wai (Application) -import Protolude hiding (get) - -spec :: SpecWith Application -spec = describe "authorization" $ do +spec :: PgVersion -> SpecWith Application +spec actualPgVersion = describe "authorization" $ do let single = ("Accept","application/vnd.pgrst.object+json") it "denies access to tables that anonymous does not own" $ - get "/authors_only" `shouldRespondWith` [json| { + get "/authors_only" `shouldRespondWith` ( + if actualPgVersion >= pgVersion112 then + [json| { "hint":null, "details":null, "code":"42501", + "message":"permission denied for table authors_only"} |] + else + [json| { + "hint":null, + "details":null, + "code":"42501", "message":"permission denied for relation authors_only"} |] + ) { matchStatus = 401 , matchHeaders = ["WWW-Authenticate" <:> "Bearer"] } @@ -28,11 +38,20 @@ it "denies access to tables that postgrest_test_author does not own" $ let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIn0.Xod-F15qsGL0WhdOCr2j3DdKuTw9QJERVgoFD3vGaWA" in request methodGet "/private_table" [auth] "" - `shouldRespondWith` [json| { + `shouldRespondWith` ( + if actualPgVersion >= pgVersion112 then + [json| { "hint":null, "details":null, "code":"42501", + "message":"permission denied for table private_table"} |] + else + [json| { + "hint":null, + "details":null, + "code":"42501", "message":"permission denied for relation private_table"} |] + ) { matchStatus = 403 , matchHeaders = [] } diff --git a/test/Feature/BinaryJwtSecretSpec.hs b/test/Feature/BinaryJwtSecretSpec.hs --- a/test/Feature/BinaryJwtSecretSpec.hs +++ b/test/Feature/BinaryJwtSecretSpec.hs @@ -1,14 +1,14 @@ module Feature.BinaryJwtSecretSpec where -- {{{ Imports +import Network.Wai (Application) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai -import Network.HTTP.Types -import SpecHelper -import Network.Wai (Application) - import Protolude +import SpecHelper -- }}} spec :: SpecWith Application diff --git a/test/Feature/ConcurrentSpec.hs b/test/Feature/ConcurrentSpec.hs --- a/test/Feature/ConcurrentSpec.hs +++ b/test/Feature/ConcurrentSpec.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Feature.ConcurrentSpec where -import Control.Monad (void) -import Control.Monad.Base +import Control.Concurrent.Async (mapConcurrently) +import Control.Monad (void) +import Network.Wai (Application) +import Control.Monad.Base import Control.Monad.Trans.Control -import Control.Concurrent.Async (mapConcurrently) +import Network.Wai.Test (Session) import Test.Hspec -import Test.Hspec.Wai.Internal import Test.Hspec.Wai +import Test.Hspec.Wai.Internal import Test.Hspec.Wai.JSON -import Network.Wai.Test (Session) - -import Network.Wai (Application) import Protolude hiding (get) diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -1,17 +1,17 @@ module Feature.CorsSpec where -- {{{ Imports -import Test.Hspec -import Test.Hspec.Wai -import Network.Wai.Test (SResponse(simpleHeaders, simpleBody)) import qualified Data.ByteString.Lazy as BL -import SpecHelper +import Network.Wai (Application) +import Network.Wai.Test (SResponse (simpleBody, simpleHeaders)) import Network.HTTP.Types -import Network.Wai (Application) +import Test.Hspec +import Test.Hspec.Wai import Protolude +import SpecHelper -- }}} spec :: SpecWith Application diff --git a/test/Feature/DeleteSpec.hs b/test/Feature/DeleteSpec.hs --- a/test/Feature/DeleteSpec.hs +++ b/test/Feature/DeleteSpec.hs @@ -1,11 +1,11 @@ module Feature.DeleteSpec where +import Network.Wai (Application) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Text.Heredoc - -import Network.HTTP.Types -import Network.Wai (Application) import Protolude hiding (get) diff --git a/test/Feature/ExtraSearchPathSpec.hs b/test/Feature/ExtraSearchPathSpec.hs --- a/test/Feature/ExtraSearchPathSpec.hs +++ b/test/Feature/ExtraSearchPathSpec.hs @@ -1,14 +1,13 @@ module Feature.ExtraSearchPathSpec where +import Network.HTTP.Types +import Network.Wai (Application) import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types -import SpecHelper -import Network.Wai (Application) - import Protolude +import SpecHelper spec :: SpecWith Application spec = describe "extra search path" $ do diff --git a/test/Feature/InsertSpec.hs b/test/Feature/InsertSpec.hs --- a/test/Feature/InsertSpec.hs +++ b/test/Feature/InsertSpec.hs @@ -1,28 +1,27 @@ module Feature.InsertSpec where -import Test.Hspec hiding (pendingWith) -import Test.Hspec.Wai -import Test.Hspec.Wai.JSON -import Test.Hspec.Wai.Matcher (bodyEquals) -import Network.Wai.Test (SResponse(simpleBody,simpleHeaders,simpleStatus)) +import qualified Data.Aeson as JSON -import SpecHelper +import Control.Monad (replicateM_, void) +import Data.List (lookup) +import Data.Maybe (fromJust) +import Network.Wai (Application) +import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus)) +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai.Matcher (bodyEquals) +import TestTypes (CompoundPK (..), IncPK (..)) -import qualified Data.Aeson as JSON -import Data.List (lookup) -import Data.Maybe (fromJust) -import Text.Heredoc -import Network.HTTP.Types.Header import Network.HTTP.Types -import Control.Monad (replicateM_, void) - -import TestTypes(IncPK(..), CompoundPK(..)) -import Network.Wai (Application) +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON +import Text.Heredoc -import Protolude hiding (get) +import PostgREST.Types (PgVersion, pgVersion112) +import Protolude hiding (get) +import SpecHelper -spec :: SpecWith Application -spec = do +spec :: PgVersion -> SpecWith Application +spec actualPgVersion = do describe "Posting new record" $ do context "disparate json types" $ do it "accepts disparate json types" $ do @@ -51,9 +50,22 @@ context "non uniform json array" $ do it "rejects json array that isn't exclusivily composed of objects" $ - post "/articles" [json| [{"id": 100, "body": "xxxxx"}, 123, "xxxx", {"id": 111, "body": "xxxx"}] |] `shouldRespondWith` 400 + post "/articles" + [json| [{"id": 100, "body": "xxxxx"}, 123, "xxxx", {"id": 111, "body": "xxxx"}] |] + `shouldRespondWith` + [json| {"message":"All object keys must match"} |] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] + } + it "rejects json array that has objects with different keys" $ - post "/articles" [json| [{"id": 100, "body": "xxxxx"}, {"id": 111, "body": "xxxx", "owner": "me"}] |] `shouldRespondWith` 400 + post "/articles" + [json| [{"id": 100, "body": "xxxxx"}, {"id": 111, "body": "xxxx", "owner": "me"}] |] + `shouldRespondWith` + [json| {"message":"All object keys must match"} |] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] + } context "requesting full representation" $ do it "includes related data after insert" $ @@ -103,11 +115,13 @@ incNullableStr record `shouldBe` Nothing context "into a table with simple pk" $ - it "fails with 400 and error" $ do - p <- post "/simple_pk" [json| { "extra":"foo"} |] - liftIO $ do - simpleStatus p `shouldBe` badRequest400 - isErrorFormat (simpleBody p) `shouldBe` True + 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"}|] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] + } context "into a table with no pk" $ do it "succeeds with 201 and a link including all fields" $ do @@ -181,11 +195,13 @@ lookup hLocation (simpleHeaders p) `shouldBe` Nothing context "with invalid json payload" $ - it "fails with 400 and error" $ do - p <- post "/simple_pk" "}{ x = 2" - liftIO $ do - simpleStatus p `shouldBe` badRequest400 - isErrorFormat (simpleBody p) `shouldBe` True + it "fails with 400 and error" $ + post "/simple_pk" "}{ x = 2" + `shouldRespondWith` + [json|{"message":"Error in $: Failed reading: not a valid json value"}|] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] + } context "with valid json payload" $ it "succeeds and returns 201 created" $ @@ -193,7 +209,12 @@ 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" } |] `shouldRespondWith` 409 + post "/simple_pk" [json| { "k":"k1", "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] + } context "attempting to insert a row with conflicting unique constraint" $ it "fails returning a 409 Conflict" $ @@ -222,12 +243,23 @@ , matchHeaders = ["Location" <:> location] } - context "empty object" $ - it "successfully populates table with all-default columns" $ + context "empty objects" $ do + it "successfully inserts a row with all-default columns" $ do post "/items" "{}" `shouldRespondWith` "" { matchStatus = 201 , matchHeaders = [] } + post "/items" "[{}]" `shouldRespondWith` "" + { matchStatus = 201 + , matchHeaders = [] + } + + it "successfully inserts two rows with all-default columns" $ + post "/items" "[{}, {}]" `shouldRespondWith` "" + { matchStatus = 201 + , matchHeaders = [] + } + context "table with limited privileges" $ do it "succeeds if correct select is applied" $ request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")] @@ -237,20 +269,75 @@ } it "fails if more columns are selected" $ request methodPost "/limited_article_stars?select=article_id,user_id,created_at" [("Prefer", "return=representation")] - [json| {"article_id": 2, "user_id": 2} |] `shouldRespondWith` - [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] + [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"}|] + else + [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] + ) { matchStatus = 401 , matchHeaders = [] } it "fails if select is not specified" $ request methodPost "/limited_article_stars" [("Prefer", "return=representation")] - [json| {"article_id": 3, "user_id": 1} |] `shouldRespondWith` [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] + [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"}|] + else + [str|{"hint":null,"details":null,"code":"42501","message":"permission denied for relation limited_article_stars"}|] + ) { matchStatus = 401 , matchHeaders = [] } - describe "CSV insert" $ do + context "POST with ?columns parameter" $ do + it "ignores json keys not included in ?columns" $ do + request methodPost "/articles?columns=id,body" [("Prefer", "return=representation")] + [json| {"id": 200, "body": "xxx", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith` + [json|[{"id": 200, "body": "xxx", "owner": "postgrest_test_anonymous"}]|] + { matchStatus = 201 + , matchHeaders = [] } + request methodPost "/articles?columns=id,body&select=id,body" [("Prefer", "return=representation")] + [json| [ + {"id": 201, "body": "yyy", "smth": "here", "other": "stuff", "fake_id": 13}, + {"id": 202, "body": "zzz", "garbage": "%%$&", "kkk": "jjj"}, + {"id": 203, "body": "aaa", "hey": "ho"} ]|] `shouldRespondWith` + [json|[ + {"id": 201, "body": "yyy"}, + {"id": 202, "body": "zzz"}, + {"id": 203, "body": "aaa"} ]|] + { matchStatus = 201 + , matchHeaders = [] } + -- TODO parse columns error message needs to be improved + it "disallows blank ?columns" $ + post "/articles?columns=" + [json|[ + {"id": 204, "body": "yyy"}, + {"id": 205, "body": "zzz"}]|] + `shouldRespondWith` + [json| {"details":"unexpected end of input expecting field name (* or [a..z0..9_])","message":"\"failed to parse columns parameter ()\" (line 1, column 1)"} |] + { matchStatus = 400 + , matchHeaders = [] + } + + it "disallows array elements that are not json objects" $ + post "/articles?columns=id,body" + [json|[ + {"id": 204, "body": "yyy"}, + 333, + "asdf", + {"id": 205, "body": "zzz"}]|] `shouldRespondWith` + [json|{ + "code": "22023", + "details": null, + "hint": null, + "message": "argument of json_populate_recordset must be an array of objects"}|] + { matchStatus = 400 + , matchHeaders = [] + } + + describe "CSV insert" $ do context "disparate csv types" $ it "succeeds with multipart response" $ do pendingWith "Decide on what to do with CSV insert" @@ -297,11 +384,13 @@ } context "with wrong number of columns" $ - it "fails for too few" $ do - p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz" - liftIO $ do - simpleStatus p `shouldBe` badRequest400 - isErrorFormat (simpleBody p) `shouldBe` True + it "fails for too few" $ + request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz" + `shouldRespondWith` + [json|{"message":"All lines must have same number of fields"}|] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] + } context "with unicode values" $ it "succeeds and returns usable location header" $ do @@ -317,22 +406,20 @@ r <- get location liftIO $ simpleBody r `shouldBe` "["<>payload<>"]" - describe "Patching record" $ do - context "to unknown uri" $ - it "gives a 404" $ + 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" $ + it "indicates no records found to update by returning 404" $ request methodPatch "/empty_table" [] [json| { "extra":20 } |] `shouldRespondWith` "" - { matchStatus = 204, - matchHeaders = ["Content-Range" <:> "*/*"] + { matchStatus = 404, + matchHeaders = [] } context "in a nonempty table" $ do @@ -359,10 +446,15 @@ [("Prefer", "return=representation")] [json| { "id":999999 } |] `shouldRespondWith` "[]" { - matchStatus = 200, - matchHeaders = ["Content-Range" <:> "*/*"] + 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 } |] @@ -390,16 +482,27 @@ [json| [{ a: "keepme", b: null }] |] { matchHeaders = [matchContentTypeJson] } - it "can update based on a computed column" $ - request methodPatch - "/items?always_true=eq.false" - [("Prefer", "return=representation")] - [json| { id: 100 } |] - `shouldRespondWith` "[]" - { matchStatus = 200, - matchHeaders = ["Content-Range" <:> "*/*"] - } + 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 = [] + } + it "can provide a representation" $ do _ <- post "/items" [json| { id: 1 } |] @@ -427,21 +530,21 @@ matchHeaders = ["Content-Range" <:> "*/*"] } - get "/items" `shouldRespondWith` - [json|[{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}]|] - { matchHeaders = [matchContentTypeJson] } + request methodPatch "/items" [] [json| [{}] |] + `shouldRespondWith` "" + { + matchStatus = 204, + matchHeaders = ["Content-Range" <:> "*/*"] + } - it "makes no updates and and returns 200, when patching with an empty json object and return=rep" $ do + it "makes no updates and and returns 200, when patching with an empty json object and return=rep" $ request methodPatch "/items" [("Prefer", "return=representation")] [json| {} |] `shouldRespondWith` "[]" { matchStatus = 200, matchHeaders = ["Content-Range" <:> "*/*"] } - get "/items" `shouldRespondWith` - [json| [{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15},{id:16},{"id":2},{"id":1}] |] - { matchHeaders = [matchContentTypeJson] } - + context "with unicode values" $ it "succeeds and returns values intact" $ do void $ request methodPost "/no_pk" [] @@ -452,6 +555,18 @@ 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 describe "Row level permission" $ it "set user_id when inserting rows" $ do diff --git a/test/Feature/JsonOperatorSpec.hs b/test/Feature/JsonOperatorSpec.hs --- a/test/Feature/JsonOperatorSpec.hs +++ b/test/Feature/JsonOperatorSpec.hs @@ -1,17 +1,18 @@ module Feature.JsonOperatorSpec where +import Network.Wai (Application) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types +import PostgREST.Types (PgVersion, pgVersion112) +import Protolude hiding (get) import SpecHelper -import Network.Wai (Application) -import Protolude hiding (get) - -spec :: SpecWith Application -spec = describe "json and jsonb operators" $ do +spec :: PgVersion -> SpecWith Application +spec actualPgVersion = describe "json and jsonb operators" $ do context "Shaping response with select parameter" $ do it "obtains a json subfield one level with casting" $ get "/complex_items?id=eq.1&select=settings->>foo::json" `shouldRespondWith` @@ -52,14 +53,28 @@ -- this works fine for /rpc/unexistent requests, but for this case a 500 seems more appropriate it "fails when a double arrow ->> is followed with a single arrow ->" $ do get "/json_arr?select=data->>c->1" - `shouldRespondWith` [json| + `shouldRespondWith` ( + if actualPgVersion >= pgVersion112 then + [json| + {"hint":"No operator matches the given name and argument types. You might need to add explicit type casts.", + "details":null,"code":"42883","message":"operator does not exist: text -> integer"} |] + else + [json| {"hint":"No operator matches the given name and argument type(s). You might need to add explicit type casts.", "details":null,"code":"42883","message":"operator does not exist: text -> integer"} |] + ) { matchStatus = 404 , matchHeaders = [] } get "/json_arr?select=data->>c->b" - `shouldRespondWith` [json| + `shouldRespondWith` ( + if actualPgVersion >= pgVersion112 then + [json| + {"hint":"No operator matches the given name and argument types. You might need to add explicit type casts.", + "details":null,"code":"42883","message":"operator does not exist: text -> unknown"} |] + else + [json| {"hint":"No operator matches the given name and argument type(s). You might need to add explicit type casts.", "details":null,"code":"42883","message":"operator does not exist: text -> unknown"} |] + ) { matchStatus = 404 , matchHeaders = [] } context "with array index" $ do diff --git a/test/Feature/NoJwtSpec.hs b/test/Feature/NoJwtSpec.hs --- a/test/Feature/NoJwtSpec.hs +++ b/test/Feature/NoJwtSpec.hs @@ -1,14 +1,16 @@ module Feature.NoJwtSpec where -- {{{ Imports -import Test.Hspec -import Test.Hspec.Wai -import Network.HTTP.Types -import SpecHelper import Network.Wai (Application) +import Network.HTTP.Types +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + import Protolude +import SpecHelper -- }}} spec :: SpecWith Application @@ -18,7 +20,11 @@ it "responds with error on attempted auth" $ do let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA" request methodGet "/authors_only" [auth] "" - `shouldRespondWith` 500 + `shouldRespondWith` + [json|{"message":"Server lacks JWT secret"}|] + { matchStatus = 500 + , matchHeaders = [ matchContentTypeJson ] + } it "behaves normally when user does not attempt auth" $ request methodGet "/items" [] "" diff --git a/test/Feature/NonexistentSchemaSpec.hs b/test/Feature/NonexistentSchemaSpec.hs --- a/test/Feature/NonexistentSchemaSpec.hs +++ b/test/Feature/NonexistentSchemaSpec.hs @@ -1,9 +1,11 @@ module Feature.NonexistentSchemaSpec where import Network.Wai (Application) -import Protolude hiding (get) + import Test.Hspec import Test.Hspec.Wai + +import Protolude hiding (get) spec :: SpecWith Application spec = diff --git a/test/Feature/PgVersion95Spec.hs b/test/Feature/PgVersion95Spec.hs --- a/test/Feature/PgVersion95Spec.hs +++ b/test/Feature/PgVersion95Spec.hs @@ -1,13 +1,13 @@ 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 -import Network.Wai (Application) - -import Protolude hiding (get) spec :: SpecWith Application spec = describe "features supported on PostgreSQL 9.5" $ diff --git a/test/Feature/PgVersion96Spec.hs b/test/Feature/PgVersion96Spec.hs --- a/test/Feature/PgVersion96Spec.hs +++ b/test/Feature/PgVersion96Spec.hs @@ -1,14 +1,14 @@ module Feature.PgVersion96Spec where +import Network.Wai (Application) + import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON +import Protolude hiding (get) import SpecHelper -import Network.Wai (Application) -import Protolude hiding (get) - spec :: SpecWith Application spec = describe "features supported on PostgreSQL 9.6" $ do @@ -34,10 +34,30 @@ "X-Test-2" <:> "key1=val1"]} it "fails when setting headers with wrong json structure" $ do - get "/rpc/bad_guc_headers_1" `shouldRespondWith` 500 - get "/rpc/bad_guc_headers_2" `shouldRespondWith` 500 - get "/rpc/bad_guc_headers_3" `shouldRespondWith` 500 - post "/rpc/bad_guc_headers_1" [json|{}|] `shouldRespondWith` 500 + 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" diff --git a/test/Feature/ProxySpec.hs b/test/Feature/ProxySpec.hs --- a/test/Feature/ProxySpec.hs +++ b/test/Feature/ProxySpec.hs @@ -1,12 +1,10 @@ module Feature.ProxySpec where -import Test.Hspec - -import SpecHelper - import Network.Wai (Application) +import Test.Hspec hiding (pendingWith) import Protolude +import SpecHelper spec :: SpecWith Application spec = diff --git a/test/Feature/QueryLimitedSpec.hs b/test/Feature/QueryLimitedSpec.hs --- a/test/Feature/QueryLimitedSpec.hs +++ b/test/Feature/QueryLimitedSpec.hs @@ -1,14 +1,15 @@ module Feature.QueryLimitedSpec where +import Network.Wai (Application) +import Network.Wai.Test (SResponse (simpleHeaders, simpleStatus)) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types -import Network.Wai.Test (SResponse(simpleHeaders, simpleStatus)) -import SpecHelper -import Network.Wai (Application) -import Protolude hiding (get) +import Protolude hiding (get) +import SpecHelper spec :: SpecWith Application spec = diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -1,16 +1,17 @@ module Feature.QuerySpec where +import Network.Wai (Application) +import Network.Wai.Test (SResponse (simpleHeaders)) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types -import Network.Wai.Test (SResponse(simpleHeaders)) -import SpecHelper import Text.Heredoc -import Network.Wai (Application) -import Protolude hiding (get) +import Protolude hiding (get) +import SpecHelper spec :: SpecWith Application spec = do @@ -181,7 +182,6 @@ { matchHeaders = [matchContentTypeJson] } 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}]|] @@ -333,6 +333,9 @@ it "can detect fk relations through views to tables in the public schema" $ get "/consumers_view?select=*,orders_view(*)" `shouldRespondWith` 200 + it "can detect fk relations through materialized views to tables in the public schema" $ + get "/materialized_projects?select=*,users(*)" `shouldRespondWith` 200 + it "can request parent without specifying primary key" $ 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"}}]|] @@ -433,22 +436,33 @@ {"number_of_projects":2,"client":{"name":"Apple"}}] |] { matchHeaders = [matchContentTypeJson] } + it "can embed a view that has a subselect containing a select in a where" $ + get "/authors_w_entities?select=name,entities,books(title)&id=eq.1" `shouldRespondWith` + [json| [{"name":"George Orwell","entities":[3, 4],"books":[{"title":"1984"}]}] |] + { matchHeaders = [matchContentTypeJson] } + describe "path fixed" $ do it "works when requesting children 2 levels" $ - get "/clients?id=eq.1&select=id,projects:projects.client_id(id,tasks(id))" `shouldRespondWith` + get "/clients?id=eq.1&select=id,projects:projects%2Bclient_id(id,tasks(id))" `shouldRespondWith` [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|] { matchHeaders = [matchContentTypeJson] } it "works with parent relation" $ - get "/message?select=id,body,sender:person.sender(name),recipient:person.recipient(name)&id=lt.4" `shouldRespondWith` + get "/message?select=id,body,sender:person%2Bsender(name),recipient:person%2Brecipient(name)&id=lt.4" `shouldRespondWith` [json| [{"id":1,"body":"Hello Jane","sender":{"name":"John"},"recipient":{"name":"Jane"}}, {"id":2,"body":"Hi John","sender":{"name":"Jane"},"recipient":{"name":"John"}}, {"id":3,"body":"How are you doing?","sender":{"name":"John"},"recipient":{"name":"Jane"}}] |] { matchHeaders = [matchContentTypeJson] } + it "fails with an unknown relation" $ + get "/message?select=id,sender:person.space(name)&id=lt.4" `shouldRespondWith` + [json|{"message":"Could not find foreign keys between these entities, No relation found between message and person"}|] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] } + it "works with a parent view relation" $ - get "/message?select=id,body,sender:person_detail.sender(name,sent),recipient:person_detail.recipient(name,received)&id=lt.4" `shouldRespondWith` + get "/message?select=id,body,sender:person_detail%2Bsender(name,sent),recipient:person_detail%2Brecipient(name,received)&id=lt.4" `shouldRespondWith` [json| [{"id":1,"body":"Hello Jane","sender":{"name":"John","sent":2},"recipient":{"name":"Jane","received":2}}, {"id":2,"body":"Hi John","sender":{"name":"Jane","sent":1},"recipient":{"name":"John","received":1}}, @@ -456,10 +470,19 @@ { matchHeaders = [matchContentTypeJson] } it "works with many<->many relation" $ - get "/tasks?select=id,users:users.users_tasks(id)" `shouldRespondWith` + get "/tasks?select=id,users:users%2Busers_tasks(id)" `shouldRespondWith` [json|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|] { matchHeaders = [matchContentTypeJson] } + describe "old dot '.' symbol, deprecated" $ + it "still works" $ do + get "/clients?id=eq.1&select=id,projects:projects.client_id(id,tasks(id))" `shouldRespondWith` + [json|[{"id":1,"projects":[{"id":1,"tasks":[{"id":1},{"id":2}]},{"id":2,"tasks":[{"id":3},{"id":4}]}]}]|] + { matchHeaders = [matchContentTypeJson] } + get "/tasks?select=id,users:users.users_tasks(id)" `shouldRespondWith` + [json|[{"id":1,"users":[{"id":1},{"id":3}]},{"id":2,"users":[{"id":1}]},{"id":3,"users":[{"id":1}]},{"id":4,"users":[{"id":1}]},{"id":5,"users":[{"id":2},{"id":3}]},{"id":6,"users":[{"id":2}]},{"id":7,"users":[{"id":2}]},{"id":8,"users":[]}]|] + { matchHeaders = [matchContentTypeJson] } + describe "aliased embeds" $ do it "works with child relation" $ get "/space?select=id,zones:zone(id,name),stores:zone(id,name)&zones.zone_type_id=eq.2&stores.zone_type_id=eq.3" `shouldRespondWith` @@ -528,7 +551,7 @@ { matchHeaders = [matchContentTypeJson] } it "embeds childs recursively" $ - get "/family_tree?id=eq.1&select=id,name, childs:family_tree.parent(id,name,childs:family_tree.parent(id,name))" `shouldRespondWith` + get "/family_tree?id=eq.1&select=id,name, childs:family_tree%2Bparent(id,name,childs:family_tree%2Bparent(id,name))" `shouldRespondWith` [json|[{ "id": "1", "name": "Parental Unit", "childs": [ { "id": "2", "name": "Kid One", "childs": [ { "id": "4", "name": "Grandkid One" } ] }, @@ -537,7 +560,7 @@ }]|] { matchHeaders = [matchContentTypeJson] } it "embeds parent and then embeds childs" $ - get "/family_tree?id=eq.2&select=id,name,parent(id,name,childs:family_tree.parent(id,name))" `shouldRespondWith` + get "/family_tree?id=eq.2&select=id,name,parent(id,name,childs:family_tree%2Bparent(id,name))" `shouldRespondWith` [json|[{ "id": "2", "name": "Kid One", "parent": { "id": "1", "name": "Parental Unit", "childs": [ { "id": "2", "name": "Kid One" }, { "id": "3", "name": "Kid Two"} ] @@ -560,7 +583,7 @@ }]|] { matchHeaders = [matchContentTypeJson] } it "embeds childs" $ do - get "/organizations?select=id,name,refereeds:organizations.referee(id,name)&id=eq.1" `shouldRespondWith` + get "/organizations?select=id,name,refereeds:organizations%2Breferee(id,name)&id=eq.1" `shouldRespondWith` [json|[{ "id": 1, "name": "Referee Org", "refereeds": [ @@ -574,7 +597,7 @@ } ] }]|] { matchHeaders = [matchContentTypeJson] } - get "/organizations?select=id,name,auditees:organizations.auditor(id,name)&id=eq.2" `shouldRespondWith` + get "/organizations?select=id,name,auditees:organizations%2Bauditor(id,name)&id=eq.2" `shouldRespondWith` [json|[{ "id": 2, "name": "Auditor Org", "auditees": [ @@ -589,6 +612,42 @@ ] }]|] { matchHeaders = [matchContentTypeJson] } + it "embeds other relations(manager) besides the self reference" $ do + get "/organizations?select=name,manager(name),referee(name,manager(name),auditor(name,manager(name))),auditor(name,manager(name),referee(name,manager(name)))&id=eq.5" `shouldRespondWith` + [json|[{ + "name":"Cyberdyne", + "manager":{"name":"Cyberdyne Manager"}, + "referee":{ + "name":"Acme", + "manager":{"name":"Acme Manager"}, + "auditor":{ + "name":"Auditor Org", + "manager":{"name":"Auditor Manager"}}}, + "auditor":{ + "name":"Umbrella", + "manager":{"name":"Umbrella Manager"}, + "referee":{ + "name":"Referee Org", + "manager":{"name":"Referee Manager"}}} + }]|] { matchHeaders = [matchContentTypeJson] } + + get "/organizations?select=name,manager(name),auditees:organizations%2Bauditor(name,manager(name),refereeds:organizations%2Breferee(name,manager(name)))&id=eq.2" `shouldRespondWith` + [json|[{ + "name":"Auditor Org", + "manager":{"name":"Auditor Manager"}, + "auditees":[ + {"name":"Acme", + "manager":{"name":"Acme Manager"}, + "refereeds":[ + {"name":"Cyberdyne", + "manager":{"name":"Cyberdyne Manager"}}, + {"name":"Oscorp", + "manager":{"name":"Oscorp Manager"}}]}, + {"name":"Umbrella", + "manager":{"name":"Umbrella Manager"}, + "refereeds":[]}] + }]|] { matchHeaders = [matchContentTypeJson] } + describe "ordering response" $ do it "by a column asc" $ get "/items?id=lte.2&order=id.asc" @@ -737,7 +796,11 @@ it "should respond an unknown accept type with 415" $ request methodGet "/simple_pk" (acceptHdrs "text/unknowntype") "" - `shouldRespondWith` 415 + `shouldRespondWith` + [json|{"message":"None of these Content-Types are available: text/unknowntype"}|] + { matchStatus = 415 + , matchHeaders = [matchContentTypeJson] + } it "should respond correctly to */* in accept header" $ request methodGet "/simple_pk" @@ -793,7 +856,6 @@ respHeaders `shouldSatisfy` matchHeader "Content-Location" "/simple_pk" - describe "weird requests" $ do it "can query as normal" $ do get "/Escap3e;" `shouldRespondWith` @@ -833,50 +895,39 @@ [json|[{":arr->ow::cast":" arrow-1 ","(inside,parens)":" parens-1 ","a.dotted.column":" dotted-1 "," col w space ":" space-1"}]|] { matchHeaders = [matchContentTypeJson] } - describe "binary output" $ do - context "on GET" $ do - it "can query if a single column is selected" $ - request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") "" - `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC" - { matchStatus = 200 - , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"] - } - - it "fails if a single column is not selected" $ do - request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") "" - `shouldRespondWith` 406 - request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") "" - `shouldRespondWith` 406 - request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") "" - `shouldRespondWith` 406 - - it "concatenates results if more than one row is returned" $ - request methodGet "/images_base64?select=img&name=in.(A.png,B.png)" (acceptHdrs "application/octet-stream") "" - `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII=" - { matchStatus = 200 - , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"] - } + context "binary output" $ do + it "can query if a single column is selected" $ + request methodGet "/images_base64?select=img&name=eq.A.png" (acceptHdrs "application/octet-stream") "" + `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC" + { matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"] + } - context "on RPC" $ do - context "Proc that returns scalar" $ - it "can query without selecting column" $ - request methodPost "/rpc/ret_base64_bin" (acceptHdrs "application/octet-stream") "" - `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC" - { matchStatus = 200 - , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"] - } + it "can get raw output with Accept: text/plain" $ + request methodGet "/projects?select=name&id=eq.1" (acceptHdrs "text/plain") "" + `shouldRespondWith` "Windows 7" + { 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"] - } + 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 a single column was not 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 - it "fails if a single column is not selected" $ - request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") "" - `shouldRespondWith` 406 + it "concatenates results if more than one row is returned" $ + request methodGet "/images_base64?select=img&name=in.(A.png,B.png)" (acceptHdrs "application/octet-stream") "" + `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCCiVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEX///8AAP94wDzzAAAAL0lEQVQIW2NgwAb+HwARH0DEDyDxwAZEyGAhLODqHmBRzAcn5GAS///A1IF14AAA5/Adbiiz/0gAAAAASUVORK5CYII=" + { matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"] + } describe "HTTP request env vars" $ do it "custom header is set" $ @@ -994,7 +1045,12 @@ [json| [] |] { matchHeaders = [matchContentTypeJson] } it "only returns an empty result set if the in value is empty" $ - get "/items_with_different_col_types?int_data=in.( ,3,4)" `shouldRespondWith` 400 + get "/items_with_different_col_types?int_data=in.( ,3,4)" + `shouldRespondWith` + [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"\""} |] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] + } describe "Embedding when column name = table name" $ do it "works with child embeds" $ diff --git a/test/Feature/RangeSpec.hs b/test/Feature/RangeSpec.hs --- a/test/Feature/RangeSpec.hs +++ b/test/Feature/RangeSpec.hs @@ -1,18 +1,18 @@ module Feature.RangeSpec where +import qualified Data.ByteString.Lazy as BL + +import Network.Wai (Application) +import Network.Wai.Test (SResponse (simpleHeaders, simpleStatus)) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types -import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus)) -import qualified Data.ByteString.Lazy as BL - +import Protolude hiding (get) import SpecHelper -import Network.Wai (Application) -import Protolude hiding (get) - defaultRange :: BL.ByteString defaultRange = [json| { "min": 0, "max": 15 } |] @@ -38,7 +38,6 @@ { matchHeaders = ["Content-Range" <:> "0-14/*"] } context "with range headers" $ do - context "of acceptable range" $ do it "succeeds with partial content" $ do r <- request methodPost "/rpc/getitemrange" @@ -156,7 +155,6 @@ , matchHeaders = ["Content-Range" <:> "0-0/*"] } - it "limit and offset works on first level" $ get "/items?select=id&order=id.asc&limit=3&offset=2" `shouldRespondWith` [json|[{"id":3},{"id":4},{"id":5}]|] @@ -164,8 +162,37 @@ , matchHeaders = ["Content-Range" <:> "2-4/*"] } - context "with range headers" $ do + it "succeeds if offset equals 0 as a no-op" $ + get "/items?select=id&offset=0" + `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/*"] + } + it "succeeds if offset is negative as a no-op" $ + get "/items?select=id&offset=-4" + `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/*"] + } + + it "fails if limit equals 0" $ + get "/items?select=id&limit=0" + `shouldRespondWith` [json|{"message":"HTTP Range error"}|] + { matchStatus = 416 + , matchHeaders = [matchContentTypeJson] + } + + it "fails if limit is negative" $ + get "/items?select=id&limit=-1" + `shouldRespondWith` [json|{"message":"HTTP Range error"}|] + { matchStatus = 416 + , matchHeaders = [matchContentTypeJson] + } + + context "with range headers" $ do context "of acceptable range" $ do it "succeeds with partial content" $ do r <- request methodGet "/items" diff --git a/test/Feature/RootSpec.hs b/test/Feature/RootSpec.hs new file mode 100644 --- /dev/null +++ b/test/Feature/RootSpec.hs @@ -0,0 +1,30 @@ +module Feature.RootSpec where + +import Network.HTTP.Types +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 "root spec function" $ do + it "accepts application/openapi+json" $ + request methodGet "/" + [("Accept","application/openapi+json")] "" `shouldRespondWith` + [json|{ + "swagger": "2.0", + "info": {"title": "PostgREST API", "description": "This is a dynamic API generated by PostgREST"} + }|] + { matchHeaders = ["Content-Type" <:> "application/openapi+json; charset=utf-8"] } + + it "accepts application/json" $ + request methodGet "/" + [("Accept", "application/json")] "" `shouldRespondWith` + [json| [{"table": "items"}, {"table": "subitems"}] |] + { matchHeaders = [matchContentTypeJson] } diff --git a/test/Feature/RpcSpec.hs b/test/Feature/RpcSpec.hs --- a/test/Feature/RpcSpec.hs +++ b/test/Feature/RpcSpec.hs @@ -1,20 +1,23 @@ module Feature.RpcSpec where -import Test.Hspec -import Test.Hspec.Wai -import Test.Hspec.Wai.JSON -import Network.HTTP.Types -import Network.Wai.Test (SResponse(simpleStatus, simpleBody)) import qualified Data.ByteString.Lazy as BL (empty) -import SpecHelper +import Network.Wai (Application) +import Network.Wai.Test (SResponse (simpleBody, simpleStatus)) + +import Network.HTTP.Types +import Test.Hspec hiding (pendingWith) +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON import Text.Heredoc -import Network.Wai (Application) -import Protolude hiding (get) +import PostgREST.Types (PgVersion, pgVersion100, pgVersion95, + pgVersion96) +import Protolude hiding (get) +import SpecHelper -spec :: SpecWith Application -spec = +spec :: PgVersion -> SpecWith Application +spec actualPgVersion = describe "remote procedure call" $ do context "a proc that returns a set" $ do it "returns paginated results" $ do @@ -77,6 +80,21 @@ 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} } |] + { matchStatus = 404 + , matchHeaders = [matchContentTypeJson] + } it "works when having uppercase identifiers" $ do get "/rpc/quotedFunction?user=mscott&fullName=Michael Scott&SSN=401-32-XXXX" `shouldRespondWith` @@ -213,6 +231,63 @@ [json|null|] { 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"]} + } |] + `shouldRespondWith` + [json|"Hi"|] + { matchHeaders = [matchContentTypeJson] } + + it "parses embedded JSON arguments as JSON" $ + post "/rpc/json_argument" + [json| { "arg": { "key": 3 } } |] + `shouldRespondWith` + [json|"object"|] + { matchHeaders = [matchContentTypeJson] } + + when (actualPgVersion <= pgVersion96) $ + it "parses quoted JSON arguments as JSON (Postgres <= 9.6)" $ + post "/rpc/json_argument" + [json| { "arg": "{ \"key\": 3 }" } |] + `shouldRespondWith` + [json|"object"|] + { matchHeaders = [matchContentTypeJson] } + + when (actualPgVersion >= pgVersion100) $ do + it "parses quoted JSON arguments as JSON string (Postgres >= 10)" $ do + -- Postgres bug report: + -- https://www.postgresql.org/message-id/D6921B37-BD8E-4664-8D5F-DB3525765DCD%40vllmrt.net + -- * json_to_record fails (see following test) + -- * jsonb_to_record parses the embedded quoted JSON to a JSON string, + -- so that's probably the expected behavior for Postgres >= 10 + pendingWith "Postgres >= 10 fails to parse quoted embedded JSON" + post "/rpc/json_argument" + [json| { "arg": "{ \"key\": 3 }" } |] + `shouldRespondWith` + [json|"string"|] + { matchHeaders = [matchContentTypeJson] } + + it "fails to parse quoted JSON arguments (Postgres >= 10)" $ + -- Confirming buggy Postgres behavior (see previous test) + post "/rpc/json_argument" + [json| { "arg": "{ \"key\": 3 }" } |] + `shouldRespondWith` + [json|{"hint":null,"details":"Token \"key\" is invalid.","code":"22P02","message":"invalid input syntax for type json"}|] + { matchStatus = 400 + , matchHeaders = [matchContentTypeJson] + } + context "improper input" $ do it "rejects unknown content type even if payload is good" $ do request methodPost "/rpc/sayhello" @@ -236,7 +311,11 @@ context "unsupported verbs" $ do it "DELETE fails" $ request methodDelete "/rpc/sayhello" [] "" - `shouldRespondWith` 405 + `shouldRespondWith` + [json|{"message":"Bad Request"}|] + { matchStatus = 405 + , matchHeaders = [matchContentTypeJson] + } it "PATCH fails" $ request methodPatch "/rpc/sayhello" [] "" `shouldRespondWith` 405 @@ -302,7 +381,12 @@ } it "defaults to status 500 if RAISE code is PT not followed by a number" $ - get "/rpc/raise_bad_pt" `shouldRespondWith` 500 + get "/rpc/raise_bad_pt" + `shouldRespondWith` + [json|{"hint": null, "details": null}|] + { matchStatus = 500 + , matchHeaders = [ matchContentTypeJson ] + } context "expects a single json object" $ do it "does not expand posted json into parameters" $ @@ -339,9 +423,100 @@ get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|] get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [str|"123"|] - context "only for POST rpc" $ + 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 + + it "ignores json keys not included in ?columns" $ + post "/rpc/sayhello?columns=name" + [json|{"name": "John", "smth": "here", "other": "stuff", "fake_id": 13}|] `shouldRespondWith` + [json|"Hello, John"|] + { matchHeaders = [matchContentTypeJson] } + + context "bulk RPC" $ do + it "works with a scalar function an returns a json array" $ + post "/rpc/add_them" + [json|[ + {"a": 1, "b": 2}, + {"a": 4, "b": 6}, + {"a": 100, "b": 200} + ]|] `shouldRespondWith` + [json| + [3, 10, 300] + |] { matchHeaders = [matchContentTypeJson] } + + it "works with a scalar function an returns a json array when posting CSV" $ + request methodPost "/rpc/add_them" [("Content-Type", "text/csv")] + "a,b\n1,2\n4,6\n100,200" + `shouldRespondWith` + [json| + [3, 10, 300] + |] + { matchStatus = 200 + , matchHeaders = [matchContentTypeJson] + } + + it "works with a non-scalar result" $ + post "/rpc/get_projects_below?select=id,name" + [json|[ + {"id": 1}, + {"id": 5} + ]|] `shouldRespondWith` + [json| + [{"id":1,"name":"Windows 7"}, + {"id":2,"name":"Windows 10"}, + {"id":3,"name":"IOS"}, + {"id":4,"name":"OSX"}] + |] { matchHeaders = [matchContentTypeJson] } + + context "binary output" $ do + context "Proc that returns scalar" $ do + it "can query without selecting column" $ + request methodPost "/rpc/ret_base64_bin" (acceptHdrs "application/octet-stream") "" + `shouldRespondWith` "iVBORw0KGgoAAAANSUhEUgAAAB4AAAAeAQMAAAAB/jzhAAAABlBMVEUAAAD/AAAb/40iAAAAP0lEQVQI12NgwAbYG2AE/wEYwQMiZB4ACQkQYZEAIgqAhAGIKLCAEQ8kgMT/P1CCEUwc4IMSzA3sUIIdCHECAGSQEkeOTUyCAAAAAElFTkSuQmCC" + { matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"] + } + + it "can get raw output with Accept: text/html" $ + request methodGet "/rpc/welcome.html" (acceptHdrs "text/html") "" + `shouldRespondWith` + [str| + | + | + | PostgREST + | + | + |

Welcome to PostgREST

+ | + | + |] + { matchStatus = 200 + , matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"] + } + + it "can get raw output with Accept: text/plain" $ + request methodGet "/rpc/welcome" (acceptHdrs "text/plain") "" + `shouldRespondWith` "Welcome 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"] + } + + it "fails if a single column is not selected" $ + request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") "" + `shouldRespondWith` + [json| {"message":"application/octet-stream requested but a single column was not selected"} |] + { matchStatus = 406 + , matchHeaders = [matchContentTypeJson] + } context "only for GET rpc" $ do it "should fail on mutating procs" $ do diff --git a/test/Feature/SingularSpec.hs b/test/Feature/SingularSpec.hs --- a/test/Feature/SingularSpec.hs +++ b/test/Feature/SingularSpec.hs @@ -1,16 +1,16 @@ module Feature.SingularSpec where -import Text.Heredoc +import Network.Wai (Application) +import Network.Wai.Test (SResponse (..)) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types -import Network.Wai.Test (SResponse(..)) - -import Network.Wai (Application) +import Text.Heredoc +import Protolude hiding (get) import SpecHelper -import Protolude hiding (get) spec :: SpecWith Application @@ -43,7 +43,6 @@ { matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] } context "when updating rows" $ do - it "works for one row" $ do _ <- post "/addresses" [json| { id: 97, address: "A Street" } |] request methodPatch @@ -56,10 +55,9 @@ 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" - [("Prefer", "return=representation"), singular] - [json| { address: "zzz" } |] + 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 @@ -67,15 +65,16 @@ -- the rows should not be updated, either get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|] - it "raises an error for zero rows" $ do - p <- request methodPatch "/items?id=gt.0&id=lt.0" - [("Prefer", "return=representation"), singular] [json|{"id":1}|] - liftIO $ do - simpleStatus p `shouldBe` notAcceptable406 - isErrorFormat (simpleBody p) `shouldBe` True + it "raises an error for zero rows" $ + 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"}|] + { matchStatus = 406 + , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + } context "when creating rows" $ do - it "works for one row" $ do p <- request methodPost "/addresses" @@ -117,17 +116,17 @@ , matchHeaders = ["Content-Range" <:> "*/*"] } - it "raises an error when creating zero entities" $ do - p <- request methodPost - "/addresses" - [("Prefer", "return=representation"), singular] - [json| [ ] |] - liftIO $ do - simpleStatus p `shouldBe` notAcceptable406 - isErrorFormat (simpleBody p) `shouldBe` True + it "raises an error when creating zero entities" $ + request methodPost "/addresses" + [("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"}|] + { matchStatus = 406 + , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + } context "when deleting rows" $ do - it "works for one row" $ do p <- request methodDelete "/items?id=eq.11" @@ -146,21 +145,24 @@ , matchHeaders = ["Content-Range" <:> "0-9/*"] } - it "raises an error when deleting zero entities" $ do - p <- request methodDelete "/items?id=lt.0" - [("Prefer", "return=representation"), singular] "" - liftIO $ do - simpleStatus p `shouldBe` notAcceptable406 - isErrorFormat (simpleBody p) `shouldBe` True + it "raises an error when deleting zero entities" $ + 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"}|] + { matchStatus = 406 + , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + } context "when calling a stored proc" $ do - - it "fails for zero rows" $ do - p <- request methodPost "/rpc/getproject" - [singular] [json|{ "id": 9999999}|] - liftIO $ do - simpleStatus p `shouldBe` notAcceptable406 - isErrorFormat (simpleBody p) `shouldBe` True + it "fails for zero rows" $ + 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"}|] + { matchStatus = 406 + , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + } -- this one may be controversial, should vnd.pgrst.object include -- the likes of 2 and "hello?" @@ -174,20 +176,26 @@ [singular] [json|{ "id": 1}|] `shouldRespondWith` [str|{"id":1,"name":"Windows 7","client_id":1}|] - it "fails for multiple rows" $ do - p <- request methodPost "/rpc/getallprojects" [singular] "{}" - liftIO $ do - simpleStatus p `shouldBe` notAcceptable406 - isErrorFormat (simpleBody p) `shouldBe` True + 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"}|] + { matchStatus = 406 + , matchHeaders = ["Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"] + } 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"}]|] - p <- request methodPost "/rpc/setprojects" [singular] - [json| {"id_l": 1, "id_h": 2, "name": "changed"} |] - liftIO $ do - simpleStatus p `shouldBe` notAcceptable406 - isErrorFormat (simpleBody p) `shouldBe` True + + request methodPost "/rpc/setprojects" [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"] + } -- should not actually have executed the function request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |] diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -1,21 +1,21 @@ module Feature.StructureSpec where -import Test.Hspec -import Test.Hspec.Wai -import Network.HTTP.Types - -import PostgREST.Config (docsVersion) -import Control.Lens ((^?)) +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 SpecHelper -import Network.Wai (Application) -import Network.Wai.Test (SResponse(..)) -import Protolude hiding (get) +import PostgREST.Config (docsVersion) +import Protolude hiding (get) +import SpecHelper spec :: SpecWith Application spec = do @@ -219,6 +219,158 @@ ] |] + 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 @@ -249,7 +401,7 @@ "properties": { "double": { "format": "double precision", - "type": "string" + "type": "number" }, "varchar": { "format": "character varying", @@ -274,6 +426,14 @@ "integer": { "format": "integer", "type": "integer" + }, + "json": { + "format": "json", + "type": "string" + }, + "jsonb": { + "format": "jsonb", + "type": "string" } }, "type": "object", diff --git a/test/Feature/UnicodeSpec.hs b/test/Feature/UnicodeSpec.hs --- a/test/Feature/UnicodeSpec.hs +++ b/test/Feature/UnicodeSpec.hs @@ -1,14 +1,14 @@ module Feature.UnicodeSpec where +import Control.Monad (void) +import Network.Wai (Application) + import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.Wai (Application) -import Control.Monad (void) +import Protolude hiding (get) import SpecHelper - -import Protolude hiding (get) spec :: SpecWith Application spec = diff --git a/test/Feature/UpsertSpec.hs b/test/Feature/UpsertSpec.hs --- a/test/Feature/UpsertSpec.hs +++ b/test/Feature/UpsertSpec.hs @@ -1,16 +1,16 @@ module Feature.UpsertSpec where +import Network.Wai (Application) + +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai import Test.Hspec.Wai.JSON -import Network.HTTP.Types +import Text.Heredoc +import Protolude hiding (get, put) import SpecHelper -import Network.Wai (Application) -import Protolude hiding (get, put) -import Text.Heredoc - spec :: SpecWith Application spec = describe "UPSERT" $ do @@ -44,6 +44,12 @@ , matchHeaders = ["Preference-Applied" <:> "resolution=merge-duplicates", matchContentTypeJson] } + it "succeeds when the payload has no elements" $ + request methodPost "/articles" [("Prefer", "return=representation"), ("Prefer", "resolution=merge-duplicates")] + [json|[]|] `shouldRespondWith` + [json|[]|] { matchStatus = 201 , matchHeaders = [matchContentTypeJson] } + + context "when Prefer: resolution=ignore-duplicates is specified" $ do it "INSERTs and ignores rows on pk conflict" $ request methodPost "/tiobe_pls" [("Prefer", "return=representation"), ("Prefer", "resolution=ignore-duplicates")] @@ -104,48 +110,96 @@ context "Restrictions" $ do it "fails if Range is specified" $ request methodPut "/tiobe_pls?name=eq.Javascript" [("Range", "0-5")] - [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400 + [str| [ { "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 } ]|] `shouldRespondWith` 400 + [str| [ { "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 } ]|] `shouldRespondWith` 400 + [str| [ { "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 the payload has more than one row" $ put "/tiobe_pls?name=eq.Go" - [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ]|] `shouldRespondWith` 400 + [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ]|] + `shouldRespondWith` + [json|{"message":"PUT payload must contain a single row"}|] + { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } it "fails if not all columns are specified" $ do put "/tiobe_pls?name=eq.Go" - [str| [ { "name": "Go" } ]|] `shouldRespondWith` 400 + [str| [ { "name": "Go" } ]|] + `shouldRespondWith` + [json|{"message":"You must specify all columns in the payload when using PUT"}|] + { matchStatus = 400 , matchHeaders = [matchContentTypeJson] } + put "/employees?first_name=eq.Susan&last_name=eq.Heidt" - [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000" } ]|] `shouldRespondWith` 400 + [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000" } ]|] + `shouldRespondWith` + [json|{"message":"You must specify all columns in the payload when using 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 } ]|] `shouldRespondWith` 405 - put "/tiobe_pls?id=not.eq.Java" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405 - put "/tiobe_pls?id=in.(Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405 - put "/tiobe_pls?and=(id.eq.Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405 + put "/tiobe_pls?rank=eq.19" + [str| [ { "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 } ]|] + `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 } ]|] + `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 } ]|] + `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" } ]|] - `shouldRespondWith` 405 + `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" } ]|] - `shouldRespondWith` 405 + `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 } ]|] `shouldRespondWith` 400 + put "/tiobe_pls?name=eq.MATLAB" [str| [ { "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" } ]|] `shouldRespondWith` 400 + [str| [ { "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" } ]|] `shouldRespondWith` 405 + put "/no_pk?a=eq.one&b=eq.two" [str| [ { "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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,23 +1,28 @@ module Main where -import Test.Hspec -import SpecHelper - -import qualified Hasql.Pool as P +import qualified Hasql.Pool as P import qualified Hasql.Transaction.Sessions as HT -import PostgREST.App (postgrest) -import PostgREST.DbStructure (getDbStructure, getPgVersion) -import PostgREST.Types (DbStructure(..), pgVersion95, pgVersion96) -import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction) -import Data.Function (id) +import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, + updateAction) +import Data.Function (id) +import Data.Time.Clock (getCurrentTime) + import Data.IORef -import Data.Time.Clock (getCurrentTime) +import Test.Hspec -import qualified Feature.AuthSpec +import PostgREST.App (postgrest) +import PostgREST.DbStructure (getDbStructure, getPgVersion) +import PostgREST.Types (DbStructure (..), pgVersion95, + pgVersion96) +import Protolude +import SpecHelper + +import qualified Feature.AndOrParamsSpec import qualified Feature.AsymmetricJwtSpec -import qualified Feature.BinaryJwtSecretSpec import qualified Feature.AudienceJwtSecretSpec +import qualified Feature.AuthSpec +import qualified Feature.BinaryJwtSecretSpec import qualified Feature.ConcurrentSpec import qualified Feature.CorsSpec import qualified Feature.DeleteSpec @@ -25,21 +30,20 @@ import qualified Feature.InsertSpec import qualified Feature.JsonOperatorSpec import qualified Feature.NoJwtSpec +import qualified Feature.NonexistentSchemaSpec +import qualified Feature.PgVersion95Spec +import qualified Feature.PgVersion96Spec +import qualified Feature.ProxySpec import qualified Feature.QueryLimitedSpec import qualified Feature.QuerySpec import qualified Feature.RangeSpec -import qualified Feature.StructureSpec +import qualified Feature.RootSpec +import qualified Feature.RpcSpec import qualified Feature.SingularSpec +import qualified Feature.StructureSpec import qualified Feature.UnicodeSpec -import qualified Feature.ProxySpec -import qualified Feature.AndOrParamsSpec -import qualified Feature.RpcSpec -import qualified Feature.NonexistentSchemaSpec -import qualified Feature.PgVersion95Spec -import qualified Feature.PgVersion96Spec import qualified Feature.UpsertSpec -import Protolude main :: IO () main = do @@ -52,7 +56,7 @@ ver <- getPgVersion HT.transaction HT.ReadCommitted HT.Read $ getDbStructure "test" ver - dbStructure <- pure $ either (panic.show) id result + let dbStructure = either (panic.show) id result getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime } @@ -69,6 +73,7 @@ asymJwkSetApp = return $ postgrest (testCfgAsymJWKSet testDbConn) refDbStructure pool getTime $ pure () nonexistentSchemaApp = return $ postgrest (testNonexistentSchemaCfg testDbConn) refDbStructure pool getTime $ pure () extraSearchPathApp = return $ postgrest (testCfgExtraSearchPath testDbConn) refDbStructure pool getTime $ pure () + rootSpecApp = return $ postgrest (testCfgRootSpec testDbConn) refDbStructure pool getTime $ pure () let reset :: IO () reset = resetDb testDbConn @@ -80,14 +85,14 @@ [("Feature.PgVersion96Spec", Feature.PgVersion96Spec.spec) | actualPgVersion >= pgVersion96] specs = uncurry describe <$> [ - ("Feature.AuthSpec" , Feature.AuthSpec.spec) + ("Feature.AuthSpec" , Feature.AuthSpec.spec actualPgVersion) , ("Feature.ConcurrentSpec" , Feature.ConcurrentSpec.spec) , ("Feature.CorsSpec" , Feature.CorsSpec.spec) , ("Feature.DeleteSpec" , Feature.DeleteSpec.spec) - , ("Feature.InsertSpec" , Feature.InsertSpec.spec) - , ("Feature.JsonOperatorSpec" , Feature.JsonOperatorSpec.spec) + , ("Feature.InsertSpec" , Feature.InsertSpec.spec actualPgVersion) + , ("Feature.JsonOperatorSpec" , Feature.JsonOperatorSpec.spec actualPgVersion) , ("Feature.QuerySpec" , Feature.QuerySpec.spec) - , ("Feature.RpcSpec" , Feature.RpcSpec.spec) + , ("Feature.RpcSpec" , Feature.RpcSpec.spec actualPgVersion) , ("Feature.RangeSpec" , Feature.RangeSpec.spec) , ("Feature.SingularSpec" , Feature.SingularSpec.spec) , ("Feature.StructureSpec" , Feature.StructureSpec.spec) @@ -136,3 +141,8 @@ -- this test runs with an extra search path beforeAll_ reset . before extraSearchPathApp $ describe "Feature.ExtraSearchPathSpec" Feature.ExtraSearchPathSpec.spec + + -- this test runs with a root spec function override + when (actualPgVersion >= pgVersion96) $ + beforeAll_ reset . before rootSpecApp $ + describe "Feature.RootSpec" Feature.RootSpec.spec diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,34 +1,29 @@ module SpecHelper where -import Control.Monad (void) +import qualified Data.ByteString.Base64 as B64 (decodeLenient, encode) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified System.IO.Error as E -import qualified System.IO.Error as E -import System.Environment (getEnv) +import Control.Monad (void) +import Data.Aeson (Value (..), decode, encode) +import Data.CaseInsensitive (CI (..)) +import Data.List (lookup) +import Network.Wai.Test (SResponse (simpleBody, simpleHeaders, simpleStatus)) +import System.Environment (getEnv) +import System.Process (readProcess) +import Text.Regex.TDFA ((=~)) -import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient) -import Data.CaseInsensitive (CI(..)) -import qualified Data.Set as S -import qualified Data.Map.Strict as M -import Data.List (lookup) -import Text.Regex.TDFA ((=~)) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL -import System.Process (readProcess) -import Text.Heredoc -import PostgREST.Config (AppConfig(..)) -import PostgREST.Types (JSPathExp(..)) - +import Network.HTTP.Types import Test.Hspec import Test.Hspec.Wai - -import Network.HTTP.Types -import Network.Wai.Test (SResponse(simpleStatus, simpleHeaders, simpleBody)) - -import Data.Maybe (fromJust) -import Data.Aeson (decode, Value(..)) -import qualified JSONSchema.Draft4 as D4 +import Text.Heredoc +import PostgREST.Config (AppConfig (..)) +import PostgREST.Types (JSPathExp (..), QualifiedIdentifier (..)) import Protolude matchContentTypeJson :: MatchHeader @@ -48,18 +43,20 @@ let respHeaders = simpleHeaders r in respHeaders `shouldSatisfy` \hs -> ("Content-Type", "application/openapi+json; charset=utf-8") `elem` hs - liftIO $ - let respBody = simpleBody r - schema :: D4.Schema - schema = D4.emptySchema { D4._schemaRef = Just "openapi.json" } - schemaContext :: D4.SchemaWithURI D4.Schema - schemaContext = D4.SchemaWithURI - { D4._swSchema = schema - , D4._swURI = Just "test/fixtures/openapi.json" - } - in - D4.fetchFilesystemAndValidate schemaContext ((fromJust . decode) respBody) `shouldReturn` Right () + let Just body = decode (simpleBody r) + Just schema <- liftIO $ decode <$> BL.readFile "test/fixtures/openapi.json" + let args :: M.Map Text Value + args = M.fromList + [ ( "schema", schema ) + , ( "data", body ) ] + hdrs = acceptHdrs "application/json" + request methodPost "/rpc/validate_json_schema" hdrs (encode args) + `shouldRespondWith` "true" + { matchStatus = 200 + , matchHeaders = [] + } + getEnvVarWithDefault :: Text -> Text -> IO Text getEnvVarWithDefault var def = toS <$> getEnv (toS var) `E.catchIOError` const (return $ toS def) @@ -67,10 +64,12 @@ _baseCfg :: AppConfig _baseCfg = -- Connection Settings AppConfig mempty "postgrest_test_anonymous" Nothing "test" "localhost" 3000 + -- No user configured Unix Socket + Nothing -- Jwt settings (Just $ encodeUtf8 "reallyreallyreallyreallyverysafe") False Nothing -- Connection Modifiers - 10 Nothing (Just "test.switch_role") + 10 10 Nothing (Just "test.switch_role") -- Debug Settings True [ ("app.settings.app_host", "localhost") @@ -80,6 +79,8 @@ (Right [JSPKey "role"]) -- Empty db-extra-search-path [] + -- No root spec override + Nothing testCfg :: Text -> AppConfig testCfg testDbConn = _baseCfg { configDatabase = testDbConn } @@ -127,12 +128,16 @@ testCfgExtraSearchPath :: Text -> AppConfig testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configExtraSearchPath = ["public", "extensions"] } +testCfgRootSpec :: Text -> AppConfig +testCfgRootSpec testDbConn = (testCfg testDbConn) { configRootSpec = Just $ QualifiedIdentifier "test" "root"} + setupDb :: Text -> IO () setupDb dbConn = do loadFixture dbConn "database" loadFixture dbConn "roles" loadFixture dbConn "schema" loadFixture dbConn "jwt" + loadFixture dbConn "jsonschema" loadFixture dbConn "privileges" resetDb dbConn @@ -141,7 +146,7 @@ loadFixture :: Text -> FilePath -> IO() loadFixture dbConn name = - void $ readProcess "psql" [toS dbConn, "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] + void $ readProcess "psql" ["--set", "ON_ERROR_STOP=1", toS dbConn, "-a", "-f", "test/fixtures/" ++ name ++ ".sql"] [] rangeHdrs :: ByteRange -> [Header] rangeHdrs r = [rangeUnit, (hRange, renderByteRange r)] diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -3,16 +3,16 @@ , CompoundPK(..) ) where +import Data.Aeson ((.:)) import qualified Data.Aeson as JSON -import Data.Aeson ((.:)) import Protolude data IncPK = IncPK { - incId :: Int + incId :: Int , incNullableStr :: Maybe Text -, incStr :: Text -, incInsert :: Text +, incStr :: Text +, incInsert :: Text } deriving (Eq, Show) instance JSON.FromJSON IncPK where @@ -24,8 +24,8 @@ parseJSON _ = mzero data CompoundPK = CompoundPK { - compoundK1 :: Int -, compoundK2 :: Text + compoundK1 :: Int +, compoundK2 :: Text , compoundExtra :: Maybe Int } deriving (Eq, Show)