1-- Copyright (c) 2014 Joe Nelson 2-- 3-- Permission is hereby granted, free of charge, to any person obtaining 4-- a copy of this software and associated documentation files (the 5-- "Software"), to deal in the Software without restriction, including 6-- without limitation the rights to use, copy, modify, merge, publish, 7-- distribute, sublicense, and/or sell copies of the Software, and to 8-- permit persons to whom the Software is furnished to do so, subject to 9-- the following conditions: 10-- 11-- The above copyright notice and this permission notice shall be included 12-- in all copies or substantial portions of the Software. 13-- 14-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17-- IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18-- CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19-- TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20-- SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 22module PostgREST.Parsers where 23 24import Protolude hiding (try, intercalate, replace, option) 25import Control.Monad ((>>)) 26import Data.Foldable (foldl1) 27import qualified Data.HashMap.Strict as M 28import Data.Text (intercalate, replace, strip) 29import Data.List (init, last) 30import Data.Tree 31import Data.Either.Combinators (mapLeft) 32import PostgREST.RangeQuery (NonnegRange,allRange) 33import PostgREST.Types 34import Text.ParserCombinators.Parsec hiding (many, (<|>)) 35import Text.Parsec.Error 36 37pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest 38pRequestSelect rootName selStr = 39 mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) 40 41pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) 42pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper) 43 where 44 treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k 45 oper = parse (pOpExpr pSingleVal pListVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v 46 path = fst <$> treePath 47 fld = snd <$> treePath 48 49pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm]) 50pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord' 51 where 52 treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k 53 path = fst <$> treePath 54 ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v 55 56pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange) 57pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v 58 where 59 treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k 60 path = fst <$> treePath 61 62pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree) 63pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree 64 where 65 path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k 66 embedPath = fst <$> path 67 op = snd <$> path 68 -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)" 69 logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v) 70 71pRequestRpcQParam :: (Text, Text) -> Either ApiRequestError RpcQParam 72pRequestRpcQParam (k, v) = mapError $ (,) <$> name <*> val 73 where 74 name = parse pFieldName ("failed to parse rpc arg name (" ++ toS k ++ ")") $ toS k 75 val = toS <$> parse (many anyChar) ("failed to parse rpc arg value (" ++ toS v ++ ")") v 76 77ws :: Parser Text 78ws = toS <$> many (oneOf " \t") 79 80lexeme :: Parser a -> Parser a 81lexeme p = ws *> p <* ws 82 83pReadRequest :: Text -> Parser ReadRequest 84pReadRequest rootNodeName = do 85 fieldTree <- pFieldForest 86 return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing, Nothing)) []) fieldTree 87 where 88 readQuery = Select [] [rootNodeName] [] Nothing allRange 89 treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest 90 treeEntry (Node fld@((fn, _),_,alias,relationDetail) fldForest) (Node (q, i) rForest) = 91 case fldForest of 92 [] -> Node (q {select=fld:select q}, i) rForest 93 _ -> Node (q, i) newForest 94 where 95 newForest = 96 foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias, relationDetail)) []) fldForest:rForest 97 98pTreePath :: Parser (EmbedPath, Field) 99pTreePath = do 100 p <- pFieldName `sepBy1` pDelimiter 101 jp <- optionMaybe pJsonPath 102 return (init p, (last p, jp)) 103 104pFieldForest :: Parser [Tree SelectItem] 105pFieldForest = pFieldTree `sepBy1` lexeme (char ',') 106 107pFieldTree :: Parser (Tree SelectItem) 108pFieldTree = try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest) -- TODO: "{}" deprecated 109 <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) 110 <|> Node <$> pFieldSelect <*> pure [] 111 112pStar :: Parser Text 113pStar = toS <$> (string "*" *> pure ("*"::ByteString)) 114 115 116pFieldName :: Parser Text 117pFieldName = do 118 matches <- (many1 (letter <|> digit <|> oneOf "_") `sepBy1` dash) <?> "field name (* or [a..z0..9_])" 119 return $ intercalate "-" $ map toS matches 120 where 121 isDash :: GenParser Char st () 122 isDash = try ( char '-' >> notFollowedBy (char '>') ) 123 dash :: Parser Char 124 dash = isDash *> pure '-' 125 126pJsonPathStep :: Parser Text 127pJsonPathStep = toS <$> try (string "->" *> pFieldName) 128 129pJsonPath :: Parser [Text] 130pJsonPath = (<>) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) ) 131 132pField :: Parser Field 133pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath 134 135aliasSeparator :: Parser () 136aliasSeparator = char ':' >> notFollowedBy (char ':') 137 138pRelationSelect :: Parser SelectItem 139pRelationSelect = lexeme $ try ( do 140 alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) 141 fld <- pField 142 relationDetail <- optionMaybe ( try( char '.' *> pFieldName ) ) 143 144 return (fld, Nothing, alias, relationDetail) 145 ) 146 147pFieldSelect :: Parser SelectItem 148pFieldSelect = lexeme $ 149 try ( 150 do 151 alias <- optionMaybe ( try(pFieldName <* aliasSeparator) ) 152 fld <- pField 153 cast' <- optionMaybe (string "::" *> many letter) 154 return (fld, toS <$> cast', alias, Nothing) 155 ) 156 <|> do 157 s <- pStar 158 return ((s, Nothing), Nothing, Nothing, Nothing) 159 160pOpExpr :: Parser SingleVal -> Parser ListVal -> Parser OpExpr 161pOpExpr pSVal pLVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation 162 where 163 pOperation :: Parser Operation 164 pOperation = 165 Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal 166 <|> In <$> (string "in" *> pDelimiter *> pLVal) 167 <|> pFts 168 <?> "operator (eq, gt, ...)" 169 170 pFts = do 171 op <- foldl1 (<|>) (try . string . toS <$> ftsOps) 172 lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_"))) 173 pDelimiter >> Fts (toS op) (toS <$> lang) <$> pSVal 174 175 ops = M.filterWithKey (const . flip notElem ("in":ftsOps)) operators 176 ftsOps = M.keys ftsOperators 177 178pSingleVal :: Parser SingleVal 179pSingleVal = toS <$> many anyChar 180 181pListVal :: Parser ListVal 182pListVal = try (lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')) 183 <|> lexeme pListElement `sepBy1` char ',' -- TODO: "in.3,4,5" deprecated, parens e.g. "in.(3,4,5)" should be used 184 185pListElement :: Parser Text 186pListElement = try pQuotedValue <|> (toS <$> many (noneOf ",)")) 187 188pQuotedValue :: Parser Text 189pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",)")) 190 191pDelimiter :: Parser Char 192pDelimiter = char '.' <?> "delimiter (.)" 193 194pOrder :: Parser [OrderTerm] 195pOrder = lexeme pOrderTerm `sepBy` char ',' 196 197pOrderTerm :: Parser OrderTerm 198pOrderTerm = 199 try ( do 200 c <- pField 201 d <- optionMaybe (try $ pDelimiter *> ( 202 try(string "asc" *> pure OrderAsc) 203 <|> try(string "desc" *> pure OrderDesc) 204 )) 205 nls <- optionMaybe (pDelimiter *> ( 206 try(string "nullslast" *> pure OrderNullsLast) 207 <|> try(string "nullsfirst" *> pure OrderNullsFirst) 208 )) 209 return $ OrderTerm c d nls 210 ) 211 <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing 212 213pLogicTree :: Parser LogicTree 214pLogicTree = Stmnt <$> try pLogicFilter 215 <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')')) 216 where 217 pLogicFilter :: Parser Filter 218 pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal pLogicListVal 219 pNot :: Parser Bool 220 pNot = try (string "not" *> pDelimiter *> pure True) 221 <|> pure False 222 <?> "negation operator (not)" 223 pLogicOp :: Parser LogicOperator 224 pLogicOp = try (string "and" *> pure And) 225 <|> string "or" *> pure Or 226 <?> "logic operator (and, or)" 227 228pLogicSingleVal :: Parser SingleVal 229pLogicSingleVal = try pQuotedValue <|> try pPgArray <|> (toS <$> many (noneOf ",)")) 230 where 231 -- TODO: "{}" deprecated, after removal pPgArray can be removed 232 pPgArray :: Parser Text 233 pPgArray = do 234 a <- string "{" 235 b <- many (noneOf "{}") 236 c <- string "}" 237 toS <$> pure (a ++ b ++ c) 238 239pLogicListVal :: Parser ListVal 240pLogicListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')') 241 242pLogicPath :: Parser (EmbedPath, Text) 243pLogicPath = do 244 path <- pFieldName `sepBy1` pDelimiter 245 let op = last path 246 notOp = "not." <> op 247 return (filter (/= "not") (init path), if "not" `elem` path then notOp else op) 248 249mapError :: Either ParseError a -> Either ApiRequestError a 250mapError = mapLeft translateError 251 where 252 translateError e = 253 ParseRequestError message details 254 where 255 message = show $ errorPos e 256 details = strip $ replace "\n" " " $ toS 257 $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) 258 259allRange :: NonnegRange 260allRange = rangeGeq 0 + 0xFF - 0XFF + 0o7 - 0O7 + 1.0e2 - 1.0E2 + 1e2 - 1E2 261{- comment {- comment -} 262comment 263-} 264{-http://example.com.-} 265