Servantify Team CSV endpoint (#2419)

* Convert CSV endpoint to Servant

* Add response header support to LowLevelStream

changelog.d/5-internal/servantify-csv

@@ -0,0 +1 @@
+Convert Team CSV endpoint to Servant

libs/wire-api/src/Wire/API/Routes/CSV.hs

@@ -0,0 +1,26 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.
+
+module Wire.API.Routes.CSV where
+
+import Network.HTTP.Media.MediaType
+import Servant.API
+
+data CSV
+
+instance Accept CSV where
+  contentType _ = "text" // "csv"

libs/wire-api/src/Wire/API/Routes/LowLevelStream.hs

@@ -0,0 +1,110 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 Wire Swiss GmbH <[email protected]>
+--
+-- This program is free software: you can redistribute it and/or modify it under
+-- the terms of the GNU Affero General Public License as published by the Free
+-- Software Foundation, either version 3 of the License, or (at your option) any
+-- later version.
+--
+-- This program is distributed in the hope that it will be useful, but WITHOUT
+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
+-- details.
+--
+-- You should have received a copy of the GNU Affero General Public License along
+-- with this program. If not, see <https://www.gnu.org/licenses/>.
+
+module Wire.API.Routes.LowLevelStream where
+
+import Control.Lens (at, (.~), (?~))
+import Data.ByteString.Char8 as B8
+import qualified Data.CaseInsensitive as CI
+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
+import Data.Metrics.Servant
+import Data.Proxy
+import qualified Data.Swagger as S
+import qualified Data.Text as Text
+import GHC.TypeLits
+import Imports
+import qualified Network.HTTP.Media as HTTP
+import Network.HTTP.Types
+import Network.Wai
+import Servant.API
+import Servant.API.ContentTypes
+import Servant.API.Status
+import Servant.Server hiding (respond)
+import Servant.Server.Internal
+import Servant.Swagger as S
+import Servant.Swagger.Internal as S
+
+-- FUTUREWORK: make it possible to generate headers at runtime
+data LowLevelStream method status (headers :: [(Symbol, Symbol)]) desc ctype
+
+class RenderHeaders (headers :: [(Symbol, Symbol)]) where
+  renderHeaders :: [(HeaderName, ByteString)]
+
+instance RenderHeaders '[] where
+  renderHeaders = []
+
+instance
+  (KnownSymbol name, KnownSymbol value, RenderHeaders headers) =>
+  RenderHeaders ('(name, value) ': headers)
+  where
+  renderHeaders = (name, value) : renderHeaders @headers
+    where
+      name :: HeaderName
+      name = CI.mk (B8.pack (symbolVal (Proxy @name)))
+      value :: ByteString
+      value = B8.pack (symbolVal (Proxy @value))
+
+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
+  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)
+    where
+      method = reflectMethod (Proxy :: Proxy method)
+      status = statusFromNat (Proxy :: Proxy status)
+      extraHeaders = renderHeaders @headers
+
+instance
+  (Accept ctype, KnownNat status, KnownSymbol desc, SwaggerMethod method) =>
+  HasSwagger (LowLevelStream method status headers desc ctype)
+  where
+  toSwagger _ =
+    mempty
+      & S.paths
+        . at "/"
+        ?~ ( mempty
+               & method
+                 ?~ ( mempty
+                        & S.produces ?~ S.MimeList [contentType (Proxy @ctype)]
+                        & S.responses . S.responses .~ fmap S.Inline responses
+                    )
+           )
+    where
+      method = S.swaggerMethod (Proxy @method)
+      responses =
+        InsOrdHashMap.singleton
+          (fromIntegral (natVal (Proxy @status)))
+          $ mempty
+            & S.description .~ Text.pack (symbolVal (Proxy @desc))
+
+instance RoutesToPaths (LowLevelStream method status headers desc ctype) where
+  getRoutes = []

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

@@ -46,6 +46,8 @@ import Wire.API.MLS.Serialisation
 import Wire.API.MLS.Servant
 import Wire.API.MLS.Welcome
 import Wire.API.Message
+import Wire.API.Routes.CSV
+import Wire.API.Routes.LowLevelStream
 import Wire.API.Routes.MultiVerb
 import Wire.API.Routes.Named
 import Wire.API.Routes.Public
@@ -1653,6 +1655,29 @@ type TeamMemberAPI =
                     '[JSON]
                     (RespondEmpty 200 "")
            )
+    :<|> Named
+           "get-team-members-csv"
+           ( Summary "Get all members of the team as a CSV file"
+               :> CanThrow 'AccessDenied
+               :> Description
+                    "The endpoint returns data in chunked transfer encoding.\
+                    \ Internal server errors might result in a failed transfer\
+                    \ instead of a 500 response."
+               :> ZLocalUser
+               :> "teams"
+               :> Capture "tid" TeamId
+               :> "members"
+               :> "csv"
+               :> LowLevelStream
+                    'GET
+                    200
+                    '[ '( "Content-Disposition",
+                          "attachment; filename=\"wire_team_members.csv\""
+                        )
+                     ]
+                    "CSV of team members"
+                    CSV
+           )
 
 type TeamMemberDeleteResultResponseType =
   '[ RespondEmpty 202 "Team member scheduled for deletion",

libs/wire-api/wire-api.cabal

@@ -69,13 +69,15 @@ library
       Wire.API.Routes.API
       Wire.API.Routes.AssetBody
       Wire.API.Routes.ClientAlgebra
+      Wire.API.Routes.CSV
       Wire.API.Routes.Internal.Brig
       Wire.API.Routes.Internal.Brig.Connection
       Wire.API.Routes.Internal.Brig.EJPD
       Wire.API.Routes.Internal.Cannon
       Wire.API.Routes.Internal.Cargohold
       Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti
       Wire.API.Routes.Internal.LegalHold
+      Wire.API.Routes.LowLevelStream
       Wire.API.Routes.MultiTablePaging
       Wire.API.Routes.MultiTablePaging.State
       Wire.API.Routes.MultiVerb

services/galley/src/Galley/API/Public.hs

@@ -110,24 +110,6 @@ errorSResponse = errorResponse (toWai (dynError @(MapError e)))
 
 sitemap :: Routes ApiBuilder (Sem GalleyEffects) ()
 sitemap = do
-  -- Team Member API -----------------------------------------------------
-
-  get "/teams/:tid/members/csv" (continueE Teams.getTeamMembersCSVH) $
-    -- we could discriminate based on accept header only, but having two paths makes building
-    -- nginz metrics dashboards easier.
-    zauthUserId
-      .&. capture "tid"
-      .&. accept "text" "csv"
-  document "GET" "getTeamMembersCSV" $ do
-    summary "Get all members of the team as a CSV file"
-    notes
-      "The endpoint returns data in chunked transfer encoding.\
-      \ Internal server errors might result in a failed transfer instead of a 500 response."
-    parameter Path "tid" bytes' $
-      description "Team ID"
-    response 200 "Team members CSV file" end
-    errorSResponse @'AccessDenied
-
   get "/teams/notifications" (continueE Teams.getTeamNotificationsH) $
     zauthUserId
       .&. opt (query "since")

services/galley/src/Galley/API/Public/Servant.hs

@@ -307,3 +307,4 @@ servantSitemap =
         <@> mkNamedAPI @"delete-team-member" deleteTeamMember
         <@> mkNamedAPI @"delete-non-binding-team-member" deleteNonBindingTeamMember
         <@> mkNamedAPI @"update-team-member" updateTeamMember
+        <@> mkNamedAPI @"get-team-members-csv" getTeamMembersCSV

services/galley/src/Galley/API/Teams.hs

@@ -32,7 +32,7 @@ module Galley.API.Teams
     getTeamNotificationsH,
     getTeamConversationRoles,
     getTeamMembers,
-    getTeamMembersCSVH,
+    getTeamMembersCSV,
     bulkGetTeamMembers,
     getTeamMember,
     deleteTeamMember,
@@ -114,7 +114,6 @@ import Galley.Types.Teams.Intra
 import Galley.Types.Teams.SearchVisibility
 import Galley.Types.UserList
 import Imports hiding (forkIO)
-import Network.HTTP.Types
 import Network.Wai
 import Network.Wai.Predicate hiding (Error, or, result, setStatus)
 import Network.Wai.Utilities hiding (Error)
@@ -497,20 +496,21 @@ outputToStreamingBody action = withWeavingToFinal @IO $ \state weave _inspect ->
           flush
     void . weave . (<$ state) $ runOutputSem writeChunk action
 
-getTeamMembersCSVH ::
+getTeamMembersCSV ::
   (Members '[BrigAccess, ErrorS 'AccessDenied, TeamMemberStore InternalPaging, TeamStore, Final IO] r) =>
-  UserId ::: TeamId ::: JSON ->
-  Sem r Response
-getTeamMembersCSVH (zusr ::: tid ::: _) = do
-  E.getTeamMember tid zusr >>= \case
+  Local UserId ->
+  TeamId ->
+  Sem r StreamingBody
+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.
-  body <- outputToStreamingBody $ do
+  outputToStreamingBody $ do
     output headerLine
     E.withChunks (\mps -> E.listTeamMembers @InternalPaging tid mps maxBound) $
       \members -> do
@@ -525,13 +525,6 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do
               defaultEncodeOptions
               (mapMaybe (teamExportUser users inviters richInfos numUserClients) members)
           )
-  pure $
-    responseStream
-      status200
-      [ (hContentType, "text/csv"),
-        ("Content-Disposition", "attachment; filename=\"wire_team_members.csv\"")
-      ]
-      body
   where
     headerLine :: LByteString
     headerLine = encodeDefaultOrderedByNameWith (defaultEncodeOptions {encIncludeHeader = True}) ([] :: [TeamExportUser])