diff --git a/Makefile b/Makefile index de21e381a80..bf97abef597 100644 --- a/Makefile +++ b/Makefile @@ -163,7 +163,7 @@ lint-all: formatc hlint-check-all lint-common # The extra 'hlint-check-pr' has been witnessed to be necessary due to # some bu in `hlint-inplace-pr`. Details got lost in history. .PHONY: lint-all-shallow -lint-all-shallow: formatf hlint-inplace-pr hlint-check-pr lint-common +lint-all-shallow: lint-common formatf hlint-inplace-pr hlint-check-pr .PHONY: lint-common lint-common: check-local-nix-derivations treefmt-check # weeder (does not work on CI yet) diff --git a/changelog.d/5-internal/wpb-8887 b/changelog.d/5-internal/wpb-8887 new file mode 100644 index 00000000000..087d81745a8 --- /dev/null +++ b/changelog.d/5-internal/wpb-8887 @@ -0,0 +1 @@ +New user subsystem operation `getAccountsBy` for complex account lookups. diff --git a/integration/test/Test/Spar.hs b/integration/test/Test/Spar.hs index 12f67d1200e..7c9d2b8bd77 100644 --- a/integration/test/Test/Spar.hs +++ b/integration/test/Test/Spar.hs @@ -29,8 +29,8 @@ testSparUserCreationInvitationTimeout = 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) + -- It's currently configured to 1s local/CI. + liftIO $ threadDelay (2_000_000) -- ...we should be able to create the user again retryT $ bindResponse (createScimUser OwnDomain tok scimUser) $ \res -> do diff --git a/libs/brig-types/src/Brig/Types/User.hs b/libs/brig-types/src/Brig/Types/User.hs index f3cc87ba048..75dfe18f59a 100644 --- a/libs/brig-types/src/Brig/Types/User.hs +++ b/libs/brig-types/src/Brig/Types/User.hs @@ -19,7 +19,6 @@ module Brig.Types.User ( ManagedByUpdate (..), RichInfoUpdate (..), PasswordResetPair, - HavePendingInvitations (..), ) where diff --git a/libs/cassandra-util/cassandra-util.cabal b/libs/cassandra-util/cassandra-util.cabal index af2e0094209..927498c24f5 100644 --- a/libs/cassandra-util/cassandra-util.cabal +++ b/libs/cassandra-util/cassandra-util.cabal @@ -18,6 +18,7 @@ library Cassandra.Helpers Cassandra.MigrateSchema Cassandra.Options + Cassandra.QQ Cassandra.Schema Cassandra.Settings Cassandra.Util @@ -87,6 +88,7 @@ library , optparse-applicative >=0.10 , retry , split >=0.2 + , template-haskell , text >=0.11 , time >=1.4 , tinylog >=0.7 diff --git a/libs/cassandra-util/default.nix b/libs/cassandra-util/default.nix index c7b1451a36e..e02d098a9b7 100644 --- a/libs/cassandra-util/default.nix +++ b/libs/cassandra-util/default.nix @@ -19,6 +19,7 @@ , optparse-applicative , retry , split +, template-haskell , text , time , tinylog @@ -44,6 +45,7 @@ mkDerivation { optparse-applicative retry split + template-haskell text time tinylog diff --git a/libs/cassandra-util/src/Cassandra.hs b/libs/cassandra-util/src/Cassandra.hs index 6774abbeb56..74dcdfc45f4 100644 --- a/libs/cassandra-util/src/Cassandra.hs +++ b/libs/cassandra-util/src/Cassandra.hs @@ -91,3 +91,4 @@ import Cassandra.Exec as C x1, x5, ) +import Cassandra.QQ as C (sql) diff --git a/libs/cassandra-util/src/Cassandra/QQ.hs b/libs/cassandra-util/src/Cassandra/QQ.hs new file mode 100644 index 00000000000..c15df3f3dca --- /dev/null +++ b/libs/cassandra-util/src/Cassandra/QQ.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Cassandra.QQ (sql) where + +import Imports +import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter (..)) + +-- | a simple quasi quoter to allow for tree-sitter syntax highlight injection. +-- This uses the name sql because that is known to tree-sitter, unlike cql +sql :: QuasiQuoter +sql = + QuasiQuoter + { quotePat = error "Cassandra.QQ: sql quasiquoter cannot be used as pattern", + quoteType = error "Cassandra.QQ: sql quasiquoter cannot be used as type", + quoteDec = error "Cassandra.QQ: sql quasiquoter cannot be used as declaration", + quoteExp = appE [|fromString|] . stringE + } diff --git a/libs/imports/src/Imports.hs b/libs/imports/src/Imports.hs index e2ddf387e25..aee8b7c0e9c 100644 --- a/libs/imports/src/Imports.hs +++ b/libs/imports/src/Imports.hs @@ -111,7 +111,6 @@ module Imports -- * Extra Helpers whenM, unlessM, - catMaybesToList, -- * Functor (<$$>), @@ -385,6 +384,3 @@ infix 4 <$$> (<$$$>) = fmap . fmap . fmap infix 4 <$$$> - -catMaybesToList :: Maybe (Maybe a) -> [a] -catMaybesToList = catMaybes . maybeToList diff --git a/libs/types-common/default.nix b/libs/types-common/default.nix index 7421aae499c..c4bbd61c01b 100644 --- a/libs/types-common/default.nix +++ b/libs/types-common/default.nix @@ -40,6 +40,7 @@ , quickcheck-instances , random , schema-profunctor +, scientific , servant-server , string-conversions , tagged @@ -96,6 +97,7 @@ mkDerivation { quickcheck-instances random schema-profunctor + scientific servant-server tagged tasty diff --git a/libs/types-common/src/Data/HavePendingInvitations.hs b/libs/types-common/src/Data/HavePendingInvitations.hs new file mode 100644 index 00000000000..03afbe6c77c --- /dev/null +++ b/libs/types-common/src/Data/HavePendingInvitations.hs @@ -0,0 +1,14 @@ +module Data.HavePendingInvitations where + +import Imports +import Wire.Arbitrary + +data HavePendingInvitations + = WithPendingInvitations + | NoPendingInvitations + deriving (Eq, Show, Ord, Generic) + deriving (Arbitrary) via GenericUniform HavePendingInvitations + +fromBool :: Bool -> HavePendingInvitations +fromBool True = WithPendingInvitations +fromBool False = NoPendingInvitations diff --git a/libs/types-common/src/Data/Qualified.hs b/libs/types-common/src/Data/Qualified.hs index d6367a1f851..8b06c4ea58f 100644 --- a/libs/types-common/src/Data/Qualified.hs +++ b/libs/types-common/src/Data/Qualified.hs @@ -28,6 +28,7 @@ module Data.Qualified tUnqualified, tDomain, tUntagged, + tSplit, qTagUnsafe, Remote, toRemoteUnsafe, @@ -92,6 +93,10 @@ tUnqualified = qUnqualified . tUntagged tDomain :: QualifiedWithTag t a -> Domain tDomain = qDomain . tUntagged +-- | perform 'qUnqualified' and 'tDomain' at once. Useful in ViewPatterns. +tSplit :: QualifiedWithTag t a -> (Domain, a) +tSplit (tUntagged -> q) = (q.qDomain, q.qUnqualified) + -- | A type representing a 'Qualified' value where the domain is guaranteed to -- be remote. type Remote = QualifiedWithTag 'QRemote diff --git a/libs/types-common/src/Util/Timeout.hs b/libs/types-common/src/Util/Timeout.hs new file mode 100644 index 00000000000..e09c358e88d --- /dev/null +++ b/libs/types-common/src/Util/Timeout.hs @@ -0,0 +1,32 @@ +module Util.Timeout + ( Timeout (..), + module Data.Time.Clock, + ) +where + +import Data.Aeson +import Data.Aeson.Types +import Data.Scientific +import Data.Time.Clock +import Imports + +newtype Timeout = Timeout + { timeoutDiff :: NominalDiffTime + } + deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show) + +instance Read Timeout where + readsPrec i s = + case readsPrec i s of + [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] + _ -> [] + +instance FromJSON Timeout where + parseJSON (Number n) = + let defaultV = 3600 + bounded = toBoundedInteger n :: Maybe Int64 + in pure $ + Timeout $ + fromIntegral @Int $ + maybe defaultV fromIntegral bounded + parseJSON v = typeMismatch "activationTimeout" v diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal index 5fb1c0ca72c..175d3964cdc 100644 --- a/libs/types-common/types-common.cabal +++ b/libs/types-common/types-common.cabal @@ -19,6 +19,7 @@ library Data.Domain Data.ETag Data.Handle + Data.HavePendingInvitations Data.Id Data.Json.Util Data.LegalHold @@ -38,6 +39,7 @@ library Util.Options Util.Options.Common Util.Test + Util.Timeout Wire.Arbitrary other-modules: Paths_types_common @@ -125,6 +127,7 @@ library , quickcheck-instances >=0.3.16 , random >=1.1 , schema-profunctor + , scientific , servant-server , tagged >=0.8 , tasty >=0.11 diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs index 70d478643a0..78d4ddcbf0a 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig/OAuth.hs @@ -39,7 +39,7 @@ type OAuthAPI = :> Post '[JSON] OAuthClientCredentials ) :<|> Named - "get-oauth-client" + "i-get-oauth-client" ( Summary "Get OAuth client by id" :> CanThrow 'OAuthFeatureDisabled :> CanThrow 'OAuthClientNotFound diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs index fb4ab2cc9e5..22f23d50a31 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Galley.hs @@ -566,7 +566,7 @@ type IMiscAPI = (RespondEmpty 200 "OK") ) :<|> Named - "add-bot" + "i-add-bot" ( -- This endpoint can lead to the following events being sent: -- - MemberJoin event to members CanThrow ('ActionDenied 'AddConversationMember) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 29f05a6b708..72afa66ff3b 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -268,7 +268,7 @@ type UserAPI = "get-rich-info" ( Summary "Get a user's rich info" :> CanThrow 'InsufficientTeamPermissions - :> ZUser + :> ZLocalUser :> "users" :> CaptureUserId "uid" :> "rich-info" @@ -322,7 +322,7 @@ type SelfAPI = :> CanThrow 'MissingAuth :> CanThrow 'DeleteCodePending :> CanThrow 'OwnerDeletingSelf - :> ZUser + :> ZLocalUser :> "self" :> ReqBody '[JSON] DeleteUser :> MultiVerb 'DELETE '[JSON] DeleteSelfResponses (Maybe Timeout) @@ -743,7 +743,7 @@ type UserClientAPI = :> CanThrow 'MalformedPrekeys :> CanThrow 'CodeAuthenticationFailed :> CanThrow 'CodeAuthenticationRequired - :> ZUser + :> ZLocalUser :> ZConn :> "clients" :> ReqBody '[JSON] NewClient @@ -766,7 +766,7 @@ type UserClientAPI = :> CanThrow 'MalformedPrekeys :> CanThrow 'CodeAuthenticationFailed :> CanThrow 'CodeAuthenticationRequired - :> ZUser + :> ZLocalUser :> ZConn :> "clients" :> ReqBody '[JSON] NewClient diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs index 2db4a8320ec..19d20cd30f6 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig/OAuth.hs @@ -39,7 +39,7 @@ type OAuthAPI = ( Summary "Get OAuth client information" :> CanThrow 'OAuthFeatureDisabled :> CanThrow 'OAuthClientNotFound - :> ZUser + :> ZLocalUser :> "oauth" :> "clients" :> Capture' '[Description "The ID of the OAuth client"] "OAuthClientId" OAuthClientId @@ -55,7 +55,7 @@ type OAuthAPI = "create-oauth-auth-code" ( Summary "Create an OAuth authorization code" :> Description "Currently only supports the 'code' response type, which corresponds to the authorization code flow." - :> ZUser + :> ZLocalUser :> "oauth" :> "authorization" :> "codes" @@ -99,7 +99,7 @@ type OAuthAPI = "get-oauth-applications" ( Summary "Get OAuth applications with account access" :> Description "Get all OAuth applications with active account access for a user." - :> ZUser + :> ZLocalUser :> "oauth" :> "applications" :> MultiVerb1 @@ -110,7 +110,7 @@ type OAuthAPI = :<|> Named "revoke-oauth-account-access-v6" ( Summary "Revoke account access from an OAuth application" - :> ZUser + :> ZLocalUser :> Until 'V7 :> "oauth" :> "applications" @@ -125,7 +125,7 @@ type OAuthAPI = "revoke-oauth-account-access" ( Summary "Revoke account access from an OAuth application" :> CanThrow 'AccessDenied - :> ZUser + :> ZLocalUser :> From 'V7 :> "oauth" :> "applications" @@ -142,7 +142,7 @@ type OAuthAPI = "delete-oauth-refresh-token" ( Summary "Revoke an active OAuth session" :> Description "Revoke an active OAuth session by providing the refresh token ID." - :> ZUser + :> ZLocalUser :> CanThrow 'AccessDenied :> CanThrow 'OAuthClientNotFound :> "oauth" diff --git a/libs/wire-api/src/Wire/API/Team/Invitation.hs b/libs/wire-api/src/Wire/API/Team/Invitation.hs index b5c0d1a8096..967adad2832 100644 --- a/libs/wire-api/src/Wire/API/Team/Invitation.hs +++ b/libs/wire-api/src/Wire/API/Team/Invitation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE StrictData #-} -- This file is part of the Wire Server implementation. @@ -67,27 +68,27 @@ instance ToSchema InvitationRequest where InvitationRequest <$> locale .= optFieldWithDocModifier "locale" (description ?~ "Locale to use for the invitation.") (maybeWithDefault A.Null schema) - <*> role + <*> (.role) .= optFieldWithDocModifier "role" (description ?~ "Role of the invitee (invited user).") (maybeWithDefault A.Null schema) - <*> inviteeName + <*> (.inviteeName) .= optFieldWithDocModifier "name" (description ?~ "Name of the invitee (1 - 128 characters).") (maybeWithDefault A.Null schema) - <*> inviteeEmail + <*> (.inviteeEmail) .= fieldWithDocModifier "email" (description ?~ "Email of the invitee.") schema -------------------------------------------------------------------------------- -- Invitation data Invitation = Invitation - { inTeam :: TeamId, - inRole :: Role, - inInvitation :: InvitationId, - inCreatedAt :: UTCTimeMillis, + { team :: TeamId, + role :: Role, + invitationId :: InvitationId, + createdAt :: UTCTimeMillis, -- | this is always 'Just' for new invitations, but for -- migration it is allowed to be 'Nothing'. - inCreatedBy :: Maybe UserId, - inInviteeEmail :: EmailAddress, - inInviteeName :: Maybe Name, - inInviteeUrl :: Maybe (URIRef Absolute) + createdBy :: Maybe UserId, + inviteeEmail :: EmailAddress, + inviteeName :: Maybe Name, + inviteeUrl :: Maybe (URIRef Absolute) } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform Invitation) @@ -99,22 +100,22 @@ instance ToSchema Invitation where "Invitation" (description ?~ "An invitation to join a team on Wire") $ Invitation - <$> inTeam + <$> (.team) .= fieldWithDocModifier "team" (description ?~ "Team ID of the inviting team") schema - <*> inRole + <*> (.role) -- clients, when leaving "role" empty, can leave the default role choice to us .= (fromMaybe defaultRole <$> optFieldWithDocModifier "role" (description ?~ "Role of the invited user") schema) - <*> inInvitation + <*> (.invitationId) .= fieldWithDocModifier "id" (description ?~ "UUID used to refer the invitation") schema - <*> inCreatedAt + <*> (.createdAt) .= fieldWithDocModifier "created_at" (description ?~ "Timestamp of invitation creation") schema - <*> inCreatedBy + <*> (.createdBy) .= optFieldWithDocModifier "created_by" (description ?~ "ID of the inviting user") (maybeWithDefault A.Null schema) - <*> inInviteeEmail + <*> (.inviteeEmail) .= fieldWithDocModifier "email" (description ?~ "Email of the invitee") schema - <*> inInviteeName + <*> (.inviteeName) .= optFieldWithDocModifier "name" (description ?~ "Name of the invitee (1 - 128 characters)") (maybeWithDefault A.Null schema) - <*> (fmap (TE.decodeUtf8 . serializeURIRef') . inInviteeUrl) + <*> (fmap (TE.decodeUtf8 . serializeURIRef') . inviteeUrl) .= optFieldWithDocModifier "url" (description ?~ "URL of the invitation link to be sent to the invitee") (maybeWithDefault A.Null urlSchema) where urlSchema = parsedText "URIRef Absolute" (runParser (uriParser strictURIParserOptions) . TE.encodeUtf8) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 10d218f34c3..2ff0c3eb3e0 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -59,7 +59,6 @@ module Wire.API.User CreateUserSparInternalResponses, newUserFromSpar, urefToExternalId, - urefToEmail, ExpiresIn, newUserTeam, newUserEmail, @@ -121,7 +120,6 @@ module Wire.API.User GetPasswordResetCodeResp (..), CheckBlacklistResponse (..), ManagedByUpdate (..), - HavePendingInvitations (..), RichInfoUpdate (..), PasswordResetPair, UpdateSSOIdResponse (..), @@ -154,7 +152,7 @@ import Cassandra qualified as C import Control.Applicative import Control.Arrow ((&&&)) import Control.Error.Safe (rightMay) -import Control.Lens (makePrisms, over, view, (.~), (?~), (^.)) +import Control.Lens (makePrisms, over, view, (.~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..), withText) import Data.Aeson.Types qualified as A import Data.Attoparsec.ByteString qualified as Parser @@ -192,7 +190,6 @@ import GHC.TypeLits import Generics.SOP qualified as GSOP import Imports import SAML2.WebSSO qualified as SAML -import SAML2.WebSSO.Types.Email qualified as SAMLEmail import Servant (FromHttpApiData (..), ToHttpApiData (..), type (.++)) import Test.QuickCheck qualified as QC import URI.ByteString (serializeURIRef) @@ -308,11 +305,6 @@ instance ToSchema ManagedByUpdate where ManagedByUpdate <$> mbuManagedBy .= field "managed_by" schema -data HavePendingInvitations - = WithPendingInvitations - | NoPendingInvitations - deriving (Eq, Show, Generic) - newtype RichInfoUpdate = RichInfoUpdate {riuRichInfo :: RichInfoAssocList} deriving (Eq, Show, Generic) deriving newtype (Arbitrary) @@ -585,7 +577,7 @@ data User = User userManagedBy :: ManagedBy, userSupportedProtocols :: Set BaseProtocolTag } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform User) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema User) @@ -850,11 +842,6 @@ instance (res ~ RegisterInternalResponses) => AsUnion res (Either RegisterError urefToExternalId :: SAML.UserRef -> Maybe Text urefToExternalId = fmap CI.original . SAML.shortShowNameID . view SAML.uidSubject -urefToEmail :: SAML.UserRef -> Maybe EmailAddress -urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of - SAML.UNameIDEmail email -> emailAddressText . SAMLEmail.render . CI.original $ email - _ -> Nothing - data CreateUserSparError = CreateUserSparHandleError ChangeHandleError | CreateUserSparRegistrationError RegisterError @@ -1222,7 +1209,7 @@ maybeNewUserOriginFromComponents hasPassword hasSSO (invcode, teamcode, team, te -- | A random invitation code for use during registration newtype InvitationCode = InvitationCode {fromInvitationCode :: AsciiBase64Url} - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving newtype (ToSchema, ToByteString, FromByteString, Arbitrary) deriving (FromJSON, ToJSON, S.ToSchema) via Schema InvitationCode @@ -1787,7 +1774,7 @@ data UserAccount = UserAccount { accountUser :: !User, accountStatus :: !AccountStatus } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform UserAccount) deriving (ToJSON, FromJSON, S.ToSchema) via Schema.Schema UserAccount @@ -1806,7 +1793,7 @@ data ExtendedUserAccount = ExtendedUserAccount { account :: UserAccount, emailUnvalidated :: Maybe EmailAddress } - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform ExtendedUserAccount) deriving (ToJSON, FromJSON, S.ToSchema) via Schema.Schema ExtendedUserAccount diff --git a/libs/wire-api/src/Wire/API/User/EmailAddress.hs b/libs/wire-api/src/Wire/API/User/EmailAddress.hs index 7c5bc2dacc7..ffde490b59e 100644 --- a/libs/wire-api/src/Wire/API/User/EmailAddress.hs +++ b/libs/wire-api/src/Wire/API/User/EmailAddress.hs @@ -6,7 +6,6 @@ module Wire.API.User.EmailAddress emailAddressText, module Text.Email.Parser, emailToSAMLNameID, - emailFromSAMLNameID, emailFromSAML, ) where @@ -16,9 +15,7 @@ where ----- import Cassandra.CQL qualified as C -import Control.Lens ((^.)) import Data.ByteString.Conversion hiding (toByteString) -import Data.CaseInsensitive qualified as CI import Data.Data (Proxy (..)) import Data.OpenApi hiding (Schema, ToSchema) import Data.Schema @@ -116,11 +113,6 @@ arbitraryValidMail = do && notAt x && isValid (fromString ("me@" <> x)) -emailFromSAMLNameID :: SAML.NameID -> Maybe EmailAddress -emailFromSAMLNameID nid = case nid ^. SAML.nameID of - SAML.UNameIDEmail eml -> Just . emailFromSAML . CI.original $ eml - _ -> Nothing - -- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this -- function total without all that praying and hoping. emailToSAMLNameID :: EmailAddress -> Either String SAML.NameID diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index a551ea825e2..65b6a5ede61 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -83,7 +83,7 @@ import Wire.Arbitrary (Arbitrary, GenericUniform (..)) data UserIdentity = EmailIdentity EmailAddress | SSOIdentity UserSSOId (Maybe EmailAddress) - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Ord, Show, Generic) deriving (Arbitrary) via (GenericUniform UserIdentity) isSSOIdentity :: UserIdentity -> Bool diff --git a/libs/wire-api/src/Wire/API/User/Scim.hs b/libs/wire-api/src/Wire/API/User/Scim.hs index 21b82fb61ee..dd7f4ad8993 100644 --- a/libs/wire-api/src/Wire/API/User/Scim.hs +++ b/libs/wire-api/src/Wire/API/User/Scim.hs @@ -380,17 +380,9 @@ arbitraryValidScimIdNoNameIDQualifiers = do . (SAML.uidSubject . SAML.nameIDSPProvidedID .~ Nothing) . (SAML.uidSubject . SAML.nameIDSPNameQ .~ Nothing) --- | Take apart a 'ValidScimId', use both 'SAML.UserRef', 'Email' if applicable, and --- merge the result with a given function. -runValidScimIdBoth :: (a -> a -> a) -> (SAML.UserRef -> a) -> (EmailAddress -> a) -> ValidScimId -> a -runValidScimIdBoth merge doURefl doEmail = these doEmail doURefl (\em uref -> doEmail em `merge` doURefl uref) . validScimIdAuthInfo - veidUref :: ValidScimId -> Maybe SAML.UserRef veidUref = justThere . validScimIdAuthInfo -isSAMLUser :: ValidScimId -> Bool -isSAMLUser = isJust . justThere . validScimIdAuthInfo - makeLenses ''ValidScimUser makeLenses ''ValidScimId diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs index 7ad5845c320..1463b0d1136 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/InvitationList_team.hs @@ -37,20 +37,20 @@ testObject_InvitationList_team_2 = InvitationList { ilInvitations = [ Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-08T09:28:36.729Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-08T09:28:36.729Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "fuC9p\1098501A\163554\f\ENQ\SO\21027N\47326_?oCX.U\r\163744W\33096\58996\1038685\DC3\t[\37667\SYN/\8408A\145025\173325\DC4H\135001\STX\166880\EOT\165028o\DC3" } ), - inInviteeUrl = Just (fromRight' (parseURI strictURIParserOptions "https://example.com/inv14")) + inviteeUrl = Just (fromRight' (parseURI strictURIParserOptions "https://example.com/inv14")) } ], ilHasMore = True @@ -64,126 +64,126 @@ testObject_InvitationList_team_4 = InvitationList { ilInvitations = [ Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T19:46:50.121Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T19:46:50.121Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "R6\133444\134053VQ\187682\SUB\SOH\180538\&0C\1088909\ESCR\185800\125002@\38857Z?\STX\169387\1067878e}\SOH\ETB\EOTm\184898\US]\986782\189015\1059374\986508\b\DC1zfw-5\120662\CAN\1064450 \EMe\DC4|\14426Vo{\1076439\DC3#\USS\45051&zz\160719\&9\142411,\SI\f\SOHp\1025840\DLE\163178\1060369.&\997544kZ\50431u\b\50764\1109279n:\1103691D$.Q" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing }, Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T09:00:02.901Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000000")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T09:00:02.901Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\DC2}q\CAN=SA\ETXx\t\ETX\\\v[\b)(\ESC]\135875Y\v@p\41515l\45065\157388\NUL\t\1100066\SOH1\DC1\ENQ\1021763\"i\29460\EM\b\ACK\SI\DC2v\ACK" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing }, Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), - inRole = RoleMember, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T11:10:31.203Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), + role = RoleMember, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T11:10:31.203Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\58076&\1059325Ec\NUL\16147}k\1036184l\172911\USJ\EM0^.+F\DEL\NUL\f$'`!\ETB[p\1041609}>E0y\96440#4I\a\66593jc\ESCgt\22473\1093208P\DC4!\1095909E93'Y$YL\46886b\r:,\181790\SO\153247y\ETX;\1064633\1099478z4z-D\1096755a\139100\&6\164829r\1033640\987906J\DLE\48134" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing }, Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T23:41:34.529Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000000")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T23:41:34.529Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "Ft*O1\b&\SO\CAN<\72219\1092619m\n\DC4\DC2; \ETX\988837\DC1\1059627\"k.T\1023249[[\FS\EOT{j`\GS\997342c\1066411{\SUB\GSQY\182805\t\NAKy\t\132339j\1036225W " } ), - inInviteeUrl = Nothing - }, - Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T00:29:17.658Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Nothing, - inInviteeUrl = Nothing - }, - Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T13:34:37.117Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + inviteeUrl = Nothing + }, + Invitation + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000000")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T00:29:17.658Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Nothing, + inviteeUrl = Nothing + }, + Invitation + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T13:34:37.117Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "Lo\r\1107113\1111565\1042998\1027480g\"\1055088\SUB\SUB\180703\43419\EOTv\188258,\171408(\GSQT\150160;\1063450\ENQ\ETBB\1106414H\170195\\\1040638,Y" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_6 :: Invitation testObject_Invitation_team_6 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000100000000")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T08:56:40.919Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000001")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000100000000")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T08:56:40.919Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "O~\DC4U\RS?V3_\191280Slh\1072236Q1\1011443j|~M7\1092762\1097596\94632\DC1K\1078140Afs\178951lGV\1113159]`o\EMf\34020InvfDDy\\DI\163761\1091945\ETBB\159212F*X\SOH\SUB\50580\ETX\DLE<\ETX\SYNc\DEL\DLE,p\v*\1005720Vn\fI\70201xS\STXV\ESC$\EMu\1002390xl>\aZ\DC44e\DC4aZ" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_7 :: Invitation testObject_Invitation_team_7 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000200000001")), - inRole = RoleExternalPartner, - inInvitation = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-07T18:46:22.786Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000100000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000200000001")), + role = RoleExternalPartner, + invitationId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002")), + createdAt = fromJust (readUTCTimeMillis "1864-05-07T18:46:22.786Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000100000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\CAN.\110967\1085214\DLE\f\DLE\CAN\150564o;Yay:yY $\ETX<\879%@\USre>5L'R\DC3\178035oy#]c4!\99741U\54858\26279\1042232\1062242p_>f\SO\DEL\175240\1077738\995735_Vm\US}\STXPz\r\ENQK\SO+>\991648\NUL\153467?pu?r\ESC\SUB!?\168405;\6533S\18757\a\1071148\b\1023581\996567\17385\120022\b\SUB\FS\SIF%<\125113\SIh\ESC\ETX\SI\994739\USO\NULg_\151272\47274\1026399\EOT\1058084\1089771z~%IA'R\b\1011572Hv^\1043633wrjb\t\166747\ETX" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_12 :: Invitation testObject_Invitation_team_12 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-12T22:47:35.829Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000000000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000000000002")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000100000002")), + createdAt = fromJust (readUTCTimeMillis "1864-05-12T22:47:35.829Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000000000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\DLEZ+wd^\67082\1073384\&1\STXYdXt>\1081020LSB7F9\\\135148\ENQ\n\987295\"\127009|\a\61724\157754\DEL'\ESCTygU\1106772R\52822\1071584O4\1035713E9\"\1016016\DC2Re\ENQD}\1051112\161959\1104733\bV\176894%98'\RS9\ACK4yP\83405\14400\345\aw\t\1098022\v\1078003xv/Yl\1005740\158703" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_13 :: Invitation testObject_Invitation_team_13 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000001")), - inRole = RoleMember, - inInvitation = Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000200000002")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-08T01:18:31.982Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000100000002"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Just (Name {fromName = "U"}), - inInviteeUrl = Nothing + { team = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000001")), + role = RoleMember, + invitationId = Id (fromJust (UUID.fromString "00000002-0000-0000-0000-000200000002")), + createdAt = fromJust (readUTCTimeMillis "1864-05-08T01:18:31.982Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000100000002"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just (Name {fromName = "U"}), + inviteeUrl = Nothing } testObject_Invitation_team_14 :: Invitation testObject_Invitation_team_14 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000100000000")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000200000002")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-12T23:54:25.090Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000200000000"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Nothing, - inInviteeUrl = Nothing + { team = Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000100000000")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000200000002")), + createdAt = fromJust (readUTCTimeMillis "1864-05-12T23:54:25.090Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000002-0000-0002-0000-000200000000"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Nothing, + inviteeUrl = Nothing } testObject_Invitation_team_15 :: Invitation testObject_Invitation_team_15 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000100000001")), - inRole = RoleOwner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-08T22:22:28.568Z"), - inCreatedBy = Nothing, - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0002-0000-000100000001")), + role = RoleOwner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000200000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-08T22:22:28.568Z"), + createdBy = Nothing, + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\71448\US&KIL\DC3\1086159![\n6\1111661HEj4E\12136UL\US>2\1070931_\nJ\53410Pv\SO\SIR\30897\&8\bmS\45510mE\ag\SYN\ENQ%\14545\f!\v\US\119306\ENQ\184817\1044744\SO83!j\73854\GS\1071331,\RS\CANF\1062795\1110535U\EMJb\DC1j\EMY\92304O\1007855" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_16 :: Invitation testObject_Invitation_team_16 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000002")), - inRole = RoleExternalPartner, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000200000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-09T09:56:33.113Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Just (Name {fromName = "\GS\DC4Q;6/_f*7\1093966\SI+\1092810\41698\&9"}), - inInviteeUrl = Nothing + { team = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000002")), + role = RoleExternalPartner, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000200000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-09T09:56:33.113Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000100000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just (Name {fromName = "\GS\DC4Q;6/_f*7\1093966\SI+\1092810\41698\&9"}), + inviteeUrl = Nothing } testObject_Invitation_team_17 :: Invitation testObject_Invitation_team_17 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000002")), - inRole = RoleAdmin, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-08T06:30:23.239Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000002")), + role = RoleAdmin, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0001-0000-000100000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-08T06:30:23.239Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000000000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "Z\ESC9E\DEL\NAK\37708\83413}(3m\97177\97764'\1072786.WY;\RS8?v-\1100720\DC2\1015859" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_19 :: Invitation testObject_Invitation_team_19 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000000")), - inRole = RoleMember, - inInvitation = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000000000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-07T15:08:06.796Z"), - inCreatedBy = Nothing, - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = + { team = Id (fromJust (UUID.fromString "00000000-0000-0000-0000-000200000000")), + role = RoleMember, + invitationId = Id (fromJust (UUID.fromString "00000001-0000-0002-0000-000000000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-07T15:08:06.796Z"), + createdBy = Nothing, + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Just ( Name { fromName = "\38776r\111317\ETXQi\1000087\1097943\EM\170747\74323+\1067948Q?H=G-\RS;\1103719\SOq^K;a\1052250W\EM X\83384\1073320>M\980\26387jjbU-&\1040136v\NULy\181884\a|\SYNUfJCHjP\SO\1111555\27981DNA:~s" } ), - inInviteeUrl = Nothing + inviteeUrl = Nothing } testObject_Invitation_team_20 :: Invitation testObject_Invitation_team_20 = Invitation - { inTeam = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), - inRole = RoleExternalPartner, - inInvitation = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000001")), - inCreatedAt = fromJust (readUTCTimeMillis "1864-05-12T08:07:17.747Z"), - inCreatedBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), - inInviteeEmail = unsafeEmailAddress "some" "example", - inInviteeName = Nothing, - inInviteeUrl = Nothing + { team = Id (fromJust (UUID.fromString "00000001-0000-0000-0000-000000000000")), + role = RoleExternalPartner, + invitationId = Id (fromJust (UUID.fromString "00000002-0000-0001-0000-000000000001")), + createdAt = fromJust (readUTCTimeMillis "1864-05-12T08:07:17.747Z"), + createdBy = Just (Id (fromJust (UUID.fromString "00000000-0000-0001-0000-000100000001"))), + inviteeEmail = unsafeEmailAddress "some" "example", + inviteeName = Nothing, + inviteeUrl = Nothing } diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index 890275b857d..29e6263437f 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -14,6 +14,7 @@ , bytestring , bytestring-conversion , cassandra-util +, conduit , containers , cql , crypton @@ -73,10 +74,12 @@ , types-common , unliftio , unordered-containers +, uri-bytestring , uuid , wai-utilities , wire-api , wire-api-federation +, witherable }: mkDerivation { pname = "wire-subsystems"; @@ -94,6 +97,7 @@ mkDerivation { bytestring bytestring-conversion cassandra-util + conduit containers cql crypton @@ -143,10 +147,12 @@ mkDerivation { types-common unliftio unordered-containers + uri-bytestring uuid wai-utilities wire-api wire-api-federation + witherable ]; testHaskellDepends = [ aeson diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs new file mode 100644 index 00000000000..9473bd16f58 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore.hs @@ -0,0 +1,30 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- 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 . +{-# LANGUAGE TemplateHaskell #-} + +module Wire.ActivationCodeStore where + +import Data.Id +import Imports +import Polysemy +import Wire.API.User.Activation +import Wire.UserKeyStore + +data ActivationCodeStore :: Effect where + LookupActivationCode :: EmailKey -> ActivationCodeStore m (Maybe (Maybe UserId, ActivationCode)) + +makeSem ''ActivationCodeStore diff --git a/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs new file mode 100644 index 00000000000..7f0ba27ba03 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/ActivationCodeStore/Cassandra.hs @@ -0,0 +1,37 @@ +module Wire.ActivationCodeStore.Cassandra where + +import Cassandra +import Data.Id +import Data.Text.Ascii qualified as Ascii +import Data.Text.Encoding qualified as T +import Imports +import OpenSSL.EVP.Digest +import Polysemy +import Polysemy.Embed +import Wire.API.User.Activation +import Wire.ActivationCodeStore +import Wire.UserKeyStore (EmailKey, emailKeyUniq) + +interpretActivationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor ActivationCodeStore r +interpretActivationCodeStoreToCassandra casClient = + interpret $ + runEmbedded (runClient casClient) . \case + LookupActivationCode ek -> embed do + liftIO (mkActivationKey ek) + >>= retry x1 . query1 cql . params LocalQuorum . Identity + where + cql :: PrepQuery R (Identity ActivationKey) (Maybe UserId, ActivationCode) + cql = + [sql| + SELECT user, code FROM activation_keys WHERE key = ? + |] + +mkActivationKey :: EmailKey -> IO ActivationKey +mkActivationKey k = do + Just d <- getDigestByName "SHA256" + pure do + ActivationKey + . Ascii.encodeBase64Url + . digestBS d + . T.encodeUtf8 + $ emailKeyUniq k diff --git a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs index 94024d5b4cf..2d28021a6a1 100644 --- a/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/AuthenticationSubsystem/Interpreter.hs @@ -49,7 +49,8 @@ import Wire.Sem.Now import Wire.Sem.Now qualified as Now import Wire.SessionStore import Wire.UserKeyStore -import Wire.UserSubsystem (UserSubsystem, getLocalUserAccountByUserKey) +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User interpretAuthenticationSubsystem :: forall r. @@ -141,20 +142,22 @@ lookupActiveUserIdByUserKey target = userId <$$> lookupActiveUserByUserKey target lookupActiveUserByUserKey :: - (Member UserSubsystem r, Member (Input (Local ())) r) => + ( Member UserSubsystem r, + Member (Input (Local ())) r + ) => EmailKey -> Sem r (Maybe User) lookupActiveUserByUserKey target = do localUnit <- input - let ltarget = qualifyAs localUnit target - mUser <- getLocalUserAccountByUserKey ltarget + let ltarget = qualifyAs localUnit [emailKeyOrig target] + mUser <- User.getExtendedAccountsByEmailNoFilter ltarget case mUser of - Just user -> do + [user] -> do pure $ - if user.accountStatus == Active - then Just user.accountUser + if user.account.accountStatus == Active + then Just user.account.accountUser else Nothing - Nothing -> pure Nothing + _ -> pure Nothing internalLookupPasswordResetCodeImpl :: ( Member PasswordResetCodeStore r, diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs index 63075543d4a..e129fb5bc2c 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess.hs @@ -67,7 +67,8 @@ data GalleyAPIAccess m a where AddTeamMember :: UserId -> TeamId -> - (Maybe (UserId, UTCTimeMillis), Role) -> + Maybe (UserId, UTCTimeMillis) -> + Role -> GalleyAPIAccess m Bool CreateTeam :: UserId -> diff --git a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs index e226d09bcdd..aa9dcb4dc9e 100644 --- a/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs +++ b/libs/wire-subsystems/src/Wire/GalleyAPIAccess/Rpc.hs @@ -71,7 +71,7 @@ interpretGalleyAPIAccessToRpc disabledVersions galleyEndpoint = GetTeamConv id' id'' id'2 -> getTeamConv v id' id'' id'2 NewClient id' ci -> newClient id' ci CheckUserCanJoinTeam id' -> checkUserCanJoinTeam id' - AddTeamMember id' id'' x0 -> addTeamMember id' id'' x0 + AddTeamMember id' id'' a b -> addTeamMember id' id'' a b CreateTeam id' bnt id'' -> createTeam id' bnt id'' GetTeamMember id' id'' -> getTeamMember id' id'' GetTeamMembers id' -> getTeamMembers id' @@ -234,9 +234,10 @@ addTeamMember :: ) => UserId -> TeamId -> - (Maybe (UserId, UTCTimeMillis), Role) -> + Maybe (UserId, UTCTimeMillis) -> + Role -> Sem r Bool -addTeamMember u tid (minvmeta, role) = do +addTeamMember u tid minvmeta role = do debug $ remote "galley" . msg (val "Adding member to team") diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs new file mode 100644 index 00000000000..a9183ae2da9 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore.hs @@ -0,0 +1,136 @@ +-- This file is part of the Wire Server implementation. +-- +-- Copyright (C) 2022 Wire Swiss GmbH +-- +-- 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 . +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Wire.InvitationCodeStore where + +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import Data.Id (InvitationId, TeamId, UserId) +import Data.Json.Util (UTCTimeMillis) +import Data.Range (Range) +import Database.CQL.Protocol (Record (..), TupleType, recordInstance) +import Imports +import Polysemy +import Polysemy.TinyLog (TinyLog) +import System.Logger.Message qualified as Log +import URI.ByteString +import Util.Timeout +import Wire.API.Team.Invitation (Invitation (inviteeEmail)) +import Wire.API.Team.Invitation qualified as Public +import Wire.API.Team.Role (Role, defaultRole) +import Wire.API.User (EmailAddress, InvitationCode, Name) +import Wire.Arbitrary (Arbitrary, GenericUniform (..)) +import Wire.Sem.Logger qualified as Log + +data StoredInvitation = MkStoredInvitation + { teamId :: TeamId, + role :: Maybe Role, + invitationId :: InvitationId, + createdAt :: UTCTimeMillis, + createdBy :: Maybe UserId, + email :: EmailAddress, + name :: Maybe Name, + code :: InvitationCode + } + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform StoredInvitation) + +recordInstance ''StoredInvitation + +data StoredInvitationInfo = MkStoredInvitationInfo + { teamId :: TeamId, + invitationId :: InvitationId, + code :: InvitationCode + } + deriving (Show, Eq, Generic) + deriving (Arbitrary) via (GenericUniform StoredInvitationInfo) + +recordInstance ''StoredInvitationInfo + +data InsertInvitation = MkInsertInvitation + { invitationId :: InvitationId, + teamId :: TeamId, + role :: Role, + createdAt :: UTCTime, + createdBy :: Maybe UserId, + inviteeEmail :: EmailAddress, + inviteeName :: Maybe Name + } + deriving (Show, Eq, Generic) + +recordInstance ''InsertInvitation + +data PaginatedResult a + = PaginatedResultHasMore a + | PaginatedResult a + deriving stock (Eq, Ord, Show, Functor, Foldable) + +---------------------------- + +data InvitationCodeStore :: Effect where + InsertInvitation :: InsertInvitation -> Timeout -> InvitationCodeStore m StoredInvitation + LookupInvitation :: TeamId -> InvitationId -> InvitationCodeStore m (Maybe StoredInvitation) + LookupInvitationInfo :: InvitationCode -> InvitationCodeStore m (Maybe StoredInvitationInfo) + LookupInvitationCodesByEmail :: EmailAddress -> InvitationCodeStore m [StoredInvitationInfo] + -- | Range is page size, it defaults to 100 + LookupInvitationsPaginated :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> InvitationCodeStore m (PaginatedResult [StoredInvitation]) + CountInvitations :: TeamId -> InvitationCodeStore m Int64 + DeleteInvitation :: TeamId -> InvitationId -> InvitationCodeStore m () + DeleteAllTeamInvitations :: TeamId -> InvitationCodeStore m () + +makeSem ''InvitationCodeStore + +---------------------------- + +lookupInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> Sem r (Maybe StoredInvitation) +lookupInvitationByEmail email = runMaybeT do + MkStoredInvitationInfo {teamId, invitationId} <- MaybeT $ lookupSingleInvitationCodeByEmail email + MaybeT $ lookupInvitation teamId invitationId + +lookupInvitationByCode :: (Member InvitationCodeStore r) => InvitationCode -> Sem r (Maybe StoredInvitation) +lookupInvitationByCode code = runMaybeT do + info <- MaybeT $ lookupInvitationInfo code + MaybeT $ lookupInvitation info.teamId info.invitationId + +lookupSingleInvitationCodeByEmail :: (Member TinyLog r, Member InvitationCodeStore r) => EmailAddress -> Sem r (Maybe StoredInvitationInfo) +lookupSingleInvitationCodeByEmail email = do + invs <- lookupInvitationCodesByEmail email + case invs of + [] -> pure Nothing + [inv] -> pure $ Just inv + (_ : _ : _) -> do + -- edge case: more than one pending invite from different teams + Log.info $ + Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") + . Log.field "email" (show email) + + pure Nothing + +invitationFromStored :: Maybe (URIRef Absolute) -> StoredInvitation -> Public.Invitation +invitationFromStored maybeUrl MkStoredInvitation {..} = + Public.Invitation + { team = teamId, + role = fromMaybe defaultRole role, + invitationId = invitationId, + createdAt = createdAt, + createdBy = createdBy, + inviteeEmail = email, + inviteeName = name, + inviteeUrl = maybeUrl + } diff --git a/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs new file mode 100644 index 00000000000..f8a3bc4a688 --- /dev/null +++ b/libs/wire-subsystems/src/Wire/InvitationCodeStore/Cassandra.hs @@ -0,0 +1,194 @@ +module Wire.InvitationCodeStore.Cassandra where + +import Cassandra +import Data.Conduit (runConduit, (.|)) +import Data.Conduit.List qualified as Conduit +import Data.Id +import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) +import Data.Range (Range, fromRange) +import Data.Text.Ascii (encodeBase64Url) +import Database.CQL.Protocol (TupleType, asRecord) +import Imports +import OpenSSL.Random (randBytes) +import Polysemy +import Polysemy.Embed +import UnliftIO.Async (pooledMapConcurrentlyN_) +import Util.Timeout +import Wire.API.Team.Role (Role) +import Wire.API.User +import Wire.InvitationCodeStore + +interpretInvitationCodeStoreToCassandra :: (Member (Embed IO) r) => ClientState -> InterpreterFor InvitationCodeStore r +interpretInvitationCodeStoreToCassandra casClient = + interpret $ + runEmbedded (runClient casClient) . \case + InsertInvitation newInv timeout -> embed $ insertInvitationImpl newInv timeout + LookupInvitation tid iid -> embed $ lookupInvitationImpl tid iid + LookupInvitationCodesByEmail email -> embed $ lookupInvitationCodesByEmailImpl email + LookupInvitationInfo code -> embed $ lookupInvitationInfoImpl code + LookupInvitationsPaginated mSize tid miid -> embed $ lookupInvitationsPaginatedImpl mSize tid miid + CountInvitations tid -> embed $ countInvitationsImpl tid + DeleteInvitation tid invId -> embed $ deleteInvitationImpl tid invId + DeleteAllTeamInvitations tid -> embed $ deleteInvitationsImpl tid + +insertInvitationImpl :: + InsertInvitation -> + -- | The timeout for the invitation code. + Timeout -> + Client StoredInvitation +insertInvitationImpl (MkInsertInvitation invId teamId role (toUTCTimeMillis -> now) uid email name) timeout = do + code <- liftIO mkInvitationCode + let inv = + MkStoredInvitation + { teamId = teamId, + role = Just role, + invitationId = invId, + createdAt = now, + createdBy = uid, + email = email, + name = name, + code = code + } + retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery cqlInsert (teamId, Just role, invId, now, uid, email, name, code, round timeout) + addPrepQuery cqlInsertInfo (code, teamId, invId, round timeout) + addPrepQuery cqlInsertByEmail (email, teamId, invId, code, round timeout) + pure inv + where + cqlInsert :: PrepQuery W (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode, Int32) () + cqlInsert = + [sql| + INSERT INTO team_invitation (team, role, id, created_at, created_by, email, name, code) VALUES (?, ?, ?, ?, ?, ?, ?, ?) USING TTL ? + |] + cqlInsertInfo :: PrepQuery W (InvitationCode, TeamId, InvitationId, Int32) () + cqlInsertInfo = + [sql| + INSERT INTO team_invitation_info (code, team, id) VALUES (?, ?, ?) USING TTL ? + |] + -- Note: the edge case of multiple invites to the same team by different admins from the + -- same team results in last-invite-wins in the team_invitation_email table. + cqlInsertByEmail :: PrepQuery W (EmailAddress, TeamId, InvitationId, InvitationCode, Int32) () + cqlInsertByEmail = + [sql| + INSERT INTO team_invitation_email (email, team, invitation, code) VALUES (?, ?, ?, ?) USING TTL ? + |] + +lookupInvitationsPaginatedImpl :: Maybe (Range 1 500 Int32) -> TeamId -> Maybe InvitationId -> Client (PaginatedResult [StoredInvitation]) +lookupInvitationsPaginatedImpl mSize tid miid = do + page <- retry x1 case miid of + Just ref -> paginate cqlSelectFrom (paramsP LocalQuorum (tid, ref) (pageSize + 1)) + Nothing -> paginate cqlSelect (paramsP LocalQuorum (Identity tid) (pageSize + 1)) + pure $ mkPage (hasMore page) $ map asRecord $ trim page + where + pageSize :: Int32 + pageSize = maybe 100 fromRange mSize + + trim :: Page a -> [a] + trim p = take (fromIntegral pageSize) (result p) + + mkPage more invs = if more then PaginatedResultHasMore invs else PaginatedResult invs + + cqlSelect :: PrepQuery R (Identity TeamId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) + cqlSelect = + [sql| + SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? ORDER BY id ASC + |] + cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) + cqlSelectFrom = + [sql| + SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC + |] + +countInvitationsImpl :: TeamId -> Client (Int64) +countInvitationsImpl t = + maybe 0 runIdentity + <$> retry x1 (query1 cql (params LocalQuorum (Identity t))) + where + cql :: PrepQuery R (Identity TeamId) (Identity Int64) + cql = [sql| SELECT count(*) FROM team_invitation WHERE team = ?|] + +lookupInvitationInfoImpl :: InvitationCode -> Client (Maybe StoredInvitationInfo) +lookupInvitationInfoImpl code = + fmap asRecord <$> retry x1 (query1 cql (params LocalQuorum (Identity code))) + where + cql :: PrepQuery R (Identity InvitationCode) (TupleType StoredInvitationInfo) + cql = + [sql| + SELECT team, id, code FROM team_invitation_info WHERE code = ? + |] + +lookupInvitationCodesByEmailImpl :: EmailAddress -> Client [StoredInvitationInfo] +lookupInvitationCodesByEmailImpl email = map asRecord <$> retry x1 (query cql (params LocalQuorum (Identity email))) + where + cql :: PrepQuery R (Identity EmailAddress) (TeamId, InvitationId, InvitationCode) + cql = + [sql| + SELECT team, invitation, code FROM team_invitation_email WHERE email = ? + |] + +lookupInvitationImpl :: TeamId -> InvitationId -> Client (Maybe StoredInvitation) +lookupInvitationImpl tid iid = + fmap asRecord + <$> retry x1 (query1 cql (params LocalQuorum (tid, iid))) + where + cql :: PrepQuery R (TeamId, InvitationId) (TupleType StoredInvitation) + cql = + [sql| + SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ? + |] + +deleteInvitationImpl :: TeamId -> InvitationId -> Client () +deleteInvitationImpl teamId invId = do + codeEmail <- lookupInvitationCodeEmail + case codeEmail of + Just (invCode, invEmail) -> retry x5 . batch $ do + setType BatchLogged + setConsistency LocalQuorum + addPrepQuery cqlInvitation (teamId, invId) + addPrepQuery cqlInvitationInfo (Identity invCode) + addPrepQuery cqlInvitationEmail (invEmail, teamId) + Nothing -> + retry x5 $ write cqlInvitation (params LocalQuorum (teamId, invId)) + where + lookupInvitationCodeEmail :: Client (Maybe (InvitationCode, EmailAddress)) + lookupInvitationCodeEmail = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (teamId, invId))) + + cqlInvitation :: PrepQuery W (TeamId, InvitationId) () + cqlInvitation = + [sql| + DELETE FROM team_invitation where team = ? AND id = ? + |] + + cqlInvitationInfo :: PrepQuery W (Identity InvitationCode) () + cqlInvitationInfo = + [sql| + DELETE FROM team_invitation_info WHERE code = ? + |] + + cqlInvitationEmail :: PrepQuery W (EmailAddress, TeamId) () + cqlInvitationEmail = + [sql| + DELETE FROM team_invitation_email WHERE email = ? AND team = ? + |] + + cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, EmailAddress) + cqlInvitationCodeEmail = + [sql| + SELECT code, email FROM team_invitation WHERE team = ? AND id = ? + |] + +deleteInvitationsImpl :: TeamId -> Client () +deleteInvitationsImpl teamId = + runConduit $ + paginateC cqlSelect (paramsP LocalQuorum (Identity teamId) 100) x1 + .| Conduit.mapM_ (pooledMapConcurrentlyN_ 16 (deleteInvitationImpl teamId . runIdentity)) + where + cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) + cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" + +-- | This function doesn't really belong here, and may want to have return type `Sem (Random : +-- ...)` instead of `IO`. Meh. +mkInvitationCode :: IO InvitationCode +mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs index dbf5502fc4a..b1db6098841 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE QuantifiedConstraints #-} -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2022 Wire Swiss GmbH @@ -33,11 +34,9 @@ data PRQueryData f = PRQueryData prqdTimeout :: f UTCTime } -deriving instance Show (PRQueryData Identity) +deriving instance (forall a. (Show a) => Show (f a)) => Show (PRQueryData f) -deriving instance Eq (PRQueryData Maybe) - -deriving instance Show (PRQueryData Maybe) +deriving instance (forall a. (Eq a) => Eq (f a)) => Eq (PRQueryData f) mapPRQueryData :: (forall a. (f1 a -> f2 a)) -> PRQueryData f1 -> PRQueryData f2 mapPRQueryData f prqd = prqd {prqdRetries = f prqd.prqdRetries, prqdTimeout = f prqd.prqdTimeout} diff --git a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs index 74bdd0ca1f7..8b923551bc2 100644 --- a/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/PasswordResetCodeStore/Cassandra.hs @@ -58,12 +58,7 @@ passwordResetCodeStoreToCassandra = . write codeInsertQuery . params LocalQuorum $ (prk, prc, uid, runIdentity n, runIdentity ut, ttl) - CodeDelete prk -> - retry x5 - . write codeDeleteQuery - . params LocalQuorum - . Identity - $ prk + CodeDelete prk -> codeDeleteImpl prk where toRecord :: (PasswordResetCode, UserId, Maybe Int32, Maybe UTCTime) -> @@ -79,6 +74,16 @@ genPhoneCode = PasswordResetCode . unsafeFromText . pack . printf "%06d" <$> liftIO (randIntegerZeroToNMinusOne 1000000) +-- FUTUREWORK(fisx,elland): this should be replaced by a method in a +-- future auth subsystem +codeDeleteImpl :: (MonadClient m) => PasswordResetKey -> m () +codeDeleteImpl prk = + retry x5 + . write codeDeleteQuery + . params LocalQuorum + . Identity + $ prk + interpretClientToIO :: (Member (Final IO) r) => ClientState -> diff --git a/libs/wire-subsystems/src/Wire/StoredUser.hs b/libs/wire-subsystems/src/Wire/StoredUser.hs index 38bb072401d..f18502ad591 100644 --- a/libs/wire-subsystems/src/Wire/StoredUser.hs +++ b/libs/wire-subsystems/src/Wire/StoredUser.hs @@ -22,6 +22,7 @@ data StoredUser = StoredUser textStatus :: Maybe TextStatus, pict :: Maybe Pict, email :: Maybe EmailAddress, + emailUnvalidated :: Maybe EmailAddress, ssoId :: Maybe UserSSOId, accentId :: ColourId, assets :: Maybe [Asset], @@ -102,6 +103,10 @@ mkAccountFromStored domain defaultLocale storedUser = (mkUserFromStored domain defaultLocale storedUser) (fromMaybe Active storedUser.status) +mkExtendedAccountFromStored :: Domain -> Locale -> StoredUser -> ExtendedUserAccount +mkExtendedAccountFromStored domain defaultLocale storedUser = + ExtendedUserAccount (mkAccountFromStored domain defaultLocale storedUser) storedUser.emailUnvalidated + toLocale :: Locale -> (Maybe Language, Maybe Country) -> Locale toLocale _ (Just l, c) = Locale l c toLocale l _ = l diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 3544ec5b35b..6429d60c597 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -46,7 +46,7 @@ data StoredUserUpdateError = StoredUserUpdateHandleExists -- | Effect containing database logic around 'StoredUser'. (Example: claim handle lock is -- database logic; validate handle is application logic.) data UserStore m a where - GetUser :: UserId -> UserStore m (Maybe StoredUser) + GetUsers :: [UserId] -> UserStore m [StoredUser] UpdateUser :: UserId -> StoredUserUpdate -> UserStore m () UpdateUserHandleEither :: UserId -> StoredUserHandleUpdate -> UserStore m (Either StoredUserUpdateError ()) DeleteUser :: User -> UserStore m () @@ -66,6 +66,9 @@ data UserStore m a where makeSem ''UserStore +getUser :: (Member UserStore r) => UserId -> Sem r (Maybe StoredUser) +getUser uid = listToMaybe <$> getUsers [uid] + updateUserHandle :: (Member UserStore r, Member (Error StoredUserUpdateError) r) => UserId -> diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index b62e615220e..9ff0e903abf 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -17,7 +17,7 @@ interpretUserStoreCassandra :: (Member (Embed IO) r) => ClientState -> Interpret interpretUserStoreCassandra casClient = interpret $ runEmbedded (runClient casClient) . \case - GetUser uid -> getUserImpl uid + GetUsers uids -> embed $ getUsersImpl uids UpdateUser uid update -> embed $ updateUserImpl uid update UpdateUserHandleEither uid update -> embed $ updateUserHandleEitherImpl uid update DeleteUser user -> embed $ deleteUserImpl user @@ -27,10 +27,10 @@ interpretUserStoreCassandra casClient = IsActivated uid -> embed $ isActivatedImpl uid LookupLocale uid -> embed $ lookupLocaleImpl uid -getUserImpl :: (Member (Embed Client) r) => UserId -> Sem r (Maybe StoredUser) -getUserImpl uid = embed $ do - mUserTuple <- retry x1 $ query1 selectUser (params LocalQuorum (Identity uid)) - pure $ asRecord <$> mUserTuple +getUsersImpl :: [UserId] -> Client [StoredUser] +getUsersImpl usrs = + map asRecord + <$> retry x1 (query selectUsers (params LocalQuorum (Identity usrs))) updateUserImpl :: UserId -> StoredUserUpdate -> Client () updateUserImpl uid update = @@ -126,12 +126,14 @@ lookupLocaleImpl u = do -------------------------------------------------------------------------------- -- Queries -selectUser :: PrepQuery R (Identity UserId) (TupleType StoredUser) -selectUser = - "SELECT id, name, text_status, picture, email, sso_id, accent_id, assets, \ - \activated, status, expires, language, country, provider, service, \ - \handle, team, managed_by, supported_protocols \ - \FROM user where id = ?" +selectUsers :: PrepQuery R (Identity [UserId]) (TupleType StoredUser) +selectUsers = + [sql| + SELECT id, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, + activated, status, expires, language, country, provider, + service, handle, team, managed_by, supported_protocols + FROM user WHERE id IN ? + |] userDisplayNameUpdate :: PrepQuery W (Name, UserId) () userDisplayNameUpdate = "UPDATE user SET name = ? WHERE id = ?" diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 3a0cab37a6a..b8c6256122f 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -1,9 +1,15 @@ +{-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -module Wire.UserSubsystem where +module Wire.UserSubsystem + ( module Wire.UserSubsystem, + module Data.HavePendingInvitations, + ) +where import Data.Default import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Id import Data.Qualified import Imports @@ -11,10 +17,10 @@ import Polysemy import Wire.API.Federation.Error import Wire.API.User import Wire.Arbitrary -import Wire.UserKeyStore +import Wire.UserKeyStore (EmailKey, emailKeyOrig) --- | Who is performing this update operation? (Single source of truth: users managed by SCIM --- can't be updated by clients and vice versa.) +-- | Who is performing this update operation / who is allowed to? (Single source of truth: +-- users managed by SCIM can't be updated by clients and vice versa.) data UpdateOriginType = -- | Call originates from the SCIM api in spar. UpdateOriginScim @@ -26,7 +32,7 @@ data UpdateOriginType -- | Simple updates (as opposed to, eg., handle, where we need to manage locks). -- -- This is isomorphic to 'StoredUserUpdate', but we keep the two types separate because they --- belong to different abstractions / levels (UserSubsystem vs. UserStore), and they may +-- belong to different abstraction levels (UserSubsystem vs. UserStore), and they may -- change independently in the future ('UserStoreUpdate' may grow more fields for other -- operations). data UserProfileUpdate = MkUserProfileUpdate @@ -53,32 +59,57 @@ instance Default UserProfileUpdate where supportedProtocols = Nothing } +-- | Parameters for `getExternalAccountsBy` operation below. +data GetBy = MkGetBy + { -- | whether or not to include pending invitations when getting users by ids. + includePendingInvitations :: HavePendingInvitations, + -- | get accounts by 'UserId'. + getByUserId :: [UserId], + -- | get accounts by their 'Handle' + getByHandle :: [Handle] + } + deriving stock (Eq, Ord, Show, Generic) + deriving (Arbitrary) via GenericUniform GetBy + +instance Default GetBy where + def = MkGetBy NoPendingInvitations [] [] + data UserSubsystem m a where -- | First arg is for authorization only. GetUserProfiles :: Local UserId -> [Qualified UserId] -> UserSubsystem m [UserProfile] + -- | These give us partial success and hide concurrency in the interpreter. + -- (Nit-pick: a better return type for this might be `([Qualified ([UserId], + -- FederationError)], [UserProfile])`, and then we'd probably need a function of type + -- `([Qualified ([UserId], FederationError)], [UserProfile]) -> ([(Qualified UserId, + -- FederationError)], [UserProfile])` to maintain API compatibility.) + GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) -- | Sometimes we don't have any identity of a requesting user, and local profiles are public. GetLocalUserProfiles :: Local [UserId] -> UserSubsystem m [UserProfile] - -- | Self profile contains things not present in Profile. + -- | Get the union of all user accounts matching the `GetBy` argument *and* having a non-empty UserIdentity. + GetExtendedAccountsBy :: Local GetBy -> UserSubsystem m [ExtendedUserAccount] + -- | Get user accounts matching the `[EmailAddress]` argument (accounts with missing + -- identity and accounts with status /= active included). + GetExtendedAccountsByEmailNoFilter :: Local [EmailAddress] -> UserSubsystem m [ExtendedUserAccount] + -- | Get user account by local user id (accounts with missing identity and accounts with + -- status /= active included). + GetAccountNoFilter :: Local UserId -> UserSubsystem m (Maybe UserAccount) + -- | Get `SelfProfile` (it contains things not present in `UserProfile`). GetSelfProfile :: Local UserId -> UserSubsystem m (Maybe SelfProfile) - -- | These give us partial success and hide concurrency in the interpreter. - -- FUTUREWORK: it would be better to return errors as `Map Domain FederationError`, but would clients like that? - GetUserProfilesWithErrors :: Local UserId -> [Qualified UserId] -> UserSubsystem m ([(Qualified UserId, FederationError)], [UserProfile]) -- | Simple updates (as opposed to, eg., handle, where we need to manage locks). Empty fields are ignored (not deleted). UpdateUserProfile :: Local UserId -> Maybe ConnId -> UpdateOriginType -> UserProfileUpdate -> UserSubsystem m () - -- | parse and lookup a handle, return what the operation has found + -- | Parse and lookup a handle. CheckHandle :: Text {- use Handle here? -} -> UserSubsystem m CheckHandleResp - -- | checks a number of 'Handle's for availability and returns at most 'Word' amount of them + -- | Check a number of 'Handle's for availability and returns at most 'Word' amount of them CheckHandles :: [Handle] -> Word -> UserSubsystem m [Handle] - -- | parses a handle, this may fail so it's effectful + -- | Parse and update a handle. Parsing may fail so this is effectful. UpdateHandle :: Local UserId -> Maybe ConnId -> UpdateOriginType -> Text {- use Handle here? -} -> UserSubsystem m () - GetLocalUserAccountByUserKey :: Local EmailKey -> UserSubsystem m (Maybe UserAccount) - -- | returns the user's locale or the default locale if the users exists + -- | Return the user's locale (or the default locale if the users exists and has none). LookupLocaleWithDefault :: Local UserId -> UserSubsystem m (Maybe Locale) - -- | checks if an email is blocked + -- | Check if an email is blocked. IsBlocked :: EmailAddress -> UserSubsystem m Bool - -- | removes an email from the block list + -- | Remove an email from the block list. BlockListDelete :: EmailAddress -> UserSubsystem m () - -- | adds an email to the block list + -- | Add an email to the block list. BlockListInsert :: EmailAddress -> UserSubsystem m () -- | the return type of 'CheckHandle' @@ -89,6 +120,10 @@ data CheckHandleResp makeSem ''UserSubsystem +-- | given a lookup criteria record ('GetBy'), return the union of the user accounts fulfilling that criteria +getAccountsBy :: (Member UserSubsystem r) => Local GetBy -> Sem r [UserAccount] +getAccountsBy getby = (.account) <$$> getExtendedAccountsBy getby + getUserProfile :: (Member UserSubsystem r) => Local UserId -> Qualified UserId -> Sem r (Maybe UserProfile) getUserProfile luid targetUser = listToMaybe <$> getUserProfiles luid [targetUser] @@ -96,3 +131,22 @@ getUserProfile luid targetUser = getLocalUserProfile :: (Member UserSubsystem r) => Local UserId -> Sem r (Maybe UserProfile) getLocalUserProfile targetUser = listToMaybe <$> getLocalUserProfiles ((: []) <$> targetUser) + +getLocalAccountBy :: + (Member UserSubsystem r) => + HavePendingInvitations -> + Local UserId -> + Sem r (Maybe UserAccount) +getLocalAccountBy includePendingInvitations uid = + listToMaybe + <$> getAccountsBy + ( qualifyAs uid $ + def + { getByUserId = [tUnqualified uid], + includePendingInvitations + } + ) + +getLocalUserAccountByUserKey :: (Member UserSubsystem r) => Local EmailKey -> Sem r (Maybe UserAccount) +getLocalUserAccountByUserKey q@(tUnqualified -> ek) = + listToMaybe . fmap (.account) <$> getExtendedAccountsByEmailNoFilter (qualifyAs q [emailKeyOrig ek]) diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 39dd0e179af..d91c6c33dd0 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -13,12 +13,14 @@ import Data.Handle qualified as Handle import Data.Id import Data.Json.Util import Data.LegalHold +import Data.List.Extra (nubOrd) import Data.Qualified import Data.Time.Clock -import Imports hiding (local) +import Imports import Polysemy import Polysemy.Error hiding (try) import Polysemy.Input +import Polysemy.TinyLog (TinyLog) import Servant.Client.Core import Wire.API.Federation.API import Wire.API.Federation.Error @@ -32,6 +34,7 @@ import Wire.DeleteQueue import Wire.Events import Wire.FederationAPIAccess import Wire.GalleyAPIAccess +import Wire.InvitationCodeStore (InvitationCodeStore, lookupInvitationByEmail) import Wire.Sem.Concurrency import Wire.Sem.Now (Now) import Wire.Sem.Now qualified as Now @@ -41,6 +44,7 @@ import Wire.UserStore as UserStore import Wire.UserSubsystem import Wire.UserSubsystem.Error import Wire.UserSubsystem.HandleBlacklist +import Witherable (wither) data UserSubsystemConfig = UserSubsystemConfig { emailVisibilityConfig :: EmailVisibilityConfig, @@ -65,7 +69,9 @@ runUserSubsystem :: Member Now r, RunClient (fedM 'Brig), FederationMonad fedM, - Typeable fedM + Typeable fedM, + Member (TinyLog) r, + Member InvitationCodeStore r ) => UserSubsystemConfig -> InterpreterFor UserSubsystem r @@ -86,19 +92,23 @@ interpretUserSubsystem :: Member Now r, RunClient (fedM 'Brig), FederationMonad fedM, - Typeable fedM + Typeable fedM, + Member InvitationCodeStore r, + Member TinyLog r ) => InterpreterFor UserSubsystem r interpretUserSubsystem = interpret \case GetUserProfiles self others -> getUserProfilesImpl self others GetLocalUserProfiles others -> getLocalUserProfilesImpl others + GetExtendedAccountsBy getBy -> getExtendedAccountsByImpl getBy + GetExtendedAccountsByEmailNoFilter emails -> getExtendedAccountsByEmailNoFilterImpl emails + GetAccountNoFilter luid -> getAccountNoFilterImpl luid GetSelfProfile self -> getSelfProfileImpl self GetUserProfilesWithErrors self others -> getUserProfilesWithErrorsImpl self others UpdateUserProfile self mconn mb update -> updateUserProfileImpl self mconn mb update CheckHandle uhandle -> checkHandleImpl uhandle CheckHandles hdls cnt -> checkHandlesImpl hdls cnt UpdateHandle uid mconn mb uhandle -> updateHandleImpl uid mconn mb uhandle - GetLocalUserAccountByUserKey userKey -> getLocalUserAccountByUserKeyImpl userKey LookupLocaleWithDefault luid -> lookupLocaleOrDefaultImpl luid IsBlocked email -> isBlockedImpl email BlockListDelete email -> blockListDeleteImpl email @@ -418,19 +428,6 @@ mkProfileUpdateHandleEvent :: UserId -> Handle -> UserEvent mkProfileUpdateHandleEvent uid handle = UserUpdated $ (emptyUserUpdatedData uid) {eupHandle = Just handle} -getLocalUserAccountByUserKeyImpl :: - ( Member UserStore r, - Member UserKeyStore r, - Member (Input UserSubsystemConfig) r - ) => - Local EmailKey -> - Sem r (Maybe UserAccount) -getLocalUserAccountByUserKeyImpl target = runMaybeT $ do - config <- lift input - uid <- MaybeT $ lookupKey (tUnqualified target) - user <- MaybeT $ getUser uid - pure $ mkAccountFromStored (tDomain target) config.defaultLocale user - -------------------------------------------------------------------------------- -- Update Handle @@ -495,3 +492,100 @@ checkHandlesImpl check num = reverse <$> collectFree [] check num case owner of Nothing -> collectFree (h : free) hs (n - 1) Just _ -> collectFree free hs n + +getAccountNoFilterImpl :: + forall r. + ( Member UserStore r, + Member (Input UserSubsystemConfig) r + ) => + Local UserId -> + Sem r (Maybe UserAccount) +getAccountNoFilterImpl (tSplit -> (domain, uid)) = do + cfg <- input + muser <- getUser uid + pure $ (mkAccountFromStored domain cfg.defaultLocale) <$> muser + +getExtendedAccountsByEmailNoFilterImpl :: + forall r. + ( Member UserStore r, + Member UserKeyStore r, + Member (Input UserSubsystemConfig) r + ) => + Local [EmailAddress] -> + Sem r [ExtendedUserAccount] +getExtendedAccountsByEmailNoFilterImpl (tSplit -> (domain, emails)) = do + config <- input + nubOrd <$> flip foldMap emails \ek -> do + mactiveUid <- lookupKey (mkEmailKey ek) + getUsers (nubOrd . catMaybes $ [mactiveUid]) + <&> map (mkExtendedAccountFromStored domain config.defaultLocale) + +-------------------------------------------------------------------------------- +-- getting user accounts by different criteria + +getExtendedAccountsByImpl :: + forall r. + ( Member UserStore r, + Member DeleteQueue r, + Member (Input UserSubsystemConfig) r, + Member InvitationCodeStore r, + Member TinyLog r + ) => + Local GetBy -> + Sem r [ExtendedUserAccount] +getExtendedAccountsByImpl (tSplit -> (domain, MkGetBy {includePendingInvitations, getByHandle, getByUserId})) = do + storedToExtAcc <- do + config <- input + pure $ mkExtendedAccountFromStored domain config.defaultLocale + + handleUserIds :: [UserId] <- + wither lookupHandle getByHandle + + accsByIds :: [ExtendedUserAccount] <- + getUsers (nubOrd $ handleUserIds <> getByUserId) <&> map storedToExtAcc + + filterM want (nubOrd $ accsByIds) + where + -- not wanted: + -- . users without identity + -- . pending users without matching invitation (those are garbage-collected) + -- . TODO: deleted users? + want :: ExtendedUserAccount -> Sem r Bool + want ExtendedUserAccount {account} = + case account.accountUser.userIdentity of + Nothing -> pure False + Just ident -> case account.accountStatus of + PendingInvitation -> + case includePendingInvitations of + WithPendingInvitations -> case emailIdentity ident of + -- TODO(fisx): emailIdentity does not return an unvalidated address in case a + -- validated one cannot be found. that's probably wrong? split up into + -- validEmailIdentity, anyEmailIdentity? + Just email -> do + hasInvitation <- isJust <$> lookupInvitationByEmail email + gcHack hasInvitation (userId account.accountUser) + pure hasInvitation + Nothing -> error "getExtendedAccountsByImpl: should never happen, user invited via scim always has an email" + NoPendingInvitations -> pure False + Active -> pure True + Suspended -> pure True + Deleted -> pure True -- TODO(mangoiv): previous comment said "We explicitly filter out deleted users now." Why? + Ephemeral -> pure True + + -- user invited via scim expires together with its invitation. the UserSubsystem interface + -- semantics hides the fact that pending users have no TTL field. we chose to emulate this + -- in this convoluted way (by making the invitation expire and then checking if it's still + -- there when looking up pending users), because adding TTLs would have been a much bigger + -- change in the database schema (`enqueueUserDeletion` would need to happen purely based + -- on TTL values in cassandra, and there is too much application logic involved there). + -- + -- we could also delete these users here and run a background process that scans for + -- pending users without invitation. we chose not to because enqueuing the user deletion + -- here is very cheap, and avoids database traffic if the user is looked up again. if the + -- background job is reliably taking care of this, there is no strong reason to keep this + -- function. + -- + -- there are certainly other ways to improve this, but they probably involve a non-trivial + -- database schema re-design. + gcHack :: Bool -> UserId -> Sem r () + gcHack hasInvitation uid = unless hasInvitation (enqueueUserDeletion uid) diff --git a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs index 8e5924d2e76..85a9af652a3 100644 --- a/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/AuthenticationSubsystem/InterpreterSpec.hs @@ -55,7 +55,7 @@ type AllEffects = UserSubsystem ] -interpretDependencies :: Domain -> [UserAccount] -> Map UserId Password -> Maybe [Text] -> Sem AllEffects a -> Either AuthenticationSubsystemError a +interpretDependencies :: Domain -> [ExtendedUserAccount] -> Map UserId Password -> Maybe [Text] -> Sem AllEffects a -> Either AuthenticationSubsystemError a interpretDependencies localDomain preexistingUsers preexistingPasswords mAllowedEmailDomains = run . userSubsystemTestInterpreter preexistingUsers @@ -84,7 +84,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (newPasswordHash, cookiesAfterReset) = - interpretDependencies localDomain [UserAccount user Active] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ do forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) @@ -105,7 +105,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (newPasswordHash, cookiesAfterReset) = - interpretDependencies localDomain [UserAccount user Active] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ do forM_ mPreviousPassword (hashPassword >=> upsertHashedPassword uid) @@ -135,7 +135,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do let user = userNoEmail {userIdentity = Just $ EmailIdentity email} localDomain = userNoEmail.userQualifiedId.qDomain createPasswordResetCodeResult = - interpretDependencies localDomain [UserAccount user Active] mempty (Just [decodeUtf8 $ domainPart email]) + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty (Just [decodeUtf8 $ domainPart email]) . interpretAuthenticationSubsystem $ createPasswordResetCode (mkEmailKey email) in counterexample ("expected Right, got: " <> show createPasswordResetCodeResult) $ @@ -146,7 +146,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do let user = userNoEmail {userIdentity = Just $ EmailIdentity email} localDomain = userNoEmail.userQualifiedId.qDomain createPasswordResetCodeResult = - interpretDependencies localDomain [UserAccount user status] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user status) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ createPasswordResetCode (mkEmailKey email) <* expectNoEmailSent @@ -168,7 +168,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (newPasswordHash, mCaughtException) = - interpretDependencies localDomain [UserAccount user Active] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ do createPasswordResetCode (mkEmailKey email) @@ -189,7 +189,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (passwordInDB, resetPasswordResult) = - interpretDependencies localDomain [UserAccount user Active] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ do upsertHashedPassword uid =<< hashPassword oldPassword @@ -209,7 +209,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (passwordInDB, resetPasswordResult) = - interpretDependencies localDomain [UserAccount user Active] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ do upsertHashedPassword uid =<< hashPassword oldPassword @@ -224,7 +224,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (passwordInDB, resetPasswordResult) = - interpretDependencies localDomain [UserAccount user Active] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ do hashAndUpsertPassword uid oldPassword @@ -240,7 +240,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right (passwordHashInDB, correctResetCode, wrongResetErrors, resetPassworedWithCorectCodeResult) = - interpretDependencies localDomain [UserAccount user Active] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ do upsertHashedPassword uid =<< hashPassword oldPassword @@ -274,7 +274,7 @@ spec = describe "AuthenticationSubsystem.Interpreter" do uid = User.userId user localDomain = userNoEmail.userQualifiedId.qDomain Right passwordHashInDB = - interpretDependencies localDomain [UserAccount user Active] mempty Nothing + interpretDependencies localDomain [ExtendedUserAccount (UserAccount user Active) Nothing] mempty Nothing . interpretAuthenticationSubsystem $ do void $ createPasswordResetCode (mkEmailKey email) diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index bd712dfe489..d5d4a789261 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -19,6 +19,8 @@ module Wire.MiniBackend -- * Quickcheck helpers NotPendingStoredUser (..), + NotPendingEmptyIdentityStoredUser (..), + PendingNotEmptyIdentityStoredUser (..), PendingStoredUser (..), ) where @@ -34,6 +36,7 @@ import Data.Proxy import Data.Qualified import Data.Time import Data.Type.Equality +import GHC.Generics import Imports import Polysemy import Polysemy.Error @@ -51,7 +54,9 @@ import Wire.API.Federation.Error import Wire.API.Team.Feature import Wire.API.Team.Member hiding (userId) import Wire.API.User as User hiding (DeleteUser) +import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Password +import Wire.ActivationCodeStore import Wire.BlockListStore import Wire.DeleteQueue import Wire.DeleteQueue.InMemory @@ -60,7 +65,10 @@ import Wire.FederationAPIAccess import Wire.FederationAPIAccess.Interpreter as FI import Wire.GalleyAPIAccess import Wire.InternalEvent hiding (DeleteUser) +import Wire.InvitationCodeStore import Wire.MockInterpreters +import Wire.MockInterpreters.ActivationCodeStore (inMemoryActivationCodeStoreInterpreter) +import Wire.MockInterpreters.InvitationCodeStore (inMemoryInvitationCodeStoreInterpreter) import Wire.PasswordResetCodeStore import Wire.Sem.Concurrency import Wire.Sem.Concurrency.Sequential @@ -72,6 +80,24 @@ import Wire.UserSubsystem import Wire.UserSubsystem.Error import Wire.UserSubsystem.Interpreter +newtype PendingNotEmptyIdentityStoredUser = PendingNotEmptyIdentityStoredUser StoredUser + deriving (Show, Eq) + +instance Arbitrary PendingNotEmptyIdentityStoredUser where + arbitrary = do + user <- arbitrary `suchThat` \user -> isJust user.identity + pure $ PendingNotEmptyIdentityStoredUser (user {status = Just PendingInvitation}) + +newtype NotPendingEmptyIdentityStoredUser = NotPendingEmptyIdentityStoredUser StoredUser + deriving (Show, Eq) + +-- TODO: make sure this is a valid state +instance Arbitrary NotPendingEmptyIdentityStoredUser where + arbitrary = do + user <- arbitrary `suchThat` \user -> isNothing user.identity + notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral]) + pure $ NotPendingEmptyIdentityStoredUser (user {status = notPendingStatus}) + newtype PendingStoredUser = PendingStoredUser StoredUser deriving (Show, Eq) @@ -86,7 +112,7 @@ newtype NotPendingStoredUser = NotPendingStoredUser StoredUser instance Arbitrary NotPendingStoredUser where arbitrary = do user <- arbitrary `suchThat` \user -> isJust user.identity - notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Deleted, Ephemeral]) + notPendingStatus <- elements (Nothing : map Just [Active, Suspended, Ephemeral]) pure $ NotPendingStoredUser (user {status = notPendingStatus}) type AllErrors = @@ -97,6 +123,11 @@ type AllErrors = type MiniBackendEffects = [ UserSubsystem, GalleyAPIAccess, + InvitationCodeStore, + State (Map (TeamId, InvitationId) StoredInvitation), + State (Map InvitationCode StoredInvitationInfo), + ActivationCodeStore, + State (Map EmailKey (Maybe UserId, ActivationCode)), BlockListStore, State [EmailKey], UserStore, @@ -123,8 +154,12 @@ data MiniBackend = MkMiniBackend users :: [StoredUser], userKeys :: Map EmailKey UserId, passwordResetCodes :: Map PasswordResetKey (PRQueryData Identity), - blockList :: [EmailKey] + blockList :: [EmailKey], + activationCodes :: Map EmailKey (Maybe UserId, ActivationCode), + invitationInfos :: Map InvitationCode StoredInvitationInfo, + invitations :: Map (TeamId, InvitationId) StoredInvitation } + deriving stock (Eq, Show, Generic) instance Default MiniBackend where def = @@ -132,7 +167,10 @@ instance Default MiniBackend where { users = mempty, userKeys = mempty, passwordResetCodes = mempty, - blockList = mempty + blockList = mempty, + activationCodes = mempty, + invitationInfos = mempty, + invitations = mempty } -- | represents an entire federated, stateful world of backends @@ -352,9 +390,29 @@ interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMem . inMemoryUserStoreInterpreter . liftBlockListStoreState . inMemoryBlockListStoreInterpreter + . liftActivationCodeStoreState + . inMemoryActivationCodeStoreInterpreter + . liftInvitationInfoStoreState + . liftInvitationCodeStoreState + . inMemoryInvitationCodeStoreInterpreter . miniGalleyAPIAccess teamMember galleyConfigs . runUserSubsystem cfg +liftInvitationInfoStoreState :: (Member (State MiniBackend) r) => Sem (State (Map InvitationCode StoredInvitationInfo) : r) a -> Sem r a +liftInvitationInfoStoreState = interpret \case + Polysemy.State.Get -> gets (.invitationInfos) + Put newAcs -> modify $ \b -> b {invitationInfos = newAcs} + +liftInvitationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map (TeamId, InvitationId) StoredInvitation) : r) a -> Sem r a +liftInvitationCodeStoreState = interpret \case + Polysemy.State.Get -> gets (.invitations) + Put newInvs -> modify $ \b -> b {invitations = newInvs} + +liftActivationCodeStoreState :: (Member (State MiniBackend) r) => Sem (State (Map EmailKey (Maybe UserId, ActivationCode)) : r) a -> Sem r a +liftActivationCodeStoreState = interpret \case + Polysemy.State.Get -> gets (.activationCodes) + Put newAcs -> modify $ \b -> b {activationCodes = newAcs} + liftBlockListStoreState :: (Member (State MiniBackend) r) => Sem (State [EmailKey] : r) a -> Sem r a liftBlockListStoreState = interpret $ \case Polysemy.State.Get -> gets (.blockList) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs new file mode 100644 index 00000000000..0265c8d07fe --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/ActivationCodeStore.hs @@ -0,0 +1,13 @@ +module Wire.MockInterpreters.ActivationCodeStore where + +import Data.Id +import Data.Map +import Imports +import Polysemy +import Polysemy.State +import Wire.API.User.Activation +import Wire.ActivationCodeStore (ActivationCodeStore (..)) +import Wire.UserKeyStore + +inMemoryActivationCodeStoreInterpreter :: (Member (State (Map EmailKey (Maybe UserId, ActivationCode))) r) => InterpreterFor ActivationCodeStore r +inMemoryActivationCodeStoreInterpreter = interpret \case LookupActivationCode ek -> gets (!? ek) diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs new file mode 100644 index 00000000000..18f00055865 --- /dev/null +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/InvitationCodeStore.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE RecordWildCards #-} + +module Wire.MockInterpreters.InvitationCodeStore where + +import Data.Id (InvitationId, TeamId) +import Data.Map (elems, (!?)) +import Data.Map qualified as M +import Imports +import Polysemy +import Polysemy.State (State, get, gets) +import Wire.API.User (InvitationCode (..)) +import Wire.InvitationCodeStore + +inMemoryInvitationCodeStoreInterpreter :: + forall r. + ( Member (State (Map (TeamId, InvitationId) StoredInvitation)) r, + Member (State (Map (InvitationCode) StoredInvitationInfo)) r + ) => + InterpreterFor InvitationCodeStore r +inMemoryInvitationCodeStoreInterpreter = interpret \case + InsertInvitation _a _timeout -> error "InsertInvitation" + LookupInvitation tid iid -> gets (!? (tid, iid)) + LookupInvitationInfo iid -> gets (!? iid) + LookupInvitationCodesByEmail em -> + let c MkStoredInvitation {..} + | email == em = Just MkStoredInvitationInfo {..} + | otherwise = Nothing + in mapMaybe c . elems <$> get + LookupInvitationsPaginated {} -> error "LookupInvitationsPaginated" + CountInvitations tid -> gets (fromIntegral . M.size . M.filterWithKey (\(tid', _) _v -> tid == tid')) + DeleteInvitation _tid _invId -> error "DeleteInvitation" + DeleteAllTeamInvitations _tid -> error "DeleteAllTeamInvitations" diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index 563b91f4bd1..bb3ad07afc6 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -16,7 +16,7 @@ inMemoryUserStoreInterpreter :: (Member (State [StoredUser]) r) => InterpreterFor UserStore r inMemoryUserStoreInterpreter = interpret $ \case - GetUser uid -> gets $ find (\user -> user.id == uid) + GetUsers uids -> gets $ filter (\user -> user.id `elem` uids) UpdateUser uid update -> modify (map doUpdate) where doUpdate :: StoredUser -> StoredUser diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs index b47bfbd7d25..45dc93a379a 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserSubsystem.hs @@ -4,12 +4,15 @@ import Data.Qualified import Imports import Polysemy import Wire.API.User -import Wire.UserKeyStore import Wire.UserSubsystem -userSubsystemTestInterpreter :: [UserAccount] -> InterpreterFor UserSubsystem r +-- HINT: This is used to test AuthenticationSubsystem, not to test itself! +userSubsystemTestInterpreter :: [ExtendedUserAccount] -> InterpreterFor UserSubsystem r userSubsystemTestInterpreter initialUsers = interpret \case - GetLocalUserAccountByUserKey localUserKey -> case (tUnqualified localUserKey) of - EmailKey _ email -> pure $ find (\u -> userEmail u.accountUser == Just email) initialUsers + GetExtendedAccountsByEmailNoFilter (tUnqualified -> emails) -> + pure $ + filter + (\u -> userEmail u.account.accountUser `elem` (Just <$> emails)) + initialUsers _ -> error $ "userSubsystemTestInterpreter: implement on demand" diff --git a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs index 9a98d7b1ae5..a7975a867a1 100644 --- a/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs +++ b/libs/wire-subsystems/test/unit/Wire/UserSubsystem/InterpreterSpec.hs @@ -28,6 +28,8 @@ import Wire.API.Team.Member import Wire.API.Team.Permission import Wire.API.User hiding (DeleteUser) import Wire.API.UserEvent +import Wire.InvitationCodeStore (StoredInvitation) +import Wire.InvitationCodeStore qualified as InvitationStore import Wire.MiniBackend import Wire.StoredUser import Wire.UserKeyStore @@ -277,6 +279,302 @@ spec = describe "UserSubsystem.Interpreter" do ) ] + describe "getAccountsBy" do + prop "GetBy userId when pending fails if not explicitly allowed" $ + \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + alice = + alice' + { email = Just email, + teamId = Just teamId + -- For simplicity, so we don't have to match the email with invitation + } + getBy = + toLocalUnsafe localDomain $ + def + { getByUserId = [alice.id], + includePendingInvitations = NoPendingInvitations + } + localBackend = + def + { users = [alice], + -- We need valid invitations or the user gets deleted by + -- our drive-by cleanup job in the interprter. + -- FUTUREWORK: Remove this if we remove the enqueueDeletion from getAccountsByImpl + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + + prop "GetBy userId works for pending if explicitly queried" $ + \(PendingNotEmptyIdentityStoredUser alice') email teamId invitationInfo localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + alice = + alice' + { email = Just email, + teamId = Just teamId + -- For simplicity, so we don't have to match the email with invitation + } + getBy = + toLocalUnsafe localDomain $ + def + { getByUserId = [alice.id], + includePendingInvitations = WithPendingInvitations + } + localBackend = + def + { users = [alice], + -- We need valid invitations or the user gets deleted by + -- our drive-by cleanup job in the interprter. + -- FUTUREWORK: Remove this if we remove the enqueueDeletion from getAccountsByImpl + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + prop "GetBy handle when pending fails if not explicitly allowed" $ + \(PendingNotEmptyIdentityStoredUser alice') handl email teamId invitationInfo localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + alice = + alice' + { email = Just email, + teamId = Just teamId, + handle = Just handl + -- For simplicity, so we don't have to match the email with invitation + } + getBy = + toLocalUnsafe localDomain $ + def + { getByHandle = [handl], + includePendingInvitations = NoPendingInvitations + } + localBackend = + def + { users = [alice], + -- We need valid invitations or the user gets deleted by + -- our drive-by cleanup job in the interprter. + -- FUTUREWORK: Remove this if we remove the enqueueDeletion from getAccountsByImpl + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + + prop "GetBy handle works for pending if explicitly queried" $ + \(PendingNotEmptyIdentityStoredUser alice') handl email teamId invitationInfo localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + alice = + alice' + { email = Just email, + teamId = Just teamId, + handle = Just handl + -- For simplicity, so we don't have to match the email with invitation + } + getBy = + toLocalUnsafe localDomain $ + def + { getByHandle = [handl], + includePendingInvitations = WithPendingInvitations + } + localBackend = + def + { users = [alice], + -- We need valid invitations or the user gets deleted by + -- our drive-by cleanup job in the interprter. + -- FUTUREWORK: Remove this if we remove the enqueueDeletion from getAccountsByImpl + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy email does not filter by pending, missing identity or expired invitations" $ + \(alice' :: StoredUser) email localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + alice = alice' {email = Just email} + localBackend = + def + { users = [alice], + userKeys = Map.singleton (mkEmailKey email) alice.id + } + result = + runNoFederationStack localBackend Nothing config $ + getExtendedAccountsByEmailNoFilter (toLocalUnsafe localDomain [email]) + in result === [mkExtendedAccountFromStored localDomain locale alice] + + prop "GetBy userId does not return missing identity users, pending invitation off" $ + \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + getBy = + toLocalUnsafe localDomain $ + def + { getByUserId = [alice.id], + includePendingInvitations = NoPendingInvitations + } + localBackend = def {users = [alice]} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + + prop "GetBy userId does not return missing identity users, pending invtation on" $ + \(NotPendingEmptyIdentityStoredUser alice) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + getBy = + toLocalUnsafe localDomain $ + def + { getByUserId = [alice.id], + includePendingInvitations = WithPendingInvitations + } + localBackend = def {users = [alice]} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + + prop "GetBy pending user by id works if there is a valid invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByUserId = [alice.id], + includePendingInvitations = WithPendingInvitations + } + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id, + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + alice = alice' {email = Just email, teamId = Just teamId} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy pending user by id fails if there is no valid invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) teamId localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByUserId = [alice.id], + includePendingInvitations = WithPendingInvitations + } + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id + } + alice = alice' {email = Just email, teamId = Just teamId} + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + + prop "GetBy pending user handle id works if there is a valid invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) handl teamId (invitationInfo :: StoredInvitation) localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByHandle = [handl], + includePendingInvitations = WithPendingInvitations + } + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id, + invitations = + Map.singleton + (teamId, invitationInfo.invitationId) + ( invitationInfo + { InvitationStore.email = email, + InvitationStore.teamId = teamId + } + ) + } + alice = + alice' + { email = Just email, + teamId = Just teamId, + handle = Just handl + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [mkAccountFromStored localDomain locale alice] + + prop "GetBy pending user by handle fails if there is no valid invitation" $ + \(PendingNotEmptyIdentityStoredUser alice') (email :: EmailAddress) handl teamId localDomain visibility locale -> + let config = UserSubsystemConfig visibility locale + emailKey = mkEmailKey email + getBy = + toLocalUnsafe localDomain $ + def + { getByHandle = [handl], + includePendingInvitations = WithPendingInvitations + } + localBackend = + def + { users = [alice], + userKeys = Map.singleton emailKey alice.id + } + alice = + alice' + { email = Just email, + teamId = Just teamId, + handle = Just handl + } + result = + runNoFederationStack localBackend Nothing config $ + getAccountsBy getBy + in result === [] + describe "user managed by scim doesn't allow certain update operations, but allows others" $ do prop "happy" $ \(NotPendingStoredUser alice) localDomain update config -> diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index e2763335c9f..a544025aa7b 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -69,6 +69,8 @@ library -- cabal-fmt: expand src exposed-modules: + Wire.ActivationCodeStore + Wire.ActivationCodeStore.Cassandra Wire.AuthenticationSubsystem Wire.AuthenticationSubsystem.Error Wire.AuthenticationSubsystem.Interpreter @@ -92,6 +94,8 @@ library Wire.GundeckAPIAccess Wire.HashPassword Wire.InternalEvent + Wire.InvitationCodeStore + Wire.InvitationCodeStore.Cassandra Wire.NotificationSubsystem Wire.NotificationSubsystem.Interpreter Wire.ParseException @@ -136,6 +140,7 @@ library , bytestring , bytestring-conversion , cassandra-util + , conduit , containers , cql , crypton @@ -185,10 +190,12 @@ library , types-common , unliftio , unordered-containers + , uri-bytestring , uuid , wai-utilities , wire-api , wire-api-federation + , witherable default-language: GHC2021 @@ -206,12 +213,14 @@ test-suite wire-subsystems-tests Wire.AuthenticationSubsystem.InterpreterSpec Wire.MiniBackend Wire.MockInterpreters + Wire.MockInterpreters.ActivationCodeStore Wire.MockInterpreters.BlockListStore Wire.MockInterpreters.EmailSubsystem Wire.MockInterpreters.Error Wire.MockInterpreters.Events Wire.MockInterpreters.GalleyAPIAccess Wire.MockInterpreters.HashPassword + Wire.MockInterpreters.InvitationCodeStore Wire.MockInterpreters.Now Wire.MockInterpreters.PasswordResetCodeStore Wire.MockInterpreters.PasswordStore diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal index 3f71d1eff87..c723695019b 100644 --- a/services/brig/brig.cabal +++ b/services/brig/brig.cabal @@ -188,7 +188,6 @@ library Brig.Schema.V84_DropTeamInvitationPhone Brig.Schema.V85_DropUserKeysHashed Brig.Team.API - Brig.Team.DB Brig.Team.Email Brig.Team.Template Brig.Team.Util @@ -298,7 +297,6 @@ library , safe-exceptions >=0.1 , saml2-web-sso , schema-profunctor - , scientific >=0.3.4 , servant , servant-openapi3 , servant-server diff --git a/services/brig/default.nix b/services/brig/default.nix index 20eb64d007b..03a8b688aa3 100644 --- a/services/brig/default.nix +++ b/services/brig/default.nix @@ -105,7 +105,6 @@ , safe-exceptions , saml2-web-sso , schema-profunctor -, scientific , servant , servant-client , servant-client-core @@ -247,7 +246,6 @@ mkDerivation { safe-exceptions saml2-web-sso schema-profunctor - scientific servant servant-openapi3 servant-server diff --git a/services/brig/src/Brig/API/Auth.hs b/services/brig/src/Brig/API/Auth.hs index cb167140ffb..eace1f730de 100644 --- a/services/brig/src/Brig/API/Auth.hs +++ b/services/brig/src/Brig/API/Auth.hs @@ -114,6 +114,7 @@ login :: Member PasswordStore r, Member UserKeyStore r, Member UserStore r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => Login -> @@ -169,9 +170,16 @@ listCookies lusr (fold -> labels) = CookieList <$> wrapClientE (Auth.listCookies (tUnqualified lusr) (toList labels)) -removeCookies :: (Member TinyLog r, Member PasswordStore r) => Local UserId -> RemoveCookies -> Handler r () +removeCookies :: + ( Member TinyLog r, + Member PasswordStore r, + Member UserSubsystem r + ) => + Local UserId -> + RemoveCookies -> + Handler r () removeCookies lusr (RemoveCookies pw lls ids) = - Auth.revokeAccess (tUnqualified lusr) pw ids lls !>> authError + Auth.revokeAccess lusr pw ids lls !>> authError legalHoldLogin :: ( Member GalleyAPIAccess r, @@ -208,12 +216,19 @@ ssoLogin l (fromMaybe False -> persist) = do getLoginCode :: Phone -> Handler r PendingLoginCode getLoginCode _ = throwStd loginCodeNotFound -reauthenticate :: (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => UserId -> ReAuthUser -> Handler r () -reauthenticate uid body = do +reauthenticate :: + ( Member GalleyAPIAccess r, + Member VerificationCodeSubsystem r, + Member UserSubsystem r + ) => + Local UserId -> + ReAuthUser -> + Handler r () +reauthenticate luid@(tUnqualified -> uid) body = do wrapClientE (User.reauthenticate uid (reAuthPassword body)) !>> reauthError case reAuthCodeAction body of Just action -> - Auth.verifyCode (reAuthCode body) action uid + Auth.verifyCode (reAuthCode body) action luid `catchE` \case VerificationCodeRequired -> throwE $ reauthError ReAuthCodeVerificationRequired VerificationCodeNoPendingCode -> throwE $ reauthError ReAuthCodeVerificationNoPendingCode diff --git a/services/brig/src/Brig/API/Client.hs b/services/brig/src/Brig/API/Client.hs index eecc682427b..cc513f7bfa8 100644 --- a/services/brig/src/Brig/API/Client.hs +++ b/services/brig/src/Brig/API/Client.hs @@ -75,6 +75,7 @@ import Data.ByteString (toStrict) import Data.ByteString.Conversion import Data.Code as Code import Data.Domain +import Data.HavePendingInvitations import Data.Id (ClientId, ConnId, UserId) import Data.List.Split (chunksOf) import Data.Map.Strict qualified as Map @@ -115,6 +116,8 @@ import Wire.Sem.Concurrency import Wire.Sem.FromUTC (FromUTC (fromUTCTime)) import Wire.Sem.Now as Now import Wire.Sem.Paging.Cassandra (InternalPaging) +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) lookupLocalClient :: UserId -> ClientId -> (AppT r) (Maybe Client) @@ -164,6 +167,7 @@ addClient :: ( Member GalleyAPIAccess r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member TinyLog r, Member DeleteQueue r, Member (Input (Local ())) r, @@ -172,7 +176,7 @@ addClient :: Member EmailSubsystem r, Member VerificationCodeSubsystem r ) => - UserId -> + Local UserId -> Maybe ConnId -> NewClient -> ExceptT ClientError (AppT r) Client @@ -191,16 +195,17 @@ addClientWithReAuthPolicy :: Member DeleteQueue r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => Data.ReAuthPolicy -> - UserId -> + Local UserId -> Maybe ConnId -> NewClient -> ExceptT ClientError (AppT r) Client -addClientWithReAuthPolicy policy u con new = do - acc <- lift (wrapClient $ Data.lookupAccount u) >>= maybe (throwE (ClientUserNotFound u)) pure - verifyCode (newClientVerificationCode new) (userId . accountUser $ acc) +addClientWithReAuthPolicy policy luid@(tUnqualified -> u) con new = do + usr <- (lift . liftSem $ User.getAccountNoFilter luid) >>= maybe (throwE (ClientUserNotFound u)) (pure . (.accountUser)) + verifyCode (newClientVerificationCode new) luid maxPermClients <- fromMaybe Opt.defUserMaxPermClients . Opt.setUserMaxPermClients <$> view settings let caps :: Maybe (Set ClientCapability) caps = updlhdev $ newClientCapabilities new @@ -212,10 +217,9 @@ addClientWithReAuthPolicy policy u con new = do lhcaps = ClientSupportsLegalholdImplicitConsent (clt0, old, count) <- wrapClientE - (Data.addClientWithReAuthPolicy policy u clientId' new maxPermClients caps) + (Data.addClientWithReAuthPolicy policy luid clientId' new maxPermClients caps) !>> ClientDataError let clt = clt0 {clientMLSPublicKeys = newClientMLSPublicKeys new} - let usr = accountUser acc lift $ do for_ old $ execDelete u con liftSem $ GalleyAPIAccess.newClient u (clientId clt) @@ -231,12 +235,12 @@ addClientWithReAuthPolicy policy u con new = do verifyCode :: Maybe Code.Value -> - UserId -> + Local UserId -> ExceptT ClientError (AppT r) () - verifyCode mbCode uid = + verifyCode mbCode luid1 = -- this only happens inside the login flow (in particular, when logging in from a new device) -- the code obtained for logging in is used a second time for adding the device - UserAuth.verifyCode mbCode Code.Login uid `catchE` \case + UserAuth.verifyCode mbCode Code.Login luid1 `catchE` \case VerificationCodeRequired -> throwE ClientCodeAuthenticationRequired VerificationCodeNoPendingCode -> throwE ClientCodeAuthenticationFailed VerificationCodeNoEmail -> throwE ClientCodeAuthenticationFailed diff --git a/services/brig/src/Brig/API/Connection.hs b/services/brig/src/Brig/API/Connection.hs index f718cd465d1..cb3ed7e3dd0 100644 --- a/services/brig/src/Brig/API/Connection.hs +++ b/services/brig/src/Brig/API/Connection.hs @@ -72,6 +72,7 @@ import Wire.GalleyAPIAccess import Wire.GalleyAPIAccess qualified as GalleyAPIAccess import Wire.NotificationSubsystem import Wire.UserStore +import Wire.UserSubsystem ensureNotSameTeam :: (Member GalleyAPIAccess r) => Local UserId -> Local UserId -> (ConnectionM r) () ensureNotSameTeam self target = do @@ -86,6 +87,7 @@ createConnection :: Member NotificationSubsystem r, Member TinyLog r, Member UserStore r, + Member UserSubsystem r, Member (Embed HttpClientIO) r ) => Local UserId -> @@ -106,6 +108,7 @@ createConnectionToLocalUser :: Member NotificationSubsystem r, Member TinyLog r, Member UserStore r, + Member UserSubsystem r, Member (Embed HttpClientIO) r ) => Local UserId -> @@ -116,7 +119,7 @@ createConnectionToLocalUser self conn target = do ensureNotSameAndActivated self (tUntagged target) noteT (InvalidUser (tUntagged target)) $ ensureIsActivated target - checkLegalholdPolicyConflict (tUnqualified self) (tUnqualified target) + checkLegalholdPolicyConflict self target ensureNotSameTeam self target s2o <- lift . wrapClient $ Data.lookupConnection self (tUntagged target) o2s <- lift . wrapClient $ Data.lookupConnection target (tUntagged self) @@ -194,9 +197,9 @@ createConnectionToLocalUser self conn target = do -- FUTUREWORK: we may want to move this to the LH application logic, so we can recycle it for -- group conv creation and possibly other situations. checkLegalholdPolicyConflict :: - (Member GalleyAPIAccess r) => - UserId -> - UserId -> + (Member GalleyAPIAccess r, Member UserSubsystem r) => + Local UserId -> + Local UserId -> ExceptT ConnectionError (AppT r) () checkLegalholdPolicyConflict uid1 uid2 = do let catchProfileNotFound = diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index fd471ba62e7..03c9af86610 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -50,7 +50,6 @@ import Brig.IO.Intra qualified as Intra import Brig.Options hiding (internalEvents) import Brig.Provider.API qualified as Provider import Brig.Team.API qualified as Team -import Brig.Team.DB (lookupInvitationByEmail) import Brig.Types.Connection import Brig.Types.Intra import Brig.Types.Team.LegalHold (LegalHoldClientRequest (..)) @@ -66,6 +65,7 @@ import Data.CommaSeparatedList import Data.Default import Data.Domain (Domain) import Data.Handle +import Data.HavePendingInvitations import Data.Id as Id import Data.Map.Strict qualified as Map import Data.Qualified @@ -76,7 +76,7 @@ import Data.Time.Clock.System import Imports hiding (head) import Network.Wai.Utilities as Utilities import Polysemy -import Polysemy.Input (Input) +import Polysemy.Input (Input, input) import Polysemy.TinyLog (TinyLog) import Servant hiding (Handler, JSON, addHeader, respond) import Servant.OpenApi.Internal.Orphans () @@ -100,11 +100,13 @@ import Wire.API.User.RichInfo import Wire.API.UserEvent import Wire.AuthenticationSubsystem (AuthenticationSubsystem) import Wire.BlockListStore (BlockListStore) -import Wire.DeleteQueue +import Wire.DeleteQueue (DeleteQueue) import Wire.EmailSending (EmailSending) import Wire.EmailSubsystem (EmailSubsystem) -import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) +import Wire.GalleyAPIAccess (GalleyAPIAccess) +import Wire.InvitationCodeStore import Wire.NotificationSubsystem +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PropertySubsystem import Wire.Rpc import Wire.Sem.Concurrency @@ -132,6 +134,7 @@ servantSitemap :: Member NotificationSubsystem r, Member UserSubsystem r, Member UserStore r, + Member InvitationCodeStore r, Member UserKeyStore r, Member Rpc r, Member TinyLog r, @@ -139,6 +142,7 @@ servantSitemap :: Member EmailSending r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, + Member PasswordResetCodeStore r, Member PropertySubsystem r ) => ServerT BrigIRoutes.API (Handler r) @@ -190,7 +194,9 @@ accountAPI :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member PasswordResetCodeStore r, + Member InvitationCodeStore r ) => ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = @@ -240,6 +246,7 @@ teamsAPI :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member InvitationCodeStore r, Member (ConnectionStore InternalPaging) r, Member EmailSending r, Member UserSubsystem r @@ -268,6 +275,7 @@ authAPI :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, @@ -278,7 +286,13 @@ authAPI = Named @"legalhold-login" (callsFed (exposeAnnotations legalHoldLogin)) :<|> Named @"sso-login" (callsFed (exposeAnnotations ssoLogin)) :<|> Named @"login-code" getLoginCode - :<|> Named @"reauthenticate" reauthenticate + :<|> Named @"reauthenticate" + ( \uid reauth -> + -- changing this end-point would involve providing a `Local` type from a user id that is + -- captured from the path, not pulled from the http header. this is certainly feasible, + -- but running qualifyLocal here is easier. + qualifyLocal uid >>= \luid -> reauthenticate luid reauth + ) federationRemotesAPI :: (Member FederationConfigStore r) => ServerT BrigIRoutes.FederationRemotesAPI (Handler r) federationRemotesAPI = @@ -408,6 +422,7 @@ addClientInternalH :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => UserId -> @@ -419,7 +434,8 @@ addClientInternalH usr mSkipReAuth new connId = do let policy | mSkipReAuth == Just True = \_ _ -> False | otherwise = Data.reAuthForNewClients - API.addClientWithReAuthPolicy policy usr connId new !>> clientError + lusr <- qualifyLocal usr + API.addClientWithReAuthPolicy policy lusr connId new !>> clientError legalHoldClientRequestedH :: ( Member (Embed HttpClientIO) r, @@ -465,9 +481,12 @@ createUserNoVerify :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member InvitationCodeStore r, Member UserKeyStore r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member (ConnectionStore InternalPaging) r ) => NewUser -> @@ -492,6 +511,7 @@ createUserNoVerifySpar :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member (ConnectionStore InternalPaging) r ) => NewUserSpar -> @@ -515,6 +535,7 @@ deleteUserNoAuthH :: Member UserStore r, Member TinyLog r, Member UserKeyStore r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, @@ -523,7 +544,8 @@ deleteUserNoAuthH :: UserId -> (Handler r) DeleteUserResponse deleteUserNoAuthH uid = do - r <- lift $ API.ensureAccountDeleted uid + luid <- qualifyLocal uid + r <- lift $ API.ensureAccountDeleted luid case r of NoUser -> throwStd (errorToWai @'E.UserNotFound) AccountAlreadyDeleted -> pure UserResponseAccountAlreadyDeleted @@ -549,9 +571,8 @@ changeSelfEmailMaybeSend u DoNotSendEmail email allowScim = do -- handler allows up to 4 lists of various user keys, and returns the union of the lookups. -- Empty list is forbidden for backwards compatibility. listActivatedAccountsH :: - ( Member DeleteQueue r, - Member UserKeyStore r, - Member UserStore r + ( Member (Input (Local ())) r, + Member UserSubsystem r ) => Maybe (CommaSeparatedList UserId) -> Maybe (CommaSeparatedList Handle) -> @@ -562,50 +583,21 @@ listActivatedAccountsH (maybe [] fromCommaSeparatedList -> uids) (maybe [] fromCommaSeparatedList -> handles) (maybe [] fromCommaSeparatedList -> emails) - (fromMaybe False -> includePendingInvitations) = do + (maybe NoPendingInvitations fromBool -> include) = do when (length uids + length handles + length emails == 0) $ do throwStd (notFound "no user keys") - lift $ do - u1 <- listActivatedAccounts (Left uids) includePendingInvitations - u2 <- listActivatedAccounts (Right handles) includePendingInvitations - u3 <- (\email -> API.lookupExtendedAccountsByIdentity email includePendingInvitations) `mapM` emails - pure $ u1 <> u2 <> join u3 - --- FUTUREWORK: this should use UserStore only through UserSubsystem. -listActivatedAccounts :: - (Member DeleteQueue r, Member UserStore r) => - Either [UserId] [Handle] -> - Bool -> - AppT r [ExtendedUserAccount] -listActivatedAccounts elh includePendingInvitations = do - Log.debug (Log.msg $ "listActivatedAccounts: " <> show (elh, includePendingInvitations)) - case elh of - Left us -> byIds us - Right hs -> do - us <- liftSem $ mapM API.lookupHandle hs - byIds (catMaybes us) - where - byIds :: (Member DeleteQueue r) => [UserId] -> (AppT r) [ExtendedUserAccount] - byIds uids = wrapClient (API.lookupExtendedAccounts uids) >>= filterM accountValid - - accountValid :: (Member DeleteQueue r) => ExtendedUserAccount -> (AppT r) Bool - accountValid (account -> acc) = case userIdentity . accountUser $ acc of - Nothing -> pure False - Just ident -> - case (accountStatus acc, includePendingInvitations, emailIdentity ident) of - (PendingInvitation, False, _) -> pure False - (PendingInvitation, True, Just email) -> do - hasInvitation <- isJust <$> wrapClient (lookupInvitationByEmail HideInvitationUrl email) - unless hasInvitation $ do - -- user invited via scim should expire together with its invitation - liftSem $ API.deleteUserNoVerify (userId . accountUser $ acc) - pure hasInvitation - (PendingInvitation, True, Nothing) -> - pure True -- cannot happen, user invited via scim always has an email - (Active, _, _) -> pure True - (Suspended, _, _) -> pure True - (Deleted, _, _) -> pure True - (Ephemeral, _, _) -> pure True + lift $ liftSem do + loc <- input + byEmails <- getExtendedAccountsByEmailNoFilter $ loc $> emails + others <- + getExtendedAccountsBy $ + loc + $> def + { includePendingInvitations = include, + getByUserId = uids, + getByHandle = handles + } + pure $ others <> byEmails getActivationCode :: EmailAddress -> Handler r GetActivationCodeResp getActivationCode email = do diff --git a/services/brig/src/Brig/API/OAuth.hs b/services/brig/src/Brig/API/OAuth.hs index 9e06bc14d4d..145d0772959 100644 --- a/services/brig/src/Brig/API/OAuth.hs +++ b/services/brig/src/Brig/API/OAuth.hs @@ -39,6 +39,7 @@ import Data.Id import Data.Json.Util (toUTCTimeMillis) import Data.Map qualified as Map import Data.Misc +import Data.Qualified import Data.Set qualified as Set import Data.Text.Ascii import Data.Text.Encoding qualified as T @@ -67,7 +68,7 @@ import Wire.Sem.Now qualified as Now internalOauthAPI :: ServerT I.OAuthAPI (Handler r) internalOauthAPI = Named @"create-oauth-client" registerOAuthClient - :<|> Named @"get-oauth-client" getOAuthClientById + :<|> Named @"i-get-oauth-client" getOAuthClientById :<|> Named @"update-oauth-client" updateOAuthClient :<|> Named @"delete-oauth-client" deleteOAuthClient @@ -122,14 +123,14 @@ deleteOAuthClient cid = do void $ getOAuthClientById cid lift $ wrapClient $ deleteOAuthClient' cid -getOAuthClient :: UserId -> OAuthClientId -> (Handler r) (Maybe OAuthClient) +getOAuthClient :: Local UserId -> OAuthClientId -> (Handler r) (Maybe OAuthClient) getOAuthClient _ cid = do unlessM (Opt.setOAuthEnabled <$> view settings) $ throwStd $ errorToWai @'OAuthFeatureDisabled lift $ wrapClient $ lookupOauthClient cid -createNewOAuthAuthorizationCode :: UserId -> CreateOAuthAuthorizationCodeRequest -> (Handler r) CreateOAuthCodeResponse -createNewOAuthAuthorizationCode uid code = do - runExceptT (validateAndCreateAuthorizationCode uid code) >>= \case +createNewOAuthAuthorizationCode :: Local UserId -> CreateOAuthAuthorizationCodeRequest -> (Handler r) CreateOAuthCodeResponse +createNewOAuthAuthorizationCode luid code = do + runExceptT (validateAndCreateAuthorizationCode luid code) >>= \case Right oauthCode -> pure $ CreateOAuthCodeSuccess $ @@ -174,11 +175,11 @@ data CreateNewOAuthCodeError | CreateNewOAuthCodeErrorUnsupportedResponseType | CreateNewOAuthCodeErrorRedirectUrlMissMatch -validateAndCreateAuthorizationCode :: UserId -> CreateOAuthAuthorizationCodeRequest -> ExceptT CreateNewOAuthCodeError (Handler r) OAuthAuthorizationCode -validateAndCreateAuthorizationCode uid (CreateOAuthAuthorizationCodeRequest cid scope responseType redirectUrl _state _ chal) = do +validateAndCreateAuthorizationCode :: Local UserId -> CreateOAuthAuthorizationCodeRequest -> ExceptT CreateNewOAuthCodeError (Handler r) OAuthAuthorizationCode +validateAndCreateAuthorizationCode luid@(tUnqualified -> uid) (CreateOAuthAuthorizationCodeRequest cid scope responseType redirectUrl _state _ chal) = do failWithM CreateNewOAuthCodeErrorFeatureDisabled (assertMay . Opt.setOAuthEnabled <$> view settings) failWith CreateNewOAuthCodeErrorUnsupportedResponseType (assertMay $ responseType == OAuthResponseTypeCode) - client <- failWithM CreateNewOAuthCodeErrorClientNotFound $ getOAuthClient uid cid + client <- failWithM CreateNewOAuthCodeErrorClientNotFound $ getOAuthClient luid cid failWith CreateNewOAuthCodeErrorRedirectUrlMissMatch (assertMay $ client.redirectUrl == redirectUrl) lift mkAuthorizationCode where @@ -201,7 +202,8 @@ createAccessTokenWithRefreshToken req = do unless (req.grantType == OAuthGrantTypeRefreshToken) $ throwStd $ errorToWai @'OAuthInvalidGrantType key <- signingKey (OAuthRefreshTokenInfo _ cid uid scope _) <- lookupVerifyAndDeleteToken key req.refreshToken - void $ getOAuthClient uid cid >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure + luid <- qualifyLocal uid + void $ getOAuthClient luid cid >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure unless (cid == req.clientId) $ throwStd $ errorToWai @'OAuthInvalidClientCredentials createAccessToken key uid cid scope @@ -226,7 +228,8 @@ createAccessTokenWithAuthorizationCode req = do (cid, uid, scope, uri, mChal) <- lift (wrapClient $ lookupAndDeleteByOAuthAuthorizationCode req.code) >>= maybe (throwStd $ errorToWai @'OAuthAuthorizationCodeNotFound) pure - oauthClient <- getOAuthClient uid req.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure + luid <- qualifyLocal uid + oauthClient <- getOAuthClient luid req.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure unless (uri == req.redirectUri) $ throwStd $ errorToWai @'OAuthRedirectUrlMissMatch unless (oauthClient.redirectUrl == req.redirectUri) $ throwStd $ errorToWai @'OAuthRedirectUrlMissMatch @@ -305,7 +308,8 @@ revokeRefreshToken :: (Member Jwk r) => OAuthRevokeRefreshTokenRequest -> (Handl revokeRefreshToken req = do key <- signingKey info <- lookupAndVerifyToken key req.refreshToken - void $ getOAuthClient info.userId info.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure + luid <- qualifyLocal info.userId + void $ getOAuthClient luid info.clientId >>= maybe (throwStd $ errorToWai @'OAuthClientNotFound) pure lift $ wrapClient $ deleteOAuthRefreshToken info.userId info.refreshTokenId lookupAndVerifyToken :: JWK -> OAuthRefreshToken -> (Handler r) OAuthRefreshTokenInfo @@ -316,8 +320,8 @@ lookupAndVerifyToken key = . lookupOAuthRefreshTokenInfo >=> maybe (throwStd $ errorToWai @'OAuthInvalidRefreshToken) pure -getOAuthApplications :: UserId -> (Handler r) [OAuthApplication] -getOAuthApplications uid = do +getOAuthApplications :: Local UserId -> (Handler r) [OAuthApplication] +getOAuthApplications (tUnqualified -> uid) = do activeRefreshTokens <- lift $ wrapClient $ lookupOAuthRefreshTokens uid toApplications activeRefreshTokens where @@ -325,26 +329,27 @@ getOAuthApplications uid = do toApplications infos = do let grouped = Map.fromListWith (<>) $ (\info -> (info.clientId, [info])) <$> infos mApps <- for (Map.toList grouped) $ \(cid, tokens) -> do - mClient <- getOAuthClient uid cid + let luid = undefined uid + mClient <- getOAuthClient luid cid pure $ (\client -> OAuthApplication cid client.name ((\i -> OAuthSession i.refreshTokenId (toUTCTimeMillis i.createdAt)) <$> tokens)) <$> mClient pure $ catMaybes mApps -revokeOAuthAccountAccessV6 :: UserId -> OAuthClientId -> (Handler r) () -revokeOAuthAccountAccessV6 uid cid = do +revokeOAuthAccountAccessV6 :: Local UserId -> OAuthClientId -> (Handler r) () +revokeOAuthAccountAccessV6 (tUnqualified -> uid) cid = do rts <- lift $ wrapClient $ lookupOAuthRefreshTokens uid for_ rts $ \rt -> when (rt.clientId == cid) $ lift $ wrapClient $ deleteOAuthRefreshToken uid rt.refreshTokenId -revokeOAuthAccountAccess :: UserId -> OAuthClientId -> PasswordReqBody -> (Handler r) () -revokeOAuthAccountAccess uid cid req = do - wrapClientE $ reauthenticate uid req.fromPasswordReqBody !>> toAccessDenied - revokeOAuthAccountAccessV6 uid cid +revokeOAuthAccountAccess :: Local UserId -> OAuthClientId -> PasswordReqBody -> (Handler r) () +revokeOAuthAccountAccess luid@(tUnqualified -> uid) cid req = do + wrapClientE (reauthenticate uid req.fromPasswordReqBody) !>> toAccessDenied + revokeOAuthAccountAccessV6 luid cid where toAccessDenied :: ReAuthError -> HttpError toAccessDenied _ = StdError $ errorToWai @'AccessDenied -deleteOAuthRefreshTokenById :: UserId -> OAuthClientId -> OAuthRefreshTokenId -> PasswordReqBody -> (Handler r) () -deleteOAuthRefreshTokenById uid cid tokenId req = do - wrapClientE $ reauthenticate uid req.fromPasswordReqBody !>> toAccessDenied +deleteOAuthRefreshTokenById :: Local UserId -> OAuthClientId -> OAuthRefreshTokenId -> PasswordReqBody -> (Handler r) () +deleteOAuthRefreshTokenById (tUnqualified -> uid) cid tokenId req = do + wrapClientE (reauthenticate uid req.fromPasswordReqBody) !>> toAccessDenied mInfo <- lift $ wrapClient $ lookupOAuthRefreshTokenInfo tokenId case mInfo of Nothing -> pure () diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index dc58cb86e28..554eceb5b85 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -53,7 +53,6 @@ import Brig.Team.API qualified as Team import Brig.Team.Email qualified as Team import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra (UserAccount (UserAccount, accountUser)) -import Brig.Types.User (HavePendingInvitations (..)) import Brig.User.API.Handle qualified as Handle import Brig.User.API.Search (teamUserSearch) import Brig.User.API.Search qualified as Search @@ -75,6 +74,7 @@ import Data.Domain import Data.FileEmbed import Data.Handle (Handle) import Data.Handle qualified as Handle +import Data.HavePendingInvitations import Data.Id import Data.Id qualified as Id import Data.List.NonEmpty (nonEmpty) @@ -152,7 +152,9 @@ import Wire.EmailSubsystem import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.InvitationCodeStore import Wire.NotificationSubsystem +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PasswordStore (PasswordStore, lookupHashedPassword) import Wire.PropertySubsystem import Wire.Sem.Concurrency @@ -162,7 +164,7 @@ import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserStore (UserStore) import Wire.UserSubsystem hiding (checkHandle, checkHandles) -import Wire.UserSubsystem qualified as UserSubsystem +import Wire.UserSubsystem qualified as User import Wire.VerificationCode import Wire.VerificationCodeGen import Wire.VerificationCodeSubsystem @@ -285,7 +287,9 @@ servantSitemap :: Member EmailSubsystem r, Member EmailSending r, Member VerificationCodeSubsystem r, - Member PropertySubsystem r + Member PropertySubsystem r, + Member PasswordResetCodeStore r, + Member InvitationCodeStore r ) => ServerT BrigAPI (Handler r) servantSitemap = @@ -559,17 +563,18 @@ addClient :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => - UserId -> + Local UserId -> ConnId -> Public.NewClient -> Handler r Public.Client -addClient usr con new = do +addClient lusr con new = do -- Users can't add legal hold clients when (Public.newClientType new == Public.LegalHoldClientType) $ throwE (clientError ClientLegalHoldCannotBeAdded) - API.addClient usr (Just con) new + API.addClient lusr (Just con) new !>> clientError deleteClient :: @@ -623,21 +628,21 @@ getClientCapabilities uid cid = do mclient <- lift (API.lookupLocalClient uid cid) maybe (throwStd (errorToWai @'E.ClientNotFound)) (pure . Public.clientCapabilities) mclient -getRichInfo :: UserId -> UserId -> Handler r Public.RichInfoAssocList -getRichInfo self user = do +getRichInfo :: (Member UserSubsystem r) => Local UserId -> UserId -> Handler r Public.RichInfoAssocList +getRichInfo lself user = do + let luser = qualifyAs lself user -- Check that both users exist and the requesting user is allowed to see rich info of the -- other user - selfUser <- - ifNothing (errorToWai @'E.UserNotFound) - =<< lift (wrapClient $ Data.lookupUser NoPendingInvitations self) - otherUser <- - ifNothing (errorToWai @'E.UserNotFound) - =<< lift (wrapClient $ Data.lookupUser NoPendingInvitations user) + let fetch luid = + ifNothing (errorToWai @'E.UserNotFound) + =<< lift (liftSem $ (.accountUser) <$$> User.getLocalAccountBy NoPendingInvitations luid) + selfUser <- fetch lself + otherUser <- fetch luser case (Public.userTeam selfUser, Public.userTeam otherUser) of (Just t1, Just t2) | t1 == t2 -> pure () _ -> throwStd insufficientTeamPermissions -- Query rich info - wrapClientE $ fromMaybe mempty <$> API.lookupRichInfo user + wrapClientE $ fromMaybe mempty <$> API.lookupRichInfo (tUnqualified luser) getSupportedProtocols :: (Member UserSubsystem r) => @@ -681,6 +686,7 @@ createAccessToken method luid cid proof = do createUser :: ( Member BlockListStore r, Member GalleyAPIAccess r, + Member InvitationCodeStore r, Member (UserPendingActivationStore p) r, Member TinyLog r, Member (Embed HttpClientIO) r, @@ -690,6 +696,8 @@ createUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, + Member PasswordResetCodeStore r, Member EmailSending r ) => Public.NewUserPublic -> @@ -934,7 +942,7 @@ changeLocale lusr conn l = updateUserProfile lusr (Just conn) - UserSubsystem.UpdateOriginWireClient + User.UpdateOriginWireClient def {locale = Just l.luLocale} changeSupportedProtocols :: @@ -944,7 +952,7 @@ changeSupportedProtocols :: Public.SupportedProtocolUpdate -> Handler r () changeSupportedProtocols u conn (Public.SupportedProtocolUpdate prots) = - lift . liftSem $ UserSubsystem.updateUserProfile u (Just conn) UpdateOriginWireClient upd + lift . liftSem $ User.updateUserProfile u (Just conn) UpdateOriginWireClient upd where upd = def {supportedProtocols = Just prots} @@ -952,7 +960,7 @@ changeSupportedProtocols u conn (Public.SupportedProtocolUpdate prots) = -- *any* account.) checkHandle :: (Member UserSubsystem r) => UserId -> Text -> Handler r () checkHandle _uid hndl = - lift (liftSem $ UserSubsystem.checkHandle hndl) >>= \case + lift (liftSem $ User.checkHandle hndl) >>= \case API.CheckHandleFound -> pure () API.CheckHandleNotFound -> throwStd (errorToWai @'E.HandleNotFound) @@ -981,7 +989,7 @@ getHandleInfoUnqualifiedH self handle = do changeHandle :: (Member UserSubsystem r) => Local UserId -> ConnId -> Public.HandleUpdate -> Handler r () changeHandle u conn (Public.HandleUpdate h) = lift $ liftSem do - UserSubsystem.updateHandle u (Just conn) UpdateOriginWireClient h + User.updateHandle u (Just conn) UpdateOriginWireClient h beginPasswordReset :: (Member AuthenticationSubsystem r) => @@ -1041,6 +1049,7 @@ createConnectionUnqualified :: Member NotificationSubsystem r, Member TinyLog r, Member UserStore r, + Member UserSubsystem r, Member (Embed HttpClientIO) r ) => UserId -> @@ -1057,6 +1066,7 @@ createConnection :: Member GalleyAPIAccess r, Member NotificationSubsystem r, Member UserStore r, + Member UserSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r ) => @@ -1172,19 +1182,21 @@ deleteSelfUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r, Member PropertySubsystem r ) => - UserId -> + Local UserId -> Public.DeleteUser -> (Handler r) (Maybe Code.Timeout) -deleteSelfUser u body = do - API.deleteSelfUser u (Public.deleteUserPassword body) !>> deleteUserError +deleteSelfUser lu body = do + API.deleteSelfUser lu (Public.deleteUserPassword body) !>> deleteUserError verifyDeleteUser :: ( Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member UserStore r, + Member UserSubsystem r, Member TinyLog r, Member (Input (Local ())) r, Member UserKeyStore r, @@ -1235,8 +1247,10 @@ activate :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member (ConnectionStore InternalPaging) r ) => Public.ActivationKey -> @@ -1252,8 +1266,10 @@ activateKey :: Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, + Member UserSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, Member (ConnectionStore InternalPaging) r ) => Public.Activate -> @@ -1275,7 +1291,9 @@ sendVerificationCode :: forall r. ( Member GalleyAPIAccess r, Member UserKeyStore r, + Member (Input (Local ())) r, Member EmailSubsystem r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => Public.SendVerificationCode -> @@ -1301,9 +1319,10 @@ sendVerificationCode req = do _ -> pure () where getAccount :: Public.EmailAddress -> (Handler r) (Maybe UserAccount) - getAccount email = lift $ do - mbUserId <- liftSem $ lookupKey $ mkEmailKey email - join <$> wrapClient (Data.lookupAccount `traverse` mbUserId) + getAccount email = lift . liftSem $ do + mbUserId <- lookupKey $ mkEmailKey email + mbLUserId <- qualifyLocal' `traverse` mbUserId + join <$> User.getAccountNoFilter `traverse` mbLUserId sendMail :: Public.EmailAddress -> Code.Value -> Maybe Public.Locale -> Public.VerificationAction -> (Handler r) () sendMail email value mbLocale = diff --git a/services/brig/src/Brig/API/Types.hs b/services/brig/src/Brig/API/Types.hs index 028b87d541d..076b844e1fc 100644 --- a/services/brig/src/Brig/API/Types.hs +++ b/services/brig/src/Brig/API/Types.hs @@ -69,6 +69,7 @@ data ActivationResult ActivationSuccess !(Maybe UserIdentity) !Bool | -- | The key/code was valid but already recently activated. ActivationPass + deriving (Show) -- | Outcome of the invariants check in 'Brig.API.User.changeEmail'. data ChangeEmailResult @@ -76,6 +77,7 @@ data ChangeEmailResult ChangeEmailNeedsActivation !(User, Activation, EmailAddress) | -- | The user asked to change the email address to the one already owned ChangeEmailIdempotent + deriving (Show) ------------------------------------------------------------------------------- -- Failures diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 84059ff5435..4f76936fae7 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -31,11 +31,6 @@ module Brig.API.User lookupHandle, changeAccountStatus, changeSingleAccountStatus, - Data.lookupAccounts, - Data.lookupExtendedAccounts, - Data.lookupAccount, - lookupAccountsByIdentity, - lookupExtendedAccountsByIdentity, getLegalHoldStatus, Data.lookupName, Data.lookupUser, @@ -89,8 +84,7 @@ import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivation (..), UserPendingActivationStore) import Brig.Effects.UserPendingActivationStore qualified as UserPendingActivationStore import Brig.IO.Intra qualified as Intra -import Brig.Options hiding (Timeout, internalEvents) -import Brig.Team.DB qualified as Team +import Brig.Options hiding (internalEvents) import Brig.Types.Activation (ActivationPair) import Brig.Types.Intra import Brig.User.Auth.Cookie qualified as Auth @@ -102,6 +96,7 @@ import Control.Lens (preview, to, view, (^.), _Just) import Control.Monad.Catch import Data.ByteString.Conversion import Data.Code +import Data.Coerce (coerce) import Data.Currency qualified as Currency import Data.Handle (Handle (fromHandle)) import Data.Id as Id @@ -129,8 +124,6 @@ import Wire.API.Error.Brig qualified as E import Wire.API.Password import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Team hiding (newTeam) -import Wire.API.Team.Invitation -import Wire.API.Team.Invitation qualified as Team import Wire.API.Team.Member (legalHoldStatus) import Wire.API.Team.Role import Wire.API.Team.Size @@ -145,7 +138,10 @@ import Wire.DeleteQueue import Wire.EmailSubsystem import Wire.Error import Wire.GalleyAPIAccess as GalleyAPIAccess +import Wire.InvitationCodeStore (InvitationCodeStore, StoredInvitation, StoredInvitationInfo) +import Wire.InvitationCodeStore qualified as InvitationCodeStore import Wire.NotificationSubsystem +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) import Wire.PasswordStore (PasswordStore, lookupHashedPassword, upsertHashedPassword) import Wire.PropertySubsystem as PropertySubsystem import Wire.Sem.Concurrency @@ -246,7 +242,7 @@ createUserSpar new = do addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> Role -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident role = do let uid = userId (accountUser account) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid (Nothing, role) + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid Nothing role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -267,12 +263,15 @@ createUser :: Member GalleyAPIAccess r, Member (UserPendingActivationStore p) r, Member UserKeyStore r, + Member UserSubsystem r, Member TinyLog r, Member (Embed HttpClientIO) r, Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member PasswordResetCodeStore r, + Member InvitationCodeStore r ) => NewUser -> ExceptT RegisterError (AppT r) CreateUserResult @@ -295,8 +294,14 @@ createUser new = do pure (Nothing, Nothing, Just tid) Nothing -> pure (Nothing, Nothing, Nothing) - let mbInv = Team.inInvitation . fst <$> teamInvitation - mbExistingAccount <- lift $ join <$> for mbInv (\(Id uuid) -> wrapClient $ Data.lookupAccount (Id uuid)) + let mbInv = (.invitationId) . fst <$> teamInvitation + mbExistingAccount <- + lift $ + join + <$> for mbInv do + \invid -> liftSem $ do + luid :: Local UserId <- qualifyLocal' (coerce invid) + User.getLocalAccountBy WithPendingInvitations luid let (new', mbHandle) = case mbExistingAccount of Nothing -> @@ -337,7 +342,7 @@ createUser new = do pure account - let uid = userId (accountUser account) + let uid = qUnqualified account.accountUser.userQualifiedId createUserTeam <- do activatedTeam <- lift $ do @@ -354,10 +359,9 @@ createUser new = do joinedTeamInvite <- case teamInvitation of Just (inv, invInfo) -> do - let em = Team.inInviteeEmail inv - acceptTeamInvitation account inv invInfo (mkEmailKey em) (EmailIdentity em) - Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName (Team.inTeam inv) - pure (Just $ CreateUserTeam (Team.inTeam inv) nm) + acceptTeamInvitation account inv invInfo (mkEmailKey inv.email) (EmailIdentity inv.email) + Team.TeamName nm <- lift $ liftSem $ GalleyAPIAccess.getTeamName inv.teamId + pure (Just $ CreateUserTeam inv.teamId nm) Nothing -> pure Nothing joinedTeamSSO <- case (newUserIdentity new', tid) of @@ -385,17 +389,25 @@ createUser new = do pure email - findTeamInvitation :: Maybe EmailKey -> InvitationCode -> ExceptT RegisterError (AppT r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) + findTeamInvitation :: + Maybe EmailKey -> + InvitationCode -> + ExceptT + RegisterError + (AppT r) + ( Maybe + (StoredInvitation, StoredInvitationInfo, TeamId) + ) findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = - lift (wrapClient $ Team.lookupInvitationInfo c) >>= \case - Just ii -> do - inv <- lift . wrapClient $ Team.lookupInvitation HideInvitationUrl (Team.iiTeam ii) (Team.iiInvId ii) - case (inv, Team.inInviteeEmail <$> inv) of + lift (liftSem $ InvitationCodeStore.lookupInvitationInfo c) >>= \case + Just invitationInfo -> do + inv <- lift . liftSem $ InvitationCodeStore.lookupInvitation invitationInfo.teamId invitationInfo.invitationId + case (inv, (.email) <$> inv) of (Just invite, Just em) | e == mkEmailKey em -> do - _ <- ensureMemberCanJoin (Team.iiTeam ii) - pure $ Just (invite, ii, Team.iiTeam ii) + ensureMemberCanJoin invitationInfo.teamId + pure $ Just (invite, invitationInfo, invitationInfo.teamId) _ -> throwE RegisterErrorInvalidInvitationCode Nothing -> throwE RegisterErrorInvalidInvitationCode @@ -414,37 +426,38 @@ createUser new = do acceptTeamInvitation :: UserAccount -> - Team.Invitation -> - Team.InvitationInfo -> + StoredInvitation -> + StoredInvitationInfo -> EmailKey -> UserIdentity -> ExceptT RegisterError (AppT r) () - acceptTeamInvitation account inv ii uk ident = do + acceptTeamInvitation account inv invitationInfo uk ident = do let uid = userId (accountUser account) ok <- lift $ liftSem $ claimKey uk uid unless ok $ throwE RegisterErrorUserKeyExists - let minvmeta :: (Maybe (UserId, UTCTimeMillis), Role) - minvmeta = ((,inCreatedAt inv) <$> inCreatedBy inv, Team.inRole inv) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid (Team.iiTeam ii) minvmeta + let minvmeta :: Maybe (UserId, UTCTimeMillis) + minvmeta = (,inv.createdAt) <$> inv.createdBy + role :: Role + role = fromMaybe defaultRole inv.role + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid invitationInfo.teamId minvmeta role unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do wrapClient $ activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) void $ onActivated (AccountActivated account) - liftSem $ + liftSem do Log.info $ field "user" (toByteString uid) - . field "team" (toByteString $ Team.iiTeam ii) + . field "team" (toByteString $ invitationInfo.teamId) . msg (val "Accepting invitation") - liftSem $ UserPendingActivationStore.remove uid - wrapClient $ do - Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) + UserPendingActivationStore.remove uid + InvitationCodeStore.deleteInvitation inv.teamId inv.invitationId addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppT r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) - added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid (Nothing, defaultRole) + added <- lift $ liftSem $ GalleyAPIAccess.addTeamMember uid tid Nothing defaultRole unless added $ throwE RegisterErrorTooManyTeamMembers lift $ do @@ -493,10 +506,10 @@ createUserInviteViaScim :: ) => NewUserScimInvitation -> ExceptT HttpError (AppT r) UserAccount -createUserInviteViaScim (NewUserScimInvitation tid uid eid loc name email _) = do +createUserInviteViaScim (NewUserScimInvitation tid uid extId loc name email _) = do let emKey = mkEmailKey email verifyUniquenessAndCheckBlacklist emKey !>> identityErrorToBrigError - account <- lift . wrapClient $ newAccountInviteViaScim uid eid tid loc name email + account <- lift . wrapClient $ newAccountInviteViaScim uid extId tid loc name email lift . liftSem . Log.debug $ field "user" (toByteString . userId . accountUser $ account) . field "action" (val "User.createUserInviteViaScim") -- add the expiry table entry first! (if brig creates an account, and then crashes before @@ -683,7 +696,9 @@ activate :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member PasswordResetCodeStore r, + Member UserSubsystem r ) => ActivationTarget -> ActivationCode -> @@ -699,6 +714,8 @@ activateWithCurrency :: Member NotificationSubsystem r, Member (Input (Local ())) r, Member (Input UTCTime) r, + Member PasswordResetCodeStore r, + Member UserSubsystem r, Member (ConnectionStore InternalPaging) r ) => ActivationTarget -> @@ -715,7 +732,7 @@ activateWithCurrency tgt code usr cur = do field "activation.key" (toByteString key) . field "activation.code" (toByteString code) . msg (val "Activating") - event <- wrapClientE $ Data.activateKey key code usr + event <- Data.activateKey key code usr case event of Nothing -> pure ActivationPass Just e -> do @@ -876,13 +893,14 @@ deleteSelfUser :: Member (ConnectionStore InternalPaging) r, Member EmailSubsystem r, Member VerificationCodeSubsystem r, + Member UserSubsystem r, Member PropertySubsystem r ) => - UserId -> + Local UserId -> Maybe PlainTextPassword6 -> ExceptT DeleteUserError (AppT r) (Maybe Timeout) -deleteSelfUser uid pwd = do - account <- lift . wrapClient $ Data.lookupAccount uid +deleteSelfUser luid@(tUnqualified -> uid) pwd = do + account <- lift . liftSem $ User.getAccountNoFilter luid case account of Nothing -> throwE DeleteUserInvalid Just a -> case accountStatus a of @@ -948,6 +966,7 @@ verifyDeleteUser :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member VerificationCodeSubsystem r, + Member UserSubsystem r, Member PropertySubsystem r ) => VerifyDeleteUser -> @@ -957,7 +976,8 @@ verifyDeleteUser d = do let code = verifyDeleteUserCode d c <- lift . liftSem $ verifyCode key VerificationCode.AccountDeletion code a <- maybe (throwE DeleteUserInvalidCode) pure (VerificationCode.codeAccount =<< c) - account <- lift . wrapClient $ Data.lookupAccount (Id a) + luid <- qualifyLocal $ Id a + account <- lift . liftSem $ User.getAccountNoFilter luid for_ account $ lift . liftSem . deleteAccount lift . liftSem $ deleteCode key VerificationCode.AccountDeletion @@ -975,12 +995,13 @@ ensureAccountDeleted :: Member (Input UTCTime) r, Member (ConnectionStore InternalPaging) r, Member UserStore r, + Member UserSubsystem r, Member PropertySubsystem r ) => - UserId -> + Local UserId -> AppT r DeleteUserResult -ensureAccountDeleted uid = do - mbAcc <- wrapClient $ lookupAccount uid +ensureAccountDeleted luid@(tUnqualified -> uid) = do + mbAcc <- liftSem $ User.getAccountNoFilter luid case mbAcc of Nothing -> pure NoUser Just acc -> do @@ -1108,10 +1129,15 @@ enqueueMultiDeleteCallsCounter = } getLegalHoldStatus :: - (Member GalleyAPIAccess r) => - UserId -> + ( Member GalleyAPIAccess r, + Member UserSubsystem r + ) => + Local UserId -> AppT r (Maybe UserLegalHoldStatus) -getLegalHoldStatus uid = traverse (liftSem . getLegalHoldStatus' . accountUser) =<< wrapHttpClient (lookupAccount uid) +getLegalHoldStatus uid = + liftSem $ + traverse (getLegalHoldStatus' . accountUser) + =<< User.getLocalAccountBy NoPendingInvitations uid getLegalHoldStatus' :: (Member GalleyAPIAccess r) => @@ -1124,32 +1150,6 @@ getLegalHoldStatus' user = teamMember <- GalleyAPIAccess.getTeamMember (userId user) tid pure $ maybe defUserLegalHoldStatus (^. legalHoldStatus) teamMember --- | Find user accounts for a given identity, both activated and those --- currently pending activation. -lookupExtendedAccountsByIdentity :: - (Member UserKeyStore r) => - EmailAddress -> - Bool -> - AppT r [ExtendedUserAccount] -lookupExtendedAccountsByIdentity email includePendingInvitations = do - let uk = mkEmailKey email - activeUid <- liftSem $ lookupKey uk - uidFromKey <- (>>= fst) <$> wrapClient (Data.lookupActivationCode uk) - result <- wrapClient $ Data.lookupExtendedAccounts (nub $ catMaybes [activeUid, uidFromKey]) - if includePendingInvitations - then pure result - else pure $ filter ((/= PendingInvitation) . accountStatus . account) result - --- | Find user accounts for a given identity, both activated and those --- currently pending activation. -lookupAccountsByIdentity :: - (Member UserKeyStore r) => - EmailAddress -> - Bool -> - AppT r [UserAccount] -lookupAccountsByIdentity email includePendingInvitations = - account <$$> lookupExtendedAccountsByIdentity email includePendingInvitations - isBlacklisted :: (Member BlockListStore r) => EmailAddress -> AppT r Bool isBlacklisted email = do let uk = mkEmailKey email diff --git a/services/brig/src/Brig/App.hs b/services/brig/src/Brig/App.hs index 1df8edefd8e..882204e28d7 100644 --- a/services/brig/src/Brig/App.hs +++ b/services/brig/src/Brig/App.hs @@ -108,7 +108,7 @@ import Brig.User.Search.Index (IndexEnv (..), MonadIndexIO (..), runIndexIO) import Brig.User.Template import Brig.ZAuth (MonadZAuth (..), runZAuth) import Brig.ZAuth qualified as ZAuth -import Cassandra (MonadClient, runClient) +import Cassandra (runClient) import Cassandra qualified as Cas import Cassandra.Util (initCassandraForService) import Control.AutoUpdate @@ -621,13 +621,13 @@ instance HasRequestId (AppT r) where -- Ad hoc interpreters -- | similarly to `wrapClient`, this function serves as a crutch while Brig is being polysemised. -adhocUserKeyStoreInterpreter :: (MonadClient m, MonadReader Env m) => Sem '[UserKeyStore, UserStore, Embed IO] a -> m a +adhocUserKeyStoreInterpreter :: (MonadIO m, MonadReader Env m) => Sem '[UserKeyStore, UserStore, Embed IO] a -> m a adhocUserKeyStoreInterpreter action = do clientState <- asks (view casClient) liftIO $ runM . interpretUserStoreCassandra clientState . interpretUserKeyStoreCassandra clientState $ action -- | similarly to `wrapClient`, this function serves as a crutch while Brig is being polysemised. -adhocSessionStoreInterpreter :: (MonadClient m, MonadReader Env m) => Sem '[SessionStore, Embed IO] a -> m a +adhocSessionStoreInterpreter :: (MonadIO m, MonadReader Env m) => Sem '[SessionStore, Embed IO] a -> m a adhocSessionStoreInterpreter action = do clientState <- asks (view casClient) liftIO $ runM . interpretSessionStoreCassandra clientState $ action diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index ca597c1063a..88cbc80b02a 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -32,6 +32,8 @@ import Polysemy.TinyLog (TinyLog) import Wire.API.Allowlists (AllowlistEmailDomains) import Wire.API.Federation.Client qualified import Wire.API.Federation.Error +import Wire.ActivationCodeStore (ActivationCodeStore) +import Wire.ActivationCodeStore.Cassandra (interpretActivationCodeStoreToCassandra) import Wire.AuthenticationSubsystem import Wire.AuthenticationSubsystem.Interpreter import Wire.BlockListStore @@ -50,6 +52,8 @@ import Wire.GalleyAPIAccess (GalleyAPIAccess) import Wire.GalleyAPIAccess.Rpc import Wire.GundeckAPIAccess import Wire.HashPassword +import Wire.InvitationCodeStore (InvitationCodeStore) +import Wire.InvitationCodeStore.Cassandra (interpretInvitationCodeStoreToCassandra) import Wire.NotificationSubsystem import Wire.NotificationSubsystem.Interpreter (defaultNotificationSubsystemConfig, runNotificationSubsystemGundeck) import Wire.ParseException @@ -107,6 +111,8 @@ type BrigCanonicalEffects = SessionStore, PasswordStore, VerificationCodeStore, + ActivationCodeStore, + InvitationCodeStore, PropertyStore, SFT, ConnectionStore InternalPaging, @@ -196,6 +202,8 @@ runBrigToIO e (AppT ma) = do . connectionStoreToCassandra . interpretSFT (e ^. httpManager) . interpretPropertyStoreCassandra (e ^. casClient) + . interpretInvitationCodeStoreToCassandra (e ^. casClient) + . interpretActivationCodeStoreToCassandra (e ^. casClient) . interpretVerificationCodeStoreCassandra (e ^. casClient) . interpretPasswordStore (e ^. casClient) . interpretSessionStoreCassandra (e ^. casClient) diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index c4f84d77022..25745846b69 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -29,9 +29,8 @@ module Brig.Data.Activation ) where -import Brig.App (Env, adhocUserKeyStoreInterpreter) +import Brig.App (AppT, adhocUserKeyStoreInterpreter, liftSem, qualifyLocal, wrapClient, wrapClientE) import Brig.Data.User -import Brig.Options import Brig.Types.Intra import Cassandra import Control.Error @@ -45,12 +44,15 @@ import OpenSSL.BN (randIntegerZeroToNMinusOne) import OpenSSL.EVP.Digest (digestBS, getDigestByName) import Polysemy import Text.Printf (printf) +import Util.Timeout import Wire.API.User import Wire.API.User.Activation import Wire.API.User.Password -import Wire.PasswordResetCodeStore qualified as E -import Wire.PasswordResetCodeStore.Cassandra +import Wire.PasswordResetCodeStore (PasswordResetCodeStore) +import Wire.PasswordResetCodeStore qualified as Password import Wire.UserKeyStore +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User -- | The information associated with the pending activation of a 'UserKey'. data Activation = Activation @@ -79,6 +81,7 @@ activationErrorToRegisterError = \case data ActivationEvent = AccountActivated !UserAccount | EmailActivated !UserId !EmailAddress + deriving (Show) -- | Max. number of activation attempts per 'ActivationKey'. maxAttempts :: Int32 @@ -86,24 +89,30 @@ maxAttempts = 3 -- docs/reference/user/activation.md {#RefActivationSubmit} activateKey :: - forall m. - (MonadClient m, MonadReader Env m) => + forall r. + ( Member UserSubsystem r, + Member PasswordResetCodeStore r + ) => ActivationKey -> ActivationCode -> Maybe UserId -> - ExceptT ActivationError m (Maybe ActivationEvent) -activateKey k c u = verifyCode k c >>= pickUser >>= activate + ExceptT ActivationError (AppT r) (Maybe ActivationEvent) +activateKey k c u = wrapClientE (verifyCode k c) >>= pickUser >>= activate where + pickUser :: (t, Maybe UserId) -> ExceptT ActivationError (AppT r) (t, UserId) pickUser (uk, u') = maybe (throwE invalidUser) (pure . (uk,)) (u <|> u') - activate (key :: EmailKey, uid) = do - a <- lift (lookupAccount uid) >>= maybe (throwE invalidUser) pure + + activate :: (EmailKey, UserId) -> ExceptT ActivationError (AppT r) (Maybe ActivationEvent) + activate (key, uid) = do + luid <- qualifyLocal uid + a <- lift (liftSem $ User.getAccountNoFilter luid) >>= maybe (throwE invalidUser) pure unless (accountStatus a == Active) $ -- this is never 'PendingActivation' in the flow this function is used in. throwE invalidCode case userIdentity (accountUser a) of Nothing -> do claim key uid let ident = EmailIdentity (emailKeyOrig key) - lift $ activateUser uid ident + wrapClientE (activateUser uid ident) let a' = a {accountUser = (accountUser a) {userIdentity = Just ident}} pure . Just $ AccountActivated a' Just _ -> do @@ -111,6 +120,13 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate profileNeedsUpdate = Just (emailKeyOrig key) /= userEmail usr oldKey :: Maybe EmailKey = mkEmailKey <$> userEmail usr in handleExistingIdentity uid profileNeedsUpdate oldKey key + + handleExistingIdentity :: + UserId -> + Bool -> + Maybe EmailKey -> + EmailKey -> + ExceptT ActivationError (AppT r) (Maybe ActivationEvent) handleExistingIdentity uid profileNeedsUpdate oldKey key | oldKey == Just key && not profileNeedsUpdate = pure Nothing -- activating existing key and exactly same profile @@ -120,15 +136,17 @@ activateKey k c u = verifyCode k c >>= pickUser >>= activate pure . Just $ EmailActivated uid (emailKeyOrig key) -- if the key is the same, we only want to update our profile | otherwise = do - lift (runM (passwordResetCodeStoreToCassandra @m @'[Embed m] (E.codeDelete (mkPasswordResetKey uid)))) + lift . liftSem $ Password.codeDelete (mkPasswordResetKey uid) claim key uid lift $ updateEmailAndDeleteEmailUnvalidated uid (emailKeyOrig key) for_ oldKey $ lift . adhocUserKeyStoreInterpreter . deleteKey pure . Just $ EmailActivated uid (emailKeyOrig key) where - updateEmailAndDeleteEmailUnvalidated :: UserId -> EmailAddress -> m () + updateEmailAndDeleteEmailUnvalidated :: UserId -> EmailAddress -> AppT r () updateEmailAndDeleteEmailUnvalidated u' email = - updateEmail u' email <* deleteEmailUnvalidated u' + wrapClient (updateEmail u' email <* deleteEmailUnvalidated u') + + claim :: EmailKey -> UserId -> ExceptT ActivationError (AppT r) () claim key uid = do ok <- lift $ adhocUserKeyStoreInterpreter (claimKey key uid) unless ok $ diff --git a/services/brig/src/Brig/Data/Client.hs b/services/brig/src/Brig/Data/Client.hs index 4c0c2b3415c..9bae096a0f3 100644 --- a/services/brig/src/Brig/Data/Client.hs +++ b/services/brig/src/Brig/Data/Client.hs @@ -73,6 +73,7 @@ import Data.HashMap.Strict qualified as HashMap import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Map qualified as Map +import Data.Qualified import Data.Set qualified as Set import Data.Text qualified as Text import Data.Time.Clock @@ -115,8 +116,10 @@ reAuthForNewClients :: ReAuthPolicy reAuthForNewClients count upsert = count > 0 && not upsert addClient :: - (MonadClient m, MonadReader Brig.App.Env m) => - UserId -> + ( MonadClient m, + MonadReader Brig.App.Env m + ) => + Local UserId -> ClientId -> NewClient -> Int -> @@ -125,26 +128,28 @@ addClient :: addClient = addClientWithReAuthPolicy reAuthForNewClients addClientWithReAuthPolicy :: - (MonadClient m, MonadReader Brig.App.Env m) => + ( MonadClient m, + MonadReader Brig.App.Env m + ) => ReAuthPolicy -> - UserId -> + Local UserId -> ClientId -> NewClient -> Int -> Maybe (Imports.Set ClientCapability) -> ExceptT ClientDataError m (Client, [Client], Word) addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients cps = do - clients <- lookupClients u + clients <- lookupClients (tUnqualified u) let typed = filter ((== newClientType c) . clientType) clients let count = length typed let upsert = any exists typed when (reAuthPolicy count upsert) $ fmapLT ClientReAuthError $ - User.reauthenticate u (newClientPassword c) + User.reauthenticate (tUnqualified u) (newClientPassword c) let capacity = fmap (+ (-count)) limit unless (maybe True (> 0) capacity || upsert) $ throwE TooManyClients - new <- insert + new <- insert (tUnqualified u) let !total = fromIntegral (length clients + if upsert then 0 else 1) let old = maybe (filter (not . exists) typed) (const []) limit pure (new, old, total) @@ -158,16 +163,16 @@ addClientWithReAuthPolicy reAuthPolicy u newId c maxPermClients cps = do exists :: Client -> Bool exists = (==) newId . clientId - insert :: (MonadClient m, MonadReader Brig.App.Env m) => ExceptT ClientDataError m Client - insert = do + insert :: (MonadClient m, MonadReader Brig.App.Env m) => UserId -> ExceptT ClientDataError m Client + insert uid = do -- Is it possible to do this somewhere else? Otherwise we could use `MonadClient` instead now <- toUTCTimeMillis <$> (liftIO =<< view currentTime) let keys = unpackLastPrekey (newClientLastKey c) : newClientPrekeys c - updatePrekeys u newId keys + updatePrekeys uid newId keys let mdl = newClientModel c - prm = (u, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, mdl, C.Set . Set.toList <$> cps) + prm = (uid, newId, now, newClientType c, newClientLabel c, newClientClass c, newClientCookie c, mdl, C.Set . Set.toList <$> cps) retry x5 $ write insertClient (params LocalQuorum prm) - addMLSPublicKeys u newId (Map.assocs (newClientMLSPublicKeys c)) + addMLSPublicKeys uid newId (Map.assocs (newClientMLSPublicKeys c)) pure $! Client { clientId = newId, diff --git a/services/brig/src/Brig/Data/MLS/KeyPackage.hs b/services/brig/src/Brig/Data/MLS/KeyPackage.hs index b5242afd6fc..f2950c27cac 100644 --- a/services/brig/src/Brig/Data/MLS/KeyPackage.hs +++ b/services/brig/src/Brig/Data/MLS/KeyPackage.hs @@ -26,7 +26,7 @@ where import Brig.API.MLS.KeyPackages.Validation import Brig.App -import Brig.Options hiding (Timeout) +import Brig.Options import Cassandra import Control.Arrow import Control.Error diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index 14120bcd932..55412d7e069 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -32,9 +32,6 @@ module Brig.Data.User isSamlUser, -- * Lookups - lookupAccount, - lookupAccounts, - lookupExtendedAccounts, lookupUser, lookupUsers, lookupName, @@ -74,6 +71,7 @@ import Control.Lens hiding (from) import Data.Conduit (ConduitM) import Data.Domain import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Misc @@ -203,7 +201,13 @@ authenticate u pw = -- | Password reauthentication. If the account has a password, reauthentication -- is mandatory. If the account has no password, or is an SSO user, and no password is given, -- reauthentication is a no-op. -reauthenticate :: (MonadClient m, MonadReader Env m) => UserId -> Maybe PlainTextPassword6 -> ExceptT ReAuthError m () +reauthenticate :: + ( MonadClient m, + MonadReader Env m + ) => + UserId -> + Maybe PlainTextPassword6 -> + ExceptT ReAuthError m () reauthenticate u pw = lift (lookupAuth u) >>= \case Nothing -> throwE (ReAuthError AuthInvalidUser) @@ -215,17 +219,18 @@ reauthenticate u pw = Just (Just pw', Ephemeral) -> maybeReAuth pw' where maybeReAuth pw' = case pw of - Nothing -> unlessM (isSamlUser u) $ throwE ReAuthMissingPassword + Nothing -> do + musr <- lookupUser NoPendingInvitations u + unless (maybe False isSamlUser musr) $ throwE ReAuthMissingPassword Just p -> unless (verifyPassword p pw') $ throwE (ReAuthError AuthInvalidCredentials) -isSamlUser :: (MonadClient m, MonadReader Env m) => UserId -> m Bool -isSamlUser uid = do - account <- lookupAccount uid - case userIdentity . accountUser =<< account of - Just (SSOIdentity (UserSSOId _) _) -> pure True - _ -> pure False +isSamlUser :: User -> Bool +isSamlUser usr = do + case usr.userIdentity of + Just (SSOIdentity (UserSSOId _) _) -> True + _ -> False insertAccount :: (MonadClient m) => @@ -391,18 +396,6 @@ lookupUsers hpi usrs = do domain <- viewFederationDomain toUsers domain loc hpi <$> retry x1 (query usersSelect (params LocalQuorum (Identity usrs))) -lookupAccount :: (MonadClient m, MonadReader Env m) => UserId -> m (Maybe UserAccount) -lookupAccount u = listToMaybe <$> lookupAccounts [u] - -lookupAccounts :: (MonadClient m, MonadReader Env m) => [UserId] -> m [UserAccount] -lookupAccounts usrs = account <$$> lookupExtendedAccounts usrs - -lookupExtendedAccounts :: (MonadClient m, MonadReader Env m) => [UserId] -> m [ExtendedUserAccount] -lookupExtendedAccounts usrs = do - loc <- setDefaultUserLocale <$> view settings - domain <- viewFederationDomain - fmap (toExtendedUserAccount domain loc) <$> retry x1 (query accountsSelect (params LocalQuorum (Identity usrs))) - lookupServiceUser :: (MonadClient m) => ProviderId -> ServiceId -> BotId -> m (Maybe (ConvId, Maybe TeamId)) lookupServiceUser pid sid bid = retry x1 (query1 cql (params LocalQuorum (pid, sid, bid))) where @@ -452,6 +445,8 @@ lookupFeatureConferenceCalling uid = do type Activated = Bool +-- UserRow is the same as AccountRow from the user subsystem. when migrating this code there, +-- consider eliminating it instead. type UserRow = ( UserId, Name, @@ -500,9 +495,6 @@ type UserRowInsert = deriving instance Show UserRowInsert --- Represents a 'UserAccount' -type AccountRow = UserRow - usersSelect :: PrepQuery R (Identity [UserId]) UserRow usersSelect = "SELECT id, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, \ @@ -528,13 +520,6 @@ richInfoSelectMulti = "SELECT user, json FROM rich_info WHERE user in ?" teamSelect :: PrepQuery R (Identity UserId) (Identity (Maybe TeamId)) teamSelect = "SELECT team FROM user WHERE id = ?" -accountsSelect :: PrepQuery R (Identity [UserId]) AccountRow -accountsSelect = - "SELECT id, name, text_status, picture, email, email_unvalidated, sso_id, accent_id, assets, \ - \activated, status, expires, language, country, provider, \ - \service, handle, team, managed_by, supported_protocols \ - \FROM user WHERE id IN ?" - userInsert :: PrepQuery W UserRowInsert () userInsert = "INSERT INTO user (id, name, text_status, picture, assets, email, sso_id, \ @@ -575,59 +560,6 @@ userRichInfoUpdate = {- `IF EXISTS`, but that requires benchmarking -} "UPDATE r ------------------------------------------------------------------------------- -- Conversions --- | Construct a 'UserAccount' from a raw user record in the database. -toExtendedUserAccount :: Domain -> Locale -> AccountRow -> ExtendedUserAccount -toExtendedUserAccount - domain - defaultLocale - ( uid, - name, - textStatus, - pict, - email, - emailUnvalidated, - ssoid, - accent, - assets, - activated, - status, - expires, - lan, - con, - pid, - sid, - handle, - tid, - managed_by, - prots - ) = - let ident = toIdentity activated email ssoid - deleted = Just Deleted == status - expiration = if status == Just Ephemeral then expires else Nothing - loc = toLocale defaultLocale (lan, con) - svc = newServiceRef <$> sid <*> pid - account = - UserAccount - ( User - (Qualified uid domain) - ident - name - textStatus - (fromMaybe noPict pict) - (fromMaybe [] assets) - accent - deleted - loc - svc - handle - expiration - tid - (fromMaybe ManagedByWire managed_by) - (fromMaybe defSupportedProtocols prots) - ) - (fromMaybe Active status) - in ExtendedUserAccount account emailUnvalidated - toUsers :: Domain -> Locale -> HavePendingInvitations -> [UserRow] -> [User] toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp where @@ -641,7 +573,7 @@ toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp _textStatus, _pict, _email, - _, + _emailUnvalidated, _ssoid, _accent, _assets, @@ -666,7 +598,7 @@ toUsers domain defaultLocale havePendingInvitations = fmap mk . filter fp textStatus, pict, email, - _, + _emailUnvalidated, ssoid, accent, assets, diff --git a/services/brig/src/Brig/InternalEvent/Process.hs b/services/brig/src/Brig/InternalEvent/Process.hs index 899381faa23..8fa8e91ac7e 100644 --- a/services/brig/src/Brig/InternalEvent/Process.hs +++ b/services/brig/src/Brig/InternalEvent/Process.hs @@ -44,6 +44,7 @@ import Wire.Sem.Delay import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserStore (UserStore) +import Wire.UserSubsystem -- | Handle an internal event. -- @@ -58,6 +59,7 @@ onEvent :: Member UserKeyStore r, Member (Input UTCTime) r, Member UserStore r, + Member UserSubsystem r, Member (ConnectionStore InternalPaging) r, Member PropertySubsystem r ) => @@ -71,7 +73,8 @@ onEvent n = handleTimeout $ case n of Log.info $ msg (val "Processing user delete event") ~~ field "user" (toByteString uid) - embed (API.lookupAccount uid) >>= mapM_ API.deleteAccount + luid <- qualifyLocal' uid + getAccountNoFilter luid >>= mapM_ API.deleteAccount -- As user deletions are expensive resource-wise in the context of -- bulk user deletions (e.g. during team deletions), -- wait 'delay' ms before processing the next event diff --git a/services/brig/src/Brig/Options.hs b/services/brig/src/Brig/Options.hs index f2c53d5d9bc..31d586cf165 100644 --- a/services/brig/src/Brig/Options.hs +++ b/services/brig/src/Brig/Options.hs @@ -41,16 +41,15 @@ import Data.Misc (HttpsUrl) import Data.Nonce import Data.Range import Data.Schema -import Data.Scientific (toBoundedInteger) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text -import Data.Time.Clock (DiffTime, NominalDiffTime, secondsToDiffTime) import Database.Bloodhound.Types qualified as ES import Imports import Network.AMQP.Extended import Network.DNS qualified as DNS import System.Logger.Extended (Level, LogFormat) import Util.Options +import Util.Timeout import Wire.API.Allowlists (AllowlistEmailDomains (..)) import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Version @@ -58,17 +57,6 @@ import Wire.API.Team.Feature import Wire.API.User import Wire.EmailSending.SMTP (SMTPConnType (..)) -newtype Timeout = Timeout - { timeoutDiff :: NominalDiffTime - } - deriving newtype (Eq, Enum, Ord, Num, Real, Fractional, RealFrac, Show) - -instance Read Timeout where - readsPrec i s = - case readsPrec i s of - [(x :: Int, s')] -> [(Timeout (fromIntegral x), s')] - _ -> [] - data ElasticSearchOpts = ElasticSearchOpts { -- | ElasticSearch URL url :: !ES.Server, @@ -825,16 +813,6 @@ defSrvDiscoveryIntervalSeconds = secondsToDiffTime 10 defSftListLength :: Range 1 100 Int defSftListLength = unsafeRange 5 -instance FromJSON Timeout where - parseJSON (Number n) = - let defaultV = 3600 - bounded = toBoundedInteger n :: Maybe Int64 - in pure $ - Timeout $ - fromIntegral @Int $ - maybe defaultV fromIntegral bounded - parseJSON v = A.typeMismatch "activationTimeout" v - instance FromJSON Settings where parseJSON = genericParseJSON customOptions where diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index bbd0e6f6940..6a36c4f5a1a 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -43,7 +43,6 @@ import Brig.Provider.DB qualified as DB import Brig.Provider.Email import Brig.Provider.RPC qualified as RPC import Brig.Team.Util -import Brig.Types.User import Brig.ZAuth qualified as ZAuth import Cassandra (MonadClient) import Control.Error (throwE) @@ -58,6 +57,7 @@ import Data.CommaSeparatedList (CommaSeparatedList (fromCommaSeparatedList)) import Data.Conduit (runConduit, (.|)) import Data.Conduit.List qualified as C import Data.Hashable (hash) +import Data.HavePendingInvitations import Data.Id import Data.LegalHold import Data.List qualified as List @@ -214,7 +214,14 @@ newAccount new = do lift $ sendActivationMail name email key val False pure $ Public.NewProviderResponse pid newPass -activateAccountKey :: (Member GalleyAPIAccess r, Member EmailSending r, Member VerificationCodeSubsystem r) => Code.Key -> Code.Value -> (Handler r) (Maybe Public.ProviderActivationResponse) +activateAccountKey :: + ( Member GalleyAPIAccess r, + Member EmailSending r, + Member VerificationCodeSubsystem r + ) => + Code.Key -> + Code.Value -> + (Handler r) (Maybe Public.ProviderActivationResponse) activateAccountKey key val = do guardSecondFactorDisabled Nothing c <- (lift . liftSem $ verifyCode key IdentityVerification val) >>= maybeInvalidCode @@ -678,7 +685,8 @@ addBot zuid zcon cid add = do -- if we want to protect bots against lh, 'addClient' cannot just send lh capability -- implicitly in the next line. pure $ FutureWork @'UnprotectedBot undefined - wrapClientE (User.addClient (botUserId bid) bcl newClt maxPermClients (Just $ Set.singleton Public.ClientSupportsLegalholdImplicitConsent)) + lbid <- qualifyLocal (botUserId bid) + wrapClientE (User.addClient lbid bcl newClt maxPermClients (Just $ Set.singleton Public.ClientSupportsLegalholdImplicitConsent)) !>> const (StdError $ badGatewayWith "MalformedPrekeys") -- Add the bot to the conversation diff --git a/services/brig/src/Brig/Run.hs b/services/brig/src/Brig/Run.hs index 5f713dd5edb..eda8c9fe88f 100644 --- a/services/brig/src/Brig/Run.hs +++ b/services/brig/src/Brig/Run.hs @@ -65,6 +65,7 @@ import Servant qualified import System.Logger (msg, val, (.=), (~~)) import System.Logger.Class (MonadLogger, err) import Util.Options +import Util.Timeout import Wire.API.Routes.API import Wire.API.Routes.Internal.Brig qualified as IAPI import Wire.API.Routes.Public.Brig diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index a6ee0283375..a7e285ad822 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -32,11 +32,12 @@ import Brig.API.User (createUserInviteViaScim, fetchUserIdentity) import Brig.API.User qualified as API import Brig.API.Util (logEmail, logInvitationCode) import Brig.App +import Brig.App qualified as App import Brig.Effects.ConnectionStore (ConnectionStore) import Brig.Effects.UserPendingActivationStore (UserPendingActivationStore) import Brig.Options (setMaxTeamSize, setTeamInvitationTimeout) -import Brig.Team.DB qualified as DB import Brig.Team.Email +import Brig.Team.Template import Brig.Team.Util (ensurePermissionToAddUser, ensurePermissions) import Brig.Types.Team (TeamSize) import Brig.User.Search.TeamSize qualified as TeamSize @@ -47,7 +48,10 @@ import Data.Id import Data.List1 qualified as List1 import Data.Qualified (Local) import Data.Range +import Data.Text.Ascii +import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy qualified as LT +import Data.Text.Lazy qualified as Text import Data.Time.Clock (UTCTime) import Data.Tuple.Extra import Imports hiding (head) @@ -55,9 +59,10 @@ import Network.Wai.Utilities hiding (code, message) import Polysemy import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) +import Polysemy.TinyLog qualified as Log import Servant hiding (Handler, JSON, addHeader) -import System.Logger.Class qualified as Log import System.Logger.Message as Log +import URI.ByteString (Absolute, URIRef, laxURIParserOptions, parseURI) import Util.Logging (logFunction, logTeam) import Wire.API.Error import Wire.API.Error.Brig qualified as E @@ -77,9 +82,12 @@ import Wire.API.User hiding (fromEmail) import Wire.API.User qualified as Public import Wire.BlockListStore import Wire.EmailSending (EmailSending) +import Wire.EmailSubsystem.Template import Wire.Error import Wire.GalleyAPIAccess (GalleyAPIAccess, ShowOrHideInvitationUrl (..)) import Wire.GalleyAPIAccess qualified as GalleyAPIAccess +import Wire.InvitationCodeStore (InsertInvitation (..), InvitationCodeStore (..), PaginatedResult (..), StoredInvitation (..)) +import Wire.InvitationCodeStore qualified as Store import Wire.NotificationSubsystem import Wire.Sem.Concurrency import Wire.Sem.Paging.Cassandra (InternalPaging) @@ -90,7 +98,9 @@ servantAPI :: ( Member GalleyAPIAccess r, Member UserKeyStore r, Member UserSubsystem r, - Member EmailSending r + Member EmailSending r, + Member TinyLog r, + Member Store.InvitationCodeStore r ) => ServerT TeamsAPI (Handler r) servantAPI = @@ -110,10 +120,14 @@ teamSizePublic uid tid = do teamSize :: TeamId -> (Handler r) TeamSize teamSize t = lift $ TeamSize.teamSize t -getInvitationCode :: TeamId -> InvitationId -> (Handler r) FoundInvitationCode +getInvitationCode :: + (Member Store.InvitationCodeStore r) => + TeamId -> + InvitationId -> + (Handler r) FoundInvitationCode getInvitationCode t r = do - code <- lift . wrapClient $ DB.lookupInvitationCode t r - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . FoundInvitationCode) code + inv <- lift . liftSem $ Store.lookupInvitation t r + maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . FoundInvitationCode . (.code)) inv data CreateInvitationInviter = CreateInvitationInviter { inviterUid :: UserId, @@ -125,7 +139,9 @@ createInvitation :: ( Member GalleyAPIAccess r, Member UserKeyStore r, Member UserSubsystem r, - Member EmailSending r + Member EmailSending r, + Member TinyLog r, + Member InvitationCodeStore r ) => UserId -> TeamId -> @@ -152,7 +168,7 @@ createInvitation uid tid body = do where loc :: Invitation -> InvitationLocation loc inv = - InvitationLocation $ "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' (inInvitation inv) + InvitationLocation $ "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' inv.invitationId createInvitationViaScim :: ( Member BlockListStore r, @@ -161,7 +177,8 @@ createInvitationViaScim :: Member (UserPendingActivationStore p) r, Member TinyLog r, Member EmailSending r, - Member UserSubsystem r + Member UserSubsystem r, + Member InvitationCodeStore r ) => TeamId -> NewUserScimInvitation -> @@ -189,20 +206,21 @@ createInvitationViaScim tid newUser@(NewUserScimInvitation _tid uid _eid loc nam createUserInviteViaScim newUser -logInvitationRequest :: (Msg -> Msg) -> (Handler r) (Invitation, InvitationCode) -> (Handler r) (Invitation, InvitationCode) +logInvitationRequest :: (Member TinyLog r) => (Msg -> Msg) -> (Handler r) (Invitation, InvitationCode) -> Handler r (Invitation, InvitationCode) logInvitationRequest context action = - flip mapExceptT action $ \action' -> do + flip mapExceptT action \action' -> do eith <- action' case eith of Left err' -> do - Log.warn $ - context - . Log.msg @Text - ( "Failed to create invitation, label: " - <> (LT.toStrict . errorLabel) err' - ) + liftSem $ + Log.warn $ + context + . Log.msg @Text + ( "Failed to create invitation, label: " + <> (LT.toStrict . errorLabel) err' + ) pure (Left err') - Right result@(_, code) -> do + Right result@(_, code) -> liftSem do Log.info $ (context . logInvitationCode code) . Log.msg @Text "Successfully created invitation" pure (Right result) @@ -210,7 +228,9 @@ createInvitation' :: ( Member UserSubsystem r, Member GalleyAPIAccess r, Member UserKeyStore r, - Member EmailSending r + Member EmailSending r, + Member TinyLog r, + Member InvitationCodeStore r ) => TeamId -> Maybe UserId -> @@ -220,7 +240,7 @@ createInvitation' :: Public.InvitationRequest -> Handler r (Public.Invitation, Public.InvitationCode) createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do - let email = (inviteeEmail body) + let email = body.inviteeEmail let uke = mkEmailKey email blacklistedEm <- lift $ liftSem $ isBlocked email when blacklistedEm $ @@ -230,69 +250,165 @@ createInvitation' tid mUid inviteeRole mbInviterUid fromEmail body = do throwStd emailExists maxSize <- setMaxTeamSize <$> view settings - pending <- lift $ wrapClient $ DB.countInvitations tid + pending <- lift $ liftSem $ Store.countInvitations tid when (fromIntegral pending >= maxSize) $ throwStd (errorToWai @'E.TooManyTeamInvitations) showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - lift $ do - iid <- maybe (liftIO DB.mkInvitationId) (pure . Id . toUUID) mUid - now <- liftIO =<< view currentTime - timeout <- setTeamInvitationTimeout <$> view settings - (newInv, code) <- - wrapClient $ - DB.insertInvitation - showInvitationUrl - iid - tid - inviteeRole - now - mbInviterUid - email - body.inviteeName - timeout - (newInv, code) <$ sendInvitationMail email tid fromEmail code body.locale - -deleteInvitation :: (Member GalleyAPIAccess r) => UserId -> TeamId -> InvitationId -> (Handler r) () + iid <- maybe (liftIO randomId) (pure . Id . toUUID) mUid + now <- liftIO =<< view currentTime + timeout <- setTeamInvitationTimeout <$> view settings + let insertInv = + MkInsertInvitation + { invitationId = iid, + teamId = tid, + role = inviteeRole, + createdAt = now, + createdBy = mbInviterUid, + inviteeEmail = email, + inviteeName = body.inviteeName + } + newInv <- + lift . liftSem $ + Store.insertInvitation + insertInv + timeout + lift $ sendInvitationMail email tid fromEmail newInv.code body.locale + inv <- toInvitation showInvitationUrl newInv + pure (inv, newInv.code) + +deleteInvitation :: + (Member GalleyAPIAccess r, Member InvitationCodeStore r) => + UserId -> + TeamId -> + InvitationId -> + (Handler r) () deleteInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] - lift $ wrapClient $ DB.deleteInvitation tid iid + lift . liftSem $ Store.deleteInvitation tid iid -listInvitations :: (Member GalleyAPIAccess r) => UserId -> TeamId -> Maybe InvitationId -> Maybe (Range 1 500 Int32) -> (Handler r) Public.InvitationList -listInvitations uid tid start mSize = do +listInvitations :: + ( Member GalleyAPIAccess r, + Member TinyLog r, + Member InvitationCodeStore r + ) => + UserId -> + TeamId -> + Maybe InvitationId -> + Maybe (Range 1 500 Int32) -> + (Handler r) Public.InvitationList +listInvitations uid tid startingId mSize = do ensurePermissions uid tid [AddTeamMember] showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - rs <- lift $ wrapClient $ DB.lookupInvitations showInvitationUrl tid start (fromMaybe (unsafeRange 100) mSize) - pure $! Public.InvitationList (DB.resultList rs) (DB.resultHasMore rs) + let toInvitations is = mapM (toInvitation showInvitationUrl) is + lift (liftSem $ Store.lookupInvitationsPaginated mSize tid startingId) >>= \case + PaginatedResultHasMore storedInvs -> do + invs <- toInvitations storedInvs + pure $ InvitationList invs True + PaginatedResult storedInvs -> do + invs <- toInvitations storedInvs + pure $ InvitationList invs False + +-- | brig used to not store the role, so for migration we allow this to be empty and fill in the +-- default here. +toInvitation :: + ( Member TinyLog r + ) => + ShowOrHideInvitationUrl -> + StoredInvitation -> + (Handler r) Invitation +toInvitation showUrl storedInv = do + url <- mkInviteUrl showUrl storedInv.teamId storedInv.code + pure $ + Invitation + { team = storedInv.teamId, + role = fromMaybe defaultRole storedInv.role, + invitationId = storedInv.invitationId, + createdAt = storedInv.createdAt, + createdBy = storedInv.createdBy, + inviteeEmail = storedInv.email, + inviteeName = storedInv.name, + inviteeUrl = url + } -getInvitation :: (Member GalleyAPIAccess r) => UserId -> TeamId -> InvitationId -> (Handler r) (Maybe Public.Invitation) +mkInviteUrl :: + (Member TinyLog r) => + ShowOrHideInvitationUrl -> + TeamId -> + InvitationCode -> + (Handler r) (Maybe (URIRef Absolute)) +mkInviteUrl HideInvitationUrl _ _ = pure Nothing +mkInviteUrl ShowInvitationUrl team (InvitationCode c) = do + template <- invitationEmailUrl . invitationEmail . snd <$> teamTemplates Nothing + branding <- view App.templateBranding + let url = Text.toStrict $ renderTextWithBranding template replace branding + parseHttpsUrl url + where + replace "team" = idToText team + replace "code" = toText c + replace x = x + parseHttpsUrl :: (Member TinyLog r) => Text -> (Handler r) (Maybe (URIRef Absolute)) + parseHttpsUrl url = + either (\e -> lift . liftSem $ logError url e >> pure Nothing) (pure . Just) $ + parseURI laxURIParserOptions (encodeUtf8 url) + logError url e = + Log.err $ + Log.msg @Text "Unable to create invitation url. Please check configuration." + . Log.field "url" url + . Log.field "error" (show e) + +getInvitation :: + ( Member GalleyAPIAccess r, + Member InvitationCodeStore r, + Member TinyLog r + ) => + UserId -> + TeamId -> + InvitationId -> + (Handler r) (Maybe Public.Invitation) getInvitation uid tid iid = do ensurePermissions uid tid [AddTeamMember] - showInvitationUrl <- lift $ liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid - lift $ wrapClient $ DB.lookupInvitation showInvitationUrl tid iid -getInvitationByCode :: Public.InvitationCode -> (Handler r) Public.Invitation + invitationM <- lift . liftSem $ Store.lookupInvitation tid iid + case invitationM of + Nothing -> pure Nothing + Just invitation -> do + showInvitationUrl <- lift . liftSem $ GalleyAPIAccess.getExposeInvitationURLsToTeamAdmin tid + maybeUrl <- mkInviteUrl showInvitationUrl tid invitation.code + pure $ Just (Store.invitationFromStored maybeUrl invitation) + +getInvitationByCode :: + (Member Store.InvitationCodeStore r) => + Public.InvitationCode -> + (Handler r) Public.Invitation getInvitationByCode c = do - inv <- lift . wrapClient $ DB.lookupInvitationByCode HideInvitationUrl c - maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) pure inv + inv <- lift . liftSem $ Store.lookupInvitationByCode c + maybe (throwStd $ errorToWai @'E.InvalidInvitationCode) (pure . Store.invitationFromStored Nothing) inv -headInvitationByEmail :: EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult -headInvitationByEmail e = do +headInvitationByEmail :: (Member InvitationCodeStore r, Member TinyLog r) => EmailAddress -> (Handler r) Public.HeadInvitationByEmailResult +headInvitationByEmail email = lift $ - wrapClient $ - DB.lookupInvitationInfoByEmail e <&> \case - DB.InvitationByEmail _ -> Public.InvitationByEmail - DB.InvitationByEmailNotFound -> Public.InvitationByEmailNotFound - DB.InvitationByEmailMoreThanOne -> Public.InvitationByEmailMoreThanOne + liftSem $ + Store.lookupInvitationCodesByEmail email >>= \case + [] -> pure Public.InvitationByEmailNotFound + [_code] -> pure Public.InvitationByEmail + (_ : _ : _) -> do + Log.info $ + Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") + . Log.field "email" (show email) + pure Public.InvitationByEmailMoreThanOne -- | FUTUREWORK: This should also respond with status 409 in case of -- @DB.InvitationByEmailMoreThanOne@. Refactor so that 'headInvitationByEmailH' and -- 'getInvitationByEmailH' are almost the same thing. -getInvitationByEmail :: EmailAddress -> (Handler r) Public.Invitation +getInvitationByEmail :: + (Member Store.InvitationCodeStore r, Member TinyLog r) => + EmailAddress -> + (Handler r) Public.Invitation getInvitationByEmail email = do - inv <- lift $ wrapClient $ DB.lookupInvitationByEmail HideInvitationUrl email - maybe (throwStd (notFound "Invitation not found")) pure inv + inv <- lift . liftSem $ Store.lookupInvitationByEmail email + maybe (throwStd (notFound "Invitation not found")) (pure . Store.invitationFromStored Nothing) inv suspendTeam :: ( Member (Embed HttpClientIO) r, @@ -302,15 +418,19 @@ suspendTeam :: Member TinyLog r, Member (Input (Local ())) r, Member (Input UTCTime) r, - Member (ConnectionStore InternalPaging) r + Member (ConnectionStore InternalPaging) r, + Member InvitationCodeStore r ) => TeamId -> (Handler r) NoContent suspendTeam tid = do - Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) + lift $ liftSem $ Log.info $ Log.msg (Log.val "Team suspended") ~~ Log.field "team" (toByteString tid) + -- Update the status of all users from the given team changeTeamAccountStatuses tid Suspended - lift $ wrapClient $ DB.deleteInvitations tid - lift $ liftSem $ GalleyAPIAccess.changeTeamStatus tid Team.Suspended Nothing + lift . liftSem $ do + Store.deleteAllTeamInvitations tid + -- RPC to galley to change team status there + GalleyAPIAccess.changeTeamStatus tid Team.Suspended Nothing pure NoContent unsuspendTeam :: diff --git a/services/brig/src/Brig/Team/DB.hs b/services/brig/src/Brig/Team/DB.hs deleted file mode 100644 index e6e19e7609d..00000000000 --- a/services/brig/src/Brig/Team/DB.hs +++ /dev/null @@ -1,323 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2022 Wire Swiss GmbH --- --- 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 . - -module Brig.Team.DB - ( module T, - countInvitations, - insertInvitation, - deleteInvitation, - deleteInvitations, - lookupInvitation, - lookupInvitationCode, - lookupInvitations, - lookupInvitationByCode, - lookupInvitationInfo, - lookupInvitationInfoByEmail, - lookupInvitationByEmail, - mkInvitationCode, - mkInvitationId, - InvitationByEmail (..), - InvitationInfo (..), - ) -where - -import Brig.App as App -import Brig.Data.Types as T -import Brig.Options -import Brig.Team.Template -import Cassandra as C -import Control.Lens (view) -import Data.Conduit (runConduit, (.|)) -import Data.Conduit.List qualified as C -import Data.Id -import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) -import Data.Range -import Data.Text.Ascii (encodeBase64Url, toText) -import Data.Text.Encoding -import Data.Text.Lazy (toStrict) -import Data.Time.Clock -import Data.UUID.V4 -import Imports -import OpenSSL.Random (randBytes) -import System.Logger.Class qualified as Log -import URI.ByteString -import UnliftIO.Async (pooledMapConcurrentlyN_) -import Wire.API.Team.Invitation hiding (HeadInvitationByEmailResult (..)) -import Wire.API.Team.Role -import Wire.API.User -import Wire.EmailSubsystem.Template (renderTextWithBranding) -import Wire.GalleyAPIAccess (ShowOrHideInvitationUrl (..)) - -mkInvitationCode :: IO InvitationCode -mkInvitationCode = InvitationCode . encodeBase64Url <$> randBytes 24 - -mkInvitationId :: IO InvitationId -mkInvitationId = Id <$> nextRandom - -data InvitationInfo = InvitationInfo - { iiCode :: InvitationCode, - iiTeam :: TeamId, - iiInvId :: InvitationId - } - deriving (Eq, Show) - -data InvitationByEmail - = InvitationByEmail InvitationInfo - | InvitationByEmailNotFound - | InvitationByEmailMoreThanOne - -insertInvitation :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadClient m - ) => - ShowOrHideInvitationUrl -> - InvitationId -> - TeamId -> - Role -> - UTCTime -> - Maybe UserId -> - EmailAddress -> - Maybe Name -> - -- | The timeout for the invitation code. - Timeout -> - m (Invitation, InvitationCode) -insertInvitation showUrl iid t role (toUTCTimeMillis -> now) minviter email inviteeName timeout = do - code <- liftIO mkInvitationCode - url <- mkInviteUrl showUrl t code - let inv = Invitation t role iid now minviter email inviteeName url - retry x5 . batch $ do - setType BatchLogged - setConsistency LocalQuorum - addPrepQuery cqlInvitation (t, role, iid, code, email, now, minviter, inviteeName, round timeout) - addPrepQuery cqlInvitationInfo (code, t, iid, round timeout) - addPrepQuery cqlInvitationByEmail (email, t, iid, code, round timeout) - pure (inv, code) - where - cqlInvitationInfo :: PrepQuery W (InvitationCode, TeamId, InvitationId, Int32) () - cqlInvitationInfo = "INSERT INTO team_invitation_info (code, team, id) VALUES (?, ?, ?) USING TTL ?" - cqlInvitation :: PrepQuery W (TeamId, Role, InvitationId, InvitationCode, EmailAddress, UTCTimeMillis, Maybe UserId, Maybe Name, Int32) () - cqlInvitation = "INSERT INTO team_invitation (team, role, id, code, email, created_at, created_by, name) VALUES (?, ?, ?, ?, ?, ?, ?, ?) USING TTL ?" - -- Note: the edge case of multiple invites to the same team by different admins from the same team results in last-invite-wins in the team_invitation_email table. - cqlInvitationByEmail :: PrepQuery W (EmailAddress, TeamId, InvitationId, InvitationCode, Int32) () - cqlInvitationByEmail = "INSERT INTO team_invitation_email (email, team, invitation, code) VALUES (?, ?, ?, ?) USING TTL ?" - -lookupInvitation :: - ( MonadClient m, - MonadReader Env m, - Log.MonadLogger m - ) => - ShowOrHideInvitationUrl -> - TeamId -> - InvitationId -> - m (Maybe Invitation) -lookupInvitation showUrl t r = do - inv <- retry x1 (query1 cqlInvitation (params LocalQuorum (t, r))) - traverse (toInvitation showUrl) inv - where - cqlInvitation :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) - cqlInvitation = "SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id = ?" - -lookupInvitationByCode :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadClient m - ) => - ShowOrHideInvitationUrl -> - InvitationCode -> - m (Maybe Invitation) -lookupInvitationByCode showUrl i = - lookupInvitationInfo i >>= \case - Just InvitationInfo {..} -> lookupInvitation showUrl iiTeam iiInvId - _ -> pure Nothing - -lookupInvitationCode :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe InvitationCode) -lookupInvitationCode t r = - fmap runIdentity - <$> retry x1 (query1 cqlInvitationCode (params LocalQuorum (t, r))) - where - cqlInvitationCode :: PrepQuery R (TeamId, InvitationId) (Identity InvitationCode) - cqlInvitationCode = "SELECT code FROM team_invitation WHERE team = ? AND id = ?" - -lookupInvitationCodeEmail :: (MonadClient m) => TeamId -> InvitationId -> m (Maybe (InvitationCode, EmailAddress)) -lookupInvitationCodeEmail t r = retry x1 (query1 cqlInvitationCodeEmail (params LocalQuorum (t, r))) - where - cqlInvitationCodeEmail :: PrepQuery R (TeamId, InvitationId) (InvitationCode, EmailAddress) - cqlInvitationCodeEmail = "SELECT code, email FROM team_invitation WHERE team = ? AND id = ?" - -lookupInvitations :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadClient m - ) => - ShowOrHideInvitationUrl -> - TeamId -> - Maybe InvitationId -> - Range 1 500 Int32 -> - m (ResultPage Invitation) -lookupInvitations showUrl team start (fromRange -> size) = do - page <- case start of - Just ref -> retry x1 $ paginate cqlSelectFrom (paramsP LocalQuorum (team, ref) (size + 1)) - Nothing -> retry x1 $ paginate cqlSelect (paramsP LocalQuorum (Identity team) (size + 1)) - toResult (hasMore page) <$> traverse (toInvitation showUrl) (trim page) - where - trim p = take (fromIntegral size) (result p) - toResult more invs = - cassandraResultPage $ - emptyPage - { result = invs, - hasMore = more - } - cqlSelect :: PrepQuery R (Identity TeamId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) - cqlSelect = "SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? ORDER BY id ASC" - cqlSelectFrom :: PrepQuery R (TeamId, InvitationId) (TeamId, Maybe Role, InvitationId, UTCTimeMillis, Maybe UserId, EmailAddress, Maybe Name, InvitationCode) - cqlSelectFrom = "SELECT team, role, id, created_at, created_by, email, name, code FROM team_invitation WHERE team = ? AND id > ? ORDER BY id ASC" - -deleteInvitation :: (MonadClient m) => TeamId -> InvitationId -> m () -deleteInvitation t i = do - codeEmail <- lookupInvitationCodeEmail t i - case codeEmail of - Just (invCode, invEmail) -> retry x5 . batch $ do - setType BatchLogged - setConsistency LocalQuorum - addPrepQuery cqlInvitation (t, i) - addPrepQuery cqlInvitationInfo (Identity invCode) - addPrepQuery cqlInvitationEmail (invEmail, t) - Nothing -> - retry x5 $ write cqlInvitation (params LocalQuorum (t, i)) - where - cqlInvitation :: PrepQuery W (TeamId, InvitationId) () - cqlInvitation = "DELETE FROM team_invitation where team = ? AND id = ?" - cqlInvitationInfo :: PrepQuery W (Identity InvitationCode) () - cqlInvitationInfo = "DELETE FROM team_invitation_info WHERE code = ?" - cqlInvitationEmail :: PrepQuery W (EmailAddress, TeamId) () - cqlInvitationEmail = "DELETE FROM team_invitation_email WHERE email = ? AND team = ?" - -deleteInvitations :: (MonadClient m) => TeamId -> m () -deleteInvitations t = - liftClient $ - runConduit $ - paginateC cqlSelect (paramsP LocalQuorum (Identity t) 100) x1 - .| C.mapM_ (pooledMapConcurrentlyN_ 16 (deleteInvitation t . runIdentity)) - where - cqlSelect :: PrepQuery R (Identity TeamId) (Identity InvitationId) - cqlSelect = "SELECT id FROM team_invitation WHERE team = ? ORDER BY id ASC" - -lookupInvitationInfo :: (MonadClient m) => InvitationCode -> m (Maybe InvitationInfo) -lookupInvitationInfo ic@(InvitationCode c) - | c == mempty = pure Nothing - | otherwise = - fmap (toInvitationInfo ic) - <$> retry x1 (query1 cqlInvitationInfo (params LocalQuorum (Identity ic))) - where - toInvitationInfo i (t, r) = InvitationInfo i t r - cqlInvitationInfo :: PrepQuery R (Identity InvitationCode) (TeamId, InvitationId) - cqlInvitationInfo = "SELECT team, id FROM team_invitation_info WHERE code = ?" - -lookupInvitationByEmail :: - ( Log.MonadLogger m, - MonadReader Env m, - MonadClient m - ) => - ShowOrHideInvitationUrl -> - EmailAddress -> - m (Maybe Invitation) -lookupInvitationByEmail showUrl e = - lookupInvitationInfoByEmail e >>= \case - InvitationByEmail InvitationInfo {..} -> lookupInvitation showUrl iiTeam iiInvId - _ -> pure Nothing - -lookupInvitationInfoByEmail :: (Log.MonadLogger m, MonadClient m) => EmailAddress -> m InvitationByEmail -lookupInvitationInfoByEmail email = do - res <- retry x1 (query cqlInvitationEmail (params LocalQuorum (Identity email))) - case res of - [] -> pure InvitationByEmailNotFound - [(tid, invId, code)] -> - -- one invite pending - pure $ InvitationByEmail (InvitationInfo code tid invId) - _ : _ : _ -> do - -- edge case: more than one pending invite from different teams - Log.info $ - Log.msg (Log.val "team_invidation_email: multiple pending invites from different teams for the same email") - Log.~~ Log.field "email" (show email) - pure InvitationByEmailMoreThanOne - where - cqlInvitationEmail :: PrepQuery R (Identity EmailAddress) (TeamId, InvitationId, InvitationCode) - cqlInvitationEmail = "SELECT team, invitation, code FROM team_invitation_email WHERE email = ?" - -countInvitations :: (MonadClient m) => TeamId -> m Int64 -countInvitations t = - maybe 0 runIdentity - <$> retry x1 (query1 cqlSelect (params LocalQuorum (Identity t))) - where - cqlSelect :: PrepQuery R (Identity TeamId) (Identity Int64) - cqlSelect = "SELECT count(*) FROM team_invitation WHERE team = ?" - --- | brig used to not store the role, so for migration we allow this to be empty and fill in the --- default here. -toInvitation :: - ( MonadReader Env m, - Log.MonadLogger m - ) => - ShowOrHideInvitationUrl -> - ( TeamId, - Maybe Role, - InvitationId, - UTCTimeMillis, - Maybe UserId, - EmailAddress, - Maybe Name, - InvitationCode - ) -> - m Invitation -toInvitation showUrl (t, r, i, tm, minviter, e, inviteeName, code) = do - url <- mkInviteUrl showUrl t code - pure $ Invitation t (fromMaybe defaultRole r) i tm minviter e inviteeName url - -mkInviteUrl :: - ( MonadReader Env m, - Log.MonadLogger m - ) => - ShowOrHideInvitationUrl -> - TeamId -> - InvitationCode -> - m (Maybe (URIRef Absolute)) -mkInviteUrl HideInvitationUrl _ _ = pure Nothing -mkInviteUrl ShowInvitationUrl team (InvitationCode c) = do - template <- invitationEmailUrl . invitationEmail . snd <$> teamTemplates Nothing - branding <- view App.templateBranding - let url = toStrict $ renderTextWithBranding template replace branding - parseHttpsUrl url - where - replace "team" = idToText team - replace "code" = toText c - replace x = x - - parseHttpsUrl :: (Log.MonadLogger m) => Text -> m (Maybe (URIRef Absolute)) - parseHttpsUrl url = - either (\e -> logError url e >> pure Nothing) (pure . Just) $ - parseURI laxURIParserOptions (encodeUtf8 url) - - logError :: (Log.MonadLogger m, Show e) => Text -> e -> m () - logError url e = - Log.err $ - Log.msg - (Log.val "Unable to create invitation url. Please check configuration.") - . Log.field "url" url - . Log.field "error" (show e) diff --git a/services/brig/src/Brig/Team/Util.hs b/services/brig/src/Brig/Team/Util.hs index 6ab5eab896d..a838a3c5fe8 100644 --- a/services/brig/src/Brig/Team/Util.hs +++ b/services/brig/src/Brig/Team/Util.hs @@ -20,9 +20,9 @@ module Brig.Team.Util where -- TODO: remove this module and move contents to Bri import Brig.API.Error import Brig.App import Brig.Data.User qualified as Data -import Brig.Types.User (HavePendingInvitations (NoPendingInvitations)) import Control.Error import Control.Lens +import Data.HavePendingInvitations import Data.Id import Data.Set qualified as Set import Imports diff --git a/services/brig/src/Brig/User/Auth.hs b/services/brig/src/Brig/User/Auth.hs index b17ff8e6689..03b4fd7895a 100644 --- a/services/brig/src/Brig/User/Auth.hs +++ b/services/brig/src/Brig/User/Auth.hs @@ -58,8 +58,7 @@ import Data.List.NonEmpty qualified as NE import Data.List1 (List1) import Data.List1 qualified as List1 import Data.Misc (PlainTextPassword6) -import Data.Qualified (Local) -import Data.Time.Clock (UTCTime) +import Data.Qualified import Data.ZAuth.Token qualified as ZAuth import Imports import Network.Wai.Utilities.Error ((!>>)) @@ -68,6 +67,7 @@ import Polysemy.Input (Input) import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log import System.Logger (field, msg, val, (~~)) +import Util.Timeout import Wire.API.Team.Feature import Wire.API.Team.Feature qualified as Public import Wire.API.User @@ -81,6 +81,8 @@ import Wire.PasswordStore (PasswordStore) import Wire.Sem.Paging.Cassandra (InternalPaging) import Wire.UserKeyStore import Wire.UserStore +import Wire.UserSubsystem (UserSubsystem) +import Wire.UserSubsystem qualified as User import Wire.VerificationCode qualified as VerificationCode import Wire.VerificationCodeGen qualified as VerificationCodeGen import Wire.VerificationCodeSubsystem (VerificationCodeSubsystem) @@ -98,6 +100,7 @@ login :: Member PasswordStore r, Member UserKeyStore r, Member UserStore r, + Member UserSubsystem r, Member VerificationCodeSubsystem r ) => Login -> @@ -117,8 +120,9 @@ login (MkLogin li pw label code) typ = do newAccess @ZAuth.User @ZAuth.Access uid Nothing typ label where verifyLoginCode :: Maybe Code.Value -> UserId -> ExceptT LoginError (AppT r) () - verifyLoginCode mbCode uid = - verifyCode mbCode Login uid + verifyLoginCode mbCode uid = do + luid <- lift $ qualifyLocal uid + verifyCode mbCode Login luid `catchE` \case VerificationCodeNoPendingCode -> wrapHttpClientE $ loginFailedWith LoginCodeInvalid uid VerificationCodeRequired -> wrapHttpClientE $ loginFailedWith LoginCodeRequired uid @@ -126,17 +130,18 @@ login (MkLogin li pw label code) typ = do verifyCode :: forall r. - (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r) => + (Member GalleyAPIAccess r, Member VerificationCodeSubsystem r, Member UserSubsystem r) => Maybe Code.Value -> VerificationAction -> - UserId -> + Local UserId -> ExceptT VerificationCodeError (AppT r) () -verifyCode mbCode action uid = do - (mbEmail, mbTeamId) <- getEmailAndTeamId uid +verifyCode mbCode action luid = do + (mbEmail, mbTeamId) <- getEmailAndTeamId luid featureEnabled <- lift $ do mbFeatureEnabled <- liftSem $ GalleyAPIAccess.getVerificationCodeEnabled `traverse` mbTeamId pure $ fromMaybe ((def @(Feature Public.SndFactorPasswordChallengeConfig)).status == Public.FeatureStatusEnabled) mbFeatureEnabled - isSsoUser <- wrapHttpClientE $ Data.isSamlUser uid + account <- lift . liftSem $ User.getAccountNoFilter luid + let isSsoUser = maybe False (Data.isSamlUser . ((.accountUser))) account when (featureEnabled && not isSsoUser) $ do case (mbCode, mbEmail) of (Just code, Just email) -> do @@ -148,10 +153,10 @@ verifyCode mbCode action uid = do (_, Nothing) -> throwE VerificationCodeNoEmail where getEmailAndTeamId :: - UserId -> + Local UserId -> ExceptT e (AppT r) (Maybe EmailAddress, Maybe TeamId) getEmailAndTeamId u = do - mbAccount <- wrapHttpClientE $ Data.lookupAccount u + mbAccount <- lift . liftSem $ User.getAccountNoFilter u pure (userEmail <$> accountUser =<< mbAccount, userTeam <$> accountUser =<< mbAccount) loginFailedWith :: (MonadClient m, MonadReader Env m) => LoginError -> UserId -> ExceptT LoginError m () @@ -177,7 +182,7 @@ withRetryLimit action uid = do let bkey = BudgetKey ("login#" <> idToText uid) budget = Budget - (Opt.timeoutDiff $ Opt.timeout opts) + (timeoutDiff $ Opt.timeout opts) (fromIntegral $ Opt.retryLimit opts) bresult <- action bkey budget case bresult of @@ -217,15 +222,21 @@ renewAccess uts at mcid = do pure $ Access at' ck' revokeAccess :: - (Member TinyLog r, Member PasswordStore r) => - UserId -> + ( Member TinyLog r, + Member PasswordStore r, + Member UserSubsystem r + ) => + Local UserId -> PlainTextPassword6 -> [CookieId] -> [CookieLabel] -> ExceptT AuthError (AppT r) () -revokeAccess u pw cc ll = do +revokeAccess luid@(tUnqualified -> u) pw cc ll = do lift . liftSem $ Log.debug $ field "user" (toByteString u) . field "action" (val "User.revokeAccess") - unlessM (lift . wrapHttpClient $ Data.isSamlUser u) $ Data.authenticate u pw + isSaml <- lift . liftSem $ do + account <- User.getAccountNoFilter luid + pure $ maybe False (Data.isSamlUser . ((.accountUser))) account + unless isSaml $ Data.authenticate u pw lift $ wrapHttpClient $ revokeCookies u cc ll -------------------------------------------------------------------------------- @@ -282,32 +293,48 @@ newAccess uid cid ct cl = do t <- lift $ newAccessToken @u @a ck Nothing pure $ Access t (Just ck) -resolveLoginId :: (Member UserKeyStore r, Member UserStore r) => LoginId -> ExceptT LoginError (AppT r) UserId +resolveLoginId :: + ( Member UserKeyStore r, + Member UserStore r, + Member UserSubsystem r, + Member (Input (Local ())) r + ) => + LoginId -> + ExceptT LoginError (AppT r) UserId resolveLoginId li = do - usr <- wrapClientE (validateLoginId li) >>= lift . either (liftSem . lookupKey) (liftSem . lookupHandle) + usr <- lift . liftSem . either lookupKey lookupHandle $ validateLoginId li case usr of Nothing -> do - pending <- wrapClientE $ isPendingActivation li + pending <- lift $ isPendingActivation li throwE $ if pending then LoginPendingActivation else LoginFailed Just uid -> pure uid -validateLoginId :: (MonadReader Env m) => LoginId -> ExceptT LoginError m (Either EmailKey Handle) -validateLoginId (LoginByEmail email) = (pure . Left . mkEmailKey) email -validateLoginId (LoginByHandle h) = (pure . Right) h +validateLoginId :: LoginId -> Either EmailKey Handle +validateLoginId (LoginByEmail email) = (Left . mkEmailKey) email +validateLoginId (LoginByHandle h) = Right h -isPendingActivation :: (MonadClient m, MonadReader Env m) => LoginId -> m Bool +isPendingActivation :: + forall r. + (Member UserSubsystem r, Member (Input (Local ())) r) => + LoginId -> + AppT r Bool isPendingActivation ident = case ident of (LoginByHandle _) -> pure False (LoginByEmail e) -> checkKey (mkEmailKey e) where + checkKey :: EmailKey -> AppT r Bool checkKey k = do - usr <- (>>= fst) <$> Data.lookupActivationCode k - case usr of + musr <- (>>= fst) <$> wrapClient (Data.lookupActivationCode k) + case musr of Nothing -> pure False - Just u -> maybe False (checkAccount k) <$> Data.lookupAccount u + Just usr -> liftSem do + lusr <- qualifyLocal' usr + maybe False (checkAccount k) <$> User.getAccountNoFilter lusr + + checkAccount :: EmailKey -> UserAccount -> Bool checkAccount k a = let i = userIdentity (accountUser a) statusAdmitsPending = case accountStatus a of diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 23ed4c461bf..f9f621ae4bb 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -57,6 +57,7 @@ import Imports import Prometheus qualified as Prom import System.Logger.Class (field, msg, val, (~~)) import System.Logger.Class qualified as Log +import Util.Timeout import Web.Cookie qualified as WebCookie import Wire.API.User.Auth import Wire.SessionStore qualified as Store diff --git a/services/brig/src/Brig/User/EJPD.hs b/services/brig/src/Brig/User/EJPD.hs index 880fc7d4618..23d4095270f 100644 --- a/services/brig/src/Brig/User/EJPD.hs +++ b/services/brig/src/Brig/User/EJPD.hs @@ -32,6 +32,7 @@ import Control.Lens (view, (^.)) import Data.Aeson qualified as A import Data.ByteString.Conversion import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Qualified import Data.Set qualified as Set import Data.Text qualified as T diff --git a/services/brig/test/integration/API/Team.hs b/services/brig/test/integration/API/Team.hs index 769efcd6a00..daac2f2e6eb 100644 --- a/services/brig/test/integration/API/Team.hs +++ b/services/brig/test/integration/API/Team.hs @@ -44,7 +44,6 @@ import Data.String.Conversions (cs) import Data.Text qualified as Text import Data.Text.Ascii qualified as Ascii import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Time (addUTCTime, getCurrentTime) import Data.UUID qualified as UUID (fromString) import Data.UUID.V4 qualified as UUID import Imports @@ -60,6 +59,7 @@ import URI.ByteString import UnliftIO.Async (mapConcurrently_, pooledForConcurrentlyN_, replicateConcurrently) import Util import Util.AWS as Util +import Util.Timeout import Web.Cookie (parseSetCookie, setCookieName) import Wire.API.Asset import Wire.API.Connection @@ -168,8 +168,8 @@ testUpdateEvents brig cannon = do inviteeEmail <- randomEmail -- invite and register Bob let invite = stdInvitationRequest inviteeEmail - inv <- responseJsonError =<< postInvitation brig tid alice invite - Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + inv :: Invitation <- responseJsonError =<< postInvitation brig tid alice invite + Just inviteeCode <- getInvitationCode brig tid inv.invitationId rsp2 <- post ( brig @@ -204,34 +204,34 @@ testInvitationEmail brig = do const 201 === statusCode inv <- responseJsonError res let actualHeader = getHeader "Location" res - let expectedHeader = "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' (inInvitation inv) + let expectedHeader = "/teams/" <> toByteString' tid <> "/invitations/" <> toByteString' inv.invitationId liftIO $ do - Just inviter @=? inCreatedBy inv - tid @=? inTeam inv + Just inviter @=? inv.createdBy + tid @=? inv.team assertInvitationResponseInvariants invite inv - (isNothing . inInviteeUrl) inv @? "No invitation url expected" + (isNothing . (.inviteeUrl)) inv @? "No invitation url expected" actualHeader @?= Just expectedHeader assertInvitationResponseInvariants :: InvitationRequest -> Invitation -> Assertion assertInvitationResponseInvariants invReq inv = do - inviteeName invReq @=? inInviteeName inv - inviteeEmail invReq @=? inInviteeEmail inv + invReq.inviteeName @=? inv.inviteeName + invReq.inviteeEmail @=? inv.inviteeEmail testGetInvitation :: Brig -> Http () testGetInvitation brig = do (inviter, tid) <- createUserWithTeam brig invite <- stdInvitationRequest <$> randomEmail inv1 <- responseJsonError =<< postInvitation brig tid inviter invite Http () testDeleteInvitation brig = do (inviter, tid) <- createUserWithTeam brig invite <- stdInvitationRequest <$> randomEmail - iid <- inInvitation <$> (responseJsonError =<< postInvitation brig tid inviter invite (toStrict . toByteString)) getQueryParam "team" resp @=? (pure . encodeUtf8 . idToText) tid getQueryParam :: ByteString -> ResponseLBS -> Maybe ByteString getQueryParam name r = do - inv <- (eitherToMaybe . responseJsonEither) r - url <- inInviteeUrl inv + inv :: Invitation <- (eitherToMaybe . responseJsonEither) r + url <- inv.inviteeUrl (lookup name . queryPairs . uriQuery) url -- | Mock the feature API because exposeInvitationURLsToTeamAdmin depends on @@ -309,13 +309,13 @@ testNoInvitationUrl opts brig = do Http () testInvitationEmailLookup brig = do @@ -338,6 +338,8 @@ testInvitationEmailLookupRegister brig = do email <- randomEmail (owner, tid) <- createUserWithTeam brig let invite = stdInvitationRequest email + -- This incidentally also tests that sending multiple + -- invites from the same team results in last-invite-wins scenario void $ postInvitation brig tid owner invite inv :: Invitation <- responseJsonError =<< postInvitation brig tid owner invite -- expect an invitation to be found querying with email after invite @@ -379,7 +381,7 @@ testInvitationTooManyPending opts brig (TeamSizeLimit limit) = do registerInvite :: Brig -> TeamId -> Invitation -> EmailAddress -> Http UserId registerInvite brig tid inv invemail = do - Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- getInvitationCode brig tid inv.invitationId rsp <- post ( brig @@ -483,9 +485,9 @@ createAndVerifyInvitation' replacementBrigApp acceptFn invite brig galley = do ) => m' (Maybe (UserId, UTCTimeMillis), Invitation, UserId, ResponseLBS) invitationHandshake = do - inv <- responseJsonError =<< postInvitation brig tid inviter invite - let invmeta = Just (inviter, inCreatedAt inv) - Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + inv :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite + let invmeta = Just (inviter, inv.createdAt) + Just inviteeCode <- getInvitationCode brig tid inv.invitationId Just invitation <- getInvitationInfo brig inviteeCode rsp2 <- post @@ -613,9 +615,8 @@ testInvitationCodeExists brig = do (uid, tid) <- createUserWithTeam brig let invite email = stdInvitationRequest email email <- randomEmail - rsp <- postInvitation brig tid uid (invite email) responseJsonMaybe rsp - Just invCode <- getInvitationCode brig tid invId + inv :: Invitation <- responseJsonError =<< postInvitation brig tid uid (invite email) responseJsonError r if more - then (invs :) <$> getPages (count + step) (fmap inInvitation . listToMaybe . reverse $ invs) step + then (invs :) <$> getPages (count + step) (fmap (.invitationId) . listToMaybe . reverse $ invs) step else pure [invs] let checkSize :: (HasCallStack) => Int -> [Int] -> Http () checkSize pageSize expectedSizes = @@ -740,13 +741,13 @@ testInvitationPaging opts brig = do mapM_ validateInv $ concat invss validateInv :: Invitation -> Assertion validateInv inv = do - assertEqual "tid" tid (inTeam inv) - assertBool "email" (inInviteeEmail inv `elem` emails) + assertEqual "tid" tid (inv.team) + assertBool "email" (inv.inviteeEmail `elem` emails) -- (the output list is not ordered chronologically and emails are unique, so we just -- check whether the email is one of the valid ones.) - assertBool "timestamp" (inCreatedAt inv > before && inCreatedAt inv < after1ms) - assertEqual "uid" (Just uid) (inCreatedBy inv) - -- not checked: @inInvitation inv :: InvitationId@ + assertBool "timestamp" (inv.createdAt > before && inv.createdAt < after1ms) + assertEqual "uid" (Just uid) (inv.createdBy) + -- not checked: @invitation inv :: InvitationId@ checkSize 2 [2, 2, 1] checkSize total [total] @@ -758,7 +759,7 @@ testInvitationInfo brig = do (uid, tid) <- createUserWithTeam brig let invite = stdInvitationRequest email inv <- responseJsonError =<< postInvitation brig tid uid invite - Just invCode <- getInvitationCode brig tid (inInvitation inv) + Just invCode <- getInvitationCode brig tid inv.invitationId Just invitation <- getInvitationInfo brig invCode liftIO $ assertEqual "Invitations differ" inv invitation @@ -769,15 +770,15 @@ testInvitationInfoBadCode brig = do get (brig . path ("/teams/invitations/info?code=" <> icode)) !!! const 400 === statusCode -testInvitationInfoExpired :: Brig -> Opt.Timeout -> Http () +testInvitationInfoExpired :: Brig -> Timeout -> Http () testInvitationInfoExpired brig timeout = do email <- randomEmail (uid, tid) <- createUserWithTeam brig let invite = stdInvitationRequest email - inv <- responseJsonError =<< postInvitation brig tid uid invite + inv :: Invitation <- responseJsonError =<< postInvitation brig tid uid invite -- Note: This value must be larger than the option passed as `team-invitation-timeout` - awaitExpiry (round timeout + 5) tid (inInvitation inv) - getCode tid (inInvitation inv) !!! const 400 === statusCode + awaitExpiry (round timeout + 5) tid inv.invitationId + getCode tid inv.invitationId !!! const 400 === statusCode headInvitationByEmail brig email 404 where getCode t i = @@ -801,8 +802,8 @@ testSuspendTeam brig = do (inviter, tid) <- createUserWithTeam brig -- invite and register invitee let invite = stdInvitationRequest inviteeEmail - inv <- responseJsonError =<< postInvitation brig tid inviter invite - Just inviteeCode <- getInvitationCode brig tid (inInvitation inv) + inv :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite + Just inviteeCode <- getInvitationCode brig tid inv.invitationId rsp2 <- post ( brig @@ -815,8 +816,8 @@ testSuspendTeam brig = do -- invite invitee2 (don't register) let invite2 = stdInvitationRequest inviteeEmail2 - inv2 <- responseJsonError =<< postInvitation brig tid inviter invite2 - Just _ <- getInvitationCode brig tid (inInvitation inv2) + inv2 :: Invitation <- responseJsonError =<< postInvitation brig tid inviter invite2 + Just _ <- getInvitationCode brig tid inv2.invitationId -- suspend team suspendTeam brig tid !!! const 200 === statusCode -- login fails @@ -826,7 +827,7 @@ testSuspendTeam brig = do -- check status chkStatus brig inviter Suspended chkStatus brig invitee Suspended - assertNoInvitationCode brig tid (inInvitation inv2) + assertNoInvitationCode brig tid inv2.invitationId -- unsuspend unsuspendTeam brig tid !!! const 200 === statusCode chkStatus brig inviter Active diff --git a/services/brig/test/integration/API/Team/Util.hs b/services/brig/test/integration/API/Team/Util.hs index 097616cdb57..defa0f8e5b3 100644 --- a/services/brig/test/integration/API/Team/Util.hs +++ b/services/brig/test/integration/API/Team/Util.hs @@ -90,11 +90,11 @@ createPopulatedBindingTeamWithNames brig names = do invitees <- forM names $ \name -> do inviteeEmail <- randomEmail let invite = stdInvitationRequest inviteeEmail - inv <- + inv :: Invitation <- responseJsonError =<< postInvitation brig tid (userId inviter) invite Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWS.Env -> UserJournalWatcher -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> CargoHold -> Galley -> AWS.Env -> UserJournalWatcher -> TestTree tests _ at opts p b c ch g aws userJournalWatcher = testGroup "account" @@ -490,7 +489,7 @@ testCreateUserExternalSSO brig = do post (brig . path "/register" . contentJson . body (p True True)) !!! const 400 === statusCode -testActivateWithExpiry :: Opt.Opts -> Brig -> Opt.Timeout -> Http () +testActivateWithExpiry :: Opt.Opts -> Brig -> Timeout -> Http () testActivateWithExpiry (Opt.setRestrictUserCreation . Opt.optSettings -> Just True) _ _ = pure () testActivateWithExpiry _ brig timeout = do u <- responseJsonError =<< registerUser "dilbert" brig @@ -1374,11 +1373,11 @@ testTooManyMembersForLegalhold opts brig = do -- would return in that case. inviteeEmail <- randomEmail let invite = stdInvitationRequest inviteeEmail - inv <- + inv :: Invitation <- responseJsonError =<< postInvitation brig tid owner invite show (retryTimeout, Opts.timeout opts)) @@ -1045,7 +1046,7 @@ testSuspendInactiveUsers config brig cookieType endPoint = do do diff --git a/services/brig/test/integration/API/User/Client.hs b/services/brig/test/integration/API/User/Client.hs index 4cc3d7e9648..fb6bf3fc06d 100644 --- a/services/brig/test/integration/API/User/Client.hs +++ b/services/brig/test/integration/API/User/Client.hs @@ -55,7 +55,6 @@ import Data.Set qualified as Set import Data.String.Conversions import Data.Text.Ascii (AsciiChars (validate), encodeBase64UrlUnpadded, toText) import Data.Text.Encoding qualified as T -import Data.Time (addUTCTime) import Data.Time.Clock.POSIX import Data.UUID (toByteString) import Data.UUID qualified as UUID @@ -65,11 +64,12 @@ import Network.Wai.Utilities.Error qualified as Error import System.Logger qualified as Log import Test.QuickCheck (arbitrary, generate) import Test.Tasty hiding (Timeout) -import Test.Tasty.Cannon hiding (Cannon) +import Test.Tasty.Cannon hiding (Cannon, Timeout) import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util +import Util.Timeout import Wire.API.Internal.Notification import Wire.API.MLS.CipherSuite import Wire.API.Routes.Version @@ -86,7 +86,7 @@ import Wire.API.Wrapped (Wrapped (..)) import Wire.VerificationCode qualified as Code import Wire.VerificationCodeGen -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> DB.ClientState -> Nginz -> Brig -> Cannon -> Galley -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> DB.ClientState -> Nginz -> Brig -> Cannon -> Galley -> TestTree tests _cl _at opts p db n b c g = testGroup "client" diff --git a/services/brig/test/integration/API/User/Connection.hs b/services/brig/test/integration/API/User/Connection.hs index e9023104eb9..76aebdaff09 100644 --- a/services/brig/test/integration/API/User/Connection.hs +++ b/services/brig/test/integration/API/User/Connection.hs @@ -26,7 +26,6 @@ import API.User.Util import Bilge hiding (accept, timeout) import Bilge.Assert import Brig.Data.Connection (remoteConnectionInsert) -import Brig.Options qualified as Opt import Cassandra qualified as DB import Control.Arrow ((&&&)) import Data.ByteString.Conversion @@ -34,13 +33,13 @@ import Data.Domain import Data.Id import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis) import Data.Qualified -import Data.Time.Clock (getCurrentTime) import Data.UUID.V4 qualified as UUID import Imports import Network.Wai.Utilities.Error qualified as Error import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util +import Util.Timeout import Wire.API.Connection import Wire.API.Conversation import Wire.API.Federation.API.Brig @@ -51,7 +50,7 @@ import Wire.API.User as User tests :: ConnectionLimit -> - Opt.Timeout -> + Timeout -> Manager -> Brig -> Cannon -> diff --git a/services/brig/test/integration/API/User/Handles.hs b/services/brig/test/integration/API/User/Handles.hs index 8da3c774ef2..d94f3fbe00f 100644 --- a/services/brig/test/integration/API/User/Handles.hs +++ b/services/brig/test/integration/API/User/Handles.hs @@ -41,18 +41,19 @@ import Imports import Network.Wai.Utilities.Error qualified as Error import Network.Wai.Utilities.Error qualified as Wai import Test.Tasty hiding (Timeout) -import Test.Tasty.Cannon hiding (Cannon) +import Test.Tasty.Cannon hiding (Cannon, Timeout) import Test.Tasty.Cannon qualified as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently) import Util +import Util.Timeout import Wire.API.Internal.Notification hiding (target) import Wire.API.Team.Feature (FeatureStatus (..)) import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Handle -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree tests _cl _at conf p b c g = testGroup "handles" diff --git a/services/brig/test/integration/API/User/PasswordReset.hs b/services/brig/test/integration/API/User/PasswordReset.hs index 857bb6c48a2..034c6c40ece 100644 --- a/services/brig/test/integration/API/User/PasswordReset.hs +++ b/services/brig/test/integration/API/User/PasswordReset.hs @@ -33,13 +33,14 @@ import Data.Misc import Imports import Test.Tasty hiding (Timeout) import Util +import Util.Timeout import Wire.API.User import Wire.API.User.Auth tests :: DB.ClientState -> ConnectionLimit -> - Opt.Timeout -> + Timeout -> Opt.Opts -> Manager -> Brig -> diff --git a/services/brig/test/integration/API/User/RichInfo.hs b/services/brig/test/integration/API/User/RichInfo.hs index cad0d8053b6..2ce2855a1cc 100644 --- a/services/brig/test/integration/API/User/RichInfo.hs +++ b/services/brig/test/integration/API/User/RichInfo.hs @@ -34,11 +34,12 @@ import Imports import Test.Tasty hiding (Timeout) import Test.Tasty.HUnit import Util +import Util.Timeout import Wire.API.Team.Permission import Wire.API.User import Wire.API.User.RichInfo -tests :: ConnectionLimit -> Opt.Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree +tests :: ConnectionLimit -> Timeout -> Opt.Opts -> Manager -> Brig -> Cannon -> Galley -> TestTree tests _cl _at conf p b _c g = testGroup "rich info" diff --git a/services/brig/test/integration/API/UserPendingActivation.hs b/services/brig/test/integration/API/UserPendingActivation.hs index a0b869d1d97..00e2e3e8de8 100644 --- a/services/brig/test/integration/API/UserPendingActivation.hs +++ b/services/brig/test/integration/API/UserPendingActivation.hs @@ -114,7 +114,7 @@ createUserStep :: Spar -> Brig -> ScimToken -> TeamId -> Scim.User.User SparTag createUserStep spar' brig' tok tid scimUser email = do scimStoredUser <- createUser spar' tok scimUser inv <- getInvitationByEmail brig' email - Just inviteeCode <- getInvitationCode brig' tid (inInvitation inv) + Just inviteeCode <- getInvitationCode brig' tid inv.invitationId pure (scimStoredUser, inv, inviteeCode) assertUserExist :: (HasCallStack) => String -> ClientState -> UserId -> Bool -> HttpT IO () diff --git a/services/galley/src/Galley/API/Internal.hs b/services/galley/src/Galley/API/Internal.hs index ad86b107436..d6f731aa195 100644 --- a/services/galley/src/Galley/API/Internal.hs +++ b/services/galley/src/Galley/API/Internal.hs @@ -229,7 +229,7 @@ miscAPI = <@> mkNamedAPI @"test-delete-client" Clients.rmClient <@> mkNamedAPI @"add-service" createService <@> mkNamedAPI @"delete-service" deleteService - <@> mkNamedAPI @"add-bot" Update.addBot + <@> mkNamedAPI @"i-add-bot" Update.addBot <@> mkNamedAPI @"delete-bot" Update.rmBot <@> mkNamedAPI @"put-custom-backend" setCustomBackend <@> mkNamedAPI @"delete-custom-backend" deleteCustomBackend diff --git a/services/galley/test/integration/API.hs b/services/galley/test/integration/API.hs index 1ecd7e4eab9..8a7894ff2ac 100644 --- a/services/galley/test/integration/API.hs +++ b/services/galley/test/integration/API.hs @@ -130,7 +130,7 @@ tests s = test s "metrics" metrics, test s "fetch conversation by qualified ID (v2)" testGetConvQualifiedV2, test s "create Proteus conversation" postProteusConvOk, - test s "create conversation with remote users some unreachable" (postConvWithUnreachableRemoteUsers $ Set.fromList [rb1, rb2, rb3, rb4]), + test s "create conversation with remote users, some unreachable" (postConvWithUnreachableRemoteUsers $ Set.fromList [rb1, rb2, rb3, rb4]), test s "get empty conversations" getConvsOk, test s "get conversations by ids" getConvsOk2, test s "fail to get >500 conversations with v2 API" getConvsFailMaxSizeV2, @@ -367,8 +367,10 @@ postConvWithUnreachableRemoteUsers rbs = do users <- connectBackend alice rb pure (users, participating rb users) pure $ foldr (\(a, p) acc -> bimap ((<>) a) ((<>) p) acc) ([], []) v - liftIO $ - assertBool "No unreachable backend in the test" (allRemotes /= participatingRemotes) + liftIO $ do + let notParticipatingRemotes = allRemotes \\ participatingRemotes + assertBool "No reachable backend in the test" (not (null participatingRemotes)) + assertBool "No unreachable backend in the test" (not (null notParticipatingRemotes)) let convName = "some chat" otherLocals = [qAlex] @@ -405,7 +407,7 @@ postConvWithUnreachableRemoteUsers rbs = do "Alice does have a group conversation, while she should not!" [] groupConvs - WS.assertNoEvent (3 # Second) [wsAlice, wsAlex] + WS.assertNoEvent (3 # Second) [wsAlice, wsAlex] -- TODO: sometimes, (at least?) one of these users gets a "connection accepted" event. -- @SF.Separation @TSFI.RESTfulAPI @S2 -- This test verifies whether a message actually gets sent all the way to diff --git a/services/galley/test/integration/API/Util.hs b/services/galley/test/integration/API/Util.hs index 7f7431bb3cc..16938edb549 100644 --- a/services/galley/test/integration/API/Util.hs +++ b/services/galley/test/integration/API/Util.hs @@ -426,7 +426,7 @@ addUserToTeamWithRole role inviter tid = do (inv, rsp2) <- addUserToTeamWithRole' role inviter tid let invitee :: User = responseJsonUnsafe rsp2 inviteeId = User.userId invitee - let invmeta = Just (inviter, inCreatedAt inv) + let invmeta = Just (inviter, inv.createdAt) mem <- getTeamMember inviter tid inviteeId liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Team.invitation) let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2 @@ -440,7 +440,7 @@ addUserToTeamWithRole' role inviter tid = do let invite = InvitationRequest Nothing role Nothing inviteeEmail invResponse <- postInvitation tid inviter invite inv <- responseJsonError invResponse - inviteeCode <- getInvitationCode tid (inInvitation inv) + inviteeCode <- getInvitationCode tid inv.invitationId r <- post ( brig diff --git a/services/spar/default.nix b/services/spar/default.nix index 4115e8cb670..8e5b8b51e4f 100644 --- a/services/spar/default.nix +++ b/services/spar/default.nix @@ -20,7 +20,6 @@ , cookie , crypton , crypton-x509 -, email-validate , exceptions , extended , gitignoreSource @@ -78,6 +77,7 @@ , wai-utilities , warp , wire-api +, wire-subsystems , xml-conduit , yaml , zauth @@ -138,6 +138,7 @@ mkDerivation { wai-utilities warp wire-api + wire-subsystems yaml ]; executableHaskellDepends = [ @@ -157,7 +158,6 @@ mkDerivation { containers cookie crypton - email-validate exceptions extended hscim diff --git a/services/spar/spar.cabal b/services/spar/spar.cabal index 5c7ba1d5247..2435d71165b 100644 --- a/services/spar/spar.cabal +++ b/services/spar/spar.cabal @@ -198,6 +198,7 @@ library , wai-utilities , warp , wire-api + , wire-subsystems , yaml default-language: Haskell2010 @@ -351,7 +352,6 @@ executable spar-integration , cassava , cookie , crypton - , email-validate , exceptions , extended , hscim diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index c1c307e341c..6ac9a07efae 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -50,6 +50,7 @@ import Cassandra as Cas import Control.Lens hiding ((.=)) import qualified Data.ByteString as SBS import Data.ByteString.Builder (toLazyByteString) +import Data.HavePendingInvitations import Data.Id import Data.Proxy import Data.Range diff --git a/services/spar/src/Spar/Intra/Brig.hs b/services/spar/src/Spar/Intra/Brig.hs index c11d4dd03f0..31333cf34f1 100644 --- a/services/spar/src/Spar/Intra/Brig.hs +++ b/services/spar/src/Spar/Intra/Brig.hs @@ -68,6 +68,7 @@ import Wire.API.User import Wire.API.User.Auth.ReAuth import Wire.API.User.Auth.Sso import Wire.API.User.RichInfo as RichInfo +import Wire.UserSubsystem (HavePendingInvitations (..)) ---------------------------------------------------------------------- diff --git a/services/spar/src/Spar/Intra/BrigApp.hs b/services/spar/src/Spar/Intra/BrigApp.hs index 83c377ff6fb..ec8ed68ed78 100644 --- a/services/spar/src/Spar/Intra/BrigApp.hs +++ b/services/spar/src/Spar/Intra/BrigApp.hs @@ -23,7 +23,6 @@ module Spar.Intra.BrigApp ( veidToUserSSOId, urefToExternalId, - urefToEmail, veidFromBrigUser, veidFromUserSSOId, mkUserName, @@ -37,18 +36,16 @@ module Spar.Intra.BrigApp -- * re-exports, mostly for historical reasons and lazyness emailFromSAML, - emailToSAMLNameID, - emailFromSAMLNameID, ) where import Brig.Types.Intra -import Brig.Types.User import Control.Lens import Control.Monad.Except import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import Data.Handle (Handle, parseHandle) +import Data.HavePendingInvitations import Data.Id (TeamId, UserId) import Data.Text.Encoding import Data.Text.Encoding.Error diff --git a/services/spar/src/Spar/Sem/BrigAccess.hs b/services/spar/src/Spar/Sem/BrigAccess.hs index 53041076773..46d208d1b10 100644 --- a/services/spar/src/Spar/Sem/BrigAccess.hs +++ b/services/spar/src/Spar/Sem/BrigAccess.hs @@ -44,9 +44,9 @@ module Spar.Sem.BrigAccess where import Brig.Types.Intra -import Brig.Types.User import Data.Code as Code import Data.Handle (Handle) +import Data.HavePendingInvitations import Data.Id (TeamId, UserId) import Data.Misc (PlainTextPassword6) import Imports diff --git a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs index efc6a1c3556..f055bc467f5 100644 --- a/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test-integration/Test/Spar/Scim/UserSpec.hs @@ -30,7 +30,6 @@ where import Bilge import Bilge.Assert -import Brig.Types.User as Brig import qualified Control.Exception import Control.Lens import Control.Monad.Except (MonadError (throwError)) @@ -46,6 +45,7 @@ import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv import Data.Handle (Handle, fromHandle, parseHandle, parseHandleEither) +import Data.HavePendingInvitations import Data.Id (TeamId, UserId, randomId) import Data.Ix (inRange) import Data.LanguageCodes (ISO639_1 (..)) @@ -627,7 +627,7 @@ testCreateUserNoIdPWithRole brig tid owner tok role = do -- user follows invitation flow do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email userName inviteeCode True -- check for correct role do @@ -690,7 +690,7 @@ testCreateUserNoIdP = do -- user should be able to follow old team invitation flow do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email userName inviteeCode True call $ headInvitation404 brig email @@ -1138,7 +1138,7 @@ testCreateUserTimeout = do scimStoredUser <- aFewTimesRecover (createUser tok scimUser) inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId pure (scimStoredUser, inv, inviteeCode) searchUser :: (HasCallStack) => Spar.Types.ScimToken -> Scim.User.User tag -> EmailAddress -> Bool -> TestSpar () @@ -1829,8 +1829,8 @@ lookupByValidScimId tid = registerUser :: BrigReq -> TeamId -> EmailAddress -> TestSpar () registerUser brig tid email = do let r = call $ get (brig . path "/i/teams/invitations/by-email" . queryItem "email" (toByteString' email)) - inv <- responseJsonError =<< r maybeToList mUpdatedRole}) @@ -2115,7 +2115,7 @@ createScimUserWithRole brig tid owner tok initialRole = do -- user follows invitation flow do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email userName inviteeCode True checkTeamMembersRole tid owner userid initialRole pure userid @@ -2236,7 +2236,7 @@ specDeleteUser = do do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email (Name "Alice") inviteeCode True call $ headInvitation404 brig email @@ -2348,7 +2348,7 @@ testDeletedUsersFreeExternalIdNoIdp = do -- accept invitation do inv <- call $ getInvitation brig email - Just inviteeCode <- call $ getInvitationCode brig tid (inInvitation inv) + Just inviteeCode <- call $ getInvitationCode brig tid inv.invitationId registerInvitation email userName inviteeCode True call $ headInvitation404 brig email diff --git a/services/spar/test-integration/Util/Core.hs b/services/spar/test-integration/Util/Core.hs index 5de87fd9579..e041c3d0b1c 100644 --- a/services/spar/test-integration/Util/Core.hs +++ b/services/spar/test-integration/Util/Core.hs @@ -185,7 +185,7 @@ import qualified Spar.Sem.SAMLUserStore as SAMLUserStore import qualified Spar.Sem.ScimExternalIdStore as ScimExternalIdStore import qualified System.Logger.Extended as Log import System.Random (randomRIO) -import Test.Hspec hiding (fit, it, pending, pendingWith, xit) +import Test.Hspec hiding (it, pending, pendingWith, xit) import qualified Test.Hspec import qualified Text.XML as XML import qualified Text.XML.Cursor as XML @@ -399,8 +399,8 @@ inviteAndRegisterUser :: m User inviteAndRegisterUser brig u tid inviteeEmail = do let invite = stdInvitationRequest inviteeEmail - inv <- responseJsonError =<< postInvitation tid u invite - Just inviteeCode <- getInvitationCode tid (TeamInvitation.inInvitation inv) + inv :: TeamInvitation.Invitation <- responseJsonError =<< postInvitation tid u invite + Just inviteeCode <- getInvitationCode tid inv.invitationId rspInvitee <- post ( brig diff --git a/services/spar/test-integration/Util/Scim.hs b/services/spar/test-integration/Util/Scim.hs index a077454467d..bf2b7ebe9ae 100644 --- a/services/spar/test-integration/Util/Scim.hs +++ b/services/spar/test-integration/Util/Scim.hs @@ -46,7 +46,6 @@ import qualified Spar.Intra.BrigApp as Intra import Spar.Scim.User (synthesizeScimUser, validateScimUser') import qualified Spar.Sem.ScimTokenStore as ScimTokenStore import Test.QuickCheck (arbitrary, generate) -import qualified Text.Email.Parser as Email import qualified Text.XML.DSig as SAML import Util.Core import Util.Types @@ -61,7 +60,6 @@ import qualified Web.Scim.Schema.Meta as Scim import qualified Web.Scim.Schema.PatchOp as Scim.PatchOp import qualified Web.Scim.Schema.User as Scim import qualified Web.Scim.Schema.User as Scim.User -import qualified Web.Scim.Schema.User.Email as Email import qualified Web.Scim.Schema.User.Email as Scim.Email import qualified Web.Scim.Schema.User.Phone as Phone import qualified Wire.API.Team.Member as Member @@ -203,17 +201,6 @@ randomScimUserWithNick = do nick ) -randomScimEmail :: (MonadRandom m) => m Email.Email -randomScimEmail = do - let typ :: Maybe Text = Nothing - primary :: Maybe Scim.ScimBool = Nothing -- TODO: where should we catch users with more than one - -- primary email? - value <- do - localpart <- cs <$> replicateM 15 (getRandomR ('a', 'z')) - domainpart <- (<> ".com") . cs <$> replicateM 15 (getRandomR ('a', 'z')) - pure . Email.EmailAddress $ Email.unsafeEmailAddress localpart domainpart - pure Email.Email {..} - randomScimPhone :: (MonadRandom m) => m Phone.Phone randomScimPhone = do let typ :: Maybe Text = Nothing diff --git a/services/spar/test/Test/Spar/Scim/UserSpec.hs b/services/spar/test/Test/Spar/Scim/UserSpec.hs index ebc26096d0f..5c51ed624de 100644 --- a/services/spar/test/Test/Spar/Scim/UserSpec.hs +++ b/services/spar/test/Test/Spar/Scim/UserSpec.hs @@ -2,9 +2,9 @@ module Test.Spar.Scim.UserSpec where import Arbitrary () import Brig.Types.Intra -import Brig.Types.User import Control.Monad.Except (runExceptT) import Data.Handle (parseHandle) +import Data.HavePendingInvitations import Data.Id import Imports import Polysemy diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index f5675118477..2e0f7d49efc 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -184,7 +184,7 @@ sitemap' = :<|> Named @"put-sso-domain-redirect" Intra.putSsoDomainRedirect :<|> Named @"delete-sso-domain-redirect" Intra.deleteSsoDomainRedirect :<|> Named @"register-oauth-client" Intra.registerOAuthClient - :<|> Named @"get-oauth-client" Intra.getOAuthClient + :<|> Named @"stern-get-oauth-client" Intra.getOAuthClient :<|> Named @"update-oauth-client" Intra.updateOAuthClient :<|> Named @"delete-oauth-client" Intra.deleteOAuthClient diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 38dba2f5817..3c78d30ebe5 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -411,7 +411,7 @@ type SternAPI = :> Post '[JSON] OAuthClientCredentials ) :<|> Named - "get-oauth-client" + "stern-get-oauth-client" ( Summary "Get OAuth client by id" :> "i" :> "oauth" diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index ba50b7edb6b..b7e04c9de2b 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -186,11 +186,8 @@ test-suite stern-tests executable stern-integration main-is: Main.hs - - -- cabal-fmt: expand test/integration other-modules: API - Main TestSetup Util diff --git a/tools/stern/test/integration/Util.hs b/tools/stern/test/integration/Util.hs index ba5ff5c7b49..0e533484b96 100644 --- a/tools/stern/test/integration/Util.hs +++ b/tools/stern/test/integration/Util.hs @@ -139,7 +139,7 @@ addUserToTeamWithRole role inviter tid = do (inv, rsp2) <- addUserToTeamWithRole' role inviter tid let invitee :: User = responseJsonUnsafe rsp2 inviteeId = User.userId invitee - let invmeta = Just (inviter, inCreatedAt inv) + let invmeta = Just (inviter, inv.createdAt) mem <- getTeamMember inviter tid inviteeId liftIO $ assertEqual "Member has no/wrong invitation metadata" invmeta (mem ^. Team.invitation) let zuid = parseSetCookie <$> getHeader "Set-Cookie" rsp2 @@ -153,7 +153,7 @@ addUserToTeamWithRole' role inviter tid = do let invite = InvitationRequest Nothing role Nothing email invResponse <- postInvitation tid inviter invite inv <- responseJsonError invResponse - inviteeCode <- getInvitationCode tid (inInvitation inv) + inviteeCode <- getInvitationCode tid inv.invitationId r <- post ( brig diff --git a/weeder.toml b/weeder.toml index 4e17e0becfa..66ab0310a78 100644 --- a/weeder.toml +++ b/weeder.toml @@ -20,6 +20,7 @@ roots = [ # may of the entries here are about general-purpose module "^API.Team.Util.*$", # FUTUREWORK: Consider whether unused utility functions should be kept. "^Bilge.*$", "^Cassandra.Helpers.toOptionFieldName", + "^Cassandra.QQ.sql$", "^Data.ETag._OpaqueDigest", "^Data.ETag._StrictETag", "^Data.ETag._WeakETag", @@ -125,6 +126,7 @@ roots = [ # may of the entries here are about general-purpose module "^Test.Data.Schema.userSchemaWithDefaultName'", "^Test.Federator.JSON.deriveJSONOptions", # This is used inside an instance derivation via TH "^Test.Wire.API.Golden.Run.main$", + "^Run.main$", "^Test.Wire.API.Password.testHashPasswordScrypt", # FUTUREWORK: reworking scrypt/argon2id is planned for next sprint "^TestSetup.runFederationClient", "^TestSetup.viewCargohold",