WPB-6577 Fix user creation conflict in SCIM

cassandra-schema.cql

@@ -2165,6 +2165,7 @@ CREATE TABLE spar_test.scim_user_times (
 CREATE TABLE spar_test.scim_external (
     team uuid,
     external_id text,
+    creation_status int,
     user uuid,
     PRIMARY KEY (team, external_id)
 ) WITH CLUSTERING ORDER BY (external_id ASC)

changelog.d/3-bug-fixes/WPB-6577

@@ -0,0 +1 @@
+Prevent conflict on subsequent tries to provision a SCIM user

integration/integration.cabal

@@ -136,6 +136,7 @@ library
     Test.Roles
     Test.Search
     Test.Services
+    Test.Spar
     Test.Swagger
     Test.TeamSettings
     Test.User

integration/test/API/Common.hs

@@ -31,8 +31,11 @@ randomName = liftIO $ do
     pick = (chars !) <$> randomRIO (Array.bounds chars)
 
 randomHandle :: App String
-randomHandle = liftIO $ do
-  n <- randomRIO (50, 256)
+randomHandle = randomHandleWithRange 50 256
+
+randomHandleWithRange :: Int -> Int -> App String
+randomHandleWithRange min' max' = liftIO $ do
+  n <- randomRIO (min', max')
   replicateM n pick
   where
     chars = mkArray $ ['a' .. 'z'] <> ['0' .. '9'] <> "_-."

integration/test/API/Spar.hs

@@ -1,5 +1,6 @@
 module API.Spar where
 
+import API.Common (defPassword)
 import GHC.Stack
 import Testlib.Prelude
 
@@ -8,3 +9,15 @@ getScimTokens :: (HasCallStack, MakesValue caller) => caller -> App Response
 getScimTokens caller = do
   req <- baseRequest caller Spar Versioned "/scim/auth-tokens"
   submit "GET" req
+
+-- https://staging-nginz-https.zinfra.io/v5/api/swagger-ui/#/default/post_scim_auth_tokens
+createScimToken :: (HasCallStack, MakesValue caller) => caller -> App Response
+createScimToken caller = do
+  req <- baseRequest caller Spar Versioned "/scim/auth-tokens"
+  submit "POST" $ req & addJSONObject ["password" .= defPassword, "description" .= "integration test"]
+
+createScimUser :: (HasCallStack, MakesValue domain, MakesValue scimUser) => domain -> String -> scimUser -> App Response
+createScimUser domain token scimUser = do
+  req <- baseRequest domain Spar Versioned "/scim/v2/Users"
+  body <- make scimUser
+  submit "POST" $ req & addJSON body . addHeader "Authorization" ("Bearer " <> token)

integration/test/SetupHelpers.hs

@@ -314,3 +314,15 @@ lhDeviceIdOf bob = do
       >>= assertOne
       >>= (%. "id")
       >>= asString
+
+randomScimUser :: App Value
+randomScimUser = do
+  email <- randomEmail
+  handle <- randomHandleWithRange 12 128
+  pure $
+    object
+      [ "schemas" .= ["urn:ietf:params:scim:schemas:core:2.0:User"],
+        "externalId" .= email,
+        "userName" .= handle,
+        "displayName" .= handle
+      ]

integration/test/Test/Spar.hs

@@ -0,0 +1,28 @@
+{-# OPTIONS_GHC -Wno-ambiguous-fields #-}
+
+module Test.Spar where
+
+import API.Spar
+import Control.Concurrent (threadDelay)
+import SetupHelpers
+import Testlib.Prelude
+
+testSparUserCreationInvitationTimeout :: HasCallStack => App ()
+testSparUserCreationInvitationTimeout = do
+  (owner, _tid, _) <- createTeam OwnDomain 1
+  tok <- createScimToken owner >>= \resp -> resp.json %. "token" >>= asString
+  scimUser <- randomScimUser
+  bindResponse (createScimUser OwnDomain tok scimUser) $ \res -> do
+    res.status `shouldMatchInt` 201
+
+  -- Trying to create the same user again right away should fail
+  bindResponse (createScimUser OwnDomain tok scimUser) $ \res -> do
+    res.status `shouldMatchInt` 409
+
+  -- However, if we wait until the invitation timeout has passed
+  -- (assuming it is configured to 10s locally and in CI)...
+  liftIO $ threadDelay (11_000_000)
+
+  -- ...we should be able to create the user again
+  retryT $ bindResponse (createScimUser OwnDomain tok scimUser) $ \res -> do
+    res.status `shouldMatchInt` 201

libs/wire-api/src/Wire/API/User.hs

@@ -59,6 +59,7 @@ module Wire.API.User
     CreateUserSparInternalResponses,
     newUserFromSpar,
     urefToExternalId,
+    urefToExternalIdUnsafe,
     urefToEmail,
     ExpiresIn,
     newUserInvitationCode,
@@ -958,6 +959,9 @@ urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of
   SAML.UNameIDEmail email -> parseEmail . SAMLEmail.render . CI.original $ email
   _ -> Nothing
 
+urefToExternalIdUnsafe :: SAML.UserRef -> Text
+urefToExternalIdUnsafe = CI.original . SAML.unsafeShowNameID . view SAML.uidSubject
+
 data CreateUserSparError
   = CreateUserSparHandleError ChangeHandleError
   | CreateUserSparRegistrationError RegisterError
@@ -1904,6 +1908,7 @@ instance Schema.ToSchema UserAccount where
 data NewUserScimInvitation = NewUserScimInvitation
   -- FIXME: the TID should be captured in the route as usual
   { newUserScimInvTeamId :: TeamId,
+    newUserScimInvUserId :: UserId,
     newUserScimInvLocale :: Maybe Locale,
     newUserScimInvName :: Name,
     newUserScimInvEmail :: Email,
@@ -1918,6 +1923,7 @@ instance Schema.ToSchema NewUserScimInvitation where
     Schema.object "NewUserScimInvitation" $
       NewUserScimInvitation
         <$> newUserScimInvTeamId Schema..= Schema.field "team_id" Schema.schema
+        <*> newUserScimInvUserId Schema..= Schema.field "user_id" Schema.schema
         <*> newUserScimInvLocale Schema..= maybe_ (optField "locale" Schema.schema)
         <*> newUserScimInvName Schema..= Schema.field "name" Schema.schema
         <*> newUserScimInvEmail Schema..= Schema.field "email" Schema.schema

libs/wire-api/src/Wire/API/User/Scim.hs

@@ -42,7 +42,7 @@
 -- * Request and response types for SCIM-related endpoints.
 module Wire.API.User.Scim where
 
-import Control.Lens (Prism', makeLenses, mapped, prism', (.~), (?~))
+import Control.Lens (Prism', makeLenses, mapped, prism', (.~), (?~), (^.))
 import Control.Monad.Except (throwError)
 import Crypto.Hash (hash)
 import Crypto.Hash.Algorithms (SHA512)
@@ -83,7 +83,8 @@ import Web.Scim.Schema.Schema qualified as Scim
 import Web.Scim.Schema.User qualified as Scim
 import Web.Scim.Schema.User qualified as Scim.User
 import Wire.API.Team.Role (Role)
-import Wire.API.User.Identity (Email)
+import Wire.API.User (emailFromSAMLNameID, urefToExternalIdUnsafe)
+import Wire.API.User.Identity (Email, fromEmail)
 import Wire.API.User.Profile as BT
 import Wire.API.User.RichInfo qualified as RI
 import Wire.API.User.Saml ()
@@ -338,6 +339,15 @@ data ValidExternalId
   | EmailOnly Email
   deriving (Eq, Show, Generic)
 
+instance Arbitrary ValidExternalId where
+  arbitrary = do
+    muref <- QC.arbitrary
+    case muref of
+      Just uref -> case emailFromSAMLNameID $ uref ^. SAML.uidSubject of
+        Just e -> pure $ EmailAndUref e uref
+        Nothing -> pure $ UrefOnly uref
+      Nothing -> EmailOnly <$> QC.arbitrary
+
 -- | Take apart a 'ValidExternalId', using 'SAML.UserRef' if available, otherwise 'Email'.
 runValidExternalIdEither :: (SAML.UserRef -> a) -> (Email -> a) -> ValidExternalId -> a
 runValidExternalIdEither doUref doEmail = \case
@@ -353,6 +363,11 @@ runValidExternalIdBoth merge doUref doEmail = \case
   UrefOnly uref -> doUref uref
   EmailOnly em -> doEmail em
 
+-- | Returns either the extracted `UnqualifiedNameID` if present and not qualified, or the email address.
+-- This throws an exception if there are any qualifiers.
+runValidExternalIdUnsafe :: ValidExternalId -> Text
+runValidExternalIdUnsafe = runValidExternalIdEither urefToExternalIdUnsafe fromEmail
+
 veidUref :: Prism' ValidExternalId SAML.UserRef
 veidUref = prism' UrefOnly $
   \case

services/brig/src/Brig/API/User.hs

@@ -557,10 +557,9 @@ createUserInviteViaScim ::
     Member (UserPendingActivationStore p) r,
     Member TinyLog r
   ) =>
-  UserId ->
   NewUserScimInvitation ->
   ExceptT Error.Error (AppT r) UserAccount
-createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail _) = do
+createUserInviteViaScim (NewUserScimInvitation tid uid loc name rawEmail _) = do
   email <- either (const . throwE . Error.StdError $ errorToWai @'E.InvalidEmail) pure (validateEmail rawEmail)
   let emKey = userEmailKey email
   verifyUniquenessAndCheckBlacklist emKey !>> identityErrorToBrigError

services/brig/src/Brig/Team/API.hs

@@ -161,7 +161,7 @@ createInvitationPublic uid tid body = do
   fst
     <$> logInvitationRequest
       context
-      (createInvitation' tid inviteeRole (Just (inviterUid inviter)) (inviterEmail inviter) body)
+      (createInvitation' tid Nothing inviteeRole (Just (inviterUid inviter)) (inviterEmail inviter) body)
 
 createInvitationViaScim ::
   ( Member BlacklistStore r,
@@ -172,7 +172,7 @@ createInvitationViaScim ::
   TeamId ->
   NewUserScimInvitation ->
   (Handler r) UserAccount
-createInvitationViaScim tid newUser@(NewUserScimInvitation _tid loc name email role) = do
+createInvitationViaScim tid newUser@(NewUserScimInvitation _tid uid loc name email role) = do
   env <- ask
   let inviteeRole = role
       fromEmail = env ^. emailSender
@@ -190,12 +190,11 @@ createInvitationViaScim tid newUser@(NewUserScimInvitation _tid loc name email r
           . logTeam tid
           . logEmail email
 
-  (inv, _) <-
+  void $
     logInvitationRequest context $
-      createInvitation' tid inviteeRole Nothing fromEmail invreq
-  let uid = Id (toUUID (inInvitation inv))
+      createInvitation' tid (Just uid) inviteeRole Nothing fromEmail invreq
 
-  createUserInviteViaScim uid newUser
+  createUserInviteViaScim newUser
 
 logInvitationRequest :: (Msg -> Msg) -> (Handler r) (Invitation, InvitationCode) -> (Handler r) (Invitation, InvitationCode)
 logInvitationRequest context action =
@@ -214,12 +213,13 @@ createInvitation' ::
     Member GalleyProvider r
   ) =>
   TeamId ->
+  Maybe UserId ->
   Public.Role ->
   Maybe UserId ->
   Email ->
   Public.InvitationRequest ->
   Handler r (Public.Invitation, Public.InvitationCode)
-createInvitation' tid inviteeRole mbInviterUid fromEmail body = do
+createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do
   -- FUTUREWORK: These validations are nearly copy+paste from accountCreation and
   --             sendActivationCode. Refactor this to a single place
 
@@ -254,7 +254,7 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do
   showInvitationUrl <- lift $ liftSem $ GalleyProvider.getExposeInvitationURLsToTeamAdmin tid
 
   lift $ do
-    iid <- liftIO DB.mkInvitationId
+    iid <- maybe (liftIO DB.mkInvitationId) (pure . Id . toUUID) mUid
     now <- liftIO =<< view currentTime
     timeout <- setTeamInvitationTimeout <$> view settings
     (newInv, code) <-

services/spar/spar.cabal

@@ -39,6 +39,7 @@ library
     Spar.Schema.V15
     Spar.Schema.V16
     Spar.Schema.V17
+    Spar.Schema.V18
     Spar.Schema.V2
     Spar.Schema.V3
     Spar.Schema.V4

services/spar/src/Spar/Data/Instances.hs

@@ -37,6 +37,7 @@ import Data.X509 (SignedCertificate)
 import Imports
 import SAML2.Util (parseURI')
 import qualified SAML2.WebSSO as SAML
+import Spar.Scim.Types (ScimUserCreationStatus (..))
 import Text.XML.DSig (parseKeyInfo, renderKeyInfo)
 import URI.ByteString
 import Wire.API.User.Saml
@@ -117,3 +118,15 @@ instance Cql ScimTokenLookupKey where
   fromCql s@(CqlText _) =
     ScimTokenLookupKeyHashed <$> fromCql s <|> ScimTokenLookupKeyPlaintext <$> fromCql s
   fromCql _ = Left "ScimTokenLookupKey: expected CqlText"
+
+instance Cql ScimUserCreationStatus where
+  ctype = Tagged IntColumn
+
+  toCql ScimUserCreated = CqlInt 0
+  toCql ScimUserCreating = CqlInt 1
+
+  fromCql (CqlInt i) = case i of
+    0 -> pure ScimUserCreated
+    1 -> pure ScimUserCreating
+    n -> Left $ "unexpected ScimUserCreationStatus: " ++ show n
+  fromCql _ = Left "int expected"

services/spar/src/Spar/Intra/Brig.hs

@@ -130,14 +130,15 @@ createBrigUserSAML uref (Id buid) teamid name managedBy handle richInfo mLocale
 createBrigUserNoSAML ::
   (HasCallStack, MonadSparToBrig m) =>
   Email ->
+  UserId ->
   TeamId ->
   -- | User name
   Name ->
   Maybe Locale ->
   Role ->
   m UserId
-createBrigUserNoSAML email teamid uname locale role = do
-  let newUser = NewUserScimInvitation teamid locale uname email role
+createBrigUserNoSAML email uid teamid uname locale role = do
+  let newUser = NewUserScimInvitation teamid uid locale uname email role
   resp :: ResponseLBS <-
     call $
       method POST

services/spar/src/Spar/Schema/Run.hs

@@ -31,6 +31,7 @@ import qualified Spar.Schema.V14 as V14
 import qualified Spar.Schema.V15 as V15
 import qualified Spar.Schema.V16 as V16
 import qualified Spar.Schema.V17 as V17
+import qualified Spar.Schema.V18 as V18
 import qualified Spar.Schema.V2 as V2
 import qualified Spar.Schema.V3 as V3
 import qualified Spar.Schema.V4 as V4
@@ -76,7 +77,8 @@ migrations =
     V14.migration,
     V15.migration,
     V16.migration,
-    V17.migration
+    V17.migration,
+    V18.migration
     -- TODO: Add a migration that removes unused fields
     -- (we don't want to risk running a migration which would
     -- effectively break the currently deployed spar service)

services/spar/src/Spar/Schema/V18.hs

@@ -0,0 +1,33 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.
+
+module Spar.Schema.V18
+  ( migration,
+  )
+where
+
+import Cassandra.Schema
+import Imports
+import Text.RawString.QQ
+
+migration :: Migration
+migration = Migration 18 "A status field to manage user creation" $ do
+  void $
+    schema'
+      [r|
+        ALTER TABLE scim_external ADD creation_status int;
+      |]

services/spar/src/Spar/Scim/Types.hs

@@ -30,8 +30,10 @@
 -- * Request and response types for SCIM-related endpoints.
 module Spar.Scim.Types where
 
+import Brig.Types.Test.Arbitrary (Arbitrary (..))
 import Control.Lens (view)
 import Imports
+import Test.QuickCheck.Gen (elements)
 import qualified Web.Scim.Schema.Common as Scim
 import qualified Web.Scim.Schema.User as Scim.User
 import Wire.API.User (AccountStatus (..))
@@ -87,3 +89,9 @@ normalizeLikeStored usr =
 
     tweakActive :: Maybe Scim.ScimBool -> Maybe Scim.ScimBool
     tweakActive = Just . Scim.ScimBool . maybe True Scim.unScimBool
+
+data ScimUserCreationStatus = ScimUserCreating | ScimUserCreated
+  deriving (Eq, Show, Generic)
+
+instance Arbitrary ScimUserCreationStatus where
+  arbitrary = elements [ScimUserCreating, ScimUserCreated]