refactor: Add doctests

.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

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

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-run ${devCabalOptions} test:spec && \
-          ${cabal-install}/bin/cabal v2-test ${devCabalOptions}"
+          ${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

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

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

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
+    prefs = fmap BS.strip . concatMap (BS.split ',' . snd) $ prefHeaders
-    comma = fromIntegral (ord ',')
-    strip = BS.dropWhile (space ==) . BS.dropWhileEnd (space ==)
-    space = fromIntegral (ord ' ')
 
     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
+  = 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
+  | 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.
+  | EstimatedCount -- ^ Use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
- deriving Eq
+  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.

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"
+    ]