diff --git a/README.md b/README.md index e508ad954..e57672d11 100644 --- a/README.md +++ b/README.md @@ -113,15 +113,15 @@ On Linux, you can deploy smp server using Docker. This will download image from mkdir -p ~/simplex/{config,logs} ``` -2. Run your Docker container. You must change **your_ip_or_domain**. `-e pass="password"` is optional variable to password-protect your `smp` server: +2. Run your Docker container. You must change **your_ip_or_domain**. `-e "pass=password"` is optional variable to password-protect your `smp` server: ```sh docker run -d \ - -e addr="your_ip_or_domain" \ - -e pass="password" \ + -e "addr=your_ip_or_domain" \ + -e "pass=password" \ -p 5223:5223 \ -v $HOME/simplex/config:/etc/opt/simplex:z \ -v $HOME/simplex/logs:/var/opt/simplex:z \ - simplexchat/simplexmq + simplexchat/simplexmq:latest ``` #### Ubuntu @@ -154,8 +154,8 @@ On Linux, you can build smp server using Docker. 3. Run your Docker container. You must change **your_ip_or_domain**. `-e pass="password"` is optional variable to password-protect your `smp` server:: ```sh docker run -d \ - -e addr="your_ip_or_domain" \ - -e pass="password" \ + -e "addr=your_ip_or_domain" \ + -e "pass=password" \ -p 5223:5223 \ -v $HOME/simplex/config:/etc/opt/simplex:z \ -v $HOME/simplex/logs:/var/opt/simplex:z \ diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 80749ac6d..56d8a4e96 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -896,7 +896,7 @@ runCommandProcessing c@AgentClient {subQ} server_ = do withStore c (`getConn` connId) >>= \case SomeConn _ conn@DuplexConnection {} -> a conn _ -> internalErr "command requires duplex connection" - tryCommand action = withRetryInterval ri $ \loop -> + tryCommand action = withRetryInterval ri $ \_ loop -> tryError action >>= \case Left e | temporaryOrHostError e -> retrySndOp c loop @@ -1002,7 +1002,7 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl Left (e :: E.SomeException) -> notify $ MERR mId (INTERNAL $ show e) Right (rq_, PendingMsgData {msgType, msgBody, msgFlags, internalTs}) -> - withRetryLock2 ri qLock $ \loop -> do + withRetryLock2 ri qLock $ \_ loop -> do resp <- tryError $ case msgType of AM_CONN_INFO -> sendConfirmation c sq msgBody _ -> sendAgentMessage c sq msgFlags msgBody diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 95eb48d3a..1ee467578 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -421,7 +421,7 @@ reconnectServer c tSess = newAsyncAction tryReconnectSMPClient $ reconnections c where tryReconnectSMPClient aId = do ri <- asks $ reconnectInterval . config - withRetryInterval ri $ \loop -> + withRetryInterval ri $ \_ loop -> reconnectSMPClient c tSess `catchError` const loop atomically . removeAsyncAction aId $ reconnections c @@ -537,7 +537,7 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconne connectAsync :: Int -> m () connectAsync aId = do ri <- asks $ reconnectInterval . config - withRetryInterval ri $ \loop -> void $ tryConnectClient (const $ reconnectClient c tSess) loop + withRetryInterval ri $ \_ loop -> void $ tryConnectClient (const $ reconnectClient c tSess) loop atomically . removeAsyncAction aId $ asyncClients c hostEvent :: forall err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> Client msg -> ACommand 'Agent diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 3dab5de2b..1a96fff16 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -175,7 +175,7 @@ runNtfWorker c srv doWork = do Nothing -> noWorkToDo Just a@(NtfSubscription {connId}, _, _) -> do ri <- asks $ reconnectInterval . config - withRetryInterval ri $ \loop -> + withRetryInterval ri $ \_ loop -> processAction a `catchError` retryOnError c "NtfWorker" loop (workerInternalError c connId . show) noWorkToDo = void . atomically $ tryTakeTMVar doWork @@ -259,7 +259,7 @@ runNtfSMPWorker c srv doWork = do Nothing -> noWorkToDo Just a@(NtfSubscription {connId}, _, _) -> do ri <- asks $ reconnectInterval . config - withRetryInterval ri $ \loop -> + withRetryInterval ri $ \_ loop -> processAction a `catchError` retryOnError c "NtfSMPWorker" loop (workerInternalError c connId . show) noWorkToDo = void . atomically $ tryTakeTMVar doWork diff --git a/src/Simplex/Messaging/Agent/RetryInterval.hs b/src/Simplex/Messaging/Agent/RetryInterval.hs index 3d5cfcbae..28128dab5 100644 --- a/src/Simplex/Messaging/Agent/RetryInterval.hs +++ b/src/Simplex/Messaging/Agent/RetryInterval.hs @@ -29,13 +29,13 @@ data RetryInterval2 = RetryInterval2 } data RetryIntervalMode = RISlow | RIFast - deriving (Eq) + deriving (Eq, Show) -withRetryInterval :: forall m. MonadIO m => RetryInterval -> (m () -> m ()) -> m () +withRetryInterval :: forall m. MonadIO m => RetryInterval -> (Int -> m () -> m ()) -> m () withRetryInterval ri action = callAction 0 $ initialInterval ri where callAction :: Int -> Int -> m () - callAction elapsed delay = action loop + callAction elapsed delay = action delay loop where loop = do liftIO $ threadDelay delay @@ -43,20 +43,23 @@ withRetryInterval ri action = callAction 0 $ initialInterval ri callAction elapsed' $ nextDelay elapsed' delay ri -- This function allows action to toggle between slow and fast retry intervals. -withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> ((RetryIntervalMode -> m ()) -> m ()) -> m () +withRetryLock2 :: forall m. MonadIO m => RetryInterval2 -> TMVar () -> ((RetryIntervalMode, Int) -> (RetryIntervalMode -> m ()) -> m ()) -> m () withRetryLock2 RetryInterval2 {riSlow, riFast} lock action = - callAction (0, initialInterval riSlow) (0, initialInterval riFast) + callAction (RIFast, 0) (0, initialInterval riSlow) (0, initialInterval riFast) where - callAction :: (Int, Int) -> (Int, Int) -> m () - callAction slow fast = action loop + callAction :: (RetryIntervalMode, Int) -> (Int, Int) -> (Int, Int) -> m () + callAction retryState slow fast = action retryState loop where - loop = \case - RISlow -> run slow riSlow (`callAction` fast) - RIFast -> run fast riFast (callAction slow) + loop mode = case mode of + RISlow -> run slow riSlow (\ri -> callAction (state ri) ri fast) + RIFast -> run fast riFast (\ri -> callAction (state ri) slow ri) + where + state ri = (mode, snd ri) run (elapsed, delay) ri call = do wait delay let elapsed' = elapsed + delay - call (elapsed', nextDelay elapsed' delay ri) + delay' = nextDelay elapsed' delay ri + call (elapsed', delay') wait delay = do waiting <- newTVarIO True _ <- liftIO . forkIO $ do diff --git a/src/Simplex/Messaging/Client/Agent.hs b/src/Simplex/Messaging/Client/Agent.hs index 2d9562aea..b99e9d61d 100644 --- a/src/Simplex/Messaging/Client/Agent.hs +++ b/src/Simplex/Messaging/Client/Agent.hs @@ -156,7 +156,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = atomically $ modifyTVar' (asyncClients ca) (a :) connectAsync :: ExceptT SMPClientError IO () connectAsync = - withRetryInterval (reconnectInterval agentCfg) $ \loop -> + withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> void $ tryConnectClient (const reconnectClient) loop connectClient :: ExceptT SMPClientError IO SMPClient @@ -195,7 +195,7 @@ getSMPServerClient' ca@SMPClientAgent {agentCfg, smpClients, msgQ} srv = tryReconnectClient :: ExceptT SMPClientError IO () tryReconnectClient = do - withRetryInterval (reconnectInterval agentCfg) $ \loop -> + withRetryInterval (reconnectInterval agentCfg) $ \_ loop -> reconnectClient `catchE` const loop reconnectClient :: ExceptT SMPClientError IO () diff --git a/tests/CoreTests/RetryIntervalTests.hs b/tests/CoreTests/RetryIntervalTests.hs index 5495e2a3a..6bede691a 100644 --- a/tests/CoreTests/RetryIntervalTests.hs +++ b/tests/CoreTests/RetryIntervalTests.hs @@ -36,22 +36,50 @@ testRetryIntervalSameMode = it "should increase elapased time and interval when the mode stays the same" $ do lock <- newEmptyTMVarIO intervals <- newTVarIO [] + reportedIntervals <- newTVarIO [] ts <- newTVarIO =<< getCurrentTime - withRetryLock2 testRI lock $ \loop -> do + withRetryLock2 testRI lock $ \ri loop -> do ints <- addInterval intervals ts + atomically $ modifyTVar' reportedIntervals (ri :) when (length ints < 9) $ loop RIFast (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 4, 4, 4] + (reverse <$> readTVarIO reportedIntervals) + `shouldReturn` [ (RIFast, 0), + (RIFast, 10000), + (RIFast, 15000), + (RIFast, 22500), + (RIFast, 33750), + (RIFast, 40000), + (RIFast, 40000), + (RIFast, 40000), + (RIFast, 40000) + ] testRetryIntervalSwitchMode :: Spec testRetryIntervalSwitchMode = it "should increase elapased time and interval when the mode stays the same" $ do lock <- newEmptyTMVarIO intervals <- newTVarIO [] + reportedIntervals <- newTVarIO [] ts <- newTVarIO =<< getCurrentTime - withRetryLock2 testRI lock $ \loop -> do + withRetryLock2 testRI lock $ \ri loop -> do ints <- addInterval intervals ts + atomically $ modifyTVar' reportedIntervals (ri :) when (length ints < 11) $ loop $ if length ints <= 5 then RIFast else RISlow (reverse <$> readTVarIO intervals) `shouldReturn` [0, 1, 1, 1, 2, 3, 2, 2, 3, 4, 4] + (reverse <$> readTVarIO reportedIntervals) + `shouldReturn` [ (RIFast, 0), + (RIFast, 10000), + (RIFast, 15000), + (RIFast, 22500), + (RIFast, 33750), + (RIFast, 40000), + (RISlow, 20000), + (RISlow, 30000), + (RISlow, 40000), + (RISlow, 40000), + (RISlow, 40000) + ] addInterval :: TVar [Int] -> TVar UTCTime -> IO [Int] addInterval intervals ts = do