Automatic tracking of CallsFed constraints

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

@@ -52,17 +52,23 @@ type instance FedApi 'Brig = BrigApi
 
 type instance FedApi 'Cargohold = CargoholdApi
 
-type HasFedEndpoint comp api name = (HasUnsafeFedEndpoint comp api name, CallsFed comp name)
+type HasFedEndpoint comp api name = (HasUnsafeFedEndpoint comp api name)
 
 -- | Like 'HasFedEndpoint', but doesn't propagate a 'CallsFed' constraint.
 -- Useful for tests, but unsafe in the sense that incorrect usage will allow
 -- you to forget about some federated calls.
 type HasUnsafeFedEndpoint comp api name = 'Just api ~ LookupEndpoint (FedApi comp) name
 
 -- | Return a client for a named endpoint.
+--
+-- This function introduces an 'AddAnnotation' constraint, which is
+-- automatically solved by the @transitive-anns@ plugin, and pushes the
+-- resulting information around in a side-channel. See the documentation at
+-- 'Wire.API.MakesFederatedCall.exposeAnnotations' for a better understanding
+-- of the information flow here.
 fedClient ::
-  forall (comp :: Component) (name :: Symbol) m api.
-  (CallsFed comp name, HasFedEndpoint comp api name, HasClient m api, m ~ FederatorClient comp) =>
+  forall (comp :: Component) (name :: Symbol) m api x.
+  (AddAnnotation 'Remote (ShowComponent comp) name x, HasFedEndpoint comp api name, HasClient m api, m ~ FederatorClient comp) =>
   Client m api
 fedClient = clientIn (Proxy @api) (Proxy @m)
 
@@ -72,7 +78,7 @@ fedClientIn ::
   Client m api
 fedClientIn = clientIn (Proxy @api) (Proxy @m)
 
--- | Like 'fedClientIn', but doesn't propagate a 'CallsFed' constraint. Inteded
+-- | Like 'fedClientIn', but doesn't propagate a 'CallsFed' constraint. Intended
 -- to be used in test situations only.
 unsafeFedClientIn ::
   forall (comp :: Component) (name :: Symbol) m api.

libs/wire-api/default.nix

@@ -92,6 +92,7 @@
 , tasty-quickcheck
 , text
 , time
+, transitive-anns
 , types-common
 , unliftio
 , unordered-containers
@@ -188,6 +189,7 @@ mkDerivation {
     tagged
     text
     time
+    transitive-anns
     types-common
     unordered-containers
     uri-bytestring

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

@@ -22,9 +22,15 @@ module Wire.API.MakesFederatedCall
     Component (..),
     callsFed,
     unsafeCallsFed,
+    AddAnnotation,
+    Location(..),
+    ShowComponent,
+    Annotation,
+    exposeAnnotations
   )
 where
 
+import TransitiveAnns.Types
 import Data.Aeson (Value (..))
 import Data.Constraint
 import Data.Kind
@@ -42,6 +48,29 @@ import Test.QuickCheck (Arbitrary)
 import Unsafe.Coerce (unsafeCoerce)
 import Wire.Arbitrary (GenericUniform (..))
 
+-- | This function exists only to provide a convenient place for the
+-- @transitive-anns@ plugin to solve the 'ToHasAnnotations' constraint. This is
+-- highly magical and warrants a note.
+--
+-- The call @'exposeAnnotations' (some expr here)@ will expand to @some expr
+-- here@, additionally generating wanted 'HasAnnotation' constraints for every
+-- 'AddAnnotation' constraint in the _transitive call closure_ of @some expr
+-- here@.
+--
+-- The use case is always going to be @'callsFed' ('exposeAnnotations' expr)@,
+-- where 'exposeAnnotations' re-introduces all of the constraints we've been
+-- squirreling away, and 'callsFed' is responsible for discharging them. It
+-- would be very desirable to combine these into one call, but the semantics of
+-- solving 'ToHasAnnotations' attaches the wanted calls to the same place as
+-- the call itself, which means the wanteds appear just after our opportunity
+-- to solve them via 'callsFed'. This is likely not a hard limitation.
+--
+-- The @x@ parameter here is intentionally ambiguous, existing as a unique
+-- skolem to prevent GHC from caching the results of solving
+-- 'ToHasAnnotations'. Callers needn't worry about it.
+exposeAnnotations :: ToHasAnnotations x => a -> a
+exposeAnnotations = id
+
 data Component
   = Brig
   | Galley
@@ -56,7 +85,7 @@ data Component
 -- 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)
+type CallsFed (comp :: Component) = HasAnnotation 'Remote (ShowComponent comp)
 
 -- | A typeclass with the same layout as 'CallsFed', which exists only so we
 -- can discharge 'CallsFeds' constraints by unsafely coercing this one.
@@ -127,6 +156,10 @@ instance HasClient m api => HasClient m (MakesFederatedCall comp name :> api ::
 class SolveCallsFed c r a where
   -- | Safely discharge a 'CallsFed' constraint. Intended to be used when
   -- connecting your handler to the server router.
+  --
+  -- This function should always be called with an argument of
+  -- 'exposeAnnotations'. See the documentation there for more information on
+  -- why.
   callsFed :: (c => r) -> a
 
 instance (c ~ ((k, d) :: Constraint), SolveCallsFed d r a) => SolveCallsFed c r (Dict k -> a) where

libs/wire-api/wire-api.cabal

@@ -276,6 +276,7 @@ library
     , tagged
     , text                       >=0.11
     , time                       >=1.4
+    , transitive-anns
     , types-common               >=0.16
     , unordered-containers       >=0.2
     , uri-bytestring             >=0.2

nix/haskell-pins.nix

@@ -57,6 +57,13 @@
 { lib, fetchgit }: hself: hsuper:
 let
   gitPins = {
+    transitive-anns = {
+      src = fetchgit {
+        url = "https://github.com/isovector/transitive-anns";
+        rev = "22f1b2b48b1d4422f32fd204a8b3454b03852ce3";
+        sha256 = "sha256-V5kfYsmaExeJVoQ7BChsXmW8gaDmt6gh2Wu7CH0IcZo=";
+      };
+    };
     HaskellNet-SSL = {
       src = fetchgit {
         url = "https://github.com/dpwright/HaskellNet-SSL";

services/brig/brig.cabal

@@ -179,6 +179,7 @@ library
     -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
     -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
     -funbox-strict-fields -fplugin=Polysemy.Plugin
+    -fplugin=TransitiveAnns.Plugin
 
   build-depends:
       aeson                      >=2.0.1.0
@@ -292,6 +293,7 @@ library
     , time-units
     , tinylog                    >=0.10
     , transformers               >=0.3
+    , transitive-anns
     , types-common               >=0.16
     , types-common-aws
     , types-common-journal       >=0.1

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

@@ -43,15 +43,13 @@ import Network.HTTP.Types
 import Network.Wai.Utilities ((!>>))
 import qualified Network.Wai.Utilities.Error as Wai
 import Polysemy
-import Wire.API.Federation.API
 import Wire.API.User
 import Wire.API.User.Auth hiding (access)
 import Wire.API.User.Auth.LegalHold
 import Wire.API.User.Auth.ReAuth
 import Wire.API.User.Auth.Sso
 
 accessH ::
-  CallsFed 'Brig "on-user-deleted-connections" =>
   Maybe ClientId ->
   [Either Text SomeUserToken] ->
   Maybe (Either Text SomeAccessToken) ->
@@ -63,7 +61,7 @@ accessH mcid ut' mat' = do
     >>= either (uncurry (access mcid)) (uncurry (access mcid))
 
 access ::
-  (TokenPair u a, CallsFed 'Brig "on-user-deleted-connections") =>
+  (TokenPair u a) =>
   Maybe ClientId ->
   NonEmpty (Token u) ->
   Maybe (Token a) ->
@@ -78,7 +76,7 @@ sendLoginCode (SendLoginCode phone call force) = do
   c <- wrapClientE (Auth.sendLoginCode phone call force) !>> sendLoginCodeError
   pure $ LoginCodeTimeout (pendingLoginTimeout c)
 
-login :: (Member GalleyProvider r, CallsFed 'Brig "on-user-deleted-connections") => Login -> Maybe Bool -> Handler r SomeAccess
+login :: (Member GalleyProvider r) => Login -> Maybe Bool -> Handler r SomeAccess
 login l (fromMaybe False -> persist) = do
   let typ = if persist then PersistentCookie else SessionCookie
   c <- Auth.login l typ !>> loginError
@@ -130,13 +128,13 @@ removeCookies :: Local UserId -> RemoveCookies -> Handler r ()
 removeCookies lusr (RemoveCookies pw lls ids) =
   wrapClientE (Auth.revokeAccess (tUnqualified lusr) pw ids lls) !>> authError
 
-legalHoldLogin :: (Member GalleyProvider r, CallsFed 'Brig "on-user-deleted-connections") => LegalHoldLogin -> Handler r SomeAccess
+legalHoldLogin :: (Member GalleyProvider r) => LegalHoldLogin -> Handler r SomeAccess
 legalHoldLogin lhl = do
   let typ = PersistentCookie -- Session cookie isn't a supported use case here
   c <- Auth.legalHoldLogin lhl typ !>> legalHoldLoginError
   traverse mkUserTokenCookie c
 
-ssoLogin :: CallsFed 'Brig "on-user-deleted-connections" => SsoLogin -> Maybe Bool -> Handler r SomeAccess
+ssoLogin :: SsoLogin -> Maybe Bool -> Handler r SomeAccess
 ssoLogin l (fromMaybe False -> persist) = do
   let typ = if persist then PersistentCookie else SessionCookie
   c <- wrapHttpClientE (Auth.ssoLogin l typ) !>> loginError

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

@@ -93,7 +93,6 @@ import Polysemy (Member, Members)
 import Servant (Link, ToHttpApiData (toUrlPiece))
 import System.Logger.Class (field, msg, val, (~~))
 import qualified System.Logger.Class as Log
-import Wire.API.Federation.API
 import Wire.API.Federation.API.Brig (GetUserClients (GetUserClients))
 import Wire.API.Federation.Error
 import Wire.API.MLS.Credential (ClientIdentity (..))
@@ -116,12 +115,12 @@ lookupLocalClient uid = wrapClient . Data.lookupClient uid
 lookupLocalClients :: UserId -> (AppT r) [Client]
 lookupLocalClients = wrapClient . Data.lookupClients
 
-lookupPubClient :: CallsFed 'Brig "get-user-clients" => Qualified UserId -> ClientId -> ExceptT ClientError (AppT r) (Maybe PubClient)
+lookupPubClient :: Qualified UserId -> ClientId -> ExceptT ClientError (AppT r) (Maybe PubClient)
 lookupPubClient qid cid = do
   clients <- lookupPubClients qid
   pure $ find ((== cid) . pubClientId) clients
 
-lookupPubClients :: CallsFed 'Brig "get-user-clients" => Qualified UserId -> ExceptT ClientError (AppT r) [PubClient]
+lookupPubClients :: Qualified UserId -> ExceptT ClientError (AppT r) [PubClient]
 lookupPubClients qid@(Qualified uid domain) = do
   getForUser <$> lookupPubClientsBulk [qid]
   where
@@ -130,7 +129,7 @@ lookupPubClients qid@(Qualified uid domain) = do
       um <- userMap <$> Map.lookup domain (qualifiedUserMap qmap)
       Set.toList <$> Map.lookup uid um
 
-lookupPubClientsBulk :: CallsFed 'Brig "get-user-clients" => [Qualified UserId] -> ExceptT ClientError (AppT r) (QualifiedUserMap (Set PubClient))
+lookupPubClientsBulk :: [Qualified UserId] -> ExceptT ClientError (AppT r) (QualifiedUserMap (Set PubClient))
 lookupPubClientsBulk qualifiedUids = do
   loc <- qualifyLocal ()
   let (localUsers, remoteUsers) = partitionQualified loc qualifiedUids
@@ -146,7 +145,7 @@ lookupLocalPubClientsBulk :: [UserId] -> ExceptT ClientError (AppT r) (UserMap (
 lookupLocalPubClientsBulk = lift . wrapClient . Data.lookupPubClientsBulk
 
 addClient ::
-  (Members '[GalleyProvider] r, CallsFed 'Brig "on-user-deleted-connections") =>
+  (Members '[GalleyProvider] r) =>
   UserId ->
   Maybe ConnId ->
   Maybe IP ->
@@ -158,7 +157,7 @@ addClient = addClientWithReAuthPolicy Data.reAuthForNewClients
 -- a superset of the clients known to galley.
 addClientWithReAuthPolicy ::
   forall r.
-  (Members '[GalleyProvider] r, CallsFed 'Brig "on-user-deleted-connections") =>
+  (Members '[GalleyProvider] r) =>
   Data.ReAuthPolicy ->
   UserId ->
   Maybe ConnId ->
@@ -239,7 +238,6 @@ rmClient u con clt pw =
       lift $ execDelete u (Just con) client
 
 claimPrekey ::
-  CallsFed 'Brig "claim-prekey" =>
   LegalholdProtectee ->
   UserId ->
   Domain ->
@@ -266,15 +264,14 @@ claimLocalPrekey protectee user client = do
 claimRemotePrekey ::
   ( MonadReader Env m,
     Log.MonadLogger m,
-    MonadClient m,
-    CallsFed 'Brig "claim-prekey"
+    MonadClient m
   ) =>
   Qualified UserId ->
   ClientId ->
   ExceptT ClientError m (Maybe ClientPrekey)
 claimRemotePrekey quser client = fmapLT ClientFederationError $ Federation.claimPrekey quser client
 
-claimPrekeyBundle :: CallsFed 'Brig "claim-prekey-bundle" => LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError (AppT r) PrekeyBundle
+claimPrekeyBundle :: LegalholdProtectee -> Domain -> UserId -> ExceptT ClientError (AppT r) PrekeyBundle
 claimPrekeyBundle protectee domain uid = do
   isLocalDomain <- (domain ==) <$> viewFederationDomain
   if isLocalDomain
@@ -287,13 +284,13 @@ claimLocalPrekeyBundle protectee u = do
   guardLegalhold protectee (mkUserClients [(u, clients)])
   PrekeyBundle u . catMaybes <$> lift (mapM (wrapHttp . Data.claimPrekey u) clients)
 
-claimRemotePrekeyBundle :: CallsFed 'Brig "claim-prekey-bundle" => Qualified UserId -> ExceptT ClientError (AppT r) PrekeyBundle
+claimRemotePrekeyBundle :: Qualified UserId -> ExceptT ClientError (AppT r) PrekeyBundle
 claimRemotePrekeyBundle quser = do
   Federation.claimPrekeyBundle quser !>> ClientFederationError
 
 claimMultiPrekeyBundles ::
   forall r.
-  (Members '[Concurrency 'Unsafe] r, CallsFed 'Brig "claim-multi-prekey-bundle") =>
+  (Members '[Concurrency 'Unsafe] r) =>
   LegalholdProtectee ->
   QualifiedUserClients ->
   ExceptT ClientError (AppT r) QualifiedUserClientPrekeyMap
@@ -413,7 +410,7 @@ pubClient c =
       pubClientClass = clientClass c
     }
 
-legalHoldClientRequested :: CallsFed 'Brig "on-user-deleted-connections" => UserId -> LegalHoldClientRequest -> (AppT r) ()
+legalHoldClientRequested :: UserId -> LegalHoldClientRequest -> (AppT r) ()
 legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPrekey') =
   wrapHttpClient $ Intra.onUserEvent targetUser Nothing lhClientEvent
   where
@@ -424,7 +421,7 @@ legalHoldClientRequested targetUser (LegalHoldClientRequest _requester lastPreke
     lhClientEvent :: UserEvent
     lhClientEvent = LegalHoldClientRequested eventData
 
-removeLegalHoldClient :: CallsFed 'Brig "on-user-deleted-connections" => UserId -> (AppT r) ()
+removeLegalHoldClient :: UserId -> (AppT r) ()
 removeLegalHoldClient uid = do
   clients <- wrapClient $ Data.lookupClients uid
   -- Should only be one; but just in case we'll treat it as a list

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

@@ -60,7 +60,6 @@ import Wire.API.Connection hiding (relationWithHistory)
 import Wire.API.Conversation
 import Wire.API.Error
 import qualified Wire.API.Error.Brig as E
-import Wire.API.Federation.API
 import Wire.API.Routes.Public.Util (ResponseForExistedCreated (..))
 
 ensureIsActivated :: Local UserId -> MaybeT (AppT r) ()
@@ -76,7 +75,7 @@ ensureNotSameTeam self target = do
     throwE ConnectSameBindingTeamUsers
 
 createConnection ::
-  (Members '[GalleyProvider] r, CallsFed 'Brig "send-connection-action") =>
+  (Members '[GalleyProvider] r) =>
   Local UserId ->
   ConnId ->
   Qualified UserId ->
@@ -211,7 +210,6 @@ checkLegalholdPolicyConflict uid1 uid2 = do
   oneway status2 status1
 
 updateConnection ::
-  CallsFed 'Brig "send-connection-action" =>
   Local UserId ->
   Qualified UserId ->
   Relation ->

services/brig/src/Brig/API/Connection/Remote.hs

@@ -39,7 +39,6 @@ import Galley.Types.Conversations.Intra (Actor (..), DesiredMembership (..), Ups
 import Imports
 import Network.Wai.Utilities.Error
 import Wire.API.Connection
-import Wire.API.Federation.API
 import Wire.API.Federation.API.Brig
   ( NewConnectionResponse (..),
     RemoteConnectionAction (..),
@@ -188,7 +187,6 @@ pushEvent self mzcon connection = do
   Intra.onConnectionEvent (tUnqualified self) mzcon event
 
 performLocalAction ::
-  CallsFed 'Brig "send-connection-action" =>
   Local UserId ->
   Maybe ConnId ->
   Remote UserId ->
@@ -253,7 +251,6 @@ performRemoteAction self other mconnection action = do
     reaction _ = Nothing
 
 createConnectionToRemoteUser ::
-  CallsFed 'Brig "send-connection-action" =>
   Local UserId ->
   ConnId ->
   Remote UserId ->
@@ -263,7 +260,6 @@ createConnectionToRemoteUser self zcon other = do
   fst <$> performLocalAction self (Just zcon) other mconnection LocalConnect
 
 updateConnectionToRemoteUser ::
-  CallsFed 'Brig "send-connection-action" =>
   Local UserId ->
   Remote UserId ->
   Relation ->