Skip to content

Commit 96571aa

Browse files
taimoorzaeemsteve-chavez
taimoorzaeem
authored and
steve-chavez
committed
refactor: move request body to a Payload.hs module
1 parent aa58e37 commit 96571aa

File tree

7 files changed

+213
-174
lines changed

7 files changed

+213
-174
lines changed

‎postgrest.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -85,6 +85,7 @@ library
8585
PostgREST.ApiRequest
8686
PostgREST.ApiRequest.Preferences
8787
PostgREST.ApiRequest.QueryParams
88+
PostgREST.ApiRequest.Payload
8889
PostgREST.ApiRequest.Types
8990
PostgREST.Response
9091
PostgREST.Response.OpenAPI

‎src/PostgREST/ApiRequest.hs‎

Lines changed: 10 additions & 162 deletions
Original file line numberDiff line numberDiff line change
@@ -6,44 +6,30 @@ Description : PostgREST functions to translate HTTP request to a domain type cal
66
{-# LANGUAGE NamedFieldPuns #-}
77
module PostgREST.ApiRequest
88
( ApiRequest(..)
9-
, InvokeMethod(..)
10-
, Mutation(..)
11-
, MediaType(..)
12-
, Action(..)
13-
, DbAction(..)
14-
, Payload(..)
159
, userApiRequest
1610
, userPreferences
1711
) where
1812

19-
import qualified Data.Aeson as JSON
20-
import qualified Data.Aeson.Key as K
21-
import qualified Data.Aeson.KeyMap as KM
22-
import qualified Data.ByteString.Char8 as BS
23-
import qualified Data.ByteString.Lazy as LBS
24-
import qualified Data.CaseInsensitive as CI
25-
import qualified Data.Csv as CSV
26-
import qualified Data.HashMap.Strict as HM
27-
import qualified Data.List.NonEmpty as NonEmptyList
28-
import qualified Data.Map.Strict as M
29-
import qualified Data.Set as S
30-
import qualified Data.Text.Encoding as T
31-
import qualified Data.Vector as V
13+
import qualified Data.CaseInsensitive as CI
14+
import qualified Data.HashMap.Strict as HM
15+
import qualified Data.List.NonEmpty as NonEmptyList
16+
import qualified Data.Set as S
17+
import qualified Data.Text.Encoding as T
3218

33-
import Data.Either.Combinators (mapBoth)
34-
35-
import Control.Arrow ((***))
36-
import Data.Aeson.Types (emptyArray, emptyObject)
3719
import Data.List (lookup)
3820
import Data.Ranged.Ranges (emptyRange, rangeIntersection,
3921
rangeIsEmpty)
4022
import Network.HTTP.Types.Header (RequestHeaders, hCookie)
41-
import Network.HTTP.Types.URI (parseSimpleQuery)
4223
import Network.Wai (Request (..))
4324
import Network.Wai.Parse (parseHttpAccept)
4425
import Web.Cookie (parseCookies)
4526

27+
import PostgREST.ApiRequest.Payload (getPayload)
4628
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
29+
import PostgREST.ApiRequest.Types (Action (..), DbAction (..),
30+
InvokeMethod (..),
31+
Mutation (..), Payload (..),
32+
RequestBody, Resource (..))
4733
import PostgREST.Config (AppConfig (..),
4834
OpenAPIMode (..))
4935
import PostgREST.Config.Database (TimezoneNames)
@@ -64,44 +50,6 @@ import qualified PostgREST.MediaType as MediaType
6450

6551
import Protolude
6652

67-
68-
type RequestBody = LBS.ByteString
69-
70-
data Payload
71-
= ProcessedJSON -- ^ Cached attributes of a JSON payload
72-
{ payRaw :: LBS.ByteString
73-
-- ^ This is the raw ByteString that comes from the request body. We
74-
-- cache this instead of an Aeson Value because it was detected that for
75-
-- large payloads the encoding had high memory usage, see
76-
-- https://github.com/PostgREST/postgrest/pull/1005 for more details
77-
, payKeys :: S.Set Text
78-
-- ^ Keys of the object or if it's an array these keys are guaranteed to
79-
-- be the same across all its objects
80-
}
81-
| ProcessedUrlEncoded { payArray :: [(Text, Text)], payKeys :: S.Set Text }
82-
| RawJSON { payRaw :: LBS.ByteString }
83-
| RawPay { payRaw :: LBS.ByteString }
84-
85-
data InvokeMethod = Inv | InvRead Bool deriving Eq
86-
data Mutation = MutationCreate | MutationDelete | MutationSingleUpsert | MutationUpdate deriving Eq
87-
88-
data Resource
89-
= ResourceRelation Text
90-
| ResourceRoutine Text
91-
| ResourceSchema
92-
93-
data DbAction
94-
= ActRelationRead {dbActQi :: QualifiedIdentifier, actHeadersOnly :: Bool}
95-
| ActRelationMut {dbActQi :: QualifiedIdentifier, actMutation :: Mutation}
96-
| ActRoutine {dbActQi :: QualifiedIdentifier, actInvMethod :: InvokeMethod}
97-
| ActSchemaRead Schema Bool
98-
99-
data Action
100-
= ActDb DbAction
101-
| ActRelationInfo QualifiedIdentifier
102-
| ActRoutineInfo QualifiedIdentifier InvokeMethod
103-
| ActSchemaInfo
104-
10553
{-|
10654
Describes what the user wants to do. This data type is a
10755
translation of the raw elements of an HTTP request into domain
@@ -240,103 +188,3 @@ getRanges method QueryParams{qsRanges} hdrs
240188
-- The only emptyRange allowed is the limit zero range
241189
isInvalidRange = topLevelRange == emptyRange && not (hasLimitZero limitRange)
242190
topLevelRange = fromMaybe allRange $ HM.lookup "limit" ranges -- if no limit is specified, get all the request rows
243-
244-
getPayload :: RequestBody -> MediaType -> QueryParams.QueryParams -> Action -> Either ApiRequestError (Maybe Payload, S.Set FieldName)
245-
getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
246-
checkedPayload <- if shouldParsePayload then payload else Right Nothing
247-
let cols = case (checkedPayload, columns) of
248-
(Just ProcessedJSON{payKeys}, _) -> payKeys
249-
(Just ProcessedUrlEncoded{payKeys}, _) -> payKeys
250-
(Just RawJSON{}, Just cls) -> cls
251-
_ -> S.empty
252-
return (checkedPayload, cols)
253-
where
254-
payload :: Either ApiRequestError (Maybe Payload)
255-
payload = mapBoth InvalidBody Just $ case (contentMediaType, isProc) of
256-
(MTApplicationJSON, _) ->
257-
if isJust columns
258-
then Right $ RawJSON reqBody
259-
else note "All object keys must match" . payloadAttributes reqBody
260-
=<< if LBS.null reqBody && isProc
261-
then Right emptyObject
262-
else first BS.pack $
263-
-- Drop parsing error message in favor of generic one (https://github.com/PostgREST/postgrest/issues/2344)
264-
maybe (Left "Empty or invalid json") Right $ JSON.decode reqBody
265-
(MTTextCSV, _) -> do
266-
json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody)
267-
note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
268-
(MTUrlEncoded, True) ->
269-
Right $ ProcessedUrlEncoded params (S.fromList $ fst <$> params)
270-
(MTUrlEncoded, False) ->
271-
let paramsMap = HM.fromList $ (identity *** JSON.String) <$> params in
272-
Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap)
273-
(MTTextPlain, True) -> Right $ RawPay reqBody
274-
(MTTextXML, True) -> Right $ RawPay reqBody
275-
(MTOctetStream, True) -> Right $ RawPay reqBody
276-
(ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
277-
278-
shouldParsePayload = case action of
279-
ActDb (ActRelationMut _ MutationDelete) -> False
280-
ActDb (ActRelationMut _ _) -> True
281-
ActDb (ActRoutine _ Inv) -> True
282-
_ -> False
283-
284-
columns = case action of
285-
ActDb (ActRelationMut _ MutationCreate) -> qsColumns
286-
ActDb (ActRelationMut _ MutationUpdate) -> qsColumns
287-
ActDb (ActRoutine _ Inv) -> qsColumns
288-
_ -> Nothing
289-
290-
isProc = case action of
291-
ActDb (ActRoutine _ _) -> True
292-
_ -> False
293-
params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
294-
295-
type CsvData = V.Vector (M.Map Text LBS.ByteString)
296-
297-
{-|
298-
Converts CSV like
299-
a,b
300-
1,hi
301-
2,bye
302-
303-
into a JSON array like
304-
[ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
305-
306-
The reason for its odd signature is so that it can compose
307-
directly with CSV.decodeByName
308-
-}
309-
csvToJson :: (CSV.Header, CsvData) -> JSON.Value
310-
csvToJson (_, vals) =
311-
JSON.Array $ V.map rowToJsonObj vals
312-
where
313-
rowToJsonObj = JSON.Object . KM.fromMapText .
314-
M.map (\str ->
315-
if str == "NULL"
316-
then JSON.Null
317-
else JSON.String . T.decodeUtf8 $ LBS.toStrict str
318-
)
319-
320-
payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
321-
payloadAttributes raw json =
322-
-- Test that Array contains only Objects having the same keys
323-
case json of
324-
JSON.Array arr ->
325-
case arr V.!? 0 of
326-
Just (JSON.Object o) ->
327-
let canonicalKeys = S.fromList $ K.toText <$> KM.keys o
328-
areKeysUniform = all (\case
329-
JSON.Object x -> S.fromList (K.toText <$> KM.keys x) == canonicalKeys
330-
_ -> False) arr in
331-
if areKeysUniform
332-
then Just $ ProcessedJSON raw canonicalKeys
333-
else Nothing
334-
Just _ -> Nothing
335-
Nothing -> Just emptyPJArray
336-
337-
JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ K.toText <$> KM.keys o)
338-
339-
-- truncate everything else to an empty array.
340-
_ -> Just emptyPJArray
341-
where
342-
emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty

‎src/PostgREST/ApiRequest/Payload.hs‎

Lines changed: 138 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,138 @@
1+
-- |
2+
-- Module : PostgREST.ApiRequest.Payload
3+
-- Description : Parser for PostgREST Request Body
4+
--
5+
-- This module is in charge of parsing the request body (payload)
6+
--
7+
{-# LANGUAGE LambdaCase #-}
8+
{-# LANGUAGE NamedFieldPuns #-}
9+
module PostgREST.ApiRequest.Payload
10+
( getPayload
11+
) where
12+
13+
import qualified Data.Aeson as JSON
14+
import qualified Data.Aeson.Key as K
15+
import qualified Data.Aeson.KeyMap as KM
16+
import qualified Data.ByteString.Char8 as BS
17+
import qualified Data.ByteString.Lazy as LBS
18+
import qualified Data.Csv as CSV
19+
import qualified Data.HashMap.Strict as HM
20+
import qualified Data.Map.Strict as M
21+
import qualified Data.Set as S
22+
import qualified Data.Text.Encoding as T
23+
import qualified Data.Vector as V
24+
25+
import Control.Arrow ((***))
26+
import Data.Aeson.Types (emptyArray, emptyObject)
27+
import Data.Either.Combinators (mapBoth)
28+
import Network.HTTP.Types.URI (parseSimpleQuery)
29+
30+
import PostgREST.ApiRequest.QueryParams (QueryParams (..))
31+
import PostgREST.ApiRequest.Types
32+
import PostgREST.Error (ApiRequestError (..))
33+
import PostgREST.MediaType (MediaType (..))
34+
import PostgREST.SchemaCache.Identifiers (FieldName)
35+
36+
import qualified PostgREST.MediaType as MediaType
37+
38+
import Protolude
39+
40+
getPayload :: RequestBody -> MediaType -> QueryParams -> Action -> Either ApiRequestError (Maybe Payload, S.Set FieldName)
41+
getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
42+
checkedPayload <- if shouldParsePayload then payload else Right Nothing
43+
let cols = case (checkedPayload, columns) of
44+
(Just ProcessedJSON{payKeys}, _) -> payKeys
45+
(Just ProcessedUrlEncoded{payKeys}, _) -> payKeys
46+
(Just RawJSON{}, Just cls) -> cls
47+
_ -> S.empty
48+
return (checkedPayload, cols)
49+
where
50+
payload :: Either ApiRequestError (Maybe Payload)
51+
payload = mapBoth InvalidBody Just $ case (contentMediaType, isProc) of
52+
(MTApplicationJSON, _) ->
53+
if isJust columns
54+
then Right $ RawJSON reqBody
55+
else note "All object keys must match" . payloadAttributes reqBody
56+
=<< if LBS.null reqBody && isProc
57+
then Right emptyObject
58+
else first BS.pack $
59+
-- Drop parsing error message in favor of generic one (https://github.com/PostgREST/postgrest/issues/2344)
60+
maybe (Left "Empty or invalid json") Right $ JSON.decode reqBody
61+
(MTTextCSV, _) -> do
62+
json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody)
63+
note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json
64+
(MTUrlEncoded, True) ->
65+
Right $ ProcessedUrlEncoded params (S.fromList $ fst <$> params)
66+
(MTUrlEncoded, False) ->
67+
let paramsMap = HM.fromList $ (identity *** JSON.String) <$> params in
68+
Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (HM.keys paramsMap)
69+
(MTTextPlain, True) -> Right $ RawPay reqBody
70+
(MTTextXML, True) -> Right $ RawPay reqBody
71+
(MTOctetStream, True) -> Right $ RawPay reqBody
72+
(ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
73+
74+
shouldParsePayload = case action of
75+
ActDb (ActRelationMut _ MutationDelete) -> False
76+
ActDb (ActRelationMut _ _) -> True
77+
ActDb (ActRoutine _ Inv) -> True
78+
_ -> False
79+
80+
columns = case action of
81+
ActDb (ActRelationMut _ MutationCreate) -> qsColumns
82+
ActDb (ActRelationMut _ MutationUpdate) -> qsColumns
83+
ActDb (ActRoutine _ Inv) -> qsColumns
84+
_ -> Nothing
85+
86+
isProc = case action of
87+
ActDb (ActRoutine _ _) -> True
88+
_ -> False
89+
params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
90+
91+
type CsvData = V.Vector (M.Map Text LBS.ByteString)
92+
93+
{-|
94+
Converts CSV like
95+
a,b
96+
1,hi
97+
2,bye
98+
99+
into a JSON array like
100+
[ {"a": "1", "b": "hi"}, {"a": 2, "b": "bye"} ]
101+
102+
The reason for its odd signature is so that it can compose
103+
directly with CSV.decodeByName
104+
-}
105+
csvToJson :: (CSV.Header, CsvData) -> JSON.Value
106+
csvToJson (_, vals) =
107+
JSON.Array $ V.map rowToJsonObj vals
108+
where
109+
rowToJsonObj = JSON.Object . KM.fromMapText .
110+
M.map (\str ->
111+
if str == "NULL"
112+
then JSON.Null
113+
else JSON.String . T.decodeUtf8 $ LBS.toStrict str
114+
)
115+
116+
payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload
117+
payloadAttributes raw json =
118+
-- Test that Array contains only Objects having the same keys
119+
case json of
120+
JSON.Array arr ->
121+
case arr V.!? 0 of
122+
Just (JSON.Object o) ->
123+
let canonicalKeys = S.fromList $ K.toText <$> KM.keys o
124+
areKeysUniform = all (\case
125+
JSON.Object x -> S.fromList (K.toText <$> KM.keys x) == canonicalKeys
126+
_ -> False) arr in
127+
if areKeysUniform
128+
then Just $ ProcessedJSON raw canonicalKeys
129+
else Nothing
130+
Just _ -> Nothing
131+
Nothing -> Just emptyPJArray
132+
133+
JSON.Object o -> Just $ ProcessedJSON raw (S.fromList $ K.toText <$> KM.keys o)
134+
135+
-- truncate everything else to an empty array.
136+
_ -> Just emptyPJArray
137+
where
138+
emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty

0 commit comments

Comments
 (0)