Federation API versioning

libs/wire-api-federation/package.yaml

@@ -28,12 +28,14 @@ dependencies:
 - kan-extensions
 - lifted-base
 - metrics-wai
+- mmorph
 - mtl
 - network
 - servant >=0.16
 - servant-client
 - servant-client-core
 - servant-server
+- singletons
 - sop-core
 - streaming-commons
 - template-haskell

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

@@ -17,18 +17,27 @@
 
 module Wire.API.Federation.API
   ( FedApi,
+    VersionedFedApi,
+    VersionedFedApi',
     HasFedEndpoint,
     fedClient,
     fedClientIn,
+    vClient,
+    vFedClient,
+    mkVersionedServer,
 
     -- * Re-exports
     Component (..),
+    Version (..),
+    VL,
   )
 where
 
 import Data.Proxy
+import Data.Singletons hiding (type (@@))
 import GHC.TypeLits
 import Imports
+import Servant
 import Servant.Client
 import Servant.Client.Core
 import Wire.API.Federation.API.Brig
@@ -37,28 +46,66 @@ import Wire.API.Federation.API.Galley
 import Wire.API.Federation.Client
 import Wire.API.Federation.Component
 import Wire.API.Federation.Endpoint
+import Wire.API.Federation.Version
+import Wire.API.Federation.Version.Info
 
--- Note: this type family being injective means that in most cases there is no need
--- to add component annotations when invoking the federator client
-type family FedApi (comp :: Component) = (api :: *) | api -> comp
+type family FedApi (comp :: Component) (v :: Version) :: * where
+  FedApi 'Galley v = GalleyApi v
+  FedApi 'Brig v = BrigApi @@ v
+  FedApi 'Cargohold v = CargoholdApi v
 
-type instance FedApi 'Galley = GalleyApi
-
-type instance FedApi 'Brig = BrigApi
-
-type instance FedApi 'Cargohold = CargoholdApi
-
-type HasFedEndpoint comp api name = ('Just api ~ LookupEndpoint (FedApi comp) name)
+type HasFedEndpoint comp v api name = ('Just api ~ LookupEndpoint (FedApi comp v) name)
 
 -- | Return a client for a named endpoint.
 fedClient ::
-  forall (comp :: Component) (name :: Symbol) m api.
-  (HasFedEndpoint comp api name, HasClient m api, m ~ FederatorClient comp) =>
-  Client m api
-fedClient = clientIn (Proxy @api) (Proxy @m)
+  forall (comp :: Component) (v :: Version) (name :: Symbol) api.
+  ( HasFedEndpoint comp v api name,
+    HasClient FederatorClient api,
+    KnownSymbol (ComponentPrefix comp)
+  ) =>
+  Client FederatorClient api
+fedClient = fedClientIn @comp @v @name @FederatorClient
 
 fedClientIn ::
-  forall (comp :: Component) (name :: Symbol) m api.
-  (HasFedEndpoint comp api name, HasClient m api) =>
+  forall (comp :: Component) (v :: Version) (name :: Symbol) m api.
+  ( HasFedEndpoint comp v api name,
+    HasClient m api,
+    KnownSymbol (ComponentPrefix comp)
+  ) =>
   Client m api
-fedClientIn = clientIn (Proxy @api) (Proxy @m)
+fedClientIn = clientIn (Proxy @(ComponentPrefix comp :> api)) (Proxy @m)
+
+vClient ::
+  forall (vapi :: *) (m :: * -> *) (v :: Version).
+  HasClient m (vapi @@ v) =>
+  Sing v ->
+  Client m (vapi @@ v)
+vClient _ = clientIn (Proxy @(vapi @@ v)) (Proxy @m)
+
+vFedClient ::
+  forall vapi v.
+  HasClient FederatorClient (vapi @@ v) =>
+  Sing v ->
+  Client FederatorClient (vapi @@ v)
+vFedClient s = vClient @vapi @FederatorClient s
+
+type family CombinedApi (comp :: Component) (vs :: [Version]) where
+  CombinedApi comp '[v0] = FedApi comp v0
+  CombinedApi comp (v0 ': vs) = FedApi comp v0 :<|> CombinedApi comp vs
+
+apiVersionEndpoint :: Applicative m => ServerT ApiVersionEndpoint m
+apiVersionEndpoint = pure supportedVersionInfo
+
+-- | All versions of the federation API.
+type VersionedFedApi (comp :: Component) = CombinedApi comp SupportedVersions
+
+-- | All versions of the federation API, plus an endpoint returning all versions.
+type VersionedFedApi' (comp :: Component) =
+  ApiVersionEndpoint :<|> VersionedFedApi comp
+
+mkVersionedServer ::
+  forall (comp :: Component) m.
+  Applicative m =>
+  ServerT (VersionedFedApi comp) m ->
+  ServerT (VersionedFedApi' comp) m
+mkVersionedServer h = apiVersionEndpoint :<|> h

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

@@ -20,13 +20,17 @@ module Wire.API.Federation.API.Brig where
 import Data.Aeson
 import Data.Handle (Handle)
 import Data.Id
+import Data.Proxy
 import Data.Range
 import Imports
 import Servant.API
+import Servant.Client
+import Servant.Client.Core
 import Test.QuickCheck (Arbitrary)
 import Wire.API.Arbitrary (GenericUniform (..))
 import Wire.API.Federation.API.Common
 import Wire.API.Federation.Endpoint
+import Wire.API.Federation.Version
 import Wire.API.Message (UserClients)
 import Wire.API.User (UserProfile)
 import Wire.API.User.Client (PubClient, UserClientPrekeyMap)
@@ -43,21 +47,46 @@ instance ToJSON SearchRequest
 
 instance FromJSON SearchRequest
 
+data BrigApi
+
 -- | For conventions see /docs/developer/federation-api-conventions.md
---
--- Maybe this module should be called Brig
-type BrigApi =
-  FedEndpoint "get-user-by-handle" Handle (Maybe UserProfile)
-    :<|> FedEndpoint "get-users-by-ids" [UserId] [UserProfile]
-    :<|> FedEndpoint "claim-prekey" (UserId, ClientId) (Maybe ClientPrekey)
-    :<|> FedEndpoint "claim-prekey-bundle" UserId PrekeyBundle
-    :<|> FedEndpoint "claim-multi-prekey-bundle" UserClients UserClientPrekeyMap
-    -- FUTUREWORK(federation): do we want to perform some type-level validation like length checks?
-    -- (handles can be up to 256 chars currently)
-    :<|> FedEndpoint "search-users" SearchRequest [Contact]
-    :<|> FedEndpoint "get-user-clients" GetUserClients (UserMap (Set PubClient))
-    :<|> FedEndpoint "send-connection-action" NewConnectionRequest NewConnectionResponse
-    :<|> FedEndpoint "on-user-deleted-connections" UserDeletedConnectionsNotification EmptyResponse
+type instance
+  BrigApi @@ 'V0 =
+    FedEndpoint "get-user-by-handle" Handle (Maybe UserProfile)
+      :<|> FedEndpoint "get-users-by-ids" [UserId] [UserProfile]
+      :<|> FedEndpoint "claim-prekey" (UserId, ClientId) (Maybe ClientPrekey)
+      :<|> FedEndpoint "claim-prekey-bundle" UserId PrekeyBundle
+      :<|> FedEndpoint "claim-multi-prekey-bundle" UserClients UserClientPrekeyMap
+      -- FUTUREWORK(federation): do we want to perform some type-level validation like length checks?
+      -- (handles can be up to 256 chars currently)
+      :<|> FedEndpoint "search-users" SearchRequest [Contact]
+      :<|> FedEndpoint "get-user-clients" GetUserClients (UserMap (Set PubClient))
+      :<|> FedEndpoint "send-connection-action" NewConnectionRequest NewConnectionResponse
+      :<|> FedEndpoint "on-user-deleted-connections" UserDeletedConnectionsNotification EmptyResponse
+
+type GetUserByHandle = BrigApi @! "get-user-by-handle"
+
+class Monad m => Algebra m r where
+  algebraFlatten :: m r -> r
+
+instance {-# INCOHERENT #-} Monad m => Algebra m (m r) where
+  algebraFlatten = join
+
+instance Algebra m r => Algebra m (a -> r) where
+  algebraFlatten alg a = algebraFlatten (alg <*> pure a)
+
+instance VersionedApi GetUserByHandle where
+  hoistV SV0 f = hoistClient (Proxy @(GetUserByHandle @@ 'V0)) f
+  clientV m SV0 = clientIn (Proxy @(GetUserByHandle @@ 'V0)) m
+  flattenV SV0 = algebraFlatten
+
+-- instance HasEndpoint BrigApi "get-user-by-handle" 'V0
+
+-- instance VersionedApi BrigApi where
+--   hoistV = go
+--     where
+--       go :: forall (v :: Version) m n. Sing v -> (forall x. m x -> n x) -> Client m (BrigApi @@ v) -> Client n (BrigApi @@ v)
+--       go _ = hoistClient (Proxy @(BrigApi @@ v))
 
 newtype GetUserClients = GetUserClients
   { gucUsers :: [UserId]

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

@@ -24,6 +24,7 @@ import Servant.API
 import Wire.API.Arbitrary (Arbitrary, GenericUniform (..))
 import Wire.API.Asset
 import Wire.API.Federation.Endpoint
+import Wire.API.Federation.Version
 import Wire.API.Routes.AssetBody
 import Wire.API.Util.Aeson
 
@@ -46,6 +47,9 @@ data GetAssetResponse = GetAssetResponse
   deriving (Arbitrary) via (GenericUniform GetAssetResponse)
   deriving (ToJSON, FromJSON) via (CustomEncoded GetAssetResponse)
 
-type CargoholdApi =
-  FedEndpoint "get-asset" GetAsset GetAssetResponse
-    :<|> StreamingFedEndpoint "stream-asset" GetAsset AssetSource
+type family CargoholdApi (v :: Version)
+
+type instance
+  CargoholdApi 'V0 =
+    FedEndpoint "get-asset" GetAsset GetAssetResponse
+      :<|> StreamingFedEndpoint "stream-asset" GetAsset AssetSource

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

@@ -15,7 +15,12 @@
 -- 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.API.Common where
+module Wire.API.Federation.API.Common
+  ( EmptyResponse (..),
+    EmptyRequest,
+    pattern EmptyRequest,
+  )
+where
 
 import Data.Aeson
 import Imports
@@ -28,6 +33,11 @@ data EmptyResponse = EmptyResponse
   deriving stock (Eq, Show, Generic)
   deriving (Arbitrary) via (GenericUniform EmptyResponse)
 
+type EmptyRequest = EmptyResponse
+
+pattern EmptyRequest :: EmptyResponse
+pattern EmptyRequest = EmptyResponse
+
 instance FromJSON EmptyResponse where
   parseJSON = withObject "EmptyResponse" . const $ pure EmptyResponse
 

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

@@ -39,6 +39,7 @@ import Wire.API.Conversation.Member (OtherMember)
 import Wire.API.Conversation.Role (RoleName)
 import Wire.API.Federation.API.Common
 import Wire.API.Federation.Endpoint
+import Wire.API.Federation.Version
 import Wire.API.Message (MessageNotSent, MessageSendingStatus, PostOtrResponse, Priority)
 import Wire.API.User.Client (UserClientMap)
 import Wire.API.Util.Aeson (CustomEncoded (..))
@@ -48,21 +49,24 @@ import Wire.API.Util.Aeson (CustomEncoded (..))
 -- for the current list we need.
 
 -- | For conventions see /docs/developer/federation-api-conventions.md
-type GalleyApi =
-  -- | Register a new conversation
-  FedEndpoint "on-conversation-created" (NewRemoteConversation ConvId) ()
-    :<|> FedEndpoint "get-conversations" GetConversationsRequest GetConversationsResponse
-    -- used by the backend that owns a conversation to inform this backend of
-    -- changes to the conversation
-    :<|> FedEndpoint "on-conversation-updated" ConversationUpdate ()
-    :<|> FedEndpoint "leave-conversation" LeaveConversationRequest LeaveConversationResponse
-    -- used to notify this backend that a new message has been posted to a
-    -- remote conversation
-    :<|> FedEndpoint "on-message-sent" (RemoteMessage ConvId) ()
-    -- used by a remote backend to send a message to a conversation owned by
-    -- this backend
-    :<|> FedEndpoint "send-message" MessageSendRequest MessageSendResponse
-    :<|> FedEndpoint "on-user-deleted-conversations" UserDeletedConversationsNotification EmptyResponse
+type family GalleyApi (v :: Version)
+
+type instance
+  GalleyApi 'V0 =
+    -- Register a new conversation
+    FedEndpoint "on-conversation-created" (NewRemoteConversation ConvId) ()
+      :<|> FedEndpoint "get-conversations" GetConversationsRequest GetConversationsResponse
+      -- used by the backend that owns a conversation to inform this backend of
+      -- changes to the conversation
+      :<|> FedEndpoint "on-conversation-updated" ConversationUpdate ()
+      :<|> FedEndpoint "leave-conversation" LeaveConversationRequest LeaveConversationResponse
+      -- used to notify this backend that a new message has been posted to a
+      -- remote conversation
+      :<|> FedEndpoint "on-message-sent" (RemoteMessage ConvId) ()
+      -- used by a remote backend to send a message to a conversation owned by
+      -- this backend
+      :<|> FedEndpoint "send-message" MessageSendRequest MessageSendResponse
+      :<|> FedEndpoint "on-user-deleted-conversations" UserDeletedConversationsNotification EmptyResponse
 
 data GetConversationsRequest = GetConversationsRequest
   { gcrUserId :: UserId,