From c1bb91a88d6b03ce0c418197b7c87d993135aebe Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 7 Oct 2024 16:59:24 +0200 Subject: [PATCH 01/23] Initial endpoint skeleton --- libs/wire-api/src/Wire/API/Routes/MultiVerb.hs | 16 ++++++++-------- .../src/Wire/API/Routes/Public/Cargohold.hs | 1 - tools/stern/src/Stern/API.hs | 16 +++++++++++++++- tools/stern/src/Stern/API/Routes.hs | 10 ++++++++++ tools/stern/src/Stern/Intra.hs | 1 + 5 files changed, 34 insertions(+), 10 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs index 2dfeb16685a..ebda942c2cd 100644 --- a/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs +++ b/libs/wire-api/src/Wire/API/Routes/MultiVerb.hs @@ -110,9 +110,9 @@ type RespondEmpty s desc = RespondAs '() s desc () -- | A type to describe a streaming 'MultiVerb' response. -- --- Includes status code, description, framing strategy and content type. Note --- that the handler return type is hardcoded to be 'SourceIO ByteString'. -data RespondStreaming (s :: Nat) (desc :: Symbol) (framing :: Type) (ct :: Type) +-- Includes status code, description and content type. Note that the handler +-- return type is hardcoded to be 'SourceIO ByteString'. +data RespondStreaming (s :: Nat) (desc :: Symbol) (ct :: Type) -- | The result of parsing a response as a union alternative of type 'a'. -- @@ -268,14 +268,14 @@ instance mempty & S.description .~ Text.pack (symbolVal (Proxy @desc)) -type instance ResponseType (RespondStreaming s desc framing ct) = SourceIO ByteString +type instance ResponseType (RespondStreaming s desc ct) = SourceIO ByteString instance (Accept ct, KnownStatus s) => - IsResponse cs (RespondStreaming s desc framing ct) + IsResponse cs (RespondStreaming s desc ct) where - type ResponseStatus (RespondStreaming s desc framing ct) = s - type ResponseBody (RespondStreaming s desc framing ct) = SourceIO ByteString + type ResponseStatus (RespondStreaming s desc ct) = s + type ResponseBody (RespondStreaming s desc ct) = SourceIO ByteString responseRender _ x = pure . addContentType @ct $ Response @@ -289,7 +289,7 @@ instance guard (responseStatusCode resp == statusVal (Proxy @s)) pure $ responseBody resp -instance (KnownSymbol desc) => IsSwaggerResponse (RespondStreaming s desc framing ct) where +instance (KnownSymbol desc) => IsSwaggerResponse (RespondStreaming s desc ct) where responseSwagger = pure $ mempty diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs index d9c7ca0ed3e..4b15e9d1df2 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Cargohold.hs @@ -80,7 +80,6 @@ type AssetStreaming = RespondStreaming 200 "Asset returned directly with content type `application/octet-stream`" - NoFraming OctetStream type GetAsset = diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 3e915b2a69e..e5b28663c4e 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -28,8 +28,9 @@ module Stern.API where import Brig.Types.Intra +import Control.Concurrent.Chan import Control.Error -import Control.Lens ((.~)) +import Control.Lens (view, (.~)) import Control.Monad.Except import Data.Aeson hiding (Error, json) import Data.Aeson.KeyMap qualified as KeyMap @@ -57,6 +58,7 @@ import Network.Wai.Utilities.Server qualified as Server import Servant (NoContent (NoContent), ServerT, (:<|>) (..)) import Servant qualified import Servant.Server qualified +import Servant.Types.SourceT (fromAction) import Stern.API.Routes import Stern.App import Stern.Intra qualified as Intra @@ -71,6 +73,7 @@ import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.Named (Named (Named)) import Wire.API.Team.Feature +import Wire.API.Team.Member (teamMembers) import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Search @@ -187,6 +190,7 @@ sitemap' = :<|> Named @"stern-get-oauth-client" Intra.getOAuthClient :<|> Named @"update-oauth-client" Intra.updateOAuthClient :<|> Named @"delete-oauth-client" Intra.deleteOAuthClient + :<|> Named @"get-team-activity-info" getTeamActivityInfo sitemapInternal :: Servant.Server SternAPIInternal sitemapInternal = @@ -450,6 +454,16 @@ getUserData uid mMaxConvs mMaxNotifs = do "properties" .= properties ] +getTeamActivityInfo :: TeamId -> Handler (Servant.SourceIO ByteString) +getTeamActivityInfo tid = do + -- TODO: handle large teams + _memList <- view teamMembers <$> Intra.getTeamMembers tid + liftIO $ do + chan <- newChan + writeChan chan (Just "foo") + writeChan chan Nothing + pure $ fmap fold $ fromAction isNothing (readChan chan) + -- Utilities instance (FromByteString a) => Servant.FromHttpApiData [a] where diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 777bd118c5d..3390e090ff5 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -40,8 +40,10 @@ import Servant.Swagger.UI import Stern.Types import Wire.API.CustomBackend import Wire.API.OAuth +import Wire.API.Routes.CSV import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus) import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD +import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named import Wire.API.SwaggerHelper (cleanupSwagger) import Wire.API.Team.Feature @@ -438,6 +440,14 @@ type SternAPI = :> Capture "id" OAuthClientId :> Delete '[JSON] () ) + :<|> Named + "get-team-activity-info" + ( Summary "List user IDs and the timestamp of their last activity" + :> "team-activity-info" + :> Capture "tid" TeamId + -- :> LowLevelStream GET 200 '[] "Output CSV" CSV + :> MultiVerb1 GET '[CSV] (RespondStreaming 200 "Output CSV" CSV) + ) ------------------------------------------------------------------------------- -- Swagger diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index f72649bba90..a5e17507ff2 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -38,6 +38,7 @@ module Stern.Intra setStatusBindingTeam, deleteBindingTeam, deleteBindingTeamForce, + getTeamMembers, getTeamInfo, getUserBindingTeam, isBlacklisted, From 617d5d75cdeb10be538c94322615cc900961dcff Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 8 Oct 2024 16:38:37 +0200 Subject: [PATCH 02/23] Set up finalisation for CSV streaming --- .../src/Wire/API/Routes/LowLevelStream.hs | 38 ++++++++++++++----- libs/wire-api/wire-api.cabal | 1 + services/galley/src/Galley/API/Teams.hs | 11 ++++-- tools/stern/src/Stern/API.hs | 36 +++++++++++++----- tools/stern/src/Stern/API/Routes.hs | 5 +-- tools/stern/stern.cabal | 1 + 6 files changed, 66 insertions(+), 26 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs b/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs index f39080b54f7..0313c04ced8 100644 --- a/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs +++ b/libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs @@ -18,6 +18,8 @@ module Wire.API.Routes.LowLevelStream where import Control.Lens (at, (.~), (?~), _Just) +import Control.Monad.Codensity +import Control.Monad.Trans.Resource import Data.ByteString.Char8 as B8 import Data.CaseInsensitive qualified as CI import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap @@ -39,6 +41,10 @@ import Servant.Server hiding (respond) import Servant.Server.Internal import Wire.API.Routes.Version +-- | Used as the return type of a streaming handler. The 'Codensity' wrapper +-- makes it possible to add finalisation logic to the streaming action. +type LowLevelStreamingBody = Codensity IO StreamingBody + -- FUTUREWORK: make it possible to generate headers at runtime data LowLevelStream method status (headers :: [(Symbol, Symbol)]) desc ctype @@ -63,7 +69,9 @@ instance (ReflectMethod method, KnownNat status, RenderHeaders headers, Accept ctype) => HasServer (LowLevelStream method status headers desc ctype) context where - type ServerT (LowLevelStream method status headers desc ctype) m = m StreamingBody + type + ServerT (LowLevelStream method status headers desc ctype) m = + m LowLevelStreamingBody hoistServerWithContext _ _ nt s = nt s route Proxy _ action = leafRouter $ \env request respond -> @@ -71,15 +79,25 @@ instance cmediatype = HTTP.matchAccept [contentType (Proxy @ctype)] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 contentHeader = (hContentType, HTTP.renderHeader . maybeToList $ cmediatype) - in runAction - ( action - `addMethodCheck` methodCheck method request - `addAcceptCheck` accCheck - ) - env - request - respond - $ Route . responseStream status (contentHeader : extraHeaders) + in runResourceT $ do + r <- + runDelayed + ( action + `addMethodCheck` methodCheck method request + `addAcceptCheck` accCheck + ) + env + request + liftIO $ case r of + Route h -> + runHandler h >>= \case + Left e -> respond $ FailFatal e + Right getStreamingBody -> lowerCodensity $ do + body <- getStreamingBody + let resp = responseStream status (contentHeader : extraHeaders) body + lift $ respond $ Route resp + Fail e -> respond $ Fail e + FailFatal e -> respond $ FailFatal e where method = reflectMethod (Proxy :: Proxy method) status = statusFromNat (Proxy :: Proxy status) diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 1091c12f7f3..33c53b3ddf3 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -300,6 +300,7 @@ library , iso3166-country-codes >=0.2 , iso639 >=0.1 , jose + , kan-extensions , lens >=4.12 , memory , metrics-wai diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index b59465923af..124945508f6 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -112,7 +112,6 @@ import Galley.Types.Conversations.Members qualified as Conv import Galley.Types.Teams import Galley.Types.UserList import Imports hiding (forkIO) -import Network.Wai import Polysemy import Polysemy.Error import Polysemy.Final @@ -132,6 +131,7 @@ import Wire.API.Event.Team import Wire.API.Federation.Error import Wire.API.Message qualified as Conv import Wire.API.Routes.Internal.Galley.TeamsIntra +import Wire.API.Routes.LowLevelStream import Wire.API.Routes.MultiTablePaging (MultiTablePage (MultiTablePage), MultiTablePagingState (mtpsState)) import Wire.API.Routes.Public.Galley.TeamMember import Wire.API.Team @@ -500,9 +500,12 @@ getTeamMembers lzusr tid mbMaxResults mbPagingState = do (pwsHasMore p) (teamMemberPagingState p) -outputToStreamingBody :: (Member (Final IO) r) => Sem (Output LByteString ': r) () -> Sem r StreamingBody +outputToStreamingBody :: + (Member (Final IO) r) => + Sem (Output LByteString ': r) () -> + Sem r LowLevelStreamingBody outputToStreamingBody action = withWeavingToFinal @IO $ \state weave _inspect -> - pure . (<$ state) $ \write flush -> do + pure . (<$ state) $ pure $ \write flush -> do let writeChunk c = embedFinal $ do write (lazyByteString c) flush @@ -518,7 +521,7 @@ getTeamMembersCSV :: ) => Local UserId -> TeamId -> - Sem r StreamingBody + Sem r LowLevelStreamingBody getTeamMembersCSV lusr tid = do E.getTeamMember tid (tUnqualified lusr) >>= \case Nothing -> throwS @'AccessDenied diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index e5b28663c4e..7e177ad512b 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -30,12 +30,16 @@ where import Brig.Types.Intra import Control.Concurrent.Chan import Control.Error +import Control.Exception (catch) import Control.Lens (view, (.~)) +import Control.Monad.Codensity import Control.Monad.Except import Data.Aeson hiding (Error, json) import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types (emptyArray) import Data.ByteString (fromStrict) +import Data.ByteString.Builder (byteString) +import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Conversion import Data.Handle (Handle) import Data.Id @@ -48,6 +52,7 @@ import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Encoding qualified as LT +import Debug.Trace import GHC.TypeLits (KnownSymbol) import Imports hiding (head) import Network.HTTP.Types @@ -58,19 +63,20 @@ import Network.Wai.Utilities.Server qualified as Server import Servant (NoContent (NoContent), ServerT, (:<|>) (..)) import Servant qualified import Servant.Server qualified -import Servant.Types.SourceT (fromAction) import Stern.API.Routes import Stern.App import Stern.Intra qualified as Intra import Stern.Options import Stern.Types -import System.Logger.Class hiding (Error, name, trace, (.=)) +import System.Logger.Class hiding (Error, flush, name, trace, (.=)) +import UnliftIO.Async import Util.Options import Wire.API.Connection import Wire.API.Internal.Notification (QueuedNotification) import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus) import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team +import Wire.API.Routes.LowLevelStream import Wire.API.Routes.Named (Named (Named)) import Wire.API.Team.Feature import Wire.API.Team.Member (teamMembers) @@ -454,15 +460,27 @@ getUserData uid mMaxConvs mMaxNotifs = do "properties" .= properties ] -getTeamActivityInfo :: TeamId -> Handler (Servant.SourceIO ByteString) +getTeamActivityInfo :: TeamId -> Handler LowLevelStreamingBody getTeamActivityInfo tid = do + traceM "getTeamActivityInfo" -- TODO: handle large teams - _memList <- view teamMembers <$> Intra.getTeamMembers tid - liftIO $ do - chan <- newChan - writeChan chan (Just "foo") - writeChan chan Nothing - pure $ fmap fold $ fromAction isNothing (readChan chan) + memList <- view teamMembers <$> Intra.getTeamMembers tid + pure $ do + chan <- liftIO newChan + let runThread = do + pooledForConcurrentlyN_ 8 memList $ \user -> do + -- get user info + info <- Intra.getUserInfo user -- ??? + writeChan chan Nothing + void $ Codensity $ withAsync runThread + let body write flush = do + let go = do + traceM "write chunk" + readChan chan >>= \case + Nothing -> write "" >> flush + Just line -> write (byteString line <> "\n") >> flush >> go + go + pure (body :: StreamingBody) -- Utilities diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 3390e090ff5..9fc6f634694 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -43,7 +43,7 @@ import Wire.API.OAuth import Wire.API.Routes.CSV import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus) import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD -import Wire.API.Routes.MultiVerb +import Wire.API.Routes.LowLevelStream import Wire.API.Routes.Named import Wire.API.SwaggerHelper (cleanupSwagger) import Wire.API.Team.Feature @@ -445,8 +445,7 @@ type SternAPI = ( Summary "List user IDs and the timestamp of their last activity" :> "team-activity-info" :> Capture "tid" TeamId - -- :> LowLevelStream GET 200 '[] "Output CSV" CSV - :> MultiVerb1 GET '[CSV] (RespondStreaming 200 "Output CSV" CSV) + :> LowLevelStream GET 200 '[] "Output CSV" CSV ) ------------------------------------------------------------------------------- diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index b7e04c9de2b..96e7d90acc6 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -86,6 +86,7 @@ library , http-client >=0.7 , http-types >=0.8 , imports + , kan-extensions , lens >=4.4 , mtl >=2.1 , openapi3 From c99c4210c0c0c23a80b6f3fdf5d7370cd86e8336 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Tue, 8 Oct 2024 17:01:26 +0200 Subject: [PATCH 03/23] Implement internal API to get user activity --- .../src/Wire/API/Routes/Internal/Brig.hs | 9 ++ libs/wire-api/src/Wire/API/Team/Member.hs | 1 + libs/wire-subsystems/src/Wire/UserStore.hs | 2 + .../src/Wire/UserStore/Cassandra.hs | 9 ++ .../wire-subsystems/src/Wire/UserSubsystem.hs | 2 + .../src/Wire/UserSubsystem/Interpreter.hs | 126 ++++++++---------- .../test/unit/Wire/MiniBackend.hs | 2 +- .../unit/Wire/MockInterpreters/UserStore.hs | 1 + services/brig/src/Brig/API/Internal.hs | 12 ++ .../brig/src/Brig/CanonicalInterpreter.hs | 4 +- tools/stern/src/Stern/API.hs | 25 +++- tools/stern/src/Stern/App.hs | 3 + tools/stern/src/Stern/Intra.hs | 16 +++ tools/stern/stern.cabal | 1 + 14 files changed, 137 insertions(+), 76 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 5c6dc34ffd9..522fd71f243 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -47,6 +47,7 @@ import Data.CommaSeparatedList import Data.Domain (Domain) import Data.Handle (Handle) import Data.Id as Id +import Data.Json.Util import Data.OpenApi (HasInfo (info), HasTitle (title), OpenApi) import Data.OpenApi qualified as S import Data.Qualified (Qualified) @@ -601,6 +602,14 @@ type UserAPI = UpdateUserLocale :<|> DeleteUserLocale :<|> GetDefaultLocale + :<|> Named + "get-activity-timestamp" + ( Summary "Get the last activity timestamp of a user" + :> "users" + :> Capture "uid" UserId + :> "activity" + :> MultiVerb1 'GET '[JSON] (Respond 200 "Activity" (Maybe UTCTimeMillis)) + ) type UpdateUserLocale = Summary diff --git a/libs/wire-api/src/Wire/API/Team/Member.hs b/libs/wire-api/src/Wire/API/Team/Member.hs index 98720fab69b..108e19adb98 100644 --- a/libs/wire-api/src/Wire/API/Team/Member.hs +++ b/libs/wire-api/src/Wire/API/Team/Member.hs @@ -22,6 +22,7 @@ module Wire.API.Team.Member ( -- * TeamMember TeamMember, + newTeamMember, mkTeamMember, userId, permissions, diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 55373c0a37d..80fe618196e 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -6,6 +6,7 @@ import Cassandra (PageWithState (..), PagingState) import Data.Default import Data.Handle import Data.Id +import Data.Time.Clock import Imports import Polysemy import Polysemy.Error @@ -67,6 +68,7 @@ data UserStore m a where IsActivated :: UserId -> UserStore m Bool LookupLocale :: UserId -> UserStore m (Maybe (Maybe Language, Maybe Country)) UpdateUserTeam :: UserId -> TeamId -> UserStore m () + GetActivityTimestamps :: UserId -> UserStore m [Maybe UTCTime] makeSem ''UserStore diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index 66d35568d27..c4ef4562d89 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -4,6 +4,7 @@ import Cassandra import Cassandra.Exec (prepared) import Data.Handle import Data.Id +import Data.Time.Clock import Database.CQL.Protocol import Imports import Polysemy @@ -31,6 +32,7 @@ interpretUserStoreCassandra casClient = IsActivated uid -> isActivatedImpl uid LookupLocale uid -> lookupLocaleImpl uid UpdateUserTeam uid tid -> updateUserTeamImpl uid tid + GetActivityTimestamps uid -> getActivityTimestampsImpl uid getUsersImpl :: [UserId] -> Client [StoredUser] getUsersImpl usrs = @@ -169,6 +171,13 @@ updateUserTeamImpl u t = retry x5 $ write userTeamUpdate (params LocalQuorum (t, userTeamUpdate :: PrepQuery W (TeamId, UserId) () userTeamUpdate = "UPDATE user SET team = ? WHERE id = ?" +getActivityTimestampsImpl :: UserId -> Client [Maybe UTCTime] +getActivityTimestampsImpl uid = do + runIdentity <$$> retry x1 (query q (params LocalQuorum (Identity uid))) + where + q :: PrepQuery R (Identity UserId) (Identity (Maybe UTCTime)) + q = "SELECT last_active from clients where user = ?" + -------------------------------------------------------------------------------- -- Queries diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 10357641b71..f677f7fb2a3 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -15,6 +15,7 @@ import Data.Id import Data.Misc import Data.Qualified import Data.Range +import Data.Time.Clock import Imports import Polysemy import Polysemy.Error @@ -143,6 +144,7 @@ data UserSubsystem m a where -- migration this would just be an internal detail of the subsystem InternalUpdateSearchIndex :: UserId -> UserSubsystem m () InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m StoredInvitation + GetUserActivityTimestamp :: UserId -> UserSubsystem m (Maybe UTCTime) -- | the return type of 'CheckHandle' data CheckHandleResp diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index bbcbe719eb8..e0b818507a5 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -100,76 +100,58 @@ runUserSubsystem :: Member FederationConfigStore r, Member Metrics r, Member InvitationStore r, - Member TinyLog r + Member TinyLog r, + Member (Input UserSubsystemConfig) r ) => - UserSubsystemConfig -> InterpreterFor AuthenticationSubsystem r -> - InterpreterFor UserSubsystem r -runUserSubsystem cfg authInterpreter = - interpret $ - \case - GetUserProfiles self others -> - runInputConst cfg $ - getUserProfilesImpl self others - GetLocalUserProfiles others -> - runInputConst cfg $ - getLocalUserProfilesImpl others - GetAccountsBy getBy -> - runInputConst cfg $ - getAccountsByImpl getBy - GetAccountsByEmailNoFilter emails -> - runInputConst cfg $ - getAccountsByEmailNoFilterImpl emails - GetAccountNoFilter luid -> - runInputConst cfg $ - getAccountNoFilterImpl luid - GetSelfProfile self -> - runInputConst cfg $ - getSelfProfileImpl self - GetUserProfilesWithErrors self others -> - runInputConst cfg $ - getUserProfilesWithErrorsImpl self others - UpdateUserProfile self mconn mb update -> - runInputConst cfg $ - updateUserProfileImpl self mconn mb update - CheckHandle uhandle -> - runInputConst cfg $ - checkHandleImpl uhandle - CheckHandles hdls cnt -> - runInputConst cfg $ - checkHandlesImpl hdls cnt - UpdateHandle uid mconn mb uhandle -> - runInputConst cfg $ - updateHandleImpl uid mconn mb uhandle - LookupLocaleWithDefault luid -> - runInputConst cfg $ - lookupLocaleOrDefaultImpl luid - IsBlocked email -> - runInputConst cfg $ - isBlockedImpl email - BlockListDelete email -> - runInputConst cfg $ - blockListDeleteImpl email - BlockListInsert email -> - runInputConst cfg $ - blockListInsertImpl email - UpdateTeamSearchVisibilityInbound status -> - runInputConst cfg $ - updateTeamSearchVisibilityInboundImpl status - SearchUsers luid query mDomain mMaxResults -> - runInputConst cfg $ - searchUsersImpl luid query mDomain mMaxResults - BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> - browseTeamImpl uid browseTeamFilters mMaxResults mPagingState - InternalUpdateSearchIndex uid -> - syncUserIndex uid - AcceptTeamInvitation luid pwd code -> - authInterpreter - . runInputConst cfg - $ acceptTeamInvitationImpl luid pwd code - InternalFindTeamInvitation mEmailKey code -> - runInputConst cfg $ - internalFindTeamInvitationImpl mEmailKey code + Sem (UserSubsystem ': r) a -> + Sem r a +runUserSubsystem authInterpreter = interpret $ + \case + GetUserProfiles self others -> + getUserProfilesImpl self others + GetLocalUserProfiles others -> + getLocalUserProfilesImpl others + GetAccountsBy getBy -> + getAccountsByImpl getBy + GetAccountsByEmailNoFilter emails -> + getAccountsByEmailNoFilterImpl 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 + LookupLocaleWithDefault luid -> + lookupLocaleOrDefaultImpl luid + IsBlocked email -> + isBlockedImpl email + BlockListDelete email -> + blockListDeleteImpl email + BlockListInsert email -> + blockListInsertImpl email + UpdateTeamSearchVisibilityInbound status -> + updateTeamSearchVisibilityInboundImpl status + SearchUsers luid query mDomain mMaxResults -> + searchUsersImpl luid query mDomain mMaxResults + BrowseTeam uid browseTeamFilters mMaxResults mPagingState -> + browseTeamImpl uid browseTeamFilters mMaxResults mPagingState + InternalUpdateSearchIndex uid -> + syncUserIndex uid + AcceptTeamInvitation luid pwd code -> + authInterpreter $ + acceptTeamInvitationImpl luid pwd code + InternalFindTeamInvitation mEmailKey code -> + internalFindTeamInvitationImpl mEmailKey code + GetUserActivityTimestamp uid -> getUserActivityTimestampImpl uid internalFindTeamInvitationImpl :: ( Member InvitationStore r, @@ -939,3 +921,11 @@ acceptTeamInvitationImpl luid pw code = do deleteInvitation inv.teamId inv.invitationId syncUserIndex uid generateUserEvent uid Nothing (teamUpdated uid tid) + +getUserActivityTimestampImpl :: (Member UserStore r) => UserId -> Sem r (Maybe UTCTime) +getUserActivityTimestampImpl = + fmap + ( maximum + . (Nothing :) -- make sure the list of timestamps is non-empty + ) + . getActivityTimestamps diff --git a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs index a13271b863a..ee951963bbc 100644 --- a/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs +++ b/libs/wire-subsystems/test/unit/Wire/MiniBackend.hs @@ -400,7 +400,7 @@ interpretMaybeFederationStackState maybeFederationAPIAccess localBackend teamMem authSubsystemInterpreter = interpretAuthenticationSubsystem userSubsystemInterpreter userSubsystemInterpreter :: InterpreterFor UserSubsystem (MiniBackendLowerEffects `Append` r) - userSubsystemInterpreter = runUserSubsystem cfg authSubsystemInterpreter + userSubsystemInterpreter = runUserSubsystem authSubsystemInterpreter in sequentiallyPerformConcurrency . noOpLogger . maybeFederationAPIAccess diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index a4c05c44b5c..c8f47d1b067 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -71,6 +71,7 @@ inMemoryUserStoreInterpreter = interpret $ \case modify $ map (\u -> if u.id == uid then u {teamId = Just tid} :: StoredUser else u) + GetActivityTimestamps _ -> pure [] storedUserToIndexUser :: StoredUser -> IndexUser storedUserToIndexUser storedUser = diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 052c5cdb59f..a5af05ead8e 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -57,6 +57,7 @@ import Data.Domain (Domain) import Data.Handle import Data.HavePendingInvitations import Data.Id as Id +import Data.Json.Util import Data.Map.Strict qualified as Map import Data.Qualified import Data.Set qualified as Set @@ -266,6 +267,7 @@ userAPI = updateLocale :<|> deleteLocale :<|> getDefaultUserLocale + :<|> Named @"get-activity-timestamp" getUserActivityTimestampH clientAPI :: ServerT BrigIRoutes.ClientAPI (Handler r) clientAPI = Named @"update-client-last-active" updateClientLastActive @@ -800,3 +802,13 @@ checkHandleInternalH h = lift $ liftSem do getContactListH :: UserId -> (Handler r) UserIds getContactListH uid = lift . wrapClient $ UserIds <$> API.lookupContactList uid + +getUserActivityTimestampH :: + (Member UserSubsystem r) => + UserId -> + Handler r (Maybe UTCTimeMillis) +getUserActivityTimestampH = + lift + . liftSem + . fmap (fmap toUTCTimeMillis) + . getUserActivityTimestamp diff --git a/services/brig/src/Brig/CanonicalInterpreter.hs b/services/brig/src/Brig/CanonicalInterpreter.hs index b2967854fd6..e0f9672bf57 100644 --- a/services/brig/src/Brig/CanonicalInterpreter.hs +++ b/services/brig/src/Brig/CanonicalInterpreter.hs @@ -134,6 +134,7 @@ type BrigLowerLevelEffects = PropertyStore, SFT, ConnectionStore InternalPaging, + Input UserSubsystemConfig, Input VerificationCodeThrottleTTL, Input UTCTime, Input (Local ()), @@ -213,7 +214,7 @@ runBrigToIO e (AppT ma) = do -- These interpreters depend on each other, we use let recursion to solve that. userSubsystemInterpreter :: (Members BrigLowerLevelEffects r) => InterpreterFor UserSubsystem r - userSubsystemInterpreter = runUserSubsystem userSubsystemConfig authSubsystemInterpreter + userSubsystemInterpreter = runUserSubsystem authSubsystemInterpreter authSubsystemInterpreter :: (Members BrigLowerLevelEffects r) => InterpreterFor AuthenticationSubsystem r authSubsystemInterpreter = interpretAuthenticationSubsystem userSubsystemInterpreter @@ -251,6 +252,7 @@ runBrigToIO e (AppT ma) = do . runInputConst (toLocalUnsafe e.settings.federationDomain ()) . runInputSem (embed getCurrentTime) . runInputConst (fromIntegral $ Opt.twoFACodeGenerationDelaySecs e.settings) + . runInputConst userSubsystemConfig . connectionStoreToCassandra . interpretSFT e.httpManager . interpretPropertyStoreCassandra e.casClient diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 7e177ad512b..b0f0322549c 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -30,8 +30,8 @@ where import Brig.Types.Intra import Control.Concurrent.Chan import Control.Error -import Control.Exception (catch) -import Control.Lens (view, (.~)) +import Control.Exception (throwIO) +import Control.Lens (toListOf, (.~)) import Control.Monad.Codensity import Control.Monad.Except import Data.Aeson hiding (Error, json) @@ -79,7 +79,7 @@ import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team import Wire.API.Routes.LowLevelStream import Wire.API.Routes.Named (Named (Named)) import Wire.API.Team.Feature -import Wire.API.Team.Member (teamMembers) +import Wire.API.Team.Member qualified as Team import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Search @@ -464,13 +464,26 @@ getTeamActivityInfo :: TeamId -> Handler LowLevelStreamingBody getTeamActivityInfo tid = do traceM "getTeamActivityInfo" -- TODO: handle large teams - memList <- view teamMembers <$> Intra.getTeamMembers tid + memList <- + toListOf (Team.teamMembers . traverse . Team.newTeamMember . Team.nUserId) + <$> Intra.getTeamMembers tid + env <- ask pure $ do chan <- liftIO newChan - let runThread = do + let runThread :: IO () = do pooledForConcurrentlyN_ 8 memList $ \user -> do -- get user info - info <- Intra.getUserInfo user -- ??? + tm <- + runHandler env (Intra.getActivityTimestamp user) + >>= either throwIO pure + writeChan + chan + ( Just + ( toByteString' user + <> "," + <> B8.pack (maybe mempty show tm) + ) + ) writeChan chan Nothing void $ Codensity $ withAsync runThread let body write flush = do diff --git a/tools/stern/src/Stern/App.hs b/tools/stern/src/Stern/App.hs index 1056cf37182..612c9c67cd8 100644 --- a/tools/stern/src/Stern/App.hs +++ b/tools/stern/src/Stern/App.hs @@ -124,6 +124,9 @@ runAppT e (AppT ma) = runReaderT ma e type Handler = ExceptT Error App +runHandler :: Env -> Handler a -> IO (Either Error a) +runHandler env = runAppT env . runExceptT + type Continue m = Response -> m ResponseReceived userMsg :: UserId -> Msg -> Msg diff --git a/tools/stern/src/Stern/Intra.hs b/tools/stern/src/Stern/Intra.hs index a5e17507ff2..d226f49f252 100644 --- a/tools/stern/src/Stern/Intra.hs +++ b/tools/stern/src/Stern/Intra.hs @@ -67,6 +67,7 @@ module Stern.Intra getOAuthClient, updateOAuthClient, deleteOAuthClient, + getActivityTimestamp, ) where @@ -93,6 +94,7 @@ import Data.Text.Encoding import Data.Text.Encoding.Error import Data.Text.Lazy as LT (pack) import Data.Text.Lazy.Encoding qualified as TL +import Data.Time.Clock import Imports import Network.HTTP.Types (urlEncode) import Network.HTTP.Types.Method @@ -1038,3 +1040,17 @@ deleteOAuthClient cid = do . expect2xx ) parseResponse (mkError status502 "bad-upstream") r + +getActivityTimestamp :: UserId -> Handler (Maybe UTCTime) +getActivityTimestamp uid = do + b <- asks (.brig) + r <- + catchRpcErrors $ + rpc' + "brig" + b + ( method GET + . Bilge.paths ["i", "users", toByteString' uid, "activity"] + . expect2xx + ) + parseResponse (mkError status502 "bad-upstream") r diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index 96e7d90acc6..ccef8770f72 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -97,6 +97,7 @@ library , servant-swagger-ui , split >=0.2 , text >=1.1 + , time , tinylog >=0.10 , transformers >=0.3 , types-common >=0.4.13 From 1b96ff0407869219ed5b0f309a9539c272cf6ebf Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 10 Oct 2024 10:37:01 +0200 Subject: [PATCH 04/23] Test activity endpoint --- integration/integration.cabal | 1 + integration/test/API/Stern.hs | 14 +++++++++ integration/test/Test/Client.hs | 31 +++++++++++++++++++ integration/test/Testlib/Assertions.hs | 1 + .../src/Wire/UserSubsystem/Interpreter.hs | 12 +++---- tools/stern/src/Stern/API.hs | 8 ++++- 6 files changed, 60 insertions(+), 7 deletions(-) create mode 100644 integration/test/API/Stern.hs diff --git a/integration/integration.cabal b/integration/integration.cabal index a3989f28e76..edada8586df 100644 --- a/integration/integration.cabal +++ b/integration/integration.cabal @@ -100,6 +100,7 @@ library API.GundeckInternal API.Nginz API.Spar + API.Stern MLS.Util Notifications RunAllTests diff --git a/integration/test/API/Stern.hs b/integration/test/API/Stern.hs new file mode 100644 index 00000000000..b6fc52a11dc --- /dev/null +++ b/integration/test/API/Stern.hs @@ -0,0 +1,14 @@ +module API.Stern where + +import API.BrigCommon +import API.Common +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Pair) +import Data.Function +import Data.Maybe +import Testlib.Prelude + +getTeamActivity :: (HasCallStack, MakesValue domain) => domain -> String -> App Response +getTeamActivity domain tid = + baseRequest domain Stern Unversioned (joinHttpPath ["team-activity-info", tid]) + >>= submit "GET" diff --git a/integration/test/Test/Client.hs b/integration/test/Test/Client.hs index 8c3101737dd..12f04f284c0 100644 --- a/integration/test/Test/Client.hs +++ b/integration/test/Test/Client.hs @@ -6,10 +6,12 @@ import API.Brig import qualified API.Brig as API import API.BrigCommon import API.Gundeck +import API.Stern import Control.Lens hiding ((.=)) import Control.Monad.Codensity import Control.Monad.Reader import Data.Aeson hiding ((.=)) +import qualified Data.ByteString.Char8 as B8 import Data.ProtoLens.Labels () import Data.Time.Clock.POSIX import Data.Time.Clock.System @@ -42,6 +44,35 @@ testClientLastActive = do <$> parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" tm1 assertBool "last_active is earlier than expected" $ ts1 >= now +testTeamActivity :: (HasCallStack) => App () +testTeamActivity = do + (alice, tid, [bob, charlie]) <- createTeam OwnDomain 3 + [alice1, _alice2] <- replicateM 2 $ addClient alice def >>= getJSON 201 + [_bob1, _bob2] <- replicateM 2 $ addClient bob def >>= getJSON 201 + charlie1 <- addClient charlie def >>= getJSON 201 + + now <- + formatTime defaultTimeLocale "%Y-%m-%d" + . systemToUTCTime + <$> liftIO getSystemTime + + for_ [(alice, alice1), (charlie, charlie1)] $ \(u, cl) -> do + clientId <- cl %. "id" & asString + void $ getNotifications u def {client = Just clientId} + + let row (u, t) = do + uid <- u %. "id" & asString + pure (uid, t) + + expectedRows <- sort <$> traverse row [(alice, True), (bob, False), (charlie, True)] + + bindResponse (getTeamActivity alice tid) $ \resp -> do + resp.status `shouldMatchInt` 200 + for_ (zip (sort (B8.lines resp.body)) expectedRows) $ \(row, (uid, active)) -> do + let [actualUser, timestamp] = B8.split ',' row + B8.unpack actualUser `shouldMatch` uid + B8.null timestamp `shouldMatch` not active + testListClientsIfBackendIsOffline :: (HasCallStack) => App () testListClientsIfBackendIsOffline = do resourcePool <- asks (.resourcePool) diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index 28ddf0c0af1..f89a143d41d 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -14,6 +14,7 @@ import qualified Data.Aeson.Diff as AD import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Aeson.KeyMap as Aeson import Data.Aeson.Lens (_Array, _Object) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BS import Data.Char diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index e0b818507a5..0807bdc2723 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -923,9 +923,9 @@ acceptTeamInvitationImpl luid pw code = do generateUserEvent uid Nothing (teamUpdated uid tid) getUserActivityTimestampImpl :: (Member UserStore r) => UserId -> Sem r (Maybe UTCTime) -getUserActivityTimestampImpl = - fmap - ( maximum - . (Nothing :) -- make sure the list of timestamps is non-empty - ) - . getActivityTimestamps +getUserActivityTimestampImpl uid = do + ts <- getActivityTimestamps uid + pure $ + maximum + -- make sure the list of timestamps is non-empty) + (Nothing : ts) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index b0f0322549c..0f86eb54b2c 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -52,6 +52,7 @@ import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Encoding qualified as LT +import Data.Time.Format import Debug.Trace import GHC.TypeLits (KnownSymbol) import Imports hiding (head) @@ -481,7 +482,12 @@ getTeamActivityInfo tid = do ( Just ( toByteString' user <> "," - <> B8.pack (maybe mempty show tm) + <> B8.pack + ( maybe + mempty + (formatTime defaultTimeLocale "%Y-%m-%d") + tm + ) ) ) writeChan chan Nothing From 2ac05036ec6ab97c5f114fba09a1ae83a40df8cf Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 10 Oct 2024 16:10:41 +0200 Subject: [PATCH 05/23] Initial refactoring of CSV export --- .../src/Wire/API/Routes/Internal/Brig.hs | 9 ++++ libs/wire-api/src/Wire/API/Team/Export.hs | 22 ++++++++ libs/wire-subsystems/src/Wire/UserStore.hs | 2 + .../src/Wire/UserStore/Cassandra.hs | 10 ++++ .../wire-subsystems/src/Wire/UserSubsystem.hs | 2 + .../src/Wire/UserSubsystem/Interpreter.hs | 53 ++++++++++++++++++- .../unit/Wire/MockInterpreters/UserStore.hs | 1 + libs/wire-subsystems/wire-subsystems.cabal | 1 + services/brig/src/Brig/API/Internal.hs | 8 +++ services/brig/src/Brig/Data/User.hs | 1 + services/galley/galley.cabal | 1 + .../galley/src/Galley/API/Teams/Export.hs | 23 ++++++++ .../galley/src/Galley/Effects/BrigAccess.hs | 3 ++ services/galley/src/Galley/Intra/Effects.hs | 3 ++ services/galley/src/Galley/Intra/User.hs | 12 +++++ tools/stern/src/Stern/API.hs | 1 - 16 files changed, 149 insertions(+), 3 deletions(-) create mode 100644 services/galley/src/Galley/API/Teams/Export.hs diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 522fd71f243..855de2714ef 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -77,6 +77,7 @@ import Wire.API.Routes.Internal.LegalHold qualified as LegalHoldInternalAPI import Wire.API.Routes.MultiVerb import Wire.API.Routes.Named import Wire.API.Routes.Public (ZUser) +import Wire.API.Team.Export (TeamExportUser) import Wire.API.Team.Feature import Wire.API.Team.Invitation (Invitation) import Wire.API.Team.LegalHold.Internal @@ -610,6 +611,14 @@ type UserAPI = :> "activity" :> MultiVerb1 'GET '[JSON] (Respond 200 "Activity" (Maybe UTCTimeMillis)) ) + :<|> Named + "get-user-export-data" + ( Summary "Get user export data" + :> "users" + :> Capture "uid" UserId + :> "export-data" + :> MultiVerb1 'GET '[JSON] (Respond 200 "User export data" (Maybe TeamExportUser)) + ) type UpdateUserLocale = Summary diff --git a/libs/wire-api/src/Wire/API/Team/Export.hs b/libs/wire-api/src/Wire/API/Team/Export.hs index 7a37047c307..61304ad28eb 100644 --- a/libs/wire-api/src/Wire/API/Team/Export.hs +++ b/libs/wire-api/src/Wire/API/Team/Export.hs @@ -17,6 +17,7 @@ module Wire.API.Team.Export (TeamExportUser (..), quoted, unquoted) where +import Data.Aeson qualified as A import Data.Aeson qualified as Aeson import Data.Attoparsec.ByteString.Lazy (parseOnly) import Data.ByteString.Char8 qualified as C @@ -26,6 +27,8 @@ import Data.Handle (Handle) import Data.Id (UserId) import Data.Json.Util (UTCTimeMillis) import Data.Misc (HttpsUrl) +import Data.OpenApi qualified as OpenApi +import Data.Schema import Data.Vector (fromList) import Imports import Test.QuickCheck @@ -53,6 +56,25 @@ data TeamExportUser = TeamExportUser } deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform TeamExportUser) + deriving (A.ToJSON, A.FromJSON, OpenApi.ToSchema) via (Schema TeamExportUser) + +instance ToSchema TeamExportUser where + schema = + object "TeamExportUser" $ + TeamExportUser + <$> tExportDisplayName .= field "display_name" schema + <*> tExportHandle .= maybe_ (optField "handle" schema) + <*> tExportEmail .= maybe_ (optField "email" schema) + <*> tExportRole .= maybe_ (optField "role" schema) + <*> tExportCreatedOn .= maybe_ (optField "created_on" schema) + <*> tExportInvitedBy .= maybe_ (optField "invited_by" schema) + <*> tExportIdpIssuer .= maybe_ (optField "idp_issuer" schema) + <*> tExportManagedBy .= field "managed_by" schema + <*> tExportSAMLNamedId .= field "saml_name_id" schema + <*> tExportSCIMExternalId .= field "scim_external_id" schema + <*> tExportSCIMRichInfo .= maybe_ (optField "scim_rich_info" schema) + <*> tExportUserId .= field "user_id" schema + <*> tExportNumDevices .= field "num_devices" schema instance ToNamedRecord TeamExportUser where toNamedRecord row = diff --git a/libs/wire-subsystems/src/Wire/UserStore.hs b/libs/wire-subsystems/src/Wire/UserStore.hs index 80fe618196e..6ebb55c71cf 100644 --- a/libs/wire-subsystems/src/Wire/UserStore.hs +++ b/libs/wire-subsystems/src/Wire/UserStore.hs @@ -11,6 +11,7 @@ import Imports import Polysemy import Polysemy.Error import Wire.API.User +import Wire.API.User.RichInfo import Wire.Arbitrary import Wire.StoredUser import Wire.UserStore.IndexUser @@ -69,6 +70,7 @@ data UserStore m a where LookupLocale :: UserId -> UserStore m (Maybe (Maybe Language, Maybe Country)) UpdateUserTeam :: UserId -> TeamId -> UserStore m () GetActivityTimestamps :: UserId -> UserStore m [Maybe UTCTime] + GetRichInfo :: UserId -> UserStore m (Maybe RichInfoAssocList) makeSem ''UserStore diff --git a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs index c4ef4562d89..db15b04f4b4 100644 --- a/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs +++ b/libs/wire-subsystems/src/Wire/UserStore/Cassandra.hs @@ -11,6 +11,7 @@ import Polysemy import Polysemy.Embed import Polysemy.Error import Wire.API.User hiding (DeleteUser) +import Wire.API.User.RichInfo import Wire.StoredUser import Wire.UserStore import Wire.UserStore.IndexUser hiding (userId) @@ -33,6 +34,7 @@ interpretUserStoreCassandra casClient = LookupLocale uid -> lookupLocaleImpl uid UpdateUserTeam uid tid -> updateUserTeamImpl uid tid GetActivityTimestamps uid -> getActivityTimestampsImpl uid + GetRichInfo uid -> getRichInfoImpl uid getUsersImpl :: [UserId] -> Client [StoredUser] getUsersImpl usrs = @@ -178,6 +180,14 @@ getActivityTimestampsImpl uid = do q :: PrepQuery R (Identity UserId) (Identity (Maybe UTCTime)) q = "SELECT last_active from clients where user = ?" +getRichInfoImpl :: UserId -> Client (Maybe RichInfoAssocList) +getRichInfoImpl uid = + fmap runIdentity + <$> retry x1 (query1 q (params LocalQuorum (Identity uid))) + where + q :: PrepQuery R (Identity UserId) (Identity RichInfoAssocList) + q = "SELECT json FROM rich_info WHERE user = ?" + -------------------------------------------------------------------------------- -- Queries diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index f677f7fb2a3..538db533134 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -21,6 +21,7 @@ import Polysemy import Polysemy.Error import Wire.API.Federation.Error import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus) +import Wire.API.Team.Export (TeamExportUser) import Wire.API.Team.Feature import Wire.API.Team.Member (IsPerm (..), TeamMember) import Wire.API.User @@ -145,6 +146,7 @@ data UserSubsystem m a where InternalUpdateSearchIndex :: UserId -> UserSubsystem m () InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m StoredInvitation GetUserActivityTimestamp :: UserId -> UserSubsystem m (Maybe UTCTime) + GetUserExportData :: UserId -> UserSubsystem m (Maybe TeamExportUser) -- | the return type of 'CheckHandle' data CheckHandleResp diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 0807bdc2723..7ea8f4d3fdc 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -7,8 +7,10 @@ module Wire.UserSubsystem.Interpreter ) where -import Control.Lens (view) +import Control.Error.Util (hush) +import Control.Lens (view, (^.)) import Control.Monad.Trans.Maybe +import Data.CaseInsensitive qualified as CI import Data.Domain import Data.Handle (Handle) import Data.Handle qualified as Handle @@ -16,7 +18,7 @@ import Data.Id import Data.Json.Util import Data.LegalHold import Data.List.Extra (nubOrd) -import Data.Misc (PlainTextPassword6) +import Data.Misc (HttpsUrl, PlainTextPassword6, mkHttpsUrl) import Data.Qualified import Data.Range import Data.Time.Clock @@ -27,6 +29,7 @@ import Polysemy.Error import Polysemy.Input import Polysemy.TinyLog (TinyLog) import Polysemy.TinyLog qualified as Log +import SAML2.WebSSO qualified as SAML import Servant.Client.Core import System.Logger.Message qualified as Log import Wire.API.Federation.API @@ -34,6 +37,7 @@ import Wire.API.Federation.API.Brig qualified as FedBrig import Wire.API.Federation.Error import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti (TeamStatus (..)) +import Wire.API.Team.Export import Wire.API.Team.Feature import Wire.API.Team.Member import Wire.API.Team.Permission qualified as Permission @@ -41,6 +45,7 @@ import Wire.API.Team.Role (defaultRole) import Wire.API.Team.SearchVisibility import Wire.API.Team.Size (TeamSize (TeamSize)) import Wire.API.User as User +import Wire.API.User.RichInfo import Wire.API.User.Search import Wire.API.UserEvent import Wire.Arbitrary @@ -152,6 +157,50 @@ runUserSubsystem authInterpreter = interpret $ InternalFindTeamInvitation mEmailKey code -> internalFindTeamInvitationImpl mEmailKey code GetUserActivityTimestamp uid -> getUserActivityTimestampImpl uid + GetUserExportData uid -> getUserExportDataImpl uid + +getUserExportDataImpl :: (Member UserStore r) => UserId -> Sem r (Maybe TeamExportUser) +getUserExportDataImpl uid = fmap hush . runError @() $ do + su <- UserStore.getUser uid >>= note () + mRichInfo <- UserStore.getRichInfo uid + timestamps <- UserStore.getActivityTimestamps uid + let numClients = length timestamps + pure $ + TeamExportUser + { tExportDisplayName = su.name, + tExportHandle = su.handle, + tExportEmail = su.email, + tExportRole = Nothing, + tExportCreatedOn = Nothing, + tExportInvitedBy = Nothing, + tExportIdpIssuer = userToIdPIssuer su, + tExportManagedBy = fromMaybe ManagedByWire su.managedBy, + tExportSAMLNamedId = fromMaybe "" (samlNamedId su), + tExportSCIMExternalId = fromMaybe "" (scimExtId su), + tExportSCIMRichInfo = fmap RichInfo mRichInfo, + tExportUserId = uid, + tExportNumDevices = numClients + } + +scimExtId :: StoredUser -> Maybe Text +scimExtId su = do + m <- su.managedBy + i <- su.identity + sso <- ssoIdentity i + scimExternalId m sso + +userToIdPIssuer :: StoredUser -> Maybe HttpsUrl +userToIdPIssuer su = case su.identity >>= ssoIdentity of + Just (UserSSOId (SAML.UserRef issuer _)) -> + either (const Nothing) Just . mkHttpsUrl $ issuer ^. SAML.fromIssuer + Just _ -> Nothing + Nothing -> Nothing + +samlNamedId :: StoredUser -> Maybe Text +samlNamedId su = + su.identity >>= ssoIdentity >>= \case + (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId + (UserScimExternalId _) -> Nothing internalFindTeamInvitationImpl :: ( Member InvitationStore r, diff --git a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs index c8f47d1b067..650aeb60dfa 100644 --- a/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs +++ b/libs/wire-subsystems/test/unit/Wire/MockInterpreters/UserStore.hs @@ -72,6 +72,7 @@ inMemoryUserStoreInterpreter = interpret $ \case map (\u -> if u.id == uid then u {teamId = Just tid} :: StoredUser else u) GetActivityTimestamps _ -> pure [] + GetRichInfo _ -> error "rich info not implemented" storedUserToIndexUser :: StoredUser -> IndexUser storedUserToIndexUser storedUser = diff --git a/libs/wire-subsystems/wire-subsystems.cabal b/libs/wire-subsystems/wire-subsystems.cabal index 54ff613f5e4..b19f48031fc 100644 --- a/libs/wire-subsystems/wire-subsystems.cabal +++ b/libs/wire-subsystems/wire-subsystems.cabal @@ -156,6 +156,7 @@ library , bloodhound , bytestring , bytestring-conversion + , case-insensitive , cassandra-util , conduit , containers diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index a5af05ead8e..150e82354af 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -83,6 +83,7 @@ import Wire.API.Routes.FederationDomainConfig import Wire.API.Routes.Internal.Brig qualified as BrigIRoutes import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Named +import Wire.API.Team.Export import Wire.API.Team.Feature import Wire.API.User import Wire.API.User.Activation @@ -268,6 +269,7 @@ userAPI = :<|> deleteLocale :<|> getDefaultUserLocale :<|> Named @"get-activity-timestamp" getUserActivityTimestampH + :<|> Named @"get-user-export-data" getUserExportDataH clientAPI :: ServerT BrigIRoutes.ClientAPI (Handler r) clientAPI = Named @"update-client-last-active" updateClientLastActive @@ -812,3 +814,9 @@ getUserActivityTimestampH = . liftSem . fmap (fmap toUTCTimeMillis) . getUserActivityTimestamp + +getUserExportDataH :: + (Member UserSubsystem r) => + UserId -> + Handler r (Maybe TeamExportUser) +getUserExportDataH = lift . liftSem . getUserExportData diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index caaa7c160cc..e5772f2912e 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -374,6 +374,7 @@ lookupName u = fmap runIdentity <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) +-- TODO: remove this lookupRichInfo :: (MonadClient m) => UserId -> m (Maybe RichInfoAssocList) lookupRichInfo u = fmap runIdentity diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index ae6bdfc65a4..03b3f251b32 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -122,6 +122,7 @@ library Galley.API.Push Galley.API.Query Galley.API.Teams + Galley.API.Teams.Export Galley.API.Teams.Features Galley.API.Teams.Features.Get Galley.API.Teams.Notifications diff --git a/services/galley/src/Galley/API/Teams/Export.hs b/services/galley/src/Galley/API/Teams/Export.hs new file mode 100644 index 00000000000..0b40c90af0a --- /dev/null +++ b/services/galley/src/Galley/API/Teams/Export.hs @@ -0,0 +1,23 @@ +module Galley.API.Teams.Export (getUserRecord) where + +import Control.Lens ((^.)) +import Galley.Effects +import Galley.Effects.BrigAccess +import Imports +import Polysemy +import Wire.API.Error +import Wire.API.Error.Galley +import Wire.API.Team.Export +import Wire.API.Team.Member + +getUserRecord :: + ( Member (ErrorS TeamMemberNotFound) r, + Member BrigAccess r + ) => + TeamMember -> + Sem r TeamExportUser +getUserRecord member = do + let uid = member ^. userId + export <- getUserExportData uid >>= noteS @TeamMemberNotFound + -- TODO + pure export diff --git a/services/galley/src/Galley/Effects/BrigAccess.hs b/services/galley/src/Galley/Effects/BrigAccess.hs index de7fc43bd5b..0e5725513c4 100644 --- a/services/galley/src/Galley/Effects/BrigAccess.hs +++ b/services/galley/src/Galley/Effects/BrigAccess.hs @@ -35,6 +35,7 @@ module Galley.Effects.BrigAccess deleteUser, getContactList, getRichInfoMultiUser, + getUserExportData, -- * Teams getSize, @@ -71,6 +72,7 @@ import Wire.API.Error.Galley import Wire.API.MLS.CipherSuite import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi +import Wire.API.Team.Export import Wire.API.Team.Feature import Wire.API.Team.Size import Wire.API.User.Auth.ReAuth @@ -126,6 +128,7 @@ data BrigAccess m a where UpdateSearchVisibilityInbound :: Multi.TeamStatus SearchVisibilityInboundConfig -> BrigAccess m () + GetUserExportData :: UserId -> BrigAccess m (Maybe TeamExportUser) makeSem ''BrigAccess diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs index ef071400ab0..29e39798ac2 100644 --- a/services/galley/src/Galley/Intra/Effects.hs +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -83,6 +83,9 @@ interpretBrigAccess = interpret $ \case GetRichInfoMultiUser uids -> do logEffect "BrigAccess.GetRichInfoMultiUser" embedApp $ getRichInfoMultiUser uids + GetUserExportData uid -> do + logEffect "BrigAccess.GetUserExportData" + embedApp $ getUserExportData uid GetSize tid -> do logEffect "BrigAccess.GetSize" embedApp $ getSize tid diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index 8d6c620fd66..27ced33fdee 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -30,6 +30,7 @@ module Galley.Intra.User getContactList, chunkify, getRichInfoMultiUser, + getUserExportData, getAccountConferenceCallingConfigClient, updateSearchVisibilityInbound, ) @@ -66,6 +67,7 @@ import Wire.API.Routes.Internal.Brig qualified as IAPI import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti qualified as Multi import Wire.API.Routes.Named +import Wire.API.Team.Export import Wire.API.Team.Feature import Wire.API.User import Wire.API.User.Auth.ReAuth @@ -237,6 +239,16 @@ getRichInfoMultiUser = chunkify $ \uids -> do . expect2xx parseResponse (mkError status502 "server-error: could not parse response to `GET brig:/i/users/rich-info`") resp +-- | Calls 'Brig.API.Internal.getUserExportDataH' +getUserExportData :: UserId -> App (Maybe TeamExportUser) +getUserExportData uid = do + resp <- + call Brig $ + method GET + . paths ["i/users", toByteString' uid, "export-data"] + . expect2xx + parseResponse (mkError status502 "server-error: could not parse response to `GET brig:/i/users/:uid/export-data`") resp + getAccountConferenceCallingConfigClient :: (HasCallStack) => UserId -> App (Feature ConferenceCallingConfig) getAccountConferenceCallingConfigClient uid = runHereClientM (namedClient @IAPI.API @"get-account-conference-calling-config" uid) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 0f86eb54b2c..79504f66086 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -473,7 +473,6 @@ getTeamActivityInfo tid = do chan <- liftIO newChan let runThread :: IO () = do pooledForConcurrentlyN_ 8 memList $ \user -> do - -- get user info tm <- runHandler env (Intra.getActivityTimestamp user) >>= either throwIO pure From a23d6fab47192761cf11b68f91d2b45995728a9f Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 11 Oct 2024 08:23:39 +0000 Subject: [PATCH 06/23] getUserRecord implemented --- .../galley/src/Galley/API/Teams/Export.hs | 27 ++++++++++++++++--- 1 file changed, 23 insertions(+), 4 deletions(-) diff --git a/services/galley/src/Galley/API/Teams/Export.hs b/services/galley/src/Galley/API/Teams/Export.hs index 0b40c90af0a..3f3d60e50e9 100644 --- a/services/galley/src/Galley/API/Teams/Export.hs +++ b/services/galley/src/Galley/API/Teams/Export.hs @@ -1,23 +1,42 @@ module Galley.API.Teams.Export (getUserRecord) where -import Control.Lens ((^.)) +import Control.Lens (view, (^.)) import Galley.Effects import Galley.Effects.BrigAccess +import Galley.Effects.SparAccess qualified as Spar import Imports import Polysemy import Wire.API.Error import Wire.API.Error.Galley import Wire.API.Team.Export import Wire.API.Team.Member +import Wire.API.User (ScimUserInfo (suiCreatedOn), User (..)) getUserRecord :: ( Member (ErrorS TeamMemberNotFound) r, - Member BrigAccess r + Member BrigAccess r, + Member Spar.SparAccess r ) => TeamMember -> Sem r TeamExportUser getUserRecord member = do let uid = member ^. userId export <- getUserExportData uid >>= noteS @TeamMemberNotFound - -- TODO - pure export + mCreatedOn <- do + let mFromInvitation = snd <$> member ^. invitation + case mFromInvitation of + Just ts -> pure $ Just ts + Nothing -> do + -- TODO: make this a single user query + suis <- Spar.lookupScimUserInfos [uid] + pure $ listToMaybe suis >>= suiCreatedOn + -- TODO: optimize! + let mInviterId = fst <$> member ^. invitation + users <- getUsers (maybeToList mInviterId) + let invitedBy = listToMaybe users >>= userHandle + pure + export + { tExportInvitedBy = invitedBy, + tExportRole = permissionsRole . view permissions $ member, + tExportCreatedOn = mCreatedOn + } From 64397eb488ea35c1920146bfb6cac5d1474bf7ae Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 11 Oct 2024 10:39:30 +0000 Subject: [PATCH 07/23] fix integration package --- integration/test/API/Stern.hs | 6 ------ integration/test/Test/Client.hs | 9 ++------- integration/test/Testlib/Assertions.hs | 1 - 3 files changed, 2 insertions(+), 14 deletions(-) diff --git a/integration/test/API/Stern.hs b/integration/test/API/Stern.hs index b6fc52a11dc..b7d93d07178 100644 --- a/integration/test/API/Stern.hs +++ b/integration/test/API/Stern.hs @@ -1,11 +1,5 @@ module API.Stern where -import API.BrigCommon -import API.Common -import qualified Data.Aeson as Aeson -import Data.Aeson.Types (Pair) -import Data.Function -import Data.Maybe import Testlib.Prelude getTeamActivity :: (HasCallStack, MakesValue domain) => domain -> String -> App Response diff --git a/integration/test/Test/Client.hs b/integration/test/Test/Client.hs index 12f04f284c0..bc39d96d985 100644 --- a/integration/test/Test/Client.hs +++ b/integration/test/Test/Client.hs @@ -51,11 +51,6 @@ testTeamActivity = do [_bob1, _bob2] <- replicateM 2 $ addClient bob def >>= getJSON 201 charlie1 <- addClient charlie def >>= getJSON 201 - now <- - formatTime defaultTimeLocale "%Y-%m-%d" - . systemToUTCTime - <$> liftIO getSystemTime - for_ [(alice, alice1), (charlie, charlie1)] $ \(u, cl) -> do clientId <- cl %. "id" & asString void $ getNotifications u def {client = Just clientId} @@ -68,8 +63,8 @@ testTeamActivity = do bindResponse (getTeamActivity alice tid) $ \resp -> do resp.status `shouldMatchInt` 200 - for_ (zip (sort (B8.lines resp.body)) expectedRows) $ \(row, (uid, active)) -> do - let [actualUser, timestamp] = B8.split ',' row + for_ (zip (sort (B8.lines resp.body)) expectedRows) $ \(r, (uid, active)) -> do + let [actualUser, timestamp] = B8.split ',' r B8.unpack actualUser `shouldMatch` uid B8.null timestamp `shouldMatch` not active diff --git a/integration/test/Testlib/Assertions.hs b/integration/test/Testlib/Assertions.hs index f89a143d41d..28ddf0c0af1 100644 --- a/integration/test/Testlib/Assertions.hs +++ b/integration/test/Testlib/Assertions.hs @@ -14,7 +14,6 @@ import qualified Data.Aeson.Diff as AD import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Aeson.KeyMap as Aeson import Data.Aeson.Lens (_Array, _Object) -import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BS import Data.Char From b2f9dd2b9fca6d4d8f181f9b8e613ddabb058c02 Mon Sep 17 00:00:00 2001 From: Leif Battermann Date: Fri, 11 Oct 2024 08:59:42 +0000 Subject: [PATCH 08/23] New implementation of getTeamMembersCSV --- .../src/Galley/API/Public/TeamMember.hs | 3 +- .../galley/src/Galley/API/Teams/Export.hs | 111 ++++++++++++++++-- 2 files changed, 104 insertions(+), 10 deletions(-) diff --git a/services/galley/src/Galley/API/Public/TeamMember.hs b/services/galley/src/Galley/API/Public/TeamMember.hs index 91956a21712..c6b7d5cd059 100644 --- a/services/galley/src/Galley/API/Public/TeamMember.hs +++ b/services/galley/src/Galley/API/Public/TeamMember.hs @@ -18,6 +18,7 @@ module Galley.API.Public.TeamMember where import Galley.API.Teams +import Galley.API.Teams.Export qualified as Export import Galley.App import Wire.API.Routes.API import Wire.API.Routes.Public.Galley.TeamMember @@ -31,4 +32,4 @@ teamMemberAPI = <@> mkNamedAPI @"delete-team-member" deleteTeamMember <@> mkNamedAPI @"delete-non-binding-team-member" deleteNonBindingTeamMember <@> mkNamedAPI @"update-team-member" updateTeamMember - <@> mkNamedAPI @"get-team-members-csv" getTeamMembersCSV + <@> mkNamedAPI @"get-team-members-csv" Export.getTeamMembersCSV diff --git a/services/galley/src/Galley/API/Teams/Export.hs b/services/galley/src/Galley/API/Teams/Export.hs index 3f3d60e50e9..f95b5cc41ab 100644 --- a/services/galley/src/Galley/API/Teams/Export.hs +++ b/services/galley/src/Galley/API/Teams/Export.hs @@ -1,38 +1,56 @@ -module Galley.API.Teams.Export (getUserRecord) where +module Galley.API.Teams.Export (getTeamMembersCSV) where +import Control.Concurrent +import Control.Concurrent.Async qualified as Async +import Control.Error (MaybeT (MaybeT, runMaybeT)) import Control.Lens (view, (^.)) +import Control.Monad.Codensity +import Data.ByteString (toStrict) +import Data.ByteString.Builder +import Data.Csv +import Data.Id +import Data.Qualified (Local, tUnqualified) +import Debug.Trace import Galley.Effects import Galley.Effects.BrigAccess import Galley.Effects.SparAccess qualified as Spar -import Imports +import Galley.Effects.TeamMemberStore (listTeamMembers) +import Galley.Effects.TeamStore +import Imports hiding (newEmptyMVar, putMVar, takeMVar, threadDelay) import Polysemy +import Polysemy.Async +import Polysemy.Resource import Wire.API.Error import Wire.API.Error.Galley +import Wire.API.Routes.LowLevelStream (LowLevelStreamingBody) import Wire.API.Team.Export import Wire.API.Team.Member import Wire.API.User (ScimUserInfo (suiCreatedOn), User (..)) +import Wire.Sem.Concurrency +import Wire.Sem.Concurrency.IO +import Wire.Sem.Paging qualified as E +import Wire.Sem.Paging.Cassandra (InternalPaging) getUserRecord :: - ( Member (ErrorS TeamMemberNotFound) r, - Member BrigAccess r, + ( Member BrigAccess r, Member Spar.SparAccess r ) => TeamMember -> - Sem r TeamExportUser -getUserRecord member = do + Sem r (Maybe TeamExportUser) +getUserRecord member = runMaybeT do let uid = member ^. userId - export <- getUserExportData uid >>= noteS @TeamMemberNotFound + export <- MaybeT $ getUserExportData uid mCreatedOn <- do let mFromInvitation = snd <$> member ^. invitation case mFromInvitation of Just ts -> pure $ Just ts Nothing -> do -- TODO: make this a single user query - suis <- Spar.lookupScimUserInfos [uid] + suis <- lift $ Spar.lookupScimUserInfos [uid] pure $ listToMaybe suis >>= suiCreatedOn -- TODO: optimize! let mInviterId = fst <$> member ^. invitation - users <- getUsers (maybeToList mInviterId) + users <- lift $ getUsers (maybeToList mInviterId) let invitedBy = listToMaybe users >>= userHandle pure export @@ -40,3 +58,78 @@ getUserRecord member = do tExportRole = permissionsRole . view permissions $ member, tExportCreatedOn = mCreatedOn } + +getTeamMembersCSV :: + forall r. + ( Member BrigAccess r, + Member (ErrorS 'AccessDenied) r, + Member (TeamMemberStore InternalPaging) r, + Member TeamStore r, + Member (Final IO) r, + Member SparAccess r + ) => + Local UserId -> + TeamId -> + Sem r LowLevelStreamingBody +getTeamMembersCSV lusr tid = do + getTeamMember tid (tUnqualified lusr) >>= \case + Nothing -> throwS @'AccessDenied + Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throwS @'AccessDenied + + chan <- embedFinal newChan + + let encodeRow r = encodeDefaultOrderedByNameWith customEncodeOptions [r] + let produceTeamExportUsers = do + embedFinal $ writeChan chan (Just headerLine) + E.withChunks (\mps -> listTeamMembers @InternalPaging tid mps maxBound) $ + \members -> unsafePooledForConcurrentlyN_ 8 members $ \member -> do + mRecord <- getUserRecord member + let mRow = encodeRow <$> mRecord + when (isJust mRow) $ + embedFinal $ + writeChan chan mRow + + -- In case an exception is thrown inside the producer thread, the response + -- will not contain a correct error message, but rather be an http error such + -- as 'InvalidChunkHeaders'. The exception however still reaches the + -- middleware and is being tracked in logging and metrics. + let producerThread = + produceTeamExportUsers + `finally` embedFinal (writeChan chan Nothing) + + asyncToIOFinal . resourceToIOFinal . unsafelyPerformConcurrency @_ @Unsafe $ do + -- Here we should really capture the Wai continuation and run the finaliser + -- after that. Unfortunately, this is not really possible with Servant, + -- because the continuation is not exposed by the Handler monad. The best + -- we can do is return a Codensity value with the correct finaliser, but + -- that still leaves a short window between when the resource is acquired + -- and when the finaliser is installed where the resource might be leaked. + -- I don't have a good solution for that. + bracketOnError + (async producerThread) + cancel + $ \producer -> do + pure $ do + void $ Codensity $ \k -> do + r <- k () + Async.cancel producer + pure r + pure $ \write flush -> do + let go = do + traceM "write chunk" + readChan chan >>= \case + Nothing -> write "" >> flush + Just line -> write (byteString (toStrict line)) >> flush >> go + go + +headerLine :: LByteString +headerLine = encodeDefaultOrderedByNameWith (customEncodeOptions {encIncludeHeader = True}) ([] :: [TeamExportUser]) + +customEncodeOptions :: EncodeOptions +customEncodeOptions = + EncodeOptions + { encDelimiter = fromIntegral (ord ','), + encUseCrLf = True, -- to be compatible with Mac and Windows + encIncludeHeader = False, -- (so we can flush when the header is on the wire) + encQuoting = QuoteAll + } From 0c192d55628dd356af336f7159edfe9c0478a0b2 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 14 Oct 2024 10:01:18 +0200 Subject: [PATCH 09/23] Implement inviter handle cache --- .../galley/src/Galley/API/Teams/Export.hs | 63 +++++++++++++++---- 1 file changed, 52 insertions(+), 11 deletions(-) diff --git a/services/galley/src/Galley/API/Teams/Export.hs b/services/galley/src/Galley/API/Teams/Export.hs index f95b5cc41ab..29c35240336 100644 --- a/services/galley/src/Galley/API/Teams/Export.hs +++ b/services/galley/src/Galley/API/Teams/Export.hs @@ -2,13 +2,15 @@ module Galley.API.Teams.Export (getTeamMembersCSV) where import Control.Concurrent import Control.Concurrent.Async qualified as Async -import Control.Error (MaybeT (MaybeT, runMaybeT)) import Control.Lens (view, (^.)) import Control.Monad.Codensity import Data.ByteString (toStrict) import Data.ByteString.Builder import Data.Csv +import Data.Handle +import Data.IORef (atomicModifyIORef, newIORef) import Data.Id +import Data.Map qualified as Map import Data.Qualified (Local, tUnqualified) import Debug.Trace import Galley.Effects @@ -16,7 +18,7 @@ import Galley.Effects.BrigAccess import Galley.Effects.SparAccess qualified as Spar import Galley.Effects.TeamMemberStore (listTeamMembers) import Galley.Effects.TeamStore -import Imports hiding (newEmptyMVar, putMVar, takeMVar, threadDelay) +import Imports hiding (atomicModifyIORef, newEmptyMVar, newIORef, putMVar, readMVar, takeMVar, threadDelay, tryPutMVar) import Polysemy import Polysemy.Async import Polysemy.Resource @@ -31,27 +33,63 @@ import Wire.Sem.Concurrency.IO import Wire.Sem.Paging qualified as E import Wire.Sem.Paging.Cassandra (InternalPaging) +-- | Cache of inviter handles. +-- +-- This is used to make sure that inviters are only looked up once in brig, +-- even if they appear as inviters of several users in the team. +type InviterCache = IORef (Map UserId (MVar (Maybe Handle))) + +lookupInviter :: + (Member Resource r, Member BrigAccess r, Member (Final IO) r) => + InviterCache -> + UserId -> + Sem r (Maybe Handle) +lookupInviter cache uid = flip onException ensureCache $ do + empty <- embedFinal newEmptyMVar + (cached, var) <- + embedFinal $ atomicModifyIORef cache $ \m -> case Map.lookup uid m of + Nothing -> (Map.insert uid empty m, (False, empty)) + Just v -> (m, (True, v)) + -- the cache did not contain this user, so write it in the corresponding MVar + unless cached $ do + u <- listToMaybe <$> getUsers [uid] + embedFinal $ putMVar var (u >>= userHandle) + -- at this point, we know that the MVar contains a value or some other thread + -- is about to write one, so it is safe to just read from the MVar with a + -- blocking call + embedFinal $ readMVar var + where + -- this is run in case of errors to guarantee that other threads will never + -- deadlock while reading the cache + ensureCache = embedFinal $ do + m <- readIORef cache + for_ (Map.lookup uid m) $ \var -> + tryPutMVar var Nothing + getUserRecord :: ( Member BrigAccess r, - Member Spar.SparAccess r + Member Spar.SparAccess r, + Member (ErrorS TeamMemberNotFound) r, + Member (Final IO) r, + Member Resource r ) => + InviterCache -> TeamMember -> - Sem r (Maybe TeamExportUser) -getUserRecord member = runMaybeT do + Sem r TeamExportUser +getUserRecord cache member = do let uid = member ^. userId - export <- MaybeT $ getUserExportData uid + export <- getUserExportData uid >>= noteS @TeamMemberNotFound mCreatedOn <- do let mFromInvitation = snd <$> member ^. invitation case mFromInvitation of Just ts -> pure $ Just ts Nothing -> do -- TODO: make this a single user query - suis <- lift $ Spar.lookupScimUserInfos [uid] + suis <- Spar.lookupScimUserInfos [uid] pure $ listToMaybe suis >>= suiCreatedOn - -- TODO: optimize! + -- look up inviter handle from the cache let mInviterId = fst <$> member ^. invitation - users <- lift $ getUsers (maybeToList mInviterId) - let invitedBy = listToMaybe users >>= userHandle + invitedBy <- join <$> traverse (lookupInviter cache) mInviterId pure export { tExportInvitedBy = invitedBy, @@ -77,13 +115,16 @@ getTeamMembersCSV lusr tid = do Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throwS @'AccessDenied chan <- embedFinal newChan + cache <- embedFinal $ newIORef mempty let encodeRow r = encodeDefaultOrderedByNameWith customEncodeOptions [r] let produceTeamExportUsers = do embedFinal $ writeChan chan (Just headerLine) E.withChunks (\mps -> listTeamMembers @InternalPaging tid mps maxBound) $ \members -> unsafePooledForConcurrentlyN_ 8 members $ \member -> do - mRecord <- getUserRecord member + mRecord <- + runErrorS @TeamMemberNotFound $ + getUserRecord cache member let mRow = encodeRow <$> mRecord when (isJust mRow) $ embedFinal $ From 24b11b7cdb1ec1cfeab7f6260385f42f22741909 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 16 Oct 2024 08:38:34 +0200 Subject: [PATCH 10/23] Remove old CSV export handler --- services/galley/galley.cabal | 2 - services/galley/src/Galley/API/Teams.hs | 146 +----------------------- 2 files changed, 1 insertion(+), 147 deletions(-) diff --git a/services/galley/galley.cabal b/services/galley/galley.cabal index 03b3f251b32..1db3f95e89c 100644 --- a/services/galley/galley.cabal +++ b/services/galley/galley.cabal @@ -301,7 +301,6 @@ library , brig-types >=0.73.1 , bytestring >=0.9 , bytestring-conversion >=0.2 - , case-insensitive , cassandra-util >=0.16.2 , cassava >=0.5.2 , comonad @@ -342,7 +341,6 @@ library , resourcet >=1.1 , retry >=0.5 , safe-exceptions >=0.1 - , saml2-web-sso >=0.20 , servant , servant-client , servant-server diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index 124945508f6..e51070d5f5a 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -31,7 +31,6 @@ module Galley.API.Teams addTeamMember, getTeamConversationRoles, getTeamMembers, - getTeamMembersCSV, bulkGetTeamMembers, getTeamMember, deleteTeamMember, @@ -61,13 +60,9 @@ import Brig.Types.Team (TeamSize (..)) import Cassandra (PageWithState (pwsResults), pwsHasMore) import Cassandra qualified as C import Control.Lens -import Data.ByteString.Builder (lazyByteString) import Data.ByteString.Conversion (List, toByteString) import Data.ByteString.Conversion qualified import Data.ByteString.Lazy qualified as LBS -import Data.CaseInsensitive qualified as CI -import Data.Csv (EncodeOptions (..), Quoting (QuoteAll), encodeDefaultOrderedByNameWith) -import Data.Handle qualified as Handle import Data.Id import Data.Json.Util import Data.LegalHold qualified as LH @@ -75,8 +70,6 @@ import Data.List.Extra qualified as List import Data.List.NonEmpty (NonEmpty (..)) import Data.List1 (list1) import Data.Map qualified as Map -import Data.Map.Strict qualified as M -import Data.Misc (HttpsUrl, mkHttpsUrl) import Data.Proxy import Data.Qualified import Data.Range as Range @@ -114,11 +107,8 @@ import Galley.Types.UserList import Imports hiding (forkIO) import Polysemy import Polysemy.Error -import Polysemy.Final import Polysemy.Input -import Polysemy.Output import Polysemy.TinyLog qualified as P -import SAML2.WebSSO qualified as SAML import System.Logger qualified as Log import Wire.API.Conversation (ConversationRemoveMembers (..)) import Wire.API.Conversation.Role (wireConvRoles) @@ -129,16 +119,13 @@ import Wire.API.Event.Conversation qualified as Conv import Wire.API.Event.LeaveReason import Wire.API.Event.Team import Wire.API.Federation.Error -import Wire.API.Message qualified as Conv import Wire.API.Routes.Internal.Galley.TeamsIntra -import Wire.API.Routes.LowLevelStream import Wire.API.Routes.MultiTablePaging (MultiTablePage (MultiTablePage), MultiTablePagingState (mtpsState)) import Wire.API.Routes.Public.Galley.TeamMember import Wire.API.Team import Wire.API.Team qualified as Public import Wire.API.Team.Conversation import Wire.API.Team.Conversation qualified as Public -import Wire.API.Team.Export (TeamExportUser (..)) import Wire.API.Team.Feature import Wire.API.Team.Member import Wire.API.Team.Member qualified as M @@ -147,12 +134,8 @@ import Wire.API.Team.Permission (Perm (..), Permissions (..), SPerm (..), copy, import Wire.API.Team.Role import Wire.API.Team.SearchVisibility import Wire.API.Team.SearchVisibility qualified as Public -import Wire.API.User (ScimUserInfo (..), User, UserIdList, UserSSOId (UserScimExternalId), userSCIMExternalId, userSSOId) import Wire.API.User qualified as U -import Wire.API.User.Identity (UserSSOId (UserSSOId)) -import Wire.API.User.RichInfo (RichInfo) import Wire.NotificationSubsystem -import Wire.Sem.Paging qualified as E import Wire.Sem.Paging.Cassandra getTeamH :: @@ -500,133 +483,6 @@ getTeamMembers lzusr tid mbMaxResults mbPagingState = do (pwsHasMore p) (teamMemberPagingState p) -outputToStreamingBody :: - (Member (Final IO) r) => - Sem (Output LByteString ': r) () -> - Sem r LowLevelStreamingBody -outputToStreamingBody action = withWeavingToFinal @IO $ \state weave _inspect -> - pure . (<$ state) $ pure $ \write flush -> do - let writeChunk c = embedFinal $ do - write (lazyByteString c) - flush - void . weave . (<$ state) $ runOutputSem writeChunk action - -getTeamMembersCSV :: - ( Member BrigAccess r, - Member (ErrorS 'AccessDenied) r, - Member (TeamMemberStore InternalPaging) r, - Member TeamStore r, - Member (Final IO) r, - Member SparAccess r - ) => - Local UserId -> - TeamId -> - Sem r LowLevelStreamingBody -getTeamMembersCSV lusr tid = do - E.getTeamMember tid (tUnqualified lusr) >>= \case - Nothing -> throwS @'AccessDenied - Just member -> unless (member `hasPermission` DownloadTeamMembersCsv) $ throwS @'AccessDenied - - -- In case an exception is thrown inside the StreamingBody of responseStream - -- the response will not contain a correct error message, but rather be an - -- http error such as 'InvalidChunkHeaders'. The exception however still - -- reaches the middleware and is being tracked in logging and metrics. - outputToStreamingBody $ do - output headerLine - E.withChunks (\mps -> E.listTeamMembers @InternalPaging tid mps maxBound) $ - \members -> do - let uids = fmap (view userId) members - teamExportUser <- - mkTeamExportUser - <$> (lookupUser <$> E.lookupActivatedUsers uids) - <*> lookupInviterHandle members - <*> (lookupRichInfo <$> E.getRichInfoMultiUser uids) - <*> (lookupClients <$> E.lookupClients uids) - <*> (lookupScimUserInfo <$> Spar.lookupScimUserInfos uids) - output @LByteString - ( encodeDefaultOrderedByNameWith - defaultEncodeOptions - (mapMaybe teamExportUser members) - ) - where - headerLine :: LByteString - headerLine = encodeDefaultOrderedByNameWith (defaultEncodeOptions {encIncludeHeader = True}) ([] :: [TeamExportUser]) - - defaultEncodeOptions :: EncodeOptions - defaultEncodeOptions = - EncodeOptions - { encDelimiter = fromIntegral (ord ','), - encUseCrLf = True, -- to be compatible with Mac and Windows - encIncludeHeader = False, -- (so we can flush when the header is on the wire) - encQuoting = QuoteAll - } - - mkTeamExportUser :: - (UserId -> Maybe User) -> - (UserId -> Maybe Handle.Handle) -> - (UserId -> Maybe RichInfo) -> - (UserId -> Int) -> - (UserId -> Maybe ScimUserInfo) -> - TeamMember -> - Maybe TeamExportUser - mkTeamExportUser users inviters richInfos numClients scimUserInfo member = do - let uid = member ^. userId - user <- users uid - pure $ - TeamExportUser - { tExportDisplayName = U.userDisplayName user, - tExportHandle = U.userHandle user, - tExportEmail = U.userIdentity user >>= U.emailIdentity, - tExportRole = permissionsRole . view permissions $ member, - tExportCreatedOn = maybe (scimUserInfo uid >>= suiCreatedOn) (Just . snd) (view invitation member), - tExportInvitedBy = inviters . fst =<< member ^. invitation, - tExportIdpIssuer = userToIdPIssuer user, - tExportManagedBy = U.userManagedBy user, - tExportSAMLNamedId = fromMaybe "" (samlNamedId user), - tExportSCIMExternalId = fromMaybe "" (userSCIMExternalId user), - tExportSCIMRichInfo = richInfos uid, - tExportUserId = U.userId user, - tExportNumDevices = numClients uid - } - - lookupInviterHandle :: (Member BrigAccess r) => [TeamMember] -> Sem r (UserId -> Maybe Handle.Handle) - lookupInviterHandle members = do - let inviterIds :: [UserId] - inviterIds = nub $ mapMaybe (fmap fst . view invitation) members - - userList <- E.getUsers inviterIds - - let userMap :: M.Map UserId Handle.Handle - userMap = M.fromList (mapMaybe extract userList) - where - extract u = (U.userId u,) <$> U.userHandle u - - pure (`M.lookup` userMap) - - userToIdPIssuer :: U.User -> Maybe HttpsUrl - userToIdPIssuer usr = case (U.userIdentity >=> U.ssoIdentity) usr of - Just (U.UserSSOId (SAML.UserRef issuer _)) -> either (const Nothing) Just . mkHttpsUrl $ issuer ^. SAML.fromIssuer - Just _ -> Nothing - Nothing -> Nothing - - lookupScimUserInfo :: [ScimUserInfo] -> (UserId -> Maybe ScimUserInfo) - lookupScimUserInfo infos = (`M.lookup` M.fromList (infos <&> (\sui -> (suiUserId sui, sui)))) - - lookupUser :: [U.User] -> (UserId -> Maybe U.User) - lookupUser users = (`M.lookup` M.fromList (users <&> \user -> (U.userId user, user))) - - lookupRichInfo :: [(UserId, RichInfo)] -> (UserId -> Maybe RichInfo) - lookupRichInfo pairs = (`M.lookup` M.fromList pairs) - - lookupClients :: Conv.UserClients -> UserId -> Int - lookupClients userClients uid = maybe 0 length (M.lookup uid (Conv.userClients userClients)) - - samlNamedId :: User -> Maybe Text - samlNamedId = - userSSOId >=> \case - (UserSSOId (SAML.UserRef _idp nameId)) -> Just . CI.original . SAML.unsafeShowNameID $ nameId - (UserScimExternalId _) -> Nothing - -- | like 'getTeamMembers', but with an explicit list of users we are to return. bulkGetTeamMembers :: ( Member (ErrorS 'BulkGetMemberLimitExceeded) r, @@ -636,7 +492,7 @@ bulkGetTeamMembers :: Local UserId -> TeamId -> Maybe (Range 1 HardTruncationLimit Int32) -> - UserIdList -> + U.UserIdList -> Sem r TeamMemberListOptPerms bulkGetTeamMembers lzusr tid mbMaxResults uids = do unless (length (U.mUsers uids) <= fromIntegral (fromRange (fromMaybe (unsafeRange Public.hardTruncationLimit) mbMaxResults))) $ From e2e810469271c1c51c3f63928167ba528b068f1a Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 16 Oct 2024 09:28:49 +0200 Subject: [PATCH 11/23] Add activity timestamp to csv export --- integration/test/Test/Teams.hs | 44 +++++++++++----- libs/wire-api/src/Wire/API/Team/Export.hs | 32 ++++++++++-- .../src/Wire/UserSubsystem/Interpreter.hs | 51 ++++++++++--------- .../galley/src/Galley/API/Teams/Export.hs | 8 ++- 4 files changed, 93 insertions(+), 42 deletions(-) diff --git a/integration/test/Test/Teams.hs b/integration/test/Test/Teams.hs index 623983abcba..8517595bb71 100644 --- a/integration/test/Test/Teams.hs +++ b/integration/test/Test/Teams.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wno-ambiguous-fields #-} -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2024 Wire Swiss GmbH @@ -22,6 +23,7 @@ import qualified API.BrigInternal as I import API.Common import API.Galley (getTeam, getTeamMembers, getTeamMembersCsv, getTeamNotifications) import API.GalleyInternal (setTeamFeatureStatus) +import API.Gundeck import Control.Monad.Codensity (Codensity (runCodensity)) import Control.Monad.Extra (findM) import Control.Monad.Reader (asks) @@ -284,16 +286,28 @@ testUpgradePersonalToTeamAlreadyInATeam = do -- for additional tests of the CSV download particularly with SCIM users, please refer to 'Test.Spar.Scim.UserSpec' testTeamMemberCsvExport :: (HasCallStack) => App () testTeamMemberCsvExport = do - (owner, tid, members) <- createTeam OwnDomain 10 - let numClients = [0, 1, 2] <> repeat 0 - modifiedMembers <- for (zip numClients (owner : members)) $ \(n, m) -> do - handle <- randomHandle - putHandle m handle >>= assertSuccess - replicateM_ n $ addClient m def - void $ I.putSSOId m def {I.scimExternalId = Just "foo"} >>= getBody 200 - setField "handle" handle m - >>= setField "role" (if m == owner then "owner" else "member") - >>= setField "num_clients" (show n) + (owner, tid, members) <- createTeam OwnDomain 5 + + modifiedMembers <- for + ( zip + ([0, 1, 2] <> repeat 0) + (owner : members) + ) + $ \(n, m) -> do + handle <- randomHandle + putHandle m handle >>= assertSuccess + clients <- + replicateM n + $ addClient m def + >>= getJSON 201 + >>= (%. "id") + >>= asString + for_ (listToMaybe clients) $ \c -> + getNotifications m def {client = Just c} + void $ I.putSSOId m def {I.scimExternalId = Just "foo"} >>= getBody 200 + setField "handle" handle m + >>= setField "role" (if m == owner then "owner" else "member") + >>= setField "num_clients" n memberMap :: Map.Map String Value <- fmap Map.fromList $ for (modifiedMembers) $ \m -> do uid <- m %. "id" & asString @@ -302,7 +316,7 @@ testTeamMemberCsvExport = do bindResponse (getTeamMembersCsv owner tid) $ \resp -> do resp.status `shouldMatchInt` 200 let rows = sort $ tail $ B8.lines $ resp.body - length rows `shouldMatchInt` 10 + length rows `shouldMatchInt` 5 for_ rows $ \row -> do let cols = B8.split ',' row let uid = read $ B8.unpack $ cols !! 11 @@ -310,6 +324,8 @@ testTeamMemberCsvExport = do ownerId <- owner %. "id" & asString let ownerMember = memberMap Map.! ownerId + now <- formatTime defaultTimeLocale "%Y-%m-%d" <$> liftIO getCurrentTime + numClients <- mem %. "num_clients" & asInt let parseField = unquote . read . B8.unpack . (cols !!) @@ -319,12 +335,14 @@ testTeamMemberCsvExport = do role <- mem %. "role" & asString parseField 3 `shouldMatch` role when (role /= "owner") $ do - now <- formatTime defaultTimeLocale "%Y-%m-%d" <$> liftIO getCurrentTime take 10 (parseField 4) `shouldMatch` now parseField 5 `shouldMatch` (ownerMember %. "handle") parseField 7 `shouldMatch` "wire" parseField 9 `shouldMatch` "foo" - parseField 12 `shouldMatch` (mem %. "num_clients") + parseField 12 `shouldMatch` show numClients + (if numClients > 0 then shouldNotMatch else shouldMatch) + (parseField 13) + "" where unquote :: String -> String unquote ('\'' : x) = x diff --git a/libs/wire-api/src/Wire/API/Team/Export.hs b/libs/wire-api/src/Wire/API/Team/Export.hs index 61304ad28eb..eb684f34a31 100644 --- a/libs/wire-api/src/Wire/API/Team/Export.hs +++ b/libs/wire-api/src/Wire/API/Team/Export.hs @@ -25,10 +25,14 @@ import Data.ByteString.Conversion (FromByteString (..), ToByteString, toByteStri import Data.Csv (DefaultOrdered (..), FromNamedRecord (..), Parser, ToNamedRecord (..), namedRecord, (.:)) import Data.Handle (Handle) import Data.Id (UserId) -import Data.Json.Util (UTCTimeMillis) +import Data.Json.Util (UTCTimeMillis, utcTimeSchema) import Data.Misc (HttpsUrl) import Data.OpenApi qualified as OpenApi import Data.Schema +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Time.Clock +import Data.Time.Format import Data.Vector (fromList) import Imports import Test.QuickCheck @@ -39,6 +43,9 @@ import Wire.API.User.Profile (ManagedBy) import Wire.API.User.RichInfo (RichInfo) import Wire.Arbitrary +timestampFormat :: String +timestampFormat = "%Y-%m-%d" + data TeamExportUser = TeamExportUser { tExportDisplayName :: Name, tExportHandle :: Maybe Handle, @@ -52,7 +59,8 @@ data TeamExportUser = TeamExportUser tExportSCIMExternalId :: Text, tExportSCIMRichInfo :: Maybe RichInfo, tExportUserId :: UserId, - tExportNumDevices :: Int + tExportNumDevices :: Int, + tExportLastActive :: Maybe UTCTime } deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform TeamExportUser) @@ -75,6 +83,7 @@ instance ToSchema TeamExportUser where <*> tExportSCIMRichInfo .= maybe_ (optField "scim_rich_info" schema) <*> tExportUserId .= field "user_id" schema <*> tExportNumDevices .= field "num_devices" schema + <*> tExportLastActive .= maybe_ (optField "last_active" utcTimeSchema) instance ToNamedRecord TeamExportUser where toNamedRecord row = @@ -91,7 +100,15 @@ instance ToNamedRecord TeamExportUser where ("scim_external_id", secureCsvFieldToByteString (tExportSCIMExternalId row)), ("scim_rich_info", maybe "" (C.toStrict . Aeson.encode) (tExportSCIMRichInfo row)), ("user_id", secureCsvFieldToByteString (tExportUserId row)), - ("num_devices", secureCsvFieldToByteString (tExportNumDevices row)) + ("num_devices", secureCsvFieldToByteString (tExportNumDevices row)), + ( "last_active", + C.pack + ( maybe + "" + (formatTime defaultTimeLocale timestampFormat) + (tExportLastActive row) + ) + ) ] secureCsvFieldToByteString :: forall a. (ToByteString a) => a -> ByteString @@ -113,7 +130,8 @@ instance DefaultOrdered TeamExportUser where "scim_external_id", "scim_rich_info", "user_id", - "num_devices" + "num_devices", + "last_active" ] allowEmpty :: (ByteString -> Parser a) -> ByteString -> Parser (Maybe a) @@ -126,6 +144,11 @@ parseByteString bstr = Left err -> fail err Right thing -> pure thing +parseUTCTime :: ByteString -> Parser UTCTime +parseUTCTime b = do + s <- either (fail . displayException) pure $ T.decodeUtf8' b + parseTimeM False defaultTimeLocale timestampFormat (T.unpack s) + instance FromNamedRecord TeamExportUser where parseNamedRecord nrec = TeamExportUser @@ -148,6 +171,7 @@ instance FromNamedRecord TeamExportUser where ) <*> (nrec .: "user_id" >>= parseByteString) <*> (nrec .: "num_devices" >>= parseByteString) + <*> (nrec .: "last_active" >>= allowEmpty parseUTCTime) quoted :: ByteString -> ByteString quoted bs = case C.uncons bs of diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 7ea8f4d3fdc..e1f7844e199 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -159,29 +159,6 @@ runUserSubsystem authInterpreter = interpret $ GetUserActivityTimestamp uid -> getUserActivityTimestampImpl uid GetUserExportData uid -> getUserExportDataImpl uid -getUserExportDataImpl :: (Member UserStore r) => UserId -> Sem r (Maybe TeamExportUser) -getUserExportDataImpl uid = fmap hush . runError @() $ do - su <- UserStore.getUser uid >>= note () - mRichInfo <- UserStore.getRichInfo uid - timestamps <- UserStore.getActivityTimestamps uid - let numClients = length timestamps - pure $ - TeamExportUser - { tExportDisplayName = su.name, - tExportHandle = su.handle, - tExportEmail = su.email, - tExportRole = Nothing, - tExportCreatedOn = Nothing, - tExportInvitedBy = Nothing, - tExportIdpIssuer = userToIdPIssuer su, - tExportManagedBy = fromMaybe ManagedByWire su.managedBy, - tExportSAMLNamedId = fromMaybe "" (samlNamedId su), - tExportSCIMExternalId = fromMaybe "" (scimExtId su), - tExportSCIMRichInfo = fmap RichInfo mRichInfo, - tExportUserId = uid, - tExportNumDevices = numClients - } - scimExtId :: StoredUser -> Maybe Text scimExtId su = do m <- su.managedBy @@ -971,6 +948,7 @@ acceptTeamInvitationImpl luid pw code = do syncUserIndex uid generateUserEvent uid Nothing (teamUpdated uid tid) +-- TODO: remove getUserActivityTimestampImpl :: (Member UserStore r) => UserId -> Sem r (Maybe UTCTime) getUserActivityTimestampImpl uid = do ts <- getActivityTimestamps uid @@ -978,3 +956,30 @@ getUserActivityTimestampImpl uid = do maximum -- make sure the list of timestamps is non-empty) (Nothing : ts) + +getUserExportDataImpl :: (Member UserStore r) => UserId -> Sem r (Maybe TeamExportUser) +getUserExportDataImpl uid = fmap hush . runError @() $ do + su <- UserStore.getUser uid >>= note () + mRichInfo <- UserStore.getRichInfo uid + timestamps <- UserStore.getActivityTimestamps uid + -- Make sure the list of timestamps is non-empty so that 'maximum' is + -- well-defined and returns 'Nothing' when no valid timestamps are present. + let lastActive = maximum (Nothing : timestamps) + let numClients = length timestamps + pure $ + TeamExportUser + { tExportDisplayName = su.name, + tExportHandle = su.handle, + tExportEmail = su.email, + tExportRole = Nothing, + tExportCreatedOn = Nothing, + tExportInvitedBy = Nothing, + tExportIdpIssuer = userToIdPIssuer su, + tExportManagedBy = fromMaybe ManagedByWire su.managedBy, + tExportSAMLNamedId = fromMaybe "" (samlNamedId su), + tExportSCIMExternalId = fromMaybe "" (scimExtId su), + tExportSCIMRichInfo = fmap RichInfo mRichInfo, + tExportUserId = uid, + tExportNumDevices = numClients, + tExportLastActive = lastActive + } diff --git a/services/galley/src/Galley/API/Teams/Export.hs b/services/galley/src/Galley/API/Teams/Export.hs index 29c35240336..273cd18972c 100644 --- a/services/galley/src/Galley/API/Teams/Export.hs +++ b/services/galley/src/Galley/API/Teams/Export.hs @@ -12,7 +12,6 @@ import Data.IORef (atomicModifyIORef, newIORef) import Data.Id import Data.Map qualified as Map import Data.Qualified (Local, tUnqualified) -import Debug.Trace import Galley.Effects import Galley.Effects.BrigAccess import Galley.Effects.SparAccess qualified as Spar @@ -97,6 +96,12 @@ getUserRecord cache member = do tExportCreatedOn = mCreatedOn } +-- | Export team info as a CSV, and stream it to the client. +-- +-- We paginate through the team member list, then spawn a thread for each user +-- (out of a thread pool) in order to fetch information for that user from brig +-- and spar. Inviter IDs are resolved to handles via a brig request, then +-- stored in a cache so that they can be reused by subsequent requests. getTeamMembersCSV :: forall r. ( Member BrigAccess r, @@ -157,7 +162,6 @@ getTeamMembersCSV lusr tid = do pure r pure $ \write flush -> do let go = do - traceM "write chunk" readChan chan >>= \case Nothing -> write "" >> flush Just line -> write (byteString (toStrict line)) >> flush >> go From 9ac3569d18b439c4ef45b5866d498e894f073fd2 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 16 Oct 2024 12:49:28 +0200 Subject: [PATCH 12/23] Regenerate nix packages --- libs/wire-api/default.nix | 2 ++ libs/wire-subsystems/default.nix | 2 ++ services/galley/default.nix | 3 --- tools/stern/default.nix | 4 ++++ 4 files changed, 8 insertions(+), 3 deletions(-) diff --git a/libs/wire-api/default.nix b/libs/wire-api/default.nix index 2fd02d1acf6..c4f7828d2c3 100644 --- a/libs/wire-api/default.nix +++ b/libs/wire-api/default.nix @@ -57,6 +57,7 @@ , iso3166-country-codes , iso639 , jose +, kan-extensions , lens , lib , memory @@ -165,6 +166,7 @@ mkDerivation { iso3166-country-codes iso639 jose + kan-extensions lens memory metrics-wai diff --git a/libs/wire-subsystems/default.nix b/libs/wire-subsystems/default.nix index ead2f2a9c9d..7582b8b4228 100644 --- a/libs/wire-subsystems/default.nix +++ b/libs/wire-subsystems/default.nix @@ -15,6 +15,7 @@ , bloodhound , bytestring , bytestring-conversion +, case-insensitive , cassandra-util , conduit , containers @@ -104,6 +105,7 @@ mkDerivation { bloodhound bytestring bytestring-conversion + case-insensitive cassandra-util conduit containers diff --git a/services/galley/default.nix b/services/galley/default.nix index 446b4c9450e..5d768c816af 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -19,7 +19,6 @@ , bytestring , bytestring-conversion , call-stack -, case-insensitive , cassandra-util , cassava , cereal @@ -148,7 +147,6 @@ mkDerivation { brig-types bytestring bytestring-conversion - case-insensitive cassandra-util cassava comonad @@ -189,7 +187,6 @@ mkDerivation { resourcet retry safe-exceptions - saml2-web-sso servant servant-client servant-server diff --git a/tools/stern/default.nix b/tools/stern/default.nix index 18246b4fc52..bf6deea7bf6 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -22,6 +22,7 @@ , http-client-tls , http-types , imports +, kan-extensions , lens , lens-aeson , lib @@ -42,6 +43,7 @@ , tasty-ant-xml , tasty-hunit , text +, time , tinylog , transformers , types-common @@ -73,6 +75,7 @@ mkDerivation { http-client http-types imports + kan-extensions lens mtl openapi3 @@ -83,6 +86,7 @@ mkDerivation { servant-swagger-ui split text + time tinylog transformers types-common From 9f824fd880936ded39bde8e85f324e4e6e6a6d02 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 16 Oct 2024 13:50:22 +0200 Subject: [PATCH 13/23] Linter --- tools/stern/src/Stern/API.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 79504f66086..714a001c549 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -482,8 +482,7 @@ getTeamActivityInfo tid = do ( toByteString' user <> "," <> B8.pack - ( maybe - mempty + ( foldMap (formatTime defaultTimeLocale "%Y-%m-%d") tm ) From 3967256d4022d417542b017f0903ef2670191230 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 16 Oct 2024 13:56:43 +0200 Subject: [PATCH 14/23] Remove new stern endpoint --- tools/stern/src/Stern/API.hs | 51 +---------------------------- tools/stern/src/Stern/API/Routes.hs | 9 ----- tools/stern/stern.cabal | 1 - 3 files changed, 1 insertion(+), 60 deletions(-) diff --git a/tools/stern/src/Stern/API.hs b/tools/stern/src/Stern/API.hs index 714a001c549..53616908c64 100644 --- a/tools/stern/src/Stern/API.hs +++ b/tools/stern/src/Stern/API.hs @@ -28,18 +28,13 @@ module Stern.API where import Brig.Types.Intra -import Control.Concurrent.Chan import Control.Error -import Control.Exception (throwIO) -import Control.Lens (toListOf, (.~)) -import Control.Monad.Codensity +import Control.Lens ((.~)) import Control.Monad.Except import Data.Aeson hiding (Error, json) import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson.Types (emptyArray) import Data.ByteString (fromStrict) -import Data.ByteString.Builder (byteString) -import Data.ByteString.Char8 qualified as B8 import Data.ByteString.Conversion import Data.Handle (Handle) import Data.Id @@ -52,8 +47,6 @@ import Data.Text.Encoding qualified as T import Data.Text.Encoding.Error import Data.Text.Lazy qualified as LT import Data.Text.Lazy.Encoding qualified as LT -import Data.Time.Format -import Debug.Trace import GHC.TypeLits (KnownSymbol) import Imports hiding (head) import Network.HTTP.Types @@ -70,17 +63,14 @@ import Stern.Intra qualified as Intra import Stern.Options import Stern.Types import System.Logger.Class hiding (Error, flush, name, trace, (.=)) -import UnliftIO.Async import Util.Options import Wire.API.Connection import Wire.API.Internal.Notification (QueuedNotification) import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus) import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD import Wire.API.Routes.Internal.Galley.TeamsIntra qualified as Team -import Wire.API.Routes.LowLevelStream import Wire.API.Routes.Named (Named (Named)) import Wire.API.Team.Feature -import Wire.API.Team.Member qualified as Team import Wire.API.Team.SearchVisibility import Wire.API.User import Wire.API.User.Search @@ -197,7 +187,6 @@ sitemap' = :<|> Named @"stern-get-oauth-client" Intra.getOAuthClient :<|> Named @"update-oauth-client" Intra.updateOAuthClient :<|> Named @"delete-oauth-client" Intra.deleteOAuthClient - :<|> Named @"get-team-activity-info" getTeamActivityInfo sitemapInternal :: Servant.Server SternAPIInternal sitemapInternal = @@ -461,44 +450,6 @@ getUserData uid mMaxConvs mMaxNotifs = do "properties" .= properties ] -getTeamActivityInfo :: TeamId -> Handler LowLevelStreamingBody -getTeamActivityInfo tid = do - traceM "getTeamActivityInfo" - -- TODO: handle large teams - memList <- - toListOf (Team.teamMembers . traverse . Team.newTeamMember . Team.nUserId) - <$> Intra.getTeamMembers tid - env <- ask - pure $ do - chan <- liftIO newChan - let runThread :: IO () = do - pooledForConcurrentlyN_ 8 memList $ \user -> do - tm <- - runHandler env (Intra.getActivityTimestamp user) - >>= either throwIO pure - writeChan - chan - ( Just - ( toByteString' user - <> "," - <> B8.pack - ( foldMap - (formatTime defaultTimeLocale "%Y-%m-%d") - tm - ) - ) - ) - writeChan chan Nothing - void $ Codensity $ withAsync runThread - let body write flush = do - let go = do - traceM "write chunk" - readChan chan >>= \case - Nothing -> write "" >> flush - Just line -> write (byteString line <> "\n") >> flush >> go - go - pure (body :: StreamingBody) - -- Utilities instance (FromByteString a) => Servant.FromHttpApiData [a] where diff --git a/tools/stern/src/Stern/API/Routes.hs b/tools/stern/src/Stern/API/Routes.hs index 9fc6f634694..777bd118c5d 100644 --- a/tools/stern/src/Stern/API/Routes.hs +++ b/tools/stern/src/Stern/API/Routes.hs @@ -40,10 +40,8 @@ import Servant.Swagger.UI import Stern.Types import Wire.API.CustomBackend import Wire.API.OAuth -import Wire.API.Routes.CSV import Wire.API.Routes.Internal.Brig.Connection (ConnectionStatus) import Wire.API.Routes.Internal.Brig.EJPD qualified as EJPD -import Wire.API.Routes.LowLevelStream import Wire.API.Routes.Named import Wire.API.SwaggerHelper (cleanupSwagger) import Wire.API.Team.Feature @@ -440,13 +438,6 @@ type SternAPI = :> Capture "id" OAuthClientId :> Delete '[JSON] () ) - :<|> Named - "get-team-activity-info" - ( Summary "List user IDs and the timestamp of their last activity" - :> "team-activity-info" - :> Capture "tid" TeamId - :> LowLevelStream GET 200 '[] "Output CSV" CSV - ) ------------------------------------------------------------------------------- -- Swagger diff --git a/tools/stern/stern.cabal b/tools/stern/stern.cabal index ccef8770f72..36b5a86ca65 100644 --- a/tools/stern/stern.cabal +++ b/tools/stern/stern.cabal @@ -86,7 +86,6 @@ library , http-client >=0.7 , http-types >=0.8 , imports - , kan-extensions , lens >=4.4 , mtl >=2.1 , openapi3 From ae68529299b4823b270744dccf02b6d6fedaeefc Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Wed, 16 Oct 2024 15:07:44 +0200 Subject: [PATCH 15/23] Add status field to CSV export --- integration/test/Test/Teams.hs | 1 + libs/wire-api/src/Wire/API/Team/Export.hs | 28 ++++++++++++++++--- .../src/Wire/UserSubsystem/Interpreter.hs | 3 +- 3 files changed, 27 insertions(+), 5 deletions(-) diff --git a/integration/test/Test/Teams.hs b/integration/test/Test/Teams.hs index 8517595bb71..5ce10031fba 100644 --- a/integration/test/Test/Teams.hs +++ b/integration/test/Test/Teams.hs @@ -343,6 +343,7 @@ testTeamMemberCsvExport = do (if numClients > 0 then shouldNotMatch else shouldMatch) (parseField 13) "" + parseField 14 `shouldMatch` "active" where unquote :: String -> String unquote ('\'' : x) = x diff --git a/libs/wire-api/src/Wire/API/Team/Export.hs b/libs/wire-api/src/Wire/API/Team/Export.hs index eb684f34a31..c31040c5e42 100644 --- a/libs/wire-api/src/Wire/API/Team/Export.hs +++ b/libs/wire-api/src/Wire/API/Team/Export.hs @@ -37,7 +37,7 @@ import Data.Vector (fromList) import Imports import Test.QuickCheck import Wire.API.Team.Role (Role) -import Wire.API.User (Name) +import Wire.API.User (AccountStatus (..), Name) import Wire.API.User.Identity (EmailAddress) import Wire.API.User.Profile (ManagedBy) import Wire.API.User.RichInfo (RichInfo) @@ -60,7 +60,8 @@ data TeamExportUser = TeamExportUser tExportSCIMRichInfo :: Maybe RichInfo, tExportUserId :: UserId, tExportNumDevices :: Int, - tExportLastActive :: Maybe UTCTime + tExportLastActive :: Maybe UTCTime, + tExportStatus :: Maybe AccountStatus } deriving (Show, Eq, Generic) deriving (Arbitrary) via (GenericUniform TeamExportUser) @@ -84,6 +85,7 @@ instance ToSchema TeamExportUser where <*> tExportUserId .= field "user_id" schema <*> tExportNumDevices .= field "num_devices" schema <*> tExportLastActive .= maybe_ (optField "last_active" utcTimeSchema) + <*> tExportStatus .= maybe_ (optField "status" schema) instance ToNamedRecord TeamExportUser where toNamedRecord row = @@ -108,7 +110,8 @@ instance ToNamedRecord TeamExportUser where (formatTime defaultTimeLocale timestampFormat) (tExportLastActive row) ) - ) + ), + ("status", maybe "" formatAccountStatus (tExportStatus row)) ] secureCsvFieldToByteString :: forall a. (ToByteString a) => a -> ByteString @@ -131,7 +134,8 @@ instance DefaultOrdered TeamExportUser where "scim_rich_info", "user_id", "num_devices", - "last_active" + "last_active", + "status" ] allowEmpty :: (ByteString -> Parser a) -> ByteString -> Parser (Maybe a) @@ -149,6 +153,21 @@ parseUTCTime b = do s <- either (fail . displayException) pure $ T.decodeUtf8' b parseTimeM False defaultTimeLocale timestampFormat (T.unpack s) +parseAccountStatus :: ByteString -> Parser AccountStatus +parseAccountStatus "active" = pure Active +parseAccountStatus "suspended" = pure Suspended +parseAccountStatus "deleted" = pure Deleted +parseAccountStatus "ephemeral" = pure Ephemeral +parseAccountStatus "pending-invitation" = pure PendingInvitation +parseAccountStatus _ = fail "invalid account status" + +formatAccountStatus :: AccountStatus -> ByteString +formatAccountStatus Active = "active" +formatAccountStatus Suspended = "suspended" +formatAccountStatus Deleted = "deleted" +formatAccountStatus Ephemeral = "ephemeral" +formatAccountStatus PendingInvitation = "pending-invitation" + instance FromNamedRecord TeamExportUser where parseNamedRecord nrec = TeamExportUser @@ -172,6 +191,7 @@ instance FromNamedRecord TeamExportUser where <*> (nrec .: "user_id" >>= parseByteString) <*> (nrec .: "num_devices" >>= parseByteString) <*> (nrec .: "last_active" >>= allowEmpty parseUTCTime) + <*> (nrec .: "status" >>= allowEmpty parseAccountStatus) quoted :: ByteString -> ByteString quoted bs = case C.uncons bs of diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index e1f7844e199..8a4611320b3 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -981,5 +981,6 @@ getUserExportDataImpl uid = fmap hush . runError @() $ do tExportSCIMRichInfo = fmap RichInfo mRichInfo, tExportUserId = uid, tExportNumDevices = numClients, - tExportLastActive = lastActive + tExportLastActive = lastActive, + tExportStatus = su.status } From c4664252851e2c87f6a6a142272b8c9201cc540a Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 17 Oct 2024 09:14:30 +0200 Subject: [PATCH 16/23] Remove new brig internal endpoint This is not needed anymore since the stern endpoint to get user activity has been removed. --- libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs | 9 --------- libs/wire-subsystems/src/Wire/UserSubsystem.hs | 2 -- .../src/Wire/UserSubsystem/Interpreter.hs | 10 ---------- services/brig/src/Brig/API/Internal.hs | 12 ------------ 4 files changed, 33 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 855de2714ef..31c1b018e33 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -47,7 +47,6 @@ import Data.CommaSeparatedList import Data.Domain (Domain) import Data.Handle (Handle) import Data.Id as Id -import Data.Json.Util import Data.OpenApi (HasInfo (info), HasTitle (title), OpenApi) import Data.OpenApi qualified as S import Data.Qualified (Qualified) @@ -603,14 +602,6 @@ type UserAPI = UpdateUserLocale :<|> DeleteUserLocale :<|> GetDefaultLocale - :<|> Named - "get-activity-timestamp" - ( Summary "Get the last activity timestamp of a user" - :> "users" - :> Capture "uid" UserId - :> "activity" - :> MultiVerb1 'GET '[JSON] (Respond 200 "Activity" (Maybe UTCTimeMillis)) - ) :<|> Named "get-user-export-data" ( Summary "Get user export data" diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem.hs b/libs/wire-subsystems/src/Wire/UserSubsystem.hs index 538db533134..c8237825748 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem.hs @@ -15,7 +15,6 @@ import Data.Id import Data.Misc import Data.Qualified import Data.Range -import Data.Time.Clock import Imports import Polysemy import Polysemy.Error @@ -145,7 +144,6 @@ data UserSubsystem m a where -- migration this would just be an internal detail of the subsystem InternalUpdateSearchIndex :: UserId -> UserSubsystem m () InternalFindTeamInvitation :: Maybe EmailKey -> InvitationCode -> UserSubsystem m StoredInvitation - GetUserActivityTimestamp :: UserId -> UserSubsystem m (Maybe UTCTime) GetUserExportData :: UserId -> UserSubsystem m (Maybe TeamExportUser) -- | the return type of 'CheckHandle' diff --git a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs index 8a4611320b3..8f9ba2566e1 100644 --- a/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs +++ b/libs/wire-subsystems/src/Wire/UserSubsystem/Interpreter.hs @@ -156,7 +156,6 @@ runUserSubsystem authInterpreter = interpret $ acceptTeamInvitationImpl luid pwd code InternalFindTeamInvitation mEmailKey code -> internalFindTeamInvitationImpl mEmailKey code - GetUserActivityTimestamp uid -> getUserActivityTimestampImpl uid GetUserExportData uid -> getUserExportDataImpl uid scimExtId :: StoredUser -> Maybe Text @@ -948,15 +947,6 @@ acceptTeamInvitationImpl luid pw code = do syncUserIndex uid generateUserEvent uid Nothing (teamUpdated uid tid) --- TODO: remove -getUserActivityTimestampImpl :: (Member UserStore r) => UserId -> Sem r (Maybe UTCTime) -getUserActivityTimestampImpl uid = do - ts <- getActivityTimestamps uid - pure $ - maximum - -- make sure the list of timestamps is non-empty) - (Nothing : ts) - getUserExportDataImpl :: (Member UserStore r) => UserId -> Sem r (Maybe TeamExportUser) getUserExportDataImpl uid = fmap hush . runError @() $ do su <- UserStore.getUser uid >>= note () diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 150e82354af..50b7ad70044 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -57,7 +57,6 @@ import Data.Domain (Domain) import Data.Handle import Data.HavePendingInvitations import Data.Id as Id -import Data.Json.Util import Data.Map.Strict qualified as Map import Data.Qualified import Data.Set qualified as Set @@ -268,7 +267,6 @@ userAPI = updateLocale :<|> deleteLocale :<|> getDefaultUserLocale - :<|> Named @"get-activity-timestamp" getUserActivityTimestampH :<|> Named @"get-user-export-data" getUserExportDataH clientAPI :: ServerT BrigIRoutes.ClientAPI (Handler r) @@ -805,16 +803,6 @@ checkHandleInternalH h = lift $ liftSem do getContactListH :: UserId -> (Handler r) UserIds getContactListH uid = lift . wrapClient $ UserIds <$> API.lookupContactList uid -getUserActivityTimestampH :: - (Member UserSubsystem r) => - UserId -> - Handler r (Maybe UTCTimeMillis) -getUserActivityTimestampH = - lift - . liftSem - . fmap (fmap toUTCTimeMillis) - . getUserActivityTimestamp - getUserExportDataH :: (Member UserSubsystem r) => UserId -> From 963b33b5346f2a49d9ca69df0fb773603c6d748e Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 17 Oct 2024 09:27:53 +0200 Subject: [PATCH 17/23] Add CHANGELOG entry --- changelog.d/1-api-changes/add-columns-to-export | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/1-api-changes/add-columns-to-export diff --git a/changelog.d/1-api-changes/add-columns-to-export b/changelog.d/1-api-changes/add-columns-to-export new file mode 100644 index 00000000000..04633327ba1 --- /dev/null +++ b/changelog.d/1-api-changes/add-columns-to-export @@ -0,0 +1 @@ +The team CSV export endpoint has gained two extra columns: `last_active` and `status`. The streaming behaviour has also been improved. From e02dfd7217e9496abfdf0d8c037db4bd3ef7fe0a Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 17 Oct 2024 11:19:03 +0200 Subject: [PATCH 18/23] Regenerate nix packages --- services/galley/default.nix | 1 - tools/stern/default.nix | 2 -- 2 files changed, 3 deletions(-) diff --git a/services/galley/default.nix b/services/galley/default.nix index 5d768c816af..602549b250b 100644 --- a/services/galley/default.nix +++ b/services/galley/default.nix @@ -78,7 +78,6 @@ , resourcet , retry , safe-exceptions -, saml2-web-sso , servant , servant-client , servant-client-core diff --git a/tools/stern/default.nix b/tools/stern/default.nix index bf6deea7bf6..81032346144 100644 --- a/tools/stern/default.nix +++ b/tools/stern/default.nix @@ -22,7 +22,6 @@ , http-client-tls , http-types , imports -, kan-extensions , lens , lens-aeson , lib @@ -75,7 +74,6 @@ mkDerivation { http-client http-types imports - kan-extensions lens mtl openapi3 From a909775e546cff772d7868eae43a22e2b1752f70 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 17 Oct 2024 14:40:44 +0200 Subject: [PATCH 19/23] Fix CSV roundtrip test --- .../test/unit/Test/Wire/API/Roundtrip/CSV.hs | 21 ++++++++++++++++--- libs/wire-api/wire-api.cabal | 1 + 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/CSV.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/CSV.hs index 3844143e128..477b154cf67 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/CSV.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/CSV.hs @@ -19,17 +19,32 @@ module Test.Wire.API.Roundtrip.CSV where import Control.Arrow ((>>>)) import Data.Csv +import Data.Time.Clock import Data.Vector qualified as V import Imports import Test.Tasty qualified as T -import Test.Tasty.QuickCheck (Arbitrary, counterexample, testProperty, (===)) +import Test.Tasty.QuickCheck import Type.Reflection (typeRep) -import Wire.API.Team.Export qualified as Team.Export +import Wire.API.Team.Export + +newtype ValidTeamExportUser = ValidTeamExportUser + {unValidTeamExportUser :: TeamExportUser} + deriving newtype (FromNamedRecord, ToNamedRecord, DefaultOrdered, Eq, Show) + +instance Arbitrary ValidTeamExportUser where + arbitrary = do + u <- arbitrary + let resetTime (UTCTime d _) = UTCTime d 0 + pure $ + ValidTeamExportUser + u + { tExportLastActive = fmap resetTime (tExportLastActive u) + } tests :: T.TestTree tests = T.localOption (T.Timeout (60 * 1000000) "60s") . T.testGroup "CSV roundtrip tests" $ - [testRoundTrip @Team.Export.TeamExportUser] + [testRoundTrip @ValidTeamExportUser] testRoundTrip :: forall a. diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 33c53b3ddf3..c0c933bec66 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -714,6 +714,7 @@ test-suite wire-api-tests , tasty-hunit , tasty-quickcheck , text + , time , types-common >=0.16 , unliftio , uuid From 6572f247e92e260bef8d826835a28ab9264b15f1 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Thu, 17 Oct 2024 16:52:01 +0200 Subject: [PATCH 20/23] Remove lookupRichInfo --- services/brig/src/Brig/API/Internal.hs | 8 +++++--- services/brig/src/Brig/API/Public.hs | 11 +++++++++-- services/brig/src/Brig/API/User.hs | 1 - services/brig/src/Brig/Data/User.hs | 10 ---------- 4 files changed, 14 insertions(+), 16 deletions(-) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 50b7ad70044..c27c5ba7a00 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -112,7 +112,7 @@ import Wire.Rpc import Wire.Sem.Concurrency import Wire.TeamInvitationSubsystem import Wire.UserKeyStore -import Wire.UserStore +import Wire.UserStore as UserStore import Wire.UserSubsystem import Wire.UserSubsystem qualified as UserSubsystem import Wire.UserSubsystem.Error @@ -764,8 +764,10 @@ updateClientLastActive u c = do } lift . wrapClient $ Data.updateClientLastActive u c now -getRichInfoH :: UserId -> (Handler r) RichInfo -getRichInfoH uid = RichInfo . fromMaybe mempty <$> lift (wrapClient $ API.lookupRichInfo uid) +getRichInfoH :: (Member UserStore r) => UserId -> Handler r RichInfo +getRichInfoH uid = + RichInfo . fromMaybe mempty + <$> lift (liftSem $ UserStore.getRichInfo uid) getRichInfoMultiH :: Maybe (CommaSeparatedList UserId) -> (Handler r) [(UserId, RichInfo)] getRichInfoMultiH (maybe [] fromCommaSeparatedList -> uids) = diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 017f225a190..7c9128f96ae 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -170,6 +170,7 @@ import Wire.TeamInvitationSubsystem import Wire.UserKeyStore import Wire.UserSearch.Types import Wire.UserStore (UserStore) +import Wire.UserStore qualified as UserStore import Wire.UserSubsystem hiding (checkHandle, checkHandles) import Wire.UserSubsystem qualified as User import Wire.UserSubsystem.Error @@ -657,7 +658,13 @@ getClientCapabilities uid cid = do mclient <- lift (API.lookupLocalClient uid cid) maybe (throwStd (errorToWai @'E.ClientNotFound)) (pure . Public.clientCapabilities) mclient -getRichInfo :: (Member UserSubsystem r) => Local UserId -> UserId -> Handler r Public.RichInfoAssocList +getRichInfo :: + ( Member UserSubsystem r, + Member UserStore 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 @@ -671,7 +678,7 @@ getRichInfo lself user = do (Just t1, Just t2) | t1 == t2 -> pure () _ -> throwStd insufficientTeamPermissions -- Query rich info - wrapClientE $ fromMaybe mempty <$> API.lookupRichInfo (tUnqualified luser) + lift $ liftSem $ fold <$> UserStore.getRichInfo (tUnqualified luser) getSupportedProtocols :: (Member UserSubsystem r) => diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index bccba92ac46..8ea615fc830 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -35,7 +35,6 @@ module Brig.API.User getLegalHoldStatus, Data.lookupName, Data.lookupUser, - Data.lookupRichInfo, Data.lookupRichInfoMultiUsers, removeEmail, revokeIdentity, diff --git a/services/brig/src/Brig/Data/User.hs b/services/brig/src/Brig/Data/User.hs index e5772f2912e..aed64c559bc 100644 --- a/services/brig/src/Brig/Data/User.hs +++ b/services/brig/src/Brig/Data/User.hs @@ -35,7 +35,6 @@ module Brig.Data.User lookupUser, lookupUsers, lookupName, - lookupRichInfo, lookupRichInfoMultiUsers, lookupUserTeam, lookupServiceUsers, @@ -374,12 +373,6 @@ lookupName u = fmap runIdentity <$> retry x1 (query1 nameSelect (params LocalQuorum (Identity u))) --- TODO: remove this -lookupRichInfo :: (MonadClient m) => UserId -> m (Maybe RichInfoAssocList) -lookupRichInfo u = - fmap runIdentity - <$> retry x1 (query1 richInfoSelect (params LocalQuorum (Identity u))) - -- | Returned rich infos are in the same order as users lookupRichInfoMultiUsers :: (MonadClient m) => [UserId] -> m [(UserId, RichInfo)] lookupRichInfoMultiUsers users = do @@ -523,9 +516,6 @@ nameSelect = "SELECT name FROM user WHERE id = ?" authSelect :: PrepQuery R (Identity UserId) (Maybe Password, Maybe AccountStatus) authSelect = "SELECT password, status FROM user WHERE id = ?" -richInfoSelect :: PrepQuery R (Identity UserId) (Identity RichInfoAssocList) -richInfoSelect = "SELECT json FROM rich_info WHERE user = ?" - richInfoSelectMulti :: PrepQuery R (Identity [UserId]) (UserId, Maybe RichInfoAssocList) richInfoSelectMulti = "SELECT user, json FROM rich_info WHERE user in ?" From 7f88e0fd661c0a1966abb4fca34bb115fda8dd35 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 18 Oct 2024 08:48:38 +0200 Subject: [PATCH 21/23] Remove stern endpoint test --- integration/test/Test/Client.hs | 26 -------------------------- 1 file changed, 26 deletions(-) diff --git a/integration/test/Test/Client.hs b/integration/test/Test/Client.hs index bc39d96d985..8c3101737dd 100644 --- a/integration/test/Test/Client.hs +++ b/integration/test/Test/Client.hs @@ -6,12 +6,10 @@ import API.Brig import qualified API.Brig as API import API.BrigCommon import API.Gundeck -import API.Stern import Control.Lens hiding ((.=)) import Control.Monad.Codensity import Control.Monad.Reader import Data.Aeson hiding ((.=)) -import qualified Data.ByteString.Char8 as B8 import Data.ProtoLens.Labels () import Data.Time.Clock.POSIX import Data.Time.Clock.System @@ -44,30 +42,6 @@ testClientLastActive = do <$> parseTimeM False defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" tm1 assertBool "last_active is earlier than expected" $ ts1 >= now -testTeamActivity :: (HasCallStack) => App () -testTeamActivity = do - (alice, tid, [bob, charlie]) <- createTeam OwnDomain 3 - [alice1, _alice2] <- replicateM 2 $ addClient alice def >>= getJSON 201 - [_bob1, _bob2] <- replicateM 2 $ addClient bob def >>= getJSON 201 - charlie1 <- addClient charlie def >>= getJSON 201 - - for_ [(alice, alice1), (charlie, charlie1)] $ \(u, cl) -> do - clientId <- cl %. "id" & asString - void $ getNotifications u def {client = Just clientId} - - let row (u, t) = do - uid <- u %. "id" & asString - pure (uid, t) - - expectedRows <- sort <$> traverse row [(alice, True), (bob, False), (charlie, True)] - - bindResponse (getTeamActivity alice tid) $ \resp -> do - resp.status `shouldMatchInt` 200 - for_ (zip (sort (B8.lines resp.body)) expectedRows) $ \(r, (uid, active)) -> do - let [actualUser, timestamp] = B8.split ',' r - B8.unpack actualUser `shouldMatch` uid - B8.null timestamp `shouldMatch` not active - testListClientsIfBackendIsOffline :: (HasCallStack) => App () testListClientsIfBackendIsOffline = do resourcePool <- asks (.resourcePool) From 809a6236db73d8d4c4b5dc34f39cfac6e1a5b7af Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 18 Oct 2024 10:30:07 +0200 Subject: [PATCH 22/23] Simplify SCIM user info lookup --- libs/wire-api/src/Wire/API/Routes/Internal/Spar.hs | 2 +- libs/wire-api/src/Wire/API/User.hs | 13 ------------- services/galley/src/Galley/API/Teams/Export.hs | 5 +---- services/galley/src/Galley/Effects/SparAccess.hs | 2 +- services/galley/src/Galley/Intra/Effects.hs | 6 +++--- services/galley/src/Galley/Intra/Spar.hs | 14 ++++++-------- services/spar/src/Spar/API.hs | 10 ++++------ 7 files changed, 16 insertions(+), 36 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Spar.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Spar.hs index 8cc2207031c..b5bc7b34380 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Spar.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Spar.hs @@ -31,7 +31,7 @@ type InternalAPI = :> ( "status" :> Get '[JSON] NoContent :<|> "teams" :> Capture "team" TeamId :> DeleteNoContent :<|> "sso" :> "settings" :> ReqBody '[JSON] SsoSettings :> Put '[JSON] NoContent - :<|> "scim" :> "userinfos" :> ReqBody '[JSON] UserSet :> Post '[JSON] ScimUserInfos + :<|> "scim" :> "userinfo" :> Capture "user" UserId :> Post '[JSON] ScimUserInfo ) swaggerDoc :: OpenApi diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 6e037a0489a..f55459746f7 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -28,7 +28,6 @@ module Wire.API.User qualifiedUserIdListObjectSchema, LimitedQualifiedUserIdList (..), ScimUserInfo (..), - ScimUserInfos (..), UserSet (..), -- Profiles UserProfile (..), @@ -1339,18 +1338,6 @@ instance ToSchema ScimUserInfo where <*> suiCreatedOn .= maybe_ (optField "created_on" schema) -newtype ScimUserInfos = ScimUserInfos {scimUserInfos :: [ScimUserInfo]} - deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via (GenericUniform ScimUserInfos) - deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ScimUserInfos) - -instance ToSchema ScimUserInfos where - schema = - object "ScimUserInfos" $ - ScimUserInfos - <$> scimUserInfos - .= field "scim_user_infos" (array schema) - ------------------------------------------------------------------------------- -- UserSet diff --git a/services/galley/src/Galley/API/Teams/Export.hs b/services/galley/src/Galley/API/Teams/Export.hs index 273cd18972c..f4f3d57c245 100644 --- a/services/galley/src/Galley/API/Teams/Export.hs +++ b/services/galley/src/Galley/API/Teams/Export.hs @@ -82,10 +82,7 @@ getUserRecord cache member = do let mFromInvitation = snd <$> member ^. invitation case mFromInvitation of Just ts -> pure $ Just ts - Nothing -> do - -- TODO: make this a single user query - suis <- Spar.lookupScimUserInfos [uid] - pure $ listToMaybe suis >>= suiCreatedOn + Nothing -> suiCreatedOn <$> Spar.lookupScimUserInfo uid -- look up inviter handle from the cache let mInviterId = fst <$> member ^. invitation invitedBy <- join <$> traverse (lookupInviter cache) mInviterId diff --git a/services/galley/src/Galley/Effects/SparAccess.hs b/services/galley/src/Galley/Effects/SparAccess.hs index 4b9b0df882d..f84e3ac87ec 100644 --- a/services/galley/src/Galley/Effects/SparAccess.hs +++ b/services/galley/src/Galley/Effects/SparAccess.hs @@ -25,6 +25,6 @@ import Wire.API.User (ScimUserInfo) data SparAccess m a where DeleteTeam :: TeamId -> SparAccess m () - LookupScimUserInfos :: [UserId] -> SparAccess m [ScimUserInfo] + LookupScimUserInfo :: UserId -> SparAccess m ScimUserInfo makeSem ''SparAccess diff --git a/services/galley/src/Galley/Intra/Effects.hs b/services/galley/src/Galley/Intra/Effects.hs index 29e39798ac2..88fc983c8e1 100644 --- a/services/galley/src/Galley/Intra/Effects.hs +++ b/services/galley/src/Galley/Intra/Effects.hs @@ -128,9 +128,9 @@ interpretSparAccess = interpret $ \case DeleteTeam tid -> do logEffect "SparAccess.DeleteTeam" embedApp $ deleteTeam tid - LookupScimUserInfos uids -> do - logEffect "SparAccess.LookupScimUserInfos" - embedApp $ lookupScimUserInfos uids + LookupScimUserInfo uid -> do + logEffect "SparAccess.LookupScimUserInfo" + embedApp $ lookupScimUserInfo uid interpretBotAccess :: ( Member (Embed IO) r, diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index 989df2563ed..3da1e85178e 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -17,19 +17,18 @@ module Galley.Intra.Spar ( deleteTeam, - lookupScimUserInfos, + lookupScimUserInfo, ) where import Bilge import Data.ByteString.Conversion import Data.Id -import Data.Set qualified as Set import Galley.Intra.Util import Galley.Monad import Imports import Network.HTTP.Types.Method -import Wire.API.User (ScimUserInfo, UserSet (..), scimUserInfos) +import Wire.API.User (ScimUserInfo) -- | Notify Spar that a team is being deleted. deleteTeam :: TeamId -> App () @@ -40,11 +39,10 @@ deleteTeam tid = do . expect2xx -- | Get the SCIM user info for a user. -lookupScimUserInfos :: [UserId] -> App [ScimUserInfo] -lookupScimUserInfos uids = do +lookupScimUserInfo :: UserId -> App (ScimUserInfo) +lookupScimUserInfo uid = do response <- call Spar $ method POST - . paths ["i", "scim", "userinfos"] - . json (UserSet $ Set.fromList uids) - pure $ foldMap scimUserInfos $ responseJsonMaybe response + . paths ["i", "scim", "userinfos", toByteString' uid] + responseJsonError response diff --git a/services/spar/src/Spar/API.hs b/services/spar/src/Spar/API.hs index 3d9eca78560..f814f211402 100644 --- a/services/spar/src/Spar/API.hs +++ b/services/spar/src/Spar/API.hs @@ -54,7 +54,6 @@ import Data.HavePendingInvitations import Data.Id import Data.Proxy import Data.Range -import qualified Data.Set as Set import Data.Text.Encoding.Error import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding @@ -791,8 +790,7 @@ internalPutSsoSettings SsoSettings {defaultSsoCode = Just code} = *> DefaultSsoCode.store code $> NoContent -internalGetScimUserInfo :: (Member ScimUserTimesStore r) => UserSet -> Sem r ScimUserInfos -internalGetScimUserInfo (UserSet uids) = do - results <- ScimUserTimesStore.readMulti (Set.toList uids) - let scimUserInfos = results <&> (\(uid, t, _) -> ScimUserInfo uid (Just t)) - pure $ ScimUserInfos scimUserInfos +internalGetScimUserInfo :: (Member ScimUserTimesStore r) => UserId -> Sem r ScimUserInfo +internalGetScimUserInfo uid = do + t <- fmap fst <$> ScimUserTimesStore.read uid + pure $ ScimUserInfo uid t From 0bafd0187dca52a78ded87ff14c50c2058a401b6 Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Mon, 21 Oct 2024 10:00:28 +0200 Subject: [PATCH 23/23] fixup! Simplify SCIM user info lookup --- services/galley/src/Galley/Intra/Spar.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/services/galley/src/Galley/Intra/Spar.hs b/services/galley/src/Galley/Intra/Spar.hs index 3da1e85178e..3fede63dc16 100644 --- a/services/galley/src/Galley/Intra/Spar.hs +++ b/services/galley/src/Galley/Intra/Spar.hs @@ -39,10 +39,10 @@ deleteTeam tid = do . expect2xx -- | Get the SCIM user info for a user. -lookupScimUserInfo :: UserId -> App (ScimUserInfo) +lookupScimUserInfo :: UserId -> App ScimUserInfo lookupScimUserInfo uid = do response <- call Spar $ method POST - . paths ["i", "scim", "userinfos", toByteString' uid] + . paths ["i", "scim", "userinfo", toByteString' uid] responseJsonError response