Ensure JSON payload objects all have same keys

2015-11-22 13:51:46 -08:00
parent 60007b5f10
commit 1f6fc5cbd8
3 changed files with 63 additions and 29 deletions
@@ -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
-                    JSON.Object o -> o
-                    _ -> undefined
-                  where pp = V.head payload
+          let p = 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)
@@ -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
-        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
+        _            -> Nothing 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
@@ -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)