Coalesce types UniformObjects and Payload into the new PayloadJSON

src/PostgREST/ApiRequest.hs

@@ -36,8 +36,8 @@ import           Network.Wai.Parse         (parseHttpAccept)
 import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
 import           Data.Ranged.Boundaries
 import           PostgREST.Types           (QualifiedIdentifier (..),
-                                            Schema, Payload(..),
+                                            Schema,
-                                            UniformObjects(..))
+                                            PayloadJSON(..))
 import           Data.Ranged.Ranges        (Range(..), singletonRange, rangeIntersection, emptyRange)
 
 type RequestBody = BL.ByteString
@@ -95,7 +95,7 @@ data ApiRequest = ApiRequest {
   -- | Content types the client will accept, [CTAny] if no Accept header
   , iAccepts :: [ContentType]
   -- | Data sent by client and used for mutation actions
-  , iPayload :: Maybe Payload
+  , iPayload :: Maybe PayloadJSON
   -- | If client wants created items echoed back
   , iPreferRepresentation :: PreferRepresentation
   -- | If client wants first row as raw object
@@ -150,13 +150,13 @@ userApiRequest schema req reqBody
       CTApplicationJSON ->
           either Left (\val -> case ensureUniform (pluralize val) of
             Nothing -> Left "All object keys must match"
-            Just json -> Right $ PayloadJSON json) (JSON.eitherDecode reqBody)
+            Just json -> Right json) (JSON.eitherDecode reqBody)
       CTTextCSV ->
           either Left (\val -> case ensureUniform (csvToJson val) of
             Nothing -> Left "All lines must have same number of fields"
-            Just json -> Right $ PayloadJSON json) (CSV.decodeByName reqBody)
+            Just json -> Right json) (CSV.decodeByName reqBody)
       CTOther "application/x-www-form-urlencoded" ->
-        Right . PayloadJSON . UniformObjects . V.singleton . M.fromList
+        Right . PayloadJSON . V.singleton . M.fromList
                     . map (toS *** JSON.String . toS) . parseSimpleQuery
                     $ toS reqBody
       ct ->
@@ -283,8 +283,8 @@ 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
+-- and if so mark it as PayloadJSON
-ensureUniform :: JSON.Array -> Maybe UniformObjects
+ensureUniform :: JSON.Array -> Maybe PayloadJSON
 ensureUniform arr =
   let objs :: V.Vector JSON.Object
       objs = foldr -- filter non-objects, map to raw objects
@@ -297,5 +297,5 @@ ensureUniform arr =
       areKeysUniform = all (==canonicalKeys) keysPerObj in
 
   if (V.length objs == V.length arr) && areKeysUniform
-    then Just (UniformObjects objs)
+    then Just (PayloadJSON objs)
     else Nothing

src/PostgREST/App.hs

@@ -128,7 +128,7 @@ app dbStructure conf apiRequest =
                     )
                   ] (toS body)
 
-        (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
+        (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->
           case mutateSqlParts of
             Left errorResponse -> return errorResponse
             Right (sq, mq) -> do
@@ -142,7 +142,7 @@ app dbStructure conf apiRequest =
                         |]
               let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
               let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload
-              row <- H.query uniform stm
+              row <- H.query payload stm
               let (_, _, fs, body) = extractQueryResult row
                   headers = catMaybes [
                       if null fs
@@ -159,13 +159,13 @@ app dbStructure conf apiRequest =
                 if iPreferRepresentation apiRequest == Full
                   then toS body else ""
 
-        (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) ->
+        (ActionUpdate, TargetIdent qi, Just payload) ->
           case mutateSqlParts of
             Left errorResponse -> return errorResponse
             Right (sq, mq) -> do
               let singular = iPreferSingular apiRequest
                   stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload
-              row <- H.query uniform stm
+              row <- H.query payload stm
               let (_, queryTotal, _, body) = extractQueryResult row
               when (singular && queryTotal > 1) $
                 HT.sql [P6.q| DO $$
@@ -187,10 +187,9 @@ app dbStructure conf apiRequest =
           case mutateSqlParts of
             Left errorResponse -> return errorResponse
             Right (sq, mq) -> do
-              let emptyUniform = UniformObjects V.empty
+              let emptyPayload = PayloadJSON V.empty
-                  fakeload = PayloadJSON emptyUniform
+                  stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) emptyPayload
-                  stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload
+              row <- H.query emptyPayload stm
-              row <- H.query emptyUniform stm
               let (_, queryTotal, _, body) = extractQueryResult row
                   r = contentRangeH 1 0 $
                         toInteger <$> if shouldCount then Just queryTotal else Nothing
@@ -208,7 +207,7 @@ app dbStructure conf apiRequest =
               let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
               return $ responseLBS status200 [allOrigins, acceptH] ""
 
-        (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) ->
+        (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->
           case readSqlParts of
             Left errorResponse -> return errorResponse
             Right (q, cq) -> do

src/PostgREST/QueryBuilder.hs

@@ -83,12 +83,12 @@ decodeStandardMay =
   HD.maybeRow standardRow
 
 {-| JSON and CSV payloads from the client are given to us as
-    UniformObjects (objects who all have the same keys),
+    PayloadJSON (objects who all have the same keys),
     and we turn this into an old fasioned JSON array
 -}
-encodeUniformObjs :: HE.Params UniformObjects
+encodeUniformObjs :: HE.Params PayloadJSON
 encodeUniformObjs =
-  contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json)
+  contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json)
 
 createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
                        H.Query () ResultsWithCount
@@ -111,10 +111,10 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv =
     | otherwise = asJsonF
 
 createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool ->
-                        PreferRepresentation -> [Text] -> Bool -> Payload ->
+                        PreferRepresentation -> [Text] -> Bool -> PayloadJSON ->
-                        H.Query UniformObjects (Maybe ResultsWithCount)
+                        H.Query PayloadJSON (Maybe ResultsWithCount)
 createWriteStatement _ _ mutateQuery _ None
-                     _ _ (PayloadJSON (UniformObjects _)) =
+                     _ _ (PayloadJSON _) =
   unicodeStatement sql encodeUniformObjs decodeStandardMay True
  where
   sql = [qc|
@@ -122,7 +122,7 @@ createWriteStatement _ _ mutateQuery _ None
       SELECT '', 0, {noLocationF}, '' |]
 
 createWriteStatement qi _ mutateQuery isSingle HeadersOnly
-                     pKeys _ (PayloadJSON (UniformObjects _)) =
+                     pKeys _ (PayloadJSON _) =
   unicodeStatement sql encodeUniformObjs decodeStandardMay True
  where
   sql = [qc|
@@ -137,7 +137,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly
     ]
 
 createWriteStatement qi selectQuery mutateQuery isSingle Full
-                     pKeys asCsv (PayloadJSON (UniformObjects _)) =
+                     pKeys asCsv (PayloadJSON _) =
   unicodeStatement sql encodeUniformObjs decodeStandardMay True
  where
   sql = [qc|
@@ -381,7 +381,7 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions
     --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
     --posible relations are Child Parent Many
     getQueryParts _ _ = undefined --error "undefined getQueryParts"
-requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) =
+requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows))) =
   let qi = QualifiedIdentifier schema mainTbl
       cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
       colsString = intercalate ", " cols
@@ -393,7 +393,7 @@ requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects r
                 else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] in
   insInto <> vals
 
-requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) =
+requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions)) =
   case rows V.!? 0 of
     Just obj ->
       let assignments = map

src/PostgREST/Types.hs

@@ -101,16 +101,11 @@ data Relation = Relation {
 
 -- | An array of JSON objects that has been verified to have
 -- the same keys in every object
-newtype UniformObjects = UniformObjects (V.Vector Object)
+newtype PayloadJSON = PayloadJSON (V.Vector Object)
   deriving (Show, Eq)
 
-unUniformObjects :: UniformObjects -> V.Vector Object
+unPayloadJSON :: PayloadJSON -> V.Vector Object
-unUniformObjects (UniformObjects objs) = objs
+unPayloadJSON (PayloadJSON objs) = objs
-
--- | 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 UniformObjects deriving (Show, Eq)
 
 data Proxy = Proxy {
   proxyScheme     :: Text
@@ -130,9 +125,9 @@ type NodeName = Text
 type SelectItem = (Field, Maybe Cast, Maybe Alias)
 type Path = [Text]
 data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
-data MutateQuery = Insert { in_::TableName, qPayload::Payload }
+data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON }
                  | Delete { in_::TableName, where_::[Filter] }
-                 | Update { in_::TableName, qPayload::Payload, where_::[Filter] } deriving (Show, Eq)
+                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter] } deriving (Show, Eq)
 data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
 type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
 type ReadRequest = Tree ReadNode