|
| 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 | + |
| 22 | +module PostgREST.Parsers where |
| 23 | + |
| 24 | +import Protolude hiding (try, intercalate, replace, option) |
| 25 | +import Control.Monad ((>>)) |
| 26 | +import Data.Foldable (foldl1) |
| 27 | +import qualified Data.HashMap.Strict as M |
| 28 | +import Data.Text (intercalate, replace, strip) |
| 29 | +import Data.List (init, last) |
| 30 | +import Data.Tree |
| 31 | +import Data.Either.Combinators (mapLeft) |
| 32 | +import PostgREST.RangeQuery (NonnegRange,allRange) |
| 33 | +import PostgREST.Types |
| 34 | +import Text.ParserCombinators.Parsec hiding (many, (<|>)) |
| 35 | +import Text.Parsec.Error |
| 36 | + |
| 37 | +pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest |
| 38 | +pRequestSelect rootName selStr = |
| 39 | + mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) |
| 40 | + |
| 41 | +pRequestFilter :: (Text, Text) -> Either ApiRequestError (EmbedPath, Filter) |
| 42 | +pRequestFilter (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 | + |
| 49 | +pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm]) |
| 50 | +pRequestOrder (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 | + |
| 56 | +pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange) |
| 57 | +pRequestRange (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 | + |
| 62 | +pRequestLogicTree :: (Text, Text) -> Either ApiRequestError (EmbedPath, LogicTree) |
| 63 | +pRequestLogicTree (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 | + |
| 71 | +pRequestRpcQParam :: (Text, Text) -> Either ApiRequestError RpcQParam |
| 72 | +pRequestRpcQParam (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 | + |
| 77 | +ws :: Parser Text |
| 78 | +ws = toS <$> many (oneOf " \t") |
| 79 | + |
| 80 | +lexeme :: Parser a -> Parser a |
| 81 | +lexeme p = ws *> p <* ws |
| 82 | + |
| 83 | +pReadRequest :: Text -> Parser ReadRequest |
| 84 | +pReadRequest 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 | + |
| 98 | +pTreePath :: Parser (EmbedPath, Field) |
| 99 | +pTreePath = do |
| 100 | + p <- pFieldName `sepBy1` pDelimiter |
| 101 | + jp <- optionMaybe pJsonPath |
| 102 | + return (init p, (last p, jp)) |
| 103 | + |
| 104 | +pFieldForest :: Parser [Tree SelectItem] |
| 105 | +pFieldForest = pFieldTree `sepBy1` lexeme (char ',') |
| 106 | + |
| 107 | +pFieldTree :: Parser (Tree SelectItem) |
| 108 | +pFieldTree = try (Node <$> pRelationSelect <*> between (char '{') (char '}') pFieldForest) -- TODO: "{}" deprecated |
| 109 | + <|> try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) |
| 110 | + <|> Node <$> pFieldSelect <*> pure [] |
| 111 | + |
| 112 | +pStar :: Parser Text |
| 113 | +pStar = toS <$> (string "*" *> pure ("*"::ByteString)) |
| 114 | + |
| 115 | + |
| 116 | +pFieldName :: Parser Text |
| 117 | +pFieldName = 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 | + |
| 126 | +pJsonPathStep :: Parser Text |
| 127 | +pJsonPathStep = toS <$> try (string "->" *> pFieldName) |
| 128 | + |
| 129 | +pJsonPath :: Parser [Text] |
| 130 | +pJsonPath = (<>) <$> many pJsonPathStep <*> ( (:[]) <$> (string "->>" *> pFieldName) ) |
| 131 | + |
| 132 | +pField :: Parser Field |
| 133 | +pField = lexeme $ (,) <$> pFieldName <*> optionMaybe pJsonPath |
| 134 | + |
| 135 | +aliasSeparator :: Parser () |
| 136 | +aliasSeparator = char ':' >> notFollowedBy (char ':') |
| 137 | + |
| 138 | +pRelationSelect :: Parser SelectItem |
| 139 | +pRelationSelect = 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 | + |
| 147 | +pFieldSelect :: Parser SelectItem |
| 148 | +pFieldSelect = 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 | + |
| 160 | +pOpExpr :: Parser SingleVal -> Parser ListVal -> Parser OpExpr |
| 161 | +pOpExpr 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 | + |
| 178 | +pSingleVal :: Parser SingleVal |
| 179 | +pSingleVal = toS <$> many anyChar |
| 180 | + |
| 181 | +pListVal :: Parser ListVal |
| 182 | +pListVal = 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 | + |
| 185 | +pListElement :: Parser Text |
| 186 | +pListElement = try pQuotedValue <|> (toS <$> many (noneOf ",)")) |
| 187 | + |
| 188 | +pQuotedValue :: Parser Text |
| 189 | +pQuotedValue = toS <$> (char '"' *> many (noneOf "\"") <* char '"' <* notFollowedBy (noneOf ",)")) |
| 190 | + |
| 191 | +pDelimiter :: Parser Char |
| 192 | +pDelimiter = char '.' <?> "delimiter (.)" |
| 193 | + |
| 194 | +pOrder :: Parser [OrderTerm] |
| 195 | +pOrder = lexeme pOrderTerm `sepBy` char ',' |
| 196 | + |
| 197 | +pOrderTerm :: Parser OrderTerm |
| 198 | +pOrderTerm = |
| 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 | + |
| 213 | +pLogicTree :: Parser LogicTree |
| 214 | +pLogicTree = 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 | + |
| 228 | +pLogicSingleVal :: Parser SingleVal |
| 229 | +pLogicSingleVal = 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 | + |
| 239 | +pLogicListVal :: Parser ListVal |
| 240 | +pLogicListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')') |
| 241 | + |
| 242 | +pLogicPath :: Parser (EmbedPath, Text) |
| 243 | +pLogicPath = 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 | + |
| 249 | +mapError :: Either ParseError a -> Either ApiRequestError a |
| 250 | +mapError = 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 | + |
| 259 | +allRange :: NonnegRange |
| 260 | +allRange = rangeGeq 0 + 0xFF - 0XFF + 0o7 - 0O7 + 1.0e2 - 1.0E2 + 1e2 - 1E2 |
| 261 | +{- comment {- comment -} |
| 262 | +comment |
| 263 | +-} |
| 264 | +{-http://example.com.-} |
0 commit comments