[WPB-5810] Fix the service provider endpoints that return no body (#3766

)

* Fix accept header issue when resp. body is empty

* Add a changelog

* Tests: provider and service endpoints

* Test: update a service name

* Test: A provider creation helper

changelog.d/3-bug-fixes/WPB-5810

@@ -0,0 +1 @@
+Do not match on the `Accept` header for service provider endpoints with no response body

integration/integration.cabal

@@ -123,6 +123,7 @@ library
     Test.Presence
     Test.Roles
     Test.Search
+    Test.Services
     Test.User
     Testlib.App
     Testlib.Assertions

integration/test/API/Brig.hs

@@ -3,9 +3,12 @@ module API.Brig where
 import API.Common
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Base64 qualified as Base64
+import Data.CaseInsensitive qualified as CI
 import Data.Foldable
 import Data.Function
+import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
+import Data.Vector qualified as V
 import GHC.Stack
 import Testlib.Prelude
 
@@ -19,6 +22,80 @@ data AddUser = AddUser
 instance Default AddUser where
   def = AddUser Nothing Nothing Nothing Nothing
 
+data NewProvider = NewProvider
+  { newProviderName :: String,
+    newProviderDesc :: String,
+    newProviderEmail :: String,
+    newProviderPassword :: Maybe String,
+    newProviderUrl :: String
+  }
+
+instance Default NewProvider where
+  def =
+    NewProvider
+      "New Provider"
+      "Just a provider"
+      "provider@example.com"
+      Nothing
+      "https://example.com"
+
+instance ToJSON NewProvider where
+  toJSON NewProvider {..} =
+    Aeson.object
+      [ "name" .= newProviderName,
+        "description" .= newProviderDesc,
+        "email" .= newProviderEmail,
+        "password" .= newProviderPassword,
+        "url" .= newProviderUrl
+      ]
+
+data NewService = NewService
+  { newServiceName :: String,
+    newServiceSummary :: String,
+    newServiceDescr :: String,
+    newServiceUrl :: String,
+    newServiceKey :: ByteString,
+    newServiceToken :: Maybe String,
+    newServiceAssets :: [String],
+    newServiceTags :: [String]
+  }
+
+instance Default NewService where
+  def =
+    NewService
+      "New Service"
+      "Just a service"
+      "Just a service description"
+      "https://example.com"
+      ( T.encodeUtf8 . T.unlines . fmap T.pack $
+          [ "-----BEGIN PUBLIC KEY-----",
+            "MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKCAQEAu+Kg/PHHU3atXrUbKnw0",
+            "G06FliXcNt3lMwl2os5twEDcPPFw/feGiAKymxp+7JqZDrseS5D9THGrW+OQRIPH",
+            "WvUBdiLfGrZqJO223DB6D8K2Su/odmnjZJ2z23rhXoEArTplu+Dg9K+c2LVeXTKV",
+            "VPOaOzgtAB21XKRiQ4ermqgi3/njr03rXyq/qNkuNd6tNcg+HAfGxfGvvCSYBfiS",
+            "bUKr/BeArYRcjzr/h5m1In6fG/if9GEI6m8dxHT9JbY53wiksowy6ajCuqskIFg8",
+            "7X883H+LA/d6X5CTiPv1VMxXdBUiGPuC9IT/6CNQ1/LFt0P37ax58+LGYlaFo7la",
+            "nQIDAQAB",
+            "-----END PUBLIC KEY-----"
+          ]
+      )
+      (Just "secret-token")
+      []
+      ["music", "quiz", "weather"]
+
+instance ToJSON NewService where
+  toJSON NewService {..} =
+    Aeson.object
+      [ "name" .= newServiceName,
+        "summary" .= newServiceSummary,
+        "description" .= newServiceDescr,
+        "base_url" .= newServiceUrl,
+        "public_key" .= (T.unpack . T.decodeUtf8) newServiceKey,
+        "auth_token" .= newServiceToken,
+        "assets" .= Aeson.Array (V.fromList (Aeson.String . T.pack <$> newServiceAssets)),
+        "tags" .= Aeson.Array (V.fromList (Aeson.String . T.pack <$> newServiceTags))
+      ]
+
 addUser :: (HasCallStack, MakesValue dom) => dom -> AddUser -> App Response
 addUser dom opts = do
   req <- baseRequest dom Brig Versioned "register"
@@ -409,3 +486,105 @@ getSwaggerInternalJson service = do
     rawBaseRequest OwnDomain Nginz Unversioned $
       joinHttpPath ["api-internal", "swagger-ui", service <> "-swagger.json"]
   submit "GET" req
+
+newProvider ::
+  ( HasCallStack,
+    MakesValue provider,
+    MakesValue user
+  ) =>
+  user ->
+  provider ->
+  App Value
+newProvider user provider = do
+  p <- make provider
+  req <-
+    baseRequest user Brig Versioned $
+      joinHttpPath ["provider", "register"]
+  submit "POST" (addJSON p req) `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 201
+    resp.json
+
+activateProvider ::
+  ( HasCallStack,
+    MakesValue dom
+  ) =>
+  dom ->
+  String ->
+  String ->
+  App ()
+activateProvider dom key code = do
+  d <- make dom
+  req <-
+    rawBaseRequest d Brig Versioned $
+      joinHttpPath ["provider", "activate"]
+  let ps = [("key", key), ("code", code)]
+  submit "GET" (addQueryParams ps req) `bindResponse` \resp -> do
+    resp.status `shouldMatchOneOf` [Number 200, Number 204]
+
+-- | Returns the value of the Set-Cookie header that is to be used to
+-- authenticate to provider endpoints.
+loginProvider ::
+  ( HasCallStack,
+    MakesValue dom
+  ) =>
+  dom ->
+  String ->
+  String ->
+  App ByteString
+loginProvider dom email pass = do
+  d <- asString dom
+  req <-
+    rawBaseRequest d Brig Versioned $
+      joinHttpPath ["provider", "login"]
+  submit "POST" (addJSONObject ["email" .= email, "password" .= pass] req) `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 200
+    let hs = headers resp
+        setCookieHeader = CI.mk (T.encodeUtf8 . T.pack $ "Set-Cookie")
+    pure . fromJust . foldMap (\(k, v) -> guard (k == setCookieHeader) $> v) $ hs
+
+newService ::
+  ( HasCallStack,
+    MakesValue dom
+  ) =>
+  dom ->
+  String ->
+  NewService ->
+  App Value
+newService dom providerId service = do
+  s <- make service
+  domain <- asString dom
+  req <-
+    rawBaseRequest domain Brig Versioned $
+      joinHttpPath ["provider", "services"]
+  let addHdrs =
+        addHeader "Z-Type" "provider"
+          . addHeader "Z-Provider" providerId
+  submit "POST" (addJSON s . addHdrs $ req) `bindResponse` \resp -> do
+    resp.status `shouldMatchInt` 201
+    resp.json
+
+updateService ::
+  ( HasCallStack,
+    MakesValue dom,
+    MakesValue serviceId
+  ) =>
+  dom ->
+  String ->
+  serviceId ->
+  Maybe String ->
+  Maybe String ->
+  App Response
+updateService dom providerId serviceId mAcceptHeader newName = do
+  sId <- asString serviceId
+  domain <- asString dom
+  req <-
+    rawBaseRequest domain Brig Versioned $
+      joinHttpPath ["provider", "services", sId]
+  let addHdrs =
+        addHeader "Z-Type" "provider"
+          . addHeader "Z-Provider" providerId
+          . maybe id (addHeader "Accept") mAcceptHeader
+  submit "PUT"
+    . addHdrs
+    . addJSONObject ["name" .= n | n <- maybeToList newName]
+    $ req

integration/test/API/BrigInternal.hs

@@ -205,3 +205,15 @@ getConnStatusInternal body dom = do
     joinHttpPath ["i", "users", "connections-status", "v2"]
   submit "POST" do
     req & addJSONObject body
+
+getProviderActivationCodeInternal ::
+  (HasCallStack, MakesValue dom) =>
+  dom ->
+  String ->
+  App Response
+getProviderActivationCodeInternal dom email = do
+  d <- make dom
+  req <-
+    rawBaseRequest d Brig Unversioned $
+      joinHttpPath ["i", "provider", "activation-code"]
+  submit "GET" (addQueryParams [("email", email)] req)

integration/test/SetupHelpers.hs

@@ -245,3 +245,27 @@ getOne2OneConversation user1 user2 cnvState = do
         qIds <- for others (%. "qualified_id")
         pure $ qIds == users && t
   head <$> filterM (isWith [user2]) l
+
+-- | Create a provider, get an activation code, activate the provider and log it
+-- in. The return value is the created provider.
+setupProvider ::
+  ( HasCallStack,
+    MakesValue user
+  ) =>
+  user ->
+  NewProvider ->
+  App Value
+setupProvider u np@(NewProvider {..}) = do
+  dom <- objDomain u
+  provider <- newProvider u np
+  pass <- provider %. "password" & asString
+  (key, code) <- do
+    pair <-
+      getProviderActivationCodeInternal dom newProviderEmail `bindResponse` \resp -> do
+        resp.status `shouldMatchInt` 200
+        resp.json
+    k <- pair %. "key" & asString
+    c <- pair %. "code" & asString
+    pure (k, c)
+  activateProvider dom key code
+  loginProvider dom newProviderEmail pass $> provider

integration/test/Test/Services.hs

@@ -0,0 +1,42 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2023 Wire Swiss GmbH <opensource@wire.com>
+--
+-- 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 Test.Services where
+
+import API.Brig
+import API.Common
+import SetupHelpers
+import Testlib.Prelude
+
+testUpdateServiceUpdateAcceptHeader :: HasCallStack => App ()
+testUpdateServiceUpdateAcceptHeader = do
+  let dom = OwnDomain
+  email <- randomEmail
+  alice <- randomUser dom def
+  provider <- setupProvider alice def {newProviderEmail = email}
+  pId <- provider %. "id" & asString
+  service <- newService dom pId def
+  sId <- service %. "id"
+  void $
+    updateService dom pId sId (Just "application/json") (Just "brand new service")
+      >>= getBody 200
+  void $
+    updateService dom pId sId (Just "text/plain") (Just "even newer service")
+      >>= getBody 200
+  void $
+    updateService dom pId sId Nothing (Just "really old service")
+      >>= getBody 200

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

@@ -73,7 +73,7 @@ type ServicesAPI =
                :> "services"
                :> Capture "service-id" ServiceId
                :> ReqBody '[JSON] Public.UpdateService
-               :> Put '[PlainText] NoContent
+               :> MultiVerb1 'PUT '[PlainText, JSON] (RespondEmpty 200 "Provider service updated")
            )
     :<|> Named
            "put-provider-services-connection-by-service-id"
@@ -88,7 +88,7 @@ type ServicesAPI =
                :> Capture "service-id" ServiceId
                :> "connection"
                :> ReqBody '[JSON] Public.UpdateServiceConn
-               :> Put '[PlainText] NoContent
+               :> MultiVerb1 'PUT '[PlainText, JSON] (RespondEmpty 200 "Provider service connection updated")
            )
     :<|> Named
            "delete-provider-services-by-service-id"

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

@@ -92,7 +92,7 @@ import OpenSSL.PEM qualified as SSL
 import OpenSSL.RSA qualified as SSL
 import OpenSSL.Random (randBytes)
 import Polysemy
-import Servant (NoContent (..), ServerT, (:<|>) (..))
+import Servant (ServerT, (:<|>) (..))
 import Ssl.Util qualified as SSL
 import System.Logger.Class (MonadLogger)
 import UnliftIO.Async (pooledMapConcurrentlyN_)
@@ -392,7 +392,7 @@ updateService ::
   ProviderId ->
   ServiceId ->
   Public.UpdateService ->
-  (Handler r) NoContent
+  Handler r ()
 updateService pid sid upd = do
   guardSecondFactorDisabled Nothing
   _ <- wrapClientE (DB.lookupAccount pid) >>= maybeInvalidProvider
@@ -420,14 +420,13 @@ updateService pid sid upd = do
       newAssets
       tagsChange
       (serviceEnabled svc)
-      $> NoContent
 
 updateServiceConn ::
   Member GalleyProvider r =>
   ProviderId ->
   ServiceId ->
   Public.UpdateServiceConn ->
-  (Handler r) NoContent
+  Handler r ()
 updateServiceConn pid sid upd = do
   guardSecondFactorDisabled Nothing
   pass <- wrapClientE (DB.lookupPassword pid) >>= maybeBadCredentials
@@ -461,7 +460,6 @@ updateServiceConn pid sid upd = do
         if sconEnabled scon
           then DB.deleteServiceIndexes pid sid name tags
           else DB.insertServiceIndexes pid sid name tags
-  pure NoContent
 
 -- TODO: Send informational email to provider.