diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index a5ba40f4a..b565835ea 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/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 - `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 @@ -227,12 +226,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 -> String -> AM () rcvWorkerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do @@ -427,7 +424,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 @@ -460,7 +457,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 @@ -627,7 +624,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 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index b1aa5070a..45a341d85 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -114,12 +114,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 @@ -212,9 +212,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 () @@ -576,7 +576,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' () @@ -915,12 +915,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 @@ -992,7 +992,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 ())) @@ -1396,7 +1396,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 () @@ -1594,7 +1594,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] @@ -2011,7 +2011,7 @@ subscriber c@AgentClient {subQ, msgQ} = forever $ do agentOperationBracket c AORcvNetwork waitUntilActive $ tryAgentError' (processSMPTransmission c t) >>= \case Left e -> do - logError $ tshow e + logError c $ tshow e atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR e) Right _ -> return () diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index fb595f1c0..1b3b98bf6 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -140,6 +140,14 @@ module Simplex.Messaging.Agent.Client XFTPTransportSession, ProxiedRelay (..), SMPConnectedClient (..), + setAgentLogLevel, + logTrace, + logDebug, + logInfo, + logNote, + logWarn, + logError, + logFail, ) where @@ -148,7 +156,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 @@ -307,6 +316,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, @@ -476,6 +486,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 @@ -514,6 +525,7 @@ newAgentClient clientId InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = invLocks, deleteLock, smpSubWorkers, + agentLogLevel, agentStats, msgCounts, clientId, @@ -658,7 +670,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 @@ -774,7 +786,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 @@ -797,7 +809,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 @@ -821,7 +833,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) @@ -1349,7 +1361,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 @@ -1441,8 +1453,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 @@ -1876,6 +1888,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) diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 4aaa5f278..45eded173 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/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 diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 1fc984ac5..dcc79144a 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/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] diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs index 6b9fb5624..7bbc722cf 100644 --- a/src/Simplex/Messaging/Encoding/String.hs +++ b/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