Automatic tracking of CallsFed constraints

changelog.d/5-internal/pr-3083

@@ -0,0 +1 @@
+Automatically track CallsFed constraints via a GHC plugin

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

@@ -55,17 +55,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 (showcomp :: Symbol) api x.
+  (AddAnnotation 'Remote showcomp name x, showcomp ~ ShowComponent comp, HasFedEndpoint comp api name, HasClient m api, m ~ FederatorClient comp) =>
   Client m api
 fedClient = clientIn (Proxy @api) (Proxy @m)
 
@@ -75,7 +81,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

@@ -91,6 +91,7 @@
 , tasty-quickcheck
 , text
 , time
+, transitive-anns
 , types-common
 , unliftio
 , unordered-containers
@@ -186,6 +187,7 @@ mkDerivation {
     tagged
     text
     time
+    transitive-anns
     types-common
     unordered-containers
     uri-bytestring

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

@@ -15,13 +15,19 @@
 -- 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 #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 
 module Wire.API.MakesFederatedCall
   ( CallsFed,
     MakesFederatedCall,
     Component (..),
     callsFed,
     unsafeCallsFed,
+    AddAnnotation,
+    Location (..),
+    ShowComponent,
+    Annotation,
+    exposeAnnotations,
   )
 where
 
@@ -39,9 +45,33 @@ import Servant.Client
 import Servant.Server
 import Servant.Swagger
 import Test.QuickCheck (Arbitrary)
+import TransitiveAnns.Types
 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 +86,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.
@@ -91,7 +121,7 @@ instance RoutesToPaths api => RoutesToPaths (MakesFederatedCall comp name :> api
   getRoutes = getRoutes @api
 
 -- | Get a symbol representation of our component.
-type family ShowComponent (x :: Component) :: Symbol where
+type family ShowComponent (x :: Component) = (res :: Symbol) | res -> x where
   ShowComponent 'Brig = "brig"
   ShowComponent 'Galley = "galley"
   ShowComponent 'Cargohold = "cargohold"
@@ -127,6 +157,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/src/Wire/API/Routes/Public/Galley/Conversation.hs

@@ -715,6 +715,7 @@ type ConversationAPI =
            ( Summary "Update membership of the specified user (deprecated)"
                :> Description "Use `PUT /conversations/:cnv_domain/:cnv/members/:usr_domain/:usr` instead"
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> ZLocalUser
                :> ZConn
@@ -739,6 +740,7 @@ type ConversationAPI =
            ( Summary "Update membership of the specified user"
                :> Description "**Note**: at least one field has to be provided."
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> ZLocalUser
                :> ZConn
@@ -765,6 +767,7 @@ type ConversationAPI =
            ( Summary "Update conversation name (deprecated)"
                :> Description "Use `/conversations/:domain/:conv/name` instead."
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> CanThrow ('ActionDenied 'ModifyConversationName)
                :> CanThrow 'ConvNotFound
@@ -785,6 +788,7 @@ type ConversationAPI =
            ( Summary "Update conversation name (deprecated)"
                :> Description "Use `/conversations/:domain/:conv/name` instead."
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> CanThrow ('ActionDenied 'ModifyConversationName)
                :> CanThrow 'ConvNotFound
@@ -805,6 +809,7 @@ type ConversationAPI =
            "update-conversation-name"
            ( Summary "Update conversation name"
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> CanThrow ('ActionDenied 'ModifyConversationName)
                :> CanThrow 'ConvNotFound
@@ -828,6 +833,7 @@ type ConversationAPI =
            ( Summary "Update the message timer for a conversation (deprecated)"
                :> Description "Use `/conversations/:domain/:cnv/message-timer` instead."
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> ZLocalUser
                :> ZConn
@@ -849,6 +855,7 @@ type ConversationAPI =
            "update-conversation-message-timer"
            ( Summary "Update the message timer for a conversation"
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> ZLocalUser
                :> ZConn
@@ -873,6 +880,7 @@ type ConversationAPI =
            ( Summary "Update receipt mode for a conversation (deprecated)"
                :> Description "Use `PUT /conversations/:domain/:cnv/receipt-mode` instead."
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> MakesFederatedCall 'Galley "update-conversation"
                :> ZLocalUser
@@ -895,6 +903,7 @@ type ConversationAPI =
            "update-conversation-receipt-mode"
            ( Summary "Update receipt mode for a conversation"
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> MakesFederatedCall 'Galley "update-conversation"
                :> ZLocalUser

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

@@ -69,6 +69,7 @@ type TeamConversationAPI =
            "delete-team-conversation"
            ( Summary "Remove a team conversation"
                :> MakesFederatedCall 'Galley "on-conversation-updated"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
                :> MakesFederatedCall 'Galley "on-new-remote-conversation"
                :> CanThrow ('ActionDenied 'DeleteConversation)
                :> CanThrow 'ConvNotFound

libs/wire-api/wire-api.cabal

@@ -280,6 +280,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/wireapp/transitive-anns";
+        rev = "c3bdc423f84bf15fe8b3618b5dddd5764fc8a470";
+        sha256 = "sha256-mWBZ2uY0shlxNRceyC2Zu1f3Kr4IDtT/rOL7CKWgilA=";
+      };
+    };
     HaskellNet-SSL = {
       src = fetchgit {
         url = "https://github.com/dpwright/HaskellNet-SSL";

services/brig/brig.cabal

@@ -179,7 +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
-    -Wredundant-constraints
+    -fplugin=TransitiveAnns.Plugin -Wredundant-constraints
 
   build-depends:
       aeson                      >=2.0.1.0
@@ -292,6 +292,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/default.nix

@@ -137,6 +137,7 @@
 , time-units
 , tinylog
 , transformers
+, transitive-anns
 , types-common
 , types-common-aws
 , types-common-journal
@@ -276,6 +277,7 @@ mkDerivation {
     time-units
     tinylog
     transformers
+    transitive-anns
     types-common
     types-common-aws
     types-common-journal

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