core: count successes and failures for batch operations, only log errors in info log-level (#2585)

* core: count successes and failures for batch operations, only log errors in info log-level * correction Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> --------- Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
2024-12-17 17:20:21 +01:00 · 2023-06-17 10:34:04 +01:00
parent e7089d4c2f
commit 53d77b25ed
6 changed files with 69 additions and 44 deletions
@@ -1231,7 +1231,7 @@ processChatCommand = \case
    let p' = (fromLocalProfile p :: Profile) {contactLink = Nothing}
    r <- updateProfile_ user p' $ withStore' $ \db -> setUserProfileContactLink db user Nothing
    let user' = case r of
-          CRUserProfileUpdated u' _ _ -> u'
+          CRUserProfileUpdated u' _ _ _ _ -> u'
          _ -> user
    pure $ CRUserContactLinkDeleted user'
  DeleteMyAddress -> withUser $ \User {userId} ->
@@ -1264,17 +1264,19 @@ processChatCommand = \case
  SendLiveMessage chatName msg -> sendTextMessage chatName msg True
  SendMessageBroadcast msg -> withUser $ \user -> do
    contacts <- withStore' (`getUserContacts` user)
+    let cts = filter (\ct -> isReady ct && directOrUsed ct) contacts
+    ChatConfig {logLevel} <- asks config
    withChatLock "sendMessageBroadcast" . procCmd $ do
-      let mc = MCText msg
-          cts = filter (\ct -> isReady ct && directOrUsed ct) contacts
-      forM_ cts $ \ct ->
-        void
-          ( do
-              (sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
-              saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc)
-          )
-          `catchError` (toView . CRChatError (Just user))
-      CRBroadcastSent user mc (length cts) <$> liftIO getCurrentTime
+      (successes, failures) <- foldM (sendAndCount user logLevel) (0, 0) cts
+      timestamp <- liftIO getCurrentTime
+      pure CRBroadcastSent {user, msgContent = mc, successes, failures, timestamp}
+    where
+      mc = MCText msg
+      sendAndCount user ll (s, f) ct =
+        (sendToContact user ct $> (s + 1, f)) `catchError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1)
+      sendToContact user ct = do
+        (sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
+        void $ saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc)
  SendMessageQuote cName (AMsgDirection msgDir) quotedMsg msg -> withUser $ \user@User {userId} -> do
    contactId <- withStore $ \db -> getContactIdByName db user cName
    quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
@@ -1596,6 +1598,7 @@ processChatCommand = \case
  UpdateProfileImage image -> withUser $ \user@User {profile} -> do
    let p = (fromLocalProfile profile :: Profile) {image}
    updateProfile user p
+  ShowProfileImage -> withUser $ \user@User {profile} -> pure $ CRUserProfileImage user $ fromLocalProfile profile
  SetUserFeature (ACF f) allowed -> withUser $ \user@User {profile} -> do
    let p = (fromLocalProfile profile :: Profile) {preferences = Just . setPreference f (Just allowed) $ preferences' user}
    updateProfile user p
@@ -1756,10 +1759,11 @@ processChatCommand = \case
        user' <- updateUser
        asks currentUser >>= atomically . (`writeTVar` Just user')
        withChatLock "updateProfile" . procCmd $ do
-          forM_ contacts $ \ct -> do
-            processContact user' ct `catchError` (toView . CRChatError (Just user))
-          pure $ CRUserProfileUpdated user' (fromLocalProfile p) p'
+          ChatConfig {logLevel} <- asks config
+          (successes, failures) <- foldM (processAndCount user' logLevel) (0, 0) contacts
+          pure $ CRUserProfileUpdated user' (fromLocalProfile p) p' successes failures
      where
+        processAndCount user' ll (s, f) ct = (processContact user' ct $> (s + 1, f)) `catchError` \e -> when (ll <= CLLInfo) (toView $ CRChatError (Just user) e) $> (s, f + 1)
        processContact user' ct = do
          let mergedProfile = userProfileToSend user Nothing $ Just ct
              ct' = updateMergedPreferences user' ct
@@ -4970,8 +4974,9 @@ chatCommandP =
      ("/reject " <|> "/rc ") *> char_ '@' *> (RejectContact <$> displayName),
      ("/markdown" <|> "/m") $> ChatHelp HSMarkdown,
      ("/welcome" <|> "/w") $> Welcome,
-      "/profile_image " *> (UpdateProfileImage . Just . ImageData <$> imageP),
-      "/profile_image" $> UpdateProfileImage Nothing,
+      "/set profile image " *> (UpdateProfileImage . Just . ImageData <$> imageP),
+      "/delete profile image" $> UpdateProfileImage Nothing,
+      "/show profile image" $> ShowProfileImage,
      ("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> profileNames),
      ("/profile" <|> "/p") $> ShowProfile,
      "/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)),
@@ -374,6 +374,7 @@ data ChatCommand
  | ShowProfile -- UserId (not used in UI)
  | UpdateProfile ContactName Text -- UserId (not used in UI)
  | UpdateProfileImage (Maybe ImageData) -- UserId (not used in UI)
+  | ShowProfileImage
  | SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
  | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
  | SetGroupFeature AGroupFeature GroupName GroupFeatureEnabled
@@ -421,7 +422,7 @@ data ChatResponse
  | CRChatItemReaction {user :: User, added :: Bool, reaction :: ACIReaction}
  | CRChatItemDeleted {user :: User, deletedChatItem :: AChatItem, toChatItem :: Maybe AChatItem, byUser :: Bool, timed :: Bool}
  | CRChatItemDeletedNotFound {user :: User, contact :: Contact, sharedMsgId :: SharedMsgId}
-  | CRBroadcastSent User MsgContent Int UTCTime
+  | CRBroadcastSent {user :: User, msgContent :: MsgContent, successes :: Int, failures :: Int, timestamp :: UTCTime}
  | CRMsgIntegrityError {user :: User, msgError :: MsgErrorType}
  | CRCmdAccepted {corr :: CorrId}
  | CRCmdOk {user_ :: Maybe User}
@@ -477,7 +478,8 @@ data ChatResponse
  | CRSndFileCompleteXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta}
  | CRSndFileCancelledXFTP {user :: User, chatItem :: AChatItem, fileTransferMeta :: FileTransferMeta}
  | CRSndFileError {user :: User, chatItem :: AChatItem}
-  | CRUserProfileUpdated {user :: User, fromProfile :: Profile, toProfile :: Profile}
+  | CRUserProfileUpdated {user :: User, fromProfile :: Profile, toProfile :: Profile, successes :: Int, failures :: Int}
+  | CRUserProfileImage {user :: User, profile :: Profile}
  | CRContactAliasUpdated {user :: User, toContact :: Contact}
  | CRConnectionAliasUpdated {user :: User, toConnection :: PendingContactConnection}
  | CRContactPrefsUpdated {user :: User, fromContact :: Contact, toContact :: Contact}
@@ -47,7 +47,6 @@ import qualified Simplex.FileTransfer.Protocol as XFTP
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Agent.Store (canAbortRcvSwitch)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@@ -98,7 +97,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts
  CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView
  CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction chat reaction $ viewItemReaction showReactions chat reaction added ts tz
  CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"]
-  CRBroadcastSent u mc n t -> ttyUser u $ viewSentBroadcast mc n ts tz t
+  CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t
  CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr
  CRCmdAccepted _ -> []
  CRCmdOk u_ -> ttyUser' u_ ["ok"]
@@ -152,7 +151,8 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts
  CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
  CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts
  CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft
-  CRUserProfileUpdated u p p' -> ttyUser u $ viewUserProfileUpdated p p'
+  CRUserProfileUpdated u p p' s f -> ttyUser u $ viewUserProfileUpdated p p' s f
+  CRUserProfileImage u p -> ttyUser u $ viewUserProfileImage p
  CRContactPrefsUpdated {user = u, fromContact, toContact} -> ttyUser u $ viewUserContactPrefsUpdated u fromContact toContact
  CRContactAliasUpdated u c -> ttyUser u $ viewContactAliasUpdated c
  CRConnectionAliasUpdated u c -> ttyUser u $ viewConnectionAliasUpdated c
@@ -983,8 +983,8 @@ viewSwitchPhase = \case
  SPSecured -> "secured new address"
  SPCompleted -> "changed address"

-viewUserProfileUpdated :: Profile -> Profile -> [StyledString]
-viewUserProfileUpdated Profile {displayName = n, fullName, image, contactLink, preferences} Profile {displayName = n', fullName = fullName', image = image', contactLink = contactLink', preferences = prefs'} =
+viewUserProfileUpdated :: Profile -> Profile -> Int -> Int -> [StyledString]
+viewUserProfileUpdated Profile {displayName = n, fullName, image, contactLink, preferences} Profile {displayName = n', fullName = fullName', image = image', contactLink = contactLink', preferences = prefs'} s f =
  profileUpdated <> viewPrefsUpdated preferences prefs'
  where
    profileUpdated
@@ -993,7 +993,15 @@ viewUserProfileUpdated Profile {displayName = n, fullName, image, contactLink, p
      | n == n' && fullName == fullName' = [if isNothing image' then "profile image removed" else "profile image updated"]
      | n == n' = ["user full name " <> (if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName') <> notified]
      | otherwise = ["user profile is changed to " <> ttyFullName n' fullName' <> notified]
-    notified = " (your contacts are notified)"
+    notified = " (your " <> sShow s <> " contacts are notified" <> failures <> ")"
+    failures
+      | f > 0 = ", " <> sShow f <> " failures"
+      | otherwise = ""
+
+viewUserProfileImage :: Profile -> [StyledString]
+viewUserProfileImage Profile {image} = case image of
+  Just (ImageData img) -> ["Profile image:", plain img]
+  _ -> ["No profile image"]

 viewUserContactPrefsUpdated :: User -> Contact -> Contact -> [StyledString]
 viewUserContactPrefsUpdated user ct ct'@Contact {mergedPreferences = cups}
@@ -1163,8 +1171,12 @@ viewSentMessage to quote mc ts tz meta@CIMeta {itemEdited, itemDeleted, itemLive
        Just False -> ttyTo "[LIVE] "
        _ -> ""

-viewSentBroadcast :: MsgContent -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
-viewSentBroadcast mc n ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow n <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc)
+viewSentBroadcast :: MsgContent -> Int -> Int -> CurrentTime -> TimeZone -> UTCTime -> [StyledString]
+viewSentBroadcast mc s f ts tz time = prependFirst (highlight' "/feed" <> " (" <> sShow s <> failures <> ") " <> ttyMsgTime ts tz time <> " ") (ttyMsgContent mc)
+  where
+    failures
+      | f > 0 = ", " <> sShow f <> " failures"
+      | otherwise = ""

 viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> TimeZone -> CIMeta c d -> [StyledString]
 viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts tz = case filePath of