[FS-1336] Leaving subconversations

changelog.d/2-features/subconv-leave

@@ -0,0 +1 @@
+Implement endpoint for leaving a subconversation

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

@@ -139,6 +139,11 @@ type GalleyApi =
            "delete-sub-conversation"
            DeleteSubConversationRequest
            DeleteSubConversationResponse
+    :<|> FedEndpointWithMods
+           '[MakesFederatedCall 'Galley "on-mls-message-sent"]
+           "leave-sub-conversation"
+           LeaveSubConversationRequest
+           LeaveSubConversationResponse
 
 data TypingDataUpdateRequest = TypingDataUpdateRequest
   { tdurTypingStatus :: TypingStatus,
@@ -458,6 +463,23 @@ data GetSubConversationsResponse
   deriving stock (Eq, Show, Generic)
   deriving (ToJSON, FromJSON) via (CustomEncoded GetSubConversationsResponse)
 
+data LeaveSubConversationRequest = LeaveSubConversationRequest
+  { lscrUser :: UserId,
+    lscrClient :: ClientId,
+    lscrConv :: ConvId,
+    lscrSubConv :: SubConvId
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via (GenericUniform LeaveSubConversationRequest)
+  deriving (ToJSON, FromJSON) via (CustomEncoded LeaveSubConversationRequest)
+
+data LeaveSubConversationResponse
+  = LeaveSubConversationResponseError GalleyError
+  | LeaveSubConversationResponseProtocolError Text
+  | LeaveSubConversationResponseOk
+  deriving stock (Eq, Show, Generic)
+  deriving (ToJSON, FromJSON) via (CustomEncoded LeaveSubConversationResponse)
+
 data DeleteSubConversationRequest = DeleteSubConversationRequest
   { dscreqUser :: UserId,
     dscreqConv :: ConvId,

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

@@ -419,6 +419,26 @@ type ConversationAPI =
                         PublicSubConversation
                     )
            )
+    :<|> Named
+           "leave-subconversation"
+           ( Summary "Leave an MLS subconversation"
+               :> MakesFederatedCall 'Galley "on-mls-message-sent"
+               :> MakesFederatedCall 'Galley "leave-sub-conversation"
+               :> CanThrow 'ConvNotFound
+               :> CanThrow 'ConvAccessDenied
+               :> CanThrow 'MLSProtocolErrorTag
+               :> ZLocalUser
+               :> ZClient
+               :> "conversations"
+               :> QualifiedCapture "cnv" ConvId
+               :> "subconversations"
+               :> Capture "subconv" SubConvId
+               :> "self"
+               :> MultiVerb1
+                    'DELETE
+                    '[JSON]
+                    (RespondEmpty 200 "OK")
+           )
     :<|> Named
            "delete-subconversation"
            ( Summary "Delete an MLS subconversation"

services/galley/src/Galley/API/Action.hs

@@ -67,7 +67,6 @@ import qualified Galley.Effects.ConversationStore as E
 import qualified Galley.Effects.FederatorAccess as E
 import qualified Galley.Effects.FireAndForget as E
 import qualified Galley.Effects.MemberStore as E
-import Galley.Effects.ProposalStore
 import qualified Galley.Effects.SubConversationStore as E
 import qualified Galley.Effects.TeamStore as E
 import Galley.Options

services/galley/src/Galley/API/Clients.hs

@@ -40,7 +40,6 @@ import qualified Galley.Effects.BrigAccess as E
 import qualified Galley.Effects.ClientStore as E
 import Galley.Effects.ConversationStore (getConversation)
 import Galley.Effects.FederatorAccess
-import Galley.Effects.ProposalStore (ProposalStore)
 import Galley.Env
 import Galley.Types.Clients (clientIds, fromUserClients)
 import Imports

services/galley/src/Galley/API/Federation.hs

@@ -17,7 +17,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
-module Galley.API.Federation where
+module Galley.API.Federation
+  ( FederationAPI,
+    federationSitemap,
+    onConversationUpdated,
+  )
+where
 
 import Control.Error
 import Control.Lens (itraversed, preview, to, (<.>))
@@ -44,7 +49,7 @@ import Galley.API.MLS.GroupInfo
 import Galley.API.MLS.KeyPackage
 import Galley.API.MLS.Message
 import Galley.API.MLS.Removal
-import Galley.API.MLS.SubConversation
+import Galley.API.MLS.SubConversation hiding (leaveSubConversation)
 import Galley.API.MLS.Welcome
 import qualified Galley.API.Mapping as Mapping
 import Galley.API.Message
@@ -57,7 +62,6 @@ import qualified Galley.Effects.BrigAccess as E
 import qualified Galley.Effects.ConversationStore as E
 import qualified Galley.Effects.FireAndForget as E
 import qualified Galley.Effects.MemberStore as E
-import Galley.Effects.ProposalStore (ProposalStore)
 import qualified Galley.Effects.SubConversationStore as E
 import Galley.Effects.SubConversationSupply
 import Galley.Options
@@ -125,6 +129,7 @@ federationSitemap =
     :<|> Named @"on-typing-indicator-updated" onTypingIndicatorUpdated
     :<|> Named @"get-sub-conversation" getSubConversationForRemoteUser
     :<|> Named @"delete-sub-conversation" (callsFed deleteSubConversationForRemoteUser)
+    :<|> Named @"leave-sub-conversation" (callsFed leaveSubConversation)
 
 onClientRemoved ::
   ( Members
@@ -766,29 +771,6 @@ sendMLSMessage remoteDomain msr =
               Nothing
               raw
 
-class ToGalleyRuntimeError (effs :: EffectRow) r where
-  mapToGalleyError ::
-    Member (Error GalleyError) r =>
-    Sem (Append effs r) a ->
-    Sem r a
-
-instance ToGalleyRuntimeError '[] r where
-  mapToGalleyError = id
-
-instance
-  forall (err :: GalleyError) effs r.
-  ( ToGalleyRuntimeError effs r,
-    SingI err,
-    Member (Error GalleyError) (Append effs r)
-  ) =>
-  ToGalleyRuntimeError (ErrorS err ': effs) r
-  where
-  mapToGalleyError act =
-    mapToGalleyError @effs @r $
-      runError act >>= \case
-        Left _ -> throw (demote @err)
-        Right res -> pure res
-
 mlsSendWelcome ::
   Members
     '[ BrigAccess,
@@ -942,6 +924,25 @@ getSubConversationForRemoteUser domain GetSubConversationsRequest {..} =
       lconv <- qualifyLocal gsreqConv
       getLocalSubConversation qusr lconv gsreqSubConv
 
+leaveSubConversation ::
+  ( HasLeaveSubConversationEffects r,
+    Members '[Input (Local ())] r
+  ) =>
+  Domain ->
+  LeaveSubConversationRequest ->
+  Sem r LeaveSubConversationResponse
+leaveSubConversation domain lscr = do
+  let rusr = toRemoteUnsafe domain (lscrUser lscr)
+      cid = mkClientIdentity (tUntagged rusr) (lscrClient lscr)
+  lcnv <- qualifyLocal (lscrConv lscr)
+  fmap (either (LeaveSubConversationResponseProtocolError . unTagged) id)
+    . runError @MLSProtocolError
+    . fmap (either LeaveSubConversationResponseError id)
+    . runError @GalleyError
+    . mapToGalleyError @LeaveSubConversationStaticErrors
+    $ leaveLocalSubConversation cid lcnv (lscrSubConv lscr)
+      $> LeaveSubConversationResponseOk
+
 deleteSubConversationForRemoteUser ::
   ( Members
       '[ ConversationStore,
@@ -972,3 +973,29 @@ deleteSubConversationForRemoteUser domain DeleteSubConversationRequest {..} =
           dsc = DeleteSubConversation dscreqGroupId dscreqEpoch
       lconv <- qualifyLocal dscreqConv
       deleteLocalSubConversation qusr lconv dscreqSubConv dsc
+
+--------------------------------------------------------------------------------
+-- Error handling machinery
+
+class ToGalleyRuntimeError (effs :: EffectRow) r where
+  mapToGalleyError ::
+    Member (Error GalleyError) r =>
+    Sem (Append effs r) a ->
+    Sem r a
+
+instance ToGalleyRuntimeError '[] r where
+  mapToGalleyError = id
+
+instance
+  forall (err :: GalleyError) effs r.
+  ( ToGalleyRuntimeError effs r,
+    SingI err,
+    Member (Error GalleyError) (Append effs r)
+  ) =>
+  ToGalleyRuntimeError (ErrorS err ': effs) r
+  where
+  mapToGalleyError act =
+    mapToGalleyError @effs @r $
+      runError act >>= \case
+        Left _ -> throw (demote @err)
+        Right res -> pure res

services/galley/src/Galley/API/Internal.hs

@@ -60,7 +60,6 @@ import Galley.Effects.FederatorAccess
 import Galley.Effects.GundeckAccess
 import Galley.Effects.LegalHoldStore as LegalHoldStore
 import Galley.Effects.MemberStore
-import Galley.Effects.ProposalStore
 import Galley.Effects.TeamStore
 import qualified Galley.Intra.Push as Intra
 import Galley.Monad

services/galley/src/Galley/API/LegalHold.hs

@@ -54,7 +54,6 @@ import Galley.Effects
 import Galley.Effects.BrigAccess
 import Galley.Effects.FireAndForget
 import qualified Galley.Effects.LegalHoldStore as LegalHoldData
-import Galley.Effects.ProposalStore
 import qualified Galley.Effects.TeamFeatureStore as TeamFeatures
 import Galley.Effects.TeamMemberStore
 import Galley.Effects.TeamStore

services/galley/src/Galley/API/MLS/Message.hs

@@ -1302,15 +1302,21 @@ executeProposalAction qusr con lconvOrSub action = do
   -- Type 2 requires no special processing on the backend, so here we filter
   -- out all removals of that type, so that further checks and processing can
   -- be applied only to type 1 removals.
-  removedUsers <- mapMaybe hush <$$> for (Map.assocs (paRemove action)) $
-    \(qtarget, Map.keysSet -> clients) -> runError @() $ do
-      -- fetch clients from brig
-      clientInfo <- Set.map ciId <$> getClientInfo lconvOrSub qtarget ss
-      -- if the clients being removed don't exist, consider this as a removal of
-      -- type 2, and skip it
-      when (Set.null (clientInfo `Set.intersection` clients)) $
-        throw ()
-      pure (qtarget, clients)
+  --
+  -- Furthermore, subconversation clients can be removed arbitrarily, so this
+  -- processing is only necessary for main conversations. In the
+  -- subconversation case, an empty list is returned.
+  removedUsers <- case convOrSub of
+    SubConv _ _ -> pure []
+    Conv _ -> mapMaybe hush <$$> for (Map.assocs (paRemove action)) $
+      \(qtarget, Map.keysSet -> clients) -> runError @() $ do
+        -- fetch clients from brig
+        clientInfo <- Set.map ciId <$> getClientInfo lconvOrSub qtarget ss
+        -- if the clients being removed don't exist, consider this as a removal of
+        -- type 2, and skip it
+        when (Set.null (clientInfo `Set.intersection` clients)) $
+          throw ()
+        pure (qtarget, clients)
 
   -- FUTUREWORK: remove this check after remote admins are implemented in federation https://wearezeta.atlassian.net/browse/FS-216
   foldQualified lconvOrSub (\_ -> pure ()) (\_ -> throwS @'MLSUnsupportedProposal) qusr