Add and/or params for complex boolean logic

* Add support for and/or params in GET, POST, PATCH and DELETE
* Restrict usage of IN in and/or to be inside parens e.g. in.(1,2,3)
* Allow quoting operators for values that have ',)' chars
  inside and/or e.g. eq."(entity,1)"

src/PostgREST/ApiRequest.hs

@@ -86,6 +86,8 @@ data ApiRequest = ApiRequest {
   , 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 @@ userApiRequest schema req reqBody
       , 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

src/PostgREST/DbRequestBuilder.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DuplicateRecordFields    #-}
 module PostgREST.DbRequestBuilder (
   readRequest
 , mutateRequest
@@ -6,6 +7,7 @@ module PostgREST.DbRequestBuilder (
 ) 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,7 +175,8 @@ addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> R
 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
@@ -182,12 +185,13 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
   where
     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
+    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 [(EmbedPath, NonnegRange)]
@@ -211,6 +215,12 @@ addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f
 addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest
 addRange = addProperty addRangeToNode
 
+addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest
+addLogicTreeToNode t (Node (q@Select{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) =
@@ -248,8 +258,8 @@ mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest
 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 @@ mutateRequest apiRequest fldNames = mapLeft apiRequestError $
         _ -> 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) =

src/PostgREST/Parsers.hs

@@ -21,7 +21,7 @@ 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
 
@@ -38,6 +38,15 @@ pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
     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 @@ pReadRequest rootNodeName = do
   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,7 +66,7 @@ pReadRequest rootNodeName = do
         _  -> 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 (EmbedPath, Field)
 pTreePath = do
@@ -119,13 +128,13 @@ pSelect = lexeme $
     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 =
-          ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys notInOps)) <*> pVText)
-      <|> ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys inOps)) <*> pVTextL)
+          ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys notInOps)) <*> parserVText)
+      <|> ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys inOps)) <*> parserVTextL)
       <?> "operator (eq, gt, ...)"
     inOps = M.filterWithKey (const . flip elem ["in", "notin"]) operators
     notInOps = M.difference operators inOps
@@ -137,7 +146,10 @@ pVTextL :: Parser Operand
 pVTextL = VTextL <$> lexeme pLValue `sepBy1` char ','
   where
     pLValue :: Parser Text
-    pLValue = toS <$> (try (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",") ) <|> many (noneOf ","))
+    pLValue = try pQuotedValue <|> (toS <$> many (noneOf ","))
+
+pQuotedValue :: Parser Text
+pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",)"))
 
 pDelimiter :: Parser Char
 pDelimiter = char '.' <?> "delimiter (.)"
@@ -161,6 +173,44 @@ pOrderTerm =
   )
   <|> 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 '(') *> pLValue `sepBy1` char ',' <* lexeme (char ')'))
+  where
+    pLValue :: Parser Text
+    pLValue = try pQuotedValue <|> (toS <$> many (noneOf ",)"))
+
+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
   where

src/PostgREST/QueryBuilder.hs

@@ -194,21 +194,25 @@ pgFmtLit x =
 
 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 +222,8 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions
       "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 +284,7 @@ requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)
         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 +292,22 @@ requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions
       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
@@ -384,8 +391,8 @@ getJoinConditions (Relation t cols ft fcs typ lt lc1 lc2) =
 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"
@@ -439,6 +446,11 @@ pgFmtFilter table (Filter fld (Operation hasNot_ ex)) = notOp <> " " <> case ex
                         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
 pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit x <> pgFmtJsonPath ( Just xs )

src/PostgREST/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields    #-}
 module PostgREST.Types where
 import           Protolude
 import qualified GHC.Show
@@ -157,6 +158,21 @@ operators = M.fromList [
 data Operation = Operation{ hasNot::Bool, expr::(Operator, Operand) } deriving (Eq, Show)
 data Operand = VText Text | VTextL [Text] | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
 
+data LogicOperator = And | Or deriving Eq
+instance Show LogicOperator where
+  show And  = "AND"
+  show Or = "OR"
+{-|
+  Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
+
+            And
+           /   \
+  name.eq.N     Or
+               /  \
+         id.eq.1   id.eq.2
+-}
+data LogicTree = Expr Bool LogicOperator LogicTree LogicTree | Stmnt Filter deriving (Show, Eq)
+
 type FieldName = Text
 type JsonPath = [Text]
 type Field = (FieldName, Maybe JsonPath)
@@ -168,10 +184,10 @@ type SelectItem = (Field, Maybe Cast, Maybe Alias)
 type EmbedPath = [Text]
 data Filter = Filter { field::Field, operation::Operation } deriving (Show, Eq)
 
-data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } 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], returning::[FieldName] }
-                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], returning::[FieldName] } deriving (Show, Eq)
+                 | 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