diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 24963e4e2..d5961ded2 100644 --- a/src/PostgREST/App.hs +++ b/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 - 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) diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index b3199caee..f802eac26 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/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 - 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 diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 9e1346f94..e9a6ad586 100644 --- a/src/PostgREST/Types.hs +++ b/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)