refactor: Split up Types.hs and logically organize modules (#1793)
This commit is contained in:
Remo Rechkemmer
@@ -0,0 +1,426 @@
|
||||
{-|
|
||||
Module : PostgREST.Request.ApiRequest
|
||||
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
|
||||
-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
|
||||
module PostgREST.Request.ApiRequest
|
||||
( ApiRequest(..)
|
||||
, InvokeMethod(..)
|
||||
, ContentType(..)
|
||||
, Action(..)
|
||||
, Target(..)
|
||||
, PayloadJSON(..)
|
||||
, mutuallyAgreeable
|
||||
, userApiRequest
|
||||
) where
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Csv as CSV
|
||||
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.Vector as V
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Data.Aeson.Types (emptyArray, emptyObject)
|
||||
import Data.List (last, lookup, partition)
|
||||
import Data.List.NonEmpty (head)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Ranged.Boundaries (Boundary (..))
|
||||
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,
|
||||
parseSimpleQuery)
|
||||
import Network.Wai (Request (..))
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
import Web.Cookie (parseCookiesText)
|
||||
|
||||
import PostgREST.ContentType (ContentType (..))
|
||||
import PostgREST.DbStructure (DbStructure (..))
|
||||
import PostgREST.DbStructure.Identifiers (FieldName,
|
||||
QualifiedIdentifier (..),
|
||||
Schema)
|
||||
import PostgREST.DbStructure.Proc (PgArg (..),
|
||||
ProcDescription (..),
|
||||
findProc)
|
||||
import PostgREST.Error (ApiRequestError (..))
|
||||
import PostgREST.Query.SqlFragment (ftsOperators, operators)
|
||||
import PostgREST.RangeQuery (NonnegRange, allRange,
|
||||
rangeGeq, rangeLimit,
|
||||
rangeOffset, rangeRequested,
|
||||
restrictRange)
|
||||
import PostgREST.Request.Parsers (pRequestColumns)
|
||||
import PostgREST.Request.Preferences (PreferCount (..),
|
||||
PreferParameters (..),
|
||||
PreferRepresentation (..),
|
||||
PreferResolution (..),
|
||||
PreferTransaction (..))
|
||||
|
||||
import qualified PostgREST.ContentType as ContentType
|
||||
|
||||
import Protolude hiding (head, toS)
|
||||
import Protolude.Conv (toS)
|
||||
|
||||
|
||||
type RequestBody = BL.ByteString
|
||||
|
||||
data PayloadJSON
|
||||
= ProcessedJSON -- ^ Cached attributes of a JSON payload
|
||||
{ pjRaw :: BL.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
|
||||
, pjKeys :: 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
|
||||
}
|
||||
| RawJSON { pjRaw :: BL.ByteString }
|
||||
|
||||
data InvokeMethod = InvHead | InvGet | InvPost deriving Eq
|
||||
-- | Types of things a user wants to do to tables/views/procs
|
||||
data Action = ActionCreate | ActionRead{isHead :: Bool}
|
||||
| ActionUpdate | ActionDelete
|
||||
| ActionSingleUpsert | ActionInvoke InvokeMethod
|
||||
| ActionInfo | ActionInspect{isHead :: Bool}
|
||||
deriving Eq
|
||||
-- | The target db object of a user action
|
||||
data Target = TargetIdent QualifiedIdentifier
|
||||
| TargetProc{tProc :: ProcDescription, tpIsRootSpec :: Bool}
|
||||
| TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/"
|
||||
| TargetUnknown
|
||||
|
||||
-- | RPC query param value `/rpc/func?v=<value>`, used for VARIADIC functions on form-urlencoded POST and GETs
|
||||
-- | It can be fixed `?v=1` or repeated `?v=1&v=2&v=3.
|
||||
data RpcParamValue = Fixed Text | Variadic [Text]
|
||||
instance JSON.ToJSON RpcParamValue where
|
||||
toJSON (Fixed v) = JSON.toJSON v
|
||||
toJSON (Variadic v) = JSON.toJSON v
|
||||
|
||||
toRpcParamValue :: ProcDescription -> (Text, Text) -> (Text, RpcParamValue)
|
||||
toRpcParamValue proc (k, v) | argIsVariadic k = (k, Variadic [v])
|
||||
| otherwise = (k, Fixed v)
|
||||
where
|
||||
argIsVariadic arg = isJust $ find (\PgArg{pgaName, pgaVar} -> pgaName == arg && pgaVar) $ pdArgs proc
|
||||
|
||||
-- | Convert rpc params `/rpc/func?a=val1&b=val2` to json `{"a": "val1", "b": "val2"}
|
||||
jsonRpcParams :: ProcDescription -> [(Text, Text)] -> PayloadJSON
|
||||
jsonRpcParams proc prms =
|
||||
if not $ pdHasVariadic proc then -- if proc has no variadic arg, save steps and directly convert to json
|
||||
ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> prms) (S.fromList $ fst <$> prms)
|
||||
else
|
||||
let paramsMap = M.fromListWith mergeParams $ toRpcParamValue proc <$> prms in
|
||||
ProcessedJSON (JSON.encode paramsMap) (S.fromList $ M.keys paramsMap)
|
||||
where
|
||||
mergeParams :: RpcParamValue -> RpcParamValue -> RpcParamValue
|
||||
mergeParams (Variadic a) (Variadic b) = Variadic $ b ++ a
|
||||
mergeParams v _ = v -- repeated params for non-variadic arguments are not merged
|
||||
|
||||
{-|
|
||||
Describes what the user wants to do. This data type is a
|
||||
translation of the raw elements of an HTTP request into domain
|
||||
specific language. There is no guarantee that the intent is
|
||||
sensible, it is up to a later stage of processing to determine
|
||||
if it is an action we are able to perform.
|
||||
-}
|
||||
data ApiRequest = ApiRequest {
|
||||
iAction :: Action -- ^ Similar but not identical to HTTP verb, e.g. Create/Invoke both POST
|
||||
, iRange :: M.HashMap ByteString NonnegRange -- ^ Requested range of rows within response
|
||||
, iTopLevelRange :: NonnegRange -- ^ Requested range of rows from the top level
|
||||
, iTarget :: Target -- ^ The target, be it calling a proc or accessing a table
|
||||
, iAccepts :: [ContentType] -- ^ Content types the client will accept, [CTAny] if no Accept header
|
||||
, iPayload :: Maybe PayloadJSON -- ^ Data sent by client and used for mutation actions
|
||||
, iPreferRepresentation :: PreferRepresentation -- ^ If client wants created items echoed back
|
||||
, iPreferParameters :: Maybe PreferParameters -- ^ How to pass parameters to a stored procedure
|
||||
, 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")
|
||||
, 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 :: [(Text, Text)] -- ^ HTTP request headers
|
||||
, iCookies :: [(Text, Text)] -- ^ Request Cookies
|
||||
, iPath :: ByteString -- ^ Raw request path
|
||||
, iMethod :: ByteString -- ^ Raw request method
|
||||
, iProfile :: Maybe Schema -- ^ The request profile for enabling use of multiple schemas. Follows the spec in hhttps://www.w3.org/TR/dx-prof-conneg/ttps://www.w3.org/TR/dx-prof-conneg/.
|
||||
, iSchema :: Schema -- ^ The request schema. Can vary depending on iProfile.
|
||||
}
|
||||
|
||||
-- | Examines HTTP request and translates it into user intent.
|
||||
userApiRequest :: NonEmpty Schema -> Maybe Text -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest
|
||||
userApiRequest confSchemas rootSpec dbStructure req reqBody
|
||||
| isJust profile && fromJust profile `notElem` confSchemas = Left $ UnacceptableSchema $ toList confSchemas
|
||||
| isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate
|
||||
| topLevelRange == emptyRange = Left InvalidRange
|
||||
| shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload
|
||||
| isLeft parsedColumns = either Left witness parsedColumns
|
||||
| otherwise = Right ApiRequest {
|
||||
iAction = action
|
||||
, iTarget = target
|
||||
, iRange = ranges
|
||||
, iTopLevelRange = topLevelRange
|
||||
, iAccepts = maybe [CTAny] (map ContentType.decodeContentType . parseHttpAccept) $ lookupHeader "accept"
|
||||
, iPayload = relevantPayload
|
||||
, iPreferRepresentation = representation
|
||||
, iPreferParameters = if | hasPrefer (show SingleObject) -> Just SingleObject
|
||||
| hasPrefer (show MultipleObjects) -> Just MultipleObjects
|
||||
| otherwise -> Nothing
|
||||
, iPreferCount = if | hasPrefer (show ExactCount) -> Just ExactCount
|
||||
| hasPrefer (show PlannedCount) -> Just PlannedCount
|
||||
| hasPrefer (show EstimatedCount) -> Just EstimatedCount
|
||||
| otherwise -> Nothing
|
||||
, iPreferResolution = if | hasPrefer (show MergeDuplicates) -> Just MergeDuplicates
|
||||
| hasPrefer (show IgnoreDuplicates) -> Just IgnoreDuplicates
|
||||
| otherwise -> Nothing
|
||||
, iPreferTransaction = if | hasPrefer (show Commit) -> Just Commit
|
||||
| hasPrefer (show Rollback) -> Just Rollback
|
||||
| otherwise -> Nothing
|
||||
, iFilters = filters
|
||||
, 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 = toS $ urlEncodeVars
|
||||
. L.sortOn fst
|
||||
. map (join (***) toS . second (fromMaybe BS.empty))
|
||||
$ qString
|
||||
, iJWT = tokenStr
|
||||
, iHeaders = [ (toS $ CI.foldedCase k, toS v) | (k,v) <- hdrs, k /= hCookie]
|
||||
, iCookies = maybe [] parseCookiesText $ lookupHeader "Cookie"
|
||||
, iPath = rawPathInfo req
|
||||
, iMethod = method
|
||||
, iProfile = profile
|
||||
, iSchema = schema
|
||||
}
|
||||
where
|
||||
-- queryString with '+' converted to ' '(space)
|
||||
qString = parseQueryReplacePlus True $ rawQueryString req
|
||||
-- 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 target of
|
||||
TargetProc _ _ -> True
|
||||
_ -> False
|
||||
isTargetingDefaultSpec = case target of
|
||||
TargetDefaultSpec _ -> True
|
||||
_ -> False
|
||||
contentType = ContentType.decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
|
||||
columns
|
||||
| action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
|
||||
| otherwise = Nothing
|
||||
parsedColumns = pRequestColumns columns
|
||||
payloadColumns =
|
||||
case (contentType, action) of
|
||||
(_, ActionInvoke InvGet) -> S.fromList $ fst <$> rpcQParams
|
||||
(_, ActionInvoke InvHead) -> S.fromList $ fst <$> rpcQParams
|
||||
(CTOther "application/x-www-form-urlencoded", _) -> S.fromList $ map (toS . fst) $ parseSimpleQuery $ toS reqBody
|
||||
_ -> case (relevantPayload, fromRight Nothing parsedColumns) of
|
||||
(Just ProcessedJSON{pjKeys}, _) -> pjKeys
|
||||
(Just RawJSON{}, Just cls) -> cls
|
||||
_ -> S.empty
|
||||
payload = case contentType of
|
||||
CTApplicationJSON ->
|
||||
if isJust columns
|
||||
then Right $ RawJSON reqBody
|
||||
else note "All object keys must match" . payloadAttributes reqBody
|
||||
=<< if BL.null reqBody && isTargetingProc
|
||||
then Right emptyObject
|
||||
else JSON.eitherDecode reqBody
|
||||
CTTextCSV -> do
|
||||
json <- csvToJson <$> CSV.decodeByName reqBody
|
||||
note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
|
||||
CTUrlEncoded ->
|
||||
let urlEncodedBody = parseSimpleQuery $ toS reqBody in
|
||||
case target of
|
||||
TargetProc{tProc} ->
|
||||
Right $ jsonRpcParams tProc $ (toS *** toS) <$> urlEncodedBody
|
||||
_ ->
|
||||
let paramsMap = M.fromList $ (toS *** JSON.String . toS) <$> urlEncodedBody in
|
||||
Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (M.keys paramsMap)
|
||||
ct ->
|
||||
Left $ toS $ "Content-Type not acceptable: " <> ContentType.toMime ct
|
||||
topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows
|
||||
action =
|
||||
case method of
|
||||
-- The HEAD method is identical to GET except that the server MUST NOT return a message-body in the response
|
||||
-- From https://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.4
|
||||
"HEAD" | isTargetingDefaultSpec -> ActionInspect{isHead=True}
|
||||
| isTargetingProc -> ActionInvoke InvHead
|
||||
| otherwise -> ActionRead{isHead=True}
|
||||
"GET" | isTargetingDefaultSpec -> ActionInspect{isHead=False}
|
||||
| isTargetingProc -> ActionInvoke InvGet
|
||||
| otherwise -> ActionRead{isHead=False}
|
||||
"POST" -> if isTargetingProc
|
||||
then ActionInvoke InvPost
|
||||
else ActionCreate
|
||||
"PATCH" -> ActionUpdate
|
||||
"PUT" -> ActionSingleUpsert
|
||||
"DELETE" -> ActionDelete
|
||||
"OPTIONS" -> ActionInfo
|
||||
_ -> ActionInspect{isHead=False}
|
||||
|
||||
defaultSchema = head confSchemas
|
||||
profile
|
||||
| length confSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config
|
||||
= Nothing
|
||||
| otherwise = case action of
|
||||
-- POST/PATCH/PUT/DELETE don't use the same header as per the spec
|
||||
ActionCreate -> contentProfile
|
||||
ActionUpdate -> contentProfile
|
||||
ActionSingleUpsert -> contentProfile
|
||||
ActionDelete -> contentProfile
|
||||
ActionInvoke InvPost -> contentProfile
|
||||
_ -> acceptProfile
|
||||
where
|
||||
contentProfile = Just $ maybe defaultSchema toS $ lookupHeader "Content-Profile"
|
||||
acceptProfile = Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile"
|
||||
schema = fromMaybe defaultSchema profile
|
||||
target =
|
||||
let
|
||||
callFindProc proc = findProc (QualifiedIdentifier schema proc) payloadColumns (hasPrefer (show SingleObject)) $ dbProcs dbStructure
|
||||
in
|
||||
case path of
|
||||
[] -> case rootSpec of
|
||||
Just pName -> TargetProc (callFindProc pName) True
|
||||
Nothing -> TargetDefaultSpec schema
|
||||
[table] -> TargetIdent $ QualifiedIdentifier schema table
|
||||
["rpc", pName] -> TargetProc (callFindProc pName) False
|
||||
_ -> TargetUnknown
|
||||
|
||||
shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke InvPost]
|
||||
relevantPayload = case (target, 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.
|
||||
(TargetProc{tProc}, ActionInvoke InvGet) -> Just $ jsonRpcParams tProc rpcQParams
|
||||
(TargetProc{tProc}, ActionInvoke InvHead) -> Just $ jsonRpcParams tProc rpcQParams
|
||||
_ | shouldParsePayload -> rightToMaybe payload
|
||||
| otherwise -> Nothing
|
||||
path = pathInfo req
|
||||
method = requestMethod req
|
||||
hdrs = requestHeaders req
|
||||
qParams = [(toS k, v)|(k,v) <- qString]
|
||||
lookupHeader = flip lookup hdrs
|
||||
hasPrefer :: Text -> Bool
|
||||
hasPrefer val = any (\(h,v) -> h == "Prefer" && val `elem` split v) hdrs
|
||||
where
|
||||
split :: BS.ByteString -> [Text]
|
||||
split = map T.strip . T.split (==',') . toS
|
||||
representation
|
||||
| hasPrefer (show Full) = Full
|
||||
| hasPrefer (show None) = None
|
||||
| otherwise = if action == ActionCreate
|
||||
then HeadersOnly -- Assume the user wants the Location header(for POST) by default
|
||||
else None
|
||||
auth = fromMaybe "" $ lookupHeader hAuthorization
|
||||
tokenStr = case T.split (== ' ') (toS auth) of
|
||||
("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 ByteString NonnegRange
|
||||
limitParams = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]
|
||||
offsetParams :: M.HashMap ByteString 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
|
||||
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
|
||||
client in order of decreasing preference and a list of types
|
||||
producible by the server. If there is no match but the client
|
||||
accepts */* then return the top server pick.
|
||||
-}
|
||||
mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType
|
||||
mutuallyAgreeable sProduces cAccepts =
|
||||
let exact = listToMaybe $ L.intersect cAccepts sProduces in
|
||||
if isNothing exact && CTAny `elem` cAccepts
|
||||
then listToMaybe sProduces
|
||||
else exact
|
||||
|
||||
type CsvData = V.Vector (M.HashMap Text BL.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 .
|
||||
M.map (\str ->
|
||||
if str == "NULL"
|
||||
then JSON.Null
|
||||
else JSON.String $ toS str
|
||||
)
|
||||
|
||||
payloadAttributes :: RequestBody -> JSON.Value -> Maybe PayloadJSON
|
||||
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 $ M.keys o
|
||||
areKeysUniform = all (\case
|
||||
JSON.Object x -> S.fromList (M.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 $ M.keys o)
|
||||
|
||||
-- truncate everything else to an empty array.
|
||||
_ -> Just emptyPJArray
|
||||
where
|
||||
emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
|
||||
@@ -0,0 +1,382 @@
|
||||
{-|
|
||||
Module : PostgREST.Request.DbRequestBuilder
|
||||
Description : PostgREST database request builder
|
||||
|
||||
This module is in charge of building an intermediate
|
||||
representation(ReadRequest, MutateRequest) between the HTTP request and the
|
||||
final resulting SQL query.
|
||||
|
||||
A query tree is built in case of resource embedding. By inferring the
|
||||
relationship between tables, join conditions are added for every embedded
|
||||
resource.
|
||||
-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module PostgREST.Request.DbRequestBuilder
|
||||
( readRequest
|
||||
, mutateRequest
|
||||
, returningCols
|
||||
) where
|
||||
|
||||
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,
|
||||
QualifiedIdentifier (..),
|
||||
Schema, TableName)
|
||||
import PostgREST.DbStructure.Relation (Cardinality (..), Link (..),
|
||||
Relation (..))
|
||||
import PostgREST.DbStructure.Table (Column (..), Table (..),
|
||||
tableQi)
|
||||
import PostgREST.Error (ApiRequestError (..),
|
||||
Error (..))
|
||||
import PostgREST.Query.SqlFragment (sourceCTEName)
|
||||
import PostgREST.RangeQuery (NonnegRange, allRange,
|
||||
restrictRange)
|
||||
import PostgREST.Request.ApiRequest (Action (..),
|
||||
ApiRequest (..),
|
||||
PayloadJSON (..))
|
||||
|
||||
import PostgREST.Request.Parsers
|
||||
import PostgREST.Request.Preferences
|
||||
import PostgREST.Request.Types
|
||||
|
||||
import qualified PostgREST.DbStructure.Relation as Relation
|
||||
|
||||
import Protolude hiding (from)
|
||||
|
||||
-- | Builds the ReadRequest tree on a number of stages.
|
||||
-- | Adds filters, order, limits on its respective nodes.
|
||||
-- | Adds joins conditions obtained from resource embedding.
|
||||
readRequest :: Schema -> TableName -> Maybe Integer -> [Relation] -> ApiRequest -> Either Error ReadRequest
|
||||
readRequest schema rootTableName maxRows allRels apiRequest =
|
||||
mapLeft ApiRequestError $
|
||||
treeRestrictRange maxRows =<<
|
||||
augmentRequestWithJoin schema rootRels =<<
|
||||
addFiltersOrdersRanges apiRequest =<<
|
||||
(initReadRequest rootName <$> pRequestSelect sel)
|
||||
where
|
||||
sel = fromMaybe "*" $ iSelect apiRequest -- default to all columns requested (SELECT *) for a non existent ?select querystring param
|
||||
(rootName, rootRels) = rootWithRels schema rootTableName allRels (iAction apiRequest)
|
||||
|
||||
-- Get the root table name with its relationships according to the Action type.
|
||||
-- This is done because of the shape of the final SQL Query. The mutation cases
|
||||
-- are wrapped in a WITH {sourceCTEName}(see Statements.hs). So we need a FROM
|
||||
-- {sourceCTEName} instead of FROM {tableName}.
|
||||
rootWithRels :: Schema -> TableName -> [Relation] -> Action -> (QualifiedIdentifier, [Relation])
|
||||
rootWithRels schema rootTableName allRels action = case action of
|
||||
ActionRead _ -> (QualifiedIdentifier schema rootTableName, allRels) -- normal read case
|
||||
_ -> (QualifiedIdentifier mempty _sourceCTEName, mapMaybe toSourceRel allRels ++ allRels) -- mutation cases and calling proc
|
||||
where
|
||||
_sourceCTEName = decodeUtf8 sourceCTEName
|
||||
-- To enable embedding in the sourceCTEName cases we need to replace the
|
||||
-- foreign key tableName in the Relation with {sourceCTEName}. This way
|
||||
-- findRel can find relationships with sourceCTEName.
|
||||
toSourceRel :: Relation -> Maybe Relation
|
||||
toSourceRel r@Relation{relTable=t}
|
||||
| rootTableName == tableName t = Just $ r {relTable=t {tableName=_sourceCTEName}}
|
||||
| otherwise = Nothing
|
||||
|
||||
-- Build the initial tree with a Depth attribute so when a self join occurs we
|
||||
-- can differentiate the parent and child tables by having an alias like
|
||||
-- "table_depth", this is related to
|
||||
-- http://github.com/PostgREST/postgrest/issues/987.
|
||||
initReadRequest :: QualifiedIdentifier -> [Tree SelectItem] -> ReadRequest
|
||||
initReadRequest rootQi =
|
||||
foldr (treeEntry rootDepth) initial
|
||||
where
|
||||
rootDepth = 0
|
||||
rootSchema = qiSchema rootQi
|
||||
rootName = qiName rootQi
|
||||
initial = Node (Select [] rootQi Nothing [] [] [] [] allRange, (rootName, Nothing, Nothing, Nothing, rootDepth)) []
|
||||
treeEntry :: Depth -> Tree SelectItem -> ReadRequest -> ReadRequest
|
||||
treeEntry depth (Node fld@((fn, _),_,alias, embedHint) fldForest) (Node (q, i) rForest) =
|
||||
let nxtDepth = succ depth in
|
||||
case fldForest of
|
||||
[] -> Node (q {select=fld:select q}, i) rForest
|
||||
_ -> Node (q, i) $
|
||||
foldr (treeEntry nxtDepth)
|
||||
(Node (Select [] (QualifiedIdentifier rootSchema fn) Nothing [] [] [] [] allRange,
|
||||
(fn, Nothing, alias, embedHint, nxtDepth)) [])
|
||||
fldForest:rForest
|
||||
|
||||
-- | Enforces the `max-rows` config on the result
|
||||
treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
|
||||
treeRestrictRange maxRows request = pure $ nodeRestrictRange maxRows <$> request
|
||||
where
|
||||
nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
|
||||
nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
|
||||
|
||||
augmentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either ApiRequestError ReadRequest
|
||||
augmentRequestWithJoin schema allRels request =
|
||||
addRels schema allRels Nothing request
|
||||
>>= addJoinConditions Nothing
|
||||
|
||||
addRels :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
|
||||
addRels schema allRels parentNode (Node (query@Select{from=tbl}, (nodeName, _, alias, hint, depth)) forest) =
|
||||
case parentNode of
|
||||
Just (Node (Select{from=parentNodeQi}, _) _) ->
|
||||
let newFrom r = if qiName tbl == nodeName then tableQi (relFTable r) else tbl
|
||||
newReadNode = (\r -> (query{from=newFrom r}, (nodeName, Just r, alias, Nothing, depth))) <$> rel
|
||||
rel = findRel schema allRels (qiName parentNodeQi) nodeName hint
|
||||
in
|
||||
Node <$> newReadNode <*> (updateForest . hush $ Node <$> newReadNode <*> pure forest)
|
||||
_ ->
|
||||
let rn = (query, (nodeName, Nothing, alias, Nothing, depth)) in
|
||||
Node rn <$> updateForest (Just $ Node rn forest)
|
||||
where
|
||||
updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
|
||||
updateForest rq = addRels schema allRels rq `traverse` forest
|
||||
|
||||
-- Finds a relationship between an origin and a target in the request:
|
||||
-- /origin?select=target(*) If more than one relationship is found then the
|
||||
-- request is ambiguous and we return an error. In that case the request can
|
||||
-- be disambiguated by adding precision to the target or by using a hint:
|
||||
-- /origin?select=target!hint(*) The elements will be matched according to
|
||||
-- these rules:
|
||||
-- origin = table / view
|
||||
-- target = table / view / constraint / column-from-origin
|
||||
-- hint = table / view / constraint / column-from-origin / column-from-target
|
||||
-- (hint can take table / view values to aid in finding the junction in an m2m relationship)
|
||||
findRel :: Schema -> [Relation] -> NodeName -> NodeName -> Maybe EmbedHint -> Either ApiRequestError Relation
|
||||
findRel schema allRels origin target hint =
|
||||
case rel of
|
||||
[] -> Left $ NoRelBetween origin target
|
||||
[r] -> Right r
|
||||
rs ->
|
||||
-- Return error if more than one relationship is found, unless we're in a
|
||||
-- self reference case.
|
||||
--
|
||||
-- Here we handle a self reference relationship to not cause a breaking
|
||||
-- change: In a self reference we get two relationships with the same
|
||||
-- foreign key and relTable/relFtable but with different
|
||||
-- cardinalities(m2o/o2m) We output the O2M rel, the M2O rel can be
|
||||
-- obtained by using the origin column as an embed hint.
|
||||
let [rel0, rel1] = take 2 rs in
|
||||
if length rs == 2 && relLink rel0 == relLink rel1 && relTable rel0 == relTable rel1 && relFTable rel0 == relFTable rel1
|
||||
then note (NoRelBetween origin target) (find (\r -> relType r == O2M) rs)
|
||||
else Left $ AmbiguousRelBetween origin target rs
|
||||
where
|
||||
matchFKSingleCol hint_ cols = length cols == 1 && hint_ == (colName <$> head cols)
|
||||
rel = filter (
|
||||
\Relation{..} ->
|
||||
-- Both relationship ends need to be on the exposed schema
|
||||
schema == tableSchema relTable && schema == tableSchema relFTable &&
|
||||
(
|
||||
-- /projects?select=clients(*)
|
||||
origin == tableName relTable && -- projects
|
||||
target == tableName relFTable || -- clients
|
||||
|
||||
-- /projects?select=projects_client_id_fkey(*)
|
||||
(
|
||||
origin == tableName relTable && -- projects
|
||||
Constraint target == relLink -- projects_client_id_fkey
|
||||
) ||
|
||||
-- /projects?select=client_id(*)
|
||||
(
|
||||
origin == tableName relTable && -- projects
|
||||
matchFKSingleCol (Just target) relColumns -- client_id
|
||||
)
|
||||
) && (
|
||||
isNothing hint || -- hint is optional
|
||||
|
||||
-- /projects?select=clients!projects_client_id_fkey(*)
|
||||
(
|
||||
relType /= M2M &&
|
||||
hint == Just (constName relLink) -- projects_client_id_fkey
|
||||
) ||
|
||||
|
||||
-- /projects?select=clients!client_id(*) or /projects?select=clients!id(*)
|
||||
matchFKSingleCol hint relColumns || -- client_id
|
||||
matchFKSingleCol hint relFColumns || -- id
|
||||
|
||||
-- /users?select=tasks!users_tasks(*)
|
||||
(
|
||||
relType == M2M && -- many-to-many between users and tasks
|
||||
hint == Just (tableName $ junTable relLink) -- users_tasks
|
||||
)
|
||||
)
|
||||
) allRels
|
||||
|
||||
-- previousAlias is only used for the case of self joins
|
||||
addJoinConditions :: Maybe Alias -> ReadRequest -> Either ApiRequestError ReadRequest
|
||||
addJoinConditions previousAlias (Node node@(query@Select{from=tbl}, nodeProps@(_, rel, _, _, depth)) forest) =
|
||||
case rel of
|
||||
Just r@Relation{relType=M2M, relLink=Junction{junTable}} ->
|
||||
let rq = augmentQuery r in
|
||||
Node (rq{implicitJoins=tableQi junTable:implicitJoins rq}, nodeProps) <$> updatedForest
|
||||
Just r -> Node (augmentQuery r, nodeProps) <$> updatedForest
|
||||
Nothing -> Node node <$> updatedForest
|
||||
where
|
||||
newAlias = case Relation.isSelfReference <$> rel of
|
||||
Just True
|
||||
| depth /= 0 -> Just (qiName tbl <> "_" <> show depth) -- root node doesn't get aliased
|
||||
| otherwise -> Nothing
|
||||
_ -> Nothing
|
||||
augmentQuery r =
|
||||
foldr
|
||||
(\jc rq@Select{joinConditions=jcs} -> rq{joinConditions=jc:jcs})
|
||||
query{fromAlias=newAlias}
|
||||
(getJoinConditions previousAlias newAlias r)
|
||||
updatedForest = addJoinConditions newAlias `traverse` forest
|
||||
|
||||
-- previousAlias and newAlias are used in the case of self joins
|
||||
getJoinConditions :: Maybe Alias -> Maybe Alias -> Relation -> [JoinCondition]
|
||||
getJoinConditions previousAlias newAlias (Relation Table{tableSchema=tSchema, tableName=tN} cols Table{tableName=ftN} fCols _ lnk) =
|
||||
case lnk of
|
||||
Junction Table{tableName=jtn} _ jc1 _ jc2 ->
|
||||
zipWith (toJoinCondition tN jtn) cols jc1 ++ zipWith (toJoinCondition ftN jtn) fCols jc2
|
||||
Constraint _ ->
|
||||
zipWith (toJoinCondition tN ftN) cols fCols
|
||||
where
|
||||
toJoinCondition :: Text -> Text -> Column -> Column -> JoinCondition
|
||||
toJoinCondition tb ftb c fc =
|
||||
let qi1 = removeSourceCTESchema tSchema tb
|
||||
qi2 = removeSourceCTESchema tSchema ftb in
|
||||
JoinCondition (maybe qi1 (QualifiedIdentifier mempty) previousAlias, colName c)
|
||||
(maybe qi2 (QualifiedIdentifier mempty) newAlias, colName fc)
|
||||
|
||||
-- On mutation and calling proc cases we wrap the target table in a WITH
|
||||
-- {sourceCTEName} if this happens remove the schema `FROM
|
||||
-- "schema"."{sourceCTEName}"` and use only the `FROM "{sourceCTEName}"`.
|
||||
-- If the schema remains the FROM would be invalid.
|
||||
removeSourceCTESchema :: Schema -> TableName -> QualifiedIdentifier
|
||||
removeSourceCTESchema schema tbl = QualifiedIdentifier (if tbl == decodeUtf8 sourceCTEName then mempty else schema) tbl
|
||||
|
||||
addFiltersOrdersRanges :: ApiRequest -> ReadRequest -> Either ApiRequestError ReadRequest
|
||||
addFiltersOrdersRanges apiRequest rReq = do
|
||||
rFlts <- foldr addFilter rReq <$> filters
|
||||
rOrds <- foldr addOrder rFlts <$> orders
|
||||
rRngs <- foldr addRange rOrds <$> ranges
|
||||
foldr addLogicTree rRngs <$> logicForest
|
||||
where
|
||||
filters :: Either ApiRequestError [(EmbedPath, Filter)]
|
||||
filters = pRequestFilter `traverse` flts
|
||||
orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]
|
||||
orders = pRequestOrder `traverse` iOrder apiRequest
|
||||
ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]
|
||||
ranges = pRequestRange `traverse` M.toList (iRange apiRequest)
|
||||
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) =
|
||||
case action of
|
||||
ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest)
|
||||
ActionRead _ -> (iFilters apiRequest, iLogic apiRequest)
|
||||
_ -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
|
||||
|
||||
addFilterToNode :: Filter -> ReadRequest -> ReadRequest
|
||||
addFilterToNode flt (Node (q@Select {where_=lf}, i) f) = Node (q{where_=addFilterToLogicForest flt lf}::ReadQuery, i) f
|
||||
|
||||
addFilter :: (EmbedPath, Filter) -> ReadRequest -> ReadRequest
|
||||
addFilter = addProperty addFilterToNode
|
||||
|
||||
addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest
|
||||
addOrderToNode o (Node (q,i) f) = Node (q{order=o}, i) f
|
||||
|
||||
addOrder :: (EmbedPath, [OrderTerm]) -> ReadRequest -> ReadRequest
|
||||
addOrder = addProperty addOrderToNode
|
||||
|
||||
addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest
|
||||
addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f
|
||||
|
||||
addRange :: (EmbedPath, NonnegRange) -> ReadRequest -> ReadRequest
|
||||
addRange = addProperty addRangeToNode
|
||||
|
||||
addLogicTreeToNode :: LogicTree -> ReadRequest -> ReadRequest
|
||||
addLogicTreeToNode t (Node (q@Select{where_=lf},i) f) = Node (q{where_=t:lf}::ReadQuery, i) f
|
||||
|
||||
addLogicTree :: (EmbedPath, LogicTree) -> ReadRequest -> ReadRequest
|
||||
addLogicTree = addProperty addLogicTreeToNode
|
||||
|
||||
addProperty :: (a -> ReadRequest -> ReadRequest) -> (EmbedPath, a) -> ReadRequest -> ReadRequest
|
||||
addProperty f ([], a) rr = f a rr
|
||||
addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =
|
||||
case pathNode of
|
||||
Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path
|
||||
Just tn -> Node rn (addProperty f (remainingPath, a) tn:delete tn forest)
|
||||
where
|
||||
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 $
|
||||
case action of
|
||||
ActionCreate -> do
|
||||
confCols <- case iOnConflict apiRequest of
|
||||
Nothing -> pure pkCols
|
||||
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 (iLogic apiRequest) &&
|
||||
S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols &&
|
||||
not (null (S.fromList pkCols)) &&
|
||||
all (\case
|
||||
Filter _ (OpExpr False (Op "eq" _)) -> True
|
||||
_ -> False) flts
|
||||
then Insert qi (iColumns apiRequest) body (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
|
||||
else
|
||||
Left InvalidFilters) =<< filters
|
||||
ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings
|
||||
_ -> Left UnsupportedVerb
|
||||
where
|
||||
qi = QualifiedIdentifier schema tName
|
||||
action = iAction apiRequest
|
||||
returnings =
|
||||
if iPreferRepresentation apiRequest == 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)
|
||||
onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
|
||||
body = pjRaw <$> iPayload apiRequest
|
||||
|
||||
returningCols :: ReadRequest -> [FieldName] -> [FieldName]
|
||||
returningCols rr@(Node _ forest) pkCols
|
||||
-- if * is part of the select, we must not add pk or fk columns manually -
|
||||
-- otherwise those would be selected and output twice
|
||||
| "*" `elem` fldNames = ["*"]
|
||||
| otherwise = returnings
|
||||
where
|
||||
fldNames = fstFieldNames rr
|
||||
-- Without fkCols, when a mutateRequest to
|
||||
-- /projects?select=name,clients(name) occurs, the RETURNING SQL part would
|
||||
-- be `RETURNING name`(see QueryBuilder). This would make the embedding
|
||||
-- fail because the following JOIN would need the "client_id" column from
|
||||
-- projects. So this adds the foreign key columns to ensure the embedding
|
||||
-- succeeds, result would be `RETURNING name, client_id`. This also works
|
||||
-- for the other relType's.
|
||||
fkCols = concat $ mapMaybe (\case
|
||||
Node (_, (_, Just Relation{relColumns=cols, relType=relTyp}, _, _, _)) _ -> case relTyp of
|
||||
O2M -> Just cols
|
||||
M2O -> Just cols
|
||||
M2M -> Just cols
|
||||
_ -> Nothing
|
||||
) forest
|
||||
-- However if the "client_id" is present, e.g. mutateRequest to
|
||||
-- /projects?select=client_id,name,clients(name) we would get `RETURNING
|
||||
-- client_id, name, client_id` and then we would produce the "column
|
||||
-- reference \"client_id\" is ambiguous" error from PostgreSQL. So we
|
||||
-- deduplicate with Set: We are adding the primary key columns as well to
|
||||
-- make sure, that a proper location header can always be built for
|
||||
-- INSERT/POST
|
||||
returnings = S.toList . S.fromList $ fldNames ++ (colName <$> fkCols) ++ pkCols
|
||||
|
||||
-- Traditional filters(e.g. id=eq.1) are added as root nodes of the LogicTree
|
||||
-- they are later concatenated with AND in the QueryBuilder
|
||||
addFilterToLogicForest :: Filter -> [LogicTree] -> [LogicTree]
|
||||
addFilterToLogicForest flt lf = Stmnt flt : lf
|
||||
@@ -0,0 +1,276 @@
|
||||
{-|
|
||||
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, toS, try)
|
||||
import Protolude.Conv (toS)
|
||||
|
||||
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 :: (ByteString, 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 = toS <$> (string "*" $> ("*"::ByteString))
|
||||
|
||||
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
|
||||
hint <- optionMaybe (
|
||||
try ( char '!' *> pFieldName) <|>
|
||||
-- deprecated, remove in next major version
|
||||
try ( char '.' *> pFieldName)
|
||||
)
|
||||
return (fld, Nothing, alias, hint)
|
||||
)
|
||||
|
||||
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)
|
||||
)
|
||||
<|> do
|
||||
s <- pStar
|
||||
return ((s, []), 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)
|
||||
<|> pFts
|
||||
<?> "operator (eq, gt, ...)"
|
||||
|
||||
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":ftsOps)) operators
|
||||
ftsOps = M.keys ftsOperators
|
||||
|
||||
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 (noneOf "\"") <* char '"')
|
||||
|
||||
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)
|
||||
@@ -0,0 +1,54 @@
|
||||
module PostgREST.Request.Preferences where
|
||||
|
||||
import GHC.Show
|
||||
import Protolude
|
||||
|
||||
|
||||
data PreferResolution
|
||||
= MergeDuplicates
|
||||
| IgnoreDuplicates
|
||||
|
||||
instance Show PreferResolution where
|
||||
show MergeDuplicates = "resolution=merge-duplicates"
|
||||
show 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 plus the Location header(in case of POST).
|
||||
| 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 Show PreferRepresentation where
|
||||
show Full = "return=representation"
|
||||
show None = "return=minimal"
|
||||
show HeadersOnly = mempty
|
||||
|
||||
data PreferParameters
|
||||
= SingleObject -- ^ Pass all parameters as a single json object to a stored procedure
|
||||
| MultipleObjects -- ^ Pass an array of json objects as params to a stored procedure
|
||||
deriving Eq
|
||||
|
||||
instance Show PreferParameters where
|
||||
show SingleObject = "params=single-object"
|
||||
show MultipleObjects = "params=multiple-objects"
|
||||
|
||||
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 Show PreferCount where
|
||||
show ExactCount = "count=exact"
|
||||
show PlannedCount = "count=planned"
|
||||
show EstimatedCount = "count=estimated"
|
||||
|
||||
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 Show PreferTransaction where
|
||||
show Commit = "tx=commit"
|
||||
show Rollback = "tx=rollback"
|
||||
@@ -0,0 +1,211 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
module PostgREST.Request.Types
|
||||
( Alias
|
||||
, Depth
|
||||
, EmbedHint
|
||||
, EmbedPath
|
||||
, Field
|
||||
, Filter(..)
|
||||
, JoinCondition(..)
|
||||
, JsonOperand(..)
|
||||
, JsonOperation(..)
|
||||
, JsonPath
|
||||
, ListVal
|
||||
, LogicOperator(..)
|
||||
, LogicTree(..)
|
||||
, MutateQuery(..)
|
||||
, MutateRequest
|
||||
, NodeName
|
||||
, OpExpr(..)
|
||||
, Operation (..)
|
||||
, OrderDirection(..)
|
||||
, OrderNulls(..)
|
||||
, OrderTerm(..)
|
||||
, ReadNode
|
||||
, ReadQuery(..)
|
||||
, ReadRequest
|
||||
, SelectItem
|
||||
, SingleVal
|
||||
, fstFieldNames
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Set as S
|
||||
|
||||
import Data.Tree (Tree (..))
|
||||
|
||||
import qualified GHC.Show (show)
|
||||
|
||||
import PostgREST.DbStructure.Identifiers (FieldName,
|
||||
QualifiedIdentifier)
|
||||
import PostgREST.DbStructure.Relation (Relation)
|
||||
import PostgREST.RangeQuery (NonnegRange)
|
||||
import PostgREST.Request.Preferences (PreferResolution)
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
type ReadRequest = Tree ReadNode
|
||||
type MutateRequest = MutateQuery
|
||||
|
||||
type ReadNode =
|
||||
(ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe EmbedHint, Depth))
|
||||
|
||||
type NodeName = Text
|
||||
type Depth = Integer
|
||||
|
||||
data ReadQuery = Select
|
||||
{ select :: [SelectItem]
|
||||
, from :: QualifiedIdentifier
|
||||
-- ^ A table alias is used in case of self joins
|
||||
, fromAlias :: Maybe Alias
|
||||
-- ^ Only used for Many to Many joins. Parent and Child joins use explicit joins.
|
||||
, implicitJoins :: [QualifiedIdentifier]
|
||||
, where_ :: [LogicTree]
|
||||
, joinConditions :: [JoinCondition]
|
||||
, order :: [OrderTerm]
|
||||
, range_ :: NonnegRange
|
||||
}
|
||||
deriving (Eq)
|
||||
|
||||
data JoinCondition =
|
||||
JoinCondition
|
||||
(QualifiedIdentifier, FieldName)
|
||||
(QualifiedIdentifier, FieldName)
|
||||
deriving (Eq)
|
||||
|
||||
data OrderTerm = OrderTerm
|
||||
{ otTerm :: Field
|
||||
, otDirection :: Maybe OrderDirection
|
||||
, otNullOrder :: Maybe OrderNulls
|
||||
}
|
||||
deriving (Eq)
|
||||
|
||||
data OrderDirection
|
||||
= OrderAsc
|
||||
| OrderDesc
|
||||
deriving (Eq)
|
||||
|
||||
instance Show OrderDirection where
|
||||
show OrderAsc = "ASC"
|
||||
show OrderDesc = "DESC"
|
||||
|
||||
data OrderNulls
|
||||
= OrderNullsFirst
|
||||
| OrderNullsLast
|
||||
deriving (Eq)
|
||||
|
||||
instance Show OrderNulls where
|
||||
show OrderNullsFirst = "NULLS FIRST"
|
||||
show OrderNullsLast = "NULLS LAST"
|
||||
|
||||
data MutateQuery
|
||||
= Insert
|
||||
{ in_ :: QualifiedIdentifier
|
||||
, insCols :: S.Set FieldName
|
||||
, insBody :: Maybe BL.ByteString
|
||||
, onConflict :: Maybe (PreferResolution, [FieldName])
|
||||
, where_ :: [LogicTree]
|
||||
, returning :: [FieldName]
|
||||
}
|
||||
| Update
|
||||
{ in_ :: QualifiedIdentifier
|
||||
, updCols :: S.Set FieldName
|
||||
, updBody :: Maybe BL.ByteString
|
||||
, where_ :: [LogicTree]
|
||||
, returning :: [FieldName]
|
||||
}
|
||||
| Delete
|
||||
{ in_ :: QualifiedIdentifier
|
||||
, where_ :: [LogicTree]
|
||||
, returning :: [FieldName]
|
||||
}
|
||||
|
||||
-- | This type will hold information about which particular 'Relation' between
|
||||
-- two tables to choose when there are multiple ones.
|
||||
-- Specifically, it will contain the name of the foreign key or the join table
|
||||
-- in many to many relations.
|
||||
type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)
|
||||
|
||||
type Field = (FieldName, JsonPath)
|
||||
type Cast = Text
|
||||
type Alias = Text
|
||||
|
||||
-- | 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.
|
||||
type EmbedHint = Text
|
||||
|
||||
-- | 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)
|
||||
|
||||
-- | Represents the key(`->'key'`) or index(`->'1`::int`), the index is Text
|
||||
-- because we reuse our escaping functons and let pg do the casting with
|
||||
-- '1'::int
|
||||
data JsonOperand
|
||||
= JKey { jVal :: Text }
|
||||
| JIdx { jVal :: Text }
|
||||
deriving (Eq)
|
||||
|
||||
-- First level FieldNames(e.g get a,b from /table?select=a,b,other(c,d))
|
||||
fstFieldNames :: ReadRequest -> [FieldName]
|
||||
fstFieldNames (Node (sel, _) _) =
|
||||
fst . (\(f, _, _, _) -> f) <$> select sel
|
||||
|
||||
|
||||
-- | 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)
|
||||
|
||||
data LogicOperator
|
||||
= And
|
||||
| Or
|
||||
deriving Eq
|
||||
|
||||
instance Show LogicOperator where
|
||||
show And = "AND"
|
||||
show Or = "OR"
|
||||
|
||||
data Filter = Filter
|
||||
{ field :: Field
|
||||
, opExpr :: OpExpr
|
||||
}
|
||||
deriving (Eq)
|
||||
|
||||
data OpExpr =
|
||||
OpExpr Bool Operation
|
||||
deriving (Eq)
|
||||
|
||||
data Operation
|
||||
= Op Operator SingleVal
|
||||
| In ListVal
|
||||
| Fts Operator (Maybe Language) SingleVal
|
||||
deriving (Eq)
|
||||
|
||||
type Operator = Text
|
||||
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]
|
||||
Reference in New Issue
Block a user