module SphinxEscape where
import Control.Applicative
import Data.Functor.Identity (Identity )
import Text.Parsec hiding (many, (<|>))
import Data.Char
import Data.List
escapeSphinxQueryString :: String -> String
escapeSphinxQueryString s = intercalate " " . map expressionToString . parseQuery $ s
data Expression =
TagFieldSearch String
| Literal String
| Phrase String
| AndOrExpr Conj Expression Expression
deriving Show
data Conj = And | Or
deriving Show
parseQuery :: String -> [Expression]
parseQuery inp =
case Text.Parsec.parse (many expression) "" inp of
Left x -> error $ "parser failed: " ++ show x
Right xs -> xs
expressionToString :: Expression -> String
expressionToString (TagFieldSearch s) = "@tag_list" ++ escapeString s
expressionToString (Literal s) = escapeString s
expressionToString (Phrase s) = "\"" ++ s ++ "\""
expressionToString (AndOrExpr c a b) =
let a' = expressionToString a
b' = expressionToString b
c' = conjToString c
in case (all isSpace a', all isSpace b') of
(True, False) -> b'
(False, True) -> a'
(False, False) -> a' ++ c' ++ b'
_ -> ""
conjToString :: Conj -> String
conjToString And = " & "
conjToString Or = " | "
escapeString :: String -> String
escapeString s = map (stripAlphaNum) s
stripAlphaNum :: Char -> Char
stripAlphaNum s | isAlphaNum s = s
| otherwise = ' '
type Parser' = ParsecT String () Identity
topLevelExpression :: Parser' [Expression]
topLevelExpression = do
a <- option [] ((:[]) <$> (tagField <|> literal))
xs <- many expression
return $ a ++ xs
expression :: Parser' Expression
expression = (try andOrExpr) <|> try tagField <|> try phrase <|> literal
tagField :: Parser' Expression
tagField = do
char '@'
string "tag_list" <|> string "(tag_list)"
s <- manyTill anyChar (try literalStop)
return $ TagFieldSearch s
andOrExpr :: Parser' Expression
andOrExpr = do
a <- (try tagField <|> try phrase <|> literal)
x <- try conjExpr
b <- expression
return $ AndOrExpr x a b
conjExpr :: Parser' Conj
conjExpr = andExpr <|> orExpr
andExpr :: Parser' Conj
andExpr = mkConjExpr ["and", "AND", "&"] And
orExpr :: Parser' Conj
orExpr = mkConjExpr ["or", "OR", "|"] Or
mkConjExpr :: [String] -> Conj -> Parser' Conj
mkConjExpr xs t =
try (many1 space >> choice (map (string . (++" ")) xs))
>> return t
phrase :: Parser' Expression
phrase = do
_ <- char '"'
xs <- manyTill anyChar (char '"')
return . Phrase $ xs
literalStop :: Parser' ()
literalStop = (choice [
lookAhead (tagField >> return ())
, lookAhead (conjExpr >> return ())
, lookAhead (phrase >> return ())
, eof
])
<?> "literalStop"
literal :: Parser' Expression
literal = do
a <- anyChar
notFollowedBy literalStop
xs <- manyTill anyChar (try literalStop)
return . Literal $ a:xs