SQSERVICES 1099 Public API end-point for re-sending email validation

libs/galley-types/src/Galley/Types/Teams.hs

@@ -340,6 +340,7 @@ data HiddenPerm
     -- efficient this end-point is.  better not let all team members
     -- play with it unless we have to.
     DownloadTeamMembersCsv
+  | ChangeTeamMemberProfiles
   deriving (Eq, Ord, Show)
 
 -- | See Note [hidden team roles]
@@ -367,6 +368,7 @@ roleHiddenPermissions role = HiddenPermissions p p
             ChangeTeamFeature TeamFeatureFileSharing,
             ChangeTeamFeature TeamFeatureClassifiedDomains {- the features not listed here can only be changed in stern -},
             ChangeTeamFeature TeamFeatureSelfDeletingMessages,
+            ChangeTeamMemberProfiles,
             ReadIdp,
             CreateUpdateDeleteIdp,
             CreateReadDeleteScimToken,

libs/wire-api/src/Wire/API/Routes/Public/Brig.hs

@@ -135,6 +135,16 @@ data Api routes = Api
         :> "self"
         :> ReqBody '[JSON] DeleteUser
         :> MultiVerb 'DELETE '[JSON] DeleteSelfResponses (Maybe Timeout),
+    updateUserEmail ::
+      routes
+        :- Summary "Resend email address validation email."
+        :> Description "If the user has a pending email validation, the validation email will be resent."
+        :> ZUser
+        :> "users"
+        :> CaptureUserId "uid"
+        :> "email"
+        :> ReqBody '[JSON] EmailUpdate
+        :> Put '[JSON] (),
     getHandleInfoUnqualified ::
       routes
         :- Summary "(deprecated, use /search/contacts) Get information on a user handle"

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

@@ -905,6 +905,13 @@ instance FromJSON LocaleUpdate where
 newtype EmailUpdate = EmailUpdate {euEmail :: Email}
   deriving stock (Eq, Show, Generic)
   deriving newtype (Arbitrary)
+  deriving (S.ToSchema) via (Schema EmailUpdate)
+
+instance ToSchema EmailUpdate where
+  schema =
+    object "EmailUpdate" $
+      EmailUpdate
+        <$> euEmail .= field "email" schema
 
 modelEmailUpdate :: Doc.Model
 modelEmailUpdate = Doc.defineModel "EmailUpdate" $ do

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

@@ -354,6 +354,9 @@ newPasswordMustDiffer = Wai.mkError status409 "password-must-differ" "For provid
 notFound :: LText -> Wai.Error
 notFound = Wai.mkError status404 "not-found"
 
+conflict :: LText -> Wai.Error
+conflict = Wai.mkError status409 "conflict"
+
 invalidAccountStatus :: Wai.Error
 invalidAccountStatus = Wai.mkError status400 "invalid-status" "The specified account status cannot be set."
 

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

@@ -40,6 +40,7 @@ import Brig.App
 import qualified Brig.Calling.API as Calling
 import qualified Brig.Data.Connection as Data
 import qualified Brig.Data.User as Data
+import qualified Brig.IO.Intra as Intra
 import Brig.Options hiding (internalEvents, sesQueue)
 import qualified Brig.Provider.API as Provider
 import qualified Brig.Team.API as Team
@@ -80,6 +81,7 @@ import qualified Data.Text.Ascii as Ascii
 import Data.Text.Encoding (decodeLatin1)
 import Data.Text.Lazy (pack)
 import qualified Data.ZAuth.Token as ZAuth
+import Galley.Types.Teams (HiddenPerm (..), hasPermission)
 import Imports hiding (head)
 import Network.HTTP.Types.Status
 import Network.Wai (Response, lazyRequestBody)
@@ -251,6 +253,7 @@ servantSitemap =
         BrigAPI.getUserQualified = getUser,
         BrigAPI.getSelf = getSelf,
         BrigAPI.deleteSelf = deleteUser,
+        BrigAPI.updateUserEmail = updateUserEmail,
         BrigAPI.getHandleInfoUnqualified = getHandleInfoUnqualifiedH,
         BrigAPI.getUserByHandleQualified = Handle.getHandleInfo,
         BrigAPI.listUsersByUnqualifiedIdsOrHandles = listUsersByUnqualifiedIdsOrHandles,
@@ -1193,6 +1196,25 @@ verifyDeleteUserH (r ::: _) = do
   API.verifyDeleteUser body !>> deleteUserError
   return (setStatus status200 empty)
 
+updateUserEmail :: UserId -> UserId -> Public.EmailUpdate -> Handler ()
+updateUserEmail zuserId emailOwnerId (Public.EmailUpdate email) = do
+  maybeZuserTeamId <- lift $ Data.lookupUserTeam zuserId
+  whenM (not . fromMaybe False <$> runMaybeT (checkPerm maybeZuserTeamId)) $ throwStd insufficientTeamPermissions
+  maybeEmailOwnerTeamId <- lift $ Data.lookupUserTeam emailOwnerId
+  checkSameTeam maybeZuserTeamId maybeEmailOwnerTeamId
+  void $ API.changeSelfEmail emailOwnerId email API.AllowSCIMUpdates
+  where
+    checkSameTeam :: Maybe TeamId -> Maybe TeamId -> Handler ()
+    checkSameTeam (Just zuserTeamId) maybeEmailOwnerTeamId =
+      when (Just zuserTeamId /= maybeEmailOwnerTeamId) $ throwStd $ notFound "user not found"
+    checkSameTeam Nothing _ = throwStd insufficientTeamPermissions
+
+    checkPerm :: Maybe TeamId -> MaybeT Handler Bool
+    checkPerm maybeTeamId = do
+      teamId <- hoistMaybe maybeTeamId
+      teamMember <- MaybeT $ lift $ Intra.getTeamMember zuserId teamId
+      pure $ teamMember `hasPermission` ChangeTeamMemberProfiles
+
 -- activation
 
 data ActivationRespWithStatus

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

@@ -1232,9 +1232,8 @@ getEmailForProfile profileOwner EmailVisibleIfOnTeam' =
     then userEmail profileOwner
     else Nothing
 getEmailForProfile profileOwner (EmailVisibleIfOnSameTeam' (Just (viewerTeamId, viewerTeamMember))) =
-  if ( Just viewerTeamId == userTeam profileOwner
-         && Team.hasPermission viewerTeamMember Team.ViewSameTeamEmails
-     )
+  if Just viewerTeamId == userTeam profileOwner
+    && Team.hasPermission viewerTeamMember Team.ViewSameTeamEmails
     then userEmail profileOwner
     else Nothing
 getEmailForProfile _ (EmailVisibleIfOnSameTeam' Nothing) = Nothing

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

@@ -404,7 +404,7 @@ lookupRichInfoMultiUsers users = do
 -- successful login.
 lookupUserTeam :: UserId -> AppIO (Maybe TeamId)
 lookupUserTeam u =
-  join . fmap runIdentity
+  (runIdentity =<<)
     <$> retry x1 (query1 teamSelect (params LocalQuorum (Identity u)))
 
 lookupAuth :: (MonadClient m) => UserId -> m (Maybe (Maybe Password, AccountStatus))
@@ -471,7 +471,7 @@ lookupFeatureConferenceCalling uid = do
   pure $ ApiFt.TeamFeatureStatusNoConfig <$> mStatusValue
   where
     select :: PrepQuery R (Identity UserId) (Identity (Maybe ApiFt.TeamFeatureStatusValue))
-    select = fromString $ "select feature_conference_calling from user where id = ?"
+    select = fromString "select feature_conference_calling from user where id = ?"
 
 -------------------------------------------------------------------------------
 -- Queries

services/brig/test/integration/API/Team/Util.hs

@@ -476,3 +476,19 @@ setTeamSearchVisibility galley tid typ =
     )
     !!! do
       const 204 === statusCode
+
+setUserEmail :: Brig -> UserId -> UserId -> Email -> Http ResponseLBS
+setUserEmail brig from uid email = do
+  put
+    ( brig
+        . paths ["users", toByteString' uid, "email"]
+        . zUser from
+        . zConn "conn"
+        . contentJson
+        . body
+          ( RequestBodyLBS . encode $
+              object
+                [ "email" .= show email
+                ]
+          )
+    )

services/brig/test/integration/API/User/Account.hs

@@ -141,9 +141,59 @@ tests _ at opts p b c ch g aws =
       testGroup
         "temporary customer extensions"
         [ test' aws p "domains blocked for registration" $ testDomainsBlockedForRegistration opts b
+        ],
+      testGroup
+        "re-send activation email"
+        [ test' aws p "put /users/:uid/email" $ testReSendActivationEmail b
         ]
     ]
 
+testReSendActivationEmail :: Brig -> Http ()
+testReSendActivationEmail brig = do
+  (_, teamOwner, emailOwner : otherTeamMember : _) <- createPopulatedBindingTeamWithNamesAndHandles brig 2
+  (teamOwnerDifferentTeam, _) <- createUserWithTeam' brig
+  newEmail <- randomEmail
+  initiateEmailUpdateNoSend brig newEmail (userId emailOwner) !!! (const 202 === statusCode)
+  checkActivationCode newEmail True
+  checkLetActivationExpire newEmail
+  checkSetUserEmail teamOwner emailOwner newEmail 200
+  checkActivationCode newEmail True
+  checkLetActivationExpire newEmail
+  checkUnauthorizedRequests emailOwner otherTeamMember teamOwnerDifferentTeam newEmail
+  checkActivationCode newEmail False
+  checkSetUserEmail teamOwner emailOwner newEmail 200
+  checkActivationCode newEmail True
+  activateEmail brig newEmail
+  -- apparently activating an email does not invalidate the activation code
+  checkLetActivationExpire newEmail
+  checkActivationCode newEmail False
+  checkSetUserEmail teamOwner emailOwner newEmail 200
+  checkActivationCode newEmail False
+  checkUnauthorizedRequests emailOwner otherTeamMember teamOwnerDifferentTeam newEmail
+  checkActivationCode newEmail False
+  where
+    checkLetActivationExpire :: Email -> Http ()
+    checkLetActivationExpire email = do
+      -- assumption: email activation timeout is set to 5 sec, so we wait until it expires
+      threadDelay (5100 * 1000)
+      checkActivationCode email False
+
+    checkActivationCode :: Email -> Bool -> Http ()
+    checkActivationCode email shouldExist = do
+      maybeActivationCode <- Util.getActivationCode brig (Left email)
+      if shouldExist
+        then void $ lift $ assertBool "activation code should exists" (isJust maybeActivationCode)
+        else void $ lift $ assertBool "activation code should not exists" (isNothing maybeActivationCode)
+
+    checkSetUserEmail :: User -> User -> Email -> Int -> Http ()
+    checkSetUserEmail teamOwner emailOwner email expectedStatusCode =
+      setUserEmail brig (userId teamOwner) (userId emailOwner) email !!! (const expectedStatusCode === statusCode)
+
+    checkUnauthorizedRequests :: User -> User -> User -> Email -> Http ()
+    checkUnauthorizedRequests emailOwner otherTeamMember teamOwnerDifferentTeam email = do
+      setUserEmail brig (userId teamOwnerDifferentTeam) (userId emailOwner) email !!! (const 404 === statusCode)
+      setUserEmail brig (userId otherTeamMember) (userId emailOwner) email !!! (const 403 === statusCode)
+
 testCreateUserWithPreverified :: Opt.Opts -> Brig -> AWS.Env -> Http ()
 testCreateUserWithPreverified opts brig aws = do
   -- Register (pre verified) user with phone