postgrest 0.4.1.0 → 0.4.2.0

raw patch · 16 files changed

+581/−232 lines, 16 filesdep +configurator-ngdep +retrydep −configuratorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: configurator-ng, retry

Dependencies removed: configurator

API changes (from Hackage documentation)

Files

• main/Main.hs +70/−16
• postgrest.cabal +4/−2
• src/PostgREST/ApiRequest.hs +4/−1
• src/PostgREST/App.hs +28/−20
• src/PostgREST/Config.hs +31/−30
• src/PostgREST/DbRequestBuilder.hs +31/−17
• src/PostgREST/Error.hs +6/−1
• src/PostgREST/OpenAPI.hs +4/−3
• src/PostgREST/Parsers.hs +72/−23
• src/PostgREST/QueryBuilder.hs +55/−43
• src/PostgREST/Types.hs +42/−64
• test/Feature/AndOrParamsSpec.hs +172/−0
• test/Feature/AuthSpec.hs +2/−2
• test/Feature/QuerySpec.hs +48/−3
• test/Main.hs +9/−7
• test/SpecHelper.hs +3/−0

@@ -12,14 +12,15 @@ import           PostgREST.Error                      (encodeError) import           PostgREST.OpenAPI                    (isMalformedProxyUri) import           PostgREST.DbStructure+import           PostgREST.Types                      (DbStructure, Schema)  import           Control.AutoUpdate+import           Control.Retry import           Data.ByteString.Base64               (decode) import           Data.String                          (IsString (..)) import           Data.Text                            (stripPrefix, pack, replace) import           Data.Text.Encoding                   (encodeUtf8, decodeUtf8) import           Data.Text.IO                         (hPutStrLn, readFile)-import           Data.Function                        (id) import           Data.Time.Clock.POSIX                (getPOSIXTime) import qualified Hasql.Query                          as H import qualified Hasql.Session                        as H@@ -43,6 +44,65 @@     H.statement "SELECT current_setting('server_version_num')::integer"       HE.unit (HD.singleRow $ HD.value HD.int4) False +{-|+  Background thread that does the following :+  1. Tries to connect to pg server and will keep trying until success.+  2. Checks if the pg version is supported and if it's not it kills the main program.+  3. Obtains the dbStructure.+  4. If 2 or 3 fail to give their result it means the connection is down so it goes back to 1,+     otherwise it finishes his work successfully.+-}+connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IORef Bool -> IO ()+connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do+  isWorkerOn <- readIORef refIsWorkerOn+  unless isWorkerOn $ do+    atomicWriteIORef refIsWorkerOn True+    void $ forkIO work+  where+    work = do+      atomicWriteIORef refDbStructure Nothing+      putStrLn ("Attempting to connect to the database..." :: Text)+      connected <- connectingSucceeded pool+      when connected $ do+        result <- P.use pool $ do+          supported <- isServerVersionSupported+          unless supported $ liftIO $ do+            hPutStrLn stderr+              ("Cannot run in this PostgreSQL version, PostgREST needs at least "+              <> pgvName minimumPgVersion)+            killThread mainTid+          dbStructure <- getDbStructure schema+          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)++-- | Connect to pg server if it fails retry with capped exponential backoff until success+connectingSucceeded :: P.Pool -> IO Bool+connectingSucceeded pool =+  retrying (capDelay 32000000 $ exponentialBackoff 1000000)+           shouldRetry+           (const $ P.release pool >> isConnectionSuccessful)+  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+    shouldRetry rs isConnSucc = do+      delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000+      itShould <- pure $ not isConnSucc+      when itShould $+        putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."+      return itShould+ main :: IO () main = do   hSetBuffering stdout LineBuffering@@ -67,31 +127,24 @@    pool <- P.acquire (configPool conf, 10, pgSettings) -  result <- P.use pool $ do-    supported <- isServerVersionSupported-    unless supported $ panic (-      "Cannot run in this PostgreSQL version, PostgREST needs at least "-      <> pgvName minimumPgVersion)-    getDbStructure (toS $ configSchema conf)+  refDbStructure <- newIORef Nothing -  forM_ (lefts [result]) $ \e -> do-    hPutStrLn stderr (toS $ encodeError e)-    exitFailure+  -- Helper ref to make sure just one connectionWorker can run at a time+  refIsWorkerOn <- newIORef False -  refDbStructure <- newIORef $ either (panic . show) id result+  mainTid <- myThreadId +  connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn+ #ifndef mingw32_HOST_OS-  tid <- myThreadId   forM_ [sigINT, sigTERM] $ \sig ->     void $ installHandler sig (Catch $ do         P.release pool-        throwTo tid UserInterrupt+        throwTo mainTid UserInterrupt       ) Nothing    void $ installHandler sigHUP (-      Catch . void . P.use pool $ do-        s <- getDbStructure (toS $ configSchema conf)-        liftIO $ atomicWriteIORef refDbStructure s+      Catch $ connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn    ) Nothing #endif @@ -100,6 +153,7 @@     defaultUpdateSettings { updateAction = getPOSIXTime }    runSettings appSettings $ postgrest conf refDbStructure pool getTime+    (connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn)  loadSecretFile :: AppConfig -> IO AppConfig loadSecretFile conf = extractAndTransform mSecret

@@ -2,7 +2,7 @@ description:           Reads the schema of a PostgreSQL database and creates RESTful routes                        for the tables and views, supporting all HTTP verbs that security                        permits.-version:               0.4.1.0+version:               0.4.2.0 synopsis:              REST API for any Postgres database license:               MIT license-file:          LICENSE@@ -40,6 +40,7 @@                      , warp                      , bytestring                      , base64-bytestring+                     , retry   if !os(windows)     build-depends:     unix @@ -54,7 +55,7 @@                      , bytestring                      , case-insensitive                      , cassava-                     , configurator+                     , configurator-ng == 0.0.0.1                      , containers                      , contravariant                      , either@@ -125,6 +126,7 @@                      , Feature.SingularSpec                      , Feature.StructureSpec                      , Feature.UnicodeSpec+                     , Feature.AndOrParamsSpec                      , SpecHelper                      , TestTypes   Build-Depends:       aeson

@@ -86,6 +86,8 @@   , iPreferCount :: Bool   -- | Filters on the result ("id", "eq.10")   , iFilters :: [(Text, Text)]+  -- | &and and &or parameters used for complex boolean logic+  , iLogic :: [(Text, Text)]   -- | &select parameter used to shape the response   , iSelect :: Text   -- | &order parameters for each level@@ -116,7 +118,8 @@       , iPreferRepresentation = representation       , iPreferSingleObjectParameter = singleObject       , iPreferCount = hasPrefer "count=exact"-      , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ]+      , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ]+      , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]       , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams       , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]       , iCanonicalQS = toS $ urlEncodeVars

@@ -45,6 +45,7 @@ import           PostgREST.Error           ( simpleError, pgError                                            , apiRequestError                                            , singularityError, binaryFieldError+                                           , connectionLostError                                            ) import           PostgREST.RangeQuery      (allRange, rangeOffset) import           PostgREST.Middleware@@ -62,28 +63,34 @@ import           Protolude              hiding (intercalate, Proxy) import           Safe                   (headMay) -postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> IO POSIXTime ->-             Application-postgrest conf refDbStructure pool getTime =+postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO POSIXTime ->+             IO () -> Application+postgrest conf refDbStructure pool getTime worker =   let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in    middle $ \ req respond -> do     time <- getTime     body <- strictRequestBody req-    dbStructure <- readIORef refDbStructure+    maybeDbStructure <- readIORef refDbStructure+    case maybeDbStructure of+      Nothing -> respond connectionLostError+      Just dbStructure -> do+        response <- case userApiRequest (configSchema conf) req body of+          Left err -> return $ apiRequestError err+          Right apiRequest -> do+            let jwtSecret = binarySecret <$> configJwtSecret conf+                eClaims = jwtClaims jwtSecret (iJWT apiRequest) time+                authed = containsRole eClaims+                handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest+                txMode = transactionMode dbStructure+                  (iTarget apiRequest) (iAction apiRequest)+            response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq+            return $ either (pgError authed) identity response+        when (isResponse503 response) worker+        respond response -    response <- case userApiRequest (configSchema conf) req body of-      Left err -> return $ apiRequestError err-      Right apiRequest -> do-        let jwtSecret = binarySecret <$> configJwtSecret conf-            eClaims = jwtClaims jwtSecret (iJWT apiRequest) time-            authed = containsRole eClaims-            handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest-            txMode = transactionMode dbStructure-              (iTarget apiRequest) (iAction apiRequest)-        response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq-        return $ either (pgError authed) identity response-    respond response+isResponse503 :: Response -> Bool+isResponse503 resp = statusCode (responseStatus resp) == 503  transactionMode :: DbStructure -> Target -> Action -> H.Mode transactionMode structure target action =@@ -231,7 +238,9 @@               let p = V.head payload                   singular = contentType == CTSingularJSON                   paramsAsSingleObject = iPreferSingleObjectParameter apiRequest-              row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular paramsAsSingleObject)+              row <- H.query () $+                callProc qi p q cq topLevelRange shouldCount singular+                         paramsAsSingleObject (contentType == CTTextCSV)               let (tableTotal, queryTotal, body) =                     fromMaybe (Just 0, 0, "[]") row                   (status, contentRange) = rangeHeader queryTotal tableTotal@@ -239,7 +248,7 @@                 then do                   HT.condemn                   return $ singularityError (toInteger queryTotal)-                else return $ responseLBS status [jsonH, contentRange] (toS body)+                else return $ responseLBS status [toHeader contentType, contentRange] (toS body)          (ActionInspect, TargetRoot, Nothing) -> do           let host = configHost conf@@ -268,7 +277,6 @@       filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb       allPrKeys = dbPrimaryKeys dbStructure       allOrigins = ("Access-Control-Allow-Origin", "*") :: Header-      jsonH = toHeader CTApplicationJSON       shouldCount = iPreferCount apiRequest       schema = toS $ configSchema conf       topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest@@ -298,7 +306,7 @@         ActionCreate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]         ActionUpdate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]         ActionDelete ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]-        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON]+        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]         ActionInspect -> [CTOpenAPI, CTApplicationJSON]         ActionInfo ->    [CTTextCSV]     serves sProduces cAccepts =

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-} {-| Module      : PostgREST.Config Description : Manages PostgREST configuration options.@@ -27,9 +28,11 @@ import qualified Data.ByteString.Char8       as BS import qualified Data.CaseInsensitive        as CI import qualified Data.Configurator           as C-import qualified Data.Configurator.Types     as C+import qualified Data.Configurator.Parser    as C+import           Data.Configurator.Types     (Value(..)) import           Data.List                   (lookup) import           Data.Monoid+import           Data.Scientific             (floatingOrInteger) import           Data.Text                   (strip, intercalate, lines) import           Data.Text.Encoding          (encodeUtf8) import           Data.Text.IO                (hPutStrLn)@@ -38,6 +41,7 @@ import           Network.Wai.Middleware.Cors (CorsResourcePolicy (..)) import           Options.Applicative hiding  (str) import           Paths_postgrest             (version)+import           System.IO                   (hPrint) import           Text.Heredoc import           Text.PrettyPrint.ANSI.Leijen hiding ((<>), (<$>)) import qualified Text.PrettyPrint.ANSI.Leijen as L@@ -95,30 +99,37 @@   cfgPath <- customExecParser parserPrefs opts   -- Now read the actual config file   conf <- catch-    (C.load [C.Required cfgPath])+    (C.readConfig =<< C.load [C.Required cfgPath])     configNotfoundHint -  handle missingKeyHint $ do-    -- db -----------------    cDbUri    <- C.require conf "db-uri"-    cDbSchema <- C.require conf "db-schema"-    cDbAnon   <- C.require conf "db-anon-role"-    cPool     <- C.lookupDefault 10 conf "db-pool"-    -- server -------------    cHost     <- C.lookupDefault "*4" conf "server-host"-    cPort     <- C.lookupDefault 3000 conf "server-port"-    cProxy    <- C.lookup conf "server-proxy-uri"-    -- jwt ----------------    cJwtSec   <- C.lookup conf "jwt-secret"-    cJwtB64   <- C.lookupDefault False conf "secret-is-base64"-    -- safety -------------    cMaxRows  <- C.lookup conf "max-rows"-    cReqCheck <- C.lookup conf "pre-request"+  let (mAppConf, errs) = flip C.runParserA conf $+        AppConfig <$>+            C.key "db-uri"+          <*> C.key "db-anon-role"+          <*> C.key "server-proxy-uri"+          <*> C.key "db-schema"+          <*> (fromMaybe "*4" <$> C.key "server-host")+          <*> (fromMaybe 3000 . join . fmap coerceInt <$> C.key "server-port")+          <*> (fmap encodeUtf8 . mfilter (/= "") <$> C.key "jwt-secret")+          <*> (fromMaybe False <$> C.key "secret-is-base64")+          <*> (fromMaybe 10 . join . fmap coerceInt <$> C.key "db-pool")+          <*> (join . fmap coerceInt <$> C.key "max-rows")+          <*> C.key "pre-request"+          <*> pure False -    return $ AppConfig cDbUri cDbAnon cProxy cDbSchema cHost cPort-          (encodeUtf8 <$> cJwtSec) cJwtB64 cPool cMaxRows cReqCheck False+  case mAppConf of+    Nothing -> do+      forM_ errs $ hPrint stderr+      exitFailure+    Just appConf ->+      return appConf   where+  coerceInt :: (Read i, Integral i) => Value -> Maybe i+  coerceInt (Number x) = rightToMaybe $ floatingOrInteger x+  coerceInt (String x) = readMaybe $ toS x+  coerceInt _ = Nothing+   opts = info (helper <*> pathParser) $            fullDesc            <> progDesc (@@ -139,15 +150,6 @@       "Cannot open config file:\n\t" <> show e     exitFailure -  missingKeyHint :: C.KeyError -> IO a-  missingKeyHint (C.KeyError n) = do-    hPutStrLn stderr $-      "Required config parameter \"" <> n <> "\" is missing or of wrong type.\n" <>-      "Documentation for configuration options available at\n" <>-      "\thttp://postgrest.com/en/v0.4/admin.html#configuration\n\n" <>-      "Try the --example-config option to see how to configure PostgREST."-    exitFailure-   exampleCfg :: Doc   exampleCfg = vsep . map (text . toS) . lines $     [str|db-uri = "postgres://user:pass@localhost:5432/dbname"@@ -172,7 +174,6 @@         |## stored proc to exec immediately after auth         |# pre-request = "stored_proc_name"         |]-  pathParser :: Parser FilePath pathParser =

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DuplicateRecordFields    #-} module PostgREST.DbRequestBuilder (   readRequest , mutateRequest@@ -6,6 +7,7 @@ ) where  import           Control.Applicative+import           Control.Arrow             ((***)) import           Control.Lens.Getter       (view) import           Control.Lens.Tuple        (_1) import qualified Data.ByteString.Char8     as BS@@ -173,45 +175,53 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [     flip (foldr addFilter) <$> filters,     flip (foldr addOrder) <$> orders,-    flip (foldr addRange) <$> ranges+    flip (foldr addRange) <$> ranges,+    flip (foldr addLogicTree) <$> logicForest   ]   {-   The esence of what is going on above is that we are composing tree functions   of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context   -}   where-    filters :: Either ApiRequestError [(Path, Filter)]+    filters :: Either ApiRequestError [(EmbedPath, Filter)]     filters = mapM pRequestFilter flts-      where-        action = iAction apiRequest-        flts-          | action == ActionRead = iFilters apiRequest-          | action == ActionInvoke = iFilters apiRequest-          | otherwise = filter (( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update-    orders :: Either ApiRequestError [(Path, [OrderTerm])]+    logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)]+    logicForest = mapM pRequestLogicTree logFrst+    action = iAction apiRequest+    -- there can be no filters on the root table when we are doing insert/update/delete+    (flts, logFrst)+      | action == ActionRead || action == ActionInvoke = (iFilters apiRequest, iLogic apiRequest)+      | otherwise = join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)+    orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]     orders = mapM pRequestOrder $ iOrder apiRequest-    ranges :: Either ApiRequestError [(Path, NonnegRange)]+    ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]     ranges = mapM pRequestRange $ M.toList $ iRange apiRequest  addFilterToNode :: Filter -> ReadRequest -> ReadRequest addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f -addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest+addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest addFilter = addProperty addFilterToNode  addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f -addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest+addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest addOrder = addProperty addOrderToNode  addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f -addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest+addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest addRange = addProperty addRangeToNode -addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest+addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest+addLogicTreeToNode t (Node (q@Select{logic=l},i) f) = Node (q{logic=t:l}::ReadQuery, i) f++addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest+addLogicTree = addProperty addLogicTreeToNode++addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest addProperty f ([], a) n = f a n addProperty f (path, a) (Node rn forest) =   case targetNode of@@ -248,8 +258,8 @@ mutateRequest apiRequest fldNames = mapLeft apiRequestError $   case action of     ActionCreate -> Right $ Insert rootTableName payload returnings-    ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings-    ActionDelete -> Delete rootTableName <$> filters <*> pure returnings+    ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> logic_ <*> pure returnings+    ActionDelete -> Delete rootTableName <$> filters <*> logic_ <*> pure returnings     _        -> Left UnsupportedVerb   where     action = iAction apiRequest@@ -261,7 +271,11 @@         _ -> undefined     returnings = if iPreferRepresentation apiRequest == None then [] else fldNames     filters = map snd <$> mapM pRequestFilter mutateFilters-      where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table+    logic_ = map snd <$> mapM pRequestLogicTree logicFilters+    -- update/delete filters can be only on the root table+    mutateFilters = onlyRoot $ iFilters apiRequest+    logicFilters = onlyRoot $ iLogic apiRequest+    onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)  fieldNames :: ReadRequest -> [FieldName] fieldNames (Node (sel, _) forest) =

@@ -8,6 +8,7 @@ , simpleError , singularityError , binaryFieldError+, connectionLostError , encodeError ) where @@ -73,6 +74,10 @@   simpleError HT.status406 (toS (toMime CTOctetStream) <>   " requested but a single column was not selected") +connectionLostError :: Response+connectionLostError =+  simpleError HT.status503 "Database connection lost, retrying the connection."+ encodeError :: JSON.ToJSON a => a -> LByteString encodeError = JSON.encode @@ -128,7 +133,7 @@     "details" .= (fmap toS d::Maybe Text)]  httpStatus :: Bool -> P.UsageError -> HT.Status-httpStatus _ (P.ConnectionError _) = HT.status500+httpStatus _ (P.ConnectionError _) = HT.status503 httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =   case toS c of     '0':'8':_ -> HT.status503 -- pg connection err

@@ -8,11 +8,12 @@  import           Control.Lens import           Data.Aeson                  (decode, encode)+import qualified Data.HashMap.Strict         as M import           Data.HashMap.Strict.InsOrd  (InsOrdHashMap, fromList) import           Data.Maybe                  (fromJust)+import qualified Data.Set                    as Set import           Data.String                 (IsString (..)) import           Data.Text                   (unpack, pack, concat, intercalate, init, tail, toLower)-import qualified Data.Set                    as Set import           Network.URI                 (parseURI, isAbsoluteURI,                                               URI (..), URIAuth (..)) @@ -23,7 +24,7 @@ import           PostgREST.ApiRequest        (ContentType(..)) import           PostgREST.Config            (prettyVersion) import           PostgREST.Types             (Table(..), Column(..), PgArg(..),-                                              Proxy(..), ProcDescription(..), toMime, Operator(..))+                                              Proxy(..), ProcDescription(..), toMime, operators)  makeMimeList :: [ContentType] -> MimeList makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs@@ -72,7 +73,7 @@   intercalate "|"   [ concat ["^", x, y, "[.]"] |     x <- ["not[.]", ""],-    y <- map show [Equals ..] ]+    y <- M.keys operators ]  makeRowFilter :: Column -> Param makeRowFilter c =

@@ -1,43 +1,52 @@ module PostgREST.Parsers where  import           Protolude                     hiding (try, intercalate)-import           Control.Monad                ((>>))-import           Data.Foldable                (foldl1)+import           Control.Monad                 ((>>))+import           Data.Foldable                 (foldl1)+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,allRange) import           PostgREST.Types import           Text.ParserCombinators.Parsec hiding (many, (<|>))-import           Text.Read                    (read)-import           PostgREST.RangeQuery      (NonnegRange,allRange) import           Text.Parsec.Error  pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest pRequestSelect rootName selStr =   mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) -pRequestFilter :: (Text, Text) -> Either ApiRequestError (Path, Filter)+pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)   where     treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k-    oper = parse pOperation ("failed to parse filter (" ++ toS v ++ ")") $ toS v+    oper = parse (pOperation pVText pVTextL) ("failed to parse filter (" ++ toS v ++ ")") $ toS v     path = fst <$> treePath     fld = snd <$> treePath -pRequestOrder :: (Text, Text) -> Either ApiRequestError (Path, [OrderTerm])+pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm]) pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'   where     treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k     path = fst <$> treePath     ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v -pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (Path, NonnegRange)+pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange) pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v   where     treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k     path = fst <$> treePath +pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree)+pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree+  where+    path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k+    embedPath = fst <$> path+    op = snd <$> path+    -- Concat op and v to make pLogicTree argument regular, in the form of "op(.,.)"+    logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v)+ ws :: Parser Text ws = toS <$> many (oneOf " \t") @@ -49,7 +58,7 @@   fieldTree <- pFieldForest   return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree   where-    readQuery = Select [] [rootNodeName] [] Nothing allRange+    readQuery = Select [] [rootNodeName] [] [] Nothing allRange     treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest     treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =       case fldForest of@@ -57,9 +66,9 @@         _  -> Node (q, i) newForest           where             newForest =-              foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest+              foldr treeEntry (Node (Select [] [fn] [] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest -pTreePath :: Parser (Path,Field)+pTreePath :: Parser (EmbedPath, Field) pTreePath = do   p <- pFieldName `sepBy1` pDelimiter   jp <- optionMaybe pJsonPath@@ -69,8 +78,9 @@ pFieldForest = pFieldTree `sepBy1` lexeme (char ',')  pFieldTree :: Parser (Tree SelectItem)-pFieldTree = try (Node <$> pSimpleSelect <*> between (char '{') (char '}') pFieldForest)-          <|>     Node <$> pSelect <*> pure []+pFieldTree =  try (Node <$> pSimpleSelect <*> between (char '{') (char '}') pFieldForest)+          <|> try (Node <$> pSimpleSelect <*> between (char '(') (char ')') pFieldForest)+          <|> Node <$> pSelect <*> pure []  pStar :: Parser Text pStar = toS <$> (string "*" *> pure ("*"::ByteString))@@ -119,26 +129,30 @@     s <- pStar     return ((s, Nothing), Nothing, Nothing) -pOperation :: Parser Operation-pOperation = try ( string "not" *> pDelimiter *> (Operation True <$> pExpr)) <|> Operation False <$> pExpr+pOperation :: Parser Operand -> Parser Operand -> Parser Operation+pOperation parserVText parserVTextL = try ( string "not" *> pDelimiter *> (Operation True <$> pExpr)) <|> Operation False <$> pExpr   where     pExpr :: Parser (Operator, Operand)     pExpr =-          ((,) <$> (read <$> foldl1 (<|>) (try . string . show <$> notInOps)) <*> (pDelimiter *> pVText))-      <|> try (string (show In) *> pDelimiter *> ((,) <$> pure In <*> pVTextL))-      <|> try (string (show NotIn) *> pDelimiter *> ((,) <$> pure NotIn <*> pVTextL))+          ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys notInOps)) <*> parserVText)+      <|> ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys inOps)) <*> parserVTextL)       <?> "operator (eq, gt, ...)"-    notInOps = [Equals .. Contained]+    inOps = M.filterWithKey (const . flip elem ["in", "notin"]) operators+    notInOps = M.difference operators inOps  pVText :: Parser Operand pVText = VText . toS <$> many anyChar  pVTextL :: Parser Operand-pVTextL = VTextL <$> pLValue `sepBy1` char ','-  where-    pLValue :: Parser Text-    pLValue = toS <$> (try (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",") ) <|> many (noneOf ","))+pVTextL =     VTextL <$> try (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))+          <|> VTextL <$> lexeme pVTextLElement `sepBy1` char ',' +pVTextLElement :: Parser Text+pVTextLElement = try pQuotedValue <|> (toS <$> many (noneOf ",)"))++pQuotedValue :: Parser Text+pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",)"))+ pDelimiter :: Parser Char pDelimiter = char '.' <?> "delimiter (.)" @@ -160,6 +174,41 @@     return $ OrderTerm c d nls   )   <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing++pLogicTree :: Parser LogicTree+pLogicTree = Stmnt <$> try pLogicFilter+             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree) <*> (lexeme (char ',') *> pLogicTree <* lexeme (char ')'))+  where+    pLogicFilter :: Parser Filter+    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOperation pLogicVText pLogicVTextL+    pNot :: Parser Bool+    pNot = try (string "not" *> pDelimiter *> pure True) +           <|> pure False+           <?> "negation operator (not)"+    pLogicOp :: Parser LogicOperator+    pLogicOp = try (string "and"  *> pure And)+               <|> string "or" *> pure Or+               <?> "logic operator (and, or)"++pLogicVText :: Parser Operand+pLogicVText = VText <$> (try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)")))+  where+    pPgArray :: Parser Text+    pPgArray =  do+      a <- string "{"+      b <- many (noneOf "{}")+      c <- string "}"+      toS <$> pure (a ++ b ++ c)++pLogicVTextL :: Parser Operand+pLogicVTextL = VTextL <$> (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))++pLogicPath :: Parser (EmbedPath, Text)+pLogicPath = do+  path <- pFieldName `sepBy1` pDelimiter+  let op = last path+      notOp = "not." <> op+  return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)  mapError :: Either ParseError a -> Either ApiRequestError a mapError = mapLeft translateError

@@ -144,8 +144,9 @@     | otherwise = asJsonF  type ProcResults = (Maybe Int64, Int64, ByteString)-callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults)-callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson =+callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange ->+  Bool -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults)+callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson asCsv =   unicodeStatement sql HE.unit decodeProc True   where     sql = [qc|@@ -178,6 +179,7 @@                    <*> HD.value HD.bytea     bodyF      | isSingle = asJsonSingleF+     | asCsv = asCsvF      | otherwise = asJsonF  pgFmtIdent :: SqlFragment -> SqlFragment@@ -194,21 +196,25 @@  requestToCountQuery :: Schema -> DbRequest -> SqlQuery requestToCountQuery _ (DbMutate _) = undefined-requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _, _)) _)) =+requestToCountQuery schema (DbRead (Node (Select _ _ conditions logic_ _ _, (mainTbl, _, _)) _)) =  unwords [    "SELECT pg_catalog.count(*)",    "FROM ", fromQi qi,-   ("WHERE " <> intercalate " AND " ( map (pgFmtFilter qi) localConditions )) `emptyOnNull` localConditions+    -- logic_ doesn't not need localFilter filtering because it doesn't have VForeignKey vals+    ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) localConditions ++ map (pgFmtLogicTree qi) logic_))+      `emptyOnFalse` (null conditions && null logic_)    ]  where    qi = removeSourceCTESchema schema mainTbl-   fn Filter{operation=Operation{expr=(_, VText _)}} = True-   fn Filter{operation=Operation{expr=(_, VTextL _)}} = True-   fn Filter{operation=Operation{expr=(_, VForeignKey _ _)}} = False-   localConditions = filter fn conditions+   localFilter :: Filter -> Bool+   localFilter Filter{operation=Operation{expr=(_, val)}} = case val of+    VText _ -> True+    VTextL _ -> True+    VForeignKey _ _ -> False+   localConditions = filter localFilter conditions  requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery-requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) =+requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions logic_ ord range, (nodeName, maybeRelation, _)) forest)) =   query   where     mainTbl = fromMaybe nodeName (tableName . relTable <$> maybeRelation)@@ -218,7 +224,8 @@       "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),       "FROM ", intercalate ", " (map (fromQi . toQi) tbls),       unwords joins,-      ("WHERE " <> intercalate " AND " ( map (pgFmtFilter qi ) conditions )) `emptyOnNull` conditions,+      ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))+        `emptyOnFalse` (null conditions && null logic_),       orderF (fromMaybe [] ord),       if isParent then "" else limitF range       ]@@ -279,7 +286,7 @@         ret = if null returnings                   then ""                   else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)]-requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions returnings)) =+requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions logic_ returnings)) =   case rows V.!? 0 of     Just obj ->       let assignments = map@@ -287,20 +294,22 @@       unwords [         "UPDATE ", fromQi qi,         " SET " <> intercalate "," assignments <> " ",-        ("WHERE " <> intercalate " AND " ( map (pgFmtFilter qi ) conditions )) `emptyOnNull` conditions,-        ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnNull` returnings+        ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))+          `emptyOnFalse` (null conditions && null logic_),+        ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings         ]     Nothing -> undefined   where     qi = QualifiedIdentifier schema mainTbl-requestToQuery schema _ (DbMutate (Delete mainTbl conditions returnings)) =+requestToQuery schema _ (DbMutate (Delete mainTbl conditions logic_ returnings)) =   query   where     qi = QualifiedIdentifier schema mainTbl     query = unwords [       "DELETE FROM ", fromQi qi,-      ("WHERE " <> intercalate " AND " ( map (pgFmtFilter qi ) conditions )) `emptyOnNull` conditions,-      ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnNull` returnings+      ("WHERE " <> intercalate " AND " (map (pgFmtFilter qi) conditions ++ map (pgFmtLogicTree qi) logic_))+        `emptyOnFalse` (null conditions && null logic_),+      ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings       ]  sourceCTEName :: SqlFragment@@ -379,13 +388,13 @@     ftN = tableName ft     ltN = fromMaybe "" (tableName <$> lt)     toFilter :: Text -> Text -> Column -> Column -> Filter-    toFilter tb ftb c fc = Filter (colName c, Nothing) (Operation False (Equals, VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})))+    toFilter tb ftb c fc = Filter (colName c, Nothing) (Operation False ("=", VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})))  unicodeStatement :: Text -> HE.Params a -> HD.Result b -> Bool -> H.Query a b unicodeStatement = H.statement . T.encodeUtf8 -emptyOnNull :: Text -> [a] -> Text-emptyOnNull val x = if null x then "" else val+emptyOnFalse :: Text -> Bool -> Text+emptyOnFalse val cond = if cond then "" else val  insertableValue :: JSON.Value -> SqlFragment insertableValue JSON.Null = "null"@@ -407,39 +416,42 @@ pgFmtSelectItem table (f@(_, jp), Just cast, alias) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> pgFmtAs jp alias  pgFmtFilter :: QualifiedIdentifier -> Filter -> SqlFragment-pgFmtFilter table (Filter fld (Operation hasNot_ ex@(op, operand))) = notOp <> " " <> case operand of-  VForeignKey fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName}) ->-    pgFmtField fQi fld <> " " <> opToSqlFragment op <> " " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName-  _ -> pgFmtField table fld <> " " <> pgFmtExpr ex-  where-    notOp = if hasNot_ then "NOT" else ""--pgFmtExpr :: (Operator, Operand) -> SqlFragment-pgFmtExpr ex =- case ex of-   (Like, VText val)    -> opToSqlFragment Like <> " " <> unknownLiteral (T.map star val)-   (ILike, VText val)   -> opToSqlFragment ILike <> " " <> unknownLiteral (T.map star val)-   (TSearch, VText val) -> opToSqlFragment TSearch <> " " <> "to_tsquery(" <> unknownLiteral val <> ") "-   (Is, VText val)      -> opToSqlFragment Is <> " " <> whiteList val-   (In, VTextL vals)    -> exprForIn vals-   (NotIn, VTextL vals) -> opToSqlFragment NotIn <> " " <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "-   (op, VText val)      -> opToSqlFragment op <> " " <> unknownLiteral val-   _ -> "" -- should not happen, all possible combinations are defined in Parsers+pgFmtFilter table (Filter fld (Operation hasNot_ ex)) = notOp <> " " <> case ex of+   (op, VText val) -> pgFmtFieldOp op <> " " <> case op of+     "like"  -> unknownLiteral (T.map star val)+     "ilike" -> unknownLiteral (T.map star val)+     "@@"    -> "to_tsquery(" <> unknownLiteral val <> ") "+     "is"    -> whiteList val+     "isnot" -> whiteList val+     _       -> unknownLiteral val+   (op, VTextL vals) -> pgFmtIn op vals -- in and notin+   (op, VForeignKey fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName})) ->+     pgFmtField fQi fld <> " " <> sqlOperator op <> " " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName  where+   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op+   sqlOperator o = HM.lookupDefault "=" o operators+   notOp = if hasNot_ then "NOT" else ""    star c = if c == '*' then '%' else c    unknownLiteral = (<> "::unknown ") . pgFmtLit    whiteList :: Text -> SqlFragment    whiteList v = fromMaybe      (toS (pgFmtLit v) <> "::unknown ")      (find ((==) . toLower $ v) ["null","true","false"])-   exprForIn :: [Text] -> SqlFragment-   exprForIn vals =-    let emptyValForIn = "= any('{}') " in+   pgFmtIn :: Operator -> [Text] -> SqlFragment+   pgFmtIn op vals =+    -- Workaround because for postgresql "col IN ()" is invalid syntax, we instead do "col = any('{}')"+    let emptyValForIn o = (if "not" `isInfixOf` o then "NOT " else "") -- handle case of "notin" operator+                          <> pgFmtField table fld <> " = any('{}') " in     case T.null <$> headMay vals of       Just isNull -> if isNull && length vals == 1-                        then emptyValForIn-                        else opToSqlFragment In <> " " <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "-      Nothing -> emptyValForIn+                        then emptyValForIn op+                        else pgFmtFieldOp op <> "(" <> intercalate ", " (map unknownLiteral vals) <> ") "+      Nothing -> emptyValForIn op++pgFmtLogicTree :: QualifiedIdentifier -> LogicTree -> SqlFragment+pgFmtLogicTree qi (Expr hasNot_ op lt rt) = notOp <> " (" <> pgFmtLogicTree qi lt <> " " <> show op <> " " <> pgFmtLogicTree qi rt <> ")"+  where notOp =  if hasNot_ then "NOT" else ""+pgFmtLogicTree qi (Stmnt flt) = pgFmtFilter qi flt  pgFmtJsonPath :: Maybe JsonPath -> SqlFragment pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x

@@ -1,10 +1,10 @@+{-# LANGUAGE DuplicateRecordFields    #-} module PostgREST.Types where import           Protolude import qualified GHC.Show-import qualified GHC.Read import           Data.Aeson import qualified Data.ByteString.Lazy as BL-import           Data.HashMap.Strict  as M+import qualified Data.HashMap.Strict  as M import           Data.Tree import qualified Data.Vector          as V import           PostgREST.RangeQuery (NonnegRange)@@ -137,66 +137,42 @@ , proxyPath       :: Text } deriving (Show, Eq) -data Operator = Equals | Gte | Gt | Lte | Lt | Neq | Like | ILike | Is | IsNot |-                TSearch | Contains | Contained | In | NotIn deriving (Eq, Enum)--instance Show Operator where-  show op =  case op of-    Equals -> "eq"-    Gte -> "gte"-    Gt -> "gt"-    Lte -> "lte"-    Lt -> "lt"-    Neq -> "neq"-    Like -> "like"-    ILike -> "ilike"-    In -> "in"-    NotIn -> "notin"-    IsNot -> "isnot"-    Is -> "is"-    TSearch -> "@@"-    Contains -> "@>"-    Contained -> "<@"+type Operator = Text+operators :: M.HashMap Operator SqlFragment+operators = M.fromList [+  ("eq", "="),+  ("gte", ">="),+  ("gt", ">"),+  ("lte", "<="),+  ("lt", "<"),+  ("neq", "<>"),+  ("like", "LIKE"),+  ("ilike", "ILIKE"),+  ("in", "IN"),+  ("notin", "NOT IN"),+  ("isnot", "IS NOT"),+  ("is", "IS"),+  ("@@", "@@"),+  ("@>", "@>"),+  ("<@", "<@")]+data Operation = Operation{ hasNot::Bool, expr::(Operator, Operand) } deriving (Eq, Show)+data Operand = VText Text | VTextL [Text] | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq) -instance Read Operator where-  readsPrec _ op =  case op of-    "eq" -> [(Equals, "")]-    "gte" -> [(Gte, "")]-    "gt" -> [(Gt, "")]-    "lte" -> [(Lte, "")]-    "lt" -> [(Lt, "")]-    "neq" -> [(Neq, "")]-    "like" -> [(Like, "")]-    "ilike" -> [(ILike, "")]-    "in" -> [(In, "")]-    "notin" -> [(NotIn, "")]-    "isnot" -> [(IsNot, "")]-    "is" -> [(Is, "")]-    "@@" -> [(TSearch, "")]-    "@>" -> [(Contains, "")]-    "<@" -> [(Contained, "")]-    _ -> []+data LogicOperator = And | Or deriving Eq+instance Show LogicOperator where+  show And  = "AND"+  show Or = "OR"+{-|+  Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is: -opToSqlFragment :: Operator -> SqlFragment-opToSqlFragment op = case op of-  Equals -> "="-  Gte -> ">="-  Gt -> ">"-  Lte -> "<="-  Lt -> "<"-  Neq -> "<>"-  Like -> "LIKE"-  ILike -> "ILIKE"-  In -> "IN"-  NotIn -> "NOT IN"-  IsNot -> "IS NOT"-  Is -> "IS"-  TSearch -> "@@"-  Contains -> "@>"-  Contained -> "<@"+            And+           /   \+  name.eq.N     Or+               /  \+         id.eq.1   id.eq.2+-}+data LogicTree = Expr Bool LogicOperator LogicTree LogicTree | Stmnt Filter deriving (Show, Eq) -data Operation = Operation{ hasNot::Bool, expr::(Operator, Operand) } deriving (Eq, Show)-data Operand = VText Text | VTextL [Text] | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq) type FieldName = Text type JsonPath = [Text] type Field = (FieldName, Maybe JsonPath)@@ -204,12 +180,14 @@ type Cast = Text type NodeName = Text type SelectItem = (Field, Maybe Cast, Maybe Alias)-type Path = [Text]-data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)-data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }-                 | Delete { in_::TableName, where_::[Filter], returning::[FieldName] }-                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], returning::[FieldName] } deriving (Show, Eq)+-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path ["clients", "projects"]+type EmbedPath = [Text] data Filter = Filter { field::Field, operation::Operation } deriving (Show, Eq)++data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], logic::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)+data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }+                 | Delete { in_::TableName, where_::[Filter], logic::[LogicTree], returning::[FieldName] }+                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], logic::[LogicTree], returning::[FieldName] } deriving (Show, Eq) type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) type ReadRequest = Tree ReadNode type MutateRequest = MutateQuery

@@ -0,0 +1,172 @@+module Feature.AndOrParamsSpec where+import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON+import Network.HTTP.Types++import Network.Wai (Application)++import SpecHelper+import Protolude hiding (get)+++spec :: SpecWith Application+spec =+  describe "and/or params used for complex boolean logic" $ do+    context "used with GET" $ do+      context "or param" $ do+        it "can do simple logic" $+          get "/entities?or=(id.eq.1,id.eq.2)&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can negate simple logic" $+          get "/entities?not.or=(id.eq.1,id.eq.2)&select=id" `shouldRespondWith`+            [json|[{ "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can be combined with traditional filters" $+          get "/entities?or=(id.eq.1,id.eq.2)&name=eq.entity 1&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }++      context "embedded levels" $ do+        it "can do logic on the second level" $+          get "/entities?child_entities.or=(id.eq.1,name.eq.child entity 2)&select=id,child_entities{id}" `shouldRespondWith`+            [json|[+              {"id": 1, "child_entities": [ { "id": 1 }, { "id": 2 } ] }, { "id": 2, "child_entities": []},+              {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []}+            ]|] { matchHeaders = [matchContentTypeJson] }+        it "can do logic on the third level" $+          get "/entities?child_entities.grandchild_entities.or=(id.eq.1,id.eq.2)&select=id,child_entities{id,grandchild_entities{id}}" `shouldRespondWith`+            [json|[+              {"id": 1, "child_entities": [ { "id": 1, "grandchild_entities": [ { "id": 1 }, { "id": 2 } ]}, { "id": 2, "grandchild_entities": []}]},+              {"id": 2, "child_entities": [ { "id": 3, "grandchild_entities": []} ]},+              {"id": 3, "child_entities": []}, {"id": 4, "child_entities": []}+            ]|] { matchHeaders = [matchContentTypeJson] }++      context "and/or params combined" $ do+        it "can be nested inside the same expression" $+          get "/entities?or=(and(name.eq.entity 2,id.eq.2),and(name.eq.entity 1,id.eq.1))&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can be negated while nested" $+          get "/entities?or=(not.and(name.eq.entity 2,id.eq.2),not.and(name.eq.entity 1,id.eq.1))&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can be combined unnested" $+          get "/entities?and=(id.eq.1,name.eq.entity 1)&or=(id.eq.1,id.eq.2)&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }++      context "operators inside and/or" $ do+        it "can handle eq and neq" $+          get "/entities?and=(id.eq.1,id.neq.2))&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can handle lt and gt" $+          get "/entities?or=(id.lt.2,id.gt.3)&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can handle lte and gte" $+          get "/entities?or=(id.lte.2,id.gte.3)&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can handle like and ilike" $+          get "/entities?or=(name.like.*1,name.ilike.*ENTITY 2)&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can handle in" $+          get "/entities?or=(id.in.(1,2),id.in.(3,4))&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can handle is" $+          get "/entities?and=(name.is.null,arr.is.null)&select=id" `shouldRespondWith`+            [json|[{ "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can handle @@" $+          get "/entities?or=(text_search_vector.@@.bar,text_search_vector.@@.baz)&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 2 }]|] { matchHeaders = [matchContentTypeJson] }+        it "can handle @> and <@" $+          get "/entities?or=(arr.@>.{1,2,3},arr.<@.{1})&select=id" `shouldRespondWith`+            [json|[{ "id": 1 },{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }+        context "operators with not" $ do+          it "eq, @>, like can be negated" $+            get "/entities?and=(arr.not.@>.{1,2,3},and(id.not.eq.2,name.not.like.*3))&select=id" `shouldRespondWith`+              [json|[{ "id": 1}]|] { matchHeaders = [matchContentTypeJson] }+          it "in, is, @@ can be negated" $+            get "/entities?and=(id.not.in.(1,3),and(name.not.is.null,text_search_vector.not.@@.foo))&select=id" `shouldRespondWith`+              [json|[{ "id": 2}]|] { matchHeaders = [matchContentTypeJson] }+          it "lt, gte, <@ can be negated" $+            get "/entities?and=(arr.not.<@.{1},or(id.not.lt.1,id.not.gte.3))&select=id" `shouldRespondWith`+              [json|[{"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }+          it "gt, lte, ilike can be negated" $+            get "/entities?and=(name.not.ilike.*ITY2,or(id.not.gt.4,id.not.lte.1))&select=id" `shouldRespondWith`+              [json|[{"id": 1}, {"id": 2}, {"id": 3}]|] { matchHeaders = [matchContentTypeJson] }++      context "and/or params with quotes" $ do+        it "eq can have quotes" $+          get "/grandchild_entities?or=(name.eq.\"(grandchild,entity,4)\",name.eq.\"(grandchild,entity,5)\")&select=id" `shouldRespondWith`+            [json|[{ "id": 4 }, { "id": 5 }]|] { matchHeaders = [matchContentTypeJson] }+        it "like and ilike can have quotes" $+          get "/grandchild_entities?or=(name.like.\"*ity,4*\",name.ilike.\"*ITY,5)\")&select=id" `shouldRespondWith`+            [json|[{ "id": 4 }, { "id": 5 }]|] { matchHeaders = [matchContentTypeJson] }+        it "in can have quotes" $+          get "/grandchild_entities?or=(id.in.(\"1\",\"2\"),id.in.(\"3\",\"4\"))&select=id" `shouldRespondWith`+            [json|[{ "id": 1 }, { "id": 2 }, { "id": 3 }, { "id": 4 }]|] { matchHeaders = [matchContentTypeJson] }++      it "allows whitespace" $+        get "/entities?and=( and ( id.in.( 1, 2, 3 ) , id.eq.3 ) , or ( id.eq.2 , id.eq.3 ) )&select=id" `shouldRespondWith`+          [json|[{ "id": 3 }]|] { matchHeaders = [matchContentTypeJson] }++    context "used with POST" $+      it "includes related data with filters" $+        request methodPost "/child_entities?entities.or=(id.eq.2,id.eq.3)&select=id,entities{id}"+          [("Prefer", "return=representation")]+          [json|[{"id":4,"name":"entity 4","parent_id":1},+                 {"id":5,"name":"entity 5","parent_id":2},+                 {"id":6,"name":"entity 6","parent_id":3}]|] `shouldRespondWith`+          [json|[{"id": 4, "entities":null}, {"id": 5, "entities": {"id": 2}}, {"id": 6, "entities": {"id": 3}}]|]+          { matchStatus = 201, matchHeaders = [matchContentTypeJson] }++    context "used with PATCH" $+      it "succeeds when using and/or params" $+        request methodPatch "/grandchild_entities?or=(id.eq.1,id.eq.2)&select=id,name"+          [("Prefer", "return=representation")]+          [json|{ name : "updated grandchild entity"}|] `shouldRespondWith`+          [json|[{ "id": 1, "name" : "updated grandchild entity"},{ "id": 2, "name" : "updated grandchild entity"}]|]+          { matchHeaders = [matchContentTypeJson] }++    context "used with DELETE" $+      it "succeeds when using and/or params" $+        request methodDelete "/grandchild_entities?or=(id.eq.1,id.eq.2)&select=id,name"+          [("Prefer", "return=representation")] "" `shouldRespondWith`+          [json|[{ "id": 1, "name" : "updated grandchild entity"},{ "id": 2, "name" : "updated grandchild entity"}]|]+          { matchHeaders = [matchContentTypeJson] }++    it "can query columns that begin with and/or reserved words" $+      get "/grandchild_entities?or=(and_starting_col.eq.smth, or_starting_col.eq.smth)" `shouldRespondWith` 200++    it "can query jsonb columns" $+      get "/grandchild_entities?or=(jsonb_col->a->>b.eq.foo, jsonb_col->>b.eq.bar)&select=id" `shouldRespondWith`+        [json|[{id: 4}, {id: 5}]|] { matchStatus = 200, matchHeaders = [matchContentTypeJson] }++    it "fails when using IN without () and provides meaningful error message" $+      get "/entities?or=(id.in.1,2,id.eq.3)" `shouldRespondWith`+        [json|{+          "details": "unexpected \"1\" expecting \"(\"",+          "message": "\"failed to parse logic tree ((id.in.1,2,id.eq.3))\" (line 1, column 10)"+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }++    it "fails on malformed query params and provides meaningful error message" $ do+      get "/entities?or=()" `shouldRespondWith`+        [json|{+          "details": "unexpected \")\" expecting field name (* or [a..z0..9_]), negation operator (not) or logic operator (and, or)",+          "message": "\"failed to parse logic tree (())\" (line 1, column 4)"+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }+      get "/entities?or=)(" `shouldRespondWith`+        [json|{+          "details": "unexpected \")\" expecting \"(\"",+          "message": "\"failed to parse logic tree ()()\" (line 1, column 3)"+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }+      get "/entities?or=(id.eq.1)" `shouldRespondWith`+        [json|{+          "details": "unexpected \")\" expecting \",\"",+          "message": "\"failed to parse logic tree ((id.eq.1))\" (line 1, column 11)"+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }+      get "/entities?and=(ord(id.eq.1,id.eq.1),id.eq.2)" `shouldRespondWith`+        [json|{+          "details": "unexpected \"d\" expecting \"(\"",+          "message": "\"failed to parse logic tree ((ord(id.eq.1,id.eq.1),id.eq.2))\" (line 1, column 7)"+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }+      get "/entities?or=(id.eq.1,not.xor(id.eq.2,id.eq.3))" `shouldRespondWith`+        [json|{+          "details": "unexpected \"x\" expecting logic operator (and, or)",+          "message": "\"failed to parse logic tree ((id.eq.1,not.xor(id.eq.2,id.eq.3)))\" (line 1, column 16)"+        }|] { matchStatus = 400, matchHeaders = [matchContentTypeJson] }

@@ -44,14 +44,14 @@       [json| { "id": "jdoe", "pass": "1234" } |]       `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xuYW1lIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.P2G9EVSVI22MWxXWFuhEYd9BZerLS1WDlqzdqplM15s"} |]         { matchStatus = 200-        , matchHeaders = [matchContentTypeJson]+        , matchHeaders = [matchContentTypeSingular]         }    it "sql functions can encode custom and standard claims" $     request methodPost  "/rpc/jwt_test" [single] "{}"       `shouldRespondWith` [json| {"token":"eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpc3MiOiJqb2UiLCJzdWIiOiJmdW4iLCJhdWQiOiJldmVyeW9uZSIsImV4cCI6MTMwMDgxOTM4MCwibmJmIjoxMzAwODE5MzgwLCJpYXQiOjEzMDA4MTkzODAsImp0aSI6ImZvbyIsInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdCIsImh0dHA6Ly9wb3N0Z3Jlc3QuY29tL2ZvbyI6dHJ1ZX0.IHF16ZSU6XTbOnUWO8CCpUn2fJwt8P00rlYVyXQjpWc"} |]         { matchStatus = 200-        , matchHeaders = [matchContentTypeJson]+        , matchHeaders = [matchContentTypeSingular]         }    it "sql functions can read custom and standard claims variables" $ do

@@ -487,6 +487,15 @@           [json| [ {"id": 3}, {"id":4} ] |]           { matchHeaders = [matchContentTypeJson] } +      it "returns CSV" $+        request methodPost "/rpc/getitemrange"+                (acceptHdrs "text/csv")+                [json| { "min": 2, "max": 4 } |]+           `shouldRespondWith` "id\n3\n4"+            { matchStatus = 200+            , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8"]+            }+     context "unknown function" $       it "returns 404" $         post "/rpc/fakefunc" [json| {} |] `shouldRespondWith` 404@@ -772,8 +781,8 @@       get "/w_or_wo_comma_names?name=in.Williams\"Hebdon, John\"" `shouldRespondWith`         [json| [] |] { matchHeaders = [matchContentTypeJson] } -  describe "IN empty set" $ do-    context "returns an empty result set when no value is present" $ do+  describe "IN and NOT IN empty set" $ do+    context "returns an empty result for IN when no value is present" $ do       it "works for integer" $         get "/items_with_different_col_types?int_data=in." `shouldRespondWith`           [json| [] |] { matchHeaders = [matchContentTypeJson] }@@ -799,8 +808,44 @@         get "/items_with_different_col_types?time_data=in." `shouldRespondWith`           [json| [] |] { matchHeaders = [matchContentTypeJson] } +    it "returns all results for notin when no value is present" $+      get "/items_with_different_col_types?int_data=notin.&select=int_data" `shouldRespondWith`+        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }++    it "returns all results for not.in when no value is present" $+      get "/items_with_different_col_types?int_data=not.in.&select=int_data" `shouldRespondWith`+        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }+     it "returns an empty result ignoring spaces" $-      get "/items_with_different_col_types?int_data=in.    " `shouldRespondWith` 400+      get "/items_with_different_col_types?int_data=in.    " `shouldRespondWith`+        [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++    it "returns empty result when the in value is empty between parentheses" $+      get "/items_with_different_col_types?int_data=in.()" `shouldRespondWith`+        [json| [] |] { matchHeaders = [matchContentTypeJson] }++    it "returns all results when the notin value is empty between parentheses" $ do+      get "/items_with_different_col_types?int_data=notin.()&select=int_data" `shouldRespondWith`+        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }+      get "/items_with_different_col_types?int_data=not.in.()&select=int_data" `shouldRespondWith`+        [json| [{int_data: 1}] |] { matchHeaders = [matchContentTypeJson] }++  describe "Transition to url safe characters" $ do+    context "top level in operator" $ do+      it "works with parentheses" $+        get "/entities?id=in.(1,2,3)&select=id" `shouldRespondWith`+          [json| [{"id": 1}, {"id": 2}, {"id": 3}] |] { matchHeaders = [matchContentTypeJson] }+      it "works without parentheses" $+        get "/entities?id=in.1,2,3&select=id" `shouldRespondWith`+          [json| [{"id": 1}, {"id": 2}, {"id": 3}] |] { matchHeaders = [matchContentTypeJson] }++    context "select query param" $ do+      it "works with parentheses" $+        get "/entities?id=eq.2&select=id,child_entities(id)" `shouldRespondWith`+          [json| [{"id": 2, "child_entities": [{"id": 3}]}] |] { matchHeaders = [matchContentTypeJson] }+      it "works with brackets" $+        get "/entities?id=eq.2&select=id,child_entities{id}" `shouldRespondWith`+          [json| [{"id": 2, "child_entities": [{"id": 3}]}] |] { matchHeaders = [matchContentTypeJson] }

@@ -26,6 +26,7 @@ import qualified Feature.SingularSpec import qualified Feature.UnicodeSpec import qualified Feature.ProxySpec+import qualified Feature.AndOrParamsSpec  import Protolude @@ -41,13 +42,13 @@     result <- P.use pool $ getDbStructure "test"-  refDbStructure <- newIORef $ either (panic.show) id result-  let withApp      = return $ postgrest (testCfg testDbConn)          refDbStructure pool getTime-      ltdApp       = return $ postgrest (testLtdRowsCfg testDbConn)   refDbStructure pool getTime-      unicodeApp   = return $ postgrest (testUnicodeCfg testDbConn)   refDbStructure pool getTime-      proxyApp     = return $ postgrest (testProxyCfg testDbConn)     refDbStructure pool getTime-      noJwtApp     = return $ postgrest (testCfgNoJWT testDbConn)     refDbStructure pool getTime-      binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime+  refDbStructure <- newIORef $ Just $ either (panic.show) id result+  let withApp      = return $ postgrest (testCfg testDbConn)          refDbStructure pool getTime $ pure ()+      ltdApp       = return $ postgrest (testLtdRowsCfg testDbConn)   refDbStructure pool getTime $ pure ()+      unicodeApp   = return $ postgrest (testUnicodeCfg testDbConn)   refDbStructure pool getTime $ pure ()+      proxyApp     = return $ postgrest (testProxyCfg testDbConn)     refDbStructure pool getTime $ pure ()+      noJwtApp     = return $ postgrest (testCfgNoJWT testDbConn)     refDbStructure pool getTime $ pure ()+      binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime $ pure ()    let reset = resetDb testDbConn   hspec $ do@@ -84,4 +85,5 @@     , ("Feature.RangeSpec"        , Feature.RangeSpec.spec)     , ("Feature.SingularSpec"     , Feature.SingularSpec.spec)     , ("Feature.StructureSpec"    , Feature.StructureSpec.spec)+    , ("Feature.AndOrParamsSpec"  , Feature.AndOrParamsSpec.spec)     ]

@@ -32,6 +32,9 @@ matchContentTypeJson :: MatchHeader matchContentTypeJson = "Content-Type" <:> "application/json; charset=utf-8" +matchContentTypeSingular :: MatchHeader+matchContentTypeSingular = "Content-Type" <:> "application/vnd.pgrst.object+json; charset=utf-8"+ validateOpenApiResponse :: [Header] -> WaiSession () validateOpenApiResponse headers = do   r <- request methodGet "/" headers ""