Allow dictionary and plain/phrase in fts

2017-09-08 19:56:00 -05:00
parent d98a05023d
commit dff4d766a8
7 changed files with 175 additions and 65 deletions
@@ -1,6 +1,6 @@
 module PostgREST.Parsers where

-import           Protolude                     hiding (try, intercalate, replace)
+import           Protolude                     hiding (try, intercalate, replace, option)
 import           Control.Monad                 ((>>))
 import           Data.Foldable                 (foldl1)
 import qualified Data.HashMap.Strict           as M
@@ -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 pVText pVTextL) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
+    oper = parse (pOpExpr pSingleVal pListVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
    path = fst <$> treePath
    fld = snd <$> treePath

@@ -96,7 +96,6 @@ pFieldName = do
    dash :: Parser Char
    dash = isDash *> pure '-'

-
 pJsonPathStep :: Parser Text
 pJsonPathStep = toS <$> try (string "->" *> pFieldName)

@@ -131,26 +130,36 @@ pFieldSelect = lexeme $
    s <- pStar
    return ((s, Nothing), Nothing, Nothing, Nothing)

-pOperation :: Parser Operand -> Parser Operand -> Parser Operation
-pOperation parserVText parserVTextL = try ( string "not" *> pDelimiter *> (Operation True <$> pExpr)) <|> Operation False <$> pExpr
+pOpExpr :: Parser Text -> Parser [Text] -> Parser OpExpr
+pOpExpr pSVal pLVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation
  where
-    pExpr :: Parser (Operator, Operand)
-    pExpr =
-          ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys notInOps)) <*> parserVText)
-      <|> ((,) <$> (toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys inOps)) <*> parserVTextL)
+    pOperation :: Parser Operation
+    pOperation =
+          Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal
+      <|> In . toS <$> (string "in" <* pDelimiter) <*> pLVal
+      <|> In . toS <$> (string "notin" <* pDelimiter) <*> pLVal
+      <|> pFts
      <?> "operator (eq, gt, ...)"
-    inOps = M.filterWithKey (const . flip elem ["in", "notin"]) operators
-    notInOps = M.difference operators inOps
+    pFts = do
+      mode <- option Normal $
+              try (string "phrase" *> pDelimiter *> pure Phrase)
+          <|> try (string "plain" *> pDelimiter *> pure Plain)

-pVText :: Parser Operand
-pVText = VText . toS <$> many anyChar
+      lang <- try (Just <$> manyTill (letter <|> digit <|> oneOf "_") (try (string ".fts") <|> try (string ".@@")) <* pDelimiter) -- TODO: '@@' deprecated
+          <|> try (string "fts" *> pDelimiter) *> pure Nothing
+          <|> try (string "@@" *> pDelimiter)  *> pure Nothing -- TODO: '@@' deprecated
+      Fts mode (toS <$> lang) <$> pSVal
+    ops = M.filterWithKey (const . flip notElem ["in", "notin", "fts", "@@"]) operators -- TODO: '@@' deprecated

-pVTextL :: Parser Operand
-pVTextL =     VTextL <$> try (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))
-          <|> VTextL <$> lexeme pVTextLElement `sepBy1` char ','
+pSingleVal :: Parser Text
+pSingleVal = toS <$> many anyChar

-pVTextLElement :: Parser Text
-pVTextLElement = try pQuotedValue <|> (toS <$> many (noneOf ",)"))
+pListVal :: Parser [Text]
+pListVal =    try (lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')'))
+          <|> lexeme pListElement `sepBy1` char ','
+
+pListElement :: Parser Text
+pListElement = try pQuotedValue <|> (toS <$> many (noneOf ",)"))

 pQuotedValue :: Parser Text
 pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",)"))
@@ -182,7 +191,7 @@ pLogicTree = Stmnt <$> try pLogicFilter
             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')'))
  where
    pLogicFilter :: Parser Filter
-    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOperation pLogicVText pLogicVTextL
+    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal pLogicListVal
    pNot :: Parser Bool
    pNot = try (string "not" *> pDelimiter *> pure True)
           <|> pure False
@@ -192,8 +201,8 @@ pLogicTree = Stmnt <$> try pLogicFilter
               <|> string "or" *> pure Or
               <?> "logic operator (and, or)"

-pLogicVText :: Parser Operand
-pLogicVText = VText <$> (try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)")))
+pLogicSingleVal :: Parser Text
+pLogicSingleVal = try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)"))
  where
    pPgArray :: Parser Text
    pPgArray =  do
@@ -202,8 +211,8 @@ pLogicVText = VText <$> (try pQuotedValue <|> try pPgArray <|> (toS <$> many (no
      c <- string "}"
      toS <$> pure (a ++ b ++ c)

-pLogicVTextL :: Parser Operand
-pLogicVTextL = VTextL <$> (lexeme (char '(') *> pVTextLElement `sepBy1` char ',' <* lexeme (char ')'))
+pLogicListVal :: Parser [Text]
+pLogicListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')

 pLogicPath :: Parser (EmbedPath, Text)
 pLogicPath = do
@@ -208,7 +208,7 @@ requestToCountQuery schema (DbRead (Node (Select _ _ logicForest _ _, (mainTbl,
   qi = removeSourceCTESchema schema mainTbl
   -- all foreing key filters are root nodes(see addFilterToLogicForest), only those are filtered
   nonFKRoot :: LogicTree -> Bool
-   nonFKRoot (Stmnt (Filter _ Operation{expr=(_, VForeignKey _ _)})) = False
+   nonFKRoot (Stmnt (Filter _ (OpExpr _ (Join _ _)))) = False
   nonFKRoot (Stmnt _) = True
   nonFKRoot Expr{} = True
   filteredLogic = filter nonFKRoot logicForest
@@ -253,7 +253,7 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest
      where
        node_name = fromMaybe name alias
        local_table_name = table <> "_" <> node_name
-        replaceTableName localTableName (Filter a (Operation b (c, VForeignKey (QualifiedIdentifier "" _) d))) = Filter a (Operation b (c, VForeignKey (QualifiedIdentifier "" localTableName) d))
+        replaceTableName localTableName (Filter a (OpExpr b (Join (QualifiedIdentifier "" _) c))) = Filter a (OpExpr b (Join (QualifiedIdentifier "" localTableName) c))
        replaceTableName _ x = x
        sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name
        joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name  <>
@@ -385,7 +385,7 @@ getJoinFilters (Relation t cols ft fcs typ lt lc1 lc2) =
    ftN = tableName ft
    ltN = fromMaybe "" (tableName <$> lt)
    toFilter :: Text -> Text -> Column -> Column -> Filter
-    toFilter tb ftb c fc = Filter (colName c, Nothing) (Operation False ("=", VForeignKey (QualifiedIdentifier s tb) (ForeignKey fc{colTable=(colTable fc){tableName=ftb}})))
+    toFilter tb ftb c fc = Filter (colName c, Nothing) (OpExpr False (Join (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
@@ -413,19 +413,25 @@ pgFmtSelectItem table (f@(_, jp), Nothing, alias, _) = pgFmtField table f <> pgF
 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)) = notOp <> " " <> case ex of
-   (op, VText val) -> pgFmtFieldOp op <> " " <> case op of
-     "like"  -> unknownLiteral (T.map star val)
-     "ilike" -> unknownLiteral (T.map star val)
-     -- TODO: The '@@' was deprecated, remove in v0.5.0.0
-     "@@"    -> "to_tsquery(" <> unknownLiteral val <> ") "
-     "fts"   -> "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
+pgFmtFilter table (Filter fld (OpExpr hasNot_ oper)) = notOp <> " " <> case oper of
+   Op op val  -> pgFmtFieldOp op <> " " <> case op of
+     "like"   -> unknownLiteral (T.map star val)
+     "ilike"  -> unknownLiteral (T.map star val)
+     "is"     -> whiteList val
+     "isnot"  -> whiteList val
+     _        -> unknownLiteral val
+
+   In op vals -> pgFmtIn op vals -- in and notin
+
+   Fts mode lang val ->
+     pgFmtFieldOp "fts" <> " " <> case mode of
+       Normal -> "to_tsquery("
+       Plain  -> "plainto_tsquery("
+       Phrase -> "phraseto_tsquery("
+     <> maybe "" (flip (<>) ", " . pgFmtLit) lang <> unknownLiteral val <> ") "
+
+   Join fQi (ForeignKey Column{colTable=Table{tableName=fTableName}, colName=fColName}) ->
+     pgFmtField fQi fld <> " = " <> pgFmtColumn (removeSourceCTESchema (qiSchema fQi) fTableName) fColName
 where
   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
   sqlOperator o = HM.lookupDefault "=" o operators
@@ -174,8 +174,15 @@ 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 OpExpr = OpExpr Bool Operation deriving (Eq, Show)
+data Operation = Op Operator Text |
+                 In Operator [Text] |
+                 Fts FtsMode (Maybe Language) Text |
+                 Join QualifiedIdentifier ForeignKey deriving (Eq, Show)
+
+data FtsMode = Normal | Plain | Phrase deriving (Eq, Show)
+type Language = Text

 data LogicOperator = And | Or deriving Eq
 instance Show LogicOperator where
@@ -207,7 +214,7 @@ type RelationDetail = Text
 type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe RelationDetail)
 -- | 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 Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq)

 data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
 data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }