diff --git a/cassandra-schema.cql b/cassandra-schema.cql index afac7e0508..161c49bac0 100644 --- a/cassandra-schema.cql +++ b/cassandra-schema.cql @@ -681,6 +681,11 @@ CREATE TABLE brig_test.user ( phone text, picture list, provider uuid, + saml_entity_id text, + saml_name_id text, + scim_external_id text, + scim_email text, + scim_email_source text, searchable boolean, service uuid, sso_id text, diff --git a/changelog.d/3-bug-fixes/WPB-1583 b/changelog.d/3-bug-fixes/WPB-1583 new file mode 100644 index 0000000000..05020526ae --- /dev/null +++ b/changelog.d/3-bug-fixes/WPB-1583 @@ -0,0 +1,3 @@ +[WIP] + +- fixed bug with scim update and ?? diff --git a/changelog.d/5-internal/WPB-1583 b/changelog.d/5-internal/WPB-1583 new file mode 100644 index 0000000000..34c9e3d397 --- /dev/null +++ b/changelog.d/5-internal/WPB-1583 @@ -0,0 +1,5 @@ +[WIP] + +- useridentity has new field uauth_id that contains consistent and complete user-identifying info from spar. +- related parsers has more error cases now. +- managed_by is not a database field any more. diff --git a/libs/brig-types/src/Brig/Types/User/Event.hs b/libs/brig-types/src/Brig/Types/User/Event.hs index 19bfc56315..d744e971c2 100644 --- a/libs/brig-types/src/Brig/Types/User/Event.hs +++ b/libs/brig-types/src/Brig/Types/User/Event.hs @@ -81,7 +81,7 @@ data UserUpdatedData = UserUpdatedData eupHandle :: !(Maybe Handle), eupLocale :: !(Maybe Locale), eupManagedBy :: !(Maybe ManagedBy), - eupSSOId :: !(Maybe UserSSOId), + eupSSOId :: !(Maybe LegacyUserSSOId), -- TODO: add fields `eupUAuthId`? (this can replace both SSOId and SSOIdRemoved, but beware of backward compatibility issues when removing those!) eupSSOIdRemoved :: Bool, eupSupportedProtocols :: !(Maybe (Set BaseProtocolTag)) } diff --git a/libs/brig-types/test/unit/Test/Brig/Types/User.hs b/libs/brig-types/test/unit/Test/Brig/Types/User.hs index da85beb625..aad01e1bd4 100644 --- a/libs/brig-types/test/unit/Test/Brig/Types/User.hs +++ b/libs/brig-types/test/unit/Test/Brig/Types/User.hs @@ -37,6 +37,7 @@ import Test.Tasty import Test.Tasty.HUnit import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (..), EJPDResponseBody (..)) import Wire.API.User.Auth.ReAuth +import Wire.API.User.Test tests :: TestTree tests = testGroup "User (types vs. aeson)" $ roundtripTests @@ -51,7 +52,7 @@ roundtripTests = testRoundTripWithSwagger @EJPDResponseBody, testRoundTrip @UpdateConnectionsInternal, testRoundTrip @SearchVisibilityInbound, - testRoundTripWithSwagger @UserAccount, + testRoundTripWithSwagger @(WithSanitizedUserIdentity UserAccount), testGroup "golden tests" $ [testCaseUserAccount] ] @@ -59,6 +60,9 @@ roundtripTests = instance Arbitrary ReAuthUser where arbitrary = ReAuthUser <$> arbitrary <*> arbitrary <*> arbitrary +instance Arbitrary (WithSanitizedUserIdentity UserAccount) where + arbitrary = (arbitrary >>= coherenizeUserAccount) <&> WithSanitizedUserIdentity + testCaseUserAccount :: TestTree testCaseUserAccount = testCase "UserAcccount" $ do assertEqual "1" (Just json1) (encode <$> decode @UserAccount json1) diff --git a/libs/wire-api/default.nix b/libs/wire-api/default.nix index 87dc1bf9b8..d69d6c92ef 100644 --- a/libs/wire-api/default.nix +++ b/libs/wire-api/default.nix @@ -225,6 +225,7 @@ mkDerivation { hex hspec hspec-wai + http-api-data http-types imports iso3166-country-codes diff --git a/libs/wire-api/src/Wire/API/Deprecated.hs b/libs/wire-api/src/Wire/API/Deprecated.hs index c68120be99..7ed9bd2bbe 100644 --- a/libs/wire-api/src/Wire/API/Deprecated.hs +++ b/libs/wire-api/src/Wire/API/Deprecated.hs @@ -30,6 +30,8 @@ import Servant.Client import Servant.OpenApi -- Annotate that the route is deprecated +-- +-- FUTUREWORK: give this a message string that explains how to migrate away from the deprecated end-point! data Deprecated deriving (Typeable) -- All of these instances are very similar to the instances diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 4a52bf64aa..ca94cd736c 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -62,6 +62,7 @@ import Servant.OpenApi (HasOpenApi (toOpenApi)) import Servant.OpenApi.Internal.Orphans () import Util.Options import Wire.API.Connection +import Wire.API.Deprecated import Wire.API.Error import Wire.API.Error.Brig import Wire.API.MLS.CipherSuite @@ -347,10 +348,11 @@ type AccountAPI = ) :<|> Named "iPutUserSsoId" - ( "users" + ( Deprecated -- use `iPutUAuthId` instead + :> "users" :> Capture "uid" UserId :> "sso-id" - :> ReqBody '[Servant.JSON] UserSSOId + :> ReqBody '[Servant.JSON] LegacyUserSSOId :> MultiVerb 'PUT '[Servant.JSON] @@ -361,7 +363,8 @@ type AccountAPI = ) :<|> Named "iDeleteUserSsoId" - ( "users" + ( Deprecated -- use `iDeleteUAuthId` instead + :> "users" :> Capture "uid" UserId :> "sso-id" :> MultiVerb @@ -372,6 +375,33 @@ type AccountAPI = ] UpdateSSOIdResponse ) + :<|> Named + "iPutUAuthId" + ( "users" + :> Capture "uid" UserId + :> "uauthid" + :> ReqBody '[Servant.JSON] PartialUAuthId + :> MultiVerb + 'PUT + '[Servant.JSON] + '[ RespondEmpty 200 "UpdateSSOIdSuccess", + RespondEmpty 404 "UpdateSSOIdNotFound" + ] + UpdateSSOIdResponse + ) + :<|> Named + "iDeleteUAuthId" + ( "users" + :> Capture "uid" UserId + :> "uauthid" + :> MultiVerb + 'DELETE + '[Servant.JSON] + '[ RespondEmpty 200 "UpdateSSOIdSuccess", + RespondEmpty 404 "UpdateSSOIdNotFound" + ] + UpdateSSOIdResponse + ) :<|> Named "iPutManagedBy" ( "users" diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index c009585596..de2903ec36 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -37,7 +37,7 @@ module Wire.API.User User (..), userEmail, userPhone, - userSSOId, + userPartialUAuthId, userIssuer, userSCIMExternalId, scimExternalId, @@ -65,7 +65,7 @@ module Wire.API.User newUserTeam, newUserEmail, newUserPhone, - newUserSSOId, + newUserUAuthId, isNewUserEphemeral, isNewUserTeamMember, @@ -669,7 +669,7 @@ data User = User -- | User identity. For endpoints like @/self@, it will be present in the response iff -- the user is activated, and the email/phone contained in it will be guaranteedly -- verified. {#RefActivation} - userIdentity :: Maybe UserIdentity, + userIdentity :: Maybe (UserIdentity "team"), -- | required; non-unique userDisplayName :: Name, -- | DEPRECATED @@ -696,8 +696,8 @@ data User = User deriving (Arbitrary) via (GenericUniform User) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema User) --- -- FUTUREWORK: --- -- disentangle json serializations for 'User', 'NewUser', 'UserIdentity', 'NewUserOrigin'. +-- FUTUREWORK: disentangle json serializations for 'User', 'NewUser', 'UserIdentity', +-- 'NewUserOrigin'. instance ToSchema User where schema = object "User" userObjectSchema @@ -739,31 +739,32 @@ userEmail = emailIdentity <=< userIdentity userPhone :: User -> Maybe Phone userPhone = phoneIdentity <=< userIdentity -userSSOId :: User -> Maybe UserSSOId -userSSOId = ssoIdentity <=< userIdentity +userPartialUAuthId :: User -> Maybe PartialUAuthId +userPartialUAuthId = uauthIdentity <=< userIdentity userSCIMExternalId :: User -> Maybe Text -userSCIMExternalId usr = scimExternalId (userManagedBy usr) =<< userSSOId usr +userSCIMExternalId usr = scimExternalId (userManagedBy usr) =<< userPartialUAuthId usr -- FUTUREWORK: this is only ignoring case in the email format, and emails should be -- handled case-insensitively. https://wearezeta.atlassian.net/browse/SQSERVICES-909 -scimExternalId :: ManagedBy -> UserSSOId -> Maybe Text -scimExternalId _ (UserScimExternalId extId) = Just extId -scimExternalId ManagedByScim (UserSSOId (SAML.UserRef _ nameIdXML)) = Just . CI.original . SAML.unsafeShowNameID $ nameIdXML -scimExternalId ManagedByWire (UserSSOId _) = Nothing - -ssoIssuerAndNameId :: UserSSOId -> Maybe (Text, Text) -ssoIssuerAndNameId (UserSSOId (SAML.UserRef (SAML.Issuer uri) nameIdXML)) = Just (fromUri uri, fromNameId nameIdXML) +scimExternalId :: ManagedBy -> PartialUAuthId -> Maybe Text +scimExternalId _ (UAuthId _ (Just extId) _ _) = Just extId +scimExternalId ManagedByScim (UAuthId (Just (SAML.UserRef _ nameIdXML)) _ _ _) = Just . CI.original . SAML.unsafeShowNameID $ nameIdXML +scimExternalId ManagedByWire (UAuthId {}) = Nothing +scimExternalId _ _ = Nothing + +ssoIssuerAndNameId :: PartialUAuthId -> Maybe (Text, Text) +ssoIssuerAndNameId (UAuthId (Just (SAML.UserRef (SAML.Issuer uri) nameIdXML)) _ _ _) = Just (fromUri uri, fromNameId nameIdXML) where fromUri = cs . toLazyByteString . serializeURIRef fromNameId = CI.original . SAML.unsafeShowNameID -ssoIssuerAndNameId (UserScimExternalId _) = Nothing +ssoIssuerAndNameId (UAuthId {}) = Nothing userIssuer :: User -> Maybe SAML.Issuer -userIssuer user = userSSOId user >>= fromSSOId +userIssuer user = userPartialUAuthId user >>= fromSSOId where - fromSSOId :: UserSSOId -> Maybe SAML.Issuer - fromSSOId (UserSSOId (SAML.UserRef issuer _)) = Just issuer + fromSSOId :: PartialUAuthId -> Maybe SAML.Issuer + fromSSOId (UAuthId (Just (SAML.UserRef issuer _)) _ _ _) = Just issuer fromSSOId _ = Nothing connectedProfile :: User -> UserLegalHoldStatus -> UserProfile @@ -850,7 +851,7 @@ instance ToSchema NewUserPublic where validateNewUserPublic :: NewUser -> Either String NewUserPublic validateNewUserPublic nu - | isJust (newUserSSOId nu) = + | isJust (newUserUAuthId nu) = Left "SSO-managed users are not allowed here." | isJust (newUserUUID nu) = Left "it is not allowed to provide a UUID for the users here." @@ -1006,7 +1007,7 @@ errFromEither (Right e) = CreateUserSparRegistrationError e data NewUserSpar = NewUserSpar { newUserSparUUID :: UUID, - newUserSparSSOId :: UserSSOId, + newUserSparUAuthId :: PartialUAuthId, newUserSparDisplayName :: Name, newUserSparTeamId :: TeamId, newUserSparManagedBy :: ManagedBy, @@ -1018,35 +1019,115 @@ data NewUserSpar = NewUserSpar deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewUserSpar) +-- | This type is only for translating the deprecated `newUserSparSSOId` field into +-- `newUserSparRawUAuthId`. Once we're confident the former won't occur on the wire any more, +-- this type can be removed. +data NewUserSparRaw = NewUserSparRaw + { newUserSparRawUUID :: UUID, + newUserSparRawUAuthId :: Maybe PartialUAuthId, + newUserSparRawSSOId :: Maybe LegacyUserSSOId, + newUserSparRawDisplayName :: Name, + newUserSparRawTeamId :: TeamId, + newUserSparRawManagedBy :: ManagedBy, + newUserSparRawHandle :: Maybe Handle, + newUserSparRawRichInfo :: Maybe RichInfo, + newUserSparRawLocale :: Maybe Locale, + newUserSparRawRole :: Role + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewUserSparRaw) + instance ToSchema NewUserSpar where - schema = - object "NewUserSpar" $ + schema = object "NewUserSpar" $ newUserSparToRaw .= withParser newUserSparRawObjectSchema newUserSparFromRaw + +newUserSparRawObjectSchema :: ObjectSchema SwaggerDoc NewUserSparRaw +newUserSparRawObjectSchema = + NewUserSparRaw + <$> newUserSparRawUUID + .= field "newUserSparUUID" genericToSchema + <*> newUserSparRawUAuthId + .= maybe_ (optField "newUserSparUAuthId" genericToSchema) + <*> newUserSparRawSSOId + .= maybe_ (optField "newUserSparSSOId" genericToSchema) + <*> newUserSparRawDisplayName + .= field "newUserSparDisplayName" schema + <*> newUserSparRawTeamId + .= field "newUserSparTeamId" schema + <*> newUserSparRawManagedBy + .= field "newUserSparManagedBy" schema + <*> newUserSparRawHandle + .= maybe_ (optField "newUserSparHandle" schema) + <*> newUserSparRawRichInfo + .= maybe_ (optField "newUserSparRichInfo" schema) + <*> newUserSparRawLocale + .= maybe_ (optField "newUserSparLocale" schema) + <*> newUserSparRawRole + .= field "newUserSparRole" schema + +instance ToSchema NewUserSparRaw where + schema = object "NewUserSparRaw" newUserSparRawObjectSchema + +newUserSparToRaw :: NewUserSpar -> NewUserSparRaw +newUserSparToRaw + NewUserSpar + { newUserSparUUID, + newUserSparUAuthId, + newUserSparDisplayName, + newUserSparTeamId, + newUserSparManagedBy, + newUserSparHandle, + newUserSparRichInfo, + newUserSparLocale, + newUserSparRole + } = + NewUserSparRaw + newUserSparUUID + (Just newUserSparUAuthId) + (uAuthIdToLegacyUserSSOId newUserSparUAuthId) + newUserSparDisplayName + newUserSparTeamId + newUserSparManagedBy + newUserSparHandle + newUserSparRichInfo + newUserSparLocale + newUserSparRole + +newUserSparFromRaw :: NewUserSparRaw -> A.Parser NewUserSpar +newUserSparFromRaw + NewUserSparRaw + { newUserSparRawUUID, + newUserSparRawUAuthId, + newUserSparRawSSOId, + newUserSparRawDisplayName, + newUserSparRawTeamId, + newUserSparRawManagedBy, + newUserSparRawHandle, + newUserSparRawRichInfo, + newUserSparRawLocale, + newUserSparRawRole + } = do + ua <- case (newUserSparRawUAuthId, newUserSparRawSSOId) of + (Just ua, _) -> pure ua + (Nothing, Just old) -> pure $ legacyUserSSOIdToUAuthId old newUserSparRawTeamId newUserSparRawManagedBy Nothing + (Nothing, Nothing) -> fail "NewUserSpar: no UAuthId" + pure $ NewUserSpar - <$> newUserSparUUID - .= field "newUserSparUUID" genericToSchema - <*> newUserSparSSOId - .= field "newUserSparSSOId" genericToSchema - <*> newUserSparDisplayName - .= field "newUserSparDisplayName" schema - <*> newUserSparTeamId - .= field "newUserSparTeamId" schema - <*> newUserSparManagedBy - .= field "newUserSparManagedBy" schema - <*> newUserSparHandle - .= maybe_ (optField "newUserSparHandle" schema) - <*> newUserSparRichInfo - .= maybe_ (optField "newUserSparRichInfo" schema) - <*> newUserSparLocale - .= maybe_ (optField "newUserSparLocale" schema) - <*> newUserSparRole - .= field "newUserSparRole" schema + newUserSparRawUUID + ua + newUserSparRawDisplayName + newUserSparRawTeamId + newUserSparRawManagedBy + newUserSparRawHandle + newUserSparRawRichInfo + newUserSparRawLocale + newUserSparRawRole newUserFromSpar :: NewUserSpar -> NewUser newUserFromSpar new = NewUser { newUserDisplayName = newUserSparDisplayName new, newUserUUID = Just $ newUserSparUUID new, - newUserIdentity = Just $ SSOIdentity (newUserSparSSOId new) Nothing Nothing, + newUserIdentity = Just $ UAuthIdentity (newUserSparUAuthId new) Nothing, newUserPict = Nothing, newUserAssets = [], newUserAccentId = Nothing, @@ -1065,7 +1146,7 @@ data NewUser = NewUser { newUserDisplayName :: Name, -- | use this as 'UserId' (if 'Nothing', call 'Data.UUID.nextRandom'). newUserUUID :: Maybe UUID, - newUserIdentity :: Maybe UserIdentity, + newUserIdentity :: Maybe (UserIdentity "team_id"), -- | DEPRECATED newUserPict :: Maybe Pict, newUserAssets :: [Asset], @@ -1112,9 +1193,15 @@ data NewUserRaw = NewUserRaw newUserRawUUID :: Maybe UUID, newUserRawEmail :: Maybe Email, newUserRawPhone :: Maybe Phone, - newUserRawSSOId :: Maybe UserSSOId, - -- | DEPRECATED - newUserRawPict :: Maybe Pict, + newUserRawSSOId :: + -- DEPRECATED (use newUserRawUAuthId instead) + Maybe LegacyUserSSOId, + newUserRawUAuthId :: + -- NOTE(fisx): This defines a json object under a json field, just like newUserRawSSOId. no inlining! + Maybe PartialUAuthId, + newUserRawPict :: + -- DEPRECATED + Maybe Pict, newUserRawAssets :: [Asset], newUserRawAccentId :: Maybe ColourId, newUserRawEmailCode :: Maybe ActivationCode, @@ -1144,6 +1231,8 @@ newUserRawObjectSchema = .= maybe_ (optField "phone" schema) <*> newUserRawSSOId .= maybe_ (optField "sso_id" genericToSchema) + <*> newUserRawUAuthId + .= maybe_ (optField "uauthid" genericToSchema) <*> newUserRawPict .= maybe_ (optField "picture" schema) <*> newUserRawAssets @@ -1187,7 +1276,8 @@ newUserToRaw NewUser {..} = newUserRawUUID = newUserUUID, newUserRawEmail = emailIdentity =<< newUserIdentity, newUserRawPhone = phoneIdentity =<< newUserIdentity, - newUserRawSSOId = ssoIdentity =<< newUserIdentity, + newUserRawSSOId = legacySsoIdentity =<< newUserIdentity, + newUserRawUAuthId = uauthIdentity =<< newUserIdentity, newUserRawPict = newUserPict, newUserRawAssets = newUserAssets, newUserRawAccentId = newUserAccentId, @@ -1213,7 +1303,19 @@ newUserFromRaw NewUserRaw {..} = do (isJust newUserRawPassword) (isJust newUserRawSSOId) (newUserRawInvitationCode, newUserRawTeamCode, newUserRawTeam, newUserRawTeamId) - let identity = maybeUserIdentityFromComponents (newUserRawEmail, newUserRawPhone, newUserRawSSOId) + identity <- + let hdl = \case + UserIdentityFromComponentsNoFields -> pure Nothing + other -> fail (show other) + in either hdl (pure . Just) $ + eUserIdentityFromComponents + ( newUserRawEmail, + newUserRawPhone, + newUserRawUAuthId, + newUserRawSSOId, + newUserRawTeamId, + newUserRawManagedBy + ) expiresIn <- case (newUserRawExpiresIn, identity) of (Just _, Just _) -> fail "Only users without an identity can expire" @@ -1260,7 +1362,7 @@ instance Arbitrary NewUser where genUserOrigin newUserIdentity = do teamid <- arbitrary let hasSSOId = case newUserIdentity of - Just SSOIdentity {} -> True + Just UAuthIdentity {} -> True _ -> False ssoOrigin = Just (NewUserOriginTeamUser (NewTeamMemberSSO teamid)) isSsoOrigin (Just (NewUserOriginTeamUser (NewTeamMemberSSO _))) = True @@ -1270,7 +1372,7 @@ instance Arbitrary NewUser where else arbitrary `QC.suchThat` (not . isSsoOrigin) genUserPassword newUserIdentity newUserOrigin = do let hasSSOId = case newUserIdentity of - Just SSOIdentity {} -> True + Just UAuthIdentity {} -> True _ -> False isTeamUser = case newUserOrigin of Just (NewUserOriginTeamUser _) -> True @@ -1295,8 +1397,8 @@ newUserEmail = emailIdentity <=< newUserIdentity newUserPhone :: NewUser -> Maybe Phone newUserPhone = phoneIdentity <=< newUserIdentity -newUserSSOId :: NewUser -> Maybe UserSSOId -newUserSSOId = ssoIdentity <=< newUserIdentity +newUserUAuthId :: NewUser -> Maybe PartialUAuthId +newUserUAuthId = uauthIdentity <=< newUserIdentity -------------------------------------------------------------------------------- -- NewUserOrigin diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index e14b30bc32..82f9416654 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/libs/wire-api/src/Wire/API/User/Activation.hs @@ -166,9 +166,14 @@ instance ToSchema Activate where ActivateEmail email -> (Nothing, Nothing, Just email) -- | Information returned as part of a successful activation. +-- +-- NB[fisx): in the non-scim-non-saml activation flow, we don't have a `TeamId` here because +-- we there is no `UAuthId` we could extract one from. The phantom type for `UserIdentity` is +-- still required, but luckily only for parsing values, which never happens here: we only +-- construct `ActivationResponse` values from already-parsed `UserIdentity` values. data ActivationResponse = ActivationResponse { -- | The activated / verified user identity. - activatedIdentity :: UserIdentity, + activatedIdentity :: UserIdentity "team_id", -- | Whether this is the first verified identity of the account. activatedFirst :: Bool } diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 2b88c1d3bd..0c32ab9815 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -22,13 +22,22 @@ module Wire.API.User.Identity ( -- * UserIdentity UserIdentity (..), + castUserIdentityTeamFieldName, newIdentity, emailIdentity, phoneIdentity, - ssoIdentity, + uauthIdentity, + legacySsoIdentity, userIdentityObjectSchema, maybeUserIdentityObjectSchema, - maybeUserIdentityFromComponents, + eUserIdentityObjectSchema, + eUserIdentityFromComponents, + eUserIdentityToComponents, + UserIdentityComponents, + UserIdentityFromComponentsParseErrors (..), + LegacyUserSSOId (..), + legacyUserSSOIdToUAuthId, + uAuthIdToLegacyUserSSOId, -- * Email Email (..), @@ -41,19 +50,30 @@ module Wire.API.User.Identity parsePhone, isValidPhone, - -- * UserSSOId - UserSSOId (..), + -- * UAuthId + UAuthId (..), + EmailWithSource (..), + EmailSource (..), + PartialUAuthId, + ScimUAuthId, + partialToScimUAuthId, + scimToPartialUAuthId, + + -- * helpers emailFromSAML, emailToSAML, emailToSAMLNameID, emailFromSAMLNameID, + mkUserNameScim, + mkUserNameSaml, mkSampleUref, mkSimpleSampleUref, + mkBasicSampleUref, ) where import Control.Applicative (optional) -import Control.Lens (dimap, over, (.~), (?~), (^.)) +import Control.Lens (dimap, over, view, (.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import Data.Aeson qualified as A import Data.Aeson.Types qualified as A @@ -61,13 +81,15 @@ import Data.Attoparsec.Text import Data.Bifunctor (first) import Data.ByteString.Conversion import Data.CaseInsensitive qualified as CI +import Data.Id import Data.OpenApi (ToParamSchema (..)) import Data.OpenApi qualified as S import Data.Schema import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Time.Clock -import Data.Tuple.Extra (fst3, snd3, thd3) +import GHC.Prim (coerce) +import GHC.TypeLits import Imports import SAML2.WebSSO.Test.Arbitrary () import SAML2.WebSSO.Types qualified as SAML @@ -80,7 +102,8 @@ import Test.QuickCheck qualified as QC import Text.Email.Validate qualified as Email.V import URI.ByteString qualified as URI import URI.ByteString.QQ (uri) -import Wire.API.User.Profile (fromName, mkName) +import Wire.API.User.Profile +import Wire.API.User.Types import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) -------------------------------------------------------------------------------- @@ -88,128 +111,153 @@ import Wire.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) -- | The private unique user identity that is used for login and -- account recovery. -data UserIdentity +-- +-- Explaining the teamFieldName phantom type is a little more involved. +-- +-- `UserIdentity` gets parsed from object schemas of different containing types. `User`, +-- `NewUser` are two good examples: both haskell types contain a field typed `UserIdentity`, +-- but the schema of the inner type is merged with the schema of the outer, ie., the parser +-- collects all fields on the root object. +-- +-- Now in `User`, the field carrying the team id is called `team`; in `NewUser`, that name is +-- already used for team name, so `team_id` is used instead. So we need to parameterize over +-- the name of that field. +data UserIdentity (tf :: Symbol) = FullIdentity Email Phone | EmailIdentity Email | PhoneIdentity Phone - | SSOIdentity UserSSOId (Maybe Email) (Maybe Phone) + | UAuthIdentity PartialUAuthId (Maybe Email {- from `brig.user.email`, which may differ from the email address inside UAuthId -}) deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform UserIdentity) + deriving (Arbitrary) via (GenericUniform (UserIdentity tf)) + +castUserIdentityTeamFieldName :: UserIdentity tf -> UserIdentity tf' +castUserIdentityTeamFieldName = coerce -userIdentityObjectSchema :: ObjectSchema SwaggerDoc UserIdentity +-- | The unparsed data as retrieved from cassandra or json. See source code and +-- `userIdentityComponentsObjectSchema`, `maybeUserIdentityFromComponents`, +-- `maybeUserIdentityToComponents` below. +userIdentityObjectSchema :: forall tf. KnownSymbol tf => ObjectSchema SwaggerDoc (UserIdentity tf) userIdentityObjectSchema = - Just .= withParser maybeUserIdentityObjectSchema (maybe (fail "Missing 'email' or 'phone' or 'sso_id'.") pure) + Right .= withParser (eUserIdentityObjectSchema @tf) (either (fail . show) pure) -maybeUserIdentityObjectSchema :: ObjectSchema SwaggerDoc (Maybe UserIdentity) -maybeUserIdentityObjectSchema = - dimap maybeUserIdentityToComponents maybeUserIdentityFromComponents userIdentityComponentsObjectSchema +eUserIdentityObjectSchema :: forall tf. KnownSymbol tf => ObjectSchema SwaggerDoc (Either UserIdentityFromComponentsParseErrors (UserIdentity tf)) +eUserIdentityObjectSchema = + dimap eUserIdentityToComponents eUserIdentityFromComponents (userIdentityComponentsObjectSchema @tf) -type UserIdentityComponents = (Maybe Email, Maybe Phone, Maybe UserSSOId) +maybeUserIdentityObjectSchema :: forall tf. KnownSymbol tf => ObjectSchema SwaggerDoc (Maybe (UserIdentity tf)) +maybeUserIdentityObjectSchema = + dimap (maybeUserIdentityToComponents @tf) (maybeUserIdentityFromComponents @tf) (userIdentityComponentsObjectSchema @tf) + +-- | See `UAuthId` docs for an explanation of the phantom type parameter. +type UserIdentityComponents (tf :: Symbol) = + ( -- email from `brig.user.email` + Maybe Email, + -- phone from `brig.user.phone` + Maybe Phone, + -- user identifying data from spar + Maybe PartialUAuthId, + -- user auth info from spar (legacy) + Maybe LegacyUserSSOId, + -- `TeamId`, `ManagedBy` are needed for migration from `LegacyUserSSOId` to + -- `PartialUAuthId`. When parsing, eg., `User` json values, these are duplicated from the + -- fields also in that record. During rendering, they will be ignored (because we always + -- have a UAuthId at that point: parsed `UserIdentity` values always contain the migrated + -- `UAuthId` value). `UserIdentityComponents` values constructed from `UAuthId` values + -- will always be 'Nothing'. + Maybe TeamId, + Maybe ManagedBy + ) -userIdentityComponentsObjectSchema :: ObjectSchema SwaggerDoc UserIdentityComponents +userIdentityComponentsObjectSchema :: forall tf. KnownSymbol tf => ObjectSchema SwaggerDoc (UserIdentityComponents tf) userIdentityComponentsObjectSchema = - (,,) - <$> fst3 .= maybe_ (optField "email" schema) - <*> snd3 .= maybe_ (optField "phone" schema) - <*> thd3 .= maybe_ (optField "sso_id" genericToSchema) - -maybeUserIdentityFromComponents :: UserIdentityComponents -> Maybe UserIdentity -maybeUserIdentityFromComponents = \case - (maybeEmail, maybePhone, Just ssoid) -> Just $ SSOIdentity ssoid maybeEmail maybePhone - (Just email, Just phone, Nothing) -> Just $ FullIdentity email phone - (Just email, Nothing, Nothing) -> Just $ EmailIdentity email - (Nothing, Just phone, Nothing) -> Just $ PhoneIdentity phone - (Nothing, Nothing, Nothing) -> Nothing - -maybeUserIdentityToComponents :: Maybe UserIdentity -> UserIdentityComponents -maybeUserIdentityToComponents Nothing = (Nothing, Nothing, Nothing) -maybeUserIdentityToComponents (Just (FullIdentity email phone)) = (Just email, Just phone, Nothing) -maybeUserIdentityToComponents (Just (EmailIdentity email)) = (Just email, Nothing, Nothing) -maybeUserIdentityToComponents (Just (PhoneIdentity phone)) = (Nothing, Just phone, Nothing) -maybeUserIdentityToComponents (Just (SSOIdentity ssoid m_email m_phone)) = (m_email, m_phone, Just ssoid) - -newIdentity :: Maybe Email -> Maybe Phone -> Maybe UserSSOId -> Maybe UserIdentity -newIdentity email phone (Just sso) = Just $! SSOIdentity sso email phone -newIdentity Nothing Nothing Nothing = Nothing -newIdentity (Just e) Nothing Nothing = Just $! EmailIdentity e -newIdentity Nothing (Just p) Nothing = Just $! PhoneIdentity p -newIdentity (Just e) (Just p) Nothing = Just $! FullIdentity e p - -emailIdentity :: UserIdentity -> Maybe Email + (,,,,,) + <$> (\(a, _, _, _, _, _) -> a) .= maybe_ (optField "email" schema) + <*> (\(_, a, _, _, _, _) -> a) .= maybe_ (optField "phone" schema) + <*> (\(_, _, a, _, _, _) -> a) .= maybe_ (fmap join (optField "uauth_id" optPartialUAuthIdSchema)) + <*> (\(_, _, _, a, _, _) -> a) .= maybe_ (optField "sso_id" genericToSchema) + <*> (\(_, _, _, _, a, _) -> a) .= maybe_ (optField (cs $ symbolVal (Proxy @tf)) genericToSchema) + <*> (\(_, _, _, _, _, a) -> a) .= maybe_ (optField "managed_by" genericToSchema) + +data UserIdentityFromComponentsParseErrors + = UserIdentityFromComponentsNoFields + | UserIdentityFromComponentsNoPhoneAllowedForUAuthId + | UserIdentityFromComponentsUAuthIdWithoutTeam + | UserIdentityFromComponentsUAuthIdTeamMismatch + deriving (Eq, Show) + +eUserIdentityFromComponents :: UserIdentityComponents tf -> Either UserIdentityFromComponentsParseErrors (UserIdentity tf) +eUserIdentityFromComponents = \case + -- old-school + (Just eml, Just phn, Nothing, Nothing, _, _) -> Right $ FullIdentity eml phn + (Just eml, Nothing, Nothing, Nothing, _, _) -> Right $ EmailIdentity eml + (Nothing, Just phn, Nothing, Nothing, _, _) -> Right $ PhoneIdentity phn + -- + -- uauth (from uauth_id; sso_id field will be ignored) + (_, Just _, Just _, _, _, _) -> Left UserIdentityFromComponentsNoPhoneAllowedForUAuthId + (_, Just _, Nothing, Just _, _, _) -> Left UserIdentityFromComponentsNoPhoneAllowedForUAuthId + (mbeml, Nothing, Just uauth, _, mbteamid, _) -> + -- `mbteamid` must be Nothing or match `uauth.uaTeamId`. `mbeml` and `uauth.uaEmail` do + -- not need to match: the email address in the first part of the tuple is the validated + -- one stored in brig. eg., the one stored in the `PartialUAuthId` may just have been + -- uploaded by scim and not yet validated. + case mbteamid of + Nothing -> Right $ UAuthIdentity uauth mbeml + Just teamid -> + if uauth.uaTeamId == teamid + then Right $ UAuthIdentity uauth mbeml + else Left UserIdentityFromComponentsUAuthIdTeamMismatch + -- + -- uauth (legacy; uauth_id is missing and sso_id is considered instead) + (mbemail, Nothing, Nothing, Just lsso, Just teamid, fromMaybe ManagedByWire -> mby) -> + Right $ UAuthIdentity (legacyUserSSOIdToUAuthId lsso teamid mby mbemail) mbemail + (_, Nothing, Nothing, Just _, Nothing, _) -> + Left UserIdentityFromComponentsUAuthIdWithoutTeam + -- + -- catchall + (Nothing, Nothing, Nothing, Nothing, _, _) -> + Left UserIdentityFromComponentsNoFields + +-- | Wrapper for `eUserIdentityFromComponents`. +maybeUserIdentityFromComponents :: forall tf. UserIdentityComponents tf -> Maybe (UserIdentity tf) +maybeUserIdentityFromComponents = either (const Nothing) Just . (eUserIdentityFromComponents @tf) + +-- | Convert `UserIdentity` back into raw data for json. The `LegacySSOIdentity` part of +-- the tuple is always `Nothing`. +eUserIdentityToComponents :: forall tf e. Either e (UserIdentity tf) -> UserIdentityComponents tf +eUserIdentityToComponents (Left _) = (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) +eUserIdentityToComponents (Right (FullIdentity email phone)) = (Just email, Just phone, Nothing, Nothing, Nothing, Nothing) +eUserIdentityToComponents (Right (EmailIdentity email)) = (Just email, Nothing, Nothing, Nothing, Nothing, Nothing) +eUserIdentityToComponents (Right (PhoneIdentity phone)) = (Nothing, Just phone, Nothing, Nothing, Nothing, Nothing) +eUserIdentityToComponents (Right (UAuthIdentity uaid mbemail)) = (mbemail, Nothing, Just uaid, uAuthIdToLegacyUserSSOId uaid, Nothing, Nothing) + +-- | Wrapper for `eUserIdentityToComponents`. +maybeUserIdentityToComponents :: Maybe (UserIdentity tf) -> UserIdentityComponents tf +maybeUserIdentityToComponents = eUserIdentityToComponents . maybe (Left ()) Right + +newIdentity :: Maybe Email -> Maybe Phone -> Maybe PartialUAuthId -> Maybe (UserIdentity tf) +newIdentity mbEmail mbPhone mbUAuth = maybeUserIdentityFromComponents (mbEmail, mbPhone, mbUAuth, Nothing, Nothing, Nothing) + +emailIdentity :: UserIdentity tf -> Maybe Email emailIdentity (FullIdentity email _) = Just email emailIdentity (EmailIdentity email) = Just email emailIdentity (PhoneIdentity _) = Nothing -emailIdentity (SSOIdentity _ (Just email) _) = Just email -emailIdentity (SSOIdentity _ Nothing _) = Nothing +emailIdentity (UAuthIdentity _ mbemail) = mbemail -- if uaid.uaEmail diverges, mbemail is not a (validated) part of uaid yet. -phoneIdentity :: UserIdentity -> Maybe Phone +phoneIdentity :: UserIdentity tf -> Maybe Phone phoneIdentity (FullIdentity _ phone) = Just phone phoneIdentity (PhoneIdentity phone) = Just phone phoneIdentity (EmailIdentity _) = Nothing -phoneIdentity (SSOIdentity _ _ (Just phone)) = Just phone -phoneIdentity (SSOIdentity _ _ Nothing) = Nothing - -ssoIdentity :: UserIdentity -> Maybe UserSSOId -ssoIdentity (SSOIdentity ssoid _ _) = Just ssoid -ssoIdentity _ = Nothing - --------------------------------------------------------------------------------- --- Email - --- FUTUREWORK: replace this type with 'EmailAddress' -data Email = Email - { emailLocal :: Text, - emailDomain :: Text - } - deriving stock (Eq, Ord, Generic) - deriving (FromJSON, ToJSON, S.ToSchema) via Schema Email - -instance ToParamSchema Email where - toParamSchema _ = toParamSchema (Proxy @Text) - -instance ToSchema Email where - schema = - fromEmail - .= parsedText - "Email" - ( maybe - (Left "Invalid email. Expected '@'.") - pure - . parseEmail - ) - -instance Show Email where - show = Text.unpack . fromEmail +phoneIdentity (UAuthIdentity _ _) = Nothing -instance ToByteString Email where - builder = builder . fromEmail +uauthIdentity :: UserIdentity tf -> Maybe PartialUAuthId +uauthIdentity (UAuthIdentity uaid _) = pure uaid +uauthIdentity _ = Nothing -instance FromByteString Email where - parser = parser >>= maybe (fail "Invalid email") pure . parseEmail +legacySsoIdentity :: UserIdentity tf -> Maybe LegacyUserSSOId +legacySsoIdentity (UAuthIdentity uaid _mbemail) = uAuthIdToLegacyUserSSOId uaid +legacySsoIdentity _ = Nothing -instance S.FromHttpApiData Email where - parseUrlPiece = maybe (Left "Invalid email") Right . fromByteString . cs - -instance S.ToHttpApiData Email where - toUrlPiece = cs . toByteString' - -instance Arbitrary Email where - arbitrary = do - localPart <- Text.filter (/= '@') <$> arbitrary - domain <- Text.filter (/= '@') <$> arbitrary - pure $ Email localPart domain - -fromEmail :: Email -> Text -fromEmail (Email loc dom) = loc <> "@" <> dom - --- | Parses an email address of the form @. -parseEmail :: Text -> Maybe Email -parseEmail t = case Text.split (== '@') t of - [localPart, domain] -> Just $! Email localPart domain - _ -> Nothing - --- | --- FUTUREWORK: +-- | FUTUREWORK: -- -- * Enforce these constrains during parsing already or use a separate type, see -- [Parse, don't validate](https://lexi-lambda.github.io/blog/2019/11/05/parse-don-t-validate). @@ -296,32 +344,91 @@ isValidPhone = either (const False) (const True) . parseOnly e164 where e164 = char '+' *> count 8 digit *> count 7 (optional digit) *> endOfInput +-- | If the budget for SMS and voice calls for a phone number +-- has been exhausted within a certain time frame, this timeout +-- indicates in seconds when another attempt may be made. +newtype PhoneBudgetTimeout = PhoneBudgetTimeout + {phoneBudgetTimeout :: NominalDiffTime} + deriving stock (Eq, Show, Generic) + deriving newtype (Arbitrary) + +instance FromJSON PhoneBudgetTimeout where + parseJSON = A.withObject "PhoneBudgetTimeout" $ \o -> + PhoneBudgetTimeout <$> o A..: "expires_in" + +instance ToJSON PhoneBudgetTimeout where + toJSON (PhoneBudgetTimeout t) = A.object ["expires_in" A..= t] + -------------------------------------------------------------------------------- --- UserSSOId +-- LegacyUserSSOId (DEPRECATED, formerly UserSSOId) --- | User's external identity. --- +-- | User's legacy external identity (DEPRECATED). -- NB: this type is serialized to the full xml encoding of the `SAML.UserRef` components, but -- deserialiation is more lenient: it also allows for the `Issuer` to be a plain URL (without -- xml around it), and the `NameID` to be an email address (=> format "email") or an arbitrary -- text (=> format "unspecified"). This is for backwards compatibility and general -- robustness. --- --- FUTUREWORK: we should probably drop this entirely and store saml and scim data in separate --- database columns. -data UserSSOId +data LegacyUserSSOId = UserSSOId SAML.UserRef | UserScimExternalId Text deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform UserSSOId) - --- | FUTUREWORK: This schema should ideally be a choice of either tenant+subject, or scim_external_id --- but this is currently not possible to derive in swagger2 --- Maybe this becomes possible with swagger 3? -instance S.ToSchema UserSSOId where + deriving (Arbitrary) via (GenericUniform LegacyUserSSOId) + +legacyUserSSOIdToUAuthId :: LegacyUserSSOId -> TeamId -> ManagedBy -> Maybe Email -> PartialUAuthId +{- +some removed code from spar that describes the semantics of LegacyUserSSOId: + +data ValidExternalId + = EmailAndUref Email SAML.UserRef + | UrefOnly SAML.UserRef + | EmailOnly Email + +veidToUserSSOId :: ValidExternalId -> UserSSOId +veidToUserSSOId = runValidExternalIdEither UserSSOId (UserScimExternalId . fromEmail) + +veidFromUserSSOId :: MonadError String m => UserSSOId -> m ValidExternalId +veidFromUserSSOId = \case + UserSSOId uref -> + case urefToEmail uref of + Nothing -> pure $ UrefOnly uref + Just email -> pure $ EmailAndUref email uref + UserScimExternalId email -> + maybe + (throwError "externalId not an email and no issuer") + (pure . EmailOnly) + (parseEmail email) +-} +legacyUserSSOIdToUAuthId ssoid tid mby mbeml = UAuthId uref' eid' eml' tid + where + uref' = case ssoid of + UserSSOId uref -> Just uref + UserScimExternalId _ -> Nothing + + eid' = case (ssoid, mby) of + (UserSSOId _, ManagedByWire) -> Nothing + (UserSSOId uref, ManagedByScim) -> Just . CI.original . SAML.unsafeShowNameID . view SAML.uidSubject $ uref + (UserScimExternalId e, _) -> Just e + + -- `EmailFromScimEmailsField` is never has not been introduced yet at the time of writing + -- this code. So no legacy users should ever exist that need this value: either they have + -- been created after introduction of `EmailFromScimEmailsField` and don't need migration, + -- or they have been introduced before and don't need `EmailFromScimEmailsField`. + eml' = mbeml <&> (`EmailWithSource` emlsrc) + emlsrc = case mby of + ManagedByWire -> EmailFromSamlNameId + ManagedByScim -> EmailFromScimExternalIdField + +uAuthIdToLegacyUserSSOId :: PartialUAuthId -> Maybe LegacyUserSSOId +uAuthIdToLegacyUserSSOId (UAuthId mburef mbeid _mbeml _tid) = case mburef of + Just uref -> Just $ UserSSOId uref + Nothing -> case mbeid of + Just eid -> Just $ UserScimExternalId eid + Nothing -> Nothing + +instance S.ToSchema LegacyUserSSOId where declareNamedSchema _ = do - tenantSchema <- S.declareSchemaRef (Proxy @Text) -- FUTUREWORK: 'Issuer' - subjectSchema <- S.declareSchemaRef (Proxy @Text) -- FUTUREWORK: 'NameID' + tenantSchema <- S.declareSchemaRef (Proxy @Text) -- 'Issuer' + subjectSchema <- S.declareSchemaRef (Proxy @Text) -- 'NameID' scimSchema <- S.declareSchemaRef (Proxy @Text) pure $ S.NamedSchema (Just "UserSSOId") $ @@ -333,35 +440,27 @@ instance S.ToSchema UserSSOId where ("scim_external_id", scimSchema) ] -instance ToJSON UserSSOId where +instance ToJSON LegacyUserSSOId where toJSON = \case - UserSSOId (SAML.UserRef tenant subject) -> A.object ["tenant" A..= SAML.encodeElem tenant, "subject" A..= SAML.encodeElem subject] - UserScimExternalId eid -> A.object ["scim_external_id" A..= eid] + UserSSOId (SAML.UserRef tenant subject) -> + A.object ["tenant" A..= SAML.encodeElem tenant, "subject" A..= SAML.encodeElem subject] + UserScimExternalId eid -> + A.object ["scim_external_id" A..= eid] -instance FromJSON UserSSOId where +instance FromJSON LegacyUserSSOId where parseJSON = A.withObject "UserSSOId" $ \obj -> do mtenant <- lenientlyParseSAMLIssuer =<< (obj A..:? "tenant") msubject <- lenientlyParseSAMLNameID =<< (obj A..:? "subject") meid <- obj A..:? "scim_external_id" case (mtenant, msubject, meid) of - (Just tenant, Just subject, Nothing) -> pure $ UserSSOId (SAML.UserRef tenant subject) - (Nothing, Nothing, Just eid) -> pure $ UserScimExternalId eid + (Just tenant, Just subject, Nothing) -> + pure $ UserSSOId (SAML.UserRef tenant subject) + (Nothing, Nothing, Just eid) -> + pure $ UserScimExternalId eid _ -> fail "either need tenant and subject, or scim_external_id, but not both" --- | If the budget for SMS and voice calls for a phone number --- has been exhausted within a certain time frame, this timeout --- indicates in seconds when another attempt may be made. -newtype PhoneBudgetTimeout = PhoneBudgetTimeout - {phoneBudgetTimeout :: NominalDiffTime} - deriving stock (Eq, Show, Generic) - deriving newtype (Arbitrary) - -instance FromJSON PhoneBudgetTimeout where - parseJSON = A.withObject "PhoneBudgetTimeout" $ \o -> - PhoneBudgetTimeout <$> o A..: "expires_in" - -instance ToJSON PhoneBudgetTimeout where - toJSON (PhoneBudgetTimeout t) = A.object ["expires_in" A..= t] +---------------------------------------------------------------------- +-- low-level helper functions lenientlyParseSAMLIssuer :: Maybe LText -> A.Parser (Maybe SAML.Issuer) lenientlyParseSAMLIssuer mbtxt = forM mbtxt $ \txt -> do @@ -420,8 +519,16 @@ emailFromSAMLNameID nid = case nid ^. SAML.nameID of SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email _ -> Nothing +mkUserNameScim :: Maybe Text -> UAuthId Maybe Identity Maybe -> Either String Name +mkUserNameScim (Just n) = const $ mkName n +mkUserNameScim Nothing = mkName . runIdentity . uaScimExternalId + +mkUserNameSaml :: Maybe Text -> UAuthId Identity Maybe Maybe -> Either String Name +mkUserNameSaml (Just n) = const $ mkName n +mkUserNameSaml Nothing = mkName . CI.original . SAML.unsafeShowNameID . view SAML.uidSubject . runIdentity . uaSamlId + -- | For testing. Create a sample 'SAML.UserRef' value with random seeds to make 'Issuer' and --- 'NameID' unique. FUTUREWORK: move to saml2-web-sso. +-- 'NameID' unique. mkSampleUref :: Text -> Text -> SAML.UserRef mkSampleUref iseed nseed = SAML.UserRef issuer nameid where @@ -429,10 +536,22 @@ mkSampleUref iseed nseed = SAML.UserRef issuer nameid issuer = SAML.Issuer ([uri|http://example.com/|] & URI.pathL .~ cs ("/" cs iseed)) nameid :: SAML.NameID - nameid = fromRight (error "impossible") $ do + nameid = fromRight (error ("impossible: " <> show (iseed, nseed))) $ do unqualified <- SAML.mkUNameIDEmail $ "me" <> nseed <> "@example.com" SAML.mkNameID unqualified Nothing Nothing Nothing -- | @mkSampleUref "" ""@ mkSimpleSampleUref :: SAML.UserRef mkSimpleSampleUref = mkSampleUref "" "" + +-- | Another, more basic variant of `mkSampleUref`. +mkBasicSampleUref :: Text -> Text -> SAML.UserRef +mkBasicSampleUref issuer_ nameid_ = SAML.UserRef issuer nameid + where + issuer :: SAML.Issuer + issuer = either (error . show) SAML.Issuer $ URI.parseURI URI.laxURIParserOptions (cs issuer_) + + nameid :: SAML.NameID + nameid = either error id (SAML.mkNameID unqualified Nothing Nothing Nothing) + where + unqualified = fromRight (SAML.mkUNameIDUnspecified nameid_) (SAML.mkUNameIDEmail nameid_) diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 752c608bd8..82a1816742 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -42,7 +42,7 @@ -- * Request and response types for SCIM-related endpoints. module Wire.API.User.Scim where -import Control.Lens (Prism', makeLenses, mapped, prism', (.~), (?~)) +import Control.Lens (makeLenses, mapped, (.~), (?~)) import Control.Monad.Except (throwError) import Crypto.Hash (hash) import Crypto.Hash.Algorithms (SHA512) @@ -83,10 +83,10 @@ import Web.Scim.Schema.Schema qualified as Scim import Web.Scim.Schema.User qualified as Scim import Web.Scim.Schema.User qualified as Scim.User import Wire.API.Team.Role (Role) -import Wire.API.User.Identity (Email) import Wire.API.User.Profile as BT import Wire.API.User.RichInfo qualified as RI import Wire.API.User.Saml () +import Wire.API.User.Types import Wire.Arbitrary (Arbitrary, GenericUniform (..)) ---------------------------------------------------------------------------- @@ -320,7 +320,7 @@ instance Scim.Patchable ScimUserExtra where -- and/or ignore POSTed content, returning the full representation can be useful to the -- client, enabling it to correlate the client's and server's views of the new resource." data ValidScimUser = ValidScimUser - { _vsuExternalId :: ValidExternalId, + { _vsuExternalId :: ScimUAuthId, _vsuHandle :: Handle, _vsuName :: BT.Name, _vsuRichInfo :: RI.RichInfo, @@ -330,45 +330,7 @@ data ValidScimUser = ValidScimUser } deriving (Eq, Show) --- | Note that a 'SAML.UserRef' may contain an email. Even though it is possible to construct a 'ValidExternalId' from such a 'UserRef' with 'UrefOnly', --- this does not represent a valid 'ValidExternalId'. So in case of a 'UrefOnly', we can assume that the 'UserRef' does not contain an email. -data ValidExternalId - = EmailAndUref Email SAML.UserRef - | UrefOnly SAML.UserRef - | EmailOnly Email - deriving (Eq, Show, Generic) - --- | Take apart a 'ValidExternalId', using 'SAML.UserRef' if available, otherwise 'Email'. -runValidExternalIdEither :: (SAML.UserRef -> a) -> (Email -> a) -> ValidExternalId -> a -runValidExternalIdEither doUref doEmail = \case - EmailAndUref _ uref -> doUref uref - UrefOnly uref -> doUref uref - EmailOnly em -> doEmail em - --- | Take apart a 'ValidExternalId', use both 'SAML.UserRef', 'Email' if applicable, and --- merge the result with a given function. -runValidExternalIdBoth :: (a -> a -> a) -> (SAML.UserRef -> a) -> (Email -> a) -> ValidExternalId -> a -runValidExternalIdBoth merge doUref doEmail = \case - EmailAndUref eml uref -> doUref uref `merge` doEmail eml - UrefOnly uref -> doUref uref - EmailOnly em -> doEmail em - -veidUref :: Prism' ValidExternalId SAML.UserRef -veidUref = prism' UrefOnly $ - \case - EmailAndUref _ uref -> Just uref - UrefOnly uref -> Just uref - EmailOnly _ -> Nothing - -veidEmail :: Prism' ValidExternalId Email -veidEmail = prism' EmailOnly $ - \case - EmailAndUref em _ -> Just em - UrefOnly _ -> Nothing - EmailOnly em -> Just em - makeLenses ''ValidScimUser -makeLenses ''ValidExternalId ---------------------------------------------------------------------------- -- Request and response types diff --git a/libs/wire-api/src/Wire/API/User/Test.hs b/libs/wire-api/src/Wire/API/User/Test.hs new file mode 100644 index 0000000000..bd446fd1de --- /dev/null +++ b/libs/wire-api/src/Wire/API/User/Test.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Wire.API.User.Test + ( WithSanitizedUserIdentity (..), + coherenizeNewUser, + coherenizeUser, + coherenizeUserAccount, + coherenizeUserIdentity, + coherenizeUAuthId, + ) +where + +import Data.Aeson +import Data.OpenApi +import Data.Proxy +import Imports +import Test.QuickCheck +import Wire.API.User qualified as User +import Wire.API.User.Identity qualified as User.Identity + +-- | Some `UserIdentity` values, or values of types containing `UserIdentity`, just as +-- `NewUser`, have values that can be represented in Haskell, but lead to parse errors on the +-- way back in aeson roundtrip tests. If you give a "sanitized" instance for those types +-- wrapped in `WithSanitizedUserIdentity`, you can run the roundtrip test on the wrapped type. +data WithSanitizedUserIdentity a = WithSanitizedUserIdentity a + deriving (Eq, Show) + +instance ToJSON a => ToJSON (WithSanitizedUserIdentity a) where + toJSON (WithSanitizedUserIdentity a) = toJSON a + +instance FromJSON a => FromJSON (WithSanitizedUserIdentity a) where + parseJSON = fmap WithSanitizedUserIdentity . parseJSON + +instance ToSchema a => ToSchema (WithSanitizedUserIdentity a) where + declareNamedSchema _ = declareNamedSchema (Proxy @a) + +coherenizeNewUser :: User.NewUser -> Gen User.NewUser +coherenizeNewUser = fixUAuth >=> matchOrigin + where + fixUAuth nu = do + ua' <- mapM coherenizeUserIdentity (User.newUserIdentity nu) + pure nu {User.newUserIdentity = ua'} + + matchOrigin nu = pure $ do + case (User.newUserIdentity nu, User.newUserOrigin nu) of + ( Just (User.Identity.UAuthIdentity (User.Identity.UAuthId saml scim eml tid) mbemail), + Just (User.NewUserOriginTeamUser (User.NewTeamMemberSSO tid')) + ) + | tid /= tid' -> + nu {User.newUserIdentity = Just (User.Identity.UAuthIdentity (User.Identity.UAuthId saml scim eml tid') mbemail)} + _ -> nu + +coherenizeUser :: User.User -> Gen User.User +coherenizeUser = fixUAuth >=> matchTeam + where + fixUAuth u = do + ua' <- mapM coherenizeUserIdentity (User.userIdentity u) + pure u {User.userIdentity = ua'} + + matchTeam u = pure $ do + case (User.userIdentity u, User.userTeam u) of + (Just (User.Identity.UAuthIdentity (User.Identity.UAuthId saml scim eml tid) mbemail), Just tid') + | tid /= tid' -> + u {User.userIdentity = Just (User.Identity.UAuthIdentity (User.Identity.UAuthId saml scim eml tid') mbemail)} + _ -> u + +coherenizeUserAccount :: User.UserAccount -> Gen User.UserAccount +coherenizeUserAccount (User.UserAccount u s) = User.UserAccount <$> coherenizeUser u <*> pure s + +coherenizeUserIdentity :: User.Identity.UserIdentity tf -> Gen (User.Identity.UserIdentity tf) +coherenizeUserIdentity (User.Identity.UAuthIdentity ua eml) = + (`User.Identity.UAuthIdentity` eml) <$> coherenizeUAuthId ua +coherenizeUserIdentity u = pure u + +coherenizeUAuthId :: User.PartialUAuthId -> Gen User.PartialUAuthId +coherenizeUAuthId = + nonEmptyId + >=> scimNeedsEmail + where + nonEmptyId (User.Identity.UAuthId Nothing Nothing eml tid) = do + scim <- arbitrary + pure $ User.Identity.UAuthId Nothing (Just scim) eml tid + nonEmptyId u = pure u + + scimNeedsEmail (User.Identity.UAuthId Nothing (Just scim) Nothing tid) = do + eml <- arbitrary + pure $ User.Identity.UAuthId Nothing (Just scim) (Just eml) tid + scimNeedsEmail u = pure u diff --git a/libs/wire-api/src/Wire/API/User/Types.hs b/libs/wire-api/src/Wire/API/User/Types.hs new file mode 100644 index 0000000000..6e3e257891 --- /dev/null +++ b/libs/wire-api/src/Wire/API/User/Types.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Wire.API.User.Types where + +import Data.Aeson (FromJSON, ToJSON) +import Data.ByteString.Conversion +import Data.CaseInsensitive as CI +import Data.EitherR (fmapL) +import Data.Id (TeamId) +import Data.Kind (Type) +import Data.OpenApi qualified as OA +import Data.Proxy +import Data.Schema +import Data.Text qualified as Text +import GHC.Generics +import Imports +import SAML2.WebSSO qualified as SAML +import Servant qualified as SE +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) +import URI.ByteString +import Wire.Arbitrary (GenericUniform (..)) + +-------------------------------------------------------------------------------- +-- Email + +-- FUTUREWORK: replace this type with 'EmailAddress' +data Email = Email + { emailLocal :: Text, + emailDomain :: Text + } + deriving stock (Eq, Ord, Generic) + deriving (FromJSON, ToJSON, OA.ToSchema) via Schema Email + +instance OA.ToParamSchema Email where + toParamSchema _ = OA.toParamSchema (Proxy @Text) + +instance ToSchema Email where + schema = + fromEmail + .= parsedText + "Email" + ( maybe + (Left "Invalid email. Expected '@'.") + pure + . parseEmail + ) + +instance Show Email where + show = Text.unpack . fromEmail + +instance ToByteString Email where + builder = builder . fromEmail + +instance FromByteString Email where + parser = parser >>= maybe (fail "Invalid email") pure . parseEmail + +instance SE.FromHttpApiData Email where + parseUrlPiece = maybe (Left "Invalid email") Right . fromByteString . cs + +instance SE.ToHttpApiData Email where + toUrlPiece = cs . toByteString' + +instance Arbitrary Email where + arbitrary = do + localPart <- Text.filter (/= '@') <$> arbitrary + domain <- Text.filter (/= '@') <$> arbitrary + pure $ Email localPart domain + +fromEmail :: Email -> Text +fromEmail (Email loc dom) = loc <> "@" <> dom + +-- | Parses an email address of the form @. +parseEmail :: Text -> Maybe Email +parseEmail t = case Text.split (== '@') t of + [localPart, domain] -> Just $! Email localPart domain + _ -> Nothing + +-- | in order to be able to reconstruct scim records, we need to know where in the scim record +-- the email came from. +data EmailWithSource = EmailWithSource + { ewsEmail :: Email, + ewsEmailSource :: EmailSource + } + deriving (Eq, Show, Generic) + deriving (Arbitrary) via (GenericUniform EmailWithSource) + +instance ToSchema EmailWithSource where + schema = + object "EmailWithSource" $ + EmailWithSource + <$> ewsEmail .= field "email" schema + <*> ewsEmailSource .= field "source" emailSourceSchema + +data EmailSource + = EmailFromScimExternalIdField + | EmailFromScimEmailsField + | -- | saml auto-provisioning (no scim). deprecated, but we need to support this for the foreseeable future. + EmailFromSamlNameId + deriving (Eq, Show, Bounded, Enum, Generic) + deriving (Arbitrary) via (GenericUniform EmailSource) + +emailSourceSchema :: ValueSchema NamedSwaggerDoc EmailSource +emailSourceSchema = + enum @Text "EmailSource" $ + mconcat + [ element "scim_external_id" EmailFromScimExternalIdField, + element "scim_emails" EmailFromScimEmailsField, + element "saml_name_id" EmailFromSamlNameId + ] + +-- | Konst exists to make the next set of declarations easier to write +type Konst = Const () + +-- | Collection of user ids for saml sso, scim, and required extra info (email, team id). +-- Type parameters let caller decide which fields are required (`Identity`) / optional +-- (`Maybe`) / missing and ignored (`Konst`). Team is always required, so no type parameter +-- necessary. +-- +-- Read `test/unit/Test/Wire/API/User.hs` to get some intuition of allowed values and +-- semantics. +data UAuthId (a :: Type -> Type) (b :: Type -> Type) (c :: Type -> Type) = UAuthId + { uaSamlId :: a SAML.UserRef, + uaScimExternalId :: b Text, + -- | In contrast to the `email` field in `User`, this is the email address coming from + -- SAML or SCIM. If the user has a confirmed email address stored in `User.email` and + -- gets an update here, the two will be different until reconfirmation. + uaEmail :: c EmailWithSource, + -- | Only team users support saml and/or scim. `externalId` is scoped in `teamId`, so + -- once we have parsed a scim user record, the `externalId` should never occur anywhere + -- without its `teamId`. `samlId` *could* under certain conditions be meaningful without + -- explicit `teamId`, but it's much easier to enforce it here, too. + uaTeamId :: TeamId + } + deriving (Generic) + +-- | In brig, we don't really care about these values and never have to validate them. We +-- just get them from spar, write them to the database, and later communicate them back to +-- spar or to team-management or to clients. In these contexts it's ok to allow any +-- combination of fields present. +-- +-- FUTUREWORK: make scim external id mandatory (dropping old discouraged saml-only use cases) +-- and drop `ScimUAuthId` in favor of `PartialUAuthId`. +type PartialUAuthId = UAuthId Maybe Maybe Maybe + +-- | In large parts of the application logic we know that the scim identity is strictly +-- required. +-- +-- FUTUREWORK: we should probably introduce and use more types like `ScimUAuthId`, like +-- `ScimOnlyUAuthId = UAuthId Konst Identity Identity`, ... +type ScimUAuthId = UAuthId Maybe Identity Maybe + +partialToScimUAuthId :: PartialUAuthId -> Maybe ScimUAuthId +partialToScimUAuthId (UAuthId saml (Just eid) eml tid) = Just $ UAuthId saml (Identity eid) eml tid +partialToScimUAuthId (UAuthId _ Nothing _ _) = Nothing + +scimToPartialUAuthId :: ScimUAuthId -> PartialUAuthId +scimToPartialUAuthId (UAuthId saml (Identity eid) eml tid) = UAuthId saml (Just eid) eml tid + +partialUAuthIdSchema :: ValueSchema NamedSwaggerDoc PartialUAuthId +partialUAuthIdSchema = + object "PartialUAuthId" $ + UAuthId + <$> uaSamlId .= maybe_ (optField "saml_id" userRefSchema) + <*> uaScimExternalId .= maybe_ (optField "scim_external_id" schema) + <*> uaEmail .= maybe_ (optField "email" schema) + <*> uaTeamId .= field "team" schema + +instance ToSchema PartialUAuthId where + schema = withParser partialUAuthIdSchema $ \case + UAuthId Nothing Nothing _ _ -> fail "at least one of saml_id, scim_external_id must be present" + UAuthId Nothing (Just _) Nothing _ -> fail "scim_external_id requires either email address or saml_id to be present" + ok -> pure ok + +-- | needed e.g. for parsing `UserIdentity`, where it's ok to have team id but no `UAuthId`. +optPartialUAuthIdSchema :: ValueSchemaP NamedSwaggerDoc PartialUAuthId (Maybe PartialUAuthId) +optPartialUAuthIdSchema = withParser partialUAuthIdSchema $ \case + UAuthId Nothing Nothing _ _ -> pure Nothing + UAuthId Nothing (Just _) Nothing _ -> fail "scim_external_id requires either email address or saml_id to be present" + ok -> pure $ Just ok + +instance ToSchema ScimUAuthId where + schema = + object "ScimUAuthId" $ + UAuthId + <$> uaSamlId .= maybe_ (optField "saml_id" userRefSchema) + <*> (runIdentity . uaScimExternalId) .= (Identity <$> field "scim_external_id" schema) + <*> uaEmail .= maybe_ (optField "email" schema) + <*> uaTeamId .= field "team" schema + +userRefSchema :: ValueSchema NamedSwaggerDoc SAML.UserRef +userRefSchema = + object "UserRef" $ + SAML.UserRef + <$> SAML._uidTenant .= field "tenant" issuerSchema + <*> SAML._uidSubject .= field "subject" nameIdSchema + +-- | FUTUREWORK: partially redundant, see lenientlyParseSAMLIssuer. +issuerSchema :: ValueSchema NamedSwaggerDoc SAML.Issuer +issuerSchema = rdr .= parsedText "SAML.Issuer" prs + where + rdr :: SAML.Issuer -> Text + rdr = cs . SAML.encodeElem + where + _justTxt :: SAML.Issuer -> Text + _justTxt = cs . normalizeURIRef' noNormalization . SAML._fromIssuer + + prs :: Text -> Either String SAML.Issuer + prs txt = SAML.decodeElem (cs txt) <|> justTxt txt + where + justTxt :: Text -> Either String SAML.Issuer + justTxt = fmap SAML.Issuer . fmapL show . parseURI laxURIParserOptions . cs + +-- | FUTUREWORK: partially redundant, see lenientlyParseSAMLNameID. +nameIdSchema :: ValueSchema NamedSwaggerDoc SAML.NameID +nameIdSchema = rdr .= parsedText "SAML.NameID" prs + where + rdr :: SAML.NameID -> Text + rdr = cs . SAML.encodeElem + where + _justTxt :: SAML.NameID -> Text + _justTxt = CI.original . SAML.nameIDToST + + prs :: Text -> Either String SAML.NameID + prs txt = SAML.decodeElem (cs txt) <|> justTxt txt + where + justTxt :: Text -> Either String SAML.NameID + justTxt = Right . either (const $ SAML.unspecifiedNameID txt) id . SAML.emailNameID + +deriving via (Schema (UAuthId a b c)) instance (Typeable a, Typeable b, Typeable c, ToSchema (UAuthId a b c)) => OA.ToSchema (UAuthId a b c) + +deriving via (Schema (UAuthId a b c)) instance (ToSchema (UAuthId a b c)) => ToJSON (UAuthId a b c) + +deriving via (Schema (UAuthId a b c)) instance (ToSchema (UAuthId a b c)) => FromJSON (UAuthId a b c) + +deriving via + (GenericUniform (UAuthId a b c)) + instance + (Arbitrary (a SAML.UserRef), Arbitrary (b Text), Arbitrary (c EmailWithSource)) => + Arbitrary (UAuthId a b c) + +deriving stock instance (Eq (a SAML.UserRef), Eq (b Text), Eq (c EmailWithSource)) => Eq (UAuthId a b c) + +deriving stock instance (Show (a SAML.UserRef), Show (b Text), Show (c EmailWithSource)) => Show (UAuthId a b c) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index 52cde0922b..241c3fdffe 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -963,7 +963,7 @@ tests = testGroup "Golden: Activate_user" $ testObjects [(Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_1, "testObject_Activate_user_1.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_2, "testObject_Activate_user_2.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_3, "testObject_Activate_user_3.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_4, "testObject_Activate_user_4.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_5, "testObject_Activate_user_5.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_6, "testObject_Activate_user_6.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_7, "testObject_Activate_user_7.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_8, "testObject_Activate_user_8.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_9, "testObject_Activate_user_9.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_10, "testObject_Activate_user_10.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_11, "testObject_Activate_user_11.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_12, "testObject_Activate_user_12.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_13, "testObject_Activate_user_13.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_14, "testObject_Activate_user_14.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_15, "testObject_Activate_user_15.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_16, "testObject_Activate_user_16.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_17, "testObject_Activate_user_17.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_18, "testObject_Activate_user_18.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_19, "testObject_Activate_user_19.json"), (Test.Wire.API.Golden.Generated.Activate_user.testObject_Activate_user_20, "testObject_Activate_user_20.json")], testGroup "Golden: ActivationResponse_user" $ - testObjects [(Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_1, "testObject_ActivationResponse_user_1.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_2, "testObject_ActivationResponse_user_2.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_3, "testObject_ActivationResponse_user_3.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_4, "testObject_ActivationResponse_user_4.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_5, "testObject_ActivationResponse_user_5.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_6, "testObject_ActivationResponse_user_6.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_7, "testObject_ActivationResponse_user_7.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_8, "testObject_ActivationResponse_user_8.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_9, "testObject_ActivationResponse_user_9.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_10, "testObject_ActivationResponse_user_10.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_11, "testObject_ActivationResponse_user_11.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_12, "testObject_ActivationResponse_user_12.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_13, "testObject_ActivationResponse_user_13.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_14, "testObject_ActivationResponse_user_14.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_15, "testObject_ActivationResponse_user_15.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_16, "testObject_ActivationResponse_user_16.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_17, "testObject_ActivationResponse_user_17.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_18, "testObject_ActivationResponse_user_18.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_19, "testObject_ActivationResponse_user_19.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_20, "testObject_ActivationResponse_user_20.json")], + testObjects [(Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_1, "testObject_ActivationResponse_user_1.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_2, "testObject_ActivationResponse_user_2.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_3, "testObject_ActivationResponse_user_3.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_4, "testObject_ActivationResponse_user_4.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_5, "testObject_ActivationResponse_user_5.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_6, "testObject_ActivationResponse_user_6.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_7, "testObject_ActivationResponse_user_7.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_8, "testObject_ActivationResponse_user_8.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_9, "testObject_ActivationResponse_user_9.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_10, "testObject_ActivationResponse_user_10.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_11, "testObject_ActivationResponse_user_11.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_12, "testObject_ActivationResponse_user_12.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_14, "testObject_ActivationResponse_user_14.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_15, "testObject_ActivationResponse_user_15.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_16, "testObject_ActivationResponse_user_16.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_18, "testObject_ActivationResponse_user_18.json"), (Test.Wire.API.Golden.Generated.ActivationResponse_user.testObject_ActivationResponse_user_20, "testObject_ActivationResponse_user_20.json")], testGroup "Golden: SendActivationCode_user" $ testObjects [(Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_1, "testObject_SendActivationCode_user_1.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_2, "testObject_SendActivationCode_user_2.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_3, "testObject_SendActivationCode_user_3.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_4, "testObject_SendActivationCode_user_4.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_5, "testObject_SendActivationCode_user_5.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_6, "testObject_SendActivationCode_user_6.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_7, "testObject_SendActivationCode_user_7.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_8, "testObject_SendActivationCode_user_8.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_9, "testObject_SendActivationCode_user_9.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_10, "testObject_SendActivationCode_user_10.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_11, "testObject_SendActivationCode_user_11.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_12, "testObject_SendActivationCode_user_12.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_13, "testObject_SendActivationCode_user_13.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_14, "testObject_SendActivationCode_user_14.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_15, "testObject_SendActivationCode_user_15.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_16, "testObject_SendActivationCode_user_16.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_17, "testObject_SendActivationCode_user_17.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_18, "testObject_SendActivationCode_user_18.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_19, "testObject_SendActivationCode_user_19.json"), (Test.Wire.API.Golden.Generated.SendActivationCode_user.testObject_SendActivationCode_user_20, "testObject_SendActivationCode_user_20.json")], testGroup "Golden: LoginId_user" $ diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs index b4700eaeb4..2af69d6168 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/ActivationResponse_user.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -17,29 +19,37 @@ module Test.Wire.API.Golden.Generated.ActivationResponse_user where -import Imports (Bool (False, True), Maybe (Just, Nothing)) +import Data.Id +import Imports +import SAML2.WebSSO.Types qualified as SAML +import Web.HttpApiData (parseUrlPiece) import Wire.API.User ( Email (Email, emailDomain, emailLocal), Phone (Phone, fromPhone), - UserIdentity - ( EmailIdentity, - FullIdentity, - PhoneIdentity, - SSOIdentity - ), - UserSSOId (UserSSOId, UserScimExternalId), + UserIdentity (EmailIdentity, FullIdentity, PhoneIdentity, UAuthIdentity), ) import Wire.API.User.Activation (ActivationResponse (..)) -import Wire.API.User.Identity (mkSimpleSampleUref) +import Wire.API.User.Identity (EmailSource (..), EmailWithSource (..), UAuthId (..), mkSimpleSampleUref) + +sampleUref :: SAML.UserRef +sampleUref = mkSimpleSampleUref + +sampleExtId :: Text +sampleExtId = "me@example.com" + +sampleEmail :: EmailWithSource +sampleEmail = EmailWithSource (Email "me" "example.com") EmailFromScimEmailsField + +sampleEmail2 :: Email +sampleEmail2 = Email "other" "2.example.com" + +sampleTeamId :: TeamId +Right sampleTeamId = parseUrlPiece "579edcd0-6f1b-11ee-b49a-e770ab99392a" testObject_ActivationResponse_user_1 :: ActivationResponse testObject_ActivationResponse_user_1 = ActivationResponse - { activatedIdentity = - SSOIdentity - (UserSSOId mkSimpleSampleUref) - (Just (Email {emailLocal = "\165918\rZ\a\ESC", emailDomain = "p\131777\62344"})) - Nothing, + { activatedIdentity = UAuthIdentity (UAuthId (Just sampleUref) Nothing (Just sampleEmail) sampleTeamId) (Just sampleEmail2), activatedFirst = False } @@ -74,7 +84,7 @@ testObject_ActivationResponse_user_5 = testObject_ActivationResponse_user_6 :: ActivationResponse testObject_ActivationResponse_user_6 = ActivationResponse - { activatedIdentity = SSOIdentity (UserScimExternalId "\an|") Nothing Nothing, + { activatedIdentity = UAuthIdentity (UAuthId Nothing (Just sampleExtId) (Just sampleEmail) sampleTeamId) Nothing, activatedFirst = False } @@ -121,21 +131,10 @@ testObject_ActivationResponse_user_12 = activatedFirst = False } -testObject_ActivationResponse_user_13 :: ActivationResponse -testObject_ActivationResponse_user_13 = - ActivationResponse - { activatedIdentity = SSOIdentity (UserScimExternalId "#") Nothing (Just (Phone {fromPhone = "+6124426658"})), - activatedFirst = False - } - testObject_ActivationResponse_user_14 :: ActivationResponse testObject_ActivationResponse_user_14 = ActivationResponse - { activatedIdentity = - SSOIdentity - (UserScimExternalId "\NUL\US\ETBY") - (Just (Email {emailLocal = "\66022", emailDomain = "\a\1081391"})) - Nothing, + { activatedIdentity = UAuthIdentity (UAuthId Nothing (Just "me") (Just sampleEmail) sampleTeamId) (Just sampleEmail2), activatedFirst = False } @@ -151,28 +150,10 @@ testObject_ActivationResponse_user_16 = activatedFirst = False } -testObject_ActivationResponse_user_17 :: ActivationResponse -testObject_ActivationResponse_user_17 = - ActivationResponse - { activatedIdentity = - SSOIdentity - (UserScimExternalId "") - (Just (Email {emailLocal = "\155143", emailDomain = "+)"})) - (Just (Phone {fromPhone = "+703448141"})), - activatedFirst = True - } - testObject_ActivationResponse_user_18 :: ActivationResponse testObject_ActivationResponse_user_18 = ActivationResponse {activatedIdentity = PhoneIdentity (Phone {fromPhone = "+974462685543005"}), activatedFirst = True} -testObject_ActivationResponse_user_19 :: ActivationResponse -testObject_ActivationResponse_user_19 = - ActivationResponse - { activatedIdentity = SSOIdentity (UserSSOId mkSimpleSampleUref) (Just (Email {emailLocal = "R", emailDomain = "K"})) Nothing, - activatedFirst = False - } - testObject_ActivationResponse_user_20 :: ActivationResponse testObject_ActivationResponse_user_20 = ActivationResponse diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs index d596164f75..e6f0ae3a6b 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUser_user.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- @@ -25,7 +26,7 @@ import Data.ISO3166_CountryCodes ( LY ), ) -import Data.Id (Id (Id, toUUID)) +import Data.Id import Data.LanguageCodes qualified ( ISO639_1 ( SN @@ -35,7 +36,8 @@ import Data.Misc (plainTextPassword8Unsafe) import Data.Range (unsafeRange) import Data.Text.Ascii (AsciiChars (validate)) import Data.UUID qualified as UUID (fromString) -import Imports (Maybe (Just, Nothing), fromJust, fromRight, undefined, (.)) +import Imports +import Web.HttpApiData (parseUrlPiece) import Wire.API.Asset import Wire.API.Team (BindingNewTeam (..), Icon (..), NewTeam (..)) import Wire.API.User @@ -54,16 +56,15 @@ import Wire.API.User NewUser (..), NewUserOrigin (..), Pict (Pict, fromPict), - UserIdentity - ( EmailIdentity, - PhoneIdentity, - SSOIdentity - ), + UserIdentity (EmailIdentity, PhoneIdentity, UAuthIdentity), emptyNewUser, ) import Wire.API.User.Activation (ActivationCode (ActivationCode, fromActivationCode)) import Wire.API.User.Auth (CookieLabel (CookieLabel, cookieLabelText)) -import Wire.API.User.Identity (Phone (..), UserSSOId (UserSSOId), mkSimpleSampleUref) +import Wire.API.User.Identity (Phone (..), UAuthId (..), mkSimpleSampleUref) + +sampleTeamId :: TeamId +Right sampleTeamId = parseUrlPiece "579edcd0-6f1b-11ee-b49a-e770ab99392a" testObject_NewUser_user_1 :: NewUser testObject_NewUser_user_1 = @@ -142,11 +143,9 @@ testObject_NewUser_user_6 = ( emptyNewUser (Name {fromName = "test name"}) ) - { newUserOrigin = Just (NewUserOriginTeamUser (NewTeamMemberSSO tid)), - newUserIdentity = Just (SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing Nothing) + { newUserOrigin = Just (NewUserOriginTeamUser (NewTeamMemberSSO sampleTeamId)), + newUserIdentity = Just (UAuthIdentity (UAuthId (Just mkSimpleSampleUref) Nothing Nothing sampleTeamId) Nothing) } - where - tid = Id (fromJust (UUID.fromString "00007b0e-0000-3489-0000-075c00005be7")) testObject_NewUser_user_7 :: NewUser testObject_NewUser_user_7 = diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserSSOId_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserSSOId_user.hs index 688a1d5374..d466d80e26 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserSSOId_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserSSOId_user.hs @@ -17,14 +17,14 @@ module Test.Wire.API.Golden.Generated.UserSSOId_user where -import Wire.API.User (UserSSOId (..)) +import Wire.API.User (LegacyUserSSOId (..)) import Wire.API.User.Identity (mkSimpleSampleUref) -testObject_UserSSOId_user_2 :: UserSSOId +testObject_UserSSOId_user_2 :: LegacyUserSSOId testObject_UserSSOId_user_2 = UserSSOId mkSimpleSampleUref -testObject_UserSSOId_user_9 :: UserSSOId +testObject_UserSSOId_user_9 :: LegacyUserSSOId testObject_UserSSOId_user_9 = UserScimExternalId "\r\1074376iua\1008736M\138936\v" -testObject_UserSSOId_user_13 :: UserSSOId +testObject_UserSSOId_user_13 :: LegacyUserSSOId testObject_UserSSOId_user_13 = UserScimExternalId "" diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs index 439e3c220d..5efbaffa6e 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/User_user.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- @@ -29,7 +30,7 @@ import Data.ISO3166_CountryCodes UA ), ) -import Data.Id (Id (Id)) +import Data.Id import Data.Json.Util (readUTCTimeMillis) import Data.LanguageCodes qualified ( ISO639_1 @@ -42,10 +43,20 @@ import Data.LanguageCodes qualified import Data.Qualified (Qualified (Qualified, qDomain, qUnqualified)) import Data.UUID qualified as UUID (fromString) import Imports +import Web.HttpApiData (parseUrlPiece) import Wire.API.Asset import Wire.API.Provider.Service (ServiceRef (ServiceRef, _serviceRefId, _serviceRefProvider)) import Wire.API.User +sampleExtId :: Text +sampleExtId = "it" + +sampleEmail :: EmailWithSource +sampleEmail = EmailWithSource (Email "it" "example.com") EmailFromScimEmailsField + +sampleTeamId :: TeamId +Right sampleTeamId = parseUrlPiece "579edcd0-6f1b-11ee-b49a-e770ab99392a" + testObject_User_user_1 :: User testObject_User_user_1 = User @@ -149,7 +160,7 @@ testObject_User_user_4 = qDomain = Domain {_domainText = "28b.cqb"} }, userIdentity = - Just (SSOIdentity (UserScimExternalId "") (Just (Email {emailLocal = "", emailDomain = ""})) Nothing), + Just (UAuthIdentity (UAuthId Nothing (Just sampleExtId) (Just sampleEmail) sampleTeamId) Nothing), userDisplayName = Name { fromName = @@ -175,7 +186,7 @@ testObject_User_user_4 = } ), userExpire = Just (fromJust (readUTCTimeMillis "1864-05-09T14:25:26.089Z")), - userTeam = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002"))), + userTeam = Just sampleTeamId, userManagedBy = ManagedByScim, userSupportedProtocols = defSupportedProtocols } diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs index 6a8e528ad2..d37c76a9b5 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual.hs @@ -33,6 +33,7 @@ import Test.Wire.API.Golden.Manual.FeatureConfigEvent import Test.Wire.API.Golden.Manual.FederationStatus import Test.Wire.API.Golden.Manual.GetPaginatedConversationIds import Test.Wire.API.Golden.Manual.GroupId +import Test.Wire.API.Golden.Manual.Identity import Test.Wire.API.Golden.Manual.ListConversations import Test.Wire.API.Golden.Manual.ListUsersById import Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap @@ -49,7 +50,26 @@ tests :: TestTree tests = testGroup "Manual golden tests" - [ testGroup "UserClientPrekeyMap" $ + [ testGroup "PartialUAuthId" $ + testObjects + [ (testObject_UAuthId_1, "testObject_UAuthId_1.json"), + (testObject_UAuthId_2, "testObject_UAuthId_2.json"), + (testObject_UAuthId_3, "testObject_UAuthId_3.json"), + (testObject_UAuthId_4, "testObject_UAuthId_4.json") + ], + testGroup "ScimUAuthId" $ + testObjects + [ (testObject_UAuthId_5, "testObject_UAuthId_5.json"), + (testObject_UAuthId_6, "testObject_UAuthId_6.json") + ], + testGroup "UserIdentity" $ + testObjects + [ (testObject_UserIdentity_1, "testObject_UserIdentity_1.json"), + (testObject_UserIdentity_2, "testObject_UserIdentity_2.json"), + (testObject_UserIdentity_3, "testObject_UserIdentity_3.json"), + (testObject_UserIdentity_4, "testObject_UserIdentity_4.json") + ], + testGroup "UserClientPrekeyMap" $ testObjects [ (testObject_UserClientPrekeyMap_1, "testObject_UserClientPrekeyMap_1.json"), (testObject_UserClientPrekeyMap_2, "testObject_UserClientPrekeyMap_2.json"), diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Identity.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Identity.hs new file mode 100644 index 0000000000..a51d8d0a2d --- /dev/null +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Manual/Identity.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-orphans #-} + +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- This program is free software: you can redistribute it and/or modify it under +-- the terms of the GNU Affero General Public License as published by the Free +-- Software Foundation, either version 3 of the License, or (at your option) any +-- later version. +-- +-- This program is distributed in the hope that it will be useful, but WITHOUT +-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more +-- details. +-- +-- You should have received a copy of the GNU Affero General Public License along +-- with this program. If not, see . + +module Test.Wire.API.Golden.Manual.Identity + ( testObject_UAuthId_1, + testObject_UAuthId_2, + testObject_UAuthId_3, + testObject_UAuthId_4, + testObject_UAuthId_5, + testObject_UAuthId_6, + testObject_UserIdentity_1, + testObject_UserIdentity_2, + testObject_UserIdentity_3, + testObject_UserIdentity_4, + ) +where + +import Data.Aeson +import Data.Id +import Data.Schema +import GHC.TypeLits +import Imports +import SAML2.WebSSO.Types qualified as SAML +import Web.HttpApiData (parseUrlPiece) +import Wire.API.User.Identity + +sampleUref :: SAML.UserRef +sampleUref = mkSampleUref "http://example.com" "it" + +sampleExtId :: Text +sampleExtId = "it" + +sampleEmail :: EmailWithSource +sampleEmail = EmailWithSource (Email "it" "example.com") EmailFromScimEmailsField + +sampleEmail2 :: Email +sampleEmail2 = Email "it2" "example.com" + +samplePhone :: Phone +samplePhone = Phone "+1123123123" + +sampleTeamId :: TeamId +Right sampleTeamId = parseUrlPiece "579edcd0-6f1b-11ee-b49a-e770ab99392a" + +testObject_UAuthId_1 :: PartialUAuthId +testObject_UAuthId_1 = UAuthId Nothing (Just sampleExtId) (Just sampleEmail) sampleTeamId + +testObject_UAuthId_2 :: PartialUAuthId +testObject_UAuthId_2 = UAuthId (Just sampleUref) Nothing Nothing sampleTeamId + +testObject_UAuthId_3 :: PartialUAuthId +testObject_UAuthId_3 = UAuthId (Just sampleUref) (Just sampleExtId) Nothing sampleTeamId + +testObject_UAuthId_4 :: PartialUAuthId +testObject_UAuthId_4 = UAuthId (Just sampleUref) (Just sampleExtId) (Just sampleEmail) sampleTeamId + +testObject_UAuthId_5 :: ScimUAuthId +testObject_UAuthId_5 = UAuthId (Just sampleUref) (Identity sampleExtId) (Just sampleEmail) sampleTeamId + +testObject_UAuthId_6 :: ScimUAuthId +testObject_UAuthId_6 = UAuthId Nothing (Identity sampleExtId) (Just sampleEmail) sampleTeamId + +testObject_UserIdentity_1 :: UserIdentity "team_id" +testObject_UserIdentity_1 = EmailIdentity (ewsEmail sampleEmail) + +testObject_UserIdentity_2 :: UserIdentity "team_id" +testObject_UserIdentity_2 = PhoneIdentity samplePhone + +testObject_UserIdentity_3 :: UserIdentity "team_id" +testObject_UserIdentity_3 = FullIdentity (ewsEmail sampleEmail) samplePhone + +testObject_UserIdentity_4 :: UserIdentity "team_id" +testObject_UserIdentity_4 = UAuthIdentity testObject_UAuthId_4 (Just sampleEmail2) + +-- | This type is usually embedded in a bigger record, but this instance is handy for testing. +instance KnownSymbol tf => ToSchema (UserIdentity tf) where + schema = Data.Schema.object "UserIdentity" (userIdentityObjectSchema @tf) + +deriving via (Schema (UserIdentity tf)) instance KnownSymbol tf => ToJSON (UserIdentity tf) + +deriving via (Schema (UserIdentity tf)) instance KnownSymbol tf => FromJSON (UserIdentity tf) diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_1.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_1.json index 1506d78440..ad219130c6 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_1.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_1.json @@ -1,8 +1,19 @@ { - "email": "𨠞\rZ\u0007\u001b@p𠋁", - "first": false, - "sso_id": { - "subject": "me@example.com", - "tenant": "http://example.com/" - } + "email": "other@2.example.com", + "first": false, + "uauth_id": { + "email": { + "email": "me@example.com", + "source": "scim_emails" + }, + "saml_id": { + "subject": "me@example.com", + "tenant": "http://example.com/" + }, + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" + }, + "sso_id": { + "subject": "me@example.com", + "tenant": "http://example.com/" + } } diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_14.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_14.json index 1b07775521..8da0b22fd3 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_14.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_14.json @@ -1,7 +1,15 @@ { - "email": "𐇦@\u0007􈀯", + "email": "other@2.example.com", "first": false, "sso_id": { - "scim_external_id": "\u0000\u001f\u0017Y" + "scim_external_id": "me" + }, + "uauth_id": { + "email": { + "email": "me@example.com", + "source": "scim_emails" + }, + "scim_external_id": "me", + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" } } diff --git a/libs/wire-api/test/golden/testObject_ActivationResponse_user_6.json b/libs/wire-api/test/golden/testObject_ActivationResponse_user_6.json index 3a3ade7e9e..5861b17a52 100644 --- a/libs/wire-api/test/golden/testObject_ActivationResponse_user_6.json +++ b/libs/wire-api/test/golden/testObject_ActivationResponse_user_6.json @@ -1,6 +1,14 @@ { "first": false, "sso_id": { - "scim_external_id": "\u0007n|" + "scim_external_id": "me@example.com" + }, + "uauth_id": { + "email": { + "email": "me@example.com", + "source": "scim_emails" + }, + "scim_external_id": "me@example.com", + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" } } diff --git a/libs/wire-api/test/golden/testObject_NewUser_user_6.json b/libs/wire-api/test/golden/testObject_NewUser_user_6.json index 158591955d..7e0d0516bf 100644 --- a/libs/wire-api/test/golden/testObject_NewUser_user_6.json +++ b/libs/wire-api/test/golden/testObject_NewUser_user_6.json @@ -5,5 +5,12 @@ "subject": "me@example.com", "tenant": "http://example.com/" }, - "team_id": "00007b0e-0000-3489-0000-075c00005be7" + "team_id": "579edcd0-6f1b-11ee-b49a-e770ab99392a", + "uauthid": { + "saml_id": { + "subject": "me@example.com", + "tenant": "http://example.com/" + }, + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" + } } diff --git a/libs/wire-api/test/golden/testObject_UAuthId_1.json b/libs/wire-api/test/golden/testObject_UAuthId_1.json new file mode 100644 index 0000000000..30b9eea775 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UAuthId_1.json @@ -0,0 +1,8 @@ +{ + "email": { + "email": "it@example.com", + "source": "scim_emails" + }, + "scim_external_id": "it", + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" +} diff --git a/libs/wire-api/test/golden/testObject_UAuthId_2.json b/libs/wire-api/test/golden/testObject_UAuthId_2.json new file mode 100644 index 0000000000..5cf28c9d37 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UAuthId_2.json @@ -0,0 +1,7 @@ +{ + "saml_id": { + "subject": "meit@example.com", + "tenant": "http://example.com/http://example.com" + }, + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" +} diff --git a/libs/wire-api/test/golden/testObject_UAuthId_3.json b/libs/wire-api/test/golden/testObject_UAuthId_3.json new file mode 100644 index 0000000000..14131301b1 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UAuthId_3.json @@ -0,0 +1,8 @@ +{ + "saml_id": { + "subject": "meit@example.com", + "tenant": "http://example.com/http://example.com" + }, + "scim_external_id": "it", + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" +} diff --git a/libs/wire-api/test/golden/testObject_UAuthId_4.json b/libs/wire-api/test/golden/testObject_UAuthId_4.json new file mode 100644 index 0000000000..4df9ccdf0a --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UAuthId_4.json @@ -0,0 +1,12 @@ +{ + "email": { + "email": "it@example.com", + "source": "scim_emails" + }, + "saml_id": { + "subject": "meit@example.com", + "tenant": "http://example.com/http://example.com" + }, + "scim_external_id": "it", + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" +} diff --git a/libs/wire-api/test/golden/testObject_UAuthId_5.json b/libs/wire-api/test/golden/testObject_UAuthId_5.json new file mode 100644 index 0000000000..4df9ccdf0a --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UAuthId_5.json @@ -0,0 +1,12 @@ +{ + "email": { + "email": "it@example.com", + "source": "scim_emails" + }, + "saml_id": { + "subject": "meit@example.com", + "tenant": "http://example.com/http://example.com" + }, + "scim_external_id": "it", + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" +} diff --git a/libs/wire-api/test/golden/testObject_UAuthId_6.json b/libs/wire-api/test/golden/testObject_UAuthId_6.json new file mode 100644 index 0000000000..30b9eea775 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UAuthId_6.json @@ -0,0 +1,8 @@ +{ + "email": { + "email": "it@example.com", + "source": "scim_emails" + }, + "scim_external_id": "it", + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" +} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_1.json b/libs/wire-api/test/golden/testObject_UserIdentity_1.json new file mode 100644 index 0000000000..9822a86f95 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UserIdentity_1.json @@ -0,0 +1,3 @@ +{ + "email": "it@example.com" +} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_2.json b/libs/wire-api/test/golden/testObject_UserIdentity_2.json new file mode 100644 index 0000000000..dc0802fd2b --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UserIdentity_2.json @@ -0,0 +1,3 @@ +{ + "phone": "+1123123123" +} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_3.json b/libs/wire-api/test/golden/testObject_UserIdentity_3.json new file mode 100644 index 0000000000..0cd4a28c1e --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UserIdentity_3.json @@ -0,0 +1,4 @@ +{ + "email": "it@example.com", + "phone": "+1123123123" +} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_4.json b/libs/wire-api/test/golden/testObject_UserIdentity_4.json new file mode 100644 index 0000000000..f7ca760851 --- /dev/null +++ b/libs/wire-api/test/golden/testObject_UserIdentity_4.json @@ -0,0 +1,19 @@ +{ + "email": "it2@example.com", + "sso_id": { + "subject": "meit@example.com", + "tenant": "http://example.com/http://example.com" + }, + "uauth_id": { + "email": { + "email": "it@example.com", + "source": "scim_emails" + }, + "saml_id": { + "subject": "meit@example.com", + "tenant": "http://example.com/http://example.com" + }, + "scim_external_id": "it", + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" + } +} diff --git a/libs/wire-api/test/golden/testObject_User_user_4.json b/libs/wire-api/test/golden/testObject_User_user_4.json index 612526358e..594e9dc3a5 100644 --- a/libs/wire-api/test/golden/testObject_User_user_4.json +++ b/libs/wire-api/test/golden/testObject_User_user_4.json @@ -1,7 +1,6 @@ { "accent_id": 0, "assets": [], - "email": "@", "expires_at": "1864-05-09T14:25:26.089Z", "handle": "iw2-.udd2l7-7yg3dfg.wzn4vx3hjhch8.--5t6uyjqk93twv-a2pce8p1xjh7387nztzu.q", "id": "00000002-0000-0001-0000-000100000002", @@ -18,10 +17,18 @@ "provider": "00000000-0000-0000-0000-000000000000" }, "sso_id": { - "scim_external_id": "" + "scim_external_id": "it" + }, + "uauth_id": { + "scim_external_id": "it", + "email": { + "email": "it@example.com", + "source": "scim_emails" + }, + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" }, "supported_protocols": [ "proteus" ], - "team": "00000000-0000-0000-0000-000100000002" + "team": "579edcd0-6f1b-11ee-b49a-e770ab99392a" } diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index aefaa6cb8c..8bd2950668 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . +{-# OPTIONS_GHC -Wno-orphans #-} module Test.Wire.API.Roundtrip.Aeson (tests) where @@ -23,7 +24,7 @@ import Data.Id (ConvId) import Data.OpenApi (ToSchema, validatePrettyToJSON) import Imports import Test.Tasty qualified as T -import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (.&&.), (===)) +import Test.Tasty.QuickCheck (Arbitrary (..), counterexample, testProperty, (.&&.), (===)) import Type.Reflection (typeRep) import Wire.API.Asset qualified as Asset import Wire.API.Call.Config qualified as Call.Config @@ -74,6 +75,7 @@ import Wire.API.User.Profile qualified as User.Profile import Wire.API.User.RichInfo qualified as User.RichInfo import Wire.API.User.Scim qualified as Scim import Wire.API.User.Search qualified as User.Search +import Wire.API.User.Test import Wire.API.Wrapped qualified as Wrapped -- FUTUREWORK(#1446): fix tests marked as failing @@ -243,14 +245,14 @@ tests = testRoundTrip @Team.SearchVisibility.TeamSearchVisibility, testRoundTrip @Team.SearchVisibility.TeamSearchVisibilityView, testRoundTrip @User.NameUpdate, - testRoundTrip @User.NewUser, + testRoundTrip @(WithSanitizedUserIdentity User.NewUser), testRoundTrip @User.NewUserPublic, testRoundTrip @User.UserIdList, testRoundTrip @(User.LimitedQualifiedUserIdList 20), testRoundTrip @User.UserProfile, - testRoundTrip @User.User, + testRoundTrip @(WithSanitizedUserIdentity User.User), testRoundTrip @User.UserSet, - testRoundTrip @User.SelfProfile, + testRoundTrip @(WithSanitizedUserIdentity User.SelfProfile), testRoundTrip @User.InvitationCode, testRoundTrip @User.BindingNewTeamUser, -- FUTUREWORK: this should probably be tested individually, @@ -273,7 +275,7 @@ tests = -- testRoundTrip @User.Activation.ActivationTarget, testRoundTrip @User.Activation.ActivationCode, testRoundTrip @User.Activation.Activate, - testRoundTrip @User.Activation.ActivationResponse, + testRoundTrip @(WithSanitizedUserIdentity User.Activation.ActivationResponse), testRoundTrip @User.Activation.SendActivationCode, testRoundTrip @User.Auth.LoginId, testRoundTrip @User.Auth.LoginCode, @@ -310,7 +312,8 @@ tests = testRoundTrip @User.Handle.CheckHandles, testRoundTrip @User.Identity.Email, testRoundTrip @User.Identity.Phone, - testRoundTrip @User.Identity.UserSSOId, + testRoundTrip @User.Identity.LegacyUserSSOId, + testRoundTrip @(WithSanitizedUserIdentity User.Identity.PartialUAuthId), testRoundTrip @User.Password.NewPasswordReset, testRoundTrip @User.Password.PasswordResetKey, -- FUTUREWORK: this should probably be tested individually, @@ -371,3 +374,26 @@ testRoundTripWithSwagger = testProperty msg (trip .&&. scm) validatePrettyToJSON v ) $ isNothing (validatePrettyToJSON v) + +instance Arbitrary (WithSanitizedUserIdentity User.NewUser) where + arbitrary = (arbitrary >>= coherenizeNewUser) <&> WithSanitizedUserIdentity + +instance Arbitrary (WithSanitizedUserIdentity User.User) where + arbitrary = (arbitrary >>= coherenizeUser) <&> WithSanitizedUserIdentity + +instance Arbitrary (WithSanitizedUserIdentity User.SelfProfile) where + arbitrary = + ( arbitrary >>= \(User.SelfProfile u) -> + User.SelfProfile <$> coherenizeUser u + ) + <&> WithSanitizedUserIdentity + +instance Arbitrary (WithSanitizedUserIdentity User.Activation.ActivationResponse) where + arbitrary = + ( arbitrary >>= \(User.Activation.ActivationResponse ui af) -> + (`User.Activation.ActivationResponse` af) <$> coherenizeUserIdentity ui + ) + <&> WithSanitizedUserIdentity + +instance Arbitrary (WithSanitizedUserIdentity User.Identity.PartialUAuthId) where + arbitrary = (arbitrary >>= coherenizeUAuthId) <&> WithSanitizedUserIdentity diff --git a/libs/wire-api/test/unit/Test/Wire/API/User.hs b/libs/wire-api/test/unit/Test/Wire/API/User.hs index 98b7745b61..7ade86ffd7 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/User.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/User.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- @@ -19,14 +21,16 @@ module Test.Wire.API.User where +import Control.Lens (Lens', (?~), _1, _2, _3, _4, _5, _6) import Data.Aeson import Data.Aeson qualified as Aeson -import Data.Aeson.Types as Aeson +import Data.Aeson.QQ (aesonQQ) +import Data.Aeson.Types qualified as Aeson import Data.Domain import Data.Id import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldNoConsent)) import Data.Qualified -import Data.Schema (schemaIn) +import Data.Schema (schema, schemaIn) import Data.UUID.V4 qualified as UUID import Imports import Test.Tasty @@ -54,36 +58,370 @@ testUserProfile = do parseIdentityTests :: [TestTree] parseIdentityTests = - [ let (=#=) :: Either String (Maybe UserIdentity) -> [Pair] -> Assertion - (=#=) uid (object -> Object obj) = assertEqual "=#=" uid (parseEither (schemaIn maybeUserIdentityObjectSchema) obj) - (=#=) _ bad = error $ "=#=: impossible: " <> show bad - in testGroup - "parseIdentity" - [ testCase "FullIdentity" $ - Right (Just (FullIdentity hemail hphone)) =#= [email, phone], - testCase "EmailIdentity" $ - Right (Just (EmailIdentity hemail)) =#= [email], - testCase "PhoneIdentity" $ - Right (Just (PhoneIdentity hphone)) =#= [phone], - testCase "SSOIdentity" $ do - Right (Just (SSOIdentity hssoid Nothing Nothing)) =#= [ssoid] - Right (Just (SSOIdentity hssoid Nothing (Just hphone))) =#= [ssoid, phone] - Right (Just (SSOIdentity hssoid (Just hemail) Nothing)) =#= [ssoid, email] - Right (Just (SSOIdentity hssoid (Just hemail) (Just hphone))) =#= [ssoid, email, phone], - testCase "Bad phone" $ - Left "Error in $.phone: Invalid phone number. Expected E.164 format." =#= [badphone], - testCase "Bad email" $ - Left "Error in $.email: Invalid email. Expected '@'." =#= [bademail], - testCase "Nothing" $ - Right Nothing =#= [("something_unrelated", "#")] - ] + [ testGroup + "parse UserIdentity: {Email,Phone,Full}Identity" + [ testCase "FullIdentity" $ + [("email", "me@example.com"), ("phone", "+493012345678")] + =#= Right (Just (FullIdentity (Email "me" "example.com") (Phone "+493012345678"))), + testCase "EmailIdentity" $ + [("email", "me@example.com")] + =#= Right (Just (EmailIdentity (Email "me" "example.com"))), + testCase "PhoneIdentity" $ + [("phone", "+493012345678")] + =#= Right (Just (PhoneIdentity (Phone "+493012345678"))), + testCase "Bad phone" $ + [("phone", "__@@")] + =#= Left "Error in $.phone: Invalid phone number. Expected E.164 format.", + testCase "Bad email" $ + [("email", "justme")] + =#= Left "Error in $.email: Invalid email. Expected '@'.", + testCase "Nothing" $ + [("something_unrelated", "#")] + =#= Right Nothing + ], + testGroup + "parse UAuthId" + [ -- {} + let jsonIn = [aesonQQ|{}|] + err = "Error in $: key \"team\" not found" + in mkUAuthIdTestCase "1" jsonIn err, + -- {email, team} + let jsonIn = + [aesonQQ|{"email": {"email": "me@example.com", "source": "scim_emails"}, + "team": "226923f0-6f15-11ee-96bd-33644427c814"}|] + err = "Error in $: at least one of saml_id, scim_external_id must be present" + in mkUAuthIdTestCase "2" jsonIn err, + -- {eid, team} + let jsonIn = + [aesonQQ|{"scim_external_id": "me@example.com", + "team": "226923f0-6f15-11ee-96bd-33644427c814"}|] + err = "Error in $: scim_external_id requires either email address or saml_id to be present" + in mkUAuthIdTestCase "3" jsonIn err + ], + testGroup + "eUserIdentityFromComponents: error cases" + [ testCase "UserIdentityFromComponentsNoFields" $ do + (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) =###= UserIdentityFromComponentsNoFields + (Nothing, Nothing, Nothing, Nothing, Nothing, Just ManagedByWire) =###= UserIdentityFromComponentsNoFields + (Nothing, Nothing, Nothing, Nothing, Just tid, Nothing) =###= UserIdentityFromComponentsNoFields + (Nothing, Nothing, Nothing, Nothing, Nothing, Just ManagedByWire) =###= UserIdentityFromComponentsNoFields, + testCase "UserIdentityFromComponentsNoPhoneAllowedForUAuthId" $ do + (Nothing, Just phn1, Just (UAuthId Nothing (Just eid1) (Just ews1) tid), Nothing, Just tid, Nothing) =###= UserIdentityFromComponentsNoPhoneAllowedForUAuthId + (Nothing, Just phn1, Nothing, Just (UserSSOId uref1), Just tid, Nothing) =###= UserIdentityFromComponentsNoPhoneAllowedForUAuthId, + testCase "UserIdentityFromComponentsUAuthIdWithoutTeam" $ do + -- NB: (Nothing, Nothing, Just (UAuthId Nothing (Just eid1) (Just ews1) tid), Nothing, Nothing, Nothing) is fine, we already have a team id! + (Nothing, Nothing, Nothing, Just (UserSSOId uref1), Nothing, Nothing) =###= UserIdentityFromComponentsUAuthIdWithoutTeam, + testCase "UserIdentityFromComponentsUAuthIdTeamMismatch" $ do + (Nothing, Nothing, Just (UAuthId Nothing (Just eid1) (Just ews1) tid), Nothing, Just tid2, Nothing) =###= UserIdentityFromComponentsUAuthIdTeamMismatch + ], + testGroup + "parse Identity: UAuthIdentity" + $ flip fmap [Nothing, Just email1, Just email2] + $ \mbBrigEmail -> + testGroup ("brig email: " <> show mbBrigEmail) $ + [ -- {eid, email, team} + let jsonIn = + [ ( "uauth_id", + [aesonQQ|{"scim_external_id": "me@example.com", + "email": {"email": "me@example.com", "source": "scim_external_id"}, + "team": "226923f0-6f15-11ee-96bd-33644427c814"}|] + ) + ] + haskellIn = Right uaid + jsonOut = jsonIn <> [("sso_id", [aesonQQ|{"scim_external_id": "me@example.com"}|])] + uaid = UAuthId Nothing (Just eid1) (Just ews1) tid + in mkUAuthIdentityTestCase "4" jsonIn haskellIn jsonOut mbBrigEmail, + let jsonIn = + [ ( "uauth_id", + [aesonQQ|{"scim_external_id": "nick", + "email": {"email": "other@example.com", "source": "scim_emails"}, + "team": "226923f0-6f15-11ee-96bd-33644427c814"}|] + ) + ] + haskellIn = Right uaid + jsonOut = jsonIn <> [("sso_id", [aesonQQ|{"scim_external_id": "nick"}|])] + uaid = UAuthId Nothing (Just eid3) (Just ews3) tid + in mkUAuthIdentityTestCase "4.1" jsonIn haskellIn jsonOut mbBrigEmail, + -- {saml, team} + let jsonIn = + [ ( "uauth_id", + [aesonQQ|{"saml_id": { + "subject": "me@example.com", + "tenant": "http://example.com/wef" + }, + "team": "226923f0-6f15-11ee-96bd-33644427c814"}|] + ) + ] + haskellIn = Right uaid + jsonOut = + jsonIn + <> [ ( "sso_id", + [aesonQQ|{"subject": "me@example.com", + "tenant": "http://example.com/wef" + }|] + ) + ] + uaid = UAuthId (Just uref1) Nothing Nothing tid + in mkUAuthIdentityTestCase "5" jsonIn haskellIn jsonOut mbBrigEmail, + -- {saml, email, team} + let jsonIn = + [ ( "uauth_id", + [aesonQQ|{"saml_id": { + "subject": "me@example.com", + "tenant": "http://example.com/wef" + }, + "email": {"email": "me@example.com", "source": "scim_external_id"}, + "team": "226923f0-6f15-11ee-96bd-33644427c814"}|] + ) + ] + haskellIn = Right uaid + jsonOut = + jsonIn + <> [ ( "sso_id", + [aesonQQ|{"subject": "me@example.com", + "tenant": "http://example.com/wef" + }|] + ) + ] + uaid = UAuthId (Just uref1) Nothing (Just ews1) tid + in mkUAuthIdentityTestCase "6" jsonIn haskellIn jsonOut mbBrigEmail, + -- {saml, eid, team} + let jsonIn = + [ ( "uauth_id", + [aesonQQ|{"scim_external_id": "nick", + "saml_id": { + "subject": "nick", + "tenant": "http://example.com/wef" + }, + "email": {"email": "other@example.com", "source": "scim_emails"}, + "team": "226923f0-6f15-11ee-96bd-33644427c814"}|] + ) + ] + haskellIn = Right uaid + jsonOut = + jsonIn + <> [ ( "sso_id", + [aesonQQ|{"subject": "nick", + "tenant": "http://example.com/wef" }|] + ) + ] + uaid = UAuthId (Just uref3) (Just "nick") (Just ews3) tid + in mkUAuthIdentityTestCase "7" jsonIn haskellIn jsonOut mbBrigEmail, + let jsonIn = + [ ( "uauth_id", + [aesonQQ|{"scim_external_id": "nick", + "saml_id": { + "subject": "nick", + "tenant": "http://example.com/wef" + }, + "email": {"email": "other@example.com", "source": "scim_emails"}, + "team": "226923f0-6f15-11ee-96bd-33644427c814"}|] + ) + ] + haskellIn = Right uaid + jsonOut = + jsonIn + <> [ ( "sso_id", + [aesonQQ|{"subject": "nick", + "tenant": "http://example.com/wef" }|] + ) + ] + uaid = UAuthId (Just uref3) (Just eid3) (Just ews3) tid + in mkUAuthIdentityTestCase "7.1" jsonIn haskellIn jsonOut mbBrigEmail, + -- {saml, eid, email, team} + let jsonIn = + [ ( "uauth_id", + [aesonQQ|{ + "email": { + "email": "me@example.com", + "source": "scim_external_id" + }, + "saml_id": { + "subject": "me@example.com", + "tenant": "http://example.com/wef" + }, + "scim_external_id": "me@example.com", + "team": "226923f0-6f15-11ee-96bd-33644427c814" + }|] + ) + ] + <> [("email", toJSON e) | e <- maybeToList mbBrigEmail] + haskellIn = Right (UAuthId (Just uref1) (Just eid1) (Just ews1) tid) + jsonOut = + jsonIn + <> [ ( "sso_id", + [aesonQQ|{ + "subject": "me@example.com", + "tenant": "http://example.com/wef" + }|] + ) + ] + in mkUAuthIdentityTestCase "8" jsonIn haskellIn jsonOut mbBrigEmail + ], + testSSOIdToUAuthIdMigrations ] where - hemail = Email "me" "example.com" - email = ("email", "me@example.com") - bademail = ("email", "justme") - hphone = Phone "+493012345678" - phone = ("phone", "+493012345678") - badphone = ("phone", "__@@") - hssoid = UserSSOId mkSimpleSampleUref - ssoid = ("sso_id", toJSON hssoid) + -- render jsonIn into a UAuthId parser error. + -- + -- msg: for associating test reports with source code of test case + -- mbBrigEmail: email address from `brig.user.email`; doesn't may or may not match email field in uauthid + mkUAuthIdTestCase :: String -> Value -> String -> TestTree + mkUAuthIdTestCase msg val err = + testCase ("mkUAuthIdTestCase[" <> msg <> "]") $ + assertEqual "" (Left err) (Aeson.parseEither (schemaIn (schema @PartialUAuthId)) val) + + -- render jsonIn into a UserIdentity value, and back to its components. + -- + -- msg: for associating test reports with source code of test case + -- mbBrigEmail: email address from `brig.user.email`; doesn't may or may not match email field in uauthid + mkUAuthIdentityTestCase :: String -> [Aeson.Pair] -> Either String PartialUAuthId -> [Aeson.Pair] -> Maybe Email -> TestTree + mkUAuthIdentityTestCase msg jsonIn_ haskellIn_ jsonOut_ mbBrigEmail = + let emailComp = [("email", String $ cs (fromEmail e)) | e <- maybeToList mbBrigEmail] + jsonIn = jsonIn_ <> emailComp + jsonOut = jsonOut_ <> emailComp + haskellIn = (`UAuthIdentity` mbBrigEmail) <$> haskellIn_ + (=##=) uid comps = assertEqual "=##=" (eUserIdentityToComponents (Right uid)) comps + in testGroup msg $ + [ testCase "in" $ + jsonIn + =#= (Just <$> haskellIn) + ] + <> ( either + (const []) + (\hsk -> [testCase "out" $ hsk =##= componentsFromJSON jsonOut]) + haskellIn + ) + + componentsFromJSON :: HasCallStack => [Aeson.Pair] -> UserIdentityComponents "team_id" + componentsFromJSON obj = foldr go (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) obj + where + go :: Aeson.Pair -> UserIdentityComponents "team_id" -> UserIdentityComponents "team_id" + go ("email", v) comps = upd comps _1 (Aeson.fromJSON v) + go ("phone", v) comps = upd comps _2 (Aeson.fromJSON v) + go ("uauth_id", v) comps = upd comps _3 (Aeson.fromJSON v) + go ("sso_id", v) comps = upd comps _4 (Aeson.fromJSON v) + go ("team_id", v) comps = upd comps _5 (Aeson.fromJSON v) + go ("managed_by", v) comps = upd comps _6 (Aeson.fromJSON v) + go bad _ = error $ unlines ["go", show obj, show bad] + + upd :: a -> Lens' a (Maybe b) -> Result b -> a + upd comps lens (Aeson.Success v) = comps & lens ?~ v + upd _ _ (Aeson.Error err) = error $ unlines ["upd", show obj, err] + + (=#=) :: HasCallStack => [Aeson.Pair] -> Either String (Maybe (UserIdentity "team_id")) -> Assertion + (=#=) (object -> Object obj) uid = assertEqual "=#=" uid (Aeson.parseEither (schemaIn (maybeUserIdentityObjectSchema @"team_id")) obj) + (=#=) _ _ = error $ "=#=: impossible" + + (=###=) :: HasCallStack => (UserIdentityComponents "team_id") -> UserIdentityFromComponentsParseErrors -> Assertion + (=###=) comps err = assertEqual "=###=" (Left err) (eUserIdentityFromComponents comps) + + email1 = Email "me" "example.com" + email2 = Email "other" "example.com" + + ews1 = EmailWithSource email1 EmailFromScimExternalIdField + ews3 = EmailWithSource email2 EmailFromScimEmailsField + + eid1 = fromEmail email1 + eid3 = "nick" :: Text + + uref1 = mkBasicSampleUref "http://example.com/wef" eid1 + uref3 = mkBasicSampleUref "http://example.com/wef" "nick" + + phn1 = Phone "+123456789" + + tid = read "226923f0-6f15-11ee-96bd-33644427c814" + tid2 = read "8298c71e-855c-11ee-9ff6-5f1a496da735" + + -- First enumerate all interesting test cases, then case-match them and handle them + -- individually in `testSSOIdToUAuthIdMigration`. this makes for marginally more LOC, but + -- separates a list of what we want to test nicely from the actual tests, making it easier + -- to see whether we've missed a spot. + testSSOIdToUAuthIdMigrations :: TestTree + testSSOIdToUAuthIdMigrations = + testGroup "translation: sso_id => uauth_id" $ + [] + <> ( testSSOIdToUAuthIdMigration + <$> [UserSSOId uref1, UserScimExternalId eid1] + <*> [minBound ..] + <*> [Nothing, Just email1] + ) + <> ( testSSOIdToUAuthIdMigration + <$> [UserSSOId uref3, UserScimExternalId eid3] + <*> [minBound ..] + <*> [Nothing, Just email2] + ) + + abbreviateMsg :: LegacyUserSSOId -> Text + abbreviateMsg (UserSSOId uref') | uref' == uref1 = "UserSSOId uref1" + abbreviateMsg (UserSSOId uref') | uref' == uref3 = "UserSSOId uref3" + abbreviateMsg (UserScimExternalId eid') | eid' == eid1 = "UserScimExternalId eid1" + abbreviateMsg (UserScimExternalId eid') | eid' == eid3 = "UserScimExternalId eid3" + + testSSOIdToUAuthIdMigration :: LegacyUserSSOId -> ManagedBy -> Maybe Email -> TestTree + testSSOIdToUAuthIdMigration lsso@(UserSSOId uref') mby@ManagedByWire mbemail@Nothing + | uref' == uref1 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId (Just uref1) Nothing ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserSSOId uref') mby@ManagedByWire mbemail@(Just email') + | uref' == uref1 && email' == email1 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId (Just uref1) Nothing ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserSSOId uref') mby@ManagedByScim mbemail@Nothing + | uref' == uref1 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId (Just uref1) (Just eid1) ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserSSOId uref') mby@ManagedByScim mbemail@(Just email') + | uref' == uref1 && email' == email1 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId (Just uref1) (Just eid1) ((`EmailWithSource` EmailFromScimExternalIdField) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + -- + testSSOIdToUAuthIdMigration lsso@(UserScimExternalId eid') mby@ManagedByWire mbemail@Nothing + | eid' == eid1 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId Nothing (Just eid1) ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserScimExternalId eid') mby@ManagedByWire mbemail@(Just email') + | eid' == eid1 && email' == email1 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId Nothing (Just eid1) ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserScimExternalId eid') mby@ManagedByScim mbemail@Nothing + | eid' == eid1 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId Nothing (Just eid1) ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserScimExternalId eid') mby@ManagedByScim mbemail@(Just email') + | eid' == eid1 && email' == email1 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId Nothing (Just eid1) ((`EmailWithSource` EmailFromScimExternalIdField) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + -- + testSSOIdToUAuthIdMigration lsso@(UserSSOId uref') mby@ManagedByWire mbemail@Nothing + | uref' == uref3 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId (Just uref3) Nothing ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserSSOId uref') mby@ManagedByWire mbemail@(Just email') + | uref' == uref3 && email' == email2 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId (Just uref3) Nothing ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserSSOId uref') mby@ManagedByScim mbemail@Nothing + | uref' == uref3 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId (Just uref3) (Just eid3) ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserSSOId uref') mby@ManagedByScim mbemail@(Just email') + | uref' == uref3 && email' == email2 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId (Just uref3) (Just eid3) ((`EmailWithSource` EmailFromScimExternalIdField) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + -- + testSSOIdToUAuthIdMigration lsso@(UserScimExternalId eid') mby@ManagedByWire mbemail@Nothing + | eid' == eid3 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId Nothing (Just eid3) ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserScimExternalId eid') mby@ManagedByWire mbemail@(Just email') + | eid' == eid3 && email' == email2 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId Nothing (Just eid3) ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserScimExternalId eid') mby@ManagedByScim mbemail@Nothing + | eid' == eid3 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId Nothing (Just eid3) ((`EmailWithSource` EmailFromSamlNameId) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail + testSSOIdToUAuthIdMigration lsso@(UserScimExternalId eid') mby@ManagedByScim mbemail@(Just email') + | eid' == eid3 && email' == email2 = + testCase (cs (encode (abbreviateMsg lsso, mby, mbemail))) $ + UAuthId Nothing (Just eid3) ((`EmailWithSource` EmailFromScimExternalIdField) <$> mbemail) tid @=? legacyUserSSOIdToUAuthId lsso tid mby mbemail diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 16b9c9b54e..12e3b26860 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -230,6 +230,8 @@ library Wire.API.User.Saml Wire.API.User.Scim Wire.API.User.Search + Wire.API.User.Test + Wire.API.User.Types Wire.API.UserMap Wire.API.Util.Aeson Wire.API.VersionInfo @@ -574,6 +576,7 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Manual.FederationStatus Test.Wire.API.Golden.Manual.GetPaginatedConversationIds Test.Wire.API.Golden.Manual.GroupId + Test.Wire.API.Golden.Manual.Identity Test.Wire.API.Golden.Manual.ListConversations Test.Wire.API.Golden.Manual.ListUsersById Test.Wire.API.Golden.Manual.QualifiedUserClientPrekeyMap @@ -599,12 +602,15 @@ test-suite wire-api-golden-tests , crypton , currency-codes , either + , http-api-data , imports , iso3166-country-codes , iso639 , lens , pem , proto-lens + , saml2-web-sso + , schema-profunctor , tasty , tasty-hunit , text @@ -669,6 +675,7 @@ test-suite wire-api-tests , hspec-wai , http-types , imports + , lens , memory , metrics-wai , openapi3 diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index d6daec5b14..838fe2234c 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -203,6 +203,7 @@ library Brig.Schema.V79_ConnectionRemoteIndex Brig.Schema.V80_KeyPackageCiphersuite Brig.Schema.V81_AddFederationRemoteTeams + Brig.Schema.V82_SparUserAuthId Brig.Schema.V_FUTUREWORK Brig.SMTP Brig.Team.API diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 61368a7012..e159f6c161 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -169,6 +169,8 @@ accountAPI = :<|> Named @"iPostPhonePrefix" addPhonePrefixH :<|> Named @"iPutUserSsoId" updateSSOIdH :<|> Named @"iDeleteUserSsoId" deleteSSOIdH + :<|> Named @"iPutUAuthId" updateUAuthIdH + :<|> Named @"iDeleteUAuthId" deleteUAuthIdH :<|> Named @"iPutManagedBy" updateManagedByH :<|> Named @"iPutRichInfo" updateRichInfoH :<|> Named @"iPutHandle" updateHandleH diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 3a6e8f606b..8e788ffad7 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -71,7 +71,7 @@ data CreateUserTeam = CreateUserTeam data ActivationResult = -- | The key/code was valid and successfully activated. - ActivationSuccess !(Maybe UserIdentity) !Bool + ActivationSuccess !(Maybe (UserIdentity "team_id")) !Bool | -- | The key/code was valid but already recently activated. ActivationPass diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 6278c13d24..28aaa4cedf 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -143,6 +143,7 @@ import Brig.User.Search.TeamSize qualified as TeamSize import Cassandra hiding (Set) import Control.Arrow ((&&&)) import Control.Error +import Control.Exception (assert) import Control.Lens (view, (^.)) import Control.Monad.Catch import Data.ByteString.Conversion @@ -234,7 +235,7 @@ createUserSpar :: createUserSpar new = do let handle' = newUserSparHandle new new' = newUserFromSpar new - ident = newUserSparSSOId new + ident = newUserSparUAuthId new tid = newUserSparTeamId new -- Create account @@ -254,7 +255,9 @@ createUserSpar new = do pure account -- Add to team - userTeam <- withExceptT CreateUserSparRegistrationError $ addUserToTeamSSO account tid (SSOIdentity ident Nothing Nothing) (newUserSparRole new) + userTeam <- + let email = Nothing -- no *validated* email can exist yet in the sso case. + in withExceptT CreateUserSparRegistrationError $ addUserToTeamSSO account tid (UAuthIdentity ident Nothing) (newUserSparRole new) -- Set up feature flags let uid = userId (accountUser account) @@ -272,7 +275,7 @@ createUserSpar new = do Just handl -> withExceptT CreateUserSparHandleError $ changeHandle uid Nothing handl AllowSCIMUpdates Nothing -> throwE $ CreateUserSparHandleError ChangeHandleInvalid - addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> Role -> ExceptT RegisterError (AppT r) CreateUserTeam + addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity tf -> Role -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident role = do let uid = userId (accountUser account) added <- lift $ liftSem $ GalleyProvider.addTeamMember uid tid (Nothing, role) @@ -321,21 +324,14 @@ createUser new = do let (new', mbHandle) = case mbExistingAccount of Nothing -> - ( new {newUserIdentity = newIdentity email phone (newUserSSOId new)}, + ( new {newUserIdentity = newIdentity email phone (newUserUAuthId new)}, Nothing ) Just existingAccount -> let existingUser = accountUser existingAccount - mbSSOid = - case (teamInvitation, email, userManagedBy existingUser) of - -- isJust teamInvitation And ManagedByScim implies that the - -- user invitation has been generated by SCIM and there is no IdP - (Just _, Just em, ManagedByScim) -> - Just $ UserScimExternalId (fromEmail em) - _ -> newUserSSOId new in ( new { newUserManagedBy = Just (userManagedBy existingUser), - newUserIdentity = newIdentity email phone mbSSOid + newUserIdentity = newIdentity email phone (newUserUAuthId new) }, userHandle existingUser ) @@ -377,7 +373,8 @@ createUser new = do Nothing -> pure Nothing joinedTeamSSO <- case (newUserIdentity new', tid) of - (Just ident@(SSOIdentity (UserSSOId _) _ _), Just tid') -> Just <$> addUserToTeamSSO account tid' ident + (Just ident@(UAuthIdentity (UAuthId (Just _) _ _ tid'') _), Just tid') -> + assert (tid'' == tid') $ Just <$> addUserToTeamSSO account tid' ident _ -> pure Nothing pure (activatedTeam <|> joinedTeamInvite <|> joinedTeamSSO) @@ -448,7 +445,7 @@ createUser new = do Team.Invitation -> Team.InvitationInfo -> UserKey -> - UserIdentity -> + UserIdentity tf -> ExceptT RegisterError (AppT r) () acceptTeamInvitation account inv ii uk ident = do let uid = userId (accountUser account) @@ -471,7 +468,7 @@ createUser new = do wrapClient $ do Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) - addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam + addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity tf -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) added <- lift $ liftSem $ GalleyProvider.addTeamMember uid tid (Nothing, defaultRole) @@ -1157,7 +1154,7 @@ mkPasswordResetKey ident = case ident of -- User Deletion -- | Initiate validation of a user's delete request. Called via @delete /self@. Users with an --- 'UserSSOId' can still do this if they also have an 'Email', 'Phone', and/or password. Otherwise, +-- 'UAuthid' can still do this if they also have email and password. Otherwise, -- the team admin has to delete them via the team console on galley. -- -- Owners are not allowed to delete themselves. Instead, they must ask a fellow owner to @@ -1188,19 +1185,22 @@ deleteSelfUser uid pwd = do Just tid -> do isOwner <- lift $ liftSem $ GalleyProvider.memberIsTeamOwner tid uid when isOwner $ throwE DeleteUserOwnerDeletingSelf + go a = maybe (byIdentity a) (byPassword a) pwd - getEmailOrPhone :: UserIdentity -> Maybe (Either Email Phone) - getEmailOrPhone (FullIdentity e _) = Just $ Left e + + getEmailOrPhone :: UserIdentity tf -> Maybe (Either Email Phone) getEmailOrPhone (EmailIdentity e) = Just $ Left e - getEmailOrPhone (SSOIdentity _ (Just e) _) = Just $ Left e getEmailOrPhone (PhoneIdentity p) = Just $ Right p - getEmailOrPhone (SSOIdentity _ _ (Just p)) = Just $ Right p - getEmailOrPhone (SSOIdentity _ Nothing Nothing) = Nothing + getEmailOrPhone (FullIdentity e _) = Just $ Left e + getEmailOrPhone (UAuthIdentity (UAuthId _ _ (Just (EmailWithSource e _)) _)) = Just $ Left e + getEmailOrPhone (UAuthIdentity (UAuthId _ _ Nothing _)) = Nothing + byIdentity a = case getEmailOrPhone =<< userIdentity (accountUser a) of Just emailOrPhone -> sendCode a emailOrPhone Nothing -> case pwd of Just _ -> throwE DeleteUserMissingPassword Nothing -> lift $ wrapHttpClient $ deleteAccount a >> pure Nothing + byPassword a pw = do lift . Log.info $ field "user" (toByteString uid) @@ -1212,6 +1212,7 @@ deleteSelfUser uid pwd = do unless (verifyPassword pw p) $ throwE DeleteUserInvalidPassword lift $ wrapHttpClient $ deleteAccount a >> pure Nothing + sendCode a target = do gen <- Code.mkGen (either Code.ForEmail Code.ForPhone target) pending <- lift . wrapClient $ Code.lookup (Code.genKey gen) Code.AccountDeletion diff --git a/services/brig/src/Brig/API/Util.hs b/services/brig/src/Brig/API/Util.hs index 67693d3730..bcf8f28a7c 100644 --- a/services/brig/src/Brig/API/Util.hs +++ b/services/brig/src/Brig/API/Util.hs @@ -70,7 +70,7 @@ lookupProfilesMaybeFilterSameTeamOnly self us = do Just team -> filter (\x -> profileTeam x == Just team) us Nothing -> us -fetchUserIdentity :: UserId -> (AppT r) (Maybe UserIdentity) +fetchUserIdentity :: UserId -> (AppT r) (Maybe (UserIdentity "team")) fetchUserIdentity uid = lookupSelfProfile uid >>= maybe diff --git a/services/brig/src/Brig/Data/Instances.hs b/services/brig/src/Brig/Data/Instances.hs index 47f0ccf337..c5eda27f2b 100644 --- a/services/brig/src/Brig/Data/Instances.hs +++ b/services/brig/src/Brig/Data/Instances.hs @@ -27,7 +27,6 @@ import Brig.Types.Common import Brig.Types.Search import Cassandra.CQL import Control.Error (note) -import Data.Aeson (eitherDecode, encode) import Data.Aeson qualified as JSON import Data.ByteString.Conversion import Data.Domain (Domain, domainText, mkDomain) @@ -81,15 +80,15 @@ instance Cql Email where toCql = toCql . fromEmail -instance Cql UserSSOId where +instance Cql LegacyUserSSOId where ctype = Tagged TextColumn - fromCql (CqlText t) = case eitherDecode $ cs t of + fromCql (CqlText t) = case JSON.eitherDecode $ cs t of Right i -> pure i - Left msg -> Left $ "fromCql: Invalid UserSSOId: " ++ msg - fromCql _ = Left "fromCql: UserSSOId: CqlText expected" + Left msg -> Left $ "fromCql: Invalid LegacyUserSSOId: " ++ msg + fromCql _ = Left "fromCql: LegacyUserSSOId: CqlText expected" - toCql = toCql . cs @LByteString @Text . encode + toCql = toCql . cs @LByteString @Text . JSON.encode instance Cql RelationWithHistory where ctype = Tagged IntColumn diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index d170ed4e42..5841b7b27c 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -55,7 +55,7 @@ module Brig.Data.User updateEmail, updateEmailUnvalidated, updatePhone, - updateSSOId, + updateUAuthId, updateManagedBy, activateUser, deactivateUser, @@ -159,7 +159,7 @@ newAccount u inv tid mbHandle = do locale defLoc = fromMaybe defLoc (newUserLocale u) managedBy = fromMaybe defaultManagedBy (newUserManagedBy u) prots = fromMaybe defSupportedProtocols (newUserSupportedProtocols u) - user uid domain l e = User uid (Qualified uid domain) ident name pict assets colour False l Nothing mbHandle e tid managedBy prots + user uid domain l e = User uid (Qualified uid domain) (castUserIdentityTeamFieldName <$> ident) name pict assets colour False l Nothing mbHandle e tid managedBy prots newAccountInviteViaScim :: MonadReader Env m => UserId -> TeamId -> Maybe Locale -> Name -> Email -> m UserAccount newAccountInviteViaScim uid tid locale name email = do @@ -223,9 +223,9 @@ reauthenticate u pw = isSamlUser :: (MonadClient m, MonadReader Env m) => UserId -> m Bool isSamlUser uid = do account <- lookupAccount uid - case userIdentity . accountUser =<< account of - Just (SSOIdentity (UserSSOId _) _ _) -> pure True - _ -> pure False + pure $ case userIdentity . accountUser =<< account of + Just (UAuthIdentity (UAuthId (Just _) _ _ _) _) -> True + _ -> False insertAccount :: MonadClient m => @@ -301,12 +301,13 @@ updateEmailUnvalidated u e = retry x5 $ write userEmailUnvalidatedUpdate (params updatePhone :: MonadClient m => UserId -> Phone -> m () updatePhone u p = retry x5 $ write userPhoneUpdate (params LocalQuorum (p, u)) -updateSSOId :: MonadClient m => UserId -> Maybe UserSSOId -> m Bool -updateSSOId u ssoid = do - mteamid <- lookupUserTeam u +updateUAuthId :: MonadClient m => UserId -> Maybe PartialUAuthId -> m Bool +updateUAuthId uid uauthid = do + -- NOTE(fisx): this probably doesn't compile yet, but the idea should be appearent? + mteamid <- lookupUserTeam uid case mteamid of Just _ -> do - retry x5 $ write userSSOIdUpdate (params LocalQuorum (ssoid, u)) + retry x5 $ write uauthIdUpdate (params LocalQuorum (uauthid.samlId.issuer, uauthid.samlId.nameid, uauthid.scimExternalId, u)) pure True Nothing -> pure False @@ -393,7 +394,7 @@ filterActive us = lookupUser :: (MonadClient m, MonadReader Env m) => HavePendingInvitations -> UserId -> m (Maybe User) lookupUser hpi u = listToMaybe <$> lookupUsers hpi [u] -activateUser :: MonadClient m => UserId -> UserIdentity -> m () +activateUser :: MonadClient m => UserId -> UserIdentity tf -> m () activateUser u ident = do let email = emailIdentity ident let phone = phoneIdentity ident @@ -645,8 +646,8 @@ userEmailUnvalidatedDelete = {- `IF EXISTS`, but that requires benchmarking -} " userPhoneUpdate :: PrepQuery W (Phone, UserId) () userPhoneUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET phone = ? WHERE id = ?" -userSSOIdUpdate :: PrepQuery W (Maybe UserSSOId, UserId) () -userSSOIdUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET sso_id = ? WHERE id = ?" +uauthIdUpdate :: PrepQuery W (Maybe Text, Maybe Text, Maybe Text, UserId) () +uauthIdUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET saml_entity_id = ?, saml_name_id = ?, scim_external_id = ?, sso_id = null WHERE id = ?" userManagedByUpdate :: PrepQuery W (ManagedBy, UserId) () userManagedByUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE user SET managed_by = ? WHERE id = ?" diff --git a/services/brig/src/Brig/Schema/Run.hs b/services/brig/src/Brig/Schema/Run.hs index 15f996f73b..c1d58fe6f0 100644 --- a/services/brig/src/Brig/Schema/Run.hs +++ b/services/brig/src/Brig/Schema/Run.hs @@ -56,6 +56,7 @@ import Brig.Schema.V78_ClientLastActive qualified as V78_ClientLastActive import Brig.Schema.V79_ConnectionRemoteIndex qualified as V79_ConnectionRemoteIndex import Brig.Schema.V80_KeyPackageCiphersuite qualified as V80_KeyPackageCiphersuite import Brig.Schema.V81_AddFederationRemoteTeams qualified as V81_AddFederationRemoteTeams +import Brig.Schema.V82_SparUserAuthId qualified as V82_SparUserAuthId import Cassandra.Schema import Control.Exception (finally) import Imports @@ -117,7 +118,8 @@ migrations = V78_ClientLastActive.migration, V79_ConnectionRemoteIndex.migration, V80_KeyPackageCiphersuite.migration, - V81_AddFederationRemoteTeams.migration + V81_AddFederationRemoteTeams.migration, + V82_SparUserAuthId.migration -- FUTUREWORK: undo V41 (searchable flag); we stopped using it in -- https://github.com/wireapp/wire-server/pull/964 -- diff --git a/services/brig/src/Brig/Schema/V82_SparUserAuthId.hs b/services/brig/src/Brig/Schema/V82_SparUserAuthId.hs new file mode 100644 index 0000000000..56a4d64446 --- /dev/null +++ b/services/brig/src/Brig/Schema/V82_SparUserAuthId.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Brig.Schema.V82_SparUserAuthId + ( migration, + ) +where + +import Cassandra.Schema +import Imports +import Text.RawString.QQ + +migration :: Migration +migration = Migration 82 "Support less insane recording of spar UAuthId* (formerly UserSSOId)" $ do + schema' + [r| ALTER TABLE user ADD ( + saml_entity_id text, -- issuer from UserRef, stored in its xml encoding so we keep all data, can be null + saml_name_id text, -- name id from UserRef, stored in its xml encoding so we keep all data, can be null + scim_external_id text, -- what you think it is, can be null + scim_email text, -- may diverge from validated email stored in `email` + scim_email_source text -- scim email field, scim external_id fiel, or saml (discouraged) + ) + |] diff --git a/services/brig/src/Brig/User/Email.hs b/services/brig/src/Brig/User/Email.hs index 0a4a0a92c1..b99e7b2602 100644 --- a/services/brig/src/Brig/User/Email.hs +++ b/services/brig/src/Brig/User/Email.hs @@ -113,7 +113,7 @@ sendActivationMail :: Name -> ActivationPair -> Maybe Locale -> - Maybe UserIdentity -> + Maybe (UserIdentity tf) -> m () sendActivationMail to name pair loc ident = do tpl <- selectTemplate . snd <$> userTemplates loc diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 946c4f7e1e..bd558839c7 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -926,7 +926,7 @@ testCreateUserInternalSSO brig galley = do resp <- postUser "dummy" True False (Just ssoid) (Just teamid) brig responseJsonMaybe resp profile <- getSelfProfile brig uid @@ -934,7 +934,7 @@ testCreateUserInternalSSO brig galley = do assertEqual "self profile user identity mismatch" (Just ssoid) - (userSSOId $ selfUser profile) + (userPartialUAuthId $ selfUser profile) -- sso-managed users must have team id. let Just teamid' = userTeam $ selfUser profile liftIO $ assertEqual "bad team_id" teamid teamid' @@ -981,7 +981,7 @@ test2FaDisabledForSsoUser brig galley = do createUserResp <- postUser "dummy" True False (Just ssoid) (Just teamid) brig responseJsonMaybe createUserResp let verificationCode = Nothing addClient brig uid (defNewClientWithVerificationCode verificationCode PermanentClientType [head somePrekeys] (head someLastPrekeys)) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 98573b9ef8..f88e95601f 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -144,10 +144,10 @@ import Wire.API.Team.Permission (Perm (..), Permissions (..), SPerm (..), copy, import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Wire.API.Team.SearchVisibility qualified as Public -import Wire.API.User (ScimUserInfo (..), User, UserIdList, UserSSOId (UserScimExternalId), userSCIMExternalId, userSSOId) +import Wire.API.User (ScimUserInfo (..), User, UserIdList, userPartialUAuthId, userSCIMExternalId) import Wire.API.User qualified as U -import Wire.API.User.Identity (UserSSOId (UserSSOId)) import Wire.API.User.RichInfo (RichInfo) +import Wire.API.User.Types import Wire.Sem.Paging qualified as E import Wire.Sem.Paging.Cassandra @@ -608,8 +608,8 @@ getTeamMembersCSV lusr tid = do pure (`M.lookup` userMap) userToIdPIssuer :: U.User -> Maybe HttpsUrl - userToIdPIssuer usr = case (U.userIdentity >=> U.ssoIdentity) usr of - Just (U.UserSSOId (SAML.UserRef issuer _)) -> either (const Nothing) Just . mkHttpsUrl $ issuer ^. SAML.fromIssuer + userToIdPIssuer usr = case (U.userIdentity >=> U.uauthIdentity) usr of + Just (U.UAuthId (Just (SAML.UserRef issuer _)) _ _ _) -> either (const Nothing) Just . mkHttpsUrl $ issuer ^. SAML.fromIssuer Just _ -> Nothing Nothing -> Nothing @@ -626,10 +626,7 @@ getTeamMembersCSV lusr tid = do lookupClients userClients uid = maybe 0 length (M.lookup uid (Conv.userClients userClients)) samlNamedId :: User -> Maybe Text - samlNamedId = - userSSOId >=> \case - (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId - (UserScimExternalId _) -> Nothing + samlNamedId = fmap (CI.original . SAML.unsafeShowNameID . view SAML.uidSubject) . (uaSamlId <=< userPartialUAuthId) -- | like 'getTeamMembers', but with an explicit list of users we are to return. bulkGetTeamMembers :: diff --git a/services/galley/test/integration/API/Teams.hs b/services/galley/test/integration/API/Teams.hs index b31f5cf347..e66c005e20 100644 --- a/services/galley/test/integration/API/Teams.hs +++ b/services/galley/test/integration/API/Teams.hs @@ -281,9 +281,8 @@ testListTeamMembersCsv numMembers = do assertEqual "tExportNumDevices: " (Map.findWithDefault (-1) (U.userId user) numClientMappings) (tExportNumDevices export) where userToIdPIssuer :: HasCallStack => U.User -> Maybe HttpsUrl - userToIdPIssuer usr = case (U.userIdentity >=> U.ssoIdentity) usr of - Just (U.UserSSOId (SAML.UserRef (SAML.Issuer issuer) _)) -> either (const $ error "shouldn't happen") Just $ mkHttpsUrl issuer - Just _ -> Nothing + userToIdPIssuer usr = case U.userPartialUAuthId usr >>= U.uaSamlId of + Just (SAML.UserRef (SAML.Issuer issuer) _) -> either (const $ error "shouldn't happen") Just $ mkHttpsUrl issuer Nothing -> Nothing decodeCSV :: FromNamedRecord a => LByteString -> Either String [a] diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index a050b333e2..f9a2a55b76 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -2498,7 +2498,7 @@ refreshIndex = do brig <- viewBrig post (brig . path "/i/index/refresh") !!! const 200 === statusCode -postSSOUser :: Text -> Bool -> UserSSOId -> TeamId -> TestM ResponseLBS +postSSOUser :: Text -> Bool -> LegacyUserSSOId -> TeamId -> TestM ResponseLBS postSSOUser name hasEmail ssoid teamid = do brig <- viewBrig email <- randomEmail diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 4f4dfdaf31..51d3adc7fc 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -538,7 +538,6 @@ test-suite spec Paths_spar Test.Spar.APISpec Test.Spar.DataSpec - Test.Spar.Intra.BrigSpec Test.Spar.Roundtrip.ByteString Test.Spar.Scim.UserSpec Test.Spar.ScimSpec diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index f32f221433..2fa401892b 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -26,8 +26,7 @@ module Spar.App throwSparSem, verdictHandler, getUserByUrefUnsafe, - getUserIdByScimExternalId, - validateEmail, + makeBrigValidateEmail, errorPage, deleteTeam, sparToServerErrorWithLogging, @@ -78,8 +77,6 @@ import Spar.Sem.Reporter (Reporter) import qualified Spar.Sem.Reporter as Reporter import Spar.Sem.SAMLUserStore (SAMLUserStore) import qualified Spar.Sem.SAMLUserStore as SAMLUserStore -import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore) -import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import Spar.Sem.ScimTokenStore (ScimTokenStore) import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Spar.Sem.VerdictFormatStore (VerdictFormatStore) @@ -88,10 +85,10 @@ import qualified System.Logger as TinyLog import URI.ByteString as URI import Web.Cookie (SetCookie, renderSetCookie) import Wire.API.Team.Role (Role, defaultRole) -import Wire.API.User hiding (validateEmail) +import Wire.API.User +import Wire.API.User.Identity import Wire.API.User.IdentityProvider import Wire.API.User.Saml -import Wire.API.User.Scim (ValidExternalId (..)) import Wire.Sem.Logger (Logger) import qualified Wire.Sem.Logger as Logger import Wire.Sem.Random (Random) @@ -123,10 +120,6 @@ data Env = Env -- password handshake have not been completed; it's still ok for the user to gain access to -- the team with valid SAML credentials. -- --- FUTUREWORK: Remove and reinstate getUser, in AuthID refactoring PR. (in --- https://github.com/wireapp/wire-server/pull/1410, undo --- https://github.com/wireapp/wire-server/pull/1418) --- -- FUTUREWORK: https://wearezeta.atlassian.net/browse/SQSERVICES-1655 getUserByUrefUnsafe :: ( Member BrigAccess r, @@ -137,23 +130,6 @@ getUserByUrefUnsafe :: getUserByUrefUnsafe uref = do maybe (pure Nothing) (Intra.getBrigUser Intra.WithPendingInvitations) =<< SAMLUserStore.get uref --- FUTUREWORK: Remove and reinstatate getUser, in AuthID refactoring PR -getUserIdByScimExternalId :: - ( Member BrigAccess r, - Member ScimExternalIdStore r - ) => - TeamId -> - Email -> - Sem r (Maybe UserId) -getUserIdByScimExternalId tid email = do - muid <- ScimExternalIdStore.lookup tid email - case muid of - Nothing -> pure Nothing - Just uid -> do - let withpending = Intra.WithPendingInvitations -- see haddocks above - itis <- isJust <$> Intra.getBrigUserTeam withpending uid - pure $ if itis then Just uid else Nothing - -- | Create a fresh 'UserId', store it on C* locally together with 'SAML.UserRef', then -- create user on brig. -- @@ -181,8 +157,8 @@ createSamlUserWithId :: Role -> Sem r () createSamlUserWithId teamid buid suid role = do - uname <- either (throwSparSem . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) - buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire Nothing Nothing Nothing role + uname <- either (throwSparSem . SparBadUserName . cs) pure $ mkUserNameSaml Nothing (UAuthId (pure suid) Nothing Nothing teamid) + buid' <- BrigAccess.createSAML suid Nothing buid teamid uname ManagedByWire Nothing Nothing Nothing role -- assert (buid == buid') $ pure () SAMLUserStore.insert suid buid @@ -222,8 +198,8 @@ autoprovisionSamlUser idp buid suid = do throwSparSem SparSamlCredentialsNotFound -- | If user's 'NameID' is an email address and the team has email validation for SSO enabled, --- make brig initiate the email validate procedure. -validateEmailIfExists :: +-- make brig initiate the email-validation-via-code procedure. +makeBrigValidateEmailIfExists :: forall r. ( Member GalleyAccess r, Member BrigAccess r @@ -231,13 +207,13 @@ validateEmailIfExists :: UserId -> SAML.UserRef -> Sem r () -validateEmailIfExists uid = \case +makeBrigValidateEmailIfExists uid = \case (SAML.UserRef _ (view SAML.nameID -> UNameIDEmail email)) -> do mbTid <- Intra.getBrigUserTeam Intra.NoPendingInvitations uid - validateEmail mbTid uid . Intra.emailFromSAML . CI.original $ email + makeBrigValidateEmail mbTid uid . Intra.emailFromSAML . CI.original $ email _ -> pure () -validateEmail :: +makeBrigValidateEmail :: forall r. ( Member GalleyAccess r, Member BrigAccess r @@ -246,7 +222,7 @@ validateEmail :: UserId -> Email -> Sem r () -validateEmail mbTid uid email = do +makeBrigValidateEmail mbTid uid email = do enabled <- maybe (pure False) GalleyAccess.isEmailValidationEnabledTeam mbTid when enabled $ do BrigAccess.updateEmail uid email @@ -414,7 +390,7 @@ verdictHandlerResultCore idp = \case Nothing -> do buid <- Id <$> Random.uuid autoprovisionSamlUser idp buid uref - validateEmailIfExists buid uref + makeBrigValidateEmailIfExists buid uref pure buid Logger.log Logger.Debug ("granting sso login for " <> show uid) diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index db6ea684d2..6c9c16206b 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -67,14 +67,9 @@ import Wire.API.User import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso import Wire.API.User.RichInfo as RichInfo -import Wire.API.User.Scim (ValidExternalId (..), runValidExternalIdEither) ---------------------------------------------------------------------- --- | FUTUREWORK: this is redundantly defined in "Spar.Intra.BrigApp". -veidToUserSSOId :: ValidExternalId -> UserSSOId -veidToUserSSOId = runValidExternalIdEither UserSSOId (UserScimExternalId . fromEmail) - -- | Similar to 'Network.Wire.Client.API.Auth.tokenResponse', but easier: we just need to set the -- cookie in the response, and the redirect will make the client negotiate a fresh auth token. -- (This is the easiest way, since the login-request that we are in the middle of responding to here @@ -94,6 +89,7 @@ class (Log.MonadLogger m, MonadError SparError m) => MonadSparToBrig m where createBrigUserSAML :: (HasCallStack, MonadSparToBrig m) => SAML.UserRef -> + Maybe (Text {- scim external id -}, EmailWithSource) -> UserId -> TeamId -> -- | User name @@ -105,12 +101,13 @@ createBrigUserSAML :: Maybe Locale -> Role -> m UserId -createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo mLocale role = do - let newUser = +createBrigUserSAML uref mbscim (Id buid) teamid name managedBy handle richInfo mLocale role = do + let (mbEid, mbEmail) = (maybe Nothing (Just . fst) mbscim, maybe Nothing (Just . snd) mbscim) + newUser = NewUserSpar { newUserSparUUID = buid, newUserSparDisplayName = name, - newUserSparSSOId = UserSSOId uref, + newUserSparUAuthId = UAuthId (Just uref) mbEid mbEmail teamid, newUserSparTeamId = teamid, newUserSparManagedBy = managedBy, newUserSparHandle = handle, @@ -271,13 +268,13 @@ setBrigUserManagedBy buid managedBy = do rethrow "brig" resp -- | Set user's UserSSOId. -setBrigUserVeid :: (HasCallStack, MonadSparToBrig m) => UserId -> ValidExternalId -> m () -setBrigUserVeid buid veid = do +setBrigUserVeid :: (HasCallStack, MonadSparToBrig m) => UserId -> PartialUAuthId -> m () +setBrigUserVeid buid uauthid = do resp <- call $ method PUT . paths ["i", "users", toByteString' buid, "sso-id"] - . json (veidToUserSSOId veid) + . json uauthid case statusCode resp of 200 -> pure () _ -> rethrow "brig" resp diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index c8f3ddb14a..41edc37c75 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -21,13 +21,8 @@ -- | Client functions for interacting with the Brig API. module Spar.Intra.BrigApp - ( veidToUserSSOId, - urefToExternalId, + ( urefToExternalId, urefToEmail, - veidFromBrigUser, - veidFromUserSSOId, - mkUserName, - renderValidExternalId, HavePendingInvitations (..), getBrigUser, getBrigUserTeam, @@ -63,53 +58,7 @@ import qualified Spar.Sem.BrigAccess as BrigAccess import Spar.Sem.GalleyAccess (GalleyAccess) import qualified Spar.Sem.GalleyAccess as GalleyAccess import Wire.API.User -import Wire.API.User.Scim (ValidExternalId (..), runValidExternalIdEither) - ----------------------------------------------------------------------- - --- | FUTUREWORK: this is redundantly defined in "Spar.Intra.Brig" -veidToUserSSOId :: ValidExternalId -> UserSSOId -veidToUserSSOId = runValidExternalIdEither UserSSOId (UserScimExternalId . fromEmail) - -veidFromUserSSOId :: MonadError String m => UserSSOId -> m ValidExternalId -veidFromUserSSOId = \case - UserSSOId uref -> - case urefToEmail uref of - Nothing -> pure $ UrefOnly uref - Just email -> pure $ EmailAndUref email uref - UserScimExternalId email -> - maybe - (throwError "externalId not an email and no issuer") - (pure . EmailOnly) - (parseEmail email) - --- | If the brig user has a 'UserSSOId', transform that into a 'ValidExternalId' (this is a --- total function as long as brig obeys the api). Otherwise, if the user has an email, we can --- construct a return value from that (and an optional saml issuer). If a user only has a --- phone number, or no identity at all, throw an error. --- --- Note: the saml issuer is only needed in the case where a user has been invited via team --- settings and is now onboarded to saml/scim. If this case can safely be ruled out, it's ok --- to just set it to 'Nothing'. -veidFromBrigUser :: MonadError String m => User -> Maybe SAML.Issuer -> m ValidExternalId -veidFromBrigUser usr mIssuer = case (userSSOId usr, userEmail usr, mIssuer) of - (Just ssoid, _, _) -> veidFromUserSSOId ssoid - (Nothing, Just email, Just issuer) -> pure $ EmailAndUref email (SAML.UserRef issuer (emailToSAMLNameID email)) - (Nothing, Just email, Nothing) -> pure $ EmailOnly email - (Nothing, Nothing, _) -> throwError "user has neither ssoIdentity nor userEmail" - --- | Take a maybe text, construct a 'Name' from what we have in a scim user. If the text --- isn't present, use an email address or a saml subject (usually also an email address). If --- both are 'Nothing', fail. -mkUserName :: Maybe Text -> ValidExternalId -> Either String Name -mkUserName (Just n) = const $ mkName n -mkUserName Nothing = - runValidExternalIdEither - (\uref -> mkName (CI.original . SAML.unsafeShowNameID $ uref ^. SAML.uidSubject)) - (mkName . fromEmail) - -renderValidExternalId :: ValidExternalId -> Maybe Text -renderValidExternalId = runValidExternalIdEither urefToExternalId (Just . fromEmail) +import Wire.API.User.Types ---------------------------------------------------------------------- diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 56922274c0..ba3c370f64 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -36,7 +36,7 @@ module Spar.Scim.User ( validateScimUser', synthesizeScimUser, toScimStoredUser', - mkValidExternalId, + mkScimUAuthId, scimFindUserByEmail, deleteScimUser, ) @@ -63,7 +63,7 @@ import Network.URI (URI, parseURI) import Polysemy import Polysemy.Input import qualified SAML2.WebSSO as SAML -import Spar.App (getUserByUrefUnsafe, getUserIdByScimExternalId) +import Spar.App (getUserByUrefUnsafe) import qualified Spar.App import qualified Spar.Intra.BrigApp as Brig import Spar.Options @@ -167,7 +167,7 @@ instance $ do mIdpConfig <- mapM (lift . IdPConfigStore.getConfig) stiIdP let notfound = Scim.notFound "User" (idToText uid) - runMaybeT (getUserById mIdpConfig stiTeam uid) >>= maybe (throwError notfound) pure + runMaybeT (getUserById mIdpConfig stiTeam (Left uid)) >>= maybe (throwError notfound) pure postUser :: ScimTokenInfo -> @@ -203,25 +203,11 @@ validateScimUser :: ScimTokenInfo -> Scim.User ST.SparTag -> m ST.ValidScimUser -validateScimUser errloc tokinfo user = do - mIdpConfig <- tokenInfoToIdP tokinfo +validateScimUser errloc (ScimTokenInfo {stiIdP}) user = do + mIdpConfig <- mapM (lift . IdPConfigStore.getConfig) stiIdP richInfoLimit <- lift $ inputs richInfoLimit validateScimUser' errloc mIdpConfig richInfoLimit user -tokenInfoToIdP :: Member IdPConfigStore r => ScimTokenInfo -> Scim.ScimHandler (Sem r) (Maybe IdP) -tokenInfoToIdP ScimTokenInfo {stiIdP} = - mapM (lift . IdPConfigStore.getConfig) stiIdP - --- | Validate a handle (@userName@). -validateHandle :: MonadError Scim.ScimError m => Text -> m Handle -validateHandle txt = case parseHandle txt of - Just h -> pure h - Nothing -> - throwError $ - Scim.badRequest - Scim.InvalidValue - (Just (txt <> "is not a valid Wire handle")) - -- | Map the SCIM data on the spar and brig schemata, and throw errors if the SCIM data does -- not comply with the standard / our constraints. See also: 'ValidScimUser'. -- @@ -258,20 +244,32 @@ validateScimUser' :: Scim.User ST.SparTag -> m ST.ValidScimUser validateScimUser' errloc midp richInfoLimit user = do - unless (isNothing $ Scim.password user) $ throwError $ badRequest "Setting user passwords is not supported for security reasons." - veid <- mkValidExternalId midp (Scim.externalId user) + unless (isNothing $ Scim.password user) $ do + throwError $ badRequest "Setting user passwords is not supported for security reasons." + veid <- + let teamid = undefined + in mkScimUAuthId teamid midp (Scim.externalId user) handl <- validateHandle . Text.toLower . Scim.userName $ user -- FUTUREWORK: 'Scim.userName' should be case insensitive; then the toLower here would -- be a little less brittle. uname <- do let err msg = throwError . Scim.badRequest Scim.InvalidValue . Just $ cs msg <> " (" <> errloc <> ")" - either err pure $ Brig.mkUserName (Scim.displayName user) veid + either err pure $ mkUserNameScim (Scim.displayName user) veid richInfo <- validateRichInfo (Scim.extra user ^. ST.sueRichInfo) let active = Scim.active user lang <- maybe (throwError $ badRequest "Could not parse language. Expected format is ISO 639-1.") pure $ mapM parseLanguage $ Scim.preferredLanguage user mRole <- validateRole user pure $ ST.ValidScimUser veid handl uname richInfo (maybe True Scim.unScimBool active) (flip Locale Nothing <$> lang) mRole where + validateHandle :: Applicative m => Text -> m Handle + validateHandle txt = case parseHandle txt of + Just h -> pure h + Nothing -> + throwError $ + Scim.badRequest + Scim.InvalidValue + (Just (txt <> "is not a valid Wire handle")) + validRoleNames :: Text validRoleNames = cs $ intercalate ", " $ map (cs . toByteString') [minBound @Role .. maxBound] @@ -314,36 +312,36 @@ validateScimUser' errloc midp richInfoLimit user = do } pure richInfo --- | Given an 'externalId' and an 'IdP', construct a 'ST.ValidExternalId'. --- --- This is needed primarily in 'validateScimUser', but also in 'updateValidScimUser' to --- recover the 'SAML.UserRef' of the scim user before the update from the database. -mkValidExternalId :: +-- | Given an 'externalId' and the necessary context, construct a 'PartialUAuthId'. Needed +-- primarily in 'validateScimUser'. +mkScimUAuthId :: forall m. (MonadError Scim.ScimError m) => + TeamId -> Maybe IdP -> Maybe Text -> - m ST.ValidExternalId -mkValidExternalId _ Nothing = + m ScimUAuthId +mkScimUAuthId _ _ Nothing = throwError $ Scim.badRequest Scim.InvalidValue (Just "externalId is required") -mkValidExternalId Nothing (Just extid) = do +mkScimUAuthId teamid Nothing (Just extid) = do let err = Scim.badRequest Scim.InvalidValue (Just "externalId must be a valid email address or (if there is a SAML IdP) a valid SAML NameID") - maybe (throwError err) (pure . ST.EmailOnly) $ parseEmail extid -mkValidExternalId (Just idp) (Just extid) = do + maybe + (throwError err) + (\eml -> pure $ UAuthId Nothing (pure extid) (pure $ EmailWithSource eml EmailFromScimExternalIdField) teamid) + $ parseEmail extid +mkScimUAuthId teamid (Just idp) (Just extid) = do let issuer = idp ^. SAML.idpMetadata . SAML.edIssuer subject <- validateSubject extid let uref = SAML.UserRef issuer subject - pure $ case parseEmail extid of - Just email -> ST.EmailAndUref email uref - Nothing -> ST.UrefOnly uref + mbEmail = parseEmail extid + pure $ UAuthId (Just uref) (pure extid) ((`EmailWithSource` EmailFromScimExternalIdField) <$> mbEmail) teamid where - -- Validate a subject ID (@externalId@). validateSubject :: Text -> m SAML.NameID validateSubject txt = do unameId :: SAML.UnqualifiedNameID <- do @@ -385,8 +383,8 @@ logEmail email = Log.field "email_sha256" (sha256String . cs . show $ email) logVSU :: ST.ValidScimUser -> (Msg -> Msg) -logVSU (ST.ValidScimUser veid handl _name _richInfo _active _lang _role) = - maybe id logEmail (veidEmail veid) +logVSU (ST.ValidScimUser uauthid handl _name _richInfo _active _lang _role) = + maybe id logEmail (ewsEmail <$> uaEmail uauthid) . logHandle handl logTokenInfo :: ScimTokenInfo -> (Msg -> Msg) @@ -398,13 +396,6 @@ logScimUserId = logUser . Scim.id . Scim.thing logScimUserIds :: Scim.ListResponse (Scim.StoredUser ST.SparTag) -> (Msg -> Msg) logScimUserIds lresp = foldl' (.) id (logScimUserId <$> Scim.resources lresp) -veidEmail :: ST.ValidExternalId -> Maybe Email -veidEmail (ST.EmailAndUref email _) = Just email -veidEmail (ST.UrefOnly _) = Nothing -veidEmail (ST.EmailOnly email) = Just email - --- in ScimTokenHash (cs @ByteString @Text (convertToBase Base64 digest)) - -- | Creates a SCIM User. -- -- User is created in Brig first, and then in SCIM and SAML. @@ -454,29 +445,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- is already in use and stops POSTing} -- Generate a UserId will be used both for scim user in spar and for brig. - buid <- - lift $ do - buid <- - ST.runValidExternalIdEither - ( \uref -> - do - -- FUTUREWORK: outsource this and some other fragments from - -- `createValidScimUser` into a function `createValidScimUserBrig` similar - -- to `createValidScimUserSpar`? - uid <- Id <$> Random.uuid - BrigAccess.createSAML uref uid stiTeam name ManagedByScim (Just handl) (Just richInfo) language (fromMaybe defaultRole role) - ) - ( \email -> do - buid <- BrigAccess.createNoSAML email stiTeam name language (fromMaybe defaultRole role) - BrigAccess.setHandle buid handl -- FUTUREWORK: possibly do the same one req as we do for saml? - pure buid - ) - veid - - Logger.debug ("createValidScimUser: brig says " <> show buid) - - BrigAccess.setRichInfo buid richInfo - pure buid + buid <- createValidScimUserBrig stiTeam veid name handl richInfo language role -- {If we crash now, a POST retry will fail with 409 user already exists. -- Azure at some point will retry with GET /Users?filter=userName eq handle @@ -497,7 +466,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid createValidScimUserSpar stiTeam buid storedUser veid -- If applicable, trigger email validation procedure on brig. - lift $ Spar.App.validateEmail (Just stiTeam) buid `mapM_` veidEmail veid + lift $ (Spar.App.makeBrigValidateEmail (Just stiTeam) buid . ewsEmail) `mapM_` (uaEmail veid) -- TODO: suspension via scim is brittle, and may leave active users behind: if we don't -- reach the following line due to a crash, the user will be active. @@ -508,6 +477,39 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid when (new /= old) $ BrigAccess.setStatus buid new pure storedUser +createValidScimUserBrig :: + forall m r. + ( (m ~ Scim.ScimHandler (Sem r)), + Member BrigAccess r, + Member Random r, + Member (Logger String) r + ) => + TeamId -> + ScimUAuthId -> + Name -> + Handle -> + RI.RichInfo -> + Maybe Locale -> + Maybe Role -> + m UserId +createValidScimUserBrig stiTeam veid name handl richInfo language role = do + buid <- case (uaSamlId veid, uaEmail veid) of + (Just uref, _) -> lift $ do + uid <- Id <$> Random.uuid + BrigAccess.createSAML uref uid stiTeam name ManagedByScim (Just handl) (Just richInfo) language (fromMaybe defaultRole role) + (Nothing, Just (EmailWithSource email _)) -> lift $ do + buid <- BrigAccess.createNoSAML email stiTeam name language (fromMaybe defaultRole role) + BrigAccess.setHandle buid handl + pure buid + (Nothing, Nothing) -> do + throwError $ Scim.badRequest Scim.InvalidValue (Just "I need at least email address *or* saml credentials.") + + lift $ do + Logger.debug ("createValidScimUser: brig says " <> show buid) + BrigAccess.setRichInfo buid richInfo + + pure buid + -- | Store scim timestamps, saml credentials, scim externalId locally in spar. Table -- `spar.scim_external` gets an entry iff there is no `UserRef`: if there is, we don't do a -- lookup in that table either, but compute the `externalId` from the `UserRef`. @@ -521,18 +523,12 @@ createValidScimUserSpar :: TeamId -> UserId -> Scim.StoredUser ST.SparTag -> - ST.ValidExternalId -> + ScimUAuthId -> m () -createValidScimUserSpar stiTeam uid storedUser veid = lift $ do +createValidScimUserSpar stiTeam uid storedUser uauthid = lift $ do ScimUserTimesStore.write storedUser - -- This uses the "both" variant to always write all applicable index tables, even if - -- `spar.scim_external` is never consulted as long as there is an IdP. This is hoped to - -- mitigate logic errors in this code and corner cases. (eg., if the IdP is later removed?) - ST.runValidExternalIdBoth - (>>) - (`SAMLUserStore.insert` uid) - (\email -> ScimExternalIdStore.insert stiTeam email uid) - veid + ScimExternalIdStore.insert stiTeam (runIdentity . uaScimExternalId $ uauthid) uid + forM_ (uaSamlId uauthid) $ \uref -> SAMLUserStore.insert uref uid -- TODO(arianvp): how do we get this safe w.r.t. race conditions / crashes? updateValidScimUser :: @@ -586,7 +582,30 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = updScimStoredUser (synthesizeScimUser newValidScimUser) oldScimStoredUser when (oldValidScimUser ^. ST.vsuExternalId /= newValidScimUser ^. ST.vsuExternalId) $ - updateVsuUref stiTeam uid (oldValidScimUser ^. ST.vsuExternalId) (newValidScimUser ^. ST.vsuExternalId) + let updateVsuUref :: + ( Member GalleyAccess r, + Member BrigAccess r, + Member ScimExternalIdStore r, + Member SAMLUserStore r + ) => + TeamId -> + UserId -> + ScimUAuthId -> + ScimUAuthId -> + Sem r () + updateVsuUref team uid old new = do + {- + case (veidEmail old, veidEmail new) of + (mo, mn@(Just email)) | mo /= mn -> Spar.App.makeBrigValidateEmail (Just team) uid email + _ -> pure () + + old & ST.runValidExternalIdBoth (>>) (SAMLUserStore.delete uid) (ScimExternalIdStore.delete team) + new & ST.runValidExternalIdBoth (>>) (`SAMLUserStore.insert` uid) (\email -> ScimExternalIdStore.insert team email uid) + + BrigAccess.setVeid uid new + -} + undefined + in updateVsuUref stiTeam uid (oldValidScimUser ^. ST.vsuExternalId) (newValidScimUser ^. ST.vsuExternalId) when (newValidScimUser ^. ST.vsuName /= oldValidScimUser ^. ST.vsuName) $ BrigAccess.setName uid (newValidScimUser ^. ST.vsuName) @@ -613,27 +632,6 @@ updateValidScimUser tokinfo@ScimTokenInfo {stiTeam} uid nvsu = ScimUserTimesStore.write newScimStoredUser Scim.getUser tokinfo uid -updateVsuUref :: - ( Member GalleyAccess r, - Member BrigAccess r, - Member ScimExternalIdStore r, - Member SAMLUserStore r - ) => - TeamId -> - UserId -> - ST.ValidExternalId -> - ST.ValidExternalId -> - Sem r () -updateVsuUref team uid old new = do - case (veidEmail old, veidEmail new) of - (mo, mn@(Just email)) | mo /= mn -> Spar.App.validateEmail (Just team) uid email - _ -> pure () - - old & ST.runValidExternalIdBoth (>>) (SAMLUserStore.delete uid) (ScimExternalIdStore.delete team) - new & ST.runValidExternalIdBoth (>>) (`SAMLUserStore.insert` uid) (\email -> ScimExternalIdStore.insert team email uid) - - BrigAccess.setVeid uid new - toScimStoredUser' :: HasCallStack => UTCTimeMillis -> @@ -759,16 +757,10 @@ deleteScimUser tokeninfo@ScimTokenInfo {stiTeam, stiIdP} uid = deleteUserInSpar brigUser = do mIdpConfig <- mapM (lift . IdPConfigStore.getConfig) stiIdP - case Brig.veidFromBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> mIdpConfig) of - Left _ -> pure () - Right veid -> - lift $ - ST.runValidExternalIdBoth - (>>) - (SAMLUserStore.delete uid) - (ScimExternalIdStore.delete stiTeam) - veid - lift $ ScimUserTimesStore.delete uid + lift $ do + SAMLUserStore.delete uid `mapM_` (userPartialUAuthId brigUser >>= uaSamlId) + ScimExternalIdStore.delete stiTeam `mapM_` (userPartialUAuthId brigUser >>= uaScimExternalId) + ScimUserTimesStore.delete uid ---------------------------------------------------------------------------- -- Utilities @@ -792,8 +784,7 @@ calculateVersion uid usr = Scim.Weak (Text.pack (show h)) h :: Digest SHA256 h = hashlazy (Aeson.encode (Scim.WithId uid usr)) --- | --- Check that the UserRef is not taken. +-- | Check that the UserRef is not taken. -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. @@ -803,7 +794,7 @@ assertExternalIdUnused :: Member SAMLUserStore r ) => TeamId -> - ST.ValidExternalId -> + ScimUAuthId -> Scim.ScimHandler (Sem r) () assertExternalIdUnused = assertExternalIdInAllowedValues @@ -814,21 +805,24 @@ assertExternalIdUnused = -- -- ASSUMPTION: every scim user has a 'SAML.UserRef', and the `SAML.NameID` in it corresponds -- to a single `externalId`. +-- +-- TODO: Can we maybe discard this function? With UAuthId, have we properly scoped scim +-- external ids and can allow the same id in two different teams? assertExternalIdNotUsedElsewhere :: ( Member BrigAccess r, Member ScimExternalIdStore r, Member SAMLUserStore r ) => TeamId -> - ST.ValidExternalId -> + ScimUAuthId -> UserId -> Scim.ScimHandler (Sem r) () -assertExternalIdNotUsedElsewhere tid veid wireUserId = +assertExternalIdNotUsedElsewhere tid uauthid wireUserId = assertExternalIdInAllowedValues [Nothing, Just wireUserId] "externalId already in use by another Wire user" tid - veid + uauthid assertExternalIdInAllowedValues :: ( Member BrigAccess r, @@ -838,18 +832,36 @@ assertExternalIdInAllowedValues :: [Maybe UserId] -> Text -> TeamId -> - ST.ValidExternalId -> + ScimUAuthId -> Scim.ScimHandler (Sem r) () -assertExternalIdInAllowedValues allowedValues errmsg tid veid = do - isGood <- - lift $ - ST.runValidExternalIdBoth - (\ma mb -> (&&) <$> ma <*> mb) - (fmap ((`elem` allowedValues) . fmap userId) . getUserByUrefUnsafe) - (fmap (`elem` allowedValues) . getUserIdByScimExternalId tid) - veid - unless isGood $ +assertExternalIdInAllowedValues allowedValues errmsg tid uauthid = do + urefGood <- + maybe + (pure True) + (lift . fmap ((`elem` allowedValues) . fmap userId) . getUserByUrefUnsafe) + (uaSamlId uauthid) + + eidGood <- + lift $ getUserIdByScimExternalId tid uauthid <&> (`elem` allowedValues) + + unless (urefGood && eidGood) $ throwError Scim.conflict {Scim.detail = Just errmsg} + where + getUserIdByScimExternalId :: + ( Member BrigAccess r, + Member ScimExternalIdStore r + ) => + TeamId -> + ScimUAuthId -> + Sem r (Maybe UserId) + getUserIdByScimExternalId teamid (runIdentity . uaScimExternalId -> eid) = do + muid <- ScimExternalIdStore.lookup teamid eid + case muid of + Nothing -> pure Nothing + Just uid -> do + let withpending = WithPendingInvitations + itis <- isJust <$> Brig.getBrigUserTeam withpending uid + pure $ if itis then Just uid else Nothing assertHandleUnused :: Member BrigAccess r => Handle -> Scim.ScimHandler (Sem r) () assertHandleUnused = assertHandleUnused' "userName is already taken" @@ -879,15 +891,15 @@ synthesizeStoredUser :: Member ScimUserTimesStore r ) => UserAccount -> - ST.ValidExternalId -> + ScimUAuthId -> Scim.ScimHandler (Sem r) (Scim.StoredUser ST.SparTag) -synthesizeStoredUser usr veid = +synthesizeStoredUser usr uauthid = logScim ( logFunction "Spar.Scim.User.synthesizeStoredUser" . logUser (userId . accountUser $ usr) . maybe id logHandle (userHandle . accountUser $ usr) . maybe id logTeam (userTeam . accountUser $ usr) - . maybe id logEmail (veidEmail veid) + . maybe id logEmail (ewsEmail <$> uaEmail uauthid) ) logScimUserId $ do @@ -921,7 +933,7 @@ synthesizeStoredUser usr veid = storedUser <- synthesizeStoredUser' uid - veid + uauthid (userDisplayName (accountUser usr)) handle richInfo @@ -941,7 +953,7 @@ synthesizeStoredUser usr veid = synthesizeStoredUser' :: UserId -> - ST.ValidExternalId -> + ScimUAuthId -> Name -> Handle -> RI.RichInfo -> @@ -952,12 +964,12 @@ synthesizeStoredUser' :: Locale -> Maybe Role -> MonadError Scim.ScimError m => m (Scim.StoredUser ST.SparTag) -synthesizeStoredUser' uid veid dname handle richInfo accStatus createdAt lastUpdatedAt baseuri locale mbRole = do +synthesizeStoredUser' uid uauthid dname handle richInfo accStatus createdAt lastUpdatedAt baseuri locale mbRole = do let scimUser :: Scim.User ST.SparTag scimUser = synthesizeScimUser ST.ValidScimUser - { ST._vsuExternalId = veid, + { ST._vsuExternalId = uauthid, ST._vsuHandle = handle {- 'Maybe' there is one in @usr@, but we want the type checker to make sure this exists, so we add it here redundantly, without the 'Maybe'. -}, @@ -974,15 +986,14 @@ synthesizeScimUser :: ST.ValidScimUser -> Scim.User ST.SparTag synthesizeScimUser info = let Handle userName = info ^. ST.vsuHandle in (Scim.empty ST.userSchemas userName (ST.ScimUserExtra (info ^. ST.vsuRichInfo))) - { Scim.externalId = Brig.renderValidExternalId $ info ^. ST.vsuExternalId, + { Scim.externalId = info ^. ST.vsuExternalId . to (Just . runIdentity . uaScimExternalId), Scim.displayName = Just $ fromName (info ^. ST.vsuName), Scim.active = Just . Scim.ScimBool $ info ^. ST.vsuActive, Scim.preferredLanguage = lan2Text . lLanguage <$> info ^. ST.vsuLocale, Scim.roles = maybe [] ((: []) . cs . toByteString) (info ^. ST.vsuRole) } --- TODO: now write a test, either in /integration or in spar, whichever is easier. (spar) - +-- | Find user in brig by id. If not already under scim control, import it. getUserById :: forall r. ( Member BrigAccess r, @@ -996,40 +1007,79 @@ getUserById :: ) => Maybe IdP -> TeamId -> - UserId -> + Either UserId UserAccount -> MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) -getUserById midp stiTeam uid = do - brigUser <- MaybeT . lift $ BrigAccess.getAccount Brig.WithPendingInvitations uid - let mbveid = - Brig.veidFromBrigUser - (accountUser brigUser) - ((^. SAML.idpMetadata . SAML.edIssuer) <$> midp) - case mbveid of - Right veid | userTeam (accountUser brigUser) == Just stiTeam -> lift $ do - storedUser :: Scim.StoredUser ST.SparTag <- synthesizeStoredUser brigUser veid +getUserById midp stiTeam eUidUacc = do + brigAccount@(accountUser -> brigUser) <- case eUidUacc of + Left uid -> MaybeT . lift $ BrigAccess.getAccount Brig.WithPendingInvitations uid + Right uacc -> MaybeT . pure . Just $ uacc + let uid = userId brigUser + + uauthid :: ScimUAuthId <- + (MaybeT . pure) . either (const Nothing) partialToScimUAuthId $ + scimImportBrigUser brigUser ((^. SAML.idpMetadata . SAML.edIssuer) <$> midp) + + unless (userTeam brigUser == Just (uaTeamId uauthid)) $ do + throwError -- TODO + undefined + + storedUser :: Scim.StoredUser ST.SparTag <- lift $ synthesizeStoredUser brigAccount uauthid + lift $ assertExternalIdNotUsedElsewhere stiTeam uauthid uid + + lift $ do + when (uauthidChanged brigUser uauthid) $ do + lift $ BrigAccess.setVeid uid (scimToPartialUAuthId uauthid) + when (managedByChanged brigUser) $ do -- if we get a user from brig that hasn't been touched by scim yet, we call this -- function to move it under scim control. - assertExternalIdNotUsedElsewhere stiTeam veid uid - createValidScimUserSpar stiTeam uid storedUser veid - lift $ do - when (veidChanged (accountUser brigUser) veid) $ - BrigAccess.setVeid uid veid - when (managedByChanged (accountUser brigUser)) $ - BrigAccess.setManagedBy uid ManagedByScim - pure storedUser - _ -> Applicative.empty + createValidScimUserSpar stiTeam uid storedUser uauthid + lift $ BrigAccess.setManagedBy uid ManagedByScim + + pure storedUser where - veidChanged :: User -> ST.ValidExternalId -> Bool - veidChanged usr veid = case userIdentity usr of + uauthidChanged :: User -> ScimUAuthId -> Bool + uauthidChanged usr uauthid = case userIdentity usr of Nothing -> True Just (FullIdentity _ _) -> True Just (EmailIdentity _) -> True Just (PhoneIdentity _) -> True - Just (SSOIdentity ssoid _ _) -> Brig.veidToUserSSOId veid /= ssoid + Just (UAuthIdentity uauthid') -> partialToScimUAuthId uauthid' /= Just uauthid managedByChanged :: User -> Bool managedByChanged usr = userManagedBy usr /= ManagedByScim +-- | Move a brig user that has been created via team-settings (or saml implicit user creation) +-- under scim management. If the brig user has a 'UAuthId', add `uaScimExternalId` if missing +-- and return. Otherwise, if the user has an email, construct a return value from that and +-- the optional saml issuer. If a user only has a phone number, or no identity at all, or no +-- team id, throw an error. +scimImportBrigUser :: MonadError String m => User -> Maybe SAML.Issuer -> m PartialUAuthId +scimImportBrigUser usr mIssuer = case (userPartialUAuthId usr, userEmail usr, userTeam usr, mIssuer) of + (Just uauthid, _, _, _) -> + pure uauthid {uaScimExternalId = Just scimExternalId} + (Nothing, Just email, Just tid, Just issuer) -> + pure $ + UAuthId + (Just (SAML.UserRef issuer (emailToSAMLNameID email))) + (Just scimExternalId) + (Just (emailWithSource email)) + tid + (Nothing, Just email, Just tid, Nothing) -> + pure $ + UAuthId + Nothing + (Just scimExternalId) + (Just (emailWithSource email)) + tid + (Nothing, Nothing, _, _) -> + throwError "user has neither ssoIdentity nor userEmail" + (_, _, Nothing, _) -> + throwError "not a team user" + where + emailWithSource _email = undefined -- EmailWithSource email _source + scimExternalId = undefined + +-- | find user in brig by handle and move under scim control (wrapper for `getUserById`). scimFindUserByHandle :: forall r. ( Member BrigAccess r, @@ -1048,8 +1098,9 @@ scimFindUserByHandle :: scimFindUserByHandle mIdpConfig stiTeam hndl = do handle <- MaybeT . pure . parseHandle . Text.toLower $ hndl brigUser <- MaybeT . lift . BrigAccess.getByHandle $ handle - getUserById mIdpConfig stiTeam . userId . accountUser $ brigUser + getUserById mIdpConfig stiTeam (Right brigUser) +-- | find user in brig by handle and move under scim control (wrapper for `getUserById`). -- | Construct a 'ValidExternalid'. If it an 'Email', find the non-SAML SCIM user in spar; if -- that fails, find the user by email in brig. If it is a 'UserRef', find the SAML user. -- Return the result as a SCIM user. @@ -1072,16 +1123,11 @@ scimFindUserByEmail :: Text -> MaybeT (Scim.ScimHandler (Sem r)) (Scim.StoredUser ST.SparTag) scimFindUserByEmail mIdpConfig stiTeam email = do - -- Azure has been observed to search for externalIds that are not emails, even if the - -- mapping is set up like it should be. This is a problem: if there is no SAML IdP, 'mkValidExternalId' - -- only supports external IDs that are emails. This is a missing feature / bug in spar tracked in - -- https://wearezeta.atlassian.net/browse/SQSERVICES-157; once it is fixed, we should go back to - -- throwing errors returned by 'mkValidExternalId' here, but *not* throw an error if the externalId is - -- a UUID, or any other text that is valid according to SCIM. - veid <- MaybeT (either (const Nothing) Just <$> runExceptT (mkValidExternalId mIdpConfig (pure email))) - uid <- MaybeT . lift $ ST.runValidExternalIdEither withUref withEmailOnly veid - brigUser <- MaybeT . lift . BrigAccess.getAccount Brig.WithPendingInvitations $ uid - getUserById mIdpConfig stiTeam . userId . accountUser $ brigUser + uauthid <- MaybeT (either (const Nothing) Just <$> runExceptT (mkScimUAuthId stiTeam mIdpConfig (pure email))) + uid <- MaybeT . lift $ case (uaSamlId uauthid, uaEmail uauthid) of + (Just uref, _) -> withUref uref + (Nothing, Just (EmailWithSource email _)) -> withEmailOnly email + getUserById mIdpConfig stiTeam (Left uid) where withUref :: SAML.UserRef -> Sem r (Maybe UserId) withUref uref = @@ -1095,7 +1141,7 @@ scimFindUserByEmail mIdpConfig stiTeam email = do -- FUTUREWORK: we could also always lookup brig, that's simpler and possibly faster, -- and it never should be visible in spar, but not in brig. inspar, inbrig :: Sem r (Maybe UserId) - inspar = ScimExternalIdStore.lookup stiTeam eml + inspar = ScimExternalIdStore.lookup stiTeam (fromEmail eml) inbrig = userId . accountUser <$$> BrigAccess.getByEmail eml logFilter :: Filter -> (Msg -> Msg) @@ -1113,22 +1159,21 @@ logFilter (FilterAttrCompare attr op val) = <> sha256String s <> (if isJust (UUID.fromText s) then " original is a UUID" else "") -{- TODO: might be useful later. -~~~~~~~~~~~~~~~~~~~~~~~~~ +{- -- | Parse a name from a user profile into an SCIM name (Okta wants given -- name and last name, so we break our names up to satisfy Okta). -- --- TODO: use the same algorithm as Wire clients use. +-- TODO: use the same algorithm that Wire clients use. toScimName :: Name -> Scim.Name toScimName (Name name) = Scim.Name - { Scim.formatted = Just name - , Scim.givenName = Just first - , Scim.familyName = if Text.null rest then Nothing else Just rest - , Scim.middleName = Nothing - , Scim.honorificPrefix = Nothing - , Scim.honorificSuffix = Nothing + { Scim.formatted = Just name, + Scim.givenName = Just first, + Scim.familyName = if Text.null rest then Nothing else Just rest, + Scim.middleName = Nothing, + Scim.honorificPrefix = Nothing, + Scim.honorificSuffix = Nothing } where (first, Text.drop 1 -> rest) = Text.breakOn " " name @@ -1137,33 +1182,17 @@ toScimName (Name name) = toScimPhone :: Phone -> Scim.Phone toScimPhone (Phone phone) = Scim.Phone - { Scim.typ = Nothing - , Scim.value = Just phone + { Scim.typ = Nothing, + Scim.value = Just phone } -- | Convert from the Wire email type to the SCIM email type. toScimEmail :: Email -> Scim.Email toScimEmail (Email eLocal eDomain) = Scim.Email - { Scim.typ = Nothing - , Scim.value = Scim.EmailAddress2 - (unsafeEmailAddress (encodeUtf8 eLocal) (encodeUtf8 eDomain)) - , Scim.primary = Just True + { Scim.typ = Nothing, + Scim.value = Scim.EmailAddress2 (unsafeEmailAddress (encodeUtf8 eLocal) (encodeUtf8 eDomain)), + Scim.primary = Just True } -} - --- Note [error handling] --- ~~~~~~~~~~~~~~~~~ --- --- FUTUREWORK: There are two problems with error handling here: --- --- 1. We want all errors originating from SCIM handlers to be thrown as SCIM --- errors, not as Spar errors. Currently errors thrown from things like --- 'getTeamMembers' will look like Spar errors and won't be wrapped into --- the 'ScimError' type. This might or might not be important, depending --- on what is expected by apps that use the SCIM interface. --- --- 2. We want generic error descriptions in response bodies, while still --- logging nice error messages internally. The current messages might --- be giving too many internal details away. diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 8fd12220ee..bda0d51c6e 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -58,10 +58,9 @@ import Wire.API.User (AccountStatus (..), DeleteUserResult, VerificationAction) import Wire.API.User.Identity import Wire.API.User.Profile import Wire.API.User.RichInfo as RichInfo -import Wire.API.User.Scim (ValidExternalId (..)) data BrigAccess m a where - CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> Maybe Locale -> Role -> BrigAccess m UserId + CreateSAML :: SAML.UserRef -> Maybe (Text {- scim external id -}, EmailWithSource) -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> Maybe Locale -> Role -> BrigAccess m UserId CreateNoSAML :: Email -> TeamId -> Name -> Maybe Locale -> Role -> BrigAccess m UserId UpdateEmail :: UserId -> Email -> BrigAccess m () GetAccount :: HavePendingInvitations -> UserId -> BrigAccess m (Maybe UserAccount) @@ -70,7 +69,7 @@ data BrigAccess m a where SetName :: UserId -> Name -> BrigAccess m () SetHandle :: UserId -> Handle {- not 'HandleUpdate'! -} -> BrigAccess m () SetManagedBy :: UserId -> ManagedBy -> BrigAccess m () - SetVeid :: UserId -> ValidExternalId -> BrigAccess m () + SetVeid :: UserId -> PartialUAuthId -> BrigAccess m () SetRichInfo :: UserId -> RichInfo -> BrigAccess m () SetLocale :: UserId -> Maybe Locale -> BrigAccess m () GetRichInfo :: UserId -> BrigAccess m RichInfo diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs index 0331cca84d..5931bdfc49 100644 --- a/services/spar/src/Spar/Sem/BrigAccess/Http.hs +++ b/services/spar/src/Spar/Sem/BrigAccess/Http.hs @@ -43,7 +43,7 @@ brigAccessToHttp :: brigAccessToHttp mgr req = interpret $ viaRunHttp (RunHttpEnv mgr req) . \case - CreateSAML u itlu itlt n m h ri ml r -> Intra.createBrigUserSAML u itlu itlt n m h ri ml r + CreateSAML u mbscim itlu itlt n m h ri ml r -> Intra.createBrigUserSAML u mbscim itlu itlt n m h ri ml r CreateNoSAML e itlt n ml r -> Intra.createBrigUserNoSAML e itlt n ml r UpdateEmail itlu e -> Intra.updateEmail itlu e GetAccount h itlu -> Intra.getBrigUserAccount h itlu diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore.hs index 7ea4fe759c..3dd3e2c3a1 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore.hs @@ -26,15 +26,14 @@ module Spar.Sem.ScimExternalIdStore where import Data.Id (TeamId, UserId) -import Imports (Maybe, Show) +import Imports (Maybe, Show, Text) import Polysemy import Polysemy.Check (deriveGenericK) -import Wire.API.User.Identity (Email) data ScimExternalIdStore m a where - Insert :: TeamId -> Email -> UserId -> ScimExternalIdStore m () - Lookup :: TeamId -> Email -> ScimExternalIdStore m (Maybe UserId) - Delete :: TeamId -> Email -> ScimExternalIdStore m () + Insert :: TeamId -> Text -> UserId -> ScimExternalIdStore m () + Lookup :: TeamId -> Text -> ScimExternalIdStore m (Maybe UserId) + Delete :: TeamId -> Text -> ScimExternalIdStore m () deriving instance Show (ScimExternalIdStore m a) diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Cassandra.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Cassandra.hs index 6dad02d5fa..7099e98129 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore/Cassandra.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Cassandra.hs @@ -27,7 +27,6 @@ import Data.Id import Imports import Polysemy import Spar.Sem.ScimExternalIdStore (ScimExternalIdStore (..)) -import Wire.API.User.Identity scimExternalIdStoreToCassandra :: forall m r a. @@ -43,27 +42,25 @@ scimExternalIdStoreToCassandra = -- | If a scim externalId does not have an associated saml idp issuer, it cannot be stored in -- table @spar.user@. In those cases, and only in those cases, we store the mapping to --- 'UserId' here. (Note that since there is no associated IdP, the externalId is required to --- be an email address, so we enforce that in the type signature, even though we only use it --- as a 'Text'.) -insertScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> UserId -> m () -insertScimExternalId tid (fromEmail -> email) uid = - retry x5 . write insert $ params LocalQuorum (tid, email, uid) +-- 'UserId' here. +insertScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Text -> UserId -> m () +insertScimExternalId tid eid uid = + retry x5 . write insert $ params LocalQuorum (tid, eid, uid) where insert :: PrepQuery W (TeamId, Text, UserId) () insert = "INSERT INTO scim_external (team, external_id, user) VALUES (?, ?, ?)" -- | The inverse of 'insertScimExternalId'. -lookupScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> m (Maybe UserId) -lookupScimExternalId tid (fromEmail -> email) = runIdentity <$$> (retry x1 . query1 sel $ params LocalQuorum (tid, email)) +lookupScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Text -> m (Maybe UserId) +lookupScimExternalId tid eid = runIdentity <$$> (retry x1 . query1 sel $ params LocalQuorum (tid, eid)) where sel :: PrepQuery R (TeamId, Text) (Identity UserId) sel = "SELECT user FROM scim_external WHERE team = ? and external_id = ?" -- | The other inverse of 'insertScimExternalId' :). -deleteScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Email -> m () -deleteScimExternalId tid (fromEmail -> email) = - retry x5 . write delete $ params LocalQuorum (tid, email) +deleteScimExternalId :: (HasCallStack, MonadClient m) => TeamId -> Text -> m () +deleteScimExternalId tid eid = + retry x5 . write delete $ params LocalQuorum (tid, eid) where delete :: PrepQuery W (TeamId, Text) () delete = "DELETE FROM scim_external WHERE team = ? and external_id = ?" diff --git a/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs b/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs index 03b742c3a6..758ee5fe09 100644 --- a/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs +++ b/services/spar/src/Spar/Sem/ScimExternalIdStore/Mem.hs @@ -28,13 +28,12 @@ import Imports import Polysemy import Polysemy.State import Spar.Sem.ScimExternalIdStore -import Wire.API.User.Identity (Email) scimExternalIdStoreToMem :: Sem (ScimExternalIdStore ': r) a -> - Sem r (Map (TeamId, Email) UserId, a) + Sem r (Map (TeamId, Text) UserId, a) scimExternalIdStoreToMem = (runState mempty .) $ reinterpret $ \case - Insert tid em uid -> modify $ M.insert (tid, em) uid - Lookup tid em -> gets $ M.lookup (tid, em) - Delete tid em -> modify $ M.delete (tid, em) + Insert tid eid uid -> modify $ M.insert (tid, eid) uid + Lookup tid eid -> gets $ M.lookup (tid, eid) + Delete tid eid -> modify $ M.delete (tid, eid) diff --git a/services/spar/test-integration/Test/Spar/APISpec.hs b/services/spar/test-integration/Test/Spar/APISpec.hs index a28d3f5ca6..5aeb0fafc2 100644 --- a/services/spar/test-integration/Test/Spar/APISpec.hs +++ b/services/spar/test-integration/Test/Spar/APISpec.hs @@ -77,6 +77,7 @@ import Spar.Options import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.BrigAccess as BrigAccess import qualified Spar.Sem.IdPConfigStore as IdPEffect +import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import Text.XML.DSig (SignPrivCreds, mkSignCredsWithCert) import qualified URI.ByteString as URI import URI.ByteString.QQ (uri) @@ -129,7 +130,7 @@ specMisc = do it "spar /i/status" $ do env <- ask ping (env ^. teSpar) `shouldRespondWith` (== ()) - describe "rule do disallow http idp urls." $ do + describe "disallow http idp urls." $ do let check :: Bool -> TestSpar () check isHttps = do somemeta <- do @@ -514,7 +515,7 @@ specFinalizeLogin = do authnreq <- negotiateAuthnRequest idp authnresp <- runSimpleSP $ mkAuthnResponseWithSubj subj privcreds idp spmeta authnreq True loginSuccess =<< submitAuthnResponse tid authnresp - ssoid <- getSsoidViaAuthResp authnresp + ssoid <- getUAuthIdViaAuthResp authnresp ssoToUidSpar tid ssoid let createEmailSubject email = do @@ -1062,8 +1063,7 @@ specCRUDIdentityProvider = do | h <- [False, True], -- are users scim provisioned or via team management invitations? u <- [False, True], -- do we use update-by-put or update-by-post? (see below) (h, u) /= (True, False), -- scim doesn't not work with more than one idp (https://wearezeta.atlassian.net/browse/WPB-689) - e <- [False, True], -- is the externalId an email address? (if not, it's a uuidv4, and the email address is stored in `emails`) - (u, u, e) /= (True, True, False) -- TODO: this combination fails, see https://github.com/wireapp/wire-server/pull/3563) + e <- [False, True] -- is the externalId an email address? (if not, it's a uuidv4, and the email address is stored in `emails`) ] $ \(haveScim, updateNotReplace, externalIdIsEmail) -> do it ("creates new idp, setting old_issuer; sets replaced_by in old idp; scim user search still works " <> show (haveScim, updateNotReplace, externalIdIsEmail)) $ do @@ -1078,7 +1078,7 @@ specCRUDIdentityProvider = do user <- if externalIdIsEmail then fst <$> randomScimUserWithEmail - else randomScimUser + else fst <$> randomScimUserWithNick scimStoredUser <- createUser tok user pure $ Just (tok, scimStoredUser, user) else pure Nothing @@ -1319,8 +1319,8 @@ specScimAndSAML = do -- UserRef maps onto correct UserId in spar (and back). userid' <- getUserIdViaRef' userref liftIO $ ('i', userid') `shouldBe` ('i', Just userid) - userssoid <- getSsoidViaSelf' userid - liftIO $ ('r', preview veidUref <$$> (Intra.veidFromUserSSOId <$> userssoid)) `shouldBe` ('r', Just (Right (Just userref))) + uaid <- getUAuthIdViaSelf' userid + liftIO $ ('r', uaSamlId =<< uaid) `shouldBe` ('r', Just userref) -- login a user for the first time with the scim-supplied credentials authnreq <- negotiateAuthnRequest idp spmeta <- getTestSPMetadata tid @@ -1368,7 +1368,7 @@ specScimAndSAML = do spmeta <- getTestSPMetadata (idp ^. idpExtraInfo . team) authnresp :: SignedAuthnResponse <- runSimpleSP $ mkAuthnResponseWithSubj subjectWithQualifier privcreds idp spmeta authnreq True - ssoid <- getSsoidViaAuthResp authnresp + ssoid <- getUAuthIdViaAuthResp authnresp mid <- ssoToUidSpar tid ssoid liftIO $ mid `shouldBe` Just (ScimT.scimUserId scimStoredUser) @@ -1553,11 +1553,14 @@ specSsoSettings = do -- TODO: what else needs to be tested, beyond the pending tests listed here? -- TODO: what tests can go to saml2-web-sso package? -getSsoidViaAuthResp :: HasCallStack => SignedAuthnResponse -> TestSpar UserSSOId -getSsoidViaAuthResp aresp = do +getUAuthIdViaAuthResp :: HasCallStack => SignedAuthnResponse -> TestSpar PartialUAuthId +getUAuthIdViaAuthResp aresp = do parsed :: AuthnResponse <- either error pure . parseFromDocument $ fromSignedAuthnResponse aresp - either error (pure . Intra.veidToUserSSOId . UrefOnly) $ getUserRef parsed + uref :: SAML.UserRef <- either (error . show) pure $ getUserRef parsed + Just (uid :: UserId) <- runSpar $ SAMLUserStore.get uref + Just (accountUser -> usr) <- runSpar $ BrigAccess.getAccount WithPendingInvitations uid + pure . fromJust . userPartialUAuthId $ usr specSparUserMigration :: SpecWith TestEnv specSparUserMigration = do @@ -1592,7 +1595,7 @@ specSparUserMigration = do authnresp <- runSimpleSP $ mkAuthnResponseWithSubj subject privcreds idp spmeta authnreq True sparresp <- submitAuthnResponse tid authnresp liftIO $ statusCode sparresp `shouldBe` 200 - ssoid <- getSsoidViaAuthResp authnresp + ssoid <- getUAuthIdViaAuthResp authnresp ssoToUidSpar tid ssoid liftIO $ mbUserId `shouldBe` Just memberUid diff --git a/services/spar/test-integration/Test/Spar/DataSpec.hs b/services/spar/test-integration/Test/Spar/DataSpec.hs index b81715f6f8..88bf3e556c 100644 --- a/services/spar/test-integration/Test/Spar/DataSpec.hs +++ b/services/spar/test-integration/Test/Spar/DataSpec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. -- @@ -32,7 +32,6 @@ import Polysemy import SAML2.WebSSO as SAML import Spar.App as App import Spar.Error (IdpDbError (IdpNotFound), SparCustomError (IdpDbError)) -import Spar.Intra.BrigApp (veidFromUserSSOId) import Spar.Options import qualified Spar.Sem.AReqIDStore as AReqIDStore import qualified Spar.Sem.AssIDStore as AssIDStore @@ -47,9 +46,9 @@ import Util.Scim import Util.Types import Web.Scim.Schema.Common as Scim.Common import Web.Scim.Schema.Meta as Scim.Meta +import Wire.API.User.Identity import Wire.API.User.IdentityProvider import Wire.API.User.Saml -import Wire.API.User.Scim spec :: SpecWith TestEnv spec = do @@ -232,8 +231,8 @@ testDeleteTeam = it "cleans up all the right tables after deletion" $ do storedUser2 <- createUser tok user2 -- Resolve the users' SSO ids let getUid = Scim.Common.id . Scim.Meta.thing - ssoid1 <- getSsoidViaSelf (getUid storedUser1) - ssoid2 <- getSsoidViaSelf (getUid storedUser2) + uauthid1 <- getUAuthIdViaSelf (getUid storedUser1) + uauthid2 <- getUAuthIdViaSelf (getUid storedUser2) -- Delete the team runSpar $ App.deleteTeam tid -- See that everything got cleaned up. @@ -248,24 +247,10 @@ testDeleteTeam = it "cleans up all the right tables after deletion" $ do liftIO $ tokens `shouldBe` [] -- The users from 'user': do - mbUser1 <- case veidFromUserSSOId ssoid1 of - Right veid -> - runSpar $ - runValidExternalIdEither - SAMLUserStore.get - undefined -- could be @Data.lookupScimExternalId@, but we don't hit that path. - veid - Left _email -> undefined -- runSparCass . Data.lookupScimExternalId . fromEmail $ _email + mbUser1 <- case uaSamlId uauthid1 of Just saml -> runSpar $ SAMLUserStore.get saml liftIO $ mbUser1 `shouldBe` Nothing do - mbUser2 <- case veidFromUserSSOId ssoid2 of - Right veid -> - runSpar $ - runValidExternalIdEither - SAMLUserStore.get - undefined - veid - Left _email -> undefined + mbUser2 <- case uaSamlId uauthid2 of Just saml -> runSpar $ SAMLUserStore.get saml liftIO $ mbUser2 `shouldBe` Nothing -- The config from 'idp': do diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index 9c2d61e2f9..e677a8ab4f 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -137,7 +137,7 @@ specImportToScimFromSAML = let uref = SAML.UserRef tenant subj subj = emailToSAMLNameID email tenant = idp ^. SAML.idpMetadata . SAML.edIssuer - (Just !uid) <- createViaSaml idp privCreds uref + Just !uid <- createViaSaml idp privCreds uref samlUserShouldSatisfy uref isJust pure (uref, uid) @@ -146,13 +146,13 @@ specImportToScimFromSAML = assertSparCassandraUref (uref, Just uid) assertSparCassandraScim ((teamid, email), Nothing) - assertBrigCassandra uid uref usr (valemail, False) ManagedByWire + assertBrigCassandra uid teamid uref usr (valemail, False) ManagedByWire -- activate email case valemail of Feature.FeatureStatusEnabled -> do asks (view teBrig) >>= \brig -> call (activateEmail brig email) - assertBrigCassandra uid uref usr (valemail, True) ManagedByWire + assertBrigCassandra uid teamid uref usr (valemail, True) ManagedByWire Feature.FeatureStatusDisabled -> do pure () @@ -170,7 +170,7 @@ specImportToScimFromSAML = liftIO $ scimUserId storedUserGot `shouldBe` uid assertSparCassandraUref (uref, Just uid) assertSparCassandraScim ((teamid, email), Just uid) - assertBrigCassandra uid uref (Scim.value . Scim.thing $ storedUserGot) (valemail, True) ManagedByScim + assertBrigCassandra uid teamid uref (Scim.value . Scim.thing $ storedUserGot) (valemail, True) ManagedByScim (usr' :: Scim.User.User SparTag) <- do (usr_, _) <- randomScimUserWithEmail @@ -192,7 +192,7 @@ specImportToScimFromSAML = liftIO $ scimUserId storedUserUpdated `shouldBe` uid assertSparCassandraUref (uref, Just uid) assertSparCassandraScim ((teamid, email), Just uid) - assertBrigCassandra uid uref (Scim.value . Scim.thing $ storedUserUpdated) (valemail, True) ManagedByScim + assertBrigCassandra uid teamid uref (Scim.value . Scim.thing $ storedUserUpdated) (valemail, True) ManagedByScim -- login again (Just !uid') <- createViaSaml idp privCreds uref @@ -335,17 +335,18 @@ assertSparCassandraUref (uref, urefAnswer) = do assertSparCassandraScim :: HasCallStack => ((TeamId, Email), Maybe UserId) -> TestSpar () assertSparCassandraScim ((teamid, email), scimAnswer) = do liftIO . (`shouldBe` scimAnswer) - =<< runSpar (ScimExternalIdStore.lookup teamid email) + =<< runSpar (ScimExternalIdStore.lookup teamid (fromEmail email)) assertBrigCassandra :: HasCallStack => UserId -> + TeamId -> SAML.UserRef -> Scim.User.User SparTag -> (Feature.FeatureStatus, Bool) -> ManagedBy -> TestSpar () -assertBrigCassandra uid uref usr (valemail, emailValidated) managedBy = do +assertBrigCassandra uid tid uref usr (valemail, emailValidated) managedBy = do runSpar (BrigAccess.getAccount NoPendingInvitations uid) >>= \(Just acc) -> liftIO $ do let handle = fromRight errmsg . parseHandleEither $ Scim.User.userName usr where @@ -366,7 +367,7 @@ assertBrigCassandra uid uref usr (valemail, emailValidated) managedBy = do userManagedBy (accountUser acc) `shouldBe` managedBy userIdentity (accountUser acc) - `shouldBe` Just (SSOIdentity (UserSSOId uref) email Nothing) + `shouldBe` Just (UAuthIdentity (UAuthId (Just uref) Nothing uaemail tid) email) specSuspend :: SpecWith TestEnv specSuspend = do @@ -500,11 +501,10 @@ testCsvData :: TeamId -> UserId -> UserId -> - Maybe Text {- externalId -} -> - Maybe UserSSOId -> + Maybe PartialUAuthId -> Bool -> TestSpar () -testCsvData tid owner uid mbeid mbsaml hasissuer = do +testCsvData tid owner uid uaid hasissuer = do usersInCsv <- do g <- view teGalley resp <- @@ -519,21 +519,19 @@ testCsvData tid owner uid mbeid mbsaml hasissuer = do elem uid (CsvExport.tExportUserId <$> usersInCsv) `shouldBe` True forM_ usersInCsv $ \export -> when (CsvExport.tExportUserId export == uid) $ do ('e', CsvExport.tExportSCIMExternalId export) - `shouldBe` ('e', fromMaybe "" mbeid) + `shouldBe` ('e', fromJust $ uaScimExternalId =<< uaid) let haveIssuer :: Maybe HttpsUrl - haveIssuer = case mbsaml of - Just (UserSSOId (SAML.UserRef (SAML.Issuer issuer) _)) -> either (const Nothing) Just $ mkHttpsUrl issuer - Just (UserScimExternalId _) -> Nothing - Nothing -> Nothing + haveIssuer = case uaSamlId =<< uaid of + Just (SAML.UserRef (SAML.Issuer issuer) _) -> either (const Nothing) Just $ mkHttpsUrl issuer + _ -> Nothing ('h', haveIssuer) `shouldSatisfy` bool isNothing isJust hasissuer . snd ('i', CsvExport.tExportIdpIssuer export) `shouldBe` ('i', haveIssuer) let haveSubject :: Text - haveSubject = case mbsaml of - Just (UserSSOId (SAML.UserRef _ subject)) -> CI.original $ SAML.unsafeShowNameID subject - Just (UserScimExternalId _) -> "" - Nothing -> "" + haveSubject = case uaSamlId =<< uaid of + Just (SAML.UserRef _ subject) -> CI.original $ SAML.unsafeShowNameID subject + _ -> "" ('n', CsvExport.tExportSAMLNamedId export) `shouldBe` ('n', haveSubject) decodeCSV :: Csv.FromNamedRecord a => LByteString -> [a] @@ -647,7 +645,7 @@ testCreateUserNoIdP = do liftIO $ accountStatus brigUserAccount `shouldBe` PendingInvitation liftIO $ userEmail brigUser `shouldBe` Just email liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim - liftIO $ userSSOId brigUser `shouldBe` Nothing + liftIO $ userPartialUAuthId brigUser `shouldBe` Nothing -- searching user in brig should fail -- >>> searchUser brig owner userName False @@ -678,14 +676,16 @@ testCreateUserNoIdP = do call $ headInvitation404 brig email -- user should now be active + brigUser <- + aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust + >>= maybe (error "could not find user in brig") pure do - brigUser <- - aFewTimes (runSpar $ BrigAccess.getAccount Intra.NoPendingInvitations userid) isJust - >>= maybe (error "could not find user in brig") pure liftIO $ accountStatus brigUser `shouldBe` Active liftIO $ userManagedBy (accountUser brigUser) `shouldBe` ManagedByScim liftIO $ userHandle (accountUser brigUser) `shouldBe` Just handle - liftIO $ userSSOId (accountUser brigUser) `shouldBe` Just (UserScimExternalId (fromEmail email)) + liftIO $ + userPartialUAuthId (accountUser brigUser) + `shouldBe` Just (UAuthId Nothing (Just (fromEmail email)) (Just (EmailWithSource email EmailFromScimExternalIdField)) tid) susr <- getUser tok userid let usr = Scim.value . Scim.thing $ susr liftIO $ Scim.User.active usr `shouldNotBe` Just (Scim.ScimBool False) @@ -696,7 +696,7 @@ testCreateUserNoIdP = do -- csv download should work let eid = Scim.User.externalId scimUser sml = Nothing - in testCsvData tid owner userid eid sml False + in testCsvData tid owner userid (userPartialUAuthId $ accountUser brigUser) False -- members table contains an entry -- (this really shouldn't be tested here, but by the type system!) @@ -769,11 +769,7 @@ testCreateUserWithSamlIdP = do liftIO $ accStatus `shouldBe` Active liftIO $ userManagedBy brigUser `shouldBe` ManagedByScim - let uid = userId brigUser - eid = Scim.User.externalId user - sml :: HasCallStack => UserSSOId - sml = fromJust $ userIdentity >=> ssoIdentity $ brigUser - in testCsvData tid owner uid eid (Just sml) True + testCsvData tid owner (userId brigUser) (userPartialUAuthId brigUser) True -- members table contains an entry -- (this really shouldn't be tested here, but by the type system!) @@ -1196,7 +1192,7 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do runSpar $ BrigAccess.setHandle uid handle pure usr let memberIdWithSSO = userId memberWithSSO - externalId = either error id $ veidToText =<< Intra.veidFromBrigUser memberWithSSO Nothing + externalId = fromMaybe (error "didn't expect that") $ userSCIMExternalId memberWithSSO -- NOTE: once SCIM is enabled, SSO auto-provisioning is disabled tok <- registerScimToken teamid (Just (idp ^. SAML.idpId)) @@ -1206,13 +1202,6 @@ testFindSamlAutoProvisionedUserMigratedWithEmailInTeamWithSSO = do liftIO $ (scimUserId <$> users) `shouldContain` [memberIdWithSSO] Just brigUser' <- runSpar $ Intra.getBrigUser Intra.NoPendingInvitations memberIdWithSSO liftIO $ userManagedBy brigUser' `shouldBe` ManagedByScim - where - veidToText :: MonadError String m => ValidExternalId -> m Text - veidToText veid = - runValidExternalIdEither - (\(SAML.UserRef _ subj) -> maybe (throwError "bad uref from brig") (pure . CI.original) $ SAML.shortShowNameID subj) - (pure . fromEmail) - veid testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO :: TestSpar () testFindTeamSettingsInvitedUserMigratedWithEmailInTeamWithSSO = do @@ -1672,8 +1661,8 @@ testUpdateExternalId withidp = do if withidp then call $ activateEmail brig email else registerUser brig tid email - veid :: ValidExternalId <- - either (error . show) pure $ mkValidExternalId midp (Scim.User.externalId user) + uaid :: ScimUAuthId <- + either (error . show) pure $ mkScimUAuthId tid midp (Scim.User.externalId user) -- Overwrite the user with another randomly-generated user (only controlling externalId) otherEmail <- randomEmail user' <- do @@ -1685,20 +1674,20 @@ testUpdateExternalId withidp = do else Scim.User.externalId user } randomScimUser <&> upd - let veid' = either (error . show) id $ mkValidExternalId midp (Scim.User.externalId user') + let uaid' = either (error . show) id $ mkScimUAuthId tid midp (Scim.User.externalId user') _ <- updateUser tok userid user' when hasChanged (call $ activateEmail brig otherEmail) - muserid <- lookupByValidExternalId tid veid - muserid' <- lookupByValidExternalId tid veid' + muserid <- lookupByScimUAuthId tid uaid + muserid' <- lookupByScimUAuthId tid uaid' liftIO $ do if hasChanged then do (hasChanged, muserid) `shouldBe` (hasChanged, Nothing) (hasChanged, muserid') `shouldBe` (hasChanged, Just userid) else do - (hasChanged, veid') `shouldBe` (hasChanged, veid) + (hasChanged, uaid') `shouldBe` (hasChanged, uaid) (hasChanged, muserid') `shouldBe` (hasChanged, Just userid) eventually $ checkEmail userid (Just $ if hasChanged then otherEmail else email) @@ -1716,38 +1705,34 @@ testUpdateExternalIdOfUnregisteredAccount = do user <- randomScimUser <&> \u -> u {Scim.User.externalId = Just $ fromEmail email} storedUser <- createUser tok user let userid = scimUserId storedUser - veid :: ValidExternalId <- - either (error . show) pure $ mkValidExternalId Nothing (Scim.User.externalId user) + uaid :: ScimUAuthId <- + either (error . show) pure $ mkScimUAuthId tid Nothing (Scim.User.externalId user) -- Overwrite the user with another randomly-generated user (only controlling externalId) -- And update the user before they have registered their account otherEmail <- randomEmail user' <- do let upd u = u {Scim.User.externalId = Just $ fromEmail otherEmail} randomScimUser <&> upd - let veid' = either (error . show) id $ mkValidExternalId Nothing (Scim.User.externalId user') + let uaid' = either (error . show) id $ mkScimUAuthId tid Nothing (Scim.User.externalId user') _ <- updateUser tok userid user' -- Now the user registers their account (via old email) registerUser brig tid email -- Then the user activates their new email address call $ activateEmail brig otherEmail - muserid <- lookupByValidExternalId tid veid - muserid' <- lookupByValidExternalId tid veid' + muserid <- lookupByScimUAuthId tid uaid + muserid' <- lookupByScimUAuthId tid uaid' liftIO $ do muserid `shouldBe` Nothing muserid' `shouldBe` Just userid eventually $ checkEmail userid (Just otherEmail) -lookupByValidExternalId :: TeamId -> ValidExternalId -> TestSpar (Maybe UserId) -lookupByValidExternalId tid = - runValidExternalIdEither - (runSpar . SAMLUserStore.get) - ( \email -> do - let action = SU.scimFindUserByEmail Nothing tid $ fromEmail email - result <- runSpar . runExceptT . runMaybeT $ action - case result of - Right muser -> pure $ Scim.id . Scim.thing <$> muser - Left err -> error $ show err - ) +lookupByScimUAuthId :: TeamId -> ScimUAuthId -> TestSpar (Maybe UserId) +lookupByScimUAuthId tid uaid = do + let action = SU.scimFindUserByEmail Nothing tid $ runIdentity (uaScimExternalId uaid) + result <- runSpar . runExceptT . runMaybeT $ action + case result of + Right muser -> pure $ Scim.id . Scim.thing <$> muser + Left err -> error $ show err registerUser :: BrigReq -> TeamId -> Email -> TestSpar () registerUser brig tid email = do @@ -2060,10 +2045,8 @@ specDeleteUser = do let uid :: UserId = scimUserId storedUser uref :: SAML.UserRef <- do usr <- runSpar $ Intra.getBrigUser Intra.WithPendingInvitations uid - let err = error . ("brig user without UserRef: " <>) . show - case (`Intra.veidFromBrigUser` Nothing) <$> usr of - bad@(Just (Right veid)) -> runValidExternalIdEither pure (const $ err bad) veid - bad -> err bad + let err = error $ "brig user without UserRef: " <> show usr + maybe err pure $ uaSamlId =<< userPartialUAuthId =<< usr spar <- view teSpar deleteUser_ (Just tok) (Just uid) spar !!! const 204 === statusCode @@ -2228,8 +2211,8 @@ specEmailValidation = do (user, email) <- randomScimUserWithEmail scimStoredUser <- createUser tok user uref :: SAML.UserRef <- - either (error . show) (pure . (^?! veidUref)) $ - mkValidExternalId (Just idp) (Scim.User.externalId . Scim.value . Scim.thing $ scimStoredUser) + either (error . show) (pure . fromJust . uaSamlId) $ + mkScimUAuthId teamid (Just idp) (Scim.User.externalId . Scim.value . Scim.thing $ scimStoredUser) uid :: UserId <- getUserIdViaRef uref brig <- view teBrig @@ -2276,7 +2259,7 @@ testDeletedUsersFreeExternalIdNoIdp = do void $ aFewTimes - (runSpar $ ScimExternalIdStore.lookup tid email) + (runSpar $ ScimExternalIdStore.lookup tid (fromEmail email)) (== Nothing) -- | CSV download of team members is mainly tested here: 'API.Teams.testListTeamMembersCsv'. diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 3298ca8047..0020ce7b1c 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -123,8 +123,8 @@ module Util.Core runSpar, runSparE, type CanonicalEffs, - getSsoidViaSelf, - getSsoidViaSelf', + getUAuthIdViaSelf, + getUAuthIdViaSelf', getUserIdViaRef, getUserIdViaRef', callGetDefaultSsoCode, @@ -194,6 +194,7 @@ import qualified System.Logger.Extended as Log import System.Random (randomRIO) import Test.Hspec hiding (it, pending, pendingWith, xit) import qualified Test.Hspec +import Test.QuickCheck (arbitrary, generate) import qualified Text.XML as XML import qualified Text.XML.Cursor as XML import Text.XML.DSig (SignPrivCreds) @@ -217,7 +218,6 @@ import qualified Wire.API.User as User import Wire.API.User.Activation import Wire.API.User.Auth hiding (Cookie) import Wire.API.User.IdentityProvider -import Wire.API.User.Scim (runValidExternalIdEither) import Wire.Sem.Logger.TinyLog -- | Call 'mkEnv' with options from config files. @@ -386,7 +386,8 @@ createUserWithTeamDisableSSO brg gly = do "password" .= defPassword, "team" .= newTeam ] - bdy <- selfUser . responseJsonUnsafe <$> post (brg . path "/i/users" . contentJson . body p) + resp <- post (brg . path "/i/users" . contentJson . body p) + let bdy = maybe (error $ show resp) selfUser $ responseJsonMaybe resp let (uid, Just tid) = (userId bdy, userTeam bdy) (team' : _) <- (^. Galley.teamListTeams) <$> getTeams uid gly () <- @@ -496,13 +497,10 @@ createTeamMember :: Permissions -> m UserId createTeamMember brigreq galleyreq teamid perms = do - let randomtxt = liftIO $ UUID.toText <$> UUID.nextRandom - randomssoid = liftIO $ UserSSOId <$> (mkSampleUref <$> rnd <*> rnd) - rnd = cs . show <$> randomRIO (0 :: Integer, 10000000) - name <- randomtxt - ssoid <- randomssoid + name <- liftIO $ UUID.toText <$> UUID.nextRandom + uauthid <- liftIO $ generate (arbitrary @PartialUAuthId) resp :: ResponseLBS <- - postUser name False (Just ssoid) (Just teamid) brigreq + postUser name False (Just uauthid) (Just teamid) brigreq Text -> Bool -> - Maybe UserSSOId -> + Maybe PartialUAuthId -> Maybe TeamId -> BrigReq -> m ResponseLBS -postUser name haveEmail ssoid teamid brig_ = do +postUser name haveEmail uauthid teamid brig_ = do email <- if haveEmail then Just <$> randomEmail else pure Nothing let p = RequestBodyLBS . Aeson.encode $ @@ -696,7 +694,7 @@ postUser name haveEmail ssoid teamid brig_ = do "email" .= email, "password" .= defPassword, "cookie" .= defCookieLabel, - "sso_id" .= ssoid, + "uauth_id" .= uauthid, "team_id" .= teamid ] post (brig_ . path "/i/users" . contentJson . body p) @@ -1243,14 +1241,10 @@ callDeleteDefaultSsoCode sparreq_ = do -- helpers talking to spar's cassandra directly -- | Look up 'UserId' under 'UserSSOId' on spar's cassandra directly. -ssoToUidSpar :: (HasCallStack, MonadIO m, MonadReader TestEnv m) => TeamId -> UserSSOId -> m (Maybe UserId) -ssoToUidSpar tid ssoid = do - veid <- either (error . ("could not parse brig sso_id: " <>)) pure $ Intra.veidFromUserSSOId ssoid - runSpar $ - runValidExternalIdEither - SAMLUserStore.get - (ScimExternalIdStore.lookup tid) - veid +ssoToUidSpar :: (HasCallStack, MonadIO m, MonadReader TestEnv m) => TeamId -> PartialUAuthId -> m (Maybe UserId) +ssoToUidSpar _ (uaSamlId -> Just uref) = runSpar $ SAMLUserStore.get uref +ssoToUidSpar tid (uaEmail -> Just (EmailWithSource (fromEmail -> email) _)) = runSpar $ ScimExternalIdStore.lookup tid email +ssoToUidSpar _ _ = pure Nothing runSimpleSP :: (MonadReader TestEnv m, MonadIO m) => SAML.SimpleSP a -> m a runSimpleSP action = do @@ -1276,18 +1270,13 @@ runSparE action = do ctx <- (^. teSparEnv) <$> ask liftIO $ runSparToIO ctx action -getSsoidViaSelf :: HasCallStack => UserId -> TestSpar UserSSOId -getSsoidViaSelf uid = maybe (error "not found") pure =<< getSsoidViaSelf' uid +getUAuthIdViaSelf :: HasCallStack => UserId -> TestSpar PartialUAuthId +getUAuthIdViaSelf uid = maybe (error "not found") pure =<< getUAuthIdViaSelf' uid -getSsoidViaSelf' :: HasCallStack => UserId -> TestSpar (Maybe UserSSOId) -getSsoidViaSelf' uid = do +getUAuthIdViaSelf' :: HasCallStack => UserId -> TestSpar (Maybe PartialUAuthId) +getUAuthIdViaSelf' uid = do musr <- aFewTimes (runSpar $ Intra.getBrigUser Intra.NoPendingInvitations uid) isJust - pure $ case userIdentity =<< musr of - Just (SSOIdentity ssoid _ _) -> Just ssoid - Just (FullIdentity _ _) -> Nothing - Just (EmailIdentity _) -> Nothing - Just (PhoneIdentity _) -> Nothing - Nothing -> Nothing + pure $ userPartialUAuthId =<< musr getUserIdViaRef :: HasCallStack => UserRef -> TestSpar UserId getUserIdViaRef uref = maybe (error "not found") pure =<< getUserIdViaRef' uref diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index dbe3b5087c..7880e29104 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -172,6 +172,19 @@ randomScimUserWithEmail = do email ) +randomScimUserWithNick :: MonadRandom m => m (Scim.User.User SparTag, Text) +randomScimUserWithNick = do + suffix <- cs <$> replicateM 7 (getRandomR ('0', '9')) + let nick = "nick" <> suffix + externalId = nick + pure + ( (Scim.User.empty userSchemas ("scimuser_" <> suffix) (ScimUserExtra mempty)) + { Scim.User.displayName = Just ("ScimUser" <> suffix), + Scim.User.externalId = Just externalId + }, + nick + ) + randomScimEmail :: MonadRandom m => m Email.Email randomScimEmail = do let typ :: Maybe Text = Nothing @@ -602,9 +615,9 @@ instance IsUser ValidScimUser where maybeUserId = Nothing maybeHandle = Just (Just . view vsuHandle) maybeName = Just (Just . view vsuName) - maybeTenant = Just (^? (vsuExternalId . veidUref . SAML.uidTenant)) - maybeSubject = Just (^? (vsuExternalId . veidUref . SAML.uidSubject)) - maybeScimExternalId = Just (runValidExternalIdEither Intra.urefToExternalId (Just . fromEmail) . view vsuExternalId) + maybeTenant = Just (^? (vsuExternalId . to uaSamlId . _Just . SAML.uidTenant)) + maybeSubject = Just (^? (vsuExternalId . to uaSamlId . _Just . SAML.uidSubject)) + maybeScimExternalId = Just (Just . runIdentity . uaScimExternalId . view vsuExternalId) maybeLocale = Just (view vsuLocale) instance IsUser (WrappedScimStoredUser SparTag) where @@ -639,21 +652,15 @@ instance IsUser User where maybeUserId = Just userId maybeHandle = Just userHandle maybeName = Just (Just . userDisplayName) - maybeTenant = Just $ \usr -> - Intra.veidFromBrigUser usr Nothing - & either - (const Nothing) - (preview (veidUref . SAML.uidTenant)) - maybeSubject = Just $ \usr -> - Intra.veidFromBrigUser usr Nothing - & either - (const Nothing) - (preview (veidUref . SAML.uidSubject)) - maybeScimExternalId = Just $ \usr -> - Intra.veidFromBrigUser usr Nothing - & either - (const Nothing) - (runValidExternalIdEither Intra.urefToExternalId (Just . fromEmail)) + maybeTenant = Just $ \case + (userSSOId -> (UAuthId (Just (SAML.UserRef t _n) _ _))) -> Just t + _ -> Nothing + maybeSubject = Just $ \case + (userSSOId -> (UAuthId (Just (SAML.UserRef _t n) _ _))) -> Just n + _ -> Nothing + maybeScimExternalId = Just $ \case + (userSSOId -> (UAuthId _ (Just eid _))) -> Just eid + _ -> Nothing maybeLocale = Just $ Just . userLocale -- | For all properties that are present in both @u1@ and @u2@, check that they match. diff --git a/services/spar/test/Test/Spar/Intra/BrigSpec.hs b/services/spar/test/Test/Spar/Intra/BrigSpec.hs deleted file mode 100644 index 2b993e38bf..0000000000 --- a/services/spar/test/Test/Spar/Intra/BrigSpec.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- This program is free software: you can redistribute it and/or modify it under --- the terms of the GNU Affero General Public License as published by the Free --- Software Foundation, either version 3 of the License, or (at your option) any --- later version. --- --- This program is distributed in the hope that it will be useful, but WITHOUT --- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS --- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more --- details. --- --- You should have received a copy of the GNU Affero General Public License along --- with this program. If not, see . - -module Test.Spar.Intra.BrigSpec where - -import Arbitrary () -import Control.Lens ((^.)) -import Imports -import SAML2.WebSSO as SAML -import Spar.Intra.BrigApp -import Test.Hspec -import Test.QuickCheck -import URI.ByteString (URI, laxURIParserOptions, parseURI) -import Wire.API.User.Identity (UserSSOId (UserSSOId)) -import Wire.API.User.Scim - -mkuri :: Text -> URI -mkuri = either (error . show) id . parseURI laxURIParserOptions . cs - -spec :: Spec -spec = do - describe "veidToUserSSOId, veidFromUserSSOId" $ do - -- example unit tests are mostly for documentation. if they fail, it may be because of some - -- harmless change in the string representation of the xml data, and you can probably just - -- remove them. - - it "example" $ do - let have = - UrefOnly $ - UserRef - (Issuer $ mkuri "http://wire.com/") - ( either (error . show) id $ - mkNameID (mkUNameIDTransient "V") (Just "kati") (Just "rolli") (Just "jaan") - ) - want = UserSSOId (SAML.UserRef iss nam) - iss :: SAML.Issuer = fromRight undefined $ SAML.decodeElem "http://wire.com/" - nam :: SAML.NameID = fromRight undefined $ SAML.decodeElem "V" - veidToUserSSOId have `shouldBe` want - veidFromUserSSOId want `shouldBe` Right have - it "another example" $ do - let have = - UrefOnly $ - UserRef - (Issuer $ mkuri "http://wire.com/") - ( either (error . show) id $ - mkNameID (mkUNameIDPersistent "PWkS") (Just "hendrik") Nothing (Just "marye") - ) - want = UserSSOId (SAML.UserRef iss nam) - iss :: SAML.Issuer = fromRight undefined $ SAML.decodeElem "http://wire.com/" - nam :: SAML.NameID = fromRight undefined $ SAML.decodeElem "PWkS" - - veidToUserSSOId have `shouldBe` want - veidFromUserSSOId want `shouldBe` Right have - - it "roundtrips" . property $ - \(x :: ValidExternalId) -> (veidFromUserSSOId @(Either String) . veidToUserSSOId) x === Right x - -instance Arbitrary ValidExternalId where - arbitrary = do - muref <- arbitrary - case muref of - Just uref -> case emailFromSAMLNameID $ uref ^. SAML.uidSubject of - Just email -> pure $ EmailAndUref email uref - Nothing -> pure $ UrefOnly uref - Nothing -> EmailOnly <$> arbitrary diff --git a/services/spar/test/Test/Spar/Scim/UserSpec.hs b/services/spar/test/Test/Spar/Scim/UserSpec.hs index 16dc0636a1..cd1b17c56d 100644 --- a/services/spar/test/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test/Test/Spar/Scim/UserSpec.hs @@ -81,9 +81,9 @@ deleteUserAndAssertDeletionInSpar acc tokenInfo = do let tid = stiTeam tokenInfo email = (fromJust . emailIdentity . fromJust . userIdentity . accountUser) acc uid = (userId . accountUser) acc - ScimExternalIdStore.insert tid email uid + ScimExternalIdStore.insert tid (fromEmail email) uid r <- runExceptT $ deleteScimUser tokenInfo uid - lr <- ScimExternalIdStore.lookup tid email + lr <- ScimExternalIdStore.lookup tid (fromEmail email) liftIO $ lr `shouldBe` Nothing pure r