139 lines
5.4 KiB
Haskell
139 lines
5.4 KiB
Haskell
-- |
|
|
-- 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
|