dandri/simplexmq
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplexmq.git synced 2026-04-09 19:06:16 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'master' into xftp

Browse Source
This commit is contained in:
spacedandy
2023-03-03 19:16:12 +04:00
parent cf147397a4 2f7c115207
commit cc38deb65d
7 changed files with 58 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
README.md
View File

@@ -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 \

4
src/Simplex/Messaging/Agent.hs
View File

@@ -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

4
src/Simplex/Messaging/Agent/Client.hs
View File

@@ -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

4
src/Simplex/Messaging/Agent/NtfSubSupervisor.hs
View File

@@ -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

25
src/Simplex/Messaging/Agent/RetryInterval.hs
View File

@@ -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

4
src/Simplex/Messaging/Client/Agent.hs
View File

@@ -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 ()

32
tests/CoreTests/RetryIntervalTests.hs
View File

@@ -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