diff --git a/postgrest.cabal b/postgrest.cabal index 6330b047c..78fa01060 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -85,6 +85,7 @@ library PostgREST.ApiRequest PostgREST.ApiRequest.Preferences PostgREST.ApiRequest.QueryParams + PostgREST.ApiRequest.Payload PostgREST.ApiRequest.Types PostgREST.Response PostgREST.Response.OpenAPI diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 0e2b11634..fed1c6ac0 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -6,44 +6,30 @@ Description : PostgREST functions to translate HTTP request to a domain type cal {-# LANGUAGE NamedFieldPuns #-} module PostgREST.ApiRequest ( ApiRequest(..) - , InvokeMethod(..) - , Mutation(..) - , MediaType(..) - , Action(..) - , DbAction(..) - , Payload(..) , userApiRequest , userPreferences ) 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.CaseInsensitive as CI -import qualified Data.Csv as CSV -import qualified Data.HashMap.Strict as HM -import qualified Data.List.NonEmpty as NonEmptyList -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 qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NonEmptyList +import qualified Data.Set as S +import qualified Data.Text.Encoding as T -import Data.Either.Combinators (mapBoth) - -import Control.Arrow ((***)) -import Data.Aeson.Types (emptyArray, emptyObject) import Data.List (lookup) import Data.Ranged.Ranges (emptyRange, rangeIntersection, rangeIsEmpty) import Network.HTTP.Types.Header (RequestHeaders, hCookie) -import Network.HTTP.Types.URI (parseSimpleQuery) import Network.Wai (Request (..)) import Network.Wai.Parse (parseHttpAccept) import Web.Cookie (parseCookies) +import PostgREST.ApiRequest.Payload (getPayload) import PostgREST.ApiRequest.QueryParams (QueryParams (..)) +import PostgREST.ApiRequest.Types (Action (..), DbAction (..), + InvokeMethod (..), + Mutation (..), Payload (..), + RequestBody, Resource (..)) import PostgREST.Config (AppConfig (..), OpenAPIMode (..)) import PostgREST.Config.Database (TimezoneNames) @@ -64,44 +50,6 @@ import qualified PostgREST.MediaType as MediaType import Protolude - -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 } - -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 - {-| Describes what the user wants to do. This data type is a translation of the raw elements of an HTTP request into domain @@ -240,103 +188,3 @@ getRanges method QueryParams{qsRanges} hdrs -- The only emptyRange allowed is the limit zero range isInvalidRange = topLevelRange == emptyRange && not (hasLimitZero limitRange) topLevelRange = fromMaybe allRange $ HM.lookup "limit" ranges -- if no limit is specified, get all the request rows - -getPayload :: RequestBody -> MediaType -> QueryParams.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 diff --git a/src/PostgREST/ApiRequest/Payload.hs b/src/PostgREST/ApiRequest/Payload.hs new file mode 100644 index 000000000..2c959f895 --- /dev/null +++ b/src/PostgREST/ApiRequest/Payload.hs @@ -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 diff --git a/src/PostgREST/ApiRequest/Types.hs b/src/PostgREST/ApiRequest/Types.hs index a53d008d4..bf3ddd9b0 100644 --- a/src/PostgREST/ApiRequest/Types.hs +++ b/src/PostgREST/ApiRequest/Types.hs @@ -30,12 +30,69 @@ module PostgREST.ApiRequest.Types , QuantOperator(..) , FtsOperator(..) , SelectItem(..) + , Payload (..) + , InvokeMethod (..) + , Mutation (..) + , Resource (..) + , DbAction (..) + , Action (..) + , RequestBody ) where -import PostgREST.SchemaCache.Identifiers (FieldName) +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 diff --git a/src/PostgREST/Plan.hs b/src/PostgREST/Plan.hs index 99f0c82c2..d2db20ea9 100644 --- a/src/PostgREST/Plan.hs +++ b/src/PostgREST/Plan.hs @@ -37,12 +37,7 @@ import Data.List (delete, lookup) import Data.Maybe (fromJust) import Data.Tree (Tree (..)) -import PostgREST.ApiRequest (Action (..), - ApiRequest (..), - DbAction (..), - InvokeMethod (..), - Mutation (..), - Payload (..)) +import PostgREST.ApiRequest (ApiRequest (..)) import PostgREST.Config (AppConfig (..)) import PostgREST.Error (ApiRequestError (..), Error (..), diff --git a/src/PostgREST/Query.hs b/src/PostgREST/Query.hs index d43d31e4c..1d0d12511 100644 --- a/src/PostgREST/Query.hs +++ b/src/PostgREST/Query.hs @@ -27,14 +27,14 @@ import qualified PostgREST.Query.Statements as Statements import qualified PostgREST.SchemaCache as SchemaCache -import PostgREST.ApiRequest (ApiRequest (..), - Mutation (..)) +import PostgREST.ApiRequest (ApiRequest (..)) import PostgREST.ApiRequest.Preferences (PreferCount (..), PreferHandling (..), PreferMaxAffected (..), PreferTransaction (..), Preferences (..), shouldCount) +import PostgREST.ApiRequest.Types (Mutation (..)) import PostgREST.Auth.Types (AuthResult (..)) import PostgREST.Config (AppConfig (..), OpenAPIMode (..)) diff --git a/src/PostgREST/Response.hs b/src/PostgREST/Response.hs index f374a60ae..106aca884 100644 --- a/src/PostgREST/Response.hs +++ b/src/PostgREST/Response.hs @@ -24,15 +24,15 @@ import qualified PostgREST.MediaType as MediaType import qualified PostgREST.RangeQuery as RangeQuery import qualified PostgREST.Response.OpenAPI as OpenAPI -import PostgREST.ApiRequest (ApiRequest (..), - InvokeMethod (..), - Mutation (..)) +import PostgREST.ApiRequest (ApiRequest (..)) import PostgREST.ApiRequest.Preferences (PreferRepresentation (..), PreferResolution (..), Preferences (..), prefAppliedHeader, shouldCount) import PostgREST.ApiRequest.QueryParams (QueryParams (..)) +import PostgREST.ApiRequest.Types (InvokeMethod (..), + Mutation (..)) import PostgREST.Config (AppConfig (..)) import PostgREST.MediaType (MediaType (..)) import PostgREST.Plan (CallReadPlan (..),