Coalesce types UniformObjects and Payload into the new PayloadJSON

2016-11-27 23:55:26 -05:00
parent 16ac034aab
commit 6c275fcec2
4 changed files with 32 additions and 38 deletions
@@ -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(..),
-                                            UniformObjects(..))
+                                            Schema,
+                                            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
-ensureUniform :: JSON.Array -> Maybe UniformObjects
+-- and if so mark it as PayloadJSON
+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
@@ -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
-                  fakeload = PayloadJSON emptyUniform
-                  stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload
-              row <- H.query emptyUniform stm
+              let emptyPayload = PayloadJSON V.empty
+                  stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) emptyPayload
+              row <- H.query emptyPayload 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
@@ -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 ->
-                        H.Query UniformObjects (Maybe ResultsWithCount)
+                        PreferRepresentation -> [Text] -> Bool -> PayloadJSON ->
+                        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
@@ -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
-unUniformObjects (UniformObjects 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)
+unPayloadJSON :: PayloadJSON -> V.Vector Object
+unPayloadJSON (PayloadJSON objs) = objs

 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