WPB-28709 additional logging on failed mls commits

changelog.d/5-internal/WPB-28709

@@ -0,0 +1 @@
+Add diagnostic logging for failed MLS commit-bundle operations, including typed failures and exceptions during commit-lock handling.

libs/wire-subsystems/src/Wire/ConversationSubsystem/Interpreter.hs

@@ -25,15 +25,18 @@ module Wire.ConversationSubsystem.Interpreter
   )
 where
 
+import Data.Aeson qualified as A
+import Data.Aeson.Types qualified as AT
 import Data.Qualified
+import Data.Text qualified as Text
 import Imports
-import Network.Wai.Utilities.JSONResponse (JSONResponse)
+import Network.Wai.Utilities.JSONResponse (JSONResponse (..))
 import Polysemy
 import Polysemy.Async (Async)
 import Polysemy.Error
 import Polysemy.Input
 import Polysemy.Resource (Resource)
-import Polysemy.TinyLog (TinyLog)
+import Polysemy.TinyLog (TinyLog, logErrors)
 import Wire.API.Conversation.Config
 import Wire.API.Error
 import Wire.API.Federation.Client (FederatorClient)
@@ -87,6 +90,14 @@ import Wire.TeamSubsystem (TeamSubsystem)
 import Wire.UserClientIndexStore (UserClientIndexStore)
 import Wire.UserGroupStore (UserGroupStore)
 
+renderConversationSubsystemError :: ConversationSubsystemError -> Text
+renderConversationSubsystemError errorValue =
+  let response = toResponse errorValue
+      label = case response.value of
+        A.Object object -> fromMaybe "unknown" (AT.parseMaybe (A..: "label") object)
+        _ -> "unknown"
+   in "status=" <> Text.pack (show response.status) <> " label=" <> label
+
 interpretConversationSubsystem ::
   ( Member MeetingNotifier r,
     Member (Error ConversationSubsystemError) r,
@@ -152,9 +163,15 @@ interpretConversationSubsystem = interpret $ \case
   InternalGetLocalMember cid uid ->
     mapErrors $ ConvStore.getLocalMember cid uid
   PostMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle ->
-    mapErrors $ MLSMessage.postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle
+    logErrors @_ @ConversationSubsystemError
+      renderConversationSubsystemError
+      "MLS commit bundle failed"
+      (mapErrors $ MLSMessage.postMLSCommitBundle loc qusr c ctype qConvOrSub conn oosCheck bundle)
   PostMLSCommitBundleFromLocalUser v lusr c conn bundle ->
-    mapErrors $ MLSMessage.postMLSCommitBundleFromLocalUser v lusr c conn bundle
+    logErrors @_ @ConversationSubsystemError
+      renderConversationSubsystemError
+      "MLS commit bundle failed"
+      (mapErrors $ MLSMessage.postMLSCommitBundleFromLocalUser v lusr c conn bundle)
   PostMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg ->
     mapErrors $ MLSMessage.postMLSMessage loc qusr c ctype qconvOrSub con oosCheck msg
   PostMLSMessageFromLocalUser v lusr c conn smsg ->

libs/wire-subsystems/src/Wire/ConversationSubsystem/MLS/Util.hs

@@ -28,7 +28,7 @@ import Data.Text qualified as T
 import Imports
 import Polysemy
 import Polysemy.Error
-import Polysemy.Resource (Resource, bracket)
+import Polysemy.Resource (Resource, bracket, onException)
 import Polysemy.TinyLog (TinyLog)
 import Polysemy.TinyLog qualified as TinyLog
 import System.Logger qualified as Log
@@ -123,25 +123,46 @@ withCommitLock lConvOrSubId gid epoch =
               Nothing
             throwS @'MLSStaleMessage
       )
-      (const $ releaseCommitLock gid epoch)
       ( const $ do
-          actualEpoch <-
-            fromMaybe (Epoch 0) <$> case tUnqualified lConvOrSubId of
-              Conv cnv -> getConversationEpoch cnv
-              SubConv cnv sub -> getSubConversationEpoch cnv sub
-          unless (actualEpoch == epoch) $ do
-            logStaleCommitLock
-              "commit-lock-epoch-mismatch"
-              lConvOrSubId
-              gid
-              epoch
-              (Just actualEpoch)
-            throwS @'MLSStaleMessage
-          k ()
+          releaseCommitLock gid epoch
+            `onException` (logCommitLockFailure "release" lConvOrSubId gid epoch)
+      )
+      ( const $
+          ( do
+              actualEpoch <-
+                fromMaybe (Epoch 0) <$> case tUnqualified lConvOrSubId of
+                  Conv cnv -> getConversationEpoch cnv
+                  SubConv cnv sub -> getSubConversationEpoch cnv sub
+              unless (actualEpoch == epoch) $ do
+                logStaleCommitLock
+                  "commit-lock-epoch-mismatch"
+                  lConvOrSubId
+                  gid
+                  epoch
+                  (Just actualEpoch)
+                throwS @'MLSStaleMessage
+              k ()
+          )
+            `onException` logCommitLockFailure "operation" lConvOrSubId gid epoch
       )
   where
     ttl = fromIntegral (600 :: Int) -- 10 minutes
 
+logCommitLockFailure ::
+  (Member TinyLog r) =>
+  ByteString ->
+  Local ConvOrSubConvId ->
+  GroupId ->
+  Epoch ->
+  Sem r ()
+logCommitLockFailure phase lConvOrSubId gid epoch =
+  TinyLog.warn $
+    Log.msg ("MLS commit lock operation failed" :: ByteString)
+      . Log.field "phase" phase
+      . Log.field "groupId" ("0x" <> hex (unGroupId gid))
+      . Log.field "epoch" (epochNumber epoch)
+      . Log.field "convOrSubConvId" (toByteString' (show (tUnqualified lConvOrSubId)))
+
 logStaleCommitLock ::
   (Member TinyLog r) =>
   ByteString ->