Allow PUT method: UPSERT of a single row

2018-02-21 07:33:54 -05:00
parent 85b1dc0eb4
commit 6675821c64
12 changed files with 245 additions and 81 deletions
@@ -42,10 +42,10 @@ import           Web.Cookie                (parseCookiesText)
 type RequestBody = BL.ByteString

 -- | Types of things a user wants to do to tables/views/procs
-data Action = ActionCreate | ActionRead
-            | ActionUpdate | ActionDelete
-            | ActionInfo   | ActionInvoke{isReadOnly :: Bool}
-            | ActionInspect
+data Action = ActionCreate  | ActionRead
+            | ActionUpdate  | ActionDelete
+            | ActionInfo    | ActionInvoke{isReadOnly :: Bool}
+            | ActionInspect | ActionSingleUpsert
            deriving Eq
 -- | The target db object of a user action
 data Target = TargetIdent QualifiedIdentifier
@@ -173,6 +173,7 @@ userApiRequest schema req reqBody
                    then ActionInvoke{isReadOnly=False}
                    else ActionCreate
      "PATCH"   -> ActionUpdate
+      "PUT"     -> ActionSingleUpsert
      "DELETE"  -> ActionDelete
      "OPTIONS" -> ActionInfo
      _         -> ActionInspect
@@ -183,7 +184,7 @@ userApiRequest schema req reqBody
              ["rpc", proc] -> TargetProc
                              $ QualifiedIdentifier schema proc
              other         -> TargetUnknown other
-  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}, ActionInvoke{isReadOnly=True}]
+  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionSingleUpsert, ActionInvoke{isReadOnly=False}, ActionInvoke{isReadOnly=True}]
  relevantPayload | shouldParsePayload = rightToMaybe payload
                  | otherwise = Nothing
  path            = pathInfo req
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}

 module PostgREST.App (
  postgrest
@@ -79,7 +80,7 @@ postgrest conf refDbStructure pool worker =

            let authed = containsRole eClaims
                proc = case (iTarget apiRequest, iPayload apiRequest, iPreferSingleObjectParameter apiRequest) of
-                  (TargetProc qi, Just PayloadJSON{pjKeys=pKeys}, s) -> findProc qi pKeys s $ dbProcs dbStructure
+                  (TargetProc qi, Just PayloadJSON{pjKeys}, s) -> findProc qi pjKeys s $ dbProcs dbStructure
                  _ -> Nothing
                handleReq = runWithClaims conf eClaims (app dbStructure proc conf) apiRequest
                txMode = transactionMode proc (iAction apiRequest)
@@ -144,11 +145,11 @@ app dbStructure proc conf apiRequest =
                      )
                    ] (toS body)

-        (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON payload pType _)) ->
-          case mutateSqlParts of
+        (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType}) ->
+          case mutateSqlParts tSchema tName of
            Left errorResponse -> return errorResponse
            Right (sq, mq) -> do
-              let (isSingle, nRows) = case pType of
+              let (isSingle, nRows) = case pjType of
                                        PJArray len -> (len == 1, len)
                                        PJObject -> (True, 1)
              if contentType == CTSingularJSON
@@ -156,17 +157,16 @@ app dbStructure proc conf apiRequest =
                 && iPreferRepresentation apiRequest == Full
                then return $ singularityError (toInteger nRows)
                else do
-                  let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-                      stm = createWriteStatement sq mq
+                  let stm = createWriteStatement sq mq
                        (contentType == CTSingularJSON) isSingle
                        (contentType == CTTextCSV) (iPreferRepresentation apiRequest)
-                        pKeys
-                  row <- H.query (toS payload) stm
+                        (tablePKCols dbStructure tSchema tName)
+                  row <- H.query (toS pjRaw) stm
                  let (_, _, fs, body) = extractQueryResult row
                      headers = catMaybes [
                          if null fs
                            then Nothing
-                            else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
+                            else Just (hLocation, "/" <> toS tName <> renderLocationFields fs)
                        , if iPreferRepresentation apiRequest == Full
                            then Just $ toHeader contentType
                            else Nothing
@@ -178,8 +178,8 @@ app dbStructure proc conf apiRequest =
                    if iPreferRepresentation apiRequest == Full
                      then toS body else ""

-        (ActionUpdate, TargetIdent _, Just p@(PayloadJSON payload _ _)) ->
-          case (mutateSqlParts, pjIsEmpty p, iPreferRepresentation apiRequest == Full) of
+        (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just p@PayloadJSON{pjRaw}) ->
+          case (mutateSqlParts tSchema tName, pjIsEmpty p, iPreferRepresentation apiRequest == Full) of
            (Left errorResponse, _, _) -> return errorResponse
            (_, True, True) -> return $ responseLBS status200 [contentRangeH 1 0 Nothing] "[]"
            (_, True, False) -> return $ responseLBS status204 [contentRangeH 1 0 Nothing] ""
@@ -187,7 +187,7 @@ app dbStructure proc conf apiRequest =
              let stm = createWriteStatement sq mq
                    (contentType == CTSingularJSON) False (contentType == CTTextCSV)
                    (iPreferRepresentation apiRequest) []
-              row <- H.query (toS payload) stm
+              row <- H.query (toS pjRaw) stm
              let (_, queryTotal, _, body) = extractQueryResult row
              if contentType == CTSingularJSON
                 && queryTotal /= 1
@@ -205,8 +205,39 @@ app dbStructure proc conf apiRequest =
                    then responseLBS s [toHeader contentType, r] (toS body)
                    else responseLBS s [r] ""

-        (ActionDelete, TargetIdent _, Nothing) ->
-          case mutateSqlParts of
+        (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just PayloadJSON{pjRaw, pjType, pjKeys}) ->
+          case mutateSqlParts tSchema tName of
+            Left errorResponse -> return errorResponse
+            Right (sq, mq) -> do
+              let isSingle = case pjType of
+                               PJArray len -> len == 1
+                               PJObject -> True
+                  colNames = colName <$> tableCols dbStructure tSchema tName
+              if topLevelRange /= allRange
+                then return $ simpleError status400 [] "Range header and limit/offset querystring parameters are not allowed for PUT"
+              else if not isSingle
+                then return $ simpleError status400 [] "PUT payload must contain a single row"
+              else if S.fromList colNames /= pjKeys
+                then return $ simpleError status400 [] "You must specify all columns in the payload when using PUT"
+              else do
+                row <- H.query (toS pjRaw) $
+                       createWriteStatement sq mq (contentType == CTSingularJSON) False
+                                            (contentType == CTTextCSV) (iPreferRepresentation apiRequest) []
+                let (_, queryTotal, _, body) = extractQueryResult row
+                -- Makes sure the querystring pk matches the payload pk
+                -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, PUT /items?id=eq.14 { "id" : 2, .. } is rejected
+                -- If this condition is not satisfied then nothing is inserted, check the WHERE for INSERT in QueryBuilder.hs to see how it's done
+                if queryTotal /= 1
+                  then do
+                    HT.condemn
+                    return $ simpleError status400 [] "Payload values do not match URL in primary key column(s)"
+                  else
+                    return $ if iPreferRepresentation apiRequest == Full
+                      then responseLBS status200 [toHeader contentType] (toS body)
+                      else responseLBS status204 [] ""
+
+        (ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) ->
+          case mutateSqlParts tSchema tName of
            Left errorResponse -> return errorResponse
            Right (sq, mq) -> do
              let stm = createWriteStatement sq mq
@@ -236,7 +267,7 @@ app dbStructure proc 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 payload pType pKeys)) ->
+        (ActionInvoke _, TargetProc qi, Just PayloadJSON{pjRaw, pjType, pjKeys}) ->
          let returnsScalar = case proc of
                Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True
                _ -> False
@@ -247,12 +278,12 @@ app dbStructure proc conf apiRequest =
          case parts of
            Left errorResponse -> return errorResponse
            Right ((q, cq), bField) -> do
-              let isObject = case pType of
+              let isObject = case pjType of
                                PJObject  -> True
                                PJArray _ -> False
                  singular = contentType == CTSingularJSON
-                  specifiedPgArgs = filter ((`S.member` pKeys) . pgaName) $ fromMaybe [] (pdArgs <$> proc)
-              row <- H.query (toS payload) $
+                  specifiedPgArgs = filter ((`S.member` pjKeys) . pgaName) $ fromMaybe [] (pdArgs <$> proc)
+              row <- H.query (toS pjRaw) $
                callProc qi specifiedPgArgs returnsScalar q cq shouldCount
                         singular (iPreferSingleObjectParameter apiRequest)
                         (contentType == CTTextCSV)
@@ -278,25 +309,16 @@ app dbStructure proc conf apiRequest =
              uri Nothing = ("http", host, port, "/")
              uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
              uri' = uri proxy
-              encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd allPrKeys
+              toTableInfo :: [Table] -> [(Table, [Column], [Text])]
+              toTableInfo = map (\t -> let (s, tn) = (tableSchema t, tableName t) in (t, tableCols dbStructure s tn, tablePKCols dbStructure s tn))
+              encodeApi ti sd procs = encodeOpenAPI (concat $ M.elems procs) (toTableInfo ti) uri' sd $ dbPrimaryKeys dbStructure
          body <- encodeApi <$> H.query schema accessibleTables <*> H.query schema schemaDescription <*> H.query schema accessibleProcs
          return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body

        _ -> return notFound

    where
-      toTableInfo :: [Table] -> [(Table, [Column], [Text])]
-      toTableInfo = map (\t ->
-        let tSchema = tableSchema t
-            tTable = tableName t
-            cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
-            pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
-        in (t, cols, pkeys))
      notFound = responseLBS status404 [] ""
-      filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
-      filterCol :: Schema -> TableName -> Column -> Bool
-      filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
-      allPrKeys = dbPrimaryKeys dbStructure
      allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
      shouldCount = iPreferCount apiRequest
      schema = toS $ configSchema conf
@@ -311,12 +333,12 @@ app dbStructure proc conf apiRequest =
      readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) proc apiRequest
      fldNames = fieldNames <$> readReq
      readDbRequest = DbRead <$> readReq
-      mutateDbRequest = DbMutate <$> (mutateRequest apiRequest allPrKeys =<< fldNames)
      selectQuery = requestToQuery schema False <$> readDbRequest
-      mutateQuery = requestToQuery schema False <$> mutateDbRequest
      countQuery = requestToCountQuery schema <$> readDbRequest
      readSqlParts = (,) <$> selectQuery <*> countQuery
-      mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
+      mutateSqlParts s t =
+        (,) <$> selectQuery
+            <*> (requestToQuery schema False . DbMutate <$> (mutateRequest apiRequest t (tablePKCols dbStructure s t) =<< fldNames))

 responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
 responseContentTypeOrError accepts action = serves contentTypesForRequest accepts
@@ -330,6 +352,7 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept
        ActionInvoke _ ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
        ActionInspect -> [CTOpenAPI, CTApplicationJSON]
        ActionInfo ->    [CTTextCSV]
+        ActionSingleUpsert ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
    serves sProduces cAccepts =
      case mutuallyAgreeable sProduces cAccepts of
        Nothing -> do
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE DuplicateRecordFields    #-}
+{-# LANGUAGE LambdaCase #-}
 module PostgREST.DbRequestBuilder (
  readRequest
 , mutateRequest
@@ -13,6 +14,7 @@ import           Control.Lens.Tuple        (_1)
 import qualified Data.ByteString.Char8     as BS
 import           Data.List                 (delete)
 import           Data.Maybe                (fromJust)
+import qualified Data.Set                  as S
 import           Data.Text                 (isInfixOf)
 import           Data.Tree
 import           Data.Either.Combinators   (mapLeft)
@@ -302,22 +304,27 @@ toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
  | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}
  | otherwise = Nothing

-mutateRequest :: ApiRequest -> [PrimaryKey] -> [FieldName] -> Either Response MutateRequest
-mutateRequest apiRequest pks fldNames = mapLeft apiRequestError $
+mutateRequest :: ApiRequest -> TableName -> [Text] -> [FieldName] -> Either Response MutateRequest
+mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $
  case action of
-    ActionCreate -> Right $ Insert rootTableName payload pkCols_ (iPreferResolution apiRequest) returnings
-    ActionUpdate -> Update rootTableName <$> pure payload <*> combinedLogic <*> pure returnings
-    ActionDelete -> Delete rootTableName <$> combinedLogic <*> pure returnings
+    ActionCreate -> Right $ Insert tName pkCols payload (iPreferResolution apiRequest) [] returnings
+    ActionUpdate -> Update tName payload <$> combinedLogic <*> pure returnings
+    ActionSingleUpsert ->
+      (\flts ->
+        if null (iLogic apiRequest) &&
+           S.fromList (fst <$> iFilters apiRequest) == S.fromList pkCols &&
+           not (null (S.fromList pkCols)) &&
+           all (\case
+              Filter _ (OpExpr False (Op "eq" _)) -> True
+              _ -> False) flts
+          then Insert tName pkCols payload (Just MergeDuplicates) <$> combinedLogic <*> pure returnings
+        else
+          Left InvalidFilters) =<< filters
+    ActionDelete -> Delete tName <$> combinedLogic <*> pure returnings
    _            -> Left UnsupportedVerb
  where
    action = iAction apiRequest
    payload = fromJust $ iPayload apiRequest
-    (schema, rootTableName) = -- TODO: Make it safe
-      case iTarget apiRequest of
-        TargetIdent (QualifiedIdentifier s t) -> (s, t)
-        _ -> undefined
-    pkCols_ = pkName <$> filter (filterPk schema rootTableName) pks
-    filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
    returnings = if iPreferRepresentation apiRequest == None then [] else fldNames
    filters = map snd <$> mapM pRequestFilter mutateFilters
    logic = map snd <$> mapM pRequestLogicTree logicFilters
@@ -39,6 +39,7 @@ apiRequestError err =
        NoRelationBetween _ _ -> HT.status400
        InvalidRange -> HT.status416
        UnknownRelation -> HT.status404
+        InvalidFilters -> HT.status405

 simpleError :: HT.Status -> [Header] -> Text -> Response
 simpleError status hdrs message =
@@ -107,6 +108,8 @@ instance JSON.ToJSON ApiRequestError where
    "message" .= ("Could not find foreign keys between these entities, No relation found between " <> parent <> " and " <> child :: Text)]
  toJSON UnsupportedVerb = JSON.object [
    "message" .= ("Unsupported HTTP verb" :: Text)]
+  toJSON InvalidFilters = JSON.object [
+    "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)]

 instance JSON.ToJSON P.UsageError where
  toJSON (P.ConnectionError e) = JSON.object [
@@ -275,7 +275,7 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls logicForest
    --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
    --posible relations are Child Parent Many
    getQueryParts _ _ = undefined
-requestToQuery schema _ (DbMutate (Insert mainTbl p@(PayloadJSON _ pType keys) _pkCols _onConflict returnings)) =
+requestToQuery schema _ (DbMutate (Insert mainTbl pkCols p@(PayloadJSON _ pType pKeys) onConflct logicForest returnings)) =
  unwords [
    ("WITH " <> ignoredBody) `emptyOnFalse` not payloadIsEmpty,
    "INSERT INTO ", fromQi qi, if payloadIsEmpty then " " else "(" <> cols <> ") ",
@@ -283,21 +283,23 @@ requestToQuery schema _ (DbMutate (Insert mainTbl p@(PayloadJSON _ pType keys) _
      (PJArray _, True) -> "SELECT null WHERE false"
      (PJObject, True)  -> "DEFAULT VALUES"
      _ -> unwords [
-        "SELECT " <> cols <> " FROM ",
+        "SELECT " <> cols <> " FROM",
        case pType of
          PJObject  -> "json_populate_record"
-          PJArray _ -> "json_populate_recordset", "(null::", fromQi qi, ", $1)"],
-    case _onConflict of
-      Just IgnoreDuplicates  -> "ON CONFLICT(" <> intercalate ", " _pkCols <> ") DO NOTHING "
-      Just MergeDuplicates -> "ON CONFLICT(" <> intercalate ", " _pkCols <> ") DO UPDATE SET " <>
-                               intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList (keys `S.difference` S.fromList _pkCols))
-
-      Nothing -> "",
-    ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings
-    ]
+          PJArray _ -> "json_populate_recordset", "(null::", fromQi qi, ", $1) _",
+        -- Only used for PUT
+        ("WHERE " <> intercalate " AND " (pgFmtLogicTree (QualifiedIdentifier "" "_") <$> logicForest)) `emptyOnFalse` null logicForest],
+    maybe "" (\x -> (
+      "ON CONFLICT(" <> intercalate ", " pkCols <> ") " <> case x of
+      IgnoreDuplicates ->
+        "DO NOTHING"
+      MergeDuplicates  ->
+        "DO UPDATE SET " <> intercalate ", " (pgFmtIdent <> const " = EXCLUDED." <> pgFmtIdent <$> S.toList pKeys)
+    ) `emptyOnFalse` null pkCols) onConflct,
+    ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnFalse` null returnings]
  where
    qi = QualifiedIdentifier schema mainTbl
-    cols = intercalate ", " $ pgFmtIdent <$> S.toList keys
+    cols = intercalate ", " $ pgFmtIdent <$> S.toList pKeys
    payloadIsEmpty = pjIsEmpty p
 requestToQuery schema _ (DbMutate (Update mainTbl p@(PayloadJSON _ pType keys) logicForest returnings)) =
  if pjIsEmpty p
@@ -23,6 +23,7 @@ data ApiRequestError = ActionInappropriate
                     | UnknownRelation
                     | NoRelationBetween Text Text
                     | UnsupportedVerb
+                     | InvalidFilters
                     deriving (Show, Eq)

 data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving (Eq, Show)
@@ -37,6 +38,14 @@ data DbStructure = DbStructure {
 , pgVersion     :: PgVersion
 } deriving (Show, Eq)

+-- TODO Table could hold references to all its Columns
+tableCols :: DbStructure -> Schema -> TableName -> [Column]
+tableCols dbs tSchema tName = filter (\Column{colTable=Table{tableSchema=s, tableName=t}} -> s==tSchema && t==tName) $ dbColumns dbs
+
+-- TODO Table could hold references to all its PrimaryKeys
+tablePKCols :: DbStructure -> Schema -> TableName -> [Text]
+tablePKCols dbs tSchema tName =  pkName <$> filter (\pk -> tSchema == (tableSchema . pkTable) pk && tName == (tableName . pkTable) pk) (dbPrimaryKeys dbs)
+
 data PgArg = PgArg {
  pgaName :: Text
 , pgaType :: Text
@@ -264,7 +273,7 @@ type EmbedPath = [Text]
 data Filter = Filter { field::Field, opExpr::OpExpr } deriving (Show, Eq)

 data ReadQuery = Select { select::[SelectItem], from::[TableName], where_::[LogicTree], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
-data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, pkCols::[Text], onConflict:: Maybe PreferResolution, returning::[FieldName] }
+data MutateQuery = Insert { in_::TableName, insPkCols::[Text], qPayload::PayloadJSON, onConflict:: Maybe PreferResolution, where_::[LogicTree], returning::[FieldName] }
                 | Delete { in_::TableName, where_::[LogicTree], returning::[FieldName] }
                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[LogicTree], returning::[FieldName] } deriving (Show, Eq)
 type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias, Maybe RelationDetail))