feat: MakesFederatedCall servant combinator

libs/wire-api-federation/src/Wire/API/Federation/API.hs

@@ -20,7 +20,7 @@ module Wire.API.Federation.API
     HasFedEndpoint,
     fedClient,
     fedClientIn,
-    CallsFed,
+    module Wire.API.MakesFederatedCall,
 
     -- * Re-exports
     Component (..),
@@ -36,7 +36,7 @@ import Wire.API.Federation.API.Brig
 import Wire.API.Federation.API.Cargohold
 import Wire.API.Federation.API.Galley
 import Wire.API.Federation.Client
-import Wire.API.Federation.Component
+import Wire.API.MakesFederatedCall
 import Wire.API.Routes.Named
 
 -- Note: this type family being injective means that in most cases there is no need
@@ -51,8 +51,6 @@ type instance FedApi 'Cargohold = CargoholdApi
 
 type HasFedEndpoint comp api name = ('Just api ~ LookupEndpoint (FedApi comp) name, CallsFed comp name)
 
-class CallsFed (comp :: Component) (name :: Symbol)
-
 -- | Return a client for a named endpoint.
 fedClient ::
   forall (comp :: Component) (name :: Symbol) m api.

libs/wire-api-federation/src/Wire/API/Federation/Component.hs

@@ -15,18 +15,14 @@
 -- 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.Federation.Component where
+module Wire.API.Federation.Component
+  ( module Wire.API.Federation.Component,
+    Component (..),
+  )
+where
 
 import Imports
-import Test.QuickCheck (Arbitrary)
-import Wire.Arbitrary (GenericUniform (..))
-
-data Component
-  = Brig
-  | Galley
-  | Cargohold
-  deriving (Show, Eq, Generic)
-  deriving (Arbitrary) via (GenericUniform Component)
+import Wire.API.MakesFederatedCall (Component (..))
 
 parseComponent :: Text -> Maybe Component
 parseComponent "brig" = Just Brig

libs/wire-api/src/Wire/API/MakesFederatedCall.hs

@@ -0,0 +1,126 @@
+-- This file is part of the Wire Server implementation.
+--
+-- Copyright (C) 2022 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/>.
+{-# LANGUAGE OverloadedLists #-}
+
+module Wire.API.MakesFederatedCall
+  ( CallsFed,
+    MakesFederatedCall,
+    Component (..),
+    callsFed,
+  )
+where
+
+import Data.Aeson (Value (..))
+import Data.Constraint
+import Data.Metrics.Servant
+import Data.Proxy
+import Data.Swagger.Operation (addExtensions)
+import qualified Data.Text as T
+import GHC.TypeLits
+import Imports
+import Servant.API
+import Servant.Client
+import Servant.Server
+import Servant.Swagger
+import Test.QuickCheck (Arbitrary)
+import Unsafe.Coerce (unsafeCoerce)
+import Wire.Arbitrary (GenericUniform (..))
+
+data Component
+  = Brig
+  | Galley
+  | Cargohold
+  deriving (Show, Eq, Generic)
+  deriving (Arbitrary) via (GenericUniform Component)
+
+-- | A typeclass corresponding to calls to federated services. This class has
+-- no methods, and exists only to automatically propagate information up to
+-- servant.
+--
+-- The only way to discharge this constraint is via 'callsFed', which should be
+-- invoked for each federated call when connecting handlers to the server
+-- definition.
+class CallsFed (comp :: Component) (name :: Symbol)
+
+-- | A typeclass with the same layout as 'CallsFed', which exists only so we
+-- can discharge 'CallsFeds' constraints by unsafely coercing this one.
+class Nullary
+
+instance Nullary
+
+-- | Construct a dictionary for 'CallsFed'.
+synthesizeCallsFed :: forall (comp :: Component) (name :: Symbol). Dict (CallsFed comp name)
+synthesizeCallsFed = unsafeCoerce $ Dict @Nullary
+
+-- | Servant combinator for tracking calls to federated calls. Annotating API
+-- endpoints with 'MakesFederatedCall' is the only way to eliminate 'CallsFed'
+-- constraints on handlers.
+data MakesFederatedCall (comp :: Component) (name :: Symbol)
+
+instance (HasServer api ctx) => HasServer (MakesFederatedCall comp name :> api :: *) ctx where
+  -- \| This should have type @CallsFed comp name => ServerT api m@, but GHC
+  -- complains loudly thinking this is a polytype. We need to introduce the
+  -- 'CallsFed' constraint so that we can eliminate it via
+  -- 'synthesizeCallsFed', which otherwise is too-high rank for GHC to notice
+  -- we've solved our constraint.
+  type ServerT (MakesFederatedCall comp name :> api) m = Dict (CallsFed comp name) -> ServerT api m
+  route _ ctx f = route (Proxy @api) ctx $ fmap ($ synthesizeCallsFed @comp @name) f
+  hoistServerWithContext _ ctx f s = hoistServerWithContext (Proxy @api) ctx f . s
+
+instance HasLink api => HasLink (MakesFederatedCall comp name :> api :: *) where
+  type MkLink (MakesFederatedCall comp name :> api) x = MkLink api x
+  toLink f _ l = toLink f (Proxy @api) l
+
+instance RoutesToPaths api => RoutesToPaths (MakesFederatedCall comp name :> api :: *) where
+  getRoutes = getRoutes @api
+
+-- | Get a symbol representation of our component.
+type family ShowComponent (x :: Component) :: Symbol where
+  ShowComponent 'Brig = "brig"
+  ShowComponent 'Galley = "galley"
+  ShowComponent 'Cargohold = "cargohold"
+
+-- | 'MakesFederatedCall' annotates the swagger documentation with an extension
+-- tag @x-wire-makes-federated-calls-to@.
+instance (HasSwagger api, KnownSymbol name, KnownSymbol (ShowComponent comp)) => HasSwagger (MakesFederatedCall comp name :> api :: *) where
+  toSwagger _ =
+    toSwagger (Proxy @api)
+      & addExtensions
+        mergeJSONArray
+        [ ( "wire-makes-federated-call-to",
+            Array
+              [ Array
+                  [ String $ T.pack $ symbolVal $ Proxy @(ShowComponent comp),
+                    String $ T.pack $ symbolVal $ Proxy @name
+                  ]
+              ]
+          )
+        ]
+
+mergeJSONArray :: Value -> Value -> Value
+mergeJSONArray (Array x) (Array y) = Array $ x <> y
+mergeJSONArray _ _ = error "impossible! bug in construction of federated calls JSON"
+
+instance HasClient m api => HasClient m (MakesFederatedCall comp name :> api :: *) where
+  type Client m (MakesFederatedCall comp name :> api) = Client m api
+  clientWithRoute p _ = clientWithRoute p $ Proxy @api
+  hoistClientMonad p _ f c = hoistClientMonad p (Proxy @api) f c
+
+-- | Safely discharge a 'CallsFed' constraint. Intended to be used when
+-- connecting your handler to the server router.
+callsFed :: (c => r) -> Dict c -> r
+callsFed f Dict = f

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

@@ -54,6 +54,7 @@ import Wire.API.Error
 import Wire.API.Error.Brig
 import Wire.API.MLS.Credential
 import Wire.API.MLS.KeyPackage
+import Wire.API.MakesFederatedCall
 import Wire.API.Routes.Internal.Brig.Connection
 import Wire.API.Routes.Internal.Brig.EJPD
 import qualified Wire.API.Routes.Internal.Galley.TeamFeatureNoConfigMulti as Multi
@@ -366,12 +367,14 @@ type AuthAPI =
   Named
     "legalhold-login"
     ( "legalhold-login"
+        :> MakesFederatedCall 'Brig "on-user-deleted-connections"
         :> ReqBody '[JSON] LegalHoldLogin
         :> MultiVerb1 'POST '[JSON] TokenResponse
     )
     :<|> Named
            "sso-login"
            ( "sso-login"
+               :> MakesFederatedCall 'Brig "on-user-deleted-connections"
                :> ReqBody '[JSON] SsoLogin
                :> QueryParam' [Optional, Strict] "persist" Bool
                :> MultiVerb1 'POST '[JSON] TokenResponse

libs/wire-api/wire-api.cabal

@@ -39,6 +39,7 @@ library
     Wire.API.Event.Team
     Wire.API.Internal.BulkPush
     Wire.API.Internal.Notification
+    Wire.API.MakesFederatedCall
     Wire.API.Message
     Wire.API.Message.Proto
     Wire.API.MLS.CipherSuite

nix/haskell-pins.nix

@@ -172,6 +172,13 @@ let
         sha256 = "1w23yz2iiayniymk7k4g8gww7268187cayw0c8m3bz2hbnvbyfbc";
       };
     };
+    swagger2 = {
+      src = fetchgit {
+        url = "https://github.com/wireapp/swagger2";
+        rev = "ba916df2775bb38ec603b726bbebfb65a908317a";
+        sha256 = "sha256-IcsrJ5ur8Zm7Xp1PQBOb+2N7T8WMI8jJ6YuDv8ypsPQ=";
+      };
+    };
     cql-io = {
       src = fetchgit {
         url = "https://gitlab.com/axeman/cql-io";

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

@@ -175,10 +175,10 @@ userAPI =
     :<|> deleteLocale
     :<|> getDefaultUserLocale
 
-authAPI :: (Member GalleyProvider r, CallsFed 'Brig "on-user-deleted-connections") => ServerT BrigIRoutes.AuthAPI (Handler r)
+authAPI :: (Member GalleyProvider r) => ServerT BrigIRoutes.AuthAPI (Handler r)
 authAPI =
-  Named @"legalhold-login" legalHoldLogin
-    :<|> Named @"sso-login" ssoLogin
+  Named @"legalhold-login" (callsFed legalHoldLogin)
+    :<|> Named @"sso-login" (callsFed ssoLogin)
     :<|> Named @"login-code" getLoginCode
     :<|> Named @"reauthenticate" reauthenticate