Refactor CSV export (#4293)

* Initial endpoint skeleton

* Set up finalisation for CSV streaming

* Implement internal API to get user activity

* Test activity endpoint

* Initial refactoring of CSV export

* getUserRecord implemented

* fix integration package

* New implementation of getTeamMembersCSV

* Implement inviter handle cache

* Remove old CSV export handler

* Add activity timestamp to csv export

* Regenerate nix packages

* Linter

* Remove new stern endpoint

* Add status field to CSV export

* Remove new brig internal endpoint

This is not needed anymore since the stern endpoint to get user activity
has been removed.

* Add CHANGELOG entry

* Regenerate nix packages

* Fix CSV roundtrip test

* Remove lookupRichInfo

* Remove stern endpoint test

* Simplify SCIM user info lookup

* fixup! Simplify SCIM user info lookup

---------

Co-authored-by: Leif Battermann <[email protected]>

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.

integration/integration.cabal

@@ -100,6 +100,7 @@ library
     API.GundeckInternal
     API.Nginz
     API.Spar
+    API.Stern
     MLS.Util
     Notifications
     RunAllTests

integration/test/API/Stern.hs

@@ -0,0 +1,8 @@
+module API.Stern where
+
+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"

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 <[email protected]>
@@ -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,14 +316,16 @@ 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
       let mem = memberMap Map.! uid
 
       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,15 @@ 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)
+        ""
+      parseField 14 `shouldMatch` "active"
   where
     unquote :: String -> String
     unquote ('\'' : x) = x

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

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

@@ -76,6 +76,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
@@ -601,6 +602,14 @@ type UserAPI =
   UpdateUserLocale
     :<|> DeleteUserLocale
     :<|> GetDefaultLocale
+    :<|> 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

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

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,23 +69,35 @@ 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 ->
     let AcceptHeader accH = getAcceptHeader request
         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)

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

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 =