Merge branch 'master' into ep/log-events

src/Simplex/FileTransfer/Agent.hs

@@ -28,7 +28,6 @@ module Simplex.FileTransfer.Agent
   )
 where
 
-import Control.Logger.Simple (logError)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -182,7 +181,7 @@ runXFTPRcvWorker c srv Worker {doWork} = do
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
             liftIO $ waitForUserNetwork c
             downloadFileChunk fc replica approvedRelays
-              `catchAgentError` \e -> retryOnError "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError c "XFTP rcv worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
               flip catchAgentError (\_ -> pure ()) $ do
@@ -232,12 +231,10 @@ withRetryIntervalLimit maxN ri action =
   withRetryIntervalCount ri $ \n delay loop ->
     when (n < maxN) $ action delay loop
 
-retryOnError :: Text -> AM a -> AM a -> AgentErrorType -> AM a
-retryOnError name loop done e = do
-  logError $ name <> " error: " <> tshow e
-  if temporaryAgentError e
-    then loop
-    else done
+retryOnError :: AgentClient -> Text -> AM a -> AM a -> AgentErrorType -> AM a
+retryOnError c name loop done e = do
+  logWarn c $ name <> " error: " <> tshow e
+  if temporaryAgentError e then loop else done
 
 rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> AgentErrorType -> AM ()
 rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath err = do
@@ -432,7 +429,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
               withRetryInterval (riFast ri) $ \_ loop -> do
                 liftIO $ waitForUserNetwork c
                 createWithNextSrv usedSrvs
-                  `catchAgentError` \e -> retryOnError "XFTP prepare worker" (retryLoop loop) (throwError e) e
+                  `catchAgentError` \e -> retryOnError c "XFTP prepare worker" (retryLoop loop) (throwError e) e
               where
                 retryLoop loop = atomically (assertAgentForeground c) >> loop
             createWithNextSrv usedSrvs = do
@@ -465,7 +462,7 @@ runXFTPSndWorker c srv Worker {doWork} = do
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
             liftIO $ waitForUserNetwork c
             uploadFileChunk cfg fc replica
-              `catchAgentError` \e -> retryOnError "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError c "XFTP snd worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
               flip catchAgentError (\_ -> pure ()) $ do
@@ -632,7 +629,7 @@ runXFTPDelWorker c srv Worker {doWork} = do
           withRetryIntervalLimit xftpConsecutiveRetries ri' $ \delay' loop -> do
             liftIO $ waitForUserNetwork c
             deleteChunkReplica
-              `catchAgentError` \e -> retryOnError "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
+              `catchAgentError` \e -> retryOnError c "XFTP del worker" (retryLoop loop e delay') (retryDone e) e
           where
             retryLoop loop e replicaDelay = do
               flip catchAgentError (\_ -> pure ()) $ do

src/Simplex/Messaging/Agent.hs

@@ -115,12 +115,12 @@ module Simplex.Messaging.Agent
     getAgentStats,
     resetAgentStats,
     getMsgCounts,
+    setAgentLogLevel,
     getAgentSubscriptions,
     logConnection,
   )
 where
 
-import Control.Logger.Simple (logError, logInfo, showText)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -213,9 +213,9 @@ getSMPAgentClient_ clientId cfg initServers store backgroundMode =
               run c "runNtfSupervisor" $ runNtfSupervisor c,
               run c "cleanupManager" $ cleanupManager c
             ]
-    run AgentClient {subQ, acThread} name a =
+    run c@AgentClient {subQ, acThread} name a =
       a `E.catchAny` \e -> whenM (isJust <$> readTVarIO acThread) $ do
-        logError $ "Agent thread " <> name <> " crashed: " <> tshow e
+        logError c $ "Agent thread " <> name <> " crashed: " <> tshow e
         atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR $ CRITICAL True $ show e)
 
 disconnectAgentClient :: AgentClient -> IO ()
@@ -569,7 +569,7 @@ withAgentEnv c a = ExceptT $ runExceptT a `runReaderT` agentEnv c
 logConnection :: AgentClient -> Bool -> IO ()
 logConnection c connected =
   let event = if connected then "connected to" else "disconnected from"
-   in logInfo $ T.unwords ["client", showText (clientId c), event, "Agent"]
+   in logInfo c $ T.unwords ["client", tshow (clientId c), event, "Agent"]
 
 -- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's.
 runAgentClient :: AgentClient -> AM' ()
@@ -908,12 +908,12 @@ rejectContact' c contactConnId invId =
 
 -- | Subscribe to receive connection messages (SUB command) in Reader monad
 subscribeConnection' :: AgentClient -> ConnId -> AM ()
-subscribeConnection' c connId = toConnResult connId =<< subscribeConnections' c [connId]
+subscribeConnection' c connId = toConnResult c connId =<< subscribeConnections' c [connId]
 {-# INLINE subscribeConnection' #-}
 
-toConnResult :: ConnId -> Map ConnId (Either AgentErrorType ()) -> AM ()
-toConnResult connId rs = case M.lookup connId rs of
-  Just (Right ()) -> when (M.size rs > 1) $ logError $ T.pack $ "too many results " <> show (M.size rs)
+toConnResult :: AgentClient -> ConnId -> Map ConnId (Either AgentErrorType ()) -> AM ()
+toConnResult c connId rs = case M.lookup connId rs of
+  Just (Right ()) -> when (M.size rs > 1) $ logError c $ T.pack $ "too many results " <> show (M.size rs)
   Just (Left e) -> throwError e
   _ -> throwError $ INTERNAL $ "no result for connection " <> B.unpack connId
 
@@ -985,7 +985,7 @@ subscribeConnections' c connIds = do
         writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected)
 
 resubscribeConnection' :: AgentClient -> ConnId -> AM ()
-resubscribeConnection' c connId = toConnResult connId =<< resubscribeConnections' c [connId]
+resubscribeConnection' c connId = toConnResult c connId =<< resubscribeConnections' c [connId]
 {-# INLINE resubscribeConnection' #-}
 
 resubscribeConnections' :: AgentClient -> [ConnId] -> AM (Map ConnId (Either AgentErrorType ()))
@@ -1389,7 +1389,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} ConnData {connId} sq (Worker {doWork
                       -- With `status == Active` condition, CON is sent here only by the accepting party, that previously received HELLO
                       when (status == Active) $ notify $ CON pqEncryption
                     -- this branch should never be reached as receive queue is created before the confirmation,
-                    _ -> logError "HELLO sent without receive queue"
+                    _ -> logError c "HELLO sent without receive queue"
                 AM_A_MSG_ -> notify $ SENT mId proxySrv_
                 AM_A_RCVD_ -> pure ()
                 AM_QCONT_ -> pure ()
@@ -1587,7 +1587,7 @@ suspendConnection' c connId = withConnLock c connId "suspendConnection" $ do
 -- unlike deleteConnectionAsync, this function does not mark connection as deleted in case of deletion failure
 -- currently it is used only in tests
 deleteConnection' :: AgentClient -> ConnId -> AM ()
-deleteConnection' c connId = toConnResult connId =<< deleteConnections' c [connId]
+deleteConnection' c connId = toConnResult c connId =<< deleteConnections' c [connId]
 {-# INLINE deleteConnection' #-}
 
 connRcvQueues :: Connection d -> [RcvQueue]

src/Simplex/Messaging/Agent/Client.hs

@@ -142,6 +142,14 @@ module Simplex.Messaging.Agent.Client
     XFTPTransportSession,
     ProxiedRelay (..),
     SMPConnectedClient (..),
+    setAgentLogLevel,
+    logTrace,
+    logDebug,
+    logInfo,
+    logNote,
+    logWarn,
+    logError,
+    logFail,
   )
 where
 
@@ -150,7 +158,8 @@ import Control.Concurrent (ThreadId, forkIO, threadDelay)
 import Control.Concurrent.Async (Async, uninterruptibleCancel)
 import Control.Concurrent.STM (retry, throwSTM)
 import Control.Exception (AsyncException (..), BlockedIndefinitelyOnSTM (..))
-import Control.Logger.Simple
+import Control.Logger.Simple (LogLevel (..))
+import qualified Control.Logger.Simple as Logger
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
@@ -308,6 +317,7 @@ data AgentClient = AgentClient
     deleteLock :: Lock,
     -- smpSubWorkers for SMP servers sessions
     smpSubWorkers :: TMap SMPTransportSession (SessionVar (Async ())),
+    agentLogLevel :: TVar LogLevel,
     agentStats :: TMap AgentStatsKey (TVar Int),
     msgCounts :: TMap ConnId (TVar (Int, Int)), -- (total, duplicates)
     clientId :: Int,
@@ -477,6 +487,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
   invLocks <- TM.empty
   deleteLock <- createLock
   smpSubWorkers <- TM.empty
+  agentLogLevel <- newTVar LogError
   agentStats <- TM.empty
   msgCounts <- TM.empty
   return
@@ -515,6 +526,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv =
         invLocks,
         deleteLock,
         smpSubWorkers,
+        agentLogLevel,
         agentStats,
         msgCounts,
         clientId,
@@ -659,7 +671,7 @@ smpConnectClient c@AgentClient {smpClients, msgQ} tSess@(_, srv, _) prs v =
 smpClientDisconnected :: AgentClient -> SMPTransportSession -> Env -> SMPClientVar -> TMap SMPServer ProxiedRelayVar -> SMPClient -> IO ()
 smpClientDisconnected c@AgentClient {active, smpClients, smpProxiedRelays} tSess@(userId, srv, qId) env v prs client = do
   removeClientAndSubs >>= serverDown
-  logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
+  logInfo c . decodeUtf8 $ "Agent disconnected from " <> showServer srv
   where
     -- we make active subscriptions pending only if the client for tSess was current (in the map) and active,
     -- because we can have a race condition when a new current client could have already
@@ -775,7 +787,7 @@ getNtfServerClient c@AgentClient {active, ntfClients, workerSeq} tSess@(userId,
       atomically $ removeSessVar v tSess ntfClients
       incClientStat c userId client "DISCONNECT" ""
       atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
-      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
+      logInfo c . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
 getXFTPServerClient :: AgentClient -> XFTPTransportSession -> AM XFTPClient
 getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId, srv, _) = do
@@ -798,7 +810,7 @@ getXFTPServerClient c@AgentClient {active, xftpClients, workerSeq} tSess@(userId
       atomically $ removeSessVar v tSess xftpClients
       incClientStat c userId client "DISCONNECT" ""
       atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client)
-      logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv
+      logInfo c . decodeUtf8 $ "Agent disconnected from " <> showServer srv
 
 waitForProtocolClient :: ProtocolTypeI (ProtoType msg) => AgentClient -> TransportSession msg -> ClientVar msg -> AM (Client msg)
 waitForProtocolClient c (_, srv, _) v = do
@@ -822,7 +834,7 @@ newProtocolClient ::
 newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient v =
   tryAgentError (connectClient v) >>= \case
     Right client -> do
-      logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
+      logInfo c . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")"
       atomically $ putTMVar (sessionVar v) (Right client)
       liftIO $ incClientStat c userId client "CLIENT" "OK"
       atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client)
@@ -1340,7 +1352,7 @@ subscribeQueues c qs = do
       if active
         then when (hasTempErrors rs) resubscribe $> rs
         else do
-          logWarn "subcription batch result for replaced SMP client, resubscribing"
+          logWarn c "subcription batch result for replaced SMP client, resubscribing"
           resubscribe $> L.map (second $ \_ -> Left PCENetworkError) rs
       where
         tSess = transportSession' smp
@@ -1437,8 +1449,8 @@ getSubscriptions = readTVar . subscrConns
 {-# INLINE getSubscriptions #-}
 
 logServer :: MonadIO m => ByteString -> AgentClient -> ProtocolServer s -> QueueId -> ByteString -> m ()
-logServer dir AgentClient {clientId} srv qId cmdStr =
-  logInfo . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
+logServer dir c@AgentClient {clientId} srv qId cmdStr =
+  logInfo c . decodeUtf8 $ B.unwords ["A", "(" <> bshow clientId <> ")", dir, showServer srv, ":", logSecret qId, cmdStr]
 {-# INLINE logServer #-}
 
 showServer :: ProtocolServer s -> ByteString
@@ -1872,6 +1884,36 @@ withNextSrv c userId usedSrvs initUsed action = do
     writeTVar usedSrvs $! used'
   action srvAuth
 
+setAgentLogLevel :: AgentClient -> LogLevel -> IO ()
+setAgentLogLevel AgentClient {agentLogLevel} = atomically . writeTVar agentLogLevel
+
+logTrace :: MonadIO m => AgentClient -> Text -> m ()
+logTrace c s = sendLogEvent c LogTrace s >> Logger.logTrace s
+
+logDebug :: MonadIO m => AgentClient -> Text -> m ()
+logDebug c s = sendLogEvent c LogDebug s >> Logger.logDebug s
+
+logInfo :: MonadIO m => AgentClient -> Text -> m ()
+logInfo c s = sendLogEvent c LogInfo s >> Logger.logInfo s
+
+logNote :: MonadIO m => AgentClient -> Text -> m ()
+logNote c s = sendLogEvent c LogNote s >> Logger.logNote s
+
+logWarn :: MonadIO m => AgentClient -> Text -> m ()
+logWarn c s = sendLogEvent c LogWarn s >> Logger.logWarn s
+
+logError :: MonadIO m => AgentClient -> Text -> m ()
+logError c s = sendLogEvent c LogError s >> Logger.logError s
+
+logFail :: (MonadFail m, MonadIO m) => AgentClient -> Text -> m a
+logFail c s = sendLogEvent c LogError s >> Logger.logFail s
+
+sendLogEvent :: MonadIO m => AgentClient -> Logger.LogLevel -> Text -> m ()
+sendLogEvent AgentClient {subQ, agentLogLevel} ll' s = do
+  ll <- readTVarIO agentLogLevel
+  when (ll' >= ll) . atomically $
+    writeTBQueue subQ ("", "", APC SAENone $ LOG (AgentLogLevel ll') s)
+
 data SubInfo = SubInfo {userId :: UserId, server :: Text, rcvId :: Text, subError :: Maybe String}
   deriving (Show)
 

src/Simplex/Messaging/Agent/NtfSubSupervisor.hs

@@ -18,7 +18,6 @@ module Simplex.Messaging.Agent.NtfSubSupervisor
   )
 where
 
-import Control.Logger.Simple (logError, logInfo)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.Reader
@@ -56,20 +55,20 @@ runNtfSupervisor c = do
   where
     handleErr :: ConnId -> AM' () -> AM' ()
     handleErr connId = E.handle $ \(e :: E.SomeException) -> do
-      logError $ "runNtfSupervisor error " <> tshow e
+      logError c $ "runNtfSupervisor error " <> tshow e
       notifyErr connId e
     notifyErr connId e = notifyInternalError c connId $ "runNtfSupervisor error " <> show e
 
 processNtfSub :: AgentClient -> (ConnId, NtfSupervisorCommand) -> AM ()
 processNtfSub c (connId, cmd) = do
-  logInfo $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
+  logInfo c $ "processNtfSub - connId = " <> tshow connId <> " - cmd = " <> tshow cmd
   case cmd of
     NSCCreate -> do
       (a, RcvQueue {server = smpServer, clientNtfCreds}) <- withStore c $ \db -> runExceptT $ do
         a <- liftIO $ getNtfSubscription db connId
         q <- ExceptT $ getPrimaryRcvQueue db connId
         pure (a, q)
-      logInfo $ "processNtfSub, NSCCreate - a = " <> tshow a
+      logInfo c $ "processNtfSub, NSCCreate - a = " <> tshow a
       case a of
         Nothing -> do
           withTokenServer $ \ntfServer -> do
@@ -119,14 +118,14 @@ processNtfSub c (connId, cmd) = do
       sub_ <- withStore' c $ \db -> do
         supervisorUpdateNtfAction db connId (NtfSubNTFAction NSADelete)
         getNtfSubscription db connId
-      logInfo $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
+      logInfo c $ "processNtfSub, NSCDelete - sub_ = " <> tshow sub_
       case sub_ of
         (Just (NtfSubscription {ntfServer}, _)) -> lift . void $ getNtfNTFWorker True c ntfServer
         _ -> pure () -- err "NSCDelete - no subscription"
     NSCSmpDelete -> do
       withStore' c (`getPrimaryRcvQueue` connId) >>= \case
         Right rq@RcvQueue {server = smpServer} -> do
-          logInfo $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
+          logInfo c $ "processNtfSub, NSCSmpDelete - rq = " <> tshow rq
           withStore' c $ \db -> supervisorUpdateNtfAction db connId (NtfSubSMPAction NSASmpDelete)
           lift . void $ getNtfSMPWorker True c smpServer
         _ -> notifyInternalError c connId "NSCSmpDelete - no rcv queue"
@@ -158,7 +157,7 @@ runNtfWorker c srv Worker {doWork} = do
     runNtfOperation =
       withWork c doWork (`getNextNtfSubNTFAction` srv) $
         \nextSub@(NtfSubscription {connId}, _, _) -> do
-          logInfo $ "runNtfWorker, nextSub " <> tshow nextSub
+          logInfo c $ "runNtfWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop -> do
             liftIO $ waitForUserNetwork c
@@ -242,7 +241,7 @@ runNtfSMPWorker c srv Worker {doWork} = do
     runNtfSMPOperation =
       withWork c doWork (`getNextNtfSubSMPAction` srv) $
         \nextSub@(NtfSubscription {connId}, _, _) -> do
-          logInfo $ "runNtfSMPWorker, nextSub " <> tshow nextSub
+          logInfo c $ "runNtfSMPWorker, nextSub " <> tshow nextSub
           ri <- asks $ reconnectInterval . config
           withRetryInterval ri $ \_ loop -> do
             liftIO $ waitForUserNetwork c
@@ -288,7 +287,7 @@ rescheduleAction doWork ts actionTs
 
 retryOnError :: AgentClient -> Text -> AM () -> (AgentErrorType -> AM ()) -> AgentErrorType -> AM ()
 retryOnError c name loop done e = do
-  logError $ name <> " error: " <> tshow e
+  logWarn c $ name <> " error: " <> tshow e
   case e of
     BROKER _ NETWORK -> retryLoop
     BROKER _ TIMEOUT -> retryLoop

src/Simplex/Messaging/Agent/Protocol.hs

@@ -114,6 +114,7 @@ module Simplex.Messaging.Agent.Protocol
     BrokerErrorType (..),
     SMPAgentError (..),
     AgentCryptoError (..),
+    AgentLogLevel (..),
     cryptoErrToSyncState,
     ATransmission,
     ATransmissionOrError,
@@ -156,6 +157,7 @@ module Simplex.Messaging.Agent.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
+import Control.Logger.Simple (LogLevel (..))
 import Control.Monad (unless)
 import Control.Monad.Except (runExceptT, throwError)
 import Control.Monad.IO.Class
@@ -391,6 +393,7 @@ data ACommand (p :: AParty) (e :: AEntity) where
   DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone
   DOWN :: SMPServer -> [ConnId] -> ACommand Agent AENone
   UP :: SMPServer -> [ConnId] -> ACommand Agent AENone
+  LOG :: AgentLogLevel -> Text -> ACommand Agent AENone
   SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn
   RSYNC :: RatchetSyncState -> Maybe AgentCryptoError -> ConnectionStats -> ACommand Agent AEConn
   SEND :: PQEncryption -> MsgFlags -> MsgBody -> ACommand Client AEConn
@@ -455,6 +458,7 @@ data ACommandTag (p :: AParty) (e :: AEntity) where
   DISCONNECT_ :: ACommandTag Agent AENone
   DOWN_ :: ACommandTag Agent AENone
   UP_ :: ACommandTag Agent AENone
+  LOG_ :: ACommandTag Agent AENone
   SWITCH_ :: ACommandTag Agent AEConn
   RSYNC_ :: ACommandTag Agent AEConn
   SEND_ :: ACommandTag Client AEConn
@@ -512,6 +516,7 @@ aCommandTag = \case
   DISCONNECT {} -> DISCONNECT_
   DOWN {} -> DOWN_
   UP {} -> UP_
+  LOG {} -> LOG_
   SWITCH {} -> SWITCH_
   RSYNC {} -> RSYNC_
   SEND {} -> SEND_
@@ -1629,6 +1634,35 @@ instance StrEncoding SMPAgentError where
     A_DUPLICATE -> "DUPLICATE"
     A_QUEUE e -> "QUEUE " <> encodeUtf8 (T.pack e)
 
+newtype AgentLogLevel = AgentLogLevel LogLevel
+  deriving (Eq, Show)
+
+instance StrEncoding AgentLogLevel where
+  strEncode (AgentLogLevel ll) = case ll of
+    LogTrace -> "TRACE"
+    LogDebug -> "DEBUG"
+    LogInfo -> "INFO"
+    LogNote -> "NOTE"
+    LogWarn -> "WARN"
+    LogError -> "ERROR"
+  strP = do
+    s <- A.takeTill (== ' ')
+    AgentLogLevel <$> case s of
+      "TRACE" -> pure LogTrace
+      "DEBUG" -> pure LogDebug
+      "INFO" -> pure LogInfo
+      "NOTE" -> pure LogNote
+      "WARN" -> pure LogWarn
+      "ERROR" -> pure LogError
+      _ -> fail "bad AgentLogLevel"
+
+instance ToJSON AgentLogLevel where
+  toJSON = strToJSON
+  toEncoding = strToJEncoding
+
+instance FromJSON AgentLogLevel where
+  parseJSON = strParseJSON "AgentLogLevel"
+
 cryptoErrToSyncState :: AgentCryptoError -> RatchetSyncState
 cryptoErrToSyncState = \case
   DECRYPT_AES -> RSAllowed
@@ -1666,6 +1700,7 @@ instance StrEncoding ACmdTag where
       "DISCONNECT" -> nt DISCONNECT_
       "DOWN" -> nt DOWN_
       "UP" -> nt UP_
+      "LOG" -> nt LOG_
       "SWITCH" -> ct SWITCH_
       "RSYNC" -> ct RSYNC_
       "SEND" -> t SEND_
@@ -1725,6 +1760,7 @@ instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where
     DISCONNECT_ -> "DISCONNECT"
     DOWN_ -> "DOWN"
     UP_ -> "UP"
+    LOG_ -> "LOG"
     SWITCH_ -> "SWITCH"
     RSYNC_ -> "RSYNC"
     SEND_ -> "SEND"
@@ -1798,6 +1834,7 @@ commandP binaryP =
           DISCONNECT_ -> s (DISCONNECT <$> strP_ <*> strP)
           DOWN_ -> s (DOWN <$> strP_ <*> connections)
           UP_ -> s (UP <$> strP_ <*> connections)
+          LOG_ -> s (LOG <$> strP_ <*> strP)
           SWITCH_ -> s (SWITCH <$> strP_ <*> strP_ <*> strP)
           RSYNC_ -> s (RSYNC <$> strP_ <*> strP <*> strP)
           MID_ -> s (MID <$> A.decimal <*> _strP)
@@ -1861,6 +1898,7 @@ serializeCommand = \case
   DISCONNECT p h -> s (DISCONNECT_, p, h)
   DOWN srv conns -> B.unwords [s DOWN_, s srv, connections conns]
   UP srv conns -> B.unwords [s UP_, s srv, connections conns]
+  LOG ll txt -> s (LOG_, ll, txt)
   SWITCH dir phase srvs -> s (SWITCH_, dir, phase, srvs)
   RSYNC rrState cryptoErr cstats -> s (RSYNC_, rrState, cryptoErr, cstats)
   SEND pqEnc msgFlags msgBody -> B.unwords [s SEND_, s pqEnc, smpEncode msgFlags, serializeBinary msgBody]

src/Simplex/Messaging/Encoding/String.hs

@@ -39,7 +39,7 @@ import Data.Time.Format.ISO8601
 import Data.Word (Word16, Word32)
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Parsers (parseAll)
-import Simplex.Messaging.Util ((<$?>))
+import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
 
 class TextEncoding a where
   textEncode :: a -> Text
@@ -81,6 +81,10 @@ instance StrEncoding String where
   strEncode = strEncode . B.pack
   strP = B.unpack <$> strP
 
+instance StrEncoding Text where
+  strEncode = strEncode . encodeUtf8
+  strP = safeDecodeUtf8 <$> A.takeByteString
+
 instance ToJSON Str where
   toJSON (Str s) = strToJSON s
   toEncoding (Str s) = strToJEncoding s