WPB-23434: Support SCIM PATCH of multi-valued emails attribute

changelog.d/3-bug-fixes/WPB-23434

@@ -0,0 +1,4 @@
+SCIM PATCH now supports the `emails` multi-valued attribute (e.g. Entra's
+`emails[type eq "work"].value`), so user emails can be updated via SCIM. Identity
+providers that previously hit a `can not lens into multi-valued attributes yet`
+error when provisioning emails now succeed.

libs/hscim/src/Web/Scim/Schema/User.hs

@@ -77,19 +77,30 @@ import Data.Aeson
 import qualified Data.Aeson.Key as Key
 import qualified Data.Aeson.KeyMap as KeyMap
 import Data.List ((\\))
+import Data.Maybe (fromMaybe)
 import Data.Text (Text, pack)
 import qualified Data.Text as Text
+import Data.Text.Encoding (decodeUtf8)
 import GHC.Generics (Generic)
 import Lens.Micro
+import qualified Text.Email.Validate as EmailValidate
 import Web.Scim.AttrName
-import Web.Scim.Filter (AttrPath (..))
+import Web.Scim.Filter
+  ( AttrPath (..),
+    CompValue (..),
+    CompareOp (..),
+    Filter (..),
+    SubAttr (..),
+    ValuePath (..),
+    compareStr,
+  )
 import Web.Scim.Schema.Common
 import Web.Scim.Schema.Error
 import Web.Scim.Schema.PatchOp
 import Web.Scim.Schema.Schema (Schema (..), getSchemaUri)
 import Web.Scim.Schema.User.Address (Address)
 import Web.Scim.Schema.User.Certificate (Certificate)
-import Web.Scim.Schema.User.Email (Email)
+import Web.Scim.Schema.User.Email (Email (Email, primary, typ), EmailAddress (..))
 import Web.Scim.Schema.User.IM (IM)
 import Web.Scim.Schema.User.Name (Name)
 import Web.Scim.Schema.User.Phone (Phone)
@@ -319,8 +330,16 @@ applyUserOperation user (Operation Replace (Just (NormalPath (AttrPath _schema a
     "roles" ->
       (\x -> user {roles = x}) <$> resultToScimError (fromJSON value)
     _ -> throwError (badRequest InvalidPath (Just "we only support attributes username, displayname, externalid, active, roles"))
-applyUserOperation _ (Operation Replace (Just (IntoValuePath _ _)) _) = do
-  throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet"))
+applyUserOperation user (Operation Replace (Just (IntoValuePath vp mSub)) (Just val)) =
+  case vp of
+    ValuePath (AttrPath _ attr _) _
+      | attr == "emails" -> replaceEmailsValuePath user vp mSub val
+      | otherwise ->
+          throwError
+            ( badRequest
+                InvalidPath
+                (Just "multi-valued PATCH is only supported for 'emails'")
+            )
 applyUserOperation user (Operation Replace Nothing (Just value)) = do
   case value of
     Object hm | null ((AttrName . Key.toText <$> KeyMap.keys hm) \\ ["username", "displayname", "externalid", "active", "roles"]) -> do
@@ -344,8 +363,154 @@ applyUserOperation user (Operation Remove (Just (NormalPath (AttrPath _schema at
     "active" -> pure $ user {active = Nothing}
     "roles" -> pure $ user {roles = []}
     _ -> pure user
-applyUserOperation _ (Operation Remove (Just (IntoValuePath _ _)) _) = do
-  throwError (badRequest InvalidPath (Just "can not lens into multi-valued attributes yet"))
+applyUserOperation user (Operation Remove (Just (IntoValuePath vp _mSub)) _) =
+  case vp of
+    ValuePath (AttrPath _ attr _) _
+      | attr == "emails" -> pure user {emails = removeMatchingEmails vp (emails user)}
+      | otherwise ->
+          throwError
+            ( badRequest
+                InvalidPath
+                (Just "multi-valued PATCH is only supported for 'emails'")
+            )
+
+----------------------------------------------------------------------------
+-- Multi-valued 'emails' value-path PATCH
+--
+-- Previously any value-path target (e.g. @emails[type eq "work"].value@) was
+-- rejected with "can not lens into multi-valued attributes yet". We now support
+-- value-path PATCH for the @emails@ attribute only -- the single multi-valued
+-- attribute that Spar persists. Other multi-valued attributes
+-- (@phoneNumbers@, @ims@, ...) remain unsupported and still fail as before.
+--
+-- NOTE on "create on absent": RFC 7644 §3.5.2.3 says a @Replace@ value-path
+-- that matches nothing is a no-op. Entra, however, emits an @Add@ (rewritten to
+-- @Replace@ in 'applyUserOperation') against @emails[type eq "work"].value@ to
+-- provision the address, expecting the entry to be created if absent. Every
+-- mainstream SCIM client/validator expects this create-on-absent behaviour for
+-- the email value-path, so we deviate from the RFC here: when the filter is
+-- @type eq <s>@ and no entry matches, we append
+-- @Email { typ = Just s, value = newVal, primary = Nothing }@.
+
+-- | The 'Filter' embedded in a 'ValuePath'.
+valuePathFilter :: ValuePath -> Filter
+valuePathFilter (ValuePath _ flt) = flt
+
+-- | Textual form of an 'Email' address, for string comparison.
+emailValueText :: Email -> Text
+emailValueText (Email _ addr _) =
+  decodeUtf8 (EmailValidate.toByteString (unEmailAddress addr))
+
+-- | Does this 'Email' satisfy the given single-attribute 'Filter'? Supports the
+-- sub-attributes Entra and the spec use: @type@, @value@, @primary@. Any
+-- operator in 'compareStr's domain works for @type@\/@value@; @primary@ only
+-- supports @eq@\/@ne@. Unknown sub-attributes or a mismatched 'CompValue' type
+-- mean "no match".
+emailMatches :: Filter -> Email -> Bool
+emailMatches (FilterAttrCompare (AttrPath _ attr _) op cval) email
+  | attr == "type" = case cval of
+      ValString s -> compareStr op (fromMaybe "" (typ email)) s
+      _ -> False
+  | attr == "value" = case cval of
+      ValString s -> compareStr op (emailValueText email) s
+      _ -> False
+  | attr == "primary" = case cval of
+      ValBool b -> primaryMatches op b (primary email)
+      _ -> False
+  | otherwise = False
+
+-- | Compare a @primary@ filter value. Only @eq@\/@ne@ are meaningful.
+primaryMatches :: CompareOp -> Bool -> Maybe ScimBool -> Bool
+primaryMatches op b mp = case op of
+  OpEq -> mp == Just (ScimBool b)
+  OpNe -> mp /= Just (ScimBool b)
+  _ -> False
+
+-- | If the filter is @type eq <s>@, return @Just s@; otherwise 'Nothing'.
+-- Drives create-on-absent for the @.value@ sub-attribute (see note above).
+filterTypeEq :: Filter -> Maybe Text
+filterTypeEq (FilterAttrCompare (AttrPath _ attr _) OpEq (ValString s))
+  | attr == "type" = Just s
+filterTypeEq _ = Nothing
+
+-- | Apply an update to each matching email. Never creates new entries.
+setEmailField :: Filter -> (Email -> Email) -> [Email] -> [Email]
+setEmailField flt update = map (\e -> if emailMatches flt e then update e else e)
+
+-- | Set the address of an 'Email'. Uses positional construction to avoid the
+-- bare 'value' selector, which is ambiguous (shared by 'Email', 'WithId' and
+-- 'Operation').
+setEmailAddress :: EmailAddress -> Email -> Email
+setEmailAddress newAddr (Email t _ p) = Email t newAddr p
+
+-- | Replace the @.value@ of every matching email. When nothing matches and the
+-- filter is @type eq <s>@, append a new entry (create-on-absent; see note).
+replaceEmailValue :: Filter -> EmailAddress -> [Email] -> [Email]
+replaceEmailValue flt newAddr es
+  | any (emailMatches flt) es = setEmailField flt (setEmailAddress newAddr) es
+  | otherwise =
+      case filterTypeEq flt of
+        Just t -> es <> [Email (Just t) newAddr Nothing]
+        Nothing -> es
+
+-- | Replace each whole matching email with a new one; append if none match.
+--
+-- NOTE: every entry that matches the filter is overwritten with the same
+-- @newEmail@, so a filter matching several entries (e.g. two with
+-- @type eq "work"@, which Spar does not prevent) collapses them into
+-- duplicates. In practice each @type@ has at most one entry (the only mapping
+-- Entra uses), so this does not arise.
+replaceEmailEntry :: Filter -> Email -> [Email] -> [Email]
+replaceEmailEntry flt newEmail es
+  | any (emailMatches flt) es = setEmailField flt (const newEmail) es
+  | otherwise = es <> [newEmail]
+
+-- | Decode the operation value as one or more emails. A bare object is treated
+-- as a single-element list; an array is decoded as-is.
+decodeEmails :: (MonadError ScimError m) => Value -> m [Email]
+decodeEmails val = case fromJSON val of
+  Success (es' :: [Email]) -> pure es'
+  _ -> (: []) <$> resultToScimError (fromJSON val)
+
+-- | Handle a @Replace@ on an @emails[...]@ value-path.
+replaceEmailsValuePath ::
+  (MonadError ScimError m) =>
+  User tag ->
+  ValuePath ->
+  Maybe SubAttr ->
+  Value ->
+  m (User tag)
+replaceEmailsValuePath user vp mSub val =
+  let flt = valuePathFilter vp
+      es = emails user
+   in case mSub of
+        Just (SubAttr sub)
+          | sub == "value" -> do
+              newAddr <- resultToScimError (fromJSON val)
+              pure user {emails = replaceEmailValue flt newAddr es}
+          | sub == "type" -> do
+              t <- resultToScimError (fromJSON val)
+              pure user {emails = setEmailField flt (\e -> e {typ = Just t}) es}
+          | sub == "primary" -> do
+              b <- resultToScimError (fromJSON val)
+              pure user {emails = setEmailField flt (\e -> e {primary = Just b}) es}
+          | otherwise ->
+              throwError
+                ( badRequest
+                    InvalidPath
+                    (Just "only the 'value', 'type' and 'primary' sub-attributes of 'emails' can be patched")
+                )
+        Nothing -> do
+          newEmails <- decodeEmails val
+          pure user {emails = foldr (replaceEmailEntry flt) es newEmails}
+
+-- | Drop every email matching the value-path filter (used by @Remove@).
+--
+-- NOTE: a sub-attribute on the path (e.g. @emails[type eq "work"].value@) is
+-- ignored -- @Remove@ always drops the whole matching entry. (Clearing just the
+-- @.value@ is infeasible anyway, since 'Email.value' is non-nullable.)
+removeMatchingEmails :: ValuePath -> [Email] -> [Email]
+removeMatchingEmails vp = filter (not . emailMatches (valuePathFilter vp))
 
 instance (UserTypes tag, FromJSON (User tag), Patchable (UserExtra tag)) => Patchable (User tag) where
   applyOperation user op@(Operation _ (Just (NormalPath (AttrPath schema _ _))) _)

libs/hscim/test/Test/Class/UserSpec.hs

@@ -328,6 +328,33 @@ spec = with app $ do
           }]}|]
           `shouldRespondWith` 400
         get "/0" `shouldRespondWith` smallUserGet {matchStatus = 200}
+      it "patches a multi-valued 'emails' value-path end-to-end" $ do
+        post "/" newBarbara `shouldRespondWith` 201
+        _ <- put "/0" smallUser
+        patch
+          "/0"
+          [scim|{
+            "schemas": ["urn:ietf:params:scim:api:messages:2.0:PatchOp"],
+            "Operations": [{
+              "op": "Replace",
+              "path": "emails[type eq \"work\"].value",
+              "value": "x@y.com"
+            }]
+          }|]
+          `shouldRespondWith` [scim|{
+            "schemas": ["urn:ietf:params:scim:schemas:core:2.0:User"],
+            "userName": "bjensen",
+            "displayName": "bjensen2",
+            "emails": [{"value":"x@y.com","type":"work"}],
+            "id": "0",
+            "meta": {
+              "resourceType": "User",
+              "location": "https://example.com/Users/id",
+              "created": "2018-01-01T00:00:00Z",
+              "version": "W/\"testVersion\"",
+              "lastModified": "2018-01-01T00:00:00Z"
+            }
+          }|]
     describe "Remove" $ do
       it "fails if no target" $ do
         post "/" newBarbara `shouldRespondWith` 201

libs/hscim/test/Test/Schema/UserSpec.hs

@@ -150,6 +150,85 @@ spec = do
       let operation = Operation Replace (Just programmingLanguagePath) (Just (toJSON @Text "haskell"))
       let patchOp = PatchOp [operation]
       User.extra <$> User.applyPatch user patchOp `shouldBe` Right (KeyMap.singleton "programmingLanguage" "haskell")
+  describe "applyPatch (emails value-path)" $ do
+    let mkEmail typ' raw = case validate raw of
+          Right a -> Email.Email (Just typ') (Email.EmailAddress a) Nothing
+          Left _ -> error $ "invalid email in test: " <> show raw
+        mkEmailPrimary typ' raw b = case validate raw of
+          Right a -> Email.Email (Just typ') (Email.EmailAddress a) (Just (ScimBool b))
+          Left _ -> error $ "invalid email in test: " <> show raw
+        mkUser :: [Email.Email] -> User PatchTag
+        mkUser es = (User.empty [] "hello" KeyMap.empty :: User PatchTag) {emails = es}
+        emailValuePath = PatchOp.parsePath (User.supportedSchemas @PatchTag) "emails[type eq \"work\"].value"
+    it "creates a work email when none matches (Entra payload)" $ do
+      let Right p = emailValuePath
+          operation = Operation Replace (Just p) (Just (String "x@y.com"))
+          result = User.applyPatch (mkUser []) (PatchOp [operation])
+      result `shouldSatisfy` isRight
+      let Right patched = result
+      emails patched `shouldBe` [mkEmail "work" "x@y.com"]
+    it "updates an existing matching email's value" $ do
+      let Right p = emailValuePath
+          operation = Operation Replace (Just p) (Just (String "new@example.com"))
+          result = User.applyPatch (mkUser [mkEmail "work" "old@example.com"]) (PatchOp [operation])
+      result `shouldSatisfy` isRight
+      let Right patched = result
+      length (emails patched) `shouldBe` 1
+      emails patched `shouldBe` [mkEmail "work" "new@example.com"]
+    it "fails when no value is provided" $ do
+      let Right p = emailValuePath
+          operation = Operation Replace (Just p) Nothing
+          result = User.applyPatch (mkUser []) (PatchOp [operation])
+      result `shouldSatisfy` isLeft
+    it "removes the whole matching email entry" $ do
+      let Right p = PatchOp.parsePath (User.supportedSchemas @PatchTag) "emails[type eq \"work\"]"
+          operation = Operation Remove (Just p) Nothing
+          result = User.applyPatch (mkUser [mkEmail "work" "w@example.com", mkEmail "home" "h@example.com"]) (PatchOp [operation])
+      result `shouldSatisfy` isRight
+      let Right patched = result
+      emails patched `shouldBe` [mkEmail "home" "h@example.com"]
+    it "is case-insensitive in the path" $ do
+      let Right p = PatchOp.parsePath (User.supportedSchemas @PatchTag) "EMAILS[TYPE EQ \"work\"].VALUE"
+          operation = Operation Replace (Just p) (Just (String "ci@example.com"))
+          result = User.applyPatch (mkUser []) (PatchOp [operation])
+      result `shouldSatisfy` isRight
+      let Right patched = result
+      emails patched `shouldBe` [mkEmail "work" "ci@example.com"]
+    it "still rejects unsupported multi-valued attributes" $ do
+      let Right p = PatchOp.parsePath (User.supportedSchemas @PatchTag) "phoneNumbers[type eq \"x\"].value"
+          operation = Operation Replace (Just p) (Just (String "+15555550100"))
+          result = User.applyPatch (mkUser []) (PatchOp [operation])
+      result `shouldSatisfy` isLeft
+    it "updates the 'type' sub-attribute of matching emails" $ do
+      let Right p = PatchOp.parsePath (User.supportedSchemas @PatchTag) "emails[type eq \"work\"].type"
+          operation = Operation Replace (Just p) (Just (String "custom"))
+          result = User.applyPatch (mkUser [mkEmail "work" "a@example.com"]) (PatchOp [operation])
+      result `shouldSatisfy` isRight
+      let Right patched = result
+      emails patched `shouldBe` [mkEmail "custom" "a@example.com"]
+    it "updates the 'primary' sub-attribute of matching emails" $ do
+      let Right p = PatchOp.parsePath (User.supportedSchemas @PatchTag) "emails[type eq \"work\"].primary"
+          operation = Operation Replace (Just p) (Just (Bool True))
+          result = User.applyPatch (mkUser [mkEmail "work" "a@example.com"]) (PatchOp [operation])
+      result `shouldSatisfy` isRight
+      let Right patched = result
+      emails patched `shouldBe` [mkEmailPrimary "work" "a@example.com" True]
+    it "replaces a whole matching email entry from an object value" $ do
+      let Right p = PatchOp.parsePath (User.supportedSchemas @PatchTag) "emails[type eq \"work\"]"
+          newVal = object ["value" .= String "new@example.com", "type" .= String "work"]
+          operation = Operation Replace (Just p) (Just newVal)
+          result = User.applyPatch (mkUser [mkEmail "work" "old@example.com"]) (PatchOp [operation])
+      result `shouldSatisfy` isRight
+      let Right patched = result
+      emails patched `shouldBe` [mkEmail "work" "new@example.com"]
+    it "replaces a whole matching email entry from an array value" $ do
+      let Right p = PatchOp.parsePath (User.supportedSchemas @PatchTag) "emails[type eq \"work\"]"
+          newVal = toJSON [object ["value" .= String "arr@example.com", "type" .= String "work"]]
+          operation = Operation Replace (Just p) (Just newVal)
+          result = User.applyPatch (mkUser [mkEmail "work" "old@example.com"]) (PatchOp [operation])
+      result `shouldSatisfy` isRight
+      let Right patched = result
+      emails patched `shouldBe` [mkEmail "work" "arr@example.com"]
   describe "JSON serialization" $ do
     it "handles all fields" $ do
       require prop_roundtrip

services/spar/src/Spar/Scim/User.hs

@@ -688,6 +688,17 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu =
             when (oldValidScimUser.externalId /= newValidScimUser.externalId) $
               updateVsuUref stiTeam uid (oldValidScimUser.externalId) (newValidScimUser.externalId)
 
+            -- An email-only change does not alter the externalId, so
+            -- 'updateVsuUref' (above, which only runs on an externalId change)
+            -- would not propagate the new email to Brig. Validate it here in
+            -- that case; when the externalId changes too, 'updateVsuUref' has
+            -- already validated the email, so we skip it here to avoid a
+            -- duplicate call.
+            when
+              ( oldValidScimUser.externalId == newValidScimUser.externalId
+                  && vsUserEmail oldValidScimUser /= vsUserEmail newValidScimUser
+              )
+              $ forM_ (vsUserEmail newValidScimUser) (Spar.App.validateEmail (Just stiTeam) uid)
             when (newValidScimUser.name /= oldValidScimUser.name) $
               BrigAPIAccess.setName uid (newValidScimUser.name)
 

services/spar/test-integration/Test/Spar/Scim/UserSpec.hs

@@ -2089,6 +2089,30 @@ specPatchUser = do
             [replaceAttrib "externalId" externalId]
       let user'' = Scim.value . Scim.thing $ storedUser'
       liftIO $ Scim.User.externalId user'' `shouldBe` externalId
+    it "can update a user's email via the multi-valued 'emails' value-path" $ do
+      (tok, (_, tid, _idp)) <- registerIdPAndScimToken
+      -- Disable email verification so the patched email is activated directly,
+      -- without a separate activation step.
+      setSamlEmailValidation tid Feature.FeatureStatusDisabled
+      newEmail <- randomEmail
+      user <- randomScimUser
+      storedUser <- createUser tok user
+      let userid = scimUserId storedUser
+      let Right p = PatchOp.parsePath userSchemas "emails[type eq \"work\"].value"
+          operation =
+            PatchOp.Operation
+              PatchOp.Replace
+              (Just p)
+              (Just (toJSON (fromEmail newEmail)))
+      _ <- patchUser tok userid (PatchOp.PatchOp [operation])
+      -- the email propagated all the way to Brig and is reflected on a fresh GET
+      eventually $ do
+        storedUser'' <- getUser tok userid
+        liftIO $
+          Scim.Email.scimEmailsToEmailAddress
+            (Scim.User.emails (Scim.value (Scim.thing storedUser'')))
+            `shouldBe` Just newEmail
+        checkEmail userid (Just newEmail)
     it "replace role works" $ testPatchRole replaceAttrib
     it "add role works" $ testPatchRole addAttrib
     it "replace with invalid input should fail" $ testPatchIvalidInput replaceAttrib