[SQSERVICES-1067] Address user account consistency issue when SCIM provisioning crashes

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.

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,

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"]

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 =

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),

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 <https://www.gnu.org/licenses/>.
-
 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

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.