refactor: Carve out QueryParams module

postgrest.cabal

@@ -60,9 +60,9 @@ library
                       PostgREST.RangeQuery
                       PostgREST.Request.ApiRequest
                       PostgREST.Request.DbRequestBuilder
-                      PostgREST.Request.Parsers
                       PostgREST.Request.Preferences
                       PostgREST.Request.Types
+                      PostgREST.Request.QueryParams
                       PostgREST.Version
                       PostgREST.Workers
   other-modules:      Paths_postgrest

src/PostgREST/App.hs

@@ -79,6 +79,7 @@ import PostgREST.Request.Preferences     (PreferCount (..),
                                           PreferParameters (..),
                                           PreferRepresentation (..),
                                           toAppliedHeader)
+import PostgREST.Request.QueryParams     (QueryParams (..))
 import PostgREST.Request.Types           (ReadRequest, fstFieldNames)
 import PostgREST.Version                 (prettyVersion)
 import PostgREST.Workers                 (connectionWorker, listener)
@@ -278,7 +279,7 @@ handleRead headersOnly identifier context@RequestContext{..} = do
       , ( "Content-Location"
         , "/"
             <> toUtf8 (qiName identifier)
-            <> if BS.null iCanonicalQS then mempty else "?" <> iCanonicalQS
+            <> if BS.null (qsCanonical iQueryParams) then mempty else "?" <> qsCanonical iQueryParams
         )
       ]
       ++ contentTypeHeaders context
@@ -326,7 +327,7 @@ handleCreate identifier@QualifiedIdentifier{..} context@RequestContext{..} = do
               )
         , Just . RangeQuery.contentRangeH 1 0 $
             if shouldCount iPreferCount then Just resQueryTotal else Nothing
-        , if null pkCols && isNothing iOnConflict then
+        , if null pkCols && isNothing (qsOnConflict iQueryParams) then
             Nothing
           else
             toAppliedHeader <$> iPreferResolution

src/PostgREST/Error.hs

@@ -29,8 +29,10 @@ import Network.Wai (Response, responseLBS)
 
 import Network.HTTP.Types.Header (Header)
 
-import           PostgREST.ContentType (ContentType (..))
+import           PostgREST.ContentType   (ContentType (..))
-import qualified PostgREST.ContentType as ContentType
+import qualified PostgREST.ContentType   as ContentType
+import           PostgREST.Request.Types (ApiRequestError (..),
+                                          QPError (..))
 
 import PostgREST.DbStructure.Proc         (ProcDescription (..),
                                            ProcParam (..))
@@ -52,22 +54,6 @@ class (JSON.ToJSON a) => PgrstError a where
   errorResponseFor :: a -> Response
   errorResponseFor err = responseLBS (status err) (headers err) $ errorPayload err
 
-
-
-data ApiRequestError
-  = ActionInappropriate
-  | InvalidRange
-  | InvalidBody ByteString
-  | ParseRequestError Text Text
-  | NoRelBetween Text Text Text
-  | AmbiguousRelBetween Text Text [Relationship]
-  | AmbiguousRpc [ProcDescription]
-  | NoRpc Text Text [Text] Bool ContentType Bool
-  | InvalidFilters
-  | UnacceptableSchema [Text]
-  | ContentTypeError [ByteString]
-  | UnsupportedVerb                -- Unreachable?
-
 instance PgrstError ApiRequestError where
   status InvalidRange            = HTTP.status416
   status InvalidFilters          = HTTP.status405
@@ -75,6 +61,7 @@ instance PgrstError ApiRequestError where
   status UnsupportedVerb         = HTTP.status405
   status ActionInappropriate     = HTTP.status405
   status (ParseRequestError _ _) = HTTP.status400
+  status (QueryParamError _)     = HTTP.status400
   status NoRelBetween{}          = HTTP.status400
   status AmbiguousRelBetween{}   = HTTP.status300
   status (AmbiguousRpc _)        = HTTP.status300
@@ -87,6 +74,8 @@ instance PgrstError ApiRequestError where
 instance JSON.ToJSON ApiRequestError where
   toJSON (ParseRequestError message details) = JSON.object [
     "message" .= message, "details" .= details]
+  toJSON (QueryParamError (QPError message details)) = JSON.object [
+    "message" .= message, "details" .= details]
   toJSON ActionInappropriate = JSON.object [
     "message" .= ("Bad Request" :: Text)]
   toJSON (InvalidBody errorMessage) = JSON.object [

src/PostgREST/Query/SqlFragment.hs

@@ -15,11 +15,9 @@ module PostgREST.Query.SqlFragment
   , asJsonSingleF
   , countF
   , fromQi
-  , ftsOperators
   , limitOffsetF
   , locationF
   , normalizedBody
-  , operators
   , pgFmtColumn
   , pgFmtIdent
   , pgFmtJoinCondition
@@ -38,7 +36,6 @@ module PostgREST.Query.SqlFragment
 
 import qualified Data.ByteString.Char8           as BS
 import qualified Data.ByteString.Lazy            as LBS
-import qualified Data.HashMap.Strict             as M
 import qualified Data.Text                       as T
 import qualified Hasql.DynamicStatements.Snippet as SQL
 import qualified Hasql.Encoders                  as HE
@@ -51,6 +48,7 @@ import PostgREST.DbStructure.Identifiers (FieldName,
 import PostgREST.RangeQuery              (NonnegRange, allRange,
                                           rangeLimit, rangeOffset)
 import PostgREST.Request.Types           (Alias, Field, Filter (..),
+                                          FtsOperator (..),
                                           JoinCondition (..),
                                           JsonOperand (..),
                                           JsonOperation (..),
@@ -61,6 +59,7 @@ import PostgREST.Request.Types           (Alias, Field, Filter (..),
                                           OrderDirection (..),
                                           OrderNulls (..),
                                           OrderTerm (..), SelectItem,
+                                          SimpleOperator (..),
                                           TrileanVal (..))
 
 import Protolude hiding (cast)
@@ -75,34 +74,31 @@ noLocationF = "array[]::text[]"
 sourceCTEName :: SqlFragment
 sourceCTEName = "pgrst_source"
 
-operators :: M.HashMap Text SqlFragment
+singleValOperator :: SimpleOperator -> SqlFragment
-operators = M.union (M.fromList [
+singleValOperator = \case
-  ("eq", "="),
+  OpEqual            -> "="
-  ("gte", ">="),
+  OpGreaterThanEqual -> ">="
-  ("gt", ">"),
+  OpGreaterThan      -> ">"
-  ("lte", "<="),
+  OpLessThanEqual    -> "<="
-  ("lt", "<"),
+  OpLessThan         -> "<"
-  ("neq", "<>"),
+  OpNotEqual         -> "<>"
-  ("like", "LIKE"),
+  OpLike             -> "like"
-  ("ilike", "ILIKE"),
+  OpILike            -> "ilike"
-  ("in", "IN"),
+  OpContains         -> "@>"
-  ("is", "IS"),
+  OpContained        -> "<@"
-  ("cs", "@>"),
+  OpOverlap          -> "&&"
-  ("cd", "<@"),
+  OpStrictlyLeft     -> "<<"
-  ("ov", "&&"),
+  OpStrictlyRight    -> ">>"
-  ("sl", "<<"),
+  OpNotExtendsRight  -> "&<"
-  ("sr", ">>"),
+  OpNotExtendsLeft   -> "&>"
-  ("nxr", "&<"),
+  OpAdjacent         -> "-|-"
-  ("nxl", "&>"),
-  ("adj", "-|-")]) ftsOperators
 
-ftsOperators :: M.HashMap Text SqlFragment
+ftsOperator :: FtsOperator -> SqlFragment
-ftsOperators = M.fromList [
+ftsOperator = \case
-  ("fts", "@@ to_tsquery"),
+  FilterFts          -> "@@ to_tsquery"
-  ("plfts", "@@ plainto_tsquery"),
+  FilterFtsPlain     -> "@@ plainto_tsquery"
-  ("phfts", "@@ phraseto_tsquery"),
+  FilterFtsPhrase    -> "@@ phraseto_tsquery"
-  ("wfts", "@@ websearch_to_tsquery")
+  FilterFtsWebsearch -> "@@ websearch_to_tsquery"
-  ]
 
 -- |
 -- These CTEs convert a json object into a json array, this way we can use json_populate_recordset for all json payloads
@@ -227,8 +223,8 @@ pgFmtOrderTerm qi ot =
 pgFmtFilter :: QualifiedIdentifier -> Filter -> SQL.Snippet
 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)
+     OpLike  -> unknownLiteral (T.map star val)
-     "ilike" -> unknownLiteral (T.map star val)
+     OpILike -> unknownLiteral (T.map star val)
      _       -> unknownLiteral val
 
    -- IS cannot be prepared. `PREPARE boolplan AS SELECT * FROM projects where id IS $1` will give a syntax error.
@@ -249,11 +245,11 @@ pgFmtFilter table (Filter fld (OpExpr hasNot oper)) = notOp <> " " <> case oper
       _    -> "= ANY (" <> unknownLiteral (pgBuildArrayLiteral vals) <> ") "
 
    Fts op lang val ->
-     pgFmtFieldOp op <> "(" <> ftsLang lang <> unknownLiteral val <> ") "
+     pgFmtFieldFts op <> "(" <> ftsLang lang <> unknownLiteral val <> ") "
  where
    ftsLang = maybe mempty (\l -> unknownLiteral l <> ", ")
-   pgFmtFieldOp op = pgFmtField table fld <> " " <> sqlOperator op
+   pgFmtFieldOp op = pgFmtField table fld <> " " <> SQL.sql (singleValOperator op)
-   sqlOperator o = SQL.sql $ M.lookupDefault "=" o operators
+   pgFmtFieldFts op = pgFmtField table fld <> " " <> SQL.sql (ftsOperator op)
    notOp = if hasNot then "NOT" else mempty
    star c = if c == '*' then '%' else c
 

src/PostgREST/Request/ApiRequest.hs

@@ -31,15 +31,11 @@ import qualified Data.Vector           as V
 
 import Control.Arrow             ((***))
 import Data.Aeson.Types          (emptyArray, emptyObject)
-import Data.List                 (last, lookup, partition, union)
+import Data.List                 (lookup, union)
 import Data.Maybe                (fromJust)
-import Data.Ranged.Boundaries    (Boundary (..))
+import Data.Ranged.Ranges        (emptyRange, rangeIntersection)
-import Data.Ranged.Ranges        (Range (..), emptyRange,
-                                  rangeIntersection)
-import Network.HTTP.Base         (urlEncodeVars)
 import Network.HTTP.Types.Header (hAuthorization, hCookie)
-import Network.HTTP.Types.URI    (parseQueryReplacePlus,
+import Network.HTTP.Types.URI    (parseSimpleQuery)
-                                  parseSimpleQuery)
 import Network.Wai               (Request (..))
 import Network.Wai.Parse         (parseHttpAccept)
 import Web.Cookie                (parseCookies)
@@ -53,21 +49,19 @@ import PostgREST.DbStructure.Identifiers (FieldName,
                                           Schema)
 import PostgREST.DbStructure.Proc        (ProcDescription (..),
                                           ProcParam (..), ProcsMap)
-import PostgREST.Error                   (ApiRequestError (..))
-import PostgREST.Query.SqlFragment       (ftsOperators, operators)
 import PostgREST.RangeQuery              (NonnegRange, allRange,
-                                          rangeGeq, rangeLimit,
+                                          rangeRequested)
-                                          rangeOffset, rangeRequested,
-                                          restrictRange)
-import PostgREST.Request.Parsers         (pRequestColumns)
 import PostgREST.Request.Preferences     (PreferCount (..),
                                           PreferParameters (..),
                                           PreferRepresentation (..),
                                           PreferResolution (..),
                                           PreferTransaction (..))
+import PostgREST.Request.QueryParams     (QueryParams (..))
+import PostgREST.Request.Types           (ApiRequestError (..))
 
 import qualified PostgREST.ContentType         as ContentType
 import qualified PostgREST.Request.Preferences as Preferences
+import qualified PostgREST.Request.QueryParams as QueryParams
 
 import Protolude
 
@@ -161,13 +155,8 @@ data ApiRequest = ApiRequest {
   , iPreferCount          :: Maybe PreferCount                -- ^ Whether the client wants a result count
   , iPreferResolution     :: Maybe PreferResolution           -- ^ Whether the client wants to UPSERT or ignore records on PK conflict
   , iPreferTransaction    :: Maybe PreferTransaction          -- ^ Whether the clients wants to commit or rollback the transaction
-  , iFilters              :: [(Text, Text)]                   -- ^ Filters on the result ("id", "eq.10")
+  , iQueryParams          :: QueryParams.QueryParams
-  , iLogic                :: [(Text, Text)]                   -- ^ &and and &or parameters used for complex boolean logic
-  , iSelect               :: Maybe Text                       -- ^ &select parameter used to shape the response
-  , iOnConflict           :: Maybe Text                       -- ^ &on_conflict parameter used to upsert on specific unique keys
   , iColumns              :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and payload
-  , iOrder                :: [(Text, Text)]                   -- ^ &order parameters for each level
-  , iCanonicalQS          :: ByteString                       -- ^ Alphabetized (canonical) request query string for response URLs
   , iJWT                  :: Text                             -- ^ JSON Web Token
   , iHeaders              :: [(ByteString, ByteString)]       -- ^ HTTP request headers
   , iCookies              :: [(ByteString, ByteString)]       -- ^ Request Cookies
@@ -180,12 +169,16 @@ data ApiRequest = ApiRequest {
 
 -- | Examines HTTP request and translates it into user intent.
 userApiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest
-userApiRequest conf@AppConfig{..} dbStructure req reqBody
+userApiRequest conf dbStructure req reqBody =
+  apiRequest conf dbStructure req reqBody =<< first QueryParamError (QueryParams.parse (rawQueryString req))
+
+apiRequest :: AppConfig -> DbStructure -> Request -> RequestBody -> QueryParams.QueryParams -> Either ApiRequestError ApiRequest
+apiRequest conf@AppConfig{..} dbStructure req reqBody queryparams@QueryParams{..}
   | isJust profile && fromJust profile `notElem` configDbSchemas = Left $ UnacceptableSchema $ toList configDbSchemas
   | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate
   | topLevelRange == emptyRange = Left InvalidRange
   | shouldParsePayload && isLeft payload = either (Left . InvalidBody) witness payload
-  | isLeft parsedColumns = either Left witness parsedColumns
+  | not expectParams && not (L.null qsParams) = Left $ ParseRequestError "Unexpected param or filter missing operator" ("Failed to parse " <> show qsParams)
   | otherwise = do
      acceptContentType <- findAcceptContentType conf action path accepts
      checkedTarget <- target
@@ -200,16 +193,8 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
       , iPreferCount = preferCount
       , iPreferResolution = preferResolution
       , iPreferTransaction = preferTransaction
-      , iFilters = filters
+      , iQueryParams = queryparams
-      , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
-      , iSelect = toS <$> join (lookup "select" qParams)
-      , iOnConflict = toS <$> join (lookup "on_conflict" qParams)
       , iColumns = payloadColumns
-      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
-      , iCanonicalQS = BS.pack $ urlEncodeVars
-        . L.sortOn fst
-        . map (join (***) BS.unpack . second (fromMaybe mempty))
-        $ qString
       , iJWT = tokenStr
       , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]
       , iCookies = maybe [] parseCookies $ lookupHeader "Cookie"
@@ -221,24 +206,9 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
       }
  where
   accepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept"
-  -- queryString with '+' converted to ' '(space)
+
-  qString = parseQueryReplacePlus True $ rawQueryString req
+  expectParams = isTargetingProc && method /= "POST"
-  -- rpcQParams = Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)
+
-  (filters, rpcQParams) =
-    case action of
-      ActionInvoke InvGet  -> partitionFlts
-      ActionInvoke InvHead -> partitionFlts
-      _                    -> (flts, [])
-  partitionFlts = partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts
-  flts =
-    [ (toS k, toS $ fromJust v) |
-      (k,v) <- qParams, isJust v,
-      k `notElem` ["select", "columns"],
-      not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
-  hasOperator val = any (`T.isPrefixOf` val) $
-                      ((<> ".") <$> "not":M.keys operators) ++
-                      ((<> "(") <$> M.keys ftsOperators)
-  isEmbedPath = T.isInfixOf "."
   isTargetingProc = case path of
     PathInfo{pHasRpc, pIsRootSpec} -> pHasRpc || pIsRootSpec
     _                              -> False
@@ -246,16 +216,19 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
     PathInfo{pIsDefaultSpec=True} -> True
     _                             -> False
   contentType = maybe CTApplicationJSON ContentType.decodeContentType $ lookupHeader "content-type"
-  columns
+
-    | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
+  columns =
-    | otherwise = Nothing
+    if action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] then
-  parsedColumns = pRequestColumns columns
+      qsColumns
+    else
+      Nothing
+
   payloadColumns =
     case (contentType, action) of
-      (_, ActionInvoke InvGet)  -> S.fromList $ fst <$> rpcQParams
+      (_, ActionInvoke InvGet)  -> S.fromList $ fst <$> qsParams
-      (_, ActionInvoke InvHead) -> S.fromList $ fst <$> rpcQParams
+      (_, ActionInvoke InvHead) -> S.fromList $ fst <$> qsParams
       (CTUrlEncoded, _)         -> S.fromList $ map (T.decodeUtf8 . fst) $ parseSimpleQuery $ LBS.toStrict reqBody
-      _ -> case (relevantPayload, fromRight Nothing parsedColumns) of
+      _ -> case (relevantPayload, columns) of
         (Just ProcessedJSON{payKeys}, _) -> payKeys
         (Just RawJSON{}, Just cls)       -> cls
         _                                -> S.empty
@@ -333,8 +306,8 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
   relevantPayload = case (contentType, action) of
     -- Though ActionInvoke GET/HEAD doesn't really have a payload, we use the payload variable as a way
     -- to store the query string arguments to the function.
-    (_, ActionInvoke InvGet)             -> targetToJsonRpcParams (rightToMaybe target) rpcQParams
+    (_, ActionInvoke InvGet)             -> targetToJsonRpcParams (rightToMaybe target) qsParams
-    (_, ActionInvoke InvHead)            -> targetToJsonRpcParams (rightToMaybe target) rpcQParams
+    (_, ActionInvoke InvHead)            -> targetToJsonRpcParams (rightToMaybe target) qsParams
     (CTUrlEncoded, ActionInvoke InvPost) -> targetToJsonRpcParams (rightToMaybe target) $ (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
     _ | shouldParsePayload               -> rightToMaybe payload
       | otherwise                        -> Nothing
@@ -349,7 +322,6 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
       _              -> PathUnknown
   method          = requestMethod req
   hdrs            = requestHeaders req
-  qParams         = [(T.decodeUtf8 k, T.decodeUtf8 <$> v)|(k,v) <- qString]
   lookupHeader    = flip lookup hdrs
   Preferences.Preferences{..} = Preferences.fromHeaders hdrs
   auth = fromMaybe "" $ lookupHeader hAuthorization
@@ -357,24 +329,9 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody
     ("Bearer" : t : _) -> t
     ("bearer" : t : _) -> t
     _                  -> ""
-  endingIn:: [Text] -> Text -> Bool
-  endingIn xx key = lastWord `elem` xx
-    where lastWord = last $ T.split (=='.') key
-
   headerRange = rangeRequested hdrs
-  replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]
-  limitParams :: M.HashMap Text NonnegRange
-  limitParams  = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe . toS =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]
-  offsetParams :: M.HashMap Text NonnegRange
-  offsetParams = M.fromList [(toS (replaceLast "limit" k), maybe allRange rangeGeq (readMaybe . toS =<< v)) | (k,v) <- qParams, isJust v, endingIn ["offset"] k]
 
-  urlRange = M.unionWith f limitParams offsetParams
+  ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" qsRanges))) qsRanges
-    where
-      f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)
-        where
-          l = fromMaybe 0 $ rangeLimit rl
-          o = rangeOffset ro
-  ranges = M.insert "limit" (rangeIntersection headerRange (fromMaybe allRange (M.lookup "limit" urlRange))) urlRange
 
 {-|
   Find the best match from a list of content types accepted by the

src/PostgREST/Request/DbRequestBuilder.hs

@@ -24,10 +24,8 @@ module PostgREST.Request.DbRequestBuilder
 import qualified Data.HashMap.Strict as M
 import qualified Data.Set            as S
 
-import Control.Arrow           ((***))
 import Data.Either.Combinators (mapLeft)
 import Data.List               (delete)
-import Data.Text               (isInfixOf)
 import Data.Tree               (Tree (..))
 
 import PostgREST.DbStructure.Identifiers  (FieldName,
@@ -41,20 +39,20 @@ import PostgREST.DbStructure.Relationship (Cardinality (..),
                                            Relationship (..))
 import PostgREST.DbStructure.Table        (Column (..), Table (..),
                                            tableQi)
-import PostgREST.Error                    (ApiRequestError (..),
+import PostgREST.Error                    (Error (..))
-                                           Error (..))
 import PostgREST.Query.SqlFragment        (sourceCTEName)
 import PostgREST.RangeQuery               (NonnegRange, allRange,
                                            restrictRange)
 import PostgREST.Request.ApiRequest       (Action (..),
                                            ApiRequest (..),
+                                           InvokeMethod (..),
                                            Payload (..))
 
-import PostgREST.Request.Parsers
 import PostgREST.Request.Preferences
 import PostgREST.Request.Types
 
 import qualified PostgREST.DbStructure.Relationship as Relationship
+import qualified PostgREST.Request.QueryParams      as QueryParams
 
 import Protolude hiding (from)
 
@@ -66,9 +64,9 @@ readRequest schema rootTableName maxRows allRels apiRequest  =
   mapLeft ApiRequestError $
   treeRestrictRange maxRows =<<
   augmentRequestWithJoin schema rootRels =<<
-  (addFiltersOrdersRanges apiRequest . initReadRequest rootName =<< pRequestSelect sel)
+  addFiltersOrdersRanges apiRequest (initReadRequest rootName sel)
   where
-    sel = fromMaybe "*" $ iSelect apiRequest -- default to all columns requested (SELECT *) for a non existent ?select querystring param
+    sel = QueryParams.qsSelect $ iQueryParams apiRequest
     (rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest)
 
 -- Get the root table name with its relationships according to the Action type.
@@ -254,27 +252,22 @@ getJoinConditions previousAlias newAlias (Relationship Table{tableSchema=tSchema
     removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == decodeUtf8 sourceCTEName then mempty else schema) tbl
 
 addFiltersOrdersRanges :: ApiRequest -> ReadRequest -> Either ApiRequestError ReadRequest
-addFiltersOrdersRanges apiRequest rReq = do
+addFiltersOrdersRanges ApiRequest{..} rReq = do
-  rFlts <- foldr addFilter rReq <$> filters
+  flip (foldr addLogicTree) qsLogic <$> (foldr addRange rOrds <$> ranges)
-  rOrds <- foldr addOrder rFlts <$> orders
-  rRngs <- foldr addRange rOrds <$> ranges
-  foldr addLogicTree rRngs      <$> logicForest
   where
-    filters :: Either ApiRequestError [(EmbedPath, Filter)]
+    rFlts = foldr addFilter rReq flts
-    filters = pRequestFilter `traverse` flts
+    rOrds = foldr addOrder rFlts qsOrder
-    orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]
+    QueryParams.QueryParams{..} = iQueryParams
-    orders = pRequestOrder `traverse` iOrder apiRequest
     ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]
-    ranges = pRequestRange `traverse` M.toList (iRange apiRequest)
+    ranges = first QueryParamError $ QueryParams.pRequestRange `traverse` M.toList iRange
-    logicForest :: Either ApiRequestError [(EmbedPath, LogicTree)]
-    logicForest = pRequestLogicTree `traverse` logFrst
-    action = iAction apiRequest
     -- there can be no filters on the root table when we are doing insert/update/delete
-    (flts, logFrst) =
+    flts =
-      case action of
+      case iAction of
-        ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest)
+        ActionInvoke InvGet  -> qsFilters
-        ActionRead _   -> (iFilters apiRequest, iLogic apiRequest)
+        ActionInvoke InvHead -> qsFilters
-        _              -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
+        ActionInvoke _       -> qsFilters
+        ActionRead _         -> qsFilters
+        _                    -> qsFiltersNotRoot
 
 addFilterToNode :: Filter -> ReadRequest -> ReadRequest
 addFilterToNode flt (Node (q@Select {where_=lf}, i) f) = Node (q{where_=addFilterToLogicForest flt lf}::ReadQuery, i) f
@@ -310,41 +303,36 @@ addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =
     pathNode = find (\(Node (_,(nodeName,_,alias,_,_, _)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest
 
 mutateRequest :: Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Error MutateRequest
-mutateRequest schema tName apiRequest pkCols readReq = mapLeft ApiRequestError $
+mutateRequest schema tName ApiRequest{..} pkCols readReq = mapLeft ApiRequestError $
-  case action of
+  case iAction of
-    ActionCreate -> do
+    ActionCreate ->
-        confCols <- case iOnConflict apiRequest of
+      Right $ Insert qi iColumns body ((,) <$> iPreferResolution <*> Just confCols) [] returnings
-            Nothing    -> pure pkCols
+    ActionUpdate -> Right $ Update qi iColumns body combinedLogic returnings
-            Just param -> pRequestOnConflict param
-        pure $ Insert qi (iColumns apiRequest) body ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
-    ActionUpdate -> Update qi (iColumns apiRequest) body  <$> combinedLogic <*> pure returnings
     ActionSingleUpsert ->
-      (\flts ->
+        if null qsLogic &&
-        if null (iLogic apiRequest) &&
+           qsFilterFields == S.fromList pkCols &&
-           S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols &&
            not (null (S.fromList pkCols)) &&
            all (\case
-              Filter _ (OpExpr False (Op "eq" _)) -> True
+              Filter _ (OpExpr False (Op OpEqual _)) -> True
-              _                                   -> False) flts
+              _                                      -> False) filters
-          then Insert qi (iColumns apiRequest) body (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
+          then Right $ Insert qi iColumns body (Just (MergeDuplicates, pkCols)) combinedLogic returnings
         else
-          Left InvalidFilters) =<< filters
+          Left InvalidFilters
-    ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings
+    ActionDelete -> Right $ Delete qi combinedLogic returnings
     _            -> Left UnsupportedVerb
   where
+    confCols = fromMaybe pkCols qsOnConflict
+    QueryParams.QueryParams{..} = iQueryParams
     qi = QualifiedIdentifier schema tName
-    action = iAction apiRequest
     returnings =
-      if iPreferRepresentation apiRequest == None
+      if iPreferRepresentation == None
         then []
         else returningCols readReq pkCols
-    filters = map snd <$> pRequestFilter `traverse` mutateFilters
-    logic = map snd <$> pRequestLogicTree `traverse` logicFilters
-    combinedLogic = foldr addFilterToLogicForest <$> logic <*> filters
     -- update/delete filters can be only on the root table
-    (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest)
+    filters = map snd qsFiltersRoot
-    onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
+    logic = map snd qsLogic
-    body = payRaw <$> iPayload apiRequest -- the body is assumed to be json at this stage(ApiRequest validates)
+    combinedLogic = foldr addFilterToLogicForest logic filters
+    body = payRaw <$> iPayload -- the body is assumed to be json at this stage(ApiRequest validates)
 
 callRequest :: ProcDescription -> ApiRequest -> ReadRequest -> CallRequest
 callRequest proc apiReq readReq = FunctionCall {

src/PostgREST/Request/Parsers.hs

@@ -1,300 +0,0 @@
-{-|
-Module      : PostgREST.Request.Parsers
-Description : PostgREST parser combinators
-
-This module is in charge of parsing all the querystring values in an url, e.g. the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.
--}
-module PostgREST.Request.Parsers
-  ( pColumns
-  , pLogicPath
-  , pLogicSingleVal
-  , pLogicTree
-  , pOrder
-  , pOrderTerm
-  , pRequestColumns
-  , pRequestFilter
-  , pRequestLogicTree
-  , pRequestOnConflict
-  , pRequestOrder
-  , pRequestRange
-  , pRequestSelect
-  , pSingleVal
-  , pTreePath
-  ) where
-
-import qualified Data.HashMap.Strict as M
-import qualified Data.Set            as S
-
-import Data.Either.Combinators       (mapLeft)
-import Data.Foldable                 (foldl1)
-import Data.List                     (init, last)
-import Data.Text                     (intercalate, replace, strip)
-import Data.Tree                     (Tree (..))
-import Text.Parsec.Error             (errorMessages,
-                                      showErrorMessages)
-import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,
-                                      anyChar, between, char, digit,
-                                      eof, errorPos, letter,
-                                      lookAhead, many1, noneOf,
-                                      notFollowedBy, oneOf, option,
-                                      optionMaybe, parse, sepBy1,
-                                      string, try, (<?>))
-
-import PostgREST.DbStructure.Identifiers (FieldName)
-import PostgREST.Error                   (ApiRequestError (ParseRequestError))
-import PostgREST.Query.SqlFragment       (ftsOperators, operators)
-import PostgREST.RangeQuery              (NonnegRange)
-
-import PostgREST.Request.Types
-
-import Protolude hiding (intercalate, option, replace, try)
-
-pRequestSelect :: Text -> Either ApiRequestError [Tree SelectItem]
-pRequestSelect selStr =
-  mapError $ parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
-
-pRequestOnConflict :: Text -> Either ApiRequestError  [FieldName]
-pRequestOnConflict oncStr =
-  mapError $ parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr)
-
-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 (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
-    path = fst <$> treePath
-    fld = snd <$> treePath
-
-pRequestOrder :: (Text, Text) -> Either ApiRequestError (EmbedPath, [OrderTerm])
-pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
-  where
-    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
-    path = fst <$> treePath
-    ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
-
-pRequestRange :: (Text, NonnegRange) -> Either ApiRequestError (EmbedPath, NonnegRange)
-pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
-  where
-    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
-    logicTree = do
-      op <- snd <$> path
-      -- Concat op and v to make pLogicTree argument regular,
-      -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
-      parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v)
-
-pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName))
-pRequestColumns colStr =
-  case colStr of
-    Just str ->
-      mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)
-    _ -> Right Nothing
-
-ws :: Parser Text
-ws = toS <$> many (oneOf " \t")
-
-lexeme :: Parser a -> Parser a
-lexeme p = ws *> p <* ws
-
-pTreePath :: Parser (EmbedPath, Field)
-pTreePath = do
-  p <- pFieldName `sepBy1` pDelimiter
-  jp <- option [] pJsonPath
-  return (init p, (last p, jp))
-
-pFieldForest :: Parser [Tree SelectItem]
-pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
-  where
-    pFieldTree :: Parser (Tree SelectItem)
-    pFieldTree =  try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|>
-                  Node <$> pFieldSelect <*> pure []
-
-pStar :: Parser Text
-pStar = string "*" $> "*"
-
-pFieldName :: Parser Text
-pFieldName =
-  pQuotedValue <|>
-  intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) <?>
-  "field name (* or [a..z0..9_])"
-  where
-    isDash :: GenParser Char st ()
-    isDash = try ( char '-' >> notFollowedBy (char '>') )
-    dash :: Parser Char
-    dash = isDash $> '-'
-
-pJsonPath :: Parser JsonPath
-pJsonPath = many pJsonOperation
-  where
-    pJsonOperation :: Parser JsonOperation
-    pJsonOperation = pJsonArrow <*> pJsonOperand
-
-    pJsonArrow   =
-      try (string "->>" $> J2Arrow) <|>
-      try (string "->" $> JArrow)
-
-    pJsonOperand =
-      let pJKey = JKey . toS <$> pFieldName
-          pJIdx = JIdx . toS <$> ((:) <$> option '+' (char '-') <*> many1 digit) <* pEnd
-          pEnd = try (void $ lookAhead (string "->")) <|>
-                 try (void $ lookAhead (string "::")) <|>
-                 try eof in
-      try pJIdx <|> try pJKey
-
-pField :: Parser Field
-pField = lexeme $ (,) <$> pFieldName <*> option [] pJsonPath
-
-aliasSeparator :: Parser ()
-aliasSeparator = char ':' >> notFollowedBy (char ':')
-
-pRelationSelect :: Parser SelectItem
-pRelationSelect = lexeme $ try ( do
-    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
-    fld <- pField
-    prm1 <- optionMaybe pEmbedParam
-    prm2 <- optionMaybe pEmbedParam
-    return (fld, Nothing, alias, embedParamHint prm1 <|> embedParamHint prm2, embedParamJoin prm1 <|> embedParamJoin prm2)
-  )
-  where
-    pEmbedParam :: Parser EmbedParam
-    pEmbedParam =
-      char '!' *> (
-        try (string "left"  $> EPJoinType JTLeft)  <|>
-        try (string "inner" $> EPJoinType JTInner) <|>
-        try (EPHint <$> pFieldName))
-    embedParamHint prm = case prm of
-      Just (EPHint hint) -> Just hint
-      _                  -> Nothing
-    embedParamJoin prm = case prm of
-      Just (EPJoinType jt) -> Just jt
-      _                    -> Nothing
-
-pFieldSelect :: Parser SelectItem
-pFieldSelect = lexeme $
-  try (
-    do
-      alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
-      fld <- pField
-      cast' <- optionMaybe (string "::" *> many letter)
-      return (fld, toS <$> cast', alias, Nothing, Nothing)
-  )
-  <|> do
-    s <- pStar
-    return ((s, []), Nothing, Nothing, Nothing, Nothing)
-
-pOpExpr :: Parser SingleVal -> Parser OpExpr
-pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation
-  where
-    pOperation :: Parser Operation
-    pOperation =
-          Op . toS <$> foldl1 (<|>) (try . ((<* pDelimiter) . string) . toS <$> M.keys ops) <*> pSVal
-      <|> In <$> (try (string "in" *> pDelimiter) *> pListVal)
-      <|> Is <$> (try (string "is" *> pDelimiter) *> pTriVal)
-      <|> pFts
-      <?> "operator (eq, gt, ...)"
-
-    pTriVal = try (ciString "null"    $> TriNull)
-          <|> try (ciString "unknown" $> TriUnknown)
-          <|> try (ciString "true"    $> TriTrue)
-          <|> try (ciString "false"   $> TriFalse)
-          <?> "null or trilean value (unknown, true, false)"
-
-    pFts = do
-      op   <- foldl1 (<|>) (try . string . toS <$> ftsOps)
-      lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_")))
-      pDelimiter >> Fts (toS op) (toS <$> lang) <$> pSVal
-
-    ops = M.filterWithKey (const . flip notElem ("in":"is":ftsOps)) operators
-    ftsOps = M.keys ftsOperators
-
-    -- case insensitive char and string
-    ciChar :: Char -> GenParser Char state Char
-    ciChar c = char c <|> char (toUpper c)
-    ciString :: [Char] -> GenParser Char state [Char]
-    ciString = traverse ciChar
-
-pSingleVal :: Parser SingleVal
-pSingleVal = toS <$> many anyChar
-
-pListVal :: Parser ListVal
-pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')
-
-pListElement :: Parser Text
-pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)"))
-
-pQuotedValue :: Parser Text
-pQuotedValue = toS <$> (char '"' *> many pCharsOrSlashed <* char '"')
-  where
-    pCharsOrSlashed = noneOf "\\\"" <|> (char '\\' *> anyChar)
-
-pDelimiter :: Parser Char
-pDelimiter = char '.' <?> "delimiter (.)"
-
-pOrder :: Parser [OrderTerm]
-pOrder = lexeme pOrderTerm `sepBy1` char ','
-
-pOrderTerm :: Parser OrderTerm
-pOrderTerm = do
-  fld <- pField
-  dir <- optionMaybe $
-         try (pDelimiter *> string "asc" $> OrderAsc) <|>
-         try (pDelimiter *> string "desc" $> OrderDesc)
-  nls <- optionMaybe pNulls <* pEnd <|>
-         pEnd $> Nothing
-  return $ OrderTerm fld dir nls
-  where
-    pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>
-             try (pDelimiter *> string "nullslast"  $> OrderNullsLast)
-    pEnd = try (void $ lookAhead (char ',')) <|>
-           try eof
-
-pLogicTree :: Parser LogicTree
-pLogicTree = Stmnt <$> try pLogicFilter
-             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')'))
-  where
-    pLogicFilter :: Parser Filter
-    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal
-    pNot :: Parser Bool
-    pNot = try (string "not" *> pDelimiter $> True)
-           <|> pure False
-           <?> "negation operator (not)"
-    pLogicOp :: Parser LogicOperator
-    pLogicOp = try (string "and" $> And)
-               <|> string "or" $> Or
-               <?> "logic operator (and, or)"
-
-pLogicSingleVal :: Parser SingleVal
-pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)"))
-  where
-    pPgArray :: Parser Text
-    pPgArray =  do
-      a <- string "{"
-      b <- many (noneOf "{}")
-      c <- string "}"
-      pure (toS $ a ++ b ++ c)
-
-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)
-
-pColumns :: Parser [FieldName]
-pColumns = pFieldName `sepBy1` lexeme (char ',')
-
-mapError :: Either ParseError a -> Either ApiRequestError a
-mapError = mapLeft translateError
-  where
-    translateError e =
-      ParseRequestError message details
-      where
-        message = show $ errorPos e
-        details = strip $ replace "\n" " " $ toS
-           $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)

src/PostgREST/Request/QueryParams.hs

@@ -0,0 +1,495 @@
+-- |
+-- Module      : PostgREST.Request.QueryParams
+-- Description : Parser for PostgREST Query paramters
+--
+-- This module is in charge of parsing all the querystring values in an url, e.g.
+-- the select, id, order in `/projects?select=id,name&id=eq.1&order=id,name.desc`.
+{-# LANGUAGE LambdaCase    #-}
+{-# LANGUAGE TupleSections #-}
+module PostgREST.Request.QueryParams
+  ( parse
+  , QueryParams(..)
+  , pRequestRange
+  ) where
+
+import qualified Data.ByteString.Char8         as BS
+import qualified Data.HashMap.Strict           as M
+import qualified Data.List                     as L
+import qualified Data.Set                      as S
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as T
+import qualified Network.HTTP.Base             as HTTP
+import qualified Network.HTTP.Types.URI        as HTTP
+import qualified Text.ParserCombinators.Parsec as P
+
+import Control.Arrow                 ((***))
+import Data.Either.Combinators       (mapLeft)
+import Data.List                     (init, last)
+import Data.Ranged.Boundaries        (Boundary (..))
+import Data.Ranged.Ranges            (Range (..))
+import Data.Tree                     (Tree (..))
+import Text.Parsec.Error             (errorMessages,
+                                      showErrorMessages)
+import Text.Parsec.Prim              (parserFail)
+import Text.ParserCombinators.Parsec (GenParser, ParseError, Parser,
+                                      anyChar, between, char, digit,
+                                      eof, errorPos, letter,
+                                      lookAhead, many1, noneOf,
+                                      notFollowedBy, oneOf,
+                                      optionMaybe, sepBy1, string,
+                                      try, (<?>))
+
+import PostgREST.DbStructure.Identifiers (FieldName)
+import PostgREST.RangeQuery              (NonnegRange, allRange,
+                                          rangeGeq, rangeLimit,
+                                          rangeOffset, restrictRange)
+
+import PostgREST.Request.Types (EmbedParam (..), EmbedPath, Field,
+                                Filter (..), FtsOperator (..),
+                                JoinType (..), JsonOperand (..),
+                                JsonOperation (..), JsonPath, ListVal,
+                                LogicOperator (..), LogicTree (..),
+                                OpExpr (..), Operation (..),
+                                OrderDirection (..), OrderNulls (..),
+                                OrderTerm (..), QPError (..),
+                                SelectItem, SingleVal,
+                                SimpleOperator (..),
+                                TrileanVal (..))
+
+import Protolude hiding (try)
+
+
+-- $setup
+-- Setup for doctests
+-- >>> import Text.Pretty.Simple (pPrint)
+-- >>> deriving instance Show QPError
+-- >>> deriving instance Show TrileanVal
+-- >>> deriving instance Show FtsOperator
+-- >>> deriving instance Show SimpleOperator
+-- >>> deriving instance Show Operation
+-- >>> deriving instance Show OpExpr
+-- >>> deriving instance Show JsonOperand
+-- >>> deriving instance Show JsonOperation
+-- >>> deriving instance Show Filter
+-- >>> deriving instance Show JoinType
+
+data QueryParams =
+  QueryParams
+    { qsCanonical      :: ByteString
+    -- ^ Canonical representation of the query params, sorted alphabetically
+    , qsParams         :: [(Text, Text)]
+    -- ^ Parameters for RPC calls
+    , qsRanges         :: M.HashMap Text (Range Integer)
+    -- ^ Ranges derived from &limit and &offset params
+    , qsOrder          :: [(EmbedPath, [OrderTerm])]
+    -- ^ &order parameters for each level
+    , qsLogic          :: [(EmbedPath, LogicTree)]
+    -- ^ &and and &or parameters used for complex boolean logic
+    , qsColumns        :: Maybe (S.Set FieldName)
+    -- ^ &columns parameter and payload
+    , qsSelect         :: [Tree SelectItem]
+    -- ^ &select parameter used to shape the response
+    , qsFilters        :: [(EmbedPath, Filter)]
+    -- ^ Filters on the result from e.g. &id=e.10
+    , qsFiltersRoot    :: [(EmbedPath, Filter)]
+    -- ^ Subset of the filters that apply on the root table
+    , qsFiltersNotRoot :: [(EmbedPath, Filter)]
+    -- ^ Subset of the filters that do not apply on the root table
+    , qsFilterFields   :: S.Set FieldName
+    -- ^ Set of fields that filters apply to
+    , qsOnConflict     :: Maybe [FieldName]
+    -- ^ &on_conflict parameter used to upsert on specific unique keys
+    }
+
+-- |
+-- Parse query parameters from a query string like "id=eq.1&select=name".
+--
+-- The canonical representation of the query string has paramters sorted alphabetically:
+--
+-- >>> qsCanonical <$> parse "a=1&c=3&b=2&d"
+-- Right "a=1&b=2&c=3&d="
+--
+-- 'select' is a reserved parameter that selects the fields to be returned:
+--
+-- >>> qsSelect <$> parse "select=name,location"
+-- Right [Node {rootLabel = (("name",[]),Nothing,Nothing,Nothing,Nothing), subForest = []},Node {rootLabel = (("location",[]),Nothing,Nothing,Nothing,Nothing), subForest = []}]
+--
+-- Filters are parameters whose value contains an operator, separated by a '.' from its value:
+--
+-- >>> qsFilters <$> parse "a.b=eq.0"
+-- Right [(["a"],Filter {field = ("b",[]), opExpr = OpExpr False (Op OpEqual "0")})]
+--
+-- If the operator specified in a filter does not exist, parsing the query string fails:
+--
+-- >>> qsFilters <$> parse "a.b=noop.0"
+-- Left (QPError "\"failed to parse filter (noop.0)\" (line 1, column 6)" "unknown single value operator noop")
+parse :: ByteString -> Either QPError QueryParams
+parse qs =
+  QueryParams
+    canonical
+    params
+    ranges
+    <$> pRequestOrder `traverse` order
+    <*> pRequestLogicTree `traverse` logic
+    <*> pRequestColumns columns
+    <*> pRequestSelect select
+    <*> pRequestFilter `traverse` filters
+    <*> pRequestFilter `traverse` filtersRoot
+    <*> pRequestFilter `traverse` filtersNotRoot
+    <*> pure (S.fromList (fst <$> filters))
+    <*> sequenceA (pRequestOnConflict <$> onConflict)
+  where
+    logic = filter (endingIn ["and", "or"] . fst) nonemptyParams
+    select = fromMaybe "*" $ lookupParam "select"
+    onConflict = lookupParam "on_conflict"
+    columns = lookupParam "columns"
+    order = filter (endingIn ["order"] . fst) nonemptyParams
+    limits = filter (endingIn ["limit"] . fst) nonemptyParams
+    -- Replace .offset ending with .limit to be able to match those params later in a map
+    offsets = first (replaceLast "limit") <$> filter (endingIn ["offset"] . fst) nonemptyParams
+    lookupParam :: Text -> Maybe Text
+    lookupParam needle = toS <$> join (L.lookup needle qParams)
+    nonemptyParams = mapMaybe (\(k, v) -> (k,) <$> v) qParams
+
+    qString = HTTP.parseQueryReplacePlus True qs
+
+    qParams = [(T.decodeUtf8 k, T.decodeUtf8 <$> v)|(k,v) <- qString]
+
+    canonical =
+      BS.pack $ HTTP.urlEncodeVars
+        . L.sortOn fst
+        . map (join (***) BS.unpack . second (fromMaybe mempty))
+        $ qString
+
+    endingIn:: [Text] -> Text -> Bool
+    endingIn xx key = lastWord `elem` xx
+      where lastWord = L.last $ T.split (== '.') key
+
+    (filters, params) = L.partition isParam filtersAndParams
+    isParam (k, v) = isEmbedPath k || hasOperator v || hasFtsOperator v
+
+    filtersAndParams = filter (isFilterOrParam . fst)  nonemptyParams
+    isFilterOrParam k = not (endingIn reservedEmbeddable k) && notElem k reserved
+    reserved = ["select", "columns", "on_conflict"]
+    reservedEmbeddable = ["order", "limit", "offset", "and", "or"]
+
+    (filtersNotRoot, filtersRoot) = L.partition isNotRoot filters
+    isNotRoot = flip T.isInfixOf "." . fst
+
+    -- TODO: These checks are redundant to the parsers, should use parsers to differentiate params
+    hasOperator val =
+      case T.splitOn "." val of
+        "not" : _ : _ -> True
+        "is" : _      -> True
+        "in" : _      -> True
+        x : _         -> isJust (operator x) || isJust (ftsOperator x)
+        _             -> False
+
+    hasFtsOperator val =
+      case T.splitOn "(" val of
+        x : _ : _ -> isJust $ ftsOperator x
+        _         -> False
+
+    isEmbedPath = T.isInfixOf "."
+    replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) <> [x]
+
+    ranges :: M.HashMap Text (Range Integer)
+    ranges = M.unionWith f limitParams offsetParams
+      where
+        f rl ro = Range (BoundaryBelow o) (BoundaryAbove $ o + l - 1)
+          where
+            l = fromMaybe 0 $ rangeLimit rl
+            o = rangeOffset ro
+
+        limitParams =
+          M.fromList [(k, restrictRange (readMaybe $ toS v) allRange) | (k,v) <- limits]
+
+        offsetParams =
+          M.fromList [(k, maybe allRange rangeGeq (readMaybe $ toS v)) | (k,v) <- offsets]
+
+operator :: Text -> Maybe SimpleOperator
+operator = \case
+  "eq"    -> Just OpEqual
+  "gte"   -> Just OpGreaterThanEqual
+  "gt"    -> Just OpGreaterThan
+  "lte"   -> Just OpLessThanEqual
+  "lt"    -> Just OpLessThan
+  "neq"   -> Just OpNotEqual
+  "like"  -> Just OpLike
+  "ilike" -> Just OpILike
+  "cs"    -> Just OpContains
+  "cd"    -> Just OpContained
+  "ov"    -> Just OpOverlap
+  "sl"    -> Just OpStrictlyLeft
+  "sr"    -> Just OpStrictlyRight
+  "nxr"   -> Just OpNotExtendsRight
+  "nxl"   -> Just OpNotExtendsLeft
+  "adj"   -> Just OpAdjacent
+  _       -> Nothing
+
+ftsOperator :: Text -> Maybe FtsOperator
+ftsOperator = \case
+  "fts"   -> Just FilterFts
+  "plfts" -> Just FilterFtsPlain
+  "phfts" -> Just FilterFtsPhrase
+  "wfts"  -> Just FilterFtsWebsearch
+  _       -> Nothing
+
+
+-- PARSERS
+
+
+pRequestSelect :: Text -> Either QPError [Tree SelectItem]
+pRequestSelect selStr =
+  mapError $ P.parse pFieldForest ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
+
+pRequestOnConflict :: Text -> Either QPError [FieldName]
+pRequestOnConflict oncStr =
+  mapError $ P.parse pColumns ("failed to parse on_conflict parameter (" <> toS oncStr <> ")") (toS oncStr)
+
+pRequestFilter :: (Text, Text) -> Either QPError (EmbedPath, Filter)
+pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
+  where
+    treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
+    oper = P.parse (pOpExpr pSingleVal) ("failed to parse filter (" ++ toS v ++ ")") $ toS v
+    path = fst <$> treePath
+    fld = snd <$> treePath
+
+pRequestOrder :: (Text, Text) -> Either QPError (EmbedPath, [OrderTerm])
+pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
+  where
+    treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
+    path = fst <$> treePath
+    ord' = P.parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
+
+pRequestRange :: (Text, NonnegRange) -> Either QPError (EmbedPath, NonnegRange)
+pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
+  where
+    treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
+    path = fst <$> treePath
+
+pRequestLogicTree :: (Text, Text) -> Either QPError (EmbedPath, LogicTree)
+pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
+  where
+    path = P.parse pLogicPath ("failed to parse logic path (" ++ toS k ++ ")") $ toS k
+    embedPath = fst <$> path
+    logicTree = do
+      op <- snd <$> path
+      -- Concat op and v to make pLogicTree argument regular,
+      -- in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
+      P.parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") $ toS (op <> v)
+
+pRequestColumns :: Maybe Text -> Either QPError (Maybe (S.Set FieldName))
+pRequestColumns colStr =
+  case colStr of
+    Just str ->
+      mapError $ Just . S.fromList <$> P.parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)
+    _ -> Right Nothing
+
+ws :: Parser Text
+ws = toS <$> many (oneOf " \t")
+
+lexeme :: Parser a -> Parser a
+lexeme p = ws *> p <* ws
+
+pTreePath :: Parser (EmbedPath, Field)
+pTreePath = do
+  p <- pFieldName `sepBy1` pDelimiter
+  jp <- P.option [] pJsonPath
+  return (init p, (last p, jp))
+
+pFieldForest :: Parser [Tree SelectItem]
+pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
+  where
+    pFieldTree :: Parser (Tree SelectItem)
+    pFieldTree =  try (Node <$> pRelationSelect <*> between (char '(') (char ')') pFieldForest) <|>
+                  Node <$> pFieldSelect <*> pure []
+
+pStar :: Parser Text
+pStar = string "*" $> "*"
+
+pFieldName :: Parser Text
+pFieldName =
+  pQuotedValue <|>
+  T.intercalate "-" . map toS <$> (many1 (letter <|> digit <|> oneOf "_ ") `sepBy1` dash) <?>
+  "field name (* or [a..z0..9_])"
+  where
+    isDash :: GenParser Char st ()
+    isDash = try ( char '-' >> notFollowedBy (char '>') )
+    dash :: Parser Char
+    dash = isDash $> '-'
+
+pJsonPath :: Parser JsonPath
+pJsonPath = many pJsonOperation
+  where
+    pJsonOperation :: Parser JsonOperation
+    pJsonOperation = pJsonArrow <*> pJsonOperand
+
+    pJsonArrow   =
+      try (string "->>" $> J2Arrow) <|>
+      try (string "->" $> JArrow)
+
+    pJsonOperand =
+      let pJKey = JKey . toS <$> pFieldName
+          pJIdx = JIdx . toS <$> ((:) <$> P.option '+' (char '-') <*> many1 digit) <* pEnd
+          pEnd = try (void $ lookAhead (string "->")) <|>
+                 try (void $ lookAhead (string "::")) <|>
+                 try eof in
+      try pJIdx <|> try pJKey
+
+pField :: Parser Field
+pField = lexeme $ (,) <$> pFieldName <*> P.option [] pJsonPath
+
+aliasSeparator :: Parser ()
+aliasSeparator = char ':' >> notFollowedBy (char ':')
+
+pRelationSelect :: Parser SelectItem
+pRelationSelect = lexeme $ try ( do
+    alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
+    fld <- pField
+    prm1 <- optionMaybe pEmbedParam
+    prm2 <- optionMaybe pEmbedParam
+    return (fld, Nothing, alias, embedParamHint prm1 <|> embedParamHint prm2, embedParamJoin prm1 <|> embedParamJoin prm2)
+  )
+  where
+    pEmbedParam :: Parser EmbedParam
+    pEmbedParam =
+      char '!' *> (
+        try (string "left"  $> EPJoinType JTLeft)  <|>
+        try (string "inner" $> EPJoinType JTInner) <|>
+        try (EPHint <$> pFieldName))
+    embedParamHint prm = case prm of
+      Just (EPHint hint) -> Just hint
+      _                  -> Nothing
+    embedParamJoin prm = case prm of
+      Just (EPJoinType jt) -> Just jt
+      _                    -> Nothing
+
+pFieldSelect :: Parser SelectItem
+pFieldSelect = lexeme $
+  try (
+    do
+      alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
+      fld <- pField
+      cast' <- optionMaybe (string "::" *> many letter)
+      return (fld, toS <$> cast', alias, Nothing, Nothing)
+  )
+  <|> do
+    s <- pStar
+    return ((s, []), Nothing, Nothing, Nothing, Nothing)
+
+pOpExpr :: Parser SingleVal -> Parser OpExpr
+pOpExpr pSVal = try ( string "not" *> pDelimiter *> (OpExpr True <$> pOperation)) <|> OpExpr False <$> pOperation
+  where
+    pOperation :: Parser Operation
+    pOperation = pIn <|> pIs <|> try pFts <|> pOp <?> "operator (eq, gt, ...)"
+
+    pIn = In <$> (try (string "in" *> pDelimiter) *> pListVal)
+    pIs = Is <$> (try (string "is" *> pDelimiter) *> pTriVal)
+
+    pOp = do
+      opStr <- try (P.manyTill anyChar (try pDelimiter))
+      op <- parseMaybe ("unknown single value operator " <> opStr) . operator $ toS opStr
+      Op op <$> pSVal
+
+    pTriVal = try (ciString "null"    $> TriNull)
+          <|> try (ciString "unknown" $> TriUnknown)
+          <|> try (ciString "true"    $> TriTrue)
+          <|> try (ciString "false"   $> TriFalse)
+          <?> "null or trilean value (unknown, true, false)"
+
+    pFts = do
+      opStr <- try (P.many (noneOf ".("))
+      op <- parseMaybe ("unknown fts operator " <> opStr) . ftsOperator $ toS opStr
+      lang <- optionMaybe $ try (between (char '(') (char ')') (many (letter <|> digit <|> oneOf "_")))
+      pDelimiter >> Fts op (toS <$> lang) <$> pSVal
+
+    parseMaybe :: [Char] -> Maybe a -> Parser a
+    parseMaybe err Nothing = parserFail err
+    parseMaybe _ (Just x)  = pure x
+
+    -- case insensitive char and string
+    ciChar :: Char -> GenParser Char state Char
+    ciChar c = char c <|> char (toUpper c)
+    ciString :: [Char] -> GenParser Char state [Char]
+    ciString = traverse ciChar
+
+pSingleVal :: Parser SingleVal
+pSingleVal = toS <$> many anyChar
+
+pListVal :: Parser ListVal
+pListVal = lexeme (char '(') *> pListElement `sepBy1` char ',' <* lexeme (char ')')
+
+pListElement :: Parser Text
+pListElement = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> (toS <$> many (noneOf ",)"))
+
+pQuotedValue :: Parser Text
+pQuotedValue = toS <$> (char '"' *> many pCharsOrSlashed <* char '"')
+  where
+    pCharsOrSlashed = noneOf "\\\"" <|> (char '\\' *> anyChar)
+
+pDelimiter :: Parser Char
+pDelimiter = char '.' <?> "delimiter (.)"
+
+pOrder :: Parser [OrderTerm]
+pOrder = lexeme pOrderTerm `sepBy1` char ','
+
+pOrderTerm :: Parser OrderTerm
+pOrderTerm = do
+  fld <- pField
+  dir <- optionMaybe $
+         try (pDelimiter *> string "asc" $> OrderAsc) <|>
+         try (pDelimiter *> string "desc" $> OrderDesc)
+  nls <- optionMaybe pNulls <* pEnd <|>
+         pEnd $> Nothing
+  return $ OrderTerm fld dir nls
+  where
+    pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>
+             try (pDelimiter *> string "nullslast"  $> OrderNullsLast)
+    pEnd = try (void $ lookAhead (char ',')) <|>
+           try eof
+
+pLogicTree :: Parser LogicTree
+pLogicTree = Stmnt <$> try pLogicFilter
+             <|> Expr <$> pNot <*> pLogicOp <*> (lexeme (char '(') *> pLogicTree `sepBy1` lexeme (char ',') <* lexeme (char ')'))
+  where
+    pLogicFilter :: Parser Filter
+    pLogicFilter = Filter <$> pField <* pDelimiter <*> pOpExpr pLogicSingleVal
+    pNot :: Parser Bool
+    pNot = try (string "not" *> pDelimiter $> True)
+           <|> pure False
+           <?> "negation operator (not)"
+    pLogicOp :: Parser LogicOperator
+    pLogicOp = try (string "and" $> And)
+               <|> string "or" $> Or
+               <?> "logic operator (and, or)"
+
+pLogicSingleVal :: Parser SingleVal
+pLogicSingleVal = try (pQuotedValue <* notFollowedBy (noneOf ",)")) <|> try pPgArray <|> (toS <$> many (noneOf ",)"))
+  where
+    pPgArray :: Parser Text
+    pPgArray =  do
+      a <- string "{"
+      b <- many (noneOf "{}")
+      c <- string "}"
+      pure (toS $ a ++ b ++ c)
+
+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)
+
+pColumns :: Parser [FieldName]
+pColumns = pFieldName `sepBy1` lexeme (char ',')
+
+mapError :: Either ParseError a -> Either QPError a
+mapError = mapLeft translateError
+  where
+    translateError e =
+      QPError message details
+      where
+        message = show $ errorPos e
+        details = T.strip $ T.replace "\n" " " $ toS
+           $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)

src/PostgREST/Request/Types.hs

@@ -3,6 +3,7 @@ module PostgREST.Request.Types
   ( Alias
   , Depth
   , EmbedParam(..)
+  , ApiRequestError(..)
   , EmbedPath
   , Field
   , Filter(..)
@@ -26,6 +27,7 @@ module PostgREST.Request.Types
   , OrderDirection(..)
   , OrderNulls(..)
   , OrderTerm(..)
+  , QPError(..)
   , ReadNode
   , ReadQuery(..)
   , ReadRequest
@@ -33,6 +35,8 @@ module PostgREST.Request.Types
   , SingleVal
   , TrileanVal(..)
   , fstFieldNames
+  , SimpleOperator(..)
+  , FtsOperator(..)
   ) where
 
 import qualified Data.ByteString.Lazy as LBS
@@ -40,9 +44,11 @@ import qualified Data.Set             as S
 
 import Data.Tree (Tree (..))
 
+import PostgREST.ContentType              (ContentType (..))
 import PostgREST.DbStructure.Identifiers  (FieldName,
                                            QualifiedIdentifier)
-import PostgREST.DbStructure.Proc         (ProcParam (..))
+import PostgREST.DbStructure.Proc         (ProcDescription (..),
+                                           ProcParam (..))
 import PostgREST.DbStructure.Relationship (Relationship)
 import PostgREST.RangeQuery               (NonnegRange)
 import PostgREST.Request.Preferences      (PreferResolution)
@@ -50,6 +56,24 @@ import PostgREST.Request.Preferences      (PreferResolution)
 import Protolude
 
 
+
+data ApiRequestError
+  = ActionInappropriate
+  | InvalidRange
+  | InvalidBody ByteString
+  | ParseRequestError Text Text
+  | QueryParamError QPError
+  | NoRelBetween Text Text Text
+  | AmbiguousRelBetween Text Text [Relationship]
+  | AmbiguousRpc [ProcDescription]
+  | NoRpc Text Text [Text] Bool ContentType Bool
+  | InvalidFilters
+  | UnacceptableSchema [Text]
+  | ContentTypeError [ByteString]
+  | UnsupportedVerb                -- Unreachable?
+
+data QPError = QPError Text Text
+
 type ReadRequest = Tree ReadNode
 type MutateRequest = MutateQuery
 type CallRequest = CallQuery
@@ -208,13 +232,12 @@ data OpExpr =
   deriving (Eq)
 
 data Operation
-  = Op Operator SingleVal
+  = Op SimpleOperator SingleVal
   | In ListVal
   | Is TrileanVal
-  | Fts Operator (Maybe Language) SingleVal
+  | Fts FtsOperator (Maybe Language) SingleVal
   deriving (Eq)
 
-type Operator = Text
 type Language = Text
 
 -- | Represents a single value in a filter, e.g. id=eq.singleval
@@ -230,3 +253,30 @@ data TrileanVal
   | TriNull
   | TriUnknown
   deriving Eq
+
+data SimpleOperator
+  = OpEqual
+  | OpGreaterThanEqual
+  | OpGreaterThan
+  | OpLessThanEqual
+  | OpLessThan
+  | OpNotEqual
+  | OpLike
+  | OpILike
+  | OpContains
+  | OpContained
+  | OpOverlap
+  | OpStrictlyLeft
+  | OpStrictlyRight
+  | OpNotExtendsRight
+  | OpNotExtendsLeft
+  | OpAdjacent
+  deriving Eq
+
+-- | Operators for full text search operators
+data FtsOperator
+  = FilterFts
+  | FilterFtsPlain
+  | FilterFtsPhrase
+  | FilterFtsWebsearch
+  deriving Eq

test/Feature/QuerySpec.hs

@@ -914,7 +914,7 @@ spec actualPgVersion = do
         { matchHeaders = [matchContentTypeJson] }
 
     it "fails if an operator is not given" $
-      get "/ghostBusters?id=0" `shouldRespondWith` [json| {"details":"unexpected \"0\" expecting \"not\" or operator (eq, gt, ...)","message":"\"failed to parse filter (0)\" (line 1, column 1)"} |]
+      get "/ghostBusters?id=0" `shouldRespondWith` [json| {"details":"Failed to parse [(\"id\",\"0\")]","message":"Unexpected param or filter missing operator"} |]
         { matchStatus  = 400
         , matchHeaders = [matchContentTypeJson]
         }

test/doctests/Main.hs

@@ -8,10 +8,10 @@ import Protolude
 main :: IO ()
 main =
   doctest
-    [ "--verbose"
+    [ "-XOverloadedStrings"
-    , "-XOverloadedStrings"
     , "-XNoImplicitPrelude"
     , "-XStandaloneDeriving"
     , "-isrc"
     , "src/PostgREST/Request/Preferences.hs"
+    , "src/PostgREST/Request/QueryParams.hs"
     ]