From f0d190d0d75f16994e1fa27ffaf47b05335c87b4 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 21 Jun 2022 15:07:01 +0000 Subject: [PATCH 1/9] Spin off SAML Spar user creation from createUser flow. --- .../src/Wire/API/Routes/Internal/Brig.hs | 6 ++ libs/wire-api/src/Wire/API/User.hs | 80 ++++++++++++++++++- libs/wire-api/src/Wire/API/User/Identity.hs | 12 +++ libs/wire-api/src/Wire/API/User/RichInfo.hs | 42 ++++++---- .../Golden/Generated/NewUserPublic_user.hs | 18 +---- services/brig/src/Brig/API/Internal.hs | 39 ++++++++- services/brig/src/Brig/API/Types.hs | 2 + services/brig/src/Brig/API/User.hs | 79 ++++++++++++++++++ services/brig/src/Brig/Data/Activation.hs | 2 +- .../test/integration/Federation/End2end.hs | 2 +- services/spar/src/Spar/App.hs | 2 +- services/spar/src/Spar/Intra/Brig.hs | 55 ++++++++++--- services/spar/src/Spar/Intra/BrigApp.hs | 8 -- services/spar/src/Spar/Scim/User.hs | 6 +- services/spar/src/Spar/Sem/BrigAccess.hs | 4 +- services/spar/src/Spar/Sem/BrigAccess/Http.hs | 3 +- .../Test/Spar/Scim/UserSpec.hs | 2 +- services/spar/test/Test/Spar/DataSpec.hs | 7 +- 18 files changed, 300 insertions(+), 69 deletions(-) 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 ba74d46c2c..eccc098c7f 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -146,6 +146,12 @@ type AccountAPI = :> ReqBody '[Servant.JSON] NewUser :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile) ) + :<|> Named + "createUserNoVerifySafe" + ( "users" :> "safe" -- TODO: temporary name + :> ReqBody '[Servant.JSON] NewUserSpar + :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile) + ) data NewKeyPackageRef = NewKeyPackageRef { nkprUserId :: Qualified UserId, diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index b2ec51358d..00d6ebf14a 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -44,11 +44,16 @@ module Wire.API.User -- * NewUser NewUserPublic (..), RegisterError (..), + -- CreateUserSparError (..), RegisterSuccess (..), RegisterResponses, RegisterInternalResponses, NewUser (..), emptyNewUser, + NewUserSpar (..), + newUserFromSpar, + urefToExternalId, + urefToEmail, ExpiresIn, newUserInvitationCode, newUserTeam, @@ -112,7 +117,7 @@ where import Control.Applicative import Control.Error.Safe (rightMay) -import Control.Lens (over, (.~), (?~)) +import Control.Lens (over, view, (.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.Types as A import qualified Data.Attoparsec.ByteString as Parser @@ -137,7 +142,7 @@ import Data.String.Conversions (cs) import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as T -import Data.Text.Ascii +import Data.Text.Ascii (AsciiBase64Url) import qualified Data.Text.Encoding as T import Data.UUID (UUID, nil) import qualified Data.UUID as UUID @@ -146,6 +151,7 @@ import GHC.TypeLits (KnownNat, Nat) import qualified Generics.SOP as GSOP import Imports import qualified SAML2.WebSSO as SAML +import qualified SAML2.WebSSO.Types.Email as SAMLEmail import Servant (FromHttpApiData (..), ToHttpApiData (..), type (.++)) import qualified Test.QuickCheck as QC import URI.ByteString (serializeURIRef) @@ -161,6 +167,7 @@ import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Identity import Wire.API.User.Profile +import Wire.API.User.RichInfo -------------------------------------------------------------------------------- -- UserIdList @@ -519,6 +526,20 @@ isNewUserTeamMember u = case newUserTeam u of instance Arbitrary NewUserPublic where arbitrary = arbitrary `QC.suchThatMap` (rightMay . validateNewUserPublic) +-- ChangeHandleErrorResponses -- .++ RegisterErrorResponses + +-- type CreateUserSparResponses = +-- CreateUserSparErrorResponses +-- .++ '[ WithHeaders +-- '[DescHeader "Location" "UserId" UserId] +-- SelfProfile +-- (Respond 201 "User created and pending activation" SelfProfile) +-- ] + +-- instance (res ~ CreateUserSparResponses) => AsUnion res (Either CreateUserSparError SelfProfile) where +-- toUnion = eitherToUnion (toUnion @CreateUserSparErrorResponses) (Z . I) +-- fromUnion = eitherFromUnion (fromUnion @CreateUserSparErrorResponses) (unI . unZ) + data RegisterError = RegisterErrorWhitelistError | RegisterErrorInvalidInvitationCode @@ -532,7 +553,7 @@ data RegisterError | RegisterErrorBlacklistedEmail | RegisterErrorTooManyTeamMembers | RegisterErrorUserCreationRestricted - deriving (Generic) + deriving (Show, Generic) deriving (AsUnion RegisterErrorResponses) via GenericAsUnion RegisterErrorResponses RegisterError instance GSOP.Generic RegisterError @@ -588,6 +609,57 @@ instance (res ~ RegisterInternalResponses) => AsUnion res (Either RegisterError toUnion = eitherToUnion (toUnion @RegisterErrorResponses) (Z . I) fromUnion = eitherFromUnion (fromUnion @RegisterErrorResponses) (unI . unZ) +urefToExternalId :: SAML.UserRef -> Maybe Text +urefToExternalId = fmap CI.original . SAML.shortShowNameID . view SAML.uidSubject + +urefToEmail :: SAML.UserRef -> Maybe Email +urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of + SAML.UNameIDEmail email -> parseEmail . SAMLEmail.render . CI.original $ email + _ -> Nothing + +data NewUserSpar = NewUserSpar + { newUserSparUUID :: UUID, + newUserSparSSOId :: UserSSOId, + newUserSparDisplayName :: Name, + newUserSparTeamId :: TeamId, + newUserSparManagedBy :: ManagedBy, + newUserSparHandle :: Maybe Handle, + newUserSparRichInfo :: Maybe RichInfo + } + deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewUserSpar) + +instance ToSchema NewUserSpar where + schema = + object "NewUserSpar" $ + 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) + +newUserFromSpar :: NewUserSpar -> NewUser +newUserFromSpar new = + NewUser + { newUserDisplayName = newUserSparDisplayName new, + newUserUUID = Just $ newUserSparUUID new, + newUserIdentity = Just $ SSOIdentity (newUserSparSSOId new) Nothing Nothing, + newUserPict = Nothing, + newUserAssets = [], + newUserAccentId = Nothing, + newUserEmailCode = Nothing, + newUserPhoneCode = Nothing, + newUserOrigin = Just . NewUserOriginTeamUser . NewTeamMemberSSO $ newUserSparTeamId new, + newUserLabel = Nothing, + newUserLocale = Nothing, + newUserPassword = Nothing, + newUserExpiresIn = Nothing, + newUserManagedBy = Just $ newUserSparManagedBy new + } + data NewUser = NewUser { newUserDisplayName :: Name, -- | use this as 'UserId' (if 'Nothing', call 'Data.UUID.nextRandom'). @@ -1130,7 +1202,7 @@ data ChangeHandleError | ChangeHandleExists | ChangeHandleInvalid | ChangeHandleManagedByScim - deriving (Generic) + deriving (Show, Generic) deriving (AsUnion ChangeHandleErrorResponses) via GenericAsUnion ChangeHandleErrorResponses ChangeHandleError instance GSOP.Generic ChangeHandleError diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 802412efd5..156c54b6f9 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -63,6 +63,18 @@ import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import Data.Proxy (Proxy (..)) import Data.Schema + ( HasDoc (doc), + ObjectSchema, + Schema (Schema), + SwaggerDoc, + ToSchema (..), + genericToSchema, + maybe_, + optField, + parsedText, + withParser, + (.=), + ) import Data.String.Conversions (cs) import qualified Data.Swagger as S import qualified Data.Text as Text diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index 14276a7eb0..75871eadd0 100644 --- a/libs/wire-api/src/Wire/API/User/RichInfo.hs +++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- This file is part of the Wire Server implementation. -- @@ -55,7 +56,10 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.List.Extra (nubOrdOn) import qualified Data.Map as Map +import Data.Schema (Schema (..), ToSchema (..), array, field) +import qualified Data.Schema as Schema import Data.String.Conversions (cs) +import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as Text import Imports @@ -68,6 +72,7 @@ import Wire.API.Arbitrary (Arbitrary (arbitrary)) -- | A 'RichInfoAssocList' that parses and renders as 'RichInfoMapAndList'. newtype RichInfo = RichInfo {unRichInfo :: RichInfoAssocList} deriving stock (Eq, Show, Generic) + deriving newtype (ToSchema) instance ToJSON RichInfo where toJSON = toJSON . fromRichInfoAssocList . unRichInfo @@ -223,6 +228,13 @@ richInfoAssocListURN = "urn:wire:scim:schemas:profile:1.0" newtype RichInfoAssocList = RichInfoAssocList {unRichInfoAssocList :: [RichField]} deriving stock (Eq, Show, Generic) +instance ToSchema RichInfoAssocList where + schema = + Schema.object "RichInfo" $ + RichInfoAssocList + <$> unRichInfoAssocList Schema..= field "fields" (array schema) + <* const (0 :: Int) Schema..= field "version" schema + -- | Uses 'normalizeRichInfoAssocList'. mkRichInfoAssocList :: [RichField] -> RichInfoAssocList mkRichInfoAssocList = RichInfoAssocList . normalizeRichInfoAssocListInt @@ -279,6 +291,7 @@ data RichField = RichField richFieldValue :: Text } deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema RichField) modelRichField :: Doc.Model modelRichField = Doc.defineModel "RichField" $ do @@ -288,22 +301,19 @@ modelRichField = Doc.defineModel "RichField" $ do Doc.property "value" Doc.string' $ Doc.description "Field value" -instance ToJSON RichField where - -- NB: "name" would be a better name for 'richFieldType', but "type" is used because we - -- also have "type" in SCIM; and the reason we use "type" for SCIM is that @{"type": ..., - -- "value": ...}@ is how all other SCIM payloads are formatted, so it's quite possible - -- that some provisioning agent would support "type" but not "name". - toJSON u = - object - [ "type" .= CI.original (richFieldType u), - "value" .= richFieldValue u - ] - -instance FromJSON RichField where - parseJSON = withObject "RichField" $ \o -> do - RichField - <$> (CI.mk <$> o .: "type") - <*> o .: "value" +-- -- NB: "name" would be a better name for 'richFieldType', but "type" is used because we +-- -- also have "type" in SCIM; and the reason we use "type" for SCIM is that @{"type": ..., +-- -- "value": ...}@ is how all other SCIM payloads are formatted, so it's quite possible +-- -- that some provisioning agent would support "type" but not "name". +instance ToSchema RichField where + schema = + Schema.object "RichField" $ + RichField + <$> richFieldType Schema..= field "type" (CI.original Schema..= (CI.mk <$> schema)) + <*> richFieldValue Schema..= field "value" schema + +-- where +-- ciSchema :: _ instance Arbitrary RichField where arbitrary = diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs index 6e2cb63749..85492312b1 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/NewUserPublic_user.hs @@ -36,23 +36,7 @@ import Wire.API.User ManagedBy (ManagedByWire), Name (Name, fromName), NewTeamUser (NewTeamMember), - NewUser - ( NewUser, - newUserAccentId, - newUserAssets, - newUserDisplayName, - newUserEmailCode, - newUserExpiresIn, - newUserIdentity, - newUserLabel, - newUserLocale, - newUserManagedBy, - newUserOrigin, - newUserPassword, - newUserPhoneCode, - newUserPict, - newUserUUID - ), + NewUser (..), NewUserOrigin (NewUserOriginTeamUser), NewUserPublic (..), Phone (Phone, fromPhone), diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 4c091d05be..f4030113cc 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -14,7 +14,6 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . - module Brig.API.Internal ( sitemap, servantSitemap, @@ -64,7 +63,7 @@ import Control.Lens (view) import Data.Aeson hiding (json) import Data.ByteString.Conversion import qualified Data.ByteString.Conversion as List -import Data.Handle (Handle) +import Data.Handle import Data.Id as Id import qualified Data.Map.Strict as Map import Data.Qualified @@ -126,7 +125,9 @@ mlsAPI = :<|> mapKeyPackageRefsInternal accountAPI :: Member BlacklistStore r => ServerT BrigIRoutes.AccountAPI (Handler r) -accountAPI = Named @"createUserNoVerify" createUserNoVerify +accountAPI = + Named @"createUserNoVerify" createUserNoVerify + :<|> Named @"createUserNoVerifySafe" createUserNoVerifySafe teamsAPI :: ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = Named @"updateSearchVisibilityInbound" Index.updateSearchVisibilityInbound @@ -420,7 +421,37 @@ createUserNoVerify uData = lift . runExceptT $ do let key = ActivateKey $ activationKey adata code = activationCode adata in API.activate key code (Just uid) !>> activationErrorToRegisterError - pure (SelfProfile usr) + pure . SelfProfile $ usr + +createUserNoVerifySafe :: NewUserSpar -> (Handler r) (Either RegisterError SelfProfile) +createUserNoVerifySafe uData = + lift . runExceptT $ do + result <- API.createUserSpar uData + let acc = createdAccount result + let usr = accountUser acc + let uid = userId usr + let eac = createdEmailActivation result + let pac = createdPhoneActivation result + for_ (catMaybes [eac, pac]) $ \adata -> + let key = ActivateKey $ activationKey adata + code = activationCode adata + in API.activate key code (Just uid) !>> activationErrorToRegisterError + pure . SelfProfile $ usr + +-- case usr of +-- Right usr' -> do +-- let uid = userId usr' +-- case HandleUpdate . fromHandle <$> newUserHandle uData of +-- Just handle -> do +-- e <- D.trace "\n+++++++++++++++++++++++++++++++++++++ update handle failed" updateHandle uid handle +-- pure . Left . CreateUserSparHandleError $ e +-- Nothing -> do +-- D.trace "\n++++++++++++++ no handle\n" pure () +-- pure . Right . SelfProfile $ usr' +-- -- _ <- D.trace "\n%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% update rich info failed " updateRichInfo uid undefined +-- pure . Right $ SelfProfile usr' +-- Left e -> do +-- pure . Left . CreateUserSparRegisterError $ RegisterErrorBlacklistedEmail deleteUserNoVerifyH :: UserId -> (Handler r) Response deleteUserNoVerifyH uid = do diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 145e1cc327..b779fcb4dd 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -59,11 +59,13 @@ data CreateUserResult = CreateUserResult -- | Info of a team just created/joined createdUserTeam :: !(Maybe CreateUserTeam) } + deriving (Show) data CreateUserTeam = CreateUserTeam { createdTeamId :: !TeamId, createdTeamName :: !Text } + deriving (Show) data ActivationResult = -- | The key/code was valid and successfully activated. diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 47096b5aa6..f0197e4153 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -19,6 +19,7 @@ module Brig.API.User ( -- * User Accounts / Profiles createUser, + createUserSpar, createUserInviteViaScim, checkRestrictedUserCreation, Brig.API.User.updateUser, @@ -178,6 +179,7 @@ import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Client import Wire.API.User.Password +import Wire.API.User.RichInfo data AllowSCIMUpdates = AllowSCIMUpdates @@ -216,6 +218,83 @@ verifyUniquenessAndCheckBlacklist uk = do unless av $ throwE IdentityErrorUserKeyExists +createUserSpar :: NewUserSpar -> ExceptT RegisterError (AppT r) CreateUserResult +createUserSpar new = do + let handle' = newUserSparHandle new + new' = newUserFromSpar new -- TODO: make it obsolete once we add rich info? + ident = newUserSparSSOId new + tid = newUserSparTeamId new + + -- Create account + account <- lift $ do + (account, pw) <- wrapClient $ newAccount new' Nothing (Just tid) handle' + + let uid = userId (accountUser account) + + -- TODO: make this transactional? + wrapClient $ Data.insertAccount account Nothing pw False + case unRichInfo <$> newUserSparRichInfo new of + Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo + Nothing -> pure () -- Nothing to do + + wrapHttp $ Intra.createSelfConv uid + wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) + + pure account + + + -- Add to team + userTeam <- addUserToTeamSSO account tid (SSOIdentity ident Nothing Nothing) + + -- Set up feature flags + let uid = userId (accountUser account) + lift $ initAccountFeatureConfig uid + + pure $! CreateUserResult account Nothing Nothing (Just userTeam) + where + addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam + addUserToTeamSSO account tid ident = do + let uid = userId (accountUser account) + added <- lift $ wrapHttp $ Intra.addTeamMember uid tid (Nothing, defaultRole) + unless added $ + throwE RegisterErrorTooManyTeamMembers + lift $ do + wrapClient $ activateUser uid ident + void $ onActivated (AccountActivated account) + Log.info $ + field "user" (toByteString uid) + . field "team" (toByteString tid) + . msg (val "Added via SSO") + Team.TeamName nm <- lift $ wrapHttp $ Intra.getTeamName tid + pure $ CreateUserTeam tid nm + +-- ensureMemberCanJoin :: TeamId -> ExceptT RegisterError (AppT r) () +-- ensureMemberCanJoin tid = do +-- maxSize <- fromIntegral . setMaxTeamSize <$> view settings +-- (TeamSize teamSize) <- TeamSize.teamSize tid +-- when (teamSize >= maxSize) $ +-- throwE RegisterErrorTooManyTeamMembers +-- -- FUTUREWORK: The above can easily be done/tested in the intra call. +-- -- Remove after the next release. +-- canAdd <- lift $ wrapHttp $ Intra.checkUserCanJoinTeam tid +-- case canAdd of +-- Just e -> throwM $ API.UserNotAllowedToJoinTeam e +-- Nothing -> pure () + +-- findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) +-- findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity +-- findTeamInvitation (Just e) c = +-- lift (wrapClient $ Team.lookupInvitationInfo c) >>= \case +-- Just ii -> do +-- inv <- lift . wrapClient $ Team.lookupInvitation (Team.iiTeam ii) (Team.iiInvId ii) +-- case (inv, Team.inInviteeEmail <$> inv) of +-- (Just invite, Just em) +-- | e == userEmailKey em -> do +-- _ <- ensureMemberCanJoin (Team.iiTeam ii) +-- pure $ Just (invite, ii, Team.iiTeam ii) +-- _ -> throwE RegisterErrorInvalidInvitationCode +-- Nothing -> throwE RegisterErrorInvalidInvitationCode + -- docs/reference/user/registration.md {#RefRegistration} createUser :: forall r. Member BlacklistStore r => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult createUser new = do diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 0925890db0..d255ed52b6 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -60,7 +60,7 @@ data Activation = Activation -- | The confidential activation code. activationCode :: !ActivationCode } - deriving (Eq) + deriving (Eq, Show) data ActivationError = UserKeyExists !LT.Text diff --git a/services/brig/test/integration/Federation/End2end.hs b/services/brig/test/integration/Federation/End2end.hs index ffb82fe9e3..cd668f0028 100644 --- a/services/brig/test/integration/Federation/End2end.hs +++ b/services/brig/test/integration/Federation/End2end.hs @@ -707,7 +707,7 @@ testSendMLSMessage brig1 brig2 galley1 galley2 cannon1 cannon2 = do <$> addClient brig1 (userId alice) - (defNewClient PermanentClientType [] (someLastPrekeys !! 0)) + (defNewClient PermanentClientType [] (Imports.head someLastPrekeys)) let aliceClientId = show (userId alice) <> ":" diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 22460e0697..fb4283fce0 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -170,7 +170,7 @@ createSamlUserWithId :: Sem r () createSamlUserWithId teamid buid suid = do uname <- either (throwSparSem . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) - buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire + buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire Nothing Nothing assert (buid == buid') $ pure () SAMLUserStore.insert suid buid diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index 56a1cd1d98..45a28888e1 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -30,6 +30,7 @@ module Spar.Intra.Brig checkHandleAvailable, deleteBrigUser, createBrigUserSAML, + createBrigUserSAMLSafe, createBrigUserNoSAML, updateEmail, ensureReAuthorised, @@ -84,6 +85,38 @@ respToCookie resp = do class (Log.MonadLogger m, MonadError SparError m) => MonadSparToBrig m where call :: (Request -> Request) -> m ResponseLBS +createBrigUserSAMLSafe :: + (HasCallStack, MonadSparToBrig m) => + SAML.UserRef -> + UserId -> + TeamId -> + -- | User name + Name -> + -- | Who should have control over the user + ManagedBy -> + Maybe Handle -> + Maybe RichInfo -> + m UserId +createBrigUserSAMLSafe uref (Id buid) teamid name managedBy handle richInfo = do + let newUser = + NewUserSpar + { newUserSparUUID = buid, + newUserSparDisplayName = name, + newUserSparSSOId = UserSSOId uref, + newUserSparTeamId = teamid, + newUserSparManagedBy = managedBy, + newUserSparHandle = handle, + newUserSparRichInfo = richInfo + } + resp :: ResponseLBS <- + call $ + method POST + . path "/i/users/safe" + . json newUser + if statusCode resp `elem` [200, 201] + then userId . selfUser <$> parseResponse @SelfProfile "brig" resp + else rethrow "brig" resp + createBrigUserSAML :: (HasCallStack, MonadSparToBrig m) => SAML.UserRef -> @@ -93,20 +126,24 @@ createBrigUserSAML :: Name -> -- | Who should have control over the user ManagedBy -> + Maybe Handle -> + Maybe RichInfo -> m UserId -createBrigUserSAML uref (Id buid) teamid uname managedBy = do - let newUser :: NewUser - newUser = - (emptyNewUser uname) - { newUserUUID = Just buid, - newUserIdentity = Just (SSOIdentity (UserSSOId uref) Nothing Nothing), - newUserOrigin = Just (NewUserOriginTeamUser . NewTeamMemberSSO $ teamid), - newUserManagedBy = Just managedBy +createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo = do + let newUser = + NewUserSpar + { newUserSparUUID = buid, + newUserSparDisplayName = name, + newUserSparSSOId = UserSSOId uref, + newUserSparTeamId = teamid, + newUserSparManagedBy = managedBy, + newUserSparHandle = handle, + newUserSparRichInfo = richInfo } resp :: ResponseLBS <- call $ method POST - . path "/i/users" + . path "/i/users/" . json newUser if statusCode resp `elem` [200, 201] then userId . selfUser <$> parseResponse @SelfProfile "brig" resp diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 4825dcb0b6..6043970a05 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -82,14 +82,6 @@ veidFromUserSSOId = \case (pure . EmailOnly) (parseEmail email) -urefToExternalId :: SAML.UserRef -> Maybe Text -urefToExternalId = fmap CI.original . SAML.shortShowNameID . view SAML.uidSubject - -urefToEmail :: SAML.UserRef -> Maybe Email -urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of - SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email - _ -> Nothing - -- | 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 diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 72dfe7365b..8bbc1c921e 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -446,7 +446,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- `createValidScimUser` into a function `createValidScimUserBrig` similar -- to `createValidScimUserSpar`? uid <- Id <$> Random.uuid - BrigAccess.createSAML uref uid stiTeam name ManagedByScim + BrigAccess.createSAMLSafe uref uid stiTeam name ManagedByScim (Just handl) (Just richInfo) ) ( \email -> BrigAccess.createNoSAML email stiTeam name language @@ -460,8 +460,8 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- up. We should consider making setUserHandle part of createUser and -- making it transactional. If the user redoes the POST A new standalone -- user will be created.} - BrigAccess.setHandle buid handl - BrigAccess.setRichInfo buid richInfo + -- BrigAccess.setHandle buid handl + -- BrigAccess.setRichInfo buid richInfo pure buid -- {If we crash now, a POST retry will fail with 409 user already exists. diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 47448ab7b7..307b683bbd 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -20,6 +20,7 @@ module Spar.Sem.BrigAccess ( BrigAccess (..), createSAML, + createSAMLSafe, createNoSAML, updateEmail, getAccount, @@ -58,7 +59,8 @@ 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 -> BrigAccess m UserId + CreateSAMLSafe :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> BrigAccess m UserId + CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> BrigAccess m UserId CreateNoSAML :: Email -> TeamId -> Name -> Maybe Locale -> BrigAccess m UserId UpdateEmail :: UserId -> Email -> BrigAccess m () GetAccount :: HavePendingInvitations -> UserId -> BrigAccess m (Maybe UserAccount) diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs index 8c139cf275..683bf4b55b 100644 --- a/services/spar/src/Spar/Sem/BrigAccess/Http.hs +++ b/services/spar/src/Spar/Sem/BrigAccess/Http.hs @@ -40,7 +40,8 @@ brigAccessToHttp :: brigAccessToHttp mgr req = interpret $ viaRunHttp (RunHttpEnv mgr req) . \case - CreateSAML u itlu itlt n m -> Intra.createBrigUserSAML u itlu itlt n m + CreateSAML u itlu itlt n m h ri -> Intra.createBrigUserSAML u itlu itlt n m h ri + CreateSAMLSafe u itlu itlt n m h ri -> Intra.createBrigUserSAMLSafe u itlu itlt n m h ri CreateNoSAML e itlt n locale -> Intra.createBrigUserNoSAML e itlt n locale UpdateEmail itlu e -> Intra.updateEmail itlu e GetAccount h itlu -> Intra.getBrigUserAccount h itlu diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index e8ec711264..44a146fa77 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -678,8 +678,8 @@ testCreateUserWithSamlIdP :: TestSpar () testCreateUserWithSamlIdP = do env <- ask -- Create a user via SCIM - user <- randomScimUser (tok, (owner, tid, _idp)) <- registerIdPAndScimToken + user <- randomScimUser scimStoredUser <- createUser tok user let userid = scimUserId scimStoredUser -- Check that this user is present in Brig and that Brig's view of the user diff --git a/services/spar/test/Test/Spar/DataSpec.hs b/services/spar/test/Test/Spar/DataSpec.hs index 32ece91eab..c5c3e43ad6 100644 --- a/services/spar/test/Test/Spar/DataSpec.hs +++ b/services/spar/test/Test/Spar/DataSpec.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-unrecognised-pragmas #-} module Test.Spar.DataSpec where @@ -40,6 +41,10 @@ check :: HasCallStack => Int -> Env -> String -> Either TTLError (TTL "authresp" check testnumber env (parsetm -> endOfLife) expectttl = it (show testnumber) $ mkTTLAssertions env endOfLife `shouldBe` expectttl +parsetm :: HasCallStack => String -> UTCTime +parsetm = fromJust . parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" + +{-# HLINT ignore "Eta reduce" #-} -- For clarity mkDataEnv :: HasCallStack => String -> TTL "authresp" -> Env mkDataEnv now maxttl = Env @@ -47,5 +52,3 @@ mkDataEnv now maxttl = 0 -- will not be looked at maxttl -- this one will -parsetm :: HasCallStack => String -> UTCTime -parsetm = fromJust . parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" From 8428fedde8c9b0adfda3431e0fc820ad1f511ec1 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Thu, 30 Jun 2022 11:01:59 +0000 Subject: [PATCH 2/9] Deleted commented out code. --- libs/wire-api/src/Wire/API/User.hs | 14 ----------- libs/wire-api/src/Wire/API/User/RichInfo.hs | 3 --- services/brig/src/Brig/API/Internal.hs | 15 ------------ services/brig/src/Brig/API/User.hs | 27 --------------------- 4 files changed, 59 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 00d6ebf14a..2516a5f6ac 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -526,20 +526,6 @@ isNewUserTeamMember u = case newUserTeam u of instance Arbitrary NewUserPublic where arbitrary = arbitrary `QC.suchThatMap` (rightMay . validateNewUserPublic) --- ChangeHandleErrorResponses -- .++ RegisterErrorResponses - --- type CreateUserSparResponses = --- CreateUserSparErrorResponses --- .++ '[ WithHeaders --- '[DescHeader "Location" "UserId" UserId] --- SelfProfile --- (Respond 201 "User created and pending activation" SelfProfile) --- ] - --- instance (res ~ CreateUserSparResponses) => AsUnion res (Either CreateUserSparError SelfProfile) where --- toUnion = eitherToUnion (toUnion @CreateUserSparErrorResponses) (Z . I) --- fromUnion = eitherFromUnion (fromUnion @CreateUserSparErrorResponses) (unI . unZ) - data RegisterError = RegisterErrorWhitelistError | RegisterErrorInvalidInvitationCode diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index 75871eadd0..0f51dd41a7 100644 --- a/libs/wire-api/src/Wire/API/User/RichInfo.hs +++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs @@ -312,9 +312,6 @@ instance ToSchema RichField where <$> richFieldType Schema..= field "type" (CI.original Schema..= (CI.mk <$> schema)) <*> richFieldValue Schema..= field "value" schema --- where --- ciSchema :: _ - instance Arbitrary RichField where arbitrary = RichField diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index f4030113cc..7eafb2186c 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -438,21 +438,6 @@ createUserNoVerifySafe uData = in API.activate key code (Just uid) !>> activationErrorToRegisterError pure . SelfProfile $ usr --- case usr of --- Right usr' -> do --- let uid = userId usr' --- case HandleUpdate . fromHandle <$> newUserHandle uData of --- Just handle -> do --- e <- D.trace "\n+++++++++++++++++++++++++++++++++++++ update handle failed" updateHandle uid handle --- pure . Left . CreateUserSparHandleError $ e --- Nothing -> do --- D.trace "\n++++++++++++++ no handle\n" pure () --- pure . Right . SelfProfile $ usr' --- -- _ <- D.trace "\n%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% update rich info failed " updateRichInfo uid undefined --- pure . Right $ SelfProfile usr' --- Left e -> do --- pure . Left . CreateUserSparRegisterError $ RegisterErrorBlacklistedEmail - deleteUserNoVerifyH :: UserId -> (Handler r) Response deleteUserNoVerifyH uid = do setStatus status202 empty <$ deleteUserNoVerify uid diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index f0197e4153..e3ec232b5f 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -268,33 +268,6 @@ createUserSpar new = do Team.TeamName nm <- lift $ wrapHttp $ Intra.getTeamName tid pure $ CreateUserTeam tid nm --- ensureMemberCanJoin :: TeamId -> ExceptT RegisterError (AppT r) () --- ensureMemberCanJoin tid = do --- maxSize <- fromIntegral . setMaxTeamSize <$> view settings --- (TeamSize teamSize) <- TeamSize.teamSize tid --- when (teamSize >= maxSize) $ --- throwE RegisterErrorTooManyTeamMembers --- -- FUTUREWORK: The above can easily be done/tested in the intra call. --- -- Remove after the next release. --- canAdd <- lift $ wrapHttp $ Intra.checkUserCanJoinTeam tid --- case canAdd of --- Just e -> throwM $ API.UserNotAllowedToJoinTeam e --- Nothing -> pure () - --- findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) --- findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity --- findTeamInvitation (Just e) c = --- lift (wrapClient $ Team.lookupInvitationInfo c) >>= \case --- Just ii -> do --- inv <- lift . wrapClient $ Team.lookupInvitation (Team.iiTeam ii) (Team.iiInvId ii) --- case (inv, Team.inInviteeEmail <$> inv) of --- (Just invite, Just em) --- | e == userEmailKey em -> do --- _ <- ensureMemberCanJoin (Team.iiTeam ii) --- pure $ Just (invite, ii, Team.iiTeam ii) --- _ -> throwE RegisterErrorInvalidInvitationCode --- Nothing -> throwE RegisterErrorInvalidInvitationCode - -- docs/reference/user/registration.md {#RefRegistration} createUser :: forall r. Member BlacklistStore r => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult createUser new = do From 371836b6ca1438585cbfeb8512076959315a0d5f Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 4 Jul 2022 12:39:46 +0000 Subject: [PATCH 3/9] Re-enabled code for the missing flows. --- services/spar/src/Spar/App.hs | 2 +- services/spar/src/Spar/Intra/Brig.hs | 19 +++++++------------ services/spar/src/Spar/Scim/User.hs | 14 +++++--------- services/spar/src/Spar/Sem/BrigAccess.hs | 2 +- services/spar/src/Spar/Sem/BrigAccess/Http.hs | 2 +- 5 files changed, 15 insertions(+), 24 deletions(-) diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index fb4283fce0..22460e0697 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -170,7 +170,7 @@ createSamlUserWithId :: Sem r () createSamlUserWithId teamid buid suid = do uname <- either (throwSparSem . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) - buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire Nothing Nothing + buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire assert (buid == buid') $ pure () SAMLUserStore.insert suid buid diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index 45a28888e1..885ff13f53 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -126,24 +126,19 @@ createBrigUserSAML :: Name -> -- | Who should have control over the user ManagedBy -> - Maybe Handle -> - Maybe RichInfo -> m UserId -createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo = do +createBrigUserSAML uref (Id buid) teamid name managedBy = do let newUser = - NewUserSpar - { newUserSparUUID = buid, - newUserSparDisplayName = name, - newUserSparSSOId = UserSSOId uref, - newUserSparTeamId = teamid, - newUserSparManagedBy = managedBy, - newUserSparHandle = handle, - newUserSparRichInfo = richInfo + (emptyNewUser name) + { newUserUUID = Just buid, + newUserIdentity = Just (SSOIdentity (UserSSOId uref) Nothing Nothing), + newUserOrigin = Just (NewUserOriginTeamUser . NewTeamMemberSSO $ teamid), + newUserManagedBy = Just managedBy } resp :: ResponseLBS <- call $ method POST - . path "/i/users/" + . path "/i/users" . json newUser if statusCode resp `elem` [200, 201] then userId . selfUser <$> parseResponse @SelfProfile "brig" resp diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 8bbc1c921e..659a910b95 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -448,20 +448,16 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid uid <- Id <$> Random.uuid BrigAccess.createSAMLSafe uref uid stiTeam name ManagedByScim (Just handl) (Just richInfo) ) - ( \email -> - BrigAccess.createNoSAML email stiTeam name language + ( \email -> do + buid <- BrigAccess.createNoSAML email stiTeam name language + BrigAccess.setHandle buid handl -- TODO: possibly do the same one req as we do for saml? + pure buid ) veid Logger.debug ("createValidScimUser: brig says " <> show buid) - -- {If we crash now, we have an active user that cannot login. And can not - -- be bound this will be a zombie user that needs to be manually cleaned - -- up. We should consider making setUserHandle part of createUser and - -- making it transactional. If the user redoes the POST A new standalone - -- user will be created.} - -- BrigAccess.setHandle buid handl - -- BrigAccess.setRichInfo buid richInfo + BrigAccess.setRichInfo buid richInfo pure buid -- {If we crash now, a POST retry will fail with 409 user already exists. diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 307b683bbd..3f23d2c3ac 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -60,7 +60,7 @@ import Wire.API.User.Scim (ValidExternalId (..)) data BrigAccess m a where CreateSAMLSafe :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> BrigAccess m UserId - CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> BrigAccess m UserId + CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> BrigAccess m UserId CreateNoSAML :: Email -> TeamId -> Name -> Maybe Locale -> BrigAccess m UserId UpdateEmail :: UserId -> Email -> BrigAccess m () GetAccount :: HavePendingInvitations -> UserId -> BrigAccess m (Maybe UserAccount) diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs index 683bf4b55b..d5489a5366 100644 --- a/services/spar/src/Spar/Sem/BrigAccess/Http.hs +++ b/services/spar/src/Spar/Sem/BrigAccess/Http.hs @@ -40,7 +40,7 @@ brigAccessToHttp :: brigAccessToHttp mgr req = interpret $ viaRunHttp (RunHttpEnv mgr req) . \case - CreateSAML u itlu itlt n m h ri -> Intra.createBrigUserSAML u itlu itlt n m h ri + CreateSAML u itlu itlt n m -> Intra.createBrigUserSAML u itlu itlt n m CreateSAMLSafe u itlu itlt n m h ri -> Intra.createBrigUserSAMLSafe u itlu itlt n m h ri CreateNoSAML e itlt n locale -> Intra.createBrigUserNoSAML e itlt n locale UpdateEmail itlu e -> Intra.updateEmail itlu e From 2917d460b0bf76e91116007e1f5573cf2afdcbea Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 12 Jul 2022 13:05:47 +0000 Subject: [PATCH 4/9] Add new return type with combined errors for user creation. --- .../src/Wire/API/Routes/Internal/Brig.hs | 2 +- libs/wire-api/src/Wire/API/User.hs | 58 +++++++++++++++++-- services/brig/src/Brig/API/Internal.hs | 4 +- services/brig/src/Brig/API/User.hs | 27 +++++++-- 4 files changed, 78 insertions(+), 13 deletions(-) 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 eccc098c7f..17ab185277 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -150,7 +150,7 @@ type AccountAPI = "createUserNoVerifySafe" ( "users" :> "safe" -- TODO: temporary name :> ReqBody '[Servant.JSON] NewUserSpar - :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile) + :> MultiVerb 'POST '[Servant.JSON] CreateUserSparInternalResponses (Either CreateUserSparError SelfProfile) ) data NewKeyPackageRef = NewKeyPackageRef diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 2516a5f6ac..d28f8c4fcd 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -51,6 +51,8 @@ module Wire.API.User NewUser (..), emptyNewUser, NewUserSpar (..), + CreateUserSparError (..), + CreateUserSparInternalResponses, newUserFromSpar, urefToExternalId, urefToEmail, @@ -603,6 +605,52 @@ urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of SAML.UNameIDEmail email -> parseEmail . SAMLEmail.render . CI.original $ email _ -> Nothing +data CreateUserSparError + = CreateUserSparHandleError ChangeHandleError + | CreateUserSparRegistrationError RegisterError + deriving (Show, Generic) + +type CreateUserSparErrorResponses = + RegisterErrorResponses .++ ChangeHandleErrorResponses + +type CreateUserSparResponses = + CreateUserSparErrorResponses + .++ '[ WithHeaders + '[ DescHeader "Set-Cookie" "Cookie" Web.SetCookie, + DescHeader "Location" "UserId" UserId + ] + RegisterSuccess + (Respond 201 "User created and pending activation" SelfProfile) + ] + +type CreateUserSparInternalResponses = + CreateUserSparErrorResponses + .++ '[ WithHeaders + '[DescHeader "Location" "UserId" UserId] + SelfProfile + (Respond 201 "User created and pending activation" SelfProfile) + ] + +instance (res ~ CreateUserSparErrorResponses) => AsUnion res CreateUserSparError where + toUnion = eitherToUnion (toUnion @ChangeHandleErrorResponses) (toUnion @RegisterErrorResponses) . errToEither + fromUnion = errFromEither . eitherFromUnion (fromUnion @ChangeHandleErrorResponses) (fromUnion @RegisterErrorResponses) + +instance (res ~ CreateUserSparResponses) => AsUnion res (Either CreateUserSparError RegisterSuccess) where + toUnion = eitherToUnion (toUnion @CreateUserSparErrorResponses) (Z . I) + fromUnion = eitherFromUnion (fromUnion @CreateUserSparErrorResponses) (unI . unZ) + +instance (res ~ CreateUserSparInternalResponses) => AsUnion res (Either CreateUserSparError SelfProfile) where + toUnion = eitherToUnion (toUnion @CreateUserSparErrorResponses) (Z . I) + fromUnion = eitherFromUnion (fromUnion @CreateUserSparErrorResponses) (unI . unZ) + +errToEither :: CreateUserSparError -> Either ChangeHandleError RegisterError +errToEither (CreateUserSparHandleError e) = Left e +errToEither (CreateUserSparRegistrationError e) = Right e + +errFromEither :: Either ChangeHandleError RegisterError -> CreateUserSparError +errFromEither (Left e) = CreateUserSparHandleError e +errFromEither (Right e) = CreateUserSparRegistrationError e + data NewUserSpar = NewUserSpar { newUserSparUUID :: UUID, newUserSparSSOId :: UserSSOId, @@ -1194,11 +1242,11 @@ data ChangeHandleError instance GSOP.Generic ChangeHandleError type ChangeHandleErrorResponses = - [ ErrorResponse 'E.NoIdentity, - ErrorResponse 'E.HandleExists, - ErrorResponse 'E.InvalidHandle, - ErrorResponse 'E.HandleManagedByScim - ] + '[ ErrorResponse 'E.NoIdentity, + ErrorResponse 'E.HandleExists, + ErrorResponse 'E.InvalidHandle, + ErrorResponse 'E.HandleManagedByScim + ] type ChangeHandleResponses = ChangeHandleErrorResponses .++ '[RespondEmpty 200 "Handle Changed"] diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 7eafb2186c..272a439455 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -423,7 +423,7 @@ createUserNoVerify uData = lift . runExceptT $ do in API.activate key code (Just uid) !>> activationErrorToRegisterError pure . SelfProfile $ usr -createUserNoVerifySafe :: NewUserSpar -> (Handler r) (Either RegisterError SelfProfile) +createUserNoVerifySafe :: NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) createUserNoVerifySafe uData = lift . runExceptT $ do result <- API.createUserSpar uData @@ -435,7 +435,7 @@ createUserNoVerifySafe uData = for_ (catMaybes [eac, pac]) $ \adata -> let key = ActivateKey $ activationKey adata code = activationCode adata - in API.activate key code (Just uid) !>> activationErrorToRegisterError + in API.activate key code (Just uid) !>> CreateUserSparRegistrationError . activationErrorToRegisterError pure . SelfProfile $ usr deleteUserNoVerifyH :: UserId -> (Handler r) Response diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index e3ec232b5f..3f04f2adcc 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -143,7 +143,7 @@ import Control.Monad.Catch import Data.ByteString.Conversion import Data.Code import qualified Data.Currency as Currency -import Data.Handle (Handle) +import Data.Handle (Handle (fromHandle), parseHandle) import Data.Id as Id import Data.Json.Util import Data.LegalHold (UserLegalHoldStatus (..), defUserLegalHoldStatus) @@ -218,7 +218,7 @@ verifyUniquenessAndCheckBlacklist uk = do unless av $ throwE IdentityErrorUserKeyExists -createUserSpar :: NewUserSpar -> ExceptT RegisterError (AppT r) CreateUserResult +createUserSpar :: NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult createUserSpar new = do let handle' = newUserSparHandle new new' = newUserFromSpar new -- TODO: make it obsolete once we add rich info? @@ -236,22 +236,39 @@ createUserSpar new = do case unRichInfo <$> newUserSparRichInfo new of Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo Nothing -> pure () -- Nothing to do - wrapHttp $ Intra.createSelfConv uid wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account)) pure account - -- Add to team - userTeam <- addUserToTeamSSO account tid (SSOIdentity ident Nothing Nothing) + userTeam <- lmap CreateUserSparRegistrationError $ addUserToTeamSSO account tid (SSOIdentity ident Nothing Nothing) -- Set up feature flags let uid = userId (accountUser account) lift $ initAccountFeatureConfig uid + -- Set handle + updateHandle' uid handle' + pure $! CreateUserResult account Nothing Nothing (Just userTeam) where + lmap f = + let h = \case + Left x -> + Left (f x) + Right a -> + Right a + {-# INLINE h #-} + in ExceptT . fmap h . runExceptT + + updateHandle' :: UserId -> Maybe Handle -> ExceptT CreateUserSparError (AppT r) () + updateHandle' _ Nothing = pure () + updateHandle' uid (Just h) = do + case parseHandle . fromHandle $ h of + Just handl -> lmap CreateUserSparHandleError $ changeHandle uid Nothing handl AllowSCIMUpdates + Nothing -> throwE $ CreateUserSparHandleError ChangeHandleInvalid + addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) From dca675c665d26786e4e0b89f6bac66446848e923 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Tue, 12 Jul 2022 14:37:19 +0000 Subject: [PATCH 5/9] Renamed+unified paths for user creation w/ Spar. --- .../src/Wire/API/Routes/Internal/Brig.hs | 4 +-- services/brig/src/Brig/API/Internal.hs | 6 ++-- services/spar/src/Spar/App.hs | 2 +- services/spar/src/Spar/Intra/Brig.hs | 34 ++----------------- services/spar/src/Spar/Scim/User.hs | 2 +- services/spar/src/Spar/Sem/BrigAccess.hs | 4 +-- services/spar/src/Spar/Sem/BrigAccess/Http.hs | 3 +- 7 files changed, 12 insertions(+), 43 deletions(-) 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 17ab185277..b4cdbab5bc 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -147,8 +147,8 @@ type AccountAPI = :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile) ) :<|> Named - "createUserNoVerifySafe" - ( "users" :> "safe" -- TODO: temporary name + "createUserNoVerifySpar" + ( "users" :> "spar" -- TODO: temporary name :> ReqBody '[Servant.JSON] NewUserSpar :> MultiVerb 'POST '[Servant.JSON] CreateUserSparInternalResponses (Either CreateUserSparError SelfProfile) ) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 272a439455..f9e0f8c57f 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -127,7 +127,7 @@ mlsAPI = accountAPI :: Member BlacklistStore r => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = Named @"createUserNoVerify" createUserNoVerify - :<|> Named @"createUserNoVerifySafe" createUserNoVerifySafe + :<|> Named @"createUserNoVerifySpar" createUserNoVerifySpar teamsAPI :: ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = Named @"updateSearchVisibilityInbound" Index.updateSearchVisibilityInbound @@ -423,8 +423,8 @@ createUserNoVerify uData = lift . runExceptT $ do in API.activate key code (Just uid) !>> activationErrorToRegisterError pure . SelfProfile $ usr -createUserNoVerifySafe :: NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) -createUserNoVerifySafe uData = +createUserNoVerifySpar :: NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile) +createUserNoVerifySpar uData = lift . runExceptT $ do result <- API.createUserSpar uData let acc = createdAccount result diff --git a/services/spar/src/Spar/App.hs b/services/spar/src/Spar/App.hs index 22460e0697..fb4283fce0 100644 --- a/services/spar/src/Spar/App.hs +++ b/services/spar/src/Spar/App.hs @@ -170,7 +170,7 @@ createSamlUserWithId :: Sem r () createSamlUserWithId teamid buid suid = do uname <- either (throwSparSem . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid) - buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire + buid' <- BrigAccess.createSAML suid buid teamid uname ManagedByWire Nothing Nothing assert (buid == buid') $ pure () SAMLUserStore.insert suid buid diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index 885ff13f53..26890fd8dc 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -30,7 +30,6 @@ module Spar.Intra.Brig checkHandleAvailable, deleteBrigUser, createBrigUserSAML, - createBrigUserSAMLSafe, createBrigUserNoSAML, updateEmail, ensureReAuthorised, @@ -85,7 +84,7 @@ respToCookie resp = do class (Log.MonadLogger m, MonadError SparError m) => MonadSparToBrig m where call :: (Request -> Request) -> m ResponseLBS -createBrigUserSAMLSafe :: +createBrigUserSAML :: (HasCallStack, MonadSparToBrig m) => SAML.UserRef -> UserId -> @@ -97,7 +96,7 @@ createBrigUserSAMLSafe :: Maybe Handle -> Maybe RichInfo -> m UserId -createBrigUserSAMLSafe uref (Id buid) teamid name managedBy handle richInfo = do +createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo = do let newUser = NewUserSpar { newUserSparUUID = buid, @@ -111,34 +110,7 @@ createBrigUserSAMLSafe uref (Id buid) teamid name managedBy handle richInfo = do resp :: ResponseLBS <- call $ method POST - . path "/i/users/safe" - . json newUser - if statusCode resp `elem` [200, 201] - then userId . selfUser <$> parseResponse @SelfProfile "brig" resp - else rethrow "brig" resp - -createBrigUserSAML :: - (HasCallStack, MonadSparToBrig m) => - SAML.UserRef -> - UserId -> - TeamId -> - -- | User name - Name -> - -- | Who should have control over the user - ManagedBy -> - m UserId -createBrigUserSAML uref (Id buid) teamid name managedBy = do - let newUser = - (emptyNewUser name) - { newUserUUID = Just buid, - newUserIdentity = Just (SSOIdentity (UserSSOId uref) Nothing Nothing), - newUserOrigin = Just (NewUserOriginTeamUser . NewTeamMemberSSO $ teamid), - newUserManagedBy = Just managedBy - } - resp :: ResponseLBS <- - call $ - method POST - . path "/i/users" + . path "/i/users/spar" . json newUser if statusCode resp `elem` [200, 201] then userId . selfUser <$> parseResponse @SelfProfile "brig" resp diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index 659a910b95..a06b13af93 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -446,7 +446,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid -- `createValidScimUser` into a function `createValidScimUserBrig` similar -- to `createValidScimUserSpar`? uid <- Id <$> Random.uuid - BrigAccess.createSAMLSafe uref uid stiTeam name ManagedByScim (Just handl) (Just richInfo) + BrigAccess.createSAML uref uid stiTeam name ManagedByScim (Just handl) (Just richInfo) ) ( \email -> do buid <- BrigAccess.createNoSAML email stiTeam name language diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 3f23d2c3ac..b71a116250 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -20,7 +20,6 @@ module Spar.Sem.BrigAccess ( BrigAccess (..), createSAML, - createSAMLSafe, createNoSAML, updateEmail, getAccount, @@ -59,8 +58,7 @@ import Wire.API.User.RichInfo as RichInfo import Wire.API.User.Scim (ValidExternalId (..)) data BrigAccess m a where - CreateSAMLSafe :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> BrigAccess m UserId - CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> BrigAccess m UserId + CreateSAML :: SAML.UserRef -> UserId -> TeamId -> Name -> ManagedBy -> Maybe Handle -> Maybe RichInfo -> BrigAccess m UserId CreateNoSAML :: Email -> TeamId -> Name -> Maybe Locale -> BrigAccess m UserId UpdateEmail :: UserId -> Email -> BrigAccess m () GetAccount :: HavePendingInvitations -> UserId -> BrigAccess m (Maybe UserAccount) diff --git a/services/spar/src/Spar/Sem/BrigAccess/Http.hs b/services/spar/src/Spar/Sem/BrigAccess/Http.hs index d5489a5366..834e470e0e 100644 --- a/services/spar/src/Spar/Sem/BrigAccess/Http.hs +++ b/services/spar/src/Spar/Sem/BrigAccess/Http.hs @@ -40,8 +40,7 @@ brigAccessToHttp :: brigAccessToHttp mgr req = interpret $ viaRunHttp (RunHttpEnv mgr req) . \case - CreateSAML u itlu itlt n m -> Intra.createBrigUserSAML u itlu itlt n m - CreateSAMLSafe u itlu itlt n m h ri -> Intra.createBrigUserSAMLSafe u itlu itlt n m h ri + CreateSAML u itlu itlt n m h ri -> Intra.createBrigUserSAML u itlu itlt n m h ri CreateNoSAML e itlt n locale -> Intra.createBrigUserNoSAML e itlt n locale UpdateEmail itlu e -> Intra.updateEmail itlu e GetAccount h itlu -> Intra.getBrigUserAccount h itlu From e4399cd2cd2cd63aa6bb1cc5d236e64ba0451aa8 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Wed, 13 Jul 2022 07:20:30 +0000 Subject: [PATCH 6/9] Format. --- libs/wire-api/src/Wire/API/User.hs | 1 - libs/wire-api/src/Wire/API/User/RichInfo.hs | 2 +- services/brig/src/Brig/API/Internal.hs | 2 +- services/spar/test/Test/Spar/DataSpec.hs | 4 ++-- 4 files changed, 4 insertions(+), 5 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index d28f8c4fcd..c18ce4bed2 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -44,7 +44,6 @@ module Wire.API.User -- * NewUser NewUserPublic (..), RegisterError (..), - -- CreateUserSparError (..), RegisterSuccess (..), RegisterResponses, RegisterInternalResponses, diff --git a/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs index 0f51dd41a7..fdb32ba0dd 100644 --- a/libs/wire-api/src/Wire/API/User/RichInfo.hs +++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE StrictData #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. -- diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index f9e0f8c57f..a70620d897 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -127,7 +127,7 @@ mlsAPI = accountAPI :: Member BlacklistStore r => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = Named @"createUserNoVerify" createUserNoVerify - :<|> Named @"createUserNoVerifySpar" createUserNoVerifySpar + :<|> Named @"createUserNoVerifySpar" createUserNoVerifySpar teamsAPI :: ServerT BrigIRoutes.TeamsAPI (Handler r) teamsAPI = Named @"updateSearchVisibilityInbound" Index.updateSearchVisibilityInbound diff --git a/services/spar/test/Test/Spar/DataSpec.hs b/services/spar/test/Test/Spar/DataSpec.hs index c5c3e43ad6..61af59b7c9 100644 --- a/services/spar/test/Test/Spar/DataSpec.hs +++ b/services/spar/test/Test/Spar/DataSpec.hs @@ -44,11 +44,11 @@ check testnumber env (parsetm -> endOfLife) expectttl = parsetm :: HasCallStack => String -> UTCTime parsetm = fromJust . parseTimeM True defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" -{-# HLINT ignore "Eta reduce" #-} -- For clarity +{-# HLINT ignore "Eta reduce" #-} +-- For clarity mkDataEnv :: HasCallStack => String -> TTL "authresp" -> Env mkDataEnv now maxttl = Env (parsetm now) 0 -- will not be looked at maxttl -- this one will - From 55fc5ad6467ab63472e29660dc61573423d49e30 Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 1 Aug 2022 09:08:40 +0000 Subject: [PATCH 7/9] Addressed PR comments. --- .../wire-api/src/Wire/API/Routes/Internal/Brig.hs | 2 +- libs/wire-api/src/Wire/API/User/Identity.hs | 12 ------------ services/brig/src/Brig/API/User.hs | 15 +++++---------- 3 files changed, 6 insertions(+), 23 deletions(-) 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 b4cdbab5bc..8a153b5675 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -148,7 +148,7 @@ type AccountAPI = ) :<|> Named "createUserNoVerifySpar" - ( "users" :> "spar" -- TODO: temporary name + ( "users" :> "spar" :> ReqBody '[Servant.JSON] NewUserSpar :> MultiVerb 'POST '[Servant.JSON] CreateUserSparInternalResponses (Either CreateUserSparError SelfProfile) ) diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 156c54b6f9..802412efd5 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -63,18 +63,6 @@ import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import Data.Proxy (Proxy (..)) import Data.Schema - ( HasDoc (doc), - ObjectSchema, - Schema (Schema), - SwaggerDoc, - ToSchema (..), - genericToSchema, - maybe_, - optField, - parsedText, - withParser, - (.=), - ) import Data.String.Conversions (cs) import qualified Data.Swagger as S import qualified Data.Text as Text diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 3f04f2adcc..d19abbe95b 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -143,6 +143,7 @@ import Control.Monad.Catch import Data.ByteString.Conversion import Data.Code import qualified Data.Currency as Currency +import Data.Either.Combinators (mapLeft) import Data.Handle (Handle (fromHandle), parseHandle) import Data.Id as Id import Data.Json.Util @@ -221,7 +222,7 @@ verifyUniquenessAndCheckBlacklist uk = do createUserSpar :: NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult createUserSpar new = do let handle' = newUserSparHandle new - new' = newUserFromSpar new -- TODO: make it obsolete once we add rich info? + new' = newUserFromSpar new ident = newUserSparSSOId new tid = newUserSparTeamId new @@ -231,7 +232,7 @@ createUserSpar new = do let uid = userId (accountUser account) - -- TODO: make this transactional? + -- FUTUREWORK: make this transactional if possible wrapClient $ Data.insertAccount account Nothing pw False case unRichInfo <$> newUserSparRichInfo new of Just richInfo -> wrapClient $ Data.updateRichInfo uid richInfo @@ -253,14 +254,8 @@ createUserSpar new = do pure $! CreateUserResult account Nothing Nothing (Just userTeam) where - lmap f = - let h = \case - Left x -> - Left (f x) - Right a -> - Right a - {-# INLINE h #-} - in ExceptT . fmap h . runExceptT + lmap :: Functor m => (a -> b) -> ExceptT a m v -> ExceptT b m v + lmap f = ExceptT . fmap (mapLeft f) . runExceptT updateHandle' :: UserId -> Maybe Handle -> ExceptT CreateUserSparError (AppT r) () updateHandle' _ Nothing = pure () From b20b395c965077d9f06bdbbccac65fbeb39c36ed Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 1 Aug 2022 12:06:36 +0000 Subject: [PATCH 8/9] Addressed PR comments pt 2 --- services/brig/src/Brig/API/User.hs | 8 ++------ services/spar/src/Spar/Scim/User.hs | 2 +- 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index d19abbe95b..3ba1eb47c3 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -143,7 +143,6 @@ import Control.Monad.Catch import Data.ByteString.Conversion import Data.Code import qualified Data.Currency as Currency -import Data.Either.Combinators (mapLeft) import Data.Handle (Handle (fromHandle), parseHandle) import Data.Id as Id import Data.Json.Util @@ -243,7 +242,7 @@ createUserSpar new = do pure account -- Add to team - userTeam <- lmap CreateUserSparRegistrationError $ addUserToTeamSSO account tid (SSOIdentity ident Nothing Nothing) + userTeam <- withExceptT CreateUserSparRegistrationError $ addUserToTeamSSO account tid (SSOIdentity ident Nothing Nothing) -- Set up feature flags let uid = userId (accountUser account) @@ -254,14 +253,11 @@ createUserSpar new = do pure $! CreateUserResult account Nothing Nothing (Just userTeam) where - lmap :: Functor m => (a -> b) -> ExceptT a m v -> ExceptT b m v - lmap f = ExceptT . fmap (mapLeft f) . runExceptT - updateHandle' :: UserId -> Maybe Handle -> ExceptT CreateUserSparError (AppT r) () updateHandle' _ Nothing = pure () updateHandle' uid (Just h) = do case parseHandle . fromHandle $ h of - Just handl -> lmap CreateUserSparHandleError $ changeHandle uid Nothing handl AllowSCIMUpdates + Just handl -> withExceptT CreateUserSparHandleError $ changeHandle uid Nothing handl AllowSCIMUpdates Nothing -> throwE $ CreateUserSparHandleError ChangeHandleInvalid addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam diff --git a/services/spar/src/Spar/Scim/User.hs b/services/spar/src/Spar/Scim/User.hs index a06b13af93..358363fe34 100644 --- a/services/spar/src/Spar/Scim/User.hs +++ b/services/spar/src/Spar/Scim/User.hs @@ -450,7 +450,7 @@ createValidScimUser tokeninfo@ScimTokenInfo {stiTeam} vsu@(ST.ValidScimUser veid ) ( \email -> do buid <- BrigAccess.createNoSAML email stiTeam name language - BrigAccess.setHandle buid handl -- TODO: possibly do the same one req as we do for saml? + BrigAccess.setHandle buid handl -- FUTUREWORK: possibly do the same one req as we do for saml? pure buid ) veid From c69989e1518d3504061030082e40a670840d2cdf Mon Sep 17 00:00:00 2001 From: Igor Ranieri Date: Mon, 1 Aug 2022 14:50:26 +0000 Subject: [PATCH 9/9] Added changelog. --- changelog.d/5-internal/user-provisioning-resilience | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/user-provisioning-resilience diff --git a/changelog.d/5-internal/user-provisioning-resilience b/changelog.d/5-internal/user-provisioning-resilience new file mode 100644 index 0000000000..21cdbf02b7 --- /dev/null +++ b/changelog.d/5-internal/user-provisioning-resilience @@ -0,0 +1 @@ +Improved the resilience of provisioning new users via SAML by combining two persistence calls into one, preventing a creation failure from locking a user handle with no corresponding user.