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.
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..8a153b5675 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
+ "createUserNoVerifySpar"
+ ( "users" :> "spar"
+ :> ReqBody '[Servant.JSON] NewUserSpar
+ :> MultiVerb 'POST '[Servant.JSON] CreateUserSparInternalResponses (Either CreateUserSparError 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..c18ce4bed2 100644
--- a/libs/wire-api/src/Wire/API/User.hs
+++ b/libs/wire-api/src/Wire/API/User.hs
@@ -49,6 +49,12 @@ module Wire.API.User
RegisterInternalResponses,
NewUser (..),
emptyNewUser,
+ NewUserSpar (..),
+ CreateUserSparError (..),
+ CreateUserSparInternalResponses,
+ newUserFromSpar,
+ urefToExternalId,
+ urefToEmail,
ExpiresIn,
newUserInvitationCode,
newUserTeam,
@@ -112,7 +118,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 +143,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 +152,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 +168,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
@@ -532,7 +540,7 @@ data RegisterError
| RegisterErrorBlacklistedEmail
| RegisterErrorTooManyTeamMembers
| RegisterErrorUserCreationRestricted
- deriving (Generic)
+ deriving (Show, Generic)
deriving (AsUnion RegisterErrorResponses) via GenericAsUnion RegisterErrorResponses RegisterError
instance GSOP.Generic RegisterError
@@ -588,6 +596,103 @@ 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 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,
+ 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,17 +1235,17 @@ data ChangeHandleError
| ChangeHandleExists
| ChangeHandleInvalid
| ChangeHandleManagedByScim
- deriving (Generic)
+ deriving (Show, Generic)
deriving (AsUnion ChangeHandleErrorResponses) via GenericAsUnion ChangeHandleErrorResponses 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/libs/wire-api/src/Wire/API/User/RichInfo.hs b/libs/wire-api/src/Wire/API/User/RichInfo.hs
index 14276a7eb0..fdb32ba0dd 100644
--- a/libs/wire-api/src/Wire/API/User/RichInfo.hs
+++ b/libs/wire-api/src/Wire/API/User/RichInfo.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StrictData #-}
-- 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,16 @@ 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
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..a70620d897 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 @"createUserNoVerifySpar" createUserNoVerifySpar
teamsAPI :: ServerT BrigIRoutes.TeamsAPI (Handler r)
teamsAPI = Named @"updateSearchVisibilityInbound" Index.updateSearchVisibilityInbound
@@ -420,7 +421,22 @@ 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
+
+createUserNoVerifySpar :: NewUserSpar -> (Handler r) (Either CreateUserSparError SelfProfile)
+createUserNoVerifySpar 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) !>> CreateUserSparRegistrationError . activationErrorToRegisterError
+ pure . SelfProfile $ usr
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..3ba1eb47c3 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,
@@ -142,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)
@@ -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,64 @@ verifyUniquenessAndCheckBlacklist uk = do
unless av $
throwE IdentityErrorUserKeyExists
+createUserSpar :: NewUserSpar -> ExceptT CreateUserSparError (AppT r) CreateUserResult
+createUserSpar new = do
+ let handle' = newUserSparHandle new
+ new' = newUserFromSpar new
+ 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)
+
+ -- 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
+ Nothing -> pure () -- Nothing to do
+ wrapHttp $ Intra.createSelfConv uid
+ wrapHttpClient $ Intra.onUserEvent uid Nothing (UserCreated (accountUser account))
+
+ pure account
+
+ -- Add to team
+ userTeam <- withExceptT 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
+ updateHandle' :: UserId -> Maybe Handle -> ExceptT CreateUserSparError (AppT r) ()
+ updateHandle' _ Nothing = pure ()
+ updateHandle' uid (Just h) = do
+ case parseHandle . fromHandle $ h of
+ Just handl -> withExceptT 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)
+ 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
+
-- 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..26890fd8dc 100644
--- a/services/spar/src/Spar/Intra/Brig.hs
+++ b/services/spar/src/Spar/Intra/Brig.hs
@@ -93,20 +93,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/spar"
. 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..358363fe34 100644
--- a/services/spar/src/Spar/Scim/User.hs
+++ b/services/spar/src/Spar/Scim/User.hs
@@ -446,21 +446,17 @@ 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.createSAML 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 -- FUTUREWORK: 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
pure buid
diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs
index 47448ab7b7..b71a116250 100644
--- a/services/spar/src/Spar/Sem/BrigAccess.hs
+++ b/services/spar/src/Spar/Sem/BrigAccess.hs
@@ -58,7 +58,7 @@ 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
+ 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..834e470e0e 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 -> Intra.createBrigUserSAML u itlu itlt n m
+ 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
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..61af59b7c9 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,12 +41,14 @@ 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
(parsetm now)
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"