chore: move executable code to src/
src/ now contains all source code - in subdirectories, according to the .cabal component they belong to. This will allow us to put vendored libraries in the same place - and later split our own code into multiple components/libraries as well.
This commit is contained in:
Wolfgang Walther
@@ -0,0 +1,138 @@
|
||||
-- |
|
||||
-- Module : PostgREST.ApiRequest.Payload
|
||||
-- Description : Parser for PostgREST Request Body
|
||||
--
|
||||
-- This module is in charge of parsing the request body (payload)
|
||||
--
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module PostgREST.ApiRequest.Payload
|
||||
( getPayload
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.Aeson.Key as K
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Csv as CSV
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Data.Aeson.Types (emptyArray, emptyObject)
|
||||
import Data.Either.Combinators (mapBoth)
|
||||
import Network.HTTP.Types.URI (parseSimpleQuery)
|
||||
|
||||
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
|
||||
import PostgREST.ApiRequest.Types
|
||||
import PostgREST.Error (ApiRequestError (..))
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName)
|
||||
|
||||
import qualified PostgREST.MediaType as MediaType
|
||||
|
||||
import Protolude
|
||||
|
||||
getPayload :: RequestBody -> MediaType -> QueryParams -> Action -> Either ApiRequestError (Maybe Payload, S.Set FieldName)
|
||||
getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
|
||||
checkedPayload <- if shouldParsePayload then payload else Right Nothing
|
||||
let cols = case (checkedPayload, columns) of
|
||||
(Just ProcessedJSON{payKeys}, _) -> payKeys
|
||||
(Just ProcessedUrlEncoded{payKeys}, _) -> payKeys
|
||||
(Just RawJSON{}, Just cls) -> cls
|
||||
_ -> S.empty
|
||||
return (checkedPayload, cols)
|
||||
where
|
||||
payload :: Either ApiRequestError (Maybe Payload)
|
||||
payload = mapBoth InvalidBody Just $ case (contentMediaType, isProc) of
|
||||
(MTApplicationJSON, _) ->
|
||||
if isJust columns
|
||||
then Right $ RawJSON reqBody
|
||||
else note "All object keys must match" . payloadAttributes reqBody
|
||||
=<< if LBS.null reqBody && isProc
|
||||
then Right emptyObject
|
||||
else first BS.pack $
|
||||
-- Drop parsing error message in favor of generic one (https://github.com/PostgREST/postgrest/issues/2344)
|
||||
maybe (Left "Empty or invalid json") Right $ JSON.decode reqBody
|
||||
(MTTextCSV, _) -> do
|
||||
json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody)
|
||||
note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
|
||||
(MTUrlEncoded, True) ->
|
||||
Right $ ProcessedUrlEncoded params (S.fromList $ fst <$> params)
|
||||
(MTUrlEncoded, False) ->
|
||||
let paramsMap = HM.fromList $ (identity *** JSON.String) <$> params in
|
||||
Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap)
|
||||
(MTTextPlain, True) -> Right $ RawPay reqBody
|
||||
(MTTextXML, True) -> Right $ RawPay reqBody
|
||||
(MTOctetStream, True) -> Right $ RawPay reqBody
|
||||
(ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
|
||||
|
||||
shouldParsePayload = case action of
|
||||
ActDb (ActRelationMut _ MutationDelete) -> False
|
||||
ActDb (ActRelationMut _ _) -> True
|
||||
ActDb (ActRoutine _ Inv) -> True
|
||||
_ -> False
|
||||
|
||||
columns = case action of
|
||||
ActDb (ActRelationMut _ MutationCreate) -> qsColumns
|
||||
ActDb (ActRelationMut _ MutationUpdate) -> qsColumns
|
||||
ActDb (ActRoutine _ Inv) -> qsColumns
|
||||
_ -> Nothing
|
||||
|
||||
isProc = case action of
|
||||
ActDb (ActRoutine _ _) -> True
|
||||
_ -> False
|
||||
params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
|
||||
|
||||
type CsvData = V.Vector (M.Map Text LBS.ByteString)
|
||||
|
||||
{-|
|
||||
Converts CSV like
|
||||
a,b
|
||||
1,hi
|
||||
2,bye
|
||||
|
||||
into a JSON array like
|
||||
[ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
|
||||
|
||||
The reason for its odd signature is so that it can compose
|
||||
directly with CSV.decodeByName
|
||||
-}
|
||||
csvToJson :: (CSV.Header, CsvData) -> JSON.Value
|
||||
csvToJson (_, vals) =
|
||||
JSON.Array $ V.map rowToJsonObj vals
|
||||
where
|
||||
rowToJsonObj = JSON.Object . KM.fromMapText .
|
||||
M.map (\str ->
|
||||
if str == "NULL"
|
||||
then JSON.Null
|
||||
else JSON.String . T.decodeUtf8 $ LBS.toStrict str
|
||||
)
|
||||
|
||||
payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
|
||||
payloadAttributes raw json =
|
||||
-- Test that Array contains only Objects having the same keys
|
||||
case json of
|
||||
JSON.Array arr ->
|
||||
case arr V.!? 0 of
|
||||
Just (JSON.Object o) ->
|
||||
let canonicalKeys = S.fromList $ K.toText <$> KM.keys o
|
||||
areKeysUniform = all (\case
|
||||
JSON.Object x -> S.fromList (K.toText <$> KM.keys x) == canonicalKeys
|
||||
_ -> False) arr in
|
||||
if areKeysUniform
|
||||
then Just $ ProcessedJSON raw canonicalKeys
|
||||
else Nothing
|
||||
Just _ -> Nothing
|
||||
Nothing -> Just emptyPJArray
|
||||
|
||||
JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ K.toText <$> KM.keys o)
|
||||
|
||||
-- truncate everything else to an empty array.
|
||||
_ -> Just emptyPJArray
|
||||
where
|
||||
emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
|
||||
@@ -0,0 +1,295 @@
|
||||
-- |
|
||||
-- Module: PostgREST.ApiRequest.Preferences
|
||||
-- Description: Track client preferences to be employed when processing requests
|
||||
--
|
||||
-- Track client preferences set in HTTP 'Prefer' headers according to RFC7240[1].
|
||||
--
|
||||
-- [1] https://datatracker.ietf.org/doc/html/rfc7240
|
||||
--
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
module PostgREST.ApiRequest.Preferences
|
||||
( Preferences(..)
|
||||
, PreferCount(..)
|
||||
, PreferHandling(..)
|
||||
, PreferMissing(..)
|
||||
, PreferRepresentation(..)
|
||||
, PreferResolution(..)
|
||||
, PreferTransaction(..)
|
||||
, PreferTimezone(..)
|
||||
, PreferMaxAffected(..)
|
||||
, fromHeaders
|
||||
, shouldCount
|
||||
, shouldExplainCount
|
||||
, prefAppliedHeader
|
||||
, toHeaderValue
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as S
|
||||
import qualified Network.HTTP.Types.Header as HTTP
|
||||
|
||||
import PostgREST.Config.Database (TimezoneNames)
|
||||
|
||||
import Protolude
|
||||
|
||||
-- $setup
|
||||
-- Setup for doctests
|
||||
-- >>> :set -XStandaloneDeriving
|
||||
-- >>> import Text.Pretty.Simple (pPrint)
|
||||
-- >>> import qualified Data.Set as S
|
||||
-- >>> import Protolude
|
||||
-- >>> deriving instance Show PreferResolution
|
||||
-- >>> deriving instance Show PreferRepresentation
|
||||
-- >>> deriving instance Show PreferCount
|
||||
-- >>> deriving instance Show PreferTransaction
|
||||
-- >>> deriving instance Show PreferMissing
|
||||
-- >>> deriving instance Show PreferHandling
|
||||
-- >>> deriving instance Show PreferTimezone
|
||||
-- >>> deriving instance Show PreferMaxAffected
|
||||
-- >>> deriving instance Show Preferences
|
||||
|
||||
-- | Preferences recognized by the application.
|
||||
data Preferences
|
||||
= Preferences
|
||||
{ preferResolution :: Maybe PreferResolution
|
||||
, preferRepresentation :: Maybe PreferRepresentation
|
||||
, preferCount :: Maybe PreferCount
|
||||
, preferTransaction :: Maybe PreferTransaction
|
||||
, preferMissing :: Maybe PreferMissing
|
||||
, preferHandling :: Maybe PreferHandling
|
||||
, preferTimezone :: Maybe PreferTimezone
|
||||
, preferMaxAffected :: Maybe PreferMaxAffected
|
||||
, invalidPrefs :: [ByteString]
|
||||
}
|
||||
|
||||
-- |
|
||||
-- Parse HTTP headers based on RFC7240[1] to identify preferences.
|
||||
--
|
||||
-- >>> let sc = S.fromList ["America/Los_Angeles"]
|
||||
--
|
||||
-- One header with comma-separated values can be used to set multiple preferences:
|
||||
-- >>> pPrint $ fromHeaders True sc [("Prefer", "resolution=ignore-duplicates, count=exact, timezone=America/Los_Angeles, max-affected=100")]
|
||||
-- Preferences
|
||||
-- { preferResolution = Just IgnoreDuplicates
|
||||
-- , preferRepresentation = Nothing
|
||||
-- , preferCount = Just ExactCount
|
||||
-- , preferTransaction = Nothing
|
||||
-- , preferMissing = Nothing
|
||||
-- , preferHandling = Nothing
|
||||
-- , preferTimezone = Just
|
||||
-- ( PreferTimezone "America/Los_Angeles" )
|
||||
-- , preferMaxAffected = Just
|
||||
-- ( PreferMaxAffected 100 )
|
||||
-- , invalidPrefs = []
|
||||
-- }
|
||||
--
|
||||
-- Multiple headers can also be used:
|
||||
--
|
||||
-- >>> pPrint $ fromHeaders True sc [("Prefer", "resolution=ignore-duplicates"), ("Prefer", "count=exact"), ("Prefer", "missing=null"), ("Prefer", "handling=lenient"), ("Prefer", "invalid"), ("Prefer", "max-affected=5999")]
|
||||
-- Preferences
|
||||
-- { preferResolution = Just IgnoreDuplicates
|
||||
-- , preferRepresentation = Nothing
|
||||
-- , preferCount = Just ExactCount
|
||||
-- , preferTransaction = Nothing
|
||||
-- , preferMissing = Just ApplyNulls
|
||||
-- , preferHandling = Just Lenient
|
||||
-- , preferTimezone = Nothing
|
||||
-- , preferMaxAffected = Just
|
||||
-- ( PreferMaxAffected 5999 )
|
||||
-- , invalidPrefs = [ "invalid" ]
|
||||
-- }
|
||||
--
|
||||
-- If a preference is set more than once, only the first is used:
|
||||
--
|
||||
-- >>> preferTransaction $ fromHeaders True sc [("Prefer", "tx=commit, tx=rollback")]
|
||||
-- Just Commit
|
||||
--
|
||||
-- This is also the case across multiple headers:
|
||||
--
|
||||
-- >>> :{
|
||||
-- preferResolution . fromHeaders True sc $
|
||||
-- [ ("Prefer", "resolution=ignore-duplicates")
|
||||
-- , ("Prefer", "resolution=merge-duplicates")
|
||||
-- ]
|
||||
-- :}
|
||||
-- Just IgnoreDuplicates
|
||||
--
|
||||
--
|
||||
-- Preferences can be separated by arbitrary amounts of space, lower-case header is also recognized:
|
||||
--
|
||||
-- >>> pPrint $ fromHeaders True sc [("prefer", "count=exact, tx=commit ,return=representation , missing=default, handling=strict, anything")]
|
||||
-- Preferences
|
||||
-- { preferResolution = Nothing
|
||||
-- , preferRepresentation = Just Full
|
||||
-- , preferCount = Just ExactCount
|
||||
-- , preferTransaction = Just Commit
|
||||
-- , preferMissing = Just ApplyDefaults
|
||||
-- , preferHandling = Just Strict
|
||||
-- , preferTimezone = Nothing
|
||||
-- , preferMaxAffected = Nothing
|
||||
-- , invalidPrefs = [ "anything" ]
|
||||
-- }
|
||||
--
|
||||
fromHeaders :: Bool -> TimezoneNames -> [HTTP.Header] -> Preferences
|
||||
fromHeaders allowTxDbOverride acceptedTzNames headers =
|
||||
Preferences
|
||||
{ preferResolution = parsePrefs [MergeDuplicates, IgnoreDuplicates]
|
||||
, preferRepresentation = parsePrefs [Full, None, HeadersOnly]
|
||||
, preferCount = parsePrefs [ExactCount, PlannedCount, EstimatedCount]
|
||||
, preferTransaction = if allowTxDbOverride then parsePrefs [Commit, Rollback] else Nothing
|
||||
, preferMissing = parsePrefs [ApplyDefaults, ApplyNulls]
|
||||
, preferHandling = parsePrefs [Strict, Lenient]
|
||||
, preferTimezone = if isTimezonePrefAccepted then PreferTimezone <$> timezonePref else Nothing
|
||||
, preferMaxAffected = PreferMaxAffected <$> maxAffectedPref
|
||||
, invalidPrefs = filter isUnacceptable prefs
|
||||
}
|
||||
where
|
||||
mapToHeadVal :: ToHeaderValue a => [a] -> [ByteString]
|
||||
mapToHeadVal = map toHeaderValue
|
||||
acceptedPrefs = mapToHeadVal [MergeDuplicates, IgnoreDuplicates] ++
|
||||
mapToHeadVal [Full, None, HeadersOnly] ++
|
||||
mapToHeadVal [ExactCount, PlannedCount, EstimatedCount] ++
|
||||
mapToHeadVal [Commit, Rollback] ++
|
||||
mapToHeadVal [ApplyDefaults, ApplyNulls] ++
|
||||
mapToHeadVal [Strict, Lenient]
|
||||
|
||||
prefHeaders = filter ((==) HTTP.hPrefer . fst) headers
|
||||
prefs = fmap BS.strip . concatMap (BS.split ',' . snd) $ prefHeaders
|
||||
|
||||
listStripPrefix prefix prefList = listToMaybe $ mapMaybe (BS.stripPrefix prefix) prefList
|
||||
|
||||
timezonePref = listStripPrefix "timezone=" prefs
|
||||
isTimezonePrefAccepted = ((S.member . decodeUtf8 <$> timezonePref) <*> pure acceptedTzNames) == Just True
|
||||
|
||||
maxAffectedPref = listStripPrefix "max-affected=" prefs >>= readMaybe . BS.unpack
|
||||
|
||||
isUnacceptable p = p `notElem` acceptedPrefs &&
|
||||
(isNothing (BS.stripPrefix "timezone=" p) || not isTimezonePrefAccepted) &&
|
||||
isNothing (BS.stripPrefix "max-affected=" p)
|
||||
|
||||
parsePrefs :: ToHeaderValue a => [a] -> Maybe a
|
||||
parsePrefs vals =
|
||||
head $ mapMaybe (flip Map.lookup $ prefMap vals) prefs
|
||||
|
||||
prefMap :: ToHeaderValue a => [a] -> Map.Map ByteString a
|
||||
prefMap = Map.fromList . fmap (\pref -> (toHeaderValue pref, pref))
|
||||
|
||||
prefAppliedHeader :: Preferences -> Maybe HTTP.Header
|
||||
prefAppliedHeader Preferences {preferResolution, preferRepresentation, preferCount, preferTransaction, preferMissing, preferHandling, preferTimezone, preferMaxAffected } =
|
||||
if null prefsVals
|
||||
then Nothing
|
||||
else Just (HTTP.hPreferenceApplied, combined)
|
||||
where
|
||||
combined = BS.intercalate ", " prefsVals
|
||||
prefsVals = catMaybes [
|
||||
toHeaderValue <$> preferResolution
|
||||
, toHeaderValue <$> preferMissing
|
||||
, toHeaderValue <$> preferRepresentation
|
||||
, toHeaderValue <$> preferCount
|
||||
, toHeaderValue <$> preferTransaction
|
||||
, toHeaderValue <$> preferHandling
|
||||
, toHeaderValue <$> preferTimezone
|
||||
, if preferHandling == Just Strict then toHeaderValue <$> preferMaxAffected else Nothing
|
||||
]
|
||||
|
||||
-- |
|
||||
-- Convert a preference into the value that we look for in the 'Prefer' headers.
|
||||
--
|
||||
-- >>> toHeaderValue MergeDuplicates
|
||||
-- "resolution=merge-duplicates"
|
||||
--
|
||||
class ToHeaderValue a where
|
||||
toHeaderValue :: a -> ByteString
|
||||
|
||||
-- | How to handle duplicate values.
|
||||
data PreferResolution
|
||||
= MergeDuplicates
|
||||
| IgnoreDuplicates
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferResolution where
|
||||
toHeaderValue MergeDuplicates = "resolution=merge-duplicates"
|
||||
toHeaderValue IgnoreDuplicates = "resolution=ignore-duplicates"
|
||||
|
||||
-- |
|
||||
-- How to return the mutated data.
|
||||
--
|
||||
-- From https://tools.ietf.org/html/rfc7240#section-4.2
|
||||
data PreferRepresentation
|
||||
= Full -- ^ Return the body.
|
||||
| HeadersOnly -- ^ Return the Location header(in case of POST). This needs a SELECT privilege on the pk.
|
||||
| None -- ^ Return nothing from the mutated data.
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferRepresentation where
|
||||
toHeaderValue Full = "return=representation"
|
||||
toHeaderValue None = "return=minimal"
|
||||
toHeaderValue HeadersOnly = "return=headers-only"
|
||||
|
||||
-- | How to determine the count of (expected) results
|
||||
data PreferCount
|
||||
= ExactCount -- ^ Exact count (slower).
|
||||
| PlannedCount -- ^ PostgreSQL query planner rows count guess. Done by using EXPLAIN {query}.
|
||||
| EstimatedCount -- ^ Use the query planner rows if the count is superior to max-rows, otherwise get the exact count.
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferCount where
|
||||
toHeaderValue ExactCount = "count=exact"
|
||||
toHeaderValue PlannedCount = "count=planned"
|
||||
toHeaderValue EstimatedCount = "count=estimated"
|
||||
|
||||
shouldCount :: Maybe PreferCount -> Bool
|
||||
shouldCount prefCount =
|
||||
prefCount == Just ExactCount || prefCount == Just EstimatedCount
|
||||
|
||||
shouldExplainCount :: Maybe PreferCount -> Bool
|
||||
shouldExplainCount prefCount =
|
||||
prefCount == Just PlannedCount || prefCount == Just EstimatedCount
|
||||
|
||||
-- | Whether to commit or roll back transactions.
|
||||
data PreferTransaction
|
||||
= Commit -- ^ Commit transaction - the default.
|
||||
| Rollback -- ^ Rollback transaction after sending the response - does not persist changes, e.g. for running tests.
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferTransaction where
|
||||
toHeaderValue Commit = "tx=commit"
|
||||
toHeaderValue Rollback = "tx=rollback"
|
||||
|
||||
-- |
|
||||
-- How to handle the insertion/update when the keys specified in ?columns are not present
|
||||
-- in the json body.
|
||||
data PreferMissing
|
||||
= ApplyDefaults -- ^ Use the default column value for missing values.
|
||||
| ApplyNulls -- ^ Use the null value for missing values.
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferMissing where
|
||||
toHeaderValue ApplyDefaults = "missing=default"
|
||||
toHeaderValue ApplyNulls = "missing=null"
|
||||
|
||||
-- |
|
||||
-- Handling of unrecognised preferences
|
||||
data PreferHandling
|
||||
= Strict -- ^ Throw error on unrecognised preferences
|
||||
| Lenient -- ^ Ignore unrecognised preferences
|
||||
deriving Eq
|
||||
|
||||
instance ToHeaderValue PreferHandling where
|
||||
toHeaderValue Strict = "handling=strict"
|
||||
toHeaderValue Lenient = "handling=lenient"
|
||||
|
||||
-- |
|
||||
-- Change timezone
|
||||
newtype PreferTimezone = PreferTimezone ByteString
|
||||
|
||||
instance ToHeaderValue PreferTimezone where
|
||||
toHeaderValue (PreferTimezone tz) = "timezone=" <> tz
|
||||
|
||||
-- |
|
||||
-- Limit Affected Resources
|
||||
newtype PreferMaxAffected = PreferMaxAffected Int64
|
||||
|
||||
instance ToHeaderValue PreferMaxAffected where
|
||||
toHeaderValue (PreferMaxAffected n) = "max-affected=" <> show n
|
||||
@@ -0,0 +1,879 @@
|
||||
-- |
|
||||
-- Module : PostgREST.ApiRequest.QueryParams
|
||||
-- Description : Parser for PostgREST Query parameters
|
||||
--
|
||||
-- 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.ApiRequest.QueryParams
|
||||
( parse
|
||||
, QueryParams(..)
|
||||
, pFieldForest
|
||||
, pFieldName
|
||||
, pFieldSelect
|
||||
, pJsonPath
|
||||
, pLogicTree
|
||||
, pOpExpr
|
||||
, pOrder
|
||||
, pRelationSelect
|
||||
, pRequestFilter
|
||||
, pRequestRange
|
||||
, pSingleVal
|
||||
, pSpreadRelationSelect
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
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.ParserCombinators.Parsec (GenParser, ParseError, Parser,
|
||||
anyChar, between, char, choice,
|
||||
digit, eof, errorPos, letter,
|
||||
lookAhead, many1, noneOf,
|
||||
notFollowedBy, oneOf,
|
||||
optionMaybe, sepBy, sepBy1,
|
||||
string, try, (<?>))
|
||||
|
||||
import PostgREST.RangeQuery (NonnegRange, allRange,
|
||||
rangeGeq, rangeLimit,
|
||||
rangeOffset, restrictRange)
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName)
|
||||
|
||||
import PostgREST.ApiRequest.Types (AggregateFunction (..),
|
||||
EmbedParam (..), EmbedPath, Field,
|
||||
Filter (..), FtsOperator (..),
|
||||
Hint, IsVal (..), JoinType (..),
|
||||
JsonOperand (..),
|
||||
JsonOperation (..), JsonPath,
|
||||
ListVal, LogicOperator (..),
|
||||
LogicTree (..), OpExpr (..),
|
||||
OpQuantifier (..), Operation (..),
|
||||
OrderDirection (..),
|
||||
OrderNulls (..), OrderTerm (..),
|
||||
QuantOperator (..),
|
||||
SelectItem (..),
|
||||
SimpleOperator (..), SingleVal)
|
||||
|
||||
import PostgREST.Error (QPError (..))
|
||||
|
||||
import Protolude hiding (Sum, try)
|
||||
|
||||
-- $setup
|
||||
-- >>> import qualified Text.ParserCombinators.Parsec as P
|
||||
-- >>> import Protolude hiding (Sum, try)
|
||||
|
||||
data QueryParams =
|
||||
QueryParams
|
||||
{ qsCanonical :: ByteString
|
||||
-- ^ Canonical representation of the query params, sorted alphabetically
|
||||
, qsParams :: [(Text, Text)]
|
||||
-- ^ Parameters for RPC calls
|
||||
, qsRanges :: HM.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 :: [Filter]
|
||||
-- ^ Subset of the filters that apply on the root table. These are used on UPDATE/DELETE.
|
||||
, 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 parameters sorted alphabetically:
|
||||
--
|
||||
-- >>> qsCanonical <$> parse True "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 False "select=name,location"
|
||||
-- Right [Node {rootLabel = SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectField {selField = ("location",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]
|
||||
--
|
||||
-- Filters are parameters whose value contains an operator, separated by a '.' from its value:
|
||||
--
|
||||
-- >>> qsFilters <$> parse False "a.b=eq.0"
|
||||
-- Right [(["a"],Filter {field = ("b",[]), opExpr = OpExpr False (OpQuant OpEqual Nothing "0")})]
|
||||
--
|
||||
-- If the operator specified in a filter does not exist, parsing the query string fails:
|
||||
--
|
||||
-- >>> qsFilters <$> parse False "a.b=noop.0"
|
||||
-- Left (QPError "\"failed to parse filter (noop.0)\" (line 1, column 1)" "unexpected \"o\" expecting \"not\" or operator (eq, gt, ...)")
|
||||
parse :: Bool -> ByteString -> Either QPError QueryParams
|
||||
parse isRpcRead qs = do
|
||||
rOrd <- pRequestOrder `traverse` order
|
||||
rLogic <- pRequestLogicTree `traverse` logic
|
||||
rCols <- pRequestColumns columns
|
||||
rSel <- pRequestSelect select
|
||||
(rFlts, params) <- L.partition hasOp <$> pRequestFilter isRpcRead `traverse` filters
|
||||
(rFltsRoot, rFltsNotRoot) <- pure $ L.partition hasRootFilter rFlts
|
||||
rOnConflict <- pRequestOnConflict `traverse` onConflict
|
||||
|
||||
let rFltsFields = S.fromList (fst <$> filters)
|
||||
params' = mapMaybe (\case {(_, Filter (fld, _) (NoOpExpr v)) -> Just (fld,v); _ -> Nothing}) params
|
||||
rFltsRoot' = snd <$> rFltsRoot
|
||||
|
||||
return $ QueryParams canonical params' ranges rOrd rLogic rCols rSel rFlts rFltsRoot' rFltsNotRoot rFltsFields rOnConflict
|
||||
where
|
||||
hasRootFilter, hasOp :: (EmbedPath, Filter) -> Bool
|
||||
hasRootFilter ([], _) = True
|
||||
hasRootFilter _ = False
|
||||
hasOp (_, Filter (_, _) (NoOpExpr _)) = False
|
||||
hasOp _ = True
|
||||
|
||||
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 = filter (isFilter . fst) nonemptyParams
|
||||
isFilter k = not (endingIn reservedEmbeddable k) && notElem k reserved
|
||||
reserved = ["select", "columns", "on_conflict"]
|
||||
reservedEmbeddable = ["order", "limit", "offset", "and", "or"]
|
||||
|
||||
replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) <> [x]
|
||||
|
||||
ranges :: HM.HashMap Text (Range Integer)
|
||||
ranges = HM.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 =
|
||||
HM.fromList [(k, restrictRange (readMaybe v) allRange) | (k,v) <- limits]
|
||||
|
||||
offsetParams =
|
||||
HM.fromList [(k, maybe allRange rangeGeq (readMaybe v)) | (k,v) <- offsets]
|
||||
|
||||
simpleOperator :: Parser SimpleOperator
|
||||
simpleOperator =
|
||||
try (string "neq" $> OpNotEqual) <|>
|
||||
try (string "cs" $> OpContains) <|>
|
||||
try (string "cd" $> OpContained) <|>
|
||||
try (string "ov" $> OpOverlap) <|>
|
||||
try (string "sl" $> OpStrictlyLeft) <|>
|
||||
try (string "sr" $> OpStrictlyRight) <|>
|
||||
try (string "nxr" $> OpNotExtendsRight) <|>
|
||||
try (string "nxl" $> OpNotExtendsLeft) <|>
|
||||
try (string "adj" $> OpAdjacent) <?>
|
||||
"unknown single value operator"
|
||||
|
||||
quantOperator :: Parser QuantOperator
|
||||
quantOperator =
|
||||
try (string "eq" $> OpEqual) <|>
|
||||
try (string "gte" $> OpGreaterThanEqual) <|>
|
||||
try (string "gt" $> OpGreaterThan) <|>
|
||||
try (string "lte" $> OpLessThanEqual) <|>
|
||||
try (string "lt" $> OpLessThan) <|>
|
||||
try (string "like" $> OpLike) <|>
|
||||
try (string "ilike" $> OpILike) <|>
|
||||
try (string "match" $> OpMatch) <|>
|
||||
try (string "imatch" $> OpIMatch) <?>
|
||||
"unknown single value operator"
|
||||
|
||||
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)
|
||||
|
||||
-- |
|
||||
-- Parse `id=eq.1`(id, eq.1) into (EmbedPath, Filter)
|
||||
--
|
||||
-- >>> pRequestFilter False ("id", "eq.1")
|
||||
-- Right ([],Filter {field = ("id",[]), opExpr = OpExpr False (OpQuant OpEqual Nothing "1")})
|
||||
--
|
||||
-- >>> pRequestFilter False ("id", "val")
|
||||
-- Left (QPError "\"failed to parse filter (val)\" (line 1, column 1)" "unexpected \"v\" expecting \"not\" or operator (eq, gt, ...)")
|
||||
--
|
||||
-- >>> pRequestFilter True ("id", "val")
|
||||
-- Right ([],Filter {field = ("id",[]), opExpr = NoOpExpr "val"})
|
||||
pRequestFilter :: Bool -> (Text, Text) -> Either QPError (EmbedPath, Filter)
|
||||
pRequestFilter isRpcRead (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> oper)
|
||||
where
|
||||
treePath = P.parse pTreePath ("failed to parse tree path (" ++ toS k ++ ")") $ toS k
|
||||
oper = P.parse parseFlt ("failed to parse filter (" ++ toS v ++ ")") $ toS v
|
||||
parseFlt = if isRpcRead
|
||||
then pOpExpr pSingleVal <|> pure (NoOpExpr v)
|
||||
else pOpExpr pSingleVal
|
||||
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))
|
||||
|
||||
-- |
|
||||
-- Parse select= into a Forest of SelectItems
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "id"
|
||||
-- Right [Node {rootLabel = SelectField {selField = ("id",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "client(id)"
|
||||
-- Right [Node {rootLabel = SelectRelation {selRelation = "client", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("id",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "*,client(*,nested(*))"
|
||||
-- Right [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectRelation {selRelation = "client", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SelectRelation {selRelation = "nested", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]}]
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "*,...client(*),other(*)"
|
||||
-- Right [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []},Node {rootLabel = SpreadRelation {selRelation = "client", selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]},Node {rootLabel = SelectRelation {selRelation = "other", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing}, subForest = [Node {rootLabel = SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing}, subForest = []}]}]
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" ""
|
||||
-- Right []
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "id,clients(name[])"
|
||||
-- Left (line 1, column 16):
|
||||
-- unexpected '['
|
||||
-- expecting letter, digit, "-", "->>", "->", "::", ".", ")", "," or end of input
|
||||
--
|
||||
-- >>> P.parse pFieldForest "" "data->>-78xy"
|
||||
-- Left (line 1, column 11):
|
||||
-- unexpected 'x'
|
||||
-- expecting digit, "->", "::", ".", "," or end of input
|
||||
pFieldForest :: Parser [Tree SelectItem]
|
||||
pFieldForest = pFieldTree `sepBy` lexeme (char ',')
|
||||
where
|
||||
pFieldTree = Node <$> try pSpreadRelationSelect <*> between (char '(') (char ')') pFieldForest <|>
|
||||
Node <$> try pRelationSelect <*> between (char '(') (char ')') pFieldForest <|>
|
||||
Node <$> pFieldSelect <*> pure []
|
||||
|
||||
-- |
|
||||
-- Parse field names
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "identifier"
|
||||
-- Right "identifier"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "identifier with spaces"
|
||||
-- Right "identifier with spaces"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "identifier-with-dashes"
|
||||
-- Right "identifier-with-dashes"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "123"
|
||||
-- Right "123"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "_"
|
||||
-- Right "_"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "$"
|
||||
-- Right "$"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" ":"
|
||||
-- Left (line 1, column 1):
|
||||
-- unexpected ":"
|
||||
-- expecting field name (* or [a..z0..9_$])
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "\":\""
|
||||
-- Right ":"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" " no leading or trailing spaces "
|
||||
-- Right "no leading or trailing spaces"
|
||||
--
|
||||
-- >>> P.parse pFieldName "" "\" leading and trailing spaces \""
|
||||
-- Right " leading and trailing spaces "
|
||||
pFieldName :: Parser Text
|
||||
pFieldName =
|
||||
pQuotedValue <|>
|
||||
sepByDash pIdentifier <?>
|
||||
"field name (* or [a..z0..9_$])"
|
||||
|
||||
sepByDash :: Parser Text -> Parser Text
|
||||
sepByDash fieldIdent =
|
||||
T.intercalate "-" . map toS <$> (fieldIdent `sepBy1` dash)
|
||||
where
|
||||
isDash :: GenParser Char st ()
|
||||
isDash = try ( char '-' >> notFollowedBy (char '>') )
|
||||
dash :: Parser Char
|
||||
dash = isDash $> '-'
|
||||
|
||||
-- |
|
||||
-- Parse json operators in select, order and filters
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->text"
|
||||
-- Right [JArrow {jOp = JKey {jVal = "text"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->!@#$%^&*_a"
|
||||
-- Right [JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->1"
|
||||
-- Right [JArrow {jOp = JIdx {jVal = "+1"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>text"
|
||||
-- Right [J2Arrow {jOp = JKey {jVal = "text"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>!@#$%^&*_a"
|
||||
-- Right [J2Arrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>1"
|
||||
-- Right [J2Arrow {jOp = JIdx {jVal = "+1"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->0,other"
|
||||
-- Right [JArrow {jOp = JIdx {jVal = "+0"}}]
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->0.desc"
|
||||
-- Right [JArrow {jOp = JIdx {jVal = "+0"}}]
|
||||
--
|
||||
-- Fails on badly formed negatives
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>-78xy"
|
||||
-- Left (line 1, column 7):
|
||||
-- unexpected 'x'
|
||||
-- expecting digit, "->", "::", ".", "," or end of input
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>--34"
|
||||
-- Left (line 1, column 5):
|
||||
-- unexpected "-"
|
||||
-- expecting digit
|
||||
--
|
||||
-- >>> P.parse pJsonPath "" "->>-xy-4"
|
||||
-- Left (line 1, column 5):
|
||||
-- unexpected "x"
|
||||
-- expecting digit
|
||||
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 <$> pJsonKeyName
|
||||
pJIdx = JIdx . toS <$> ((:) <$> P.option '+' (char '-') <*> many1 digit) <* pEnd
|
||||
pEnd = try (void $ lookAhead (string "->")) <|>
|
||||
try (void $ lookAhead (string "::")) <|>
|
||||
try (void $ lookAhead (string ".")) <|>
|
||||
try (void $ lookAhead (string ",")) <|>
|
||||
try eof in
|
||||
try pJIdx <|> try pJKey
|
||||
|
||||
pJsonKeyName :: Parser Text
|
||||
pJsonKeyName =
|
||||
pQuotedValue <|>
|
||||
sepByDash pJsonKeyIdentifier <?>
|
||||
"any non reserved character different from: .,>()"
|
||||
|
||||
pJsonKeyIdentifier :: Parser Text
|
||||
pJsonKeyIdentifier = T.strip . toS <$> many1 (noneOf "(-:.,>)")
|
||||
|
||||
pField :: Parser Field
|
||||
pField = lexeme $ (,) <$> pFieldName <*> P.option [] pJsonPath
|
||||
|
||||
aliasSeparator :: Parser ()
|
||||
aliasSeparator = char ':' >> notFollowedBy (char ':')
|
||||
|
||||
-- |
|
||||
-- Parse regular fields in select
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Nothing, selJoinType = Nothing})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "alias:rel(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Just "alias", selHint = Nothing, selJoinType = Nothing})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel!hint(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Just "hint", selJoinType = Nothing})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel!inner(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Nothing, selJoinType = Just JTInner})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel!hint!inner(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Nothing, selHint = Just "hint", selJoinType = Just JTInner})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "alias:rel!inner!hint(*)"
|
||||
-- Right (SelectRelation {selRelation = "rel", selAlias = Just "alias", selHint = Just "hint", selJoinType = Just JTInner})
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel->jsonpath(*)"
|
||||
-- Left (line 1, column 6):
|
||||
-- unexpected '>'
|
||||
--
|
||||
-- >>> P.parse pRelationSelect "" "rel->jsonpath!hint(*)"
|
||||
-- Left (line 1, column 6):
|
||||
-- unexpected '>'
|
||||
pRelationSelect :: Parser SelectItem
|
||||
pRelationSelect = lexeme $ do
|
||||
alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
|
||||
name <- pFieldName
|
||||
guard (name /= "count")
|
||||
(hint, jType) <- pEmbedParams
|
||||
try (void $ lookAhead (string "("))
|
||||
return $ SelectRelation name alias hint jType
|
||||
|
||||
|
||||
-- |
|
||||
-- Parse regular fields in select
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name"
|
||||
-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name->jsonpath"
|
||||
-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "jsonpath"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name::cast"
|
||||
-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Nothing})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "alias:name"
|
||||
-- Right (SelectField {selField = ("name",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Just "alias"})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "alias:name->jsonpath::cast"
|
||||
-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "jsonpath"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Just "alias"})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "alias:name->!@#$%^&*_a::cast"
|
||||
-- Right (SelectField {selField = ("name",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Just "cast", selAlias = Just "alias"})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "*"
|
||||
-- Right (SelectField {selField = ("*",[]), selAggregateFunction = Nothing, selAggregateCast = Nothing, selCast = Nothing, selAlias = Nothing})
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name!hint"
|
||||
-- Left (line 1, column 5):
|
||||
-- unexpected '!'
|
||||
-- expecting letter, digit, "-", "->>", "->", "::", ".", ")", "," or end of input
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "*!hint"
|
||||
-- Left (line 1, column 2):
|
||||
-- unexpected '!'
|
||||
-- expecting ")", "," or end of input
|
||||
--
|
||||
-- >>> P.parse pFieldSelect "" "name::"
|
||||
-- Left (line 1, column 7):
|
||||
-- unexpected end of input
|
||||
-- expecting letter or digit
|
||||
pFieldSelect :: Parser SelectItem
|
||||
pFieldSelect = lexeme $ try (do
|
||||
s <- pStar
|
||||
pEnd
|
||||
return $ SelectField (s, []) Nothing Nothing Nothing Nothing)
|
||||
<|> try (do
|
||||
alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
|
||||
_ <- string "count()"
|
||||
aggCast' <- optionMaybe (string "::" *> pIdentifier)
|
||||
pEnd
|
||||
return $ SelectField ("*", []) (Just Count) (toS <$> aggCast') Nothing alias)
|
||||
<|> do
|
||||
alias <- optionMaybe ( try(pFieldName <* aliasSeparator) )
|
||||
fld <- pField
|
||||
cast' <- optionMaybe (string "::" *> pIdentifier)
|
||||
agg <- optionMaybe (try (char '.' *> pAggregation <* string "()"))
|
||||
aggCast' <- optionMaybe (string "::" *> pIdentifier)
|
||||
pEnd
|
||||
return $ SelectField fld agg (toS <$> aggCast') (toS <$> cast') alias
|
||||
where
|
||||
pEnd = try (void $ lookAhead (string ")")) <|>
|
||||
try (void $ lookAhead (string ",")) <|>
|
||||
try eof
|
||||
pStar = string "*" $> "*"
|
||||
pAggregation = choice
|
||||
[ string "sum" $> Sum
|
||||
, string "avg" $> Avg
|
||||
, string "count" $> Count
|
||||
-- Using 'try' for "min" and "max" to allow backtracking.
|
||||
-- This is necessary because both start with the same character 'm',
|
||||
-- and without 'try', a partial match on "max" would prevent "min" from being tried.
|
||||
, try (string "max") $> Max
|
||||
, try (string "min") $> Min
|
||||
]
|
||||
|
||||
|
||||
-- |
|
||||
-- Parse spread relations in select
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "...rel(*)"
|
||||
-- Right (SpreadRelation {selRelation = "rel", selHint = Nothing, selJoinType = Nothing})
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "...rel!hint!inner(*)"
|
||||
-- Right (SpreadRelation {selRelation = "rel", selHint = Just "hint", selJoinType = Just JTInner})
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "rel(*)"
|
||||
-- Left (line 1, column 1):
|
||||
-- unexpected "r"
|
||||
-- expecting "..."
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "alias:...rel(*)"
|
||||
-- Left (line 1, column 1):
|
||||
-- unexpected "a"
|
||||
-- expecting "..."
|
||||
--
|
||||
-- >>> P.parse pSpreadRelationSelect "" "...rel->jsonpath(*)"
|
||||
-- Left (line 1, column 9):
|
||||
-- unexpected '>'
|
||||
pSpreadRelationSelect :: Parser SelectItem
|
||||
pSpreadRelationSelect = lexeme $ do
|
||||
name <- string "..." >> pFieldName
|
||||
(hint, jType) <- pEmbedParams
|
||||
try (void $ lookAhead (string "("))
|
||||
return $ SpreadRelation name hint jType
|
||||
|
||||
pEmbedParams :: Parser (Maybe Hint, Maybe JoinType)
|
||||
pEmbedParams = do
|
||||
prm1 <- optionMaybe pEmbedParam
|
||||
prm2 <- optionMaybe pEmbedParam
|
||||
return (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
|
||||
|
||||
-- |
|
||||
-- Parse operator expression used in horizontal filtering
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "fts().value"
|
||||
-- Left (line 1, column 5):
|
||||
-- unexpected ")"
|
||||
-- expecting operator (eq, gt, ...)
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "eq(any).value"
|
||||
-- Right (OpExpr False (OpQuant OpEqual (Just QuantAny) "value"))
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "eq(all).value"
|
||||
-- Right (OpExpr False (OpQuant OpEqual (Just QuantAll) "value"))
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "not.eq(all).value"
|
||||
-- Right (OpExpr True (OpQuant OpEqual (Just QuantAll) "value"))
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "eq().value"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected ")"
|
||||
-- expecting operator (eq, gt, ...)
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "is().value"
|
||||
-- Left (line 1, column 3):
|
||||
-- unexpected "("
|
||||
-- expecting operator (eq, gt, ...)
|
||||
--
|
||||
-- >>> P.parse (pOpExpr pSingleVal) "" "in().value"
|
||||
-- Left (line 1, column 3):
|
||||
-- unexpected "("
|
||||
-- expecting operator (eq, gt, ...)
|
||||
pOpExpr :: Parser SingleVal -> Parser OpExpr
|
||||
pOpExpr pSVal = do
|
||||
boolExpr <- try (string "not" *> pDelimiter $> True) <|> pure False
|
||||
OpExpr boolExpr <$> pOperation
|
||||
where
|
||||
pOperation :: Parser Operation
|
||||
pOperation = pIn <|> pIs <|> pIsDist <|> try pFts <|> try pSimpleOp <|> try pQuantOp <?> "operator (eq, gt, ...)"
|
||||
|
||||
pIn = In <$> (try (string "in" *> pDelimiter) *> pListVal)
|
||||
pIs = Is <$> (try (string "is" *> pDelimiter) *> pIsVal)
|
||||
|
||||
pIsDist = IsDistinctFrom <$> (try (string "isdistinct" *> pDelimiter) *> pSVal)
|
||||
|
||||
pSimpleOp = do
|
||||
op <- simpleOperator
|
||||
pDelimiter *> (Op op <$> pSVal)
|
||||
|
||||
pQuantOp = do
|
||||
op <- quantOperator
|
||||
quant <- optionMaybe $ try (between (char '(') (char ')') (try (string "any" $> QuantAny) <|> string "all" $> QuantAll))
|
||||
pDelimiter *> (OpQuant op quant <$> pSVal)
|
||||
|
||||
pIsVal = try (ciString "null" $> IsNull)
|
||||
<|> try (ciString "not_null" $> IsNotNull)
|
||||
<|> try (ciString "true" $> IsTriTrue)
|
||||
<|> try (ciString "false" $> IsTriFalse)
|
||||
<|> try (ciString "unknown" $> IsTriUnknown)
|
||||
<?> "isVal: (null, not_null, true, false, unknown)"
|
||||
|
||||
pFts = do
|
||||
op <- try (string "fts" $> FilterFts)
|
||||
<|> try (string "plfts" $> FilterFtsPlain)
|
||||
<|> try (string "phfts" $> FilterFtsPhrase)
|
||||
<|> try (string "wfts" $> FilterFtsWebsearch)
|
||||
|
||||
lang <- optionMaybe $ try (between (char '(') (char ')') pIdentifier)
|
||||
pDelimiter >> Fts op (toS <$> lang) <$> pSVal
|
||||
|
||||
-- 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 (.)"
|
||||
|
||||
-- |
|
||||
-- Parses the elements in the order query parameter
|
||||
--
|
||||
-- >>> P.parse pOrder "" "name.desc.nullsfirst"
|
||||
-- Right [OrderTerm {otTerm = ("name",[]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "json_col->key.asc.nullslast"
|
||||
-- Right [OrderTerm {otTerm = ("json_col",[JArrow {jOp = JKey {jVal = "key"}}]), otDirection = Just OrderAsc, otNullOrder = Just OrderNullsLast}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "json_col->!@#$%^&*_a.asc.nullslast"
|
||||
-- Right [OrderTerm {otTerm = ("json_col",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), otDirection = Just OrderAsc, otNullOrder = Just OrderNullsLast}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "clients(json_col->key).desc.nullsfirst"
|
||||
-- Right [OrderRelationTerm {otRelation = "clients", otRelTerm = ("json_col",[JArrow {jOp = JKey {jVal = "key"}}]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "clients(json_col->!@#$%^&*_a).desc.nullsfirst"
|
||||
-- Right [OrderRelationTerm {otRelation = "clients", otRelTerm = ("json_col",[JArrow {jOp = JKey {jVal = "!@#$%^&*_a"}}]), otDirection = Just OrderDesc, otNullOrder = Just OrderNullsFirst}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "clients(name,id)"
|
||||
-- Left (line 1, column 8):
|
||||
-- unexpected '('
|
||||
-- expecting letter, digit, "-", "->>", "->", delimiter (.), "," or end of input
|
||||
--
|
||||
-- >>> P.parse pOrder "" "name,clients(name),id"
|
||||
-- Right [OrderTerm {otTerm = ("name",[]), otDirection = Nothing, otNullOrder = Nothing},OrderRelationTerm {otRelation = "clients", otRelTerm = ("name",[]), otDirection = Nothing, otNullOrder = Nothing},OrderTerm {otTerm = ("id",[]), otDirection = Nothing, otNullOrder = Nothing}]
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.ac"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected "c"
|
||||
-- expecting "asc", "desc", "nullsfirst" or "nullslast"
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.descc"
|
||||
-- Left (line 1, column 8):
|
||||
-- unexpected 'c'
|
||||
-- expecting delimiter (.), "," or end of input
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.nulsfist"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected "n"
|
||||
-- expecting "asc", "desc", "nullsfirst" or "nullslast"
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.nullslasttt"
|
||||
-- Left (line 1, column 13):
|
||||
-- unexpected 't'
|
||||
-- expecting "," or end of input
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.smth34"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected "s"
|
||||
-- expecting "asc", "desc", "nullsfirst" or "nullslast"
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.asc.nlsfst"
|
||||
-- Left (line 1, column 8):
|
||||
-- unexpected "l"
|
||||
-- expecting "nullsfirst" or "nullslast"
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.asc.nullslasttt"
|
||||
-- Left (line 1, column 17):
|
||||
-- unexpected 't'
|
||||
-- expecting "," or end of input
|
||||
--
|
||||
-- >>> P.parse pOrder "" "id.asc.smth34"
|
||||
-- Left (line 1, column 8):
|
||||
-- unexpected "s"
|
||||
-- expecting "nullsfirst" or "nullslast"
|
||||
pOrder :: Parser [OrderTerm]
|
||||
pOrder = lexeme (try pOrderRelationTerm <|> pOrderTerm) `sepBy1` char ','
|
||||
where
|
||||
pOrderTerm = do
|
||||
fld <- pField
|
||||
dir <- optionMaybe pOrdDir
|
||||
nls <- optionMaybe pNulls <* pEnd <|>
|
||||
pEnd $> Nothing
|
||||
return $ OrderTerm fld dir nls
|
||||
|
||||
pOrderRelationTerm = do
|
||||
nam <- pFieldName
|
||||
fld <- between (char '(') (char ')') pField
|
||||
dir <- optionMaybe pOrdDir
|
||||
nls <- optionMaybe pNulls <* pEnd <|> pEnd $> Nothing
|
||||
return $ OrderRelationTerm nam fld dir nls
|
||||
|
||||
pNulls :: Parser OrderNulls
|
||||
pNulls = try (pDelimiter *> string "nullsfirst" $> OrderNullsFirst) <|>
|
||||
try (pDelimiter *> string "nullslast" $> OrderNullsLast)
|
||||
|
||||
pOrdDir :: Parser OrderDirection
|
||||
pOrdDir = try (pDelimiter *> string "asc" $> OrderAsc) <|>
|
||||
try (pDelimiter *> string "desc" $> OrderDesc)
|
||||
|
||||
pEnd = try (void $ lookAhead (char ',')) <|> try eof
|
||||
|
||||
-- |
|
||||
-- Parses the elements inside or/and
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "or()"
|
||||
-- Left (line 1, column 4):
|
||||
-- unexpected ")"
|
||||
-- expecting field name (* or [a..z0..9_$]), negation operator (not) or logic operator (and, or)
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "or(id.in.1,2,id.eq.3)"
|
||||
-- Left (line 1, column 10):
|
||||
-- unexpected "1"
|
||||
-- expecting "("
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "or)("
|
||||
-- Left (line 1, column 3):
|
||||
-- unexpected ")"
|
||||
-- expecting "("
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "and(ord(id.eq.1,id.eq.1),id.eq.2)"
|
||||
-- Left (line 1, column 7):
|
||||
-- unexpected "d"
|
||||
-- expecting "("
|
||||
--
|
||||
-- >>> P.parse pLogicTree "" "or(id.eq.1,not.xor(id.eq.2,id.eq.3))"
|
||||
-- Left (line 1, column 16):
|
||||
-- unexpected "x"
|
||||
-- expecting logic operator (and, or)
|
||||
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 ',')
|
||||
|
||||
pIdentifier :: Parser Text
|
||||
pIdentifier = T.strip . toS <$> many1 pIdentifierChar
|
||||
|
||||
pIdentifierChar :: Parser Char
|
||||
pIdentifierChar = letter <|> digit <|> oneOf "_ $"
|
||||
|
||||
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)
|
||||
@@ -0,0 +1,279 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
module PostgREST.ApiRequest.Types
|
||||
( AggregateFunction(..)
|
||||
, Alias
|
||||
, Cast
|
||||
, Depth
|
||||
, EmbedParam(..)
|
||||
, EmbedPath
|
||||
, Field
|
||||
, Filter(..)
|
||||
, Hint
|
||||
, JoinType(..)
|
||||
, JsonOperand(..)
|
||||
, JsonOperation(..)
|
||||
, JsonPath
|
||||
, Language
|
||||
, ListVal
|
||||
, LogicOperator(..)
|
||||
, LogicTree(..)
|
||||
, NodeName
|
||||
, OpExpr(..)
|
||||
, Operation (..)
|
||||
, OpQuantifier(..)
|
||||
, OrderDirection(..)
|
||||
, OrderNulls(..)
|
||||
, OrderTerm(..)
|
||||
, SingleVal
|
||||
, IsVal(..)
|
||||
, SimpleOperator(..)
|
||||
, QuantOperator(..)
|
||||
, FtsOperator(..)
|
||||
, SelectItem(..)
|
||||
, Payload (..)
|
||||
, InvokeMethod (..)
|
||||
, Mutation (..)
|
||||
, Resource (..)
|
||||
, DbAction (..)
|
||||
, Action (..)
|
||||
, RequestBody
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Set as S
|
||||
|
||||
import PostgREST.SchemaCache.Identifiers (FieldName,
|
||||
QualifiedIdentifier (..),
|
||||
Schema)
|
||||
|
||||
import Protolude
|
||||
|
||||
data InvokeMethod = Inv | InvRead Bool
|
||||
deriving Eq
|
||||
|
||||
data Mutation
|
||||
= MutationCreate
|
||||
| MutationDelete
|
||||
| MutationSingleUpsert
|
||||
| MutationUpdate
|
||||
deriving Eq
|
||||
|
||||
data Resource
|
||||
= ResourceRelation Text
|
||||
| ResourceRoutine Text
|
||||
| ResourceSchema
|
||||
|
||||
data DbAction
|
||||
= ActRelationRead {dbActQi :: QualifiedIdentifier, actHeadersOnly :: Bool}
|
||||
| ActRelationMut {dbActQi :: QualifiedIdentifier, actMutation :: Mutation}
|
||||
| ActRoutine {dbActQi :: QualifiedIdentifier, actInvMethod :: InvokeMethod}
|
||||
| ActSchemaRead Schema Bool
|
||||
|
||||
data Action
|
||||
= ActDb DbAction
|
||||
| ActRelationInfo QualifiedIdentifier
|
||||
| ActRoutineInfo QualifiedIdentifier InvokeMethod
|
||||
| ActSchemaInfo
|
||||
|
||||
type RequestBody = LBS.ByteString
|
||||
|
||||
data Payload
|
||||
= ProcessedJSON -- ^ Cached attributes of a JSON payload
|
||||
{ payRaw :: LBS.ByteString
|
||||
-- ^ This is the raw ByteString that comes from the request body. We
|
||||
-- cache this instead of an Aeson Value because it was detected that for
|
||||
-- large payloads the encoding had high memory usage, see
|
||||
-- https://github.com/PostgREST/postgrest/pull/1005 for more details
|
||||
, payKeys :: S.Set Text
|
||||
-- ^ Keys of the object or if it's an array these keys are guaranteed to
|
||||
-- be the same across all its objects
|
||||
}
|
||||
| ProcessedUrlEncoded { payArray :: [(Text, Text)], payKeys :: S.Set Text }
|
||||
| RawJSON { payRaw :: LBS.ByteString }
|
||||
| RawPay { payRaw :: LBS.ByteString }
|
||||
|
||||
|
||||
-- | The value in `/tbl?select=alias:field.aggregateFunction()::cast`
|
||||
data SelectItem
|
||||
= SelectField
|
||||
{ selField :: Field
|
||||
, selAggregateFunction :: Maybe AggregateFunction
|
||||
, selAggregateCast :: Maybe Cast
|
||||
, selCast :: Maybe Cast
|
||||
, selAlias :: Maybe Alias
|
||||
}
|
||||
-- | The value in `/tbl?select=alias:another_tbl(*)`
|
||||
| SelectRelation
|
||||
{ selRelation :: FieldName
|
||||
, selAlias :: Maybe Alias
|
||||
, selHint :: Maybe Hint
|
||||
, selJoinType :: Maybe JoinType
|
||||
}
|
||||
-- | The value in `/tbl?select=...another_tbl(*)`
|
||||
| SpreadRelation
|
||||
{ selRelation :: FieldName
|
||||
, selHint :: Maybe Hint
|
||||
, selJoinType :: Maybe JoinType
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type NodeName = Text
|
||||
type Depth = Integer
|
||||
|
||||
data OrderTerm
|
||||
= OrderTerm
|
||||
{ otTerm :: Field
|
||||
, otDirection :: Maybe OrderDirection
|
||||
, otNullOrder :: Maybe OrderNulls
|
||||
}
|
||||
| OrderRelationTerm
|
||||
{ otRelation :: FieldName
|
||||
, otRelTerm :: Field
|
||||
, otDirection :: Maybe OrderDirection
|
||||
, otNullOrder :: Maybe OrderNulls
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data OrderDirection
|
||||
= OrderAsc
|
||||
| OrderDesc
|
||||
deriving (Eq, Show)
|
||||
|
||||
data OrderNulls
|
||||
= OrderNullsFirst
|
||||
| OrderNullsLast
|
||||
deriving (Eq, Show)
|
||||
|
||||
type Field = (FieldName, JsonPath)
|
||||
type Cast = Text
|
||||
type Alias = Text
|
||||
type Hint = Text
|
||||
|
||||
data AggregateFunction = Sum | Avg | Max | Min | Count
|
||||
deriving (Show, Eq)
|
||||
|
||||
data EmbedParam
|
||||
-- | Disambiguates an embedding operation when there's multiple relationships
|
||||
-- between two tables. Can be the name of a foreign key constraint, column
|
||||
-- name or the junction in an m2m relationship.
|
||||
= EPHint Hint
|
||||
| EPJoinType JoinType
|
||||
|
||||
data JoinType
|
||||
= JTInner
|
||||
| JTLeft
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Path of the embedded levels, e.g "clients.projects.name=eq.." gives Path
|
||||
-- ["clients", "projects"]
|
||||
type EmbedPath = [Text]
|
||||
|
||||
-- | Json path operations as specified in
|
||||
-- https://www.postgresql.org/docs/current/static/functions-json.html
|
||||
type JsonPath = [JsonOperation]
|
||||
|
||||
-- | Represents the single arrow `->` or double arrow `->>` operators
|
||||
data JsonOperation
|
||||
= JArrow { jOp :: JsonOperand }
|
||||
| J2Arrow { jOp :: JsonOperand }
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text
|
||||
-- because we reuse our escaping functions and let pg do the casting with
|
||||
-- '1'::int
|
||||
data JsonOperand
|
||||
= JKey { jVal :: Text }
|
||||
| JIdx { jVal :: Text }
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
-- | Boolean logic expression tree e.g. "and(name.eq.N,or(id.eq.1,id.eq.2))" is:
|
||||
--
|
||||
-- And
|
||||
-- / \
|
||||
-- name.eq.N Or
|
||||
-- / \
|
||||
-- id.eq.1 id.eq.2
|
||||
data LogicTree
|
||||
= Expr Bool LogicOperator [LogicTree]
|
||||
| Stmnt Filter
|
||||
deriving (Eq, Show)
|
||||
|
||||
data LogicOperator
|
||||
= And
|
||||
| Or
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Filter
|
||||
= Filter
|
||||
{ field :: Field
|
||||
, opExpr :: OpExpr
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data OpExpr
|
||||
= OpExpr Bool Operation
|
||||
| NoOpExpr Text
|
||||
deriving (Eq, Show)
|
||||
|
||||
data OpQuantifier = QuantAny | QuantAll
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Operation
|
||||
= Op SimpleOperator SingleVal
|
||||
| OpQuant QuantOperator (Maybe OpQuantifier) SingleVal
|
||||
| In ListVal
|
||||
| Is IsVal
|
||||
| IsDistinctFrom SingleVal
|
||||
| Fts FtsOperator (Maybe Language) SingleVal
|
||||
deriving (Eq, Show)
|
||||
|
||||
type Language = Text
|
||||
|
||||
-- | Represents a single value in a filter, e.g. id=eq.singleval
|
||||
type SingleVal = Text
|
||||
|
||||
-- | Represents a list value in a filter, e.g. id=in.(val1,val2,val3)
|
||||
type ListVal = [Text]
|
||||
|
||||
data IsVal
|
||||
= IsNull
|
||||
| IsNotNull
|
||||
-- Trilean values
|
||||
| IsTriTrue
|
||||
| IsTriFalse
|
||||
| IsTriUnknown
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- Operators that are quantifiable, i.e. they can be used with the any/all modifiers
|
||||
data QuantOperator
|
||||
= OpEqual
|
||||
| OpGreaterThanEqual
|
||||
| OpGreaterThan
|
||||
| OpLessThanEqual
|
||||
| OpLessThan
|
||||
| OpLike
|
||||
| OpILike
|
||||
| OpMatch
|
||||
| OpIMatch
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SimpleOperator
|
||||
= OpNotEqual
|
||||
| OpContains
|
||||
| OpContained
|
||||
| OpOverlap
|
||||
| OpStrictlyLeft
|
||||
| OpStrictlyRight
|
||||
| OpNotExtendsRight
|
||||
| OpNotExtendsLeft
|
||||
| OpAdjacent
|
||||
deriving (Eq, Show)
|
||||
|
||||
--
|
||||
-- | Operators for full text search operators
|
||||
data FtsOperator
|
||||
= FilterFts
|
||||
| FilterFtsPlain
|
||||
| FilterFtsPhrase
|
||||
| FilterFtsWebsearch
|
||||
deriving (Eq, Show)
|
||||
Reference in New Issue
Block a user