Ensure JSON payload objects all have same keys

src/PostgREST/App.hs

@@ -13,6 +13,7 @@ import           Data.Bifunctor            (first)
 import qualified Data.ByteString.Lazy      as BL
 import           Data.Functor.Identity
 import qualified Data.HashMap.Strict       as HM
+import qualified Data.HashSet              as S
 import           Data.List                 (find, sortBy, delete, transpose)
 import           Data.Maybe                (fromMaybe, fromJust, isNothing, mapMaybe)
 import           Data.Ord                  (comparing)
@@ -113,7 +114,8 @@ app dbStructure conf reqBody req =
                   )
                 ] (fromMaybe "[]" body)
 
-    (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->
+    (ActionCreate, TargetIdent (QualifiedIdentifier _ table),
+     Just payload@(PayloadJSON (UniformObjects rows))) ->
       case queries of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq) -> do
@@ -147,7 +149,7 @@ app dbStructure conf reqBody req =
       case queries of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq) -> do
-          let fakeload = PayloadJSON V.empty
+          let fakeload = PayloadJSON $ UniformObjects V.empty
           let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) fakeload
           row <- H.maybeEx stm
           let (_, queryTotal, _, _) = extractQueryResult row
@@ -164,14 +166,12 @@ app dbStructure conf reqBody req =
           filterCol _ _ _ =  False
       return $ responseLBS status200 [jsonH, allOrigins] $ cs body
 
-    (ActionInvoke, TargetIdent qi, Just (PayloadJSON payload)) -> do
+    (ActionInvoke, TargetIdent qi,
+     Just (PayloadJSON (UniformObjects payload))) -> do
       exists <- doesProcExist qi
       if exists
         then do
-          let p = case pp of
+          let p = V.head payload
-                    JSON.Object o -> o
-                    _ -> undefined
-                  where pp = V.head payload
               call = B.Stmt "select " V.empty True <>
                 asJson (callProc qi p)
               jwtSecret = configJwtSecret conf
@@ -391,7 +391,8 @@ createReadStatement selectQuery range isSingle countTable asCsv =
 
 createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool ->
                         [Text] -> Bool -> Payload -> B.Stmt P.Postgres
-createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv (PayloadJSON rows) =
+createWriteStatement selectQuery mutateQuery isSingle echoRequested
+                     pKeys asCsv (PayloadJSON (UniformObjects rows)) =
   B.Stmt (
     wrapQuery mutateQuery [
       countNoneF, -- when updateing it does not make sense
@@ -405,7 +406,7 @@ createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv
       else "null"
 
     ] selectQuery Nothing
-  ) (V.singleton . B.encodeValue . JSON.Array $ rows) True
+  ) (V.singleton . B.encodeValue . JSON.Array . V.map Object $ rows) True
 
 extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
                          -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)

src/PostgREST/RequestIntent.hs

@@ -6,6 +6,7 @@ import qualified Data.ByteString.Lazy    as BL
 import qualified Data.Csv                as CSV
 import           Data.List               (find)
 import qualified Data.HashMap.Strict     as M
+import qualified Data.Set                as S
 import           Data.Maybe              (fromMaybe, isJust, isNothing,
                                           listToMaybe, fromJust)
 import           Control.Monad           (join)
@@ -17,7 +18,8 @@ import           Network.Wai             (Request (..))
 import           Network.Wai.Parse       (parseHttpAccept)
 import           PostgREST.RangeQuery    (NonnegRange, rangeRequested)
 import           PostgREST.Types         (QualifiedIdentifier (..),
-                                          Schema, Payload(..))
+                                          Schema, Payload(..),
+                                          UniformObjects(..))
 
 type RequestBody = BL.ByteString
 
@@ -88,30 +90,32 @@ userIntent schema req reqBody =
                  ["rpc", proc] -> TargetIdent
                                   $ QualifiedIdentifier schema proc
                  other         -> TargetUnknown other
-      reqPayload = case action of
+      payload = case pickContentType (lookupHeader "content-type") of
+        Right ApplicationJSON ->
+          either (PayloadParseError . cs)
+            (\val -> case ensureUniform (pluralize val) of
+              Nothing -> PayloadParseError "All object keys must match"
+              Just json -> PayloadJSON json)
+            (JSON.eitherDecode reqBody)
+        Right TextCSV ->
+          either (PayloadParseError . cs)
+            (PayloadJSON . csvToJson)
+            (CSV.decodeByName reqBody)
+        Left accept ->
+          PayloadParseError $
+            "Content-type not acceptable: " <> accept
+      relevantPayload = case action of
         ActionCreate -> Just payload
         ActionUpdate -> Just payload
         ActionInvoke -> Just payload
-        _            -> Nothing
+        _            -> Nothing in
-        where payload = case pickContentType (lookupHeader "content-type") of
-                     Right ApplicationJSON ->
-                       either (PayloadParseError . cs)
-                         (PayloadJSON . pluralize)
-                         (JSON.eitherDecode reqBody)
-                     Right TextCSV ->
-                       either (PayloadParseError . cs)
-                         (PayloadJSON . csvToJson)
-                         (CSV.decodeByName reqBody)
-                     Left accept ->
-                       PayloadParseError $
-                         "Content-type not acceptable: " <> accept in
 
   Intent {
     iAction = action
   , iRange  = if singular then Nothing else rangeRequested hdrs
   , iTarget = target
   , iAccepts = pickContentType $ lookupHeader "accept"
-  , iPayload = reqPayload
+  , iPayload = relevantPayload
   , iPreferRepresentation = hasPrefer "return=representation"
   , iPreferSingular = singular
   , iPreferCount = not $ hasPrefer "count=none"
@@ -173,11 +177,11 @@ type CsvData = V.Vector (M.HashMap T.Text BL.ByteString)
   The reason for its odd signature is so that it can compose
   directly with CSV.decodeByName
 -}
-csvToJson :: (CSV.Header, CsvData) -> JSON.Array
+csvToJson :: (CSV.Header, CsvData) -> UniformObjects
 csvToJson (_, vals) =
-  V.map rowToJsonObj vals
+  UniformObjects $ V.map rowToJsonObj vals
  where
-  rowToJsonObj = JSON.Object .
+  rowToJsonObj =
     M.map (\str ->
         if str == "NULL"
           then JSON.Null
@@ -190,3 +194,26 @@ pluralize :: JSON.Value -> JSON.Array
 pluralize obj@(JSON.Object _) = V.singleton obj
 pluralize (JSON.Array arr)    = arr
 pluralize _                   = V.empty
+
+-- | Test that Array contains only Objects having the same keys
+-- and if so mark it as UniformObjects
+ensureUniform :: JSON.Array -> Maybe UniformObjects
+ensureUniform arr =
+  let objs :: V.Vector JSON.Object
+      objs = foldr -- filter non-objects, map to raw objects
+               (\result val -> case val of
+                  JSON.Object o -> V.cons o result
+                  _ -> result)
+               V.empty arr
+      keysPerObj :: [S.Set T.Text]
+      keysPerObj = V.toList $ V.map (S.fromList . M.keys) objs
+      allKeys    :: S.Set T.Text
+      allKeys    = S.unions keysPerObj
+      commonKeys :: S.Set T.Text
+      commonKeys = case keysPerObj of
+                     h : _ -> foldr S.intersection h keysPerObj
+                     [] -> S.empty in
+
+  if (length objs == length arr) && (allKeys == commonKeys)
+    then Just (UniformObjects objs)
+    else Nothing

src/PostgREST/Types.hs

@@ -3,6 +3,7 @@ import Data.Text
 import Data.Tree
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString      as BS
+import qualified Data.Vector          as V
 import Data.Aeson
 
 data DbStructure = DbStructure {
@@ -84,10 +85,15 @@ data Relation = Relation {
 , relLCols2   :: Maybe [Column]
 } deriving (Show, Eq)
 
+-- | An array of JSON objects that has been verified to have
+-- the same keys in every object
+newtype UniformObjects = UniformObjects (V.Vector Object)
+  deriving (Show, Eq)
+
 -- | When Hasql supports the COPY command then we can
 -- have a special payload just for CSV, but until
 -- then CSV is converted to a JSON array.
-data Payload = PayloadJSON Array
+data Payload = PayloadJSON UniformObjects
              | PayloadParseError BS.ByteString
              deriving (Show, Eq)