diff --git a/changelog.d/3-bug-fixes/WPB-23434 b/changelog.d/3-bug-fixes/WPB-23434 new file mode 100644 index 00000000000..626855dbce1 --- /dev/null +++ b/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. diff --git a/changelog.d/3-bug-fixes/WPB-23434-email-type b/changelog.d/3-bug-fixes/WPB-23434-email-type new file mode 100644 index 00000000000..7f37a87feae --- /dev/null +++ b/changelog.d/3-bug-fixes/WPB-23434-email-type @@ -0,0 +1,5 @@ +SCIM now echoes the canonical email `type` of `"work"` on stored user emails, so +that PATCH value-path filters like Entra's `emails[type eq "work"].value` match +the existing entry for an in-place update. Previously spar synthesized emails +with no `type`, the filter never matched, and every such PATCH appended a +duplicate email instead of updating the address in place. diff --git a/changelog.d/3-bug-fixes/WPB-23434-multi-primary b/changelog.d/3-bug-fixes/WPB-23434-multi-primary new file mode 100644 index 00000000000..737c51773e1 --- /dev/null +++ b/changelog.d/3-bug-fixes/WPB-23434-multi-primary @@ -0,0 +1,4 @@ +SCIM user provisioning now rejects requests (HTTP 400) that mark more than one +email as `primary`, an RFC 7643 §2.4 violation. Previously spar silently picked +one primary and dropped the rest, masking client-side misconfiguration. Requests +with zero or one primary email are unchanged. diff --git a/integration/test/API/Spar.hs b/integration/test/API/Spar.hs index b679e437256..003ca6afb49 100644 --- a/integration/test/API/Spar.hs +++ b/integration/test/API/Spar.hs @@ -112,6 +112,20 @@ updateScimUser domain scimToken userId scimUser = do & scimCommonHeaders scimToken & addJSON body +patchScimUser :: + (HasCallStack, MakesValue domain, MakesValue patchOp) => + domain -> + String -> + String -> + patchOp -> + App Response +patchScimUser domain scimToken userId patchOp = do + req <- baseRequest domain Spar Versioned $ joinHttpPath ["scim", "v2", "Users", userId] + body <- make patchOp + submit "PATCH" $ req + & scimCommonHeaders scimToken + & addJSON body + createScimUserGroup :: (HasCallStack, MakesValue domain, MakesValue scimUserGroup) => domain -> String -> scimUserGroup -> App Response createScimUserGroup domain token scimUserGroup = do req <- baseRequest domain Spar Versioned "/scim/v2/Groups" diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index fff111393d5..4cb424d9524 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -195,6 +195,109 @@ testSparExternalIdDifferentFromEmailWithIdp = do subject <- u %. "sso_id.subject" >>= asString subject `shouldContainString` currentExtId +testSparPatchEmailValuePath :: (HasCallStack) => App () +testSparPatchEmailValuePath = do + (owner, tid, _) <- createTeam OwnDomain 1 + void $ setTeamFeatureStatus owner tid "sso" "enabled" + void $ registerTestIdPWithMeta owner >>= getJSON 201 + -- Disable SAML email validation so the provisioned email is activated + -- directly (the IdP vouches for it), with no separate activation step. + void $ setTeamFeatureStatus owner tid "validateSAMLemails" "disabled" + tok <- createScimTokenV6 owner def >>= getJSON 200 >>= (%. "token") >>= asString + extId <- randomExternalId + -- Exercise create-on-absent: a SAML user provisioned with no email receives + -- its first work email via Entra's @Add@ on @emails[type eq "work"].value@. + -- spar echoes @type = "work"@ on stored emails (see 'synthesizeScimUser'), but + -- this user has no email yet, so the value-path filter matches nothing and the + -- entry is created. In-place update of an existing email is covered by + -- 'testSparPatchEmailValuePathInPlace'. + scimUser <- randomScimUserWith def {mkExternalId = pure extId} >>= removeField "emails" + userId <- createScimUser OwnDomain tok scimUser >>= getJSON 201 >>= (%. "id") >>= asString + newEmail <- randomEmail + let patchOp = + object + [ "schemas" .= (["urn:ietf:params:scim:api:messages:2.0:PatchOp" :: String]), + "Operations" + .= [ object + [ "op" .= ("Add" :: String), + "path" .= ("emails[type eq \"work\"].value" :: String), + "value" .= newEmail + ] + ] + ] + bindResponse (patchScimUser OwnDomain tok userId patchOp) $ \res -> do + res.status `shouldMatchInt` 200 + -- The provisioned email propagates end-to-end: SCIM GET reflects it and, + -- with validation disabled, it is active in Brig. + eventually $ do + checkSparGetUserAndFindByExtId OwnDomain tok extId userId $ \u -> do + (u %. "emails" >>= asList >>= assertOne >>= (%. "value")) `shouldMatch` newEmail + bindResponse (getUsersId OwnDomain [userId]) $ \res -> do + res.status `shouldMatchInt` 200 + u <- res.json & asList >>= assertOne + u %. "email" `shouldMatch` newEmail + +testSparPatchEmailValuePathInPlace :: (HasCallStack) => App () +testSparPatchEmailValuePathInPlace = do + (owner, tid, _) <- createTeam OwnDomain 1 + void $ setTeamFeatureStatus owner tid "sso" "enabled" + void $ registerTestIdPWithMeta owner >>= getJSON 201 + -- Disable SAML email validation so the updated email is activated directly + -- (the IdP vouches for it), with no separate activation step. + void $ setTeamFeatureStatus owner tid "validateSAMLemails" "disabled" + tok <- createScimTokenV6 owner def >>= getJSON 200 >>= (%. "token") >>= asString + extId <- randomExternalId + email <- randomEmail + scimUser <- randomScimUserWithEmail extId email + userId <- createScimUser OwnDomain tok scimUser >>= getJSON 201 >>= (%. "id") >>= asString + newEmail <- randomEmail + let patchOp = + object + [ "schemas" .= (["urn:ietf:params:scim:api:messages:2.0:PatchOp" :: String]), + "Operations" + .= [ object + [ "op" .= ("Add" :: String), + "path" .= ("emails[type eq \"work\"].value" :: String), + "value" .= newEmail + ] + ] + ] + bindResponse (patchScimUser OwnDomain tok userId patchOp) $ \res -> do + res.status `shouldMatchInt` 200 + -- In-place update (not create-on-absent): spar echoes @type = "work"@ on + -- stored emails (see 'synthesizeScimUser'), so the value-path filter + -- @emails[type eq "work"]@ matches the existing entry and updates its + -- @.value@. The proof is the new value and echoed @type = "work"@ below -- a + -- create-on-absent append would be collapsed back to the OLD address by + -- 'scimEmailsToEmailAddress', failing the value assertion. + eventually $ do + checkSparGetUserAndFindByExtId OwnDomain tok extId userId $ \u -> do + storedEmail <- u %. "emails" >>= asList >>= assertOne + storedEmail %. "value" `shouldMatch` newEmail + storedEmail %. "type" `shouldMatch` ("work" :: String) + bindResponse (getUsersId OwnDomain [userId]) $ \res -> do + res.status `shouldMatchInt` 200 + u <- res.json & asList >>= assertOne + u %. "email" `shouldMatch` newEmail + +testSparRejectsMultiplePrimaryEmails :: (HasCallStack) => App () +testSparRejectsMultiplePrimaryEmails = do + (owner, _tid, _) <- createTeam OwnDomain 1 + tok <- createScimTokenV6 owner def >>= getJSON 200 >>= (%. "token") >>= asString + email1 <- randomEmail + email2 <- randomEmail + scimUser <- + randomScimUserWith def + >>= setField + "emails" + ( toJSON + [ object ["value" .= email1, "primary" .= True], + object ["value" .= email2, "primary" .= True] + ] + ) + bindResponse (createScimUser OwnDomain tok scimUser) $ \res -> + res.status `shouldMatchInt` 400 + testSparExternalIdDifferentFromEmail :: (HasCallStack) => App () testSparExternalIdDifferentFromEmail = do (owner, tid, _) <- createTeam OwnDomain 1 @@ -318,11 +421,11 @@ testSparMigrateFromExternalIdOnlyToEmail (MkTagged emailUnchanged) = do -- Verify that updating a user with an empty emails does not change the email bindResponse (updateScimUser OwnDomain tok userId scimUser) $ \resp -> do - resp.json %. "emails" `shouldMatch` (toJSON [object ["value" .= email]]) + resp.json %. "emails" `shouldMatch` (toJSON [scimWorkEmail email]) resp.status `shouldMatchInt` 200 newEmail <- if emailUnchanged then pure email else randomEmail - let newEmails = (toJSON [object ["value" .= newEmail]]) + let newEmails = toJSON [scimWorkEmail newEmail] updatedScimUser <- setField "emails" newEmails scimUser updateScimUser OwnDomain tok userId updatedScimUser `bindResponse` \resp -> do resp.status `shouldMatchInt` 200 @@ -354,6 +457,12 @@ checkSparGetUserAndFindByExtId domain tok extId uid k = do userByUid `shouldMatch` userByIdExtId +-- | Expected SCIM email object. spar synthesizes @type = "work"@ on every stored +-- email (see 'Spar.Scim.User.synthesizeScimUser'), so assertions comparing the +-- server's @emails@ must expect it. +scimWorkEmail :: String -> Value +scimWorkEmail addr = object ["type" .= ("work" :: String), "value" .= addr] + testSparScimTokenLimit :: (HasCallStack) => App () testSparScimTokenLimit = withModifiedBackend def @@ -1039,7 +1148,7 @@ testScimUpdateEmailAddress (TaggedBool extIdIsEmail) (TaggedBool requireExternal res.json %. "id" `shouldMatch` uid lookupField res.json "emails" `shouldMatch` ( if extIdIsEmail - then Just [object ["value" .= oldEmail]] + then Just [scimWorkEmail oldEmail] else Nothing ) @@ -1058,11 +1167,11 @@ testScimUpdateEmailAddress (TaggedBool extIdIsEmail) (TaggedBool requireExternal updateScimUser OwnDomain tok uid newScimUser `bindResponse` \res -> do res.status `shouldMatchInt` 200 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail] getScimUser OwnDomain tok uid `bindResponse` \res -> do res.status `shouldMatchInt` 200 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail] when requireExternalEmailVerification $ do getUsersId OwnDomain [uid] `bindResponse` \res -> do @@ -1126,7 +1235,7 @@ testScimUpdateEmailAddressAndExternalId = do getScimUser OwnDomain tok brigUserId `bindResponse` \res -> do res.status `shouldMatchInt` 200 res.json %. "id" `shouldMatch` brigUserId - res.json %. "emails" `shouldMatch` [object ["value" .= extId1]] + res.json %. "emails" `shouldMatch` [scimWorkEmail extId1] findUsersByExternalId OwnDomain tok extId1 `bindResponse` \res -> do res.status `shouldMatchInt` 200 @@ -1149,11 +1258,11 @@ testScimUpdateEmailAddressAndExternalId = do updateScimUser OwnDomain tok brigUserId newScimUser1 `bindResponse` \res -> do res.status `shouldMatchInt` 200 res.json %. "externalId" `shouldMatch` extId1 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail1]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail1] getScimUser OwnDomain tok brigUserId `bindResponse` \res -> do res.status `shouldMatchInt` 200 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail1]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail1] findUsersByExternalId OwnDomain tok extId1 `bindResponse` \res -> do res.status `shouldMatchInt` 200 @@ -1182,11 +1291,11 @@ testScimUpdateEmailAddressAndExternalId = do updateScimUser OwnDomain tok brigUserId newScimUser2 `bindResponse` \res -> do res.status `shouldMatchInt` 200 res.json %. "externalId" `shouldMatch` newExtId2 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail1]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail1] getScimUser OwnDomain tok brigUserId `bindResponse` \res -> do res.status `shouldMatchInt` 200 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail1]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail1] findUsersByExternalId OwnDomain tok newExtId2 `bindResponse` \res -> do res.status `shouldMatchInt` 200 @@ -1215,11 +1324,11 @@ testScimUpdateEmailAddressAndExternalId = do updateScimUser OwnDomain tok brigUserId newScimUser3 `bindResponse` \res -> do res.status `shouldMatchInt` 200 res.json %. "externalId" `shouldMatch` newEmail3 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail1]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail1] getScimUser OwnDomain tok brigUserId `bindResponse` \res -> do res.status `shouldMatchInt` 200 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail1]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail1] findUsersByExternalId OwnDomain tok newEmail3 `bindResponse` \res -> do res.status `shouldMatchInt` 200 @@ -1431,7 +1540,7 @@ testAllowUpdatesBySCIMWhenE2EIdEnabled (TaggedBool ssoEnabled) = do su <- setField "emails" [object ["value" .= newEmail]] scimUser bindResponse (updateScimUser OwnDomain tok uid su) $ \res -> do res.status `shouldMatchInt` 200 - res.json %. "emails" `shouldMatch` [object ["value" .= newEmail]] + res.json %. "emails" `shouldMatch` [scimWorkEmail newEmail] activateEmail OwnDomain newEmail bindResponse (getUsersId OwnDomain [uid]) $ \res -> do res.status `shouldMatchInt` 200 diff --git a/libs/hscim/src/Web/Scim/Filter.hs b/libs/hscim/src/Web/Scim/Filter.hs index 5862f6a36bf..e9947556689 100644 --- a/libs/hscim/src/Web/Scim/Filter.hs +++ b/libs/hscim/src/Web/Scim/Filter.hs @@ -128,7 +128,10 @@ data Filter -- TODO(arianvp): This is a slight simplification at the moment as we -- don't support the complete Filter grammar. This should be a -- valFilter, not a FILTER. -data ValuePath = ValuePath AttrPath Filter +data ValuePath = ValuePath + { valuePathAttrPath :: AttrPath, + valuePathFilter :: Filter + } deriving (Eq, Show) -- | subAttr = "." ATTRNAME diff --git a/libs/hscim/src/Web/Scim/Schema/User.hs b/libs/hscim/src/Web/Scim/Schema/User.hs index 1a37f6dae60..93ccaa4d718 100644 --- a/libs/hscim/src/Web/Scim/Schema/User.hs +++ b/libs/hscim/src/Web/Scim/Schema/User.hs @@ -54,6 +54,12 @@ -- and all the others are either implied 'primary: false' or must be checked -- that they're false -- +-- (Partially addressed for @emails@: at most one @primary: true@ entry is +-- now enforced at selection time in +-- "Web.Scim.Schema.User.Email".'Web.Scim.Schema.User.Email.scimEmailsToEmailAddress', +-- which rejects a multi-primary @emails@ list instead of silently picking +-- one. Other multi-valued attributes are not yet validated.) +-- -- -- == Attribute names -- @@ -77,19 +83,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) @@ -305,6 +322,24 @@ applyUserOperation :: User tag -> Operation -> m (User tag) +applyUserOperation user (Operation Add (Just (IntoValuePath vp mSub)) (Just val)) = + case vp of + ValuePath (AttrPath _ attr _) _ + | attr == "emails" -> addEmailsValuePath user vp mSub val + | otherwise -> + throwError + ( badRequest + InvalidPath + (Just "multi-valued PATCH is only supported for 'emails'") + ) +-- Catch-all: for single-valued 'NormalPath' attributes (username, displayname, +-- externalid, active) an @Add@ coincides with a @Replace@ (RFC 7644 §3.5.2.1: +-- a single-valued target has its value replaced). @roles@ is multi-valued +-- (@[Text]@), so the rewrite turns an RFC-mandated append into an overwrite -- +-- a known deviation, acceptable while no client relies on append semantics for +-- @roles@. Multi-valued value-path @Add@ is intercepted above; any future +-- complex or multi-valued attribute added to 'NormalPath' must not rely on +-- this rewrite. applyUserOperation user (Operation Add path value) = applyUserOperation user (Operation Replace path value) applyUserOperation user (Operation Replace (Just (NormalPath (AttrPath _schema attr _subAttr))) (Just value)) = case attr of @@ -319,8 +354,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 +387,176 @@ 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 value-path @Replace@ +-- that matches nothing is a no-op. Microsoft Entra ID, however, provisions the +-- email address with an @Add@ against @emails[type eq "work"].value@ (Entra uses +-- @Add@ for both insert and update -- see +-- ), +-- expecting the entry to be created if absent. Both 'addEmailsValuePath' and the +-- @Replace@ path therefore route the @.value@ sub-attribute through +-- 'replaceEmailValue', which deviates from the RFC: when the filter is +-- @type eq @ and no entry matches, it appends +-- @Email { typ = Just s, value = newVal, primary = Nothing }@. + +-- | 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 @, 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 @, 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 an @Add@ on an @emails[...]@ value-path. +-- +-- For the single-valued email sub-attributes (@.value@, @.type@, @.primary@) an +-- @Add@ coincides with a @Replace@ (RFC 7644 §3.5.2.3): it sets the +-- sub-attribute and, for @.value@, creates the entry on absent via +-- 'replaceEmailValue'. For a whole-entry @Add@ (no sub-attribute) the value-path +-- filter is intentionally ignored and the new entries are /appended/ rather than +-- overwriting matches -- the concat semantics that distinguish @Add@ from +-- @Replace@ for multi-valued attributes (where @Replace@ narrows the target set +-- via the filter). +addEmailsValuePath :: + (MonadError ScimError m) => + User tag -> + ValuePath -> + Maybe SubAttr -> + Value -> + m (User tag) +addEmailsValuePath user vp mSub val = + case mSub of + Just _ -> replaceEmailsValuePath user vp mSub val + Nothing -> do + newEmails <- decodeEmails val + pure user {emails = emails user <> newEmails} + +-- | 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 _ _))) _) diff --git a/libs/hscim/src/Web/Scim/Schema/User/Email.hs b/libs/hscim/src/Web/Scim/Schema/User/Email.hs index 0b8bf7e919b..79c0ecbc851 100644 --- a/libs/hscim/src/Web/Scim/Schema/User/Email.hs +++ b/libs/hscim/src/Web/Scim/Schema/User/Email.hs @@ -53,12 +53,27 @@ instance ToJSON Email where emailToEmailAddress :: Email -> Email.EmailAddress emailToEmailAddress = unEmailAddress . value -scimEmailsToEmailAddress :: [Email] -> Maybe Email.EmailAddress -scimEmailsToEmailAddress es = pickPrimary es <|> pickFirst es +-- | Reduce a list of SCIM emails to the single address Wire stores. +-- +-- Wire/brig holds at most one email per user, so the (possibly multi-valued) +-- SCIM @emails@ attribute must be reduced to one address. Selection rule: +-- the entry marked @primary@ (RFC 7643 §2.4: @primary@ value @true@ MUST +-- appear no more than once), else the first entry. Per RFC 7643 §2.4 an +-- absent @primary@ is assumed @false@; with none marked primary, Wire +-- deterministically picks the first entry (it must store exactly one email). +-- +-- If more than one entry is marked @primary@ — a client-side protocol +-- violation — this returns 'Left' with a descriptive message so the caller +-- rejects the request instead of silently picking one. +scimEmailsToEmailAddress :: [Email] -> Either Text (Maybe Email.EmailAddress) +scimEmailsToEmailAddress es + | Prelude.length primaries > 1 = + Left "More than one email is marked as primary; RFC 7643 §2.4 allows at most one." + | otherwise = Right (pickFirst primaries <|> pickFirst es) where + primaries = Prelude.filter isPrimary es + pickFirst [] = Nothing pickFirst (e : _) = Just (unEmailAddress (value e)) - pickPrimary = pickFirst . Prelude.filter isPrimary - isPrimary e = primary e == Just (ScimBool True) diff --git a/libs/hscim/test/Test/Class/UserSpec.hs b/libs/hscim/test/Test/Class/UserSpec.hs index 6a46738dccc..de1fd973efa 100644 --- a/libs/hscim/test/Test/Class/UserSpec.hs +++ b/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 diff --git a/libs/hscim/test/Test/Schema/UserSpec.hs b/libs/hscim/test/Test/Schema/UserSpec.hs index 1885060facc..ef2d7b16cbe 100644 --- a/libs/hscim/test/Test/Schema/UserSpec.hs +++ b/libs/hscim/test/Test/Schema/UserSpec.hs @@ -79,7 +79,7 @@ spec = do true = Just (ScimBool True) it "returns Nothing if empty" $ do - scimEmailsToEmailAddress [] `shouldBe` Nothing + scimEmailsToEmailAddress [] `shouldBe` Right Nothing it "returns first primary if it exists" $ do scimEmailsToEmailAddress @@ -87,19 +87,33 @@ spec = do Email Nothing (EmailAddress adr2) false2, Email (Just "this is ignored") (EmailAddress adr3) true ] - `shouldBe` Just adr3 + `shouldBe` Right (Just adr3) it "returns first entry if no primary exists" $ do scimEmailsToEmailAddress [ Email Nothing (EmailAddress adr1) false1, Email Nothing (EmailAddress adr2) false2 ] - `shouldBe` Just adr1 + `shouldBe` Right (Just adr1) scimEmailsToEmailAddress [ Email Nothing (EmailAddress adr1) false2, Email Nothing (EmailAddress adr2) false1 ] - `shouldBe` Just adr1 + `shouldBe` Right (Just adr1) + + it "rejects when more than one email is primary" $ do + scimEmailsToEmailAddress + [ Email Nothing (EmailAddress adr1) true, + Email Nothing (EmailAddress adr2) true + ] + `shouldBe` Left "More than one email is marked as primary; RFC 7643 §2.4 allows at most one." + + it "does not reject when one primary is true and another is false" $ do + scimEmailsToEmailAddress + [ Email Nothing (EmailAddress adr1) true, + Email Nothing (EmailAddress adr2) false2 + ] + `shouldBe` Right (Just adr1) describe "applyPatch" $ do it "only applies patch for supported fields" $ do @@ -150,6 +164,107 @@ 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 via Replace when none matches" $ 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"] + it "Add on .value updates an existing matching email" $ do + let Right p = emailValuePath + operation = Operation Add (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 + emails patched `shouldBe` [mkEmail "work" "new@example.com"] + it "Add on .value creates a work email when none matches" $ do + let Right p = emailValuePath + operation = Operation Add (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 "Add on a whole emails entry appends without overwriting" $ do + let Right p = PatchOp.parsePath (User.supportedSchemas @PatchTag) "emails[type eq \"work\"]" + newVal = object ["value" .= String "added@example.com", "type" .= String "work"] + operation = Operation Add (Just p) (Just newVal) + result = User.applyPatch (mkUser [mkEmail "work" "keep@example.com"]) (PatchOp [operation]) + result `shouldSatisfy` isRight + let Right patched = result + emails patched `shouldBe` [mkEmail "work" "keep@example.com", mkEmail "work" "added@example.com"] describe "JSON serialization" $ do it "handles all fields" $ do require prop_roundtrip diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index a8b54e2de02..616cb984351 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -302,7 +302,9 @@ validateScimUser' :: Sem r ST.ValidScimUser validateScimUser' errloc midp richInfoLimit user = do unless (isNothing $ Scim.password user) $ throw $ badRequest "Setting user passwords is not supported for security reasons." - veid <- mkValidScimId midp (Scim.externalId user) (Scim.Email.scimEmailsToEmailAddress $ Scim.emails user) + veid <- case Scim.Email.scimEmailsToEmailAddress (Scim.emails user) of + Left msg -> throw $ badRequest msg + Right mEmail -> mkValidScimId midp (Scim.externalId user) mEmail handl <- validateHandle . Text.toLower . Scim.userName $ user -- FUTUREWORK: 'Scim.userName' should be case insensitive; then the toLower here would -- be a little less brittle. @@ -688,6 +690,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) @@ -1092,7 +1105,13 @@ synthesizeScimUser info = . toByteString ) (info.role), - Scim.emails = (\e -> Scim.Email.Email Nothing (Scim.Email.EmailAddress e) Nothing) <$> info.emails + -- Echo the canonical SCIM email type "work" (RFC 7643 §4.1.2) so Entra's + -- value-path filter `emails[type eq "work"]` matches the stored entry for + -- an in-place PATCH update; without it the filter never matches and a + -- duplicate email is appended. spar/brig store one address with no type. + -- Do NOT change it back to `Nothing`. (Okta also filters `primary eq true`; + -- echoing `primary` is out of scope.) + Scim.emails = (\e -> Scim.Email.Email (Just "work") (Scim.Email.EmailAddress e) Nothing) <$> info.emails } -- TODO: now write a test, either in /integration or in spar, whichever is easier. (spar) diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index 315d798378c..ab717a95bfb 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -1068,7 +1068,7 @@ specCRUDIdentityProvider = do -- if the externalId is an email, and the email field was -- empty, the scim response from spar contains the externalId -- (parsed) in the emails field. - Just e -> u {Scim.emails = [Scim.Email Nothing (Scim.EmailAddress e) Nothing]} + Just e -> u {Scim.emails = [Scim.Email (Just "work") (Scim.EmailAddress e) Nothing]} Nothing -> u in -- don't compare meta, or you need to update the ETag in version because email may have changed. Scim.WithId i u' diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index 9f8d1b1c023..c8b3c2f2d33 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -728,7 +728,7 @@ setDefaultRoleAndEmailsIfEmpty u = xs -> xs, -- when the emails field is empty, we try to populate it with the externalId Scim.User.emails = case Scim.User.emails u of - [] -> maybeToList ((\e -> Scim.Email.Email Nothing (Scim.Email.EmailAddress e) Nothing) <$> (emailAddressText =<< (Scim.User.externalId u))) + [] -> maybeToList ((\e -> Scim.Email.Email (Just "work") (Scim.Email.EmailAddress e) Nothing) <$> (emailAddressText =<< (Scim.User.externalId u))) xs -> xs }