diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index e4454b867..82dd0792d 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -67,6 +67,14 @@ jobs: if: always() run: postgrest-with-postgresql-9.5 postgrest-test-spec + - name: Run query cost tests against all PostgreSQL versions + if: always() + run: postgrest-with-all postgrest-test-querycost + + - name: Run doctests + if: always() + run: nix-shell --run postgrest-test-doctests + - name: Check the spec tests for idempotence if: always() run: postgrest-test-spec-idempotence @@ -289,7 +297,7 @@ jobs: path: artifacts - name: Create release bundle with archives for all builds run: | - find artifacts -type f -iname postgrest -exec chmod +x {} \; + find artifacts -type f -iname postgrest -exec chmod +x {} \; mkdir -p release-bundle diff --git a/nix/tools/devTools.nix b/nix/tools/devTools.nix index 286763740..815c0c9b2 100644 --- a/nix/tools/devTools.nix +++ b/nix/tools/devTools.nix @@ -73,6 +73,8 @@ let } '' ${withTools}/bin/postgrest-with-all ${tests}/bin/postgrest-test-spec + ${withTools}/bin/postgrest-with-all ${tests}/bin/postgrest-test-querycost + ${tests}/bin/postgrest-test-doctests ${tests}/bin/postgrest-test-spec-idempotence ${tests}/bin/postgrest-test-io ${style}/bin/postgrest-lint diff --git a/nix/tools/tests.nix b/nix/tools/tests.nix index c72c75c10..bb5292636 100644 --- a/nix/tools/tests.nix +++ b/nix/tools/tests.nix @@ -24,7 +24,37 @@ let withEnv = postgrest.env; } '' - ${withTools.latest} ${cabal-install}/bin/cabal v2-test ${devCabalOptions} + ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec + ''; + + testQuerycost = + checkedShellScript + { + name = "postgrest-test-querycost"; + docs = "Run the Haskell test suite for query costs"; + inRootDir = true; + withEnv = postgrest.env; + } + '' + ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:querycost + ''; + + testDoctests = + checkedShellScript + { + name = "postgrest-test-doctests"; + docs = "Run the Haskell doctest test suite"; + inRootDir = true; + withEnv = postgrest.env; + } + '' + # For unknown reasons, doctests uses the wrong GHC package database outside + # nix-shell and fails, so we set the package path explicitly + #ghcWithPackages="$(cat ${postgrest.env})" + #ghcVersion="$(ls "$ghcWithPackages/lib")" + #export GHC_PACKAGE_PATH="$ghcWithPackages/lib/$ghcVersion/package.conf.d/" + + ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:doctests ''; testSpecIdempotence = @@ -37,8 +67,8 @@ let } '' ${withTools.latest} ${runtimeShell} -c " \ - ${cabal-install}/bin/cabal v2-test ${devCabalOptions} && \ - ${cabal-install}/bin/cabal v2-test ${devCabalOptions}" + ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec && \ + ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec" ''; ioTestPython = @@ -101,18 +131,24 @@ let rm -rf coverage/* # build once before running all the tests - ${cabal-install}/bin/cabal v2-build ${devCabalOptions} exe:postgrest lib:postgrest test:spec test:spec-querycost + ${cabal-install}/bin/cabal v2-build ${devCabalOptions} exe:postgrest lib:postgrest test:spec test:querycost # collect all tests HPCTIXFILE="$tmpdir"/io.tix \ - ${withTools.latest} ${cabal-install}/bin/cabal v2-exec ${devCabalOptions} \ + ${withTools.latest} ${cabal-install}/bin/cabal v2-exec ${devCabalOptions} \ ${ioTestPython}/bin/pytest -- -v test/io-tests HPCTIXFILE="$tmpdir"/spec.tix \ - ${withTools.latest} ${cabal-install}/bin/cabal v2-test ${devCabalOptions} + ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:spec + + HPCTIXFILE="$tmpdir"/querycost.tix \ + ${withTools.latest} ${cabal-install}/bin/cabal v2-run ${devCabalOptions} test:querycost + + # Note: No coverage for doctests, as doctests leverage GHCi and GHCi does not support hpc # collect all the tix files - ${ghc}/bin/hpc sum --union --exclude=Paths_postgrest --output="$tmpdir"/tests.tix "$tmpdir"/io*.tix "$tmpdir"/spec.tix + ${ghc}/bin/hpc sum --union --exclude=Paths_postgrest --output="$tmpdir"/tests.tix \ + "$tmpdir"/io*.tix "$tmpdir"/spec.tix "$tmpdir"/querycost.tix # prepare the overlay ${ghc}/bin/hpc overlay --output="$tmpdir"/overlay.tix test/coverage.overlay @@ -163,6 +199,8 @@ buildToolbox tools = [ testSpec + testQuerycost + testDoctests testSpecIdempotence testIO dumpSchema diff --git a/postgrest.cabal b/postgrest.cabal index 4711fd48d..b10becedd 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -238,7 +238,7 @@ test-suite spec -fno-spec-constr -optP-Wno-nonportable-include-path -fno-warn-missing-signatures -test-suite spec-querycost +test-suite querycost type: exitcode-stdio-1.0 default-language: Haskell2010 default-extensions: OverloadedStrings @@ -281,3 +281,18 @@ test-suite spec-querycost , wai-extra >= 3.0.19 && < 3.2 ghc-options: -O0 -Werror -Wall -fwarn-identities -fno-spec-constr -optP-Wno-nonportable-include-path + +test-suite doctests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + default-extensions: OverloadedStrings + NoImplicitPrelude + hs-source-dirs: test/doctests + main-is: Main.hs + build-depends: base >= 4.9 && < 4.16 + , doctest >= 0.8 + , postgrest + , pretty-simple + , protolude >= 0.3 && < 0.4 + ghc-options: -threaded -O0 -Werror -Wall -fwarn-identities + -fno-spec-constr -optP-Wno-nonportable-include-path diff --git a/src/PostgREST/Request/ApiRequest.hs b/src/PostgREST/Request/ApiRequest.hs index 39fa9478b..cd5271965 100644 --- a/src/PostgREST/Request/ApiRequest.hs +++ b/src/PostgREST/Request/ApiRequest.hs @@ -195,7 +195,7 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody , iRange = ranges , iTopLevelRange = topLevelRange , iPayload = relevantPayload - , iPreferRepresentation = preferRepresentation + , iPreferRepresentation = fromMaybe None preferRepresentation , iPreferParameters = preferParameters , iPreferCount = preferCount , iPreferResolution = preferResolution diff --git a/src/PostgREST/Request/Preferences.hs b/src/PostgREST/Request/Preferences.hs index a62e188ff..6c809a17c 100644 --- a/src/PostgREST/Request/Preferences.hs +++ b/src/PostgREST/Request/Preferences.hs @@ -1,3 +1,11 @@ +-- | +-- Module: PostgREST.Request.Preferences +-- Description: Track client preferences to be employed when processing requests +-- +-- Track client prefences set in HTTP 'Prefer' headers according to RFC7240[1]. +-- +-- [1] https://datatracker.ietf.org/doc/html/rfc7240 +-- module PostgREST.Request.Preferences ( Preferences(..) , PreferCount(..) @@ -9,37 +17,101 @@ module PostgREST.Request.Preferences , ToAppliedHeader(..) ) where -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS import qualified Data.Map as Map import qualified Network.HTTP.Types.Header as HTTP import Protolude +-- $setup +-- Setup for doctests +-- >>> import Text.Pretty.Simple (pPrint) +-- >>> deriving instance Show PreferResolution +-- >>> deriving instance Show PreferRepresentation +-- >>> deriving instance Show PreferParameters +-- >>> deriving instance Show PreferCount +-- >>> deriving instance Show PreferTransaction +-- >>> deriving instance Show Preferences + +-- | Preferences recognized by the application. data Preferences = Preferences { preferResolution :: Maybe PreferResolution - , preferRepresentation :: PreferRepresentation + , preferRepresentation :: Maybe PreferRepresentation , preferParameters :: Maybe PreferParameters , preferCount :: Maybe PreferCount , preferTransaction :: Maybe PreferTransaction } +-- | +-- Parse HTTP headers based on RFC7240[1] to identify preferences. +-- +-- One header with comma-separated values can be used to set multiple preferences: +-- +-- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates, count=exact")] +-- Preferences +-- { preferResolution = Just IgnoreDuplicates +-- , preferRepresentation = Nothing +-- , preferParameters = Nothing +-- , preferCount = Just ExactCount +-- , preferTransaction = Nothing +-- } +-- +-- Multiple headers can also be used: +-- +-- >>> pPrint $ fromHeaders [("Prefer", "resolution=ignore-duplicates"), ("Prefer", "count=exact")] +-- Preferences +-- { preferResolution = Just IgnoreDuplicates +-- , preferRepresentation = Nothing +-- , preferParameters = Nothing +-- , preferCount = Just ExactCount +-- , preferTransaction = Nothing +-- } +-- +-- If a preference is set more than once, only the first is used: +-- +-- >>> preferTransaction $ fromHeaders [("Prefer", "tx=commit, tx=rollback")] +-- Just Commit +-- +-- This is also the case across multiple headers: +-- +-- >>> :{ +-- preferResolution . fromHeaders $ +-- [ ("Prefer", "resolution=ignore-duplicates") +-- , ("Prefer", "resolution=merge-duplicates") +-- ] +-- :} +-- Just IgnoreDuplicates +-- +-- Preferences not recognized by the application are ignored: +-- +-- >>> preferResolution $ fromHeaders [("Prefer", "resolution=foo")] +-- Nothing +-- +-- Preferences can be separated by arbitrary amounts of space, lower-case header is also recognized: +-- +-- >>> pPrint $ fromHeaders [("prefer", "count=exact, tx=commit ,return=minimal")] +-- Preferences +-- { preferResolution = Nothing +-- , preferRepresentation = Just None +-- , preferParameters = Nothing +-- , preferCount = Just ExactCount +-- , preferTransaction = Just Commit +-- } +-- fromHeaders :: [HTTP.Header] -> Preferences fromHeaders headers = Preferences { preferResolution = parsePrefs [MergeDuplicates, IgnoreDuplicates] - , preferRepresentation = fromMaybe None $ parsePrefs [Full, None, HeadersOnly] + , preferRepresentation = parsePrefs [Full, None, HeadersOnly] , preferParameters = parsePrefs [SingleObject, MultipleObjects] , preferCount = parsePrefs [ExactCount, PlannedCount, EstimatedCount] , preferTransaction = parsePrefs [Commit, Rollback] } where prefHeaders = filter ((==) HTTP.hPrefer . fst) headers - prefs = fmap strip . concatMap (BS.split comma . snd) $ prefHeaders - comma = fromIntegral (ord ',') - strip = BS.dropWhile (space ==) . BS.dropWhileEnd (space ==) - space = fromIntegral (ord ' ') + prefs = fmap BS.strip . concatMap (BS.split ',' . snd) $ prefHeaders parsePrefs :: ToHeaderValue a => [a] -> Maybe a parsePrefs vals = @@ -48,13 +120,26 @@ fromHeaders headers = prefMap :: ToHeaderValue a => [a] -> Map.Map ByteString a prefMap = Map.fromList . fmap (\pref -> (toHeaderValue pref, pref)) +-- | +-- Convert a preference into the value that we look for in the 'Prefer' headers. +-- +-- >>> toHeaderValue MergeDuplicates +-- "resolution=merge-duplicates" +-- class ToHeaderValue a where toHeaderValue :: a -> ByteString +-- | +-- Header to indicate that a preference has been applied. +-- +-- >>> toAppliedHeader MergeDuplicates +-- ("Preference-Applied","resolution=merge-duplicates") +-- class ToHeaderValue a => ToAppliedHeader a where toAppliedHeader :: a -> HTTP.Header toAppliedHeader x = (HTTP.hPreferenceApplied, toHeaderValue x) +-- | How to handle duplicate values. data PreferResolution = MergeDuplicates | IgnoreDuplicates @@ -65,7 +150,10 @@ instance ToHeaderValue PreferResolution where instance ToAppliedHeader PreferResolution --- | How to return the mutated data. From https://tools.ietf.org/html/rfc7240#section-4.2 +-- | +-- How to return the mutated data. +-- +-- From https://tools.ietf.org/html/rfc7240#section-4.2 data PreferRepresentation = Full -- ^ Return the body plus the Location header(in case of POST). | HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk. @@ -77,26 +165,29 @@ instance ToHeaderValue PreferRepresentation where toHeaderValue None = "return=minimal" toHeaderValue HeadersOnly = "return=headers-only" +-- | How to pass parameters to stored procedures. data PreferParameters - = SingleObject -- ^ Pass all parameters as a single json object to a stored procedure - | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure + = SingleObject -- ^ Pass all parameters as a single json object to a stored procedure. + | MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure. deriving Eq instance ToHeaderValue PreferParameters where toHeaderValue SingleObject = "params=single-object" toHeaderValue MultipleObjects = "params=multiple-objects" +-- | How to determine the count of (expected) results data PreferCount - = ExactCount -- ^ exact count(slower) + = ExactCount -- ^ Exact count (slower). | PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}. - | EstimatedCount -- ^ use the query planner rows if the count is superior to max-rows, otherwise get the exact count. - deriving Eq + | EstimatedCount -- ^ Use the query planner rows if the count is superior to max-rows, otherwise get the exact count. + deriving Eq instance ToHeaderValue PreferCount where toHeaderValue ExactCount = "count=exact" toHeaderValue PlannedCount = "count=planned" toHeaderValue EstimatedCount = "count=estimated" +-- | Whether to commit or roll back transactions. data PreferTransaction = Commit -- ^ Commit transaction - the default. | Rollback -- ^ Rollback transaction after sending the response - does not persist changes, e.g. for running tests. diff --git a/test/doctests/Main.hs b/test/doctests/Main.hs new file mode 100644 index 000000000..86e8fd168 --- /dev/null +++ b/test/doctests/Main.hs @@ -0,0 +1,17 @@ +module Main (main) where + +import Test.DocTest (doctest) + +import Protolude + + +main :: IO () +main = + doctest + [ "--verbose" + , "-XOverloadedStrings" + , "-XNoImplicitPrelude" + , "-XStandaloneDeriving" + , "-isrc" + , "src/PostgREST/Request/Preferences.hs" + ]