mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-07-20 07:02:13 +00:00
Merge branch 'master' into xftp
This commit is contained in:
Evgeny Poberezkin
@@ -1,3 +1,14 @@
|
||||
# 4.4.0
|
||||
|
||||
SMP agent:
|
||||
|
||||
- support multiple user profiles with transport session isolation.
|
||||
- support optional transport isolation per connection.
|
||||
- batch connection deletion
|
||||
- improve asynchronous connection deletion – it may now be completed after the client is restarted as well.
|
||||
- improve subscription logic to retry if initial attempt fails.
|
||||
- end SMP client connection after a number of failed PINGs (defalt is 3).
|
||||
|
||||
# 4.3.0
|
||||
|
||||
SMP server:
|
||||
|
||||
+1
-1
@@ -1,5 +1,5 @@
|
||||
name: simplexmq
|
||||
version: 4.3.1
|
||||
version: 4.4.0
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: |
|
||||
This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
|
||||
+1
-1
@@ -5,7 +5,7 @@ cabal-version: 1.12
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: simplexmq
|
||||
version: 4.3.1
|
||||
version: 4.4.0
|
||||
synopsis: SimpleXMQ message broker
|
||||
description: This package includes <./docs/Simplex-Messaging-Server.html server>,
|
||||
<./docs/Simplex-Messaging-Client.html client> and
|
||||
|
||||
@@ -12,6 +12,7 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- |
|
||||
-- Module : Simplex.Messaging.Agent
|
||||
@@ -472,7 +473,7 @@ deleteConnectionsAsync_ :: forall m. AgentMonad m => m () -> AgentClient -> [Con
|
||||
deleteConnectionsAsync_ onSuccess c connIds = case connIds of
|
||||
[] -> onSuccess
|
||||
_ -> do
|
||||
(_, rqs, connIds') <- prepareDeleteConnections_ getConn c connIds
|
||||
(_, rqs, connIds') <- prepareDeleteConnections_ getConns c connIds
|
||||
withStore' c $ forM_ connIds' . setConnDeleted
|
||||
void . forkIO $
|
||||
withLock (deleteLock c) "deleteConnectionsAsync" $
|
||||
@@ -628,7 +629,7 @@ type QCmdResult = (QueueStatus, Either AgentErrorType ())
|
||||
subscribeConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||
subscribeConnections' _ [] = pure M.empty
|
||||
subscribeConnections' c connIds = do
|
||||
conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConn)
|
||||
conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (`getConns` connIds)
|
||||
let (errs, cs) = M.mapEither id conns
|
||||
errs' = M.map (Left . storeError) errs
|
||||
(subRs, rcvQs) = M.mapEither rcvQueueOrResult cs
|
||||
@@ -1193,20 +1194,20 @@ disableConn c connId = do
|
||||
|
||||
-- Unlike deleteConnectionsAsync, this function does not mark connections as deleted in case of deletion failure.
|
||||
deleteConnections' :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections' = deleteConnections_ getConn False
|
||||
deleteConnections' = deleteConnections_ getConns False
|
||||
|
||||
deleteDeletedConns :: forall m. AgentMonad m => AgentClient -> [ConnId] -> m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteDeletedConns = deleteConnections_ getDeletedConn True
|
||||
deleteDeletedConns = deleteConnections_ getDeletedConns True
|
||||
|
||||
prepareDeleteConnections_ ::
|
||||
forall m.
|
||||
AgentMonad m =>
|
||||
(DB.Connection -> ConnId -> IO (Either StoreError SomeConn)) ->
|
||||
(DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]) ->
|
||||
AgentClient ->
|
||||
[ConnId] ->
|
||||
m (Map ConnId (Either AgentErrorType ()), [RcvQueue], [ConnId])
|
||||
prepareDeleteConnections_ getConnection c connIds = do
|
||||
conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (forM connIds . getConnection)
|
||||
prepareDeleteConnections_ getConnections c connIds = do
|
||||
conns :: Map ConnId (Either StoreError SomeConn) <- M.fromList . zip connIds <$> withStore' c (`getConnections` connIds)
|
||||
let (errs, cs) = M.mapEither id conns
|
||||
errs' = M.map (Left . storeError) errs
|
||||
(delRs, rcvQs) = M.mapEither rcvQueues cs
|
||||
@@ -1259,14 +1260,14 @@ deleteConnQueues c ntf rqs = do
|
||||
deleteConnections_ ::
|
||||
forall m.
|
||||
AgentMonad m =>
|
||||
(DB.Connection -> ConnId -> IO (Either StoreError SomeConn)) ->
|
||||
(DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]) ->
|
||||
Bool ->
|
||||
AgentClient ->
|
||||
[ConnId] ->
|
||||
m (Map ConnId (Either AgentErrorType ()))
|
||||
deleteConnections_ _ _ _ [] = pure M.empty
|
||||
deleteConnections_ getConnection ntf c connIds = do
|
||||
(rs, rqs, _) <- prepareDeleteConnections_ getConnection c connIds
|
||||
deleteConnections_ getConnections ntf c connIds = do
|
||||
(rs, rqs, _) <- prepareDeleteConnections_ getConnections c connIds
|
||||
rcvRs <- deleteConnQueues c ntf rqs
|
||||
let rs' = M.union rs rcvRs
|
||||
notifyResultError rs'
|
||||
@@ -1576,7 +1577,7 @@ cleanupManager c = do
|
||||
forever $ do
|
||||
void . runExceptT $
|
||||
withLock (deleteLock c) "cleanupManager" $ do
|
||||
void $ withStore' c getDeletedConns >>= deleteDeletedConns c
|
||||
void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c
|
||||
withStore' c deleteUsersWithoutConns >>= mapM_ notifyUserDeleted
|
||||
threadDelay int
|
||||
where
|
||||
|
||||
@@ -520,7 +520,7 @@ throwWhenNoDelivery c SndQueue {server, sndId} =
|
||||
|
||||
closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO ()
|
||||
closeProtocolServerClients c clientsSel =
|
||||
readTVarIO cs >>= mapM_ (forkIO . closeClient) >> atomically (writeTVar cs M.empty)
|
||||
atomically (swapTVar cs M.empty) >>= mapM_ (forkIO . closeClient)
|
||||
where
|
||||
cs = clientsSel c
|
||||
closeClient cVar = do
|
||||
@@ -530,7 +530,7 @@ closeProtocolServerClients c clientsSel =
|
||||
_ -> pure ()
|
||||
|
||||
cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO ()
|
||||
cancelActions as = readTVarIO as >>= mapM_ (forkIO . uninterruptibleCancel) >> atomically (writeTVar as mempty)
|
||||
cancelActions as = atomically (swapTVar as mempty) >>= mapM_ (forkIO . uninterruptibleCancel)
|
||||
|
||||
withConnLock :: MonadUnliftIO m => AgentClient -> ConnId -> String -> m a -> m a
|
||||
withConnLock _ "" _ = id
|
||||
|
||||
@@ -43,9 +43,11 @@ module Simplex.Messaging.Agent.Store.SQLite
|
||||
createSndConn,
|
||||
getConn,
|
||||
getDeletedConn,
|
||||
getConns,
|
||||
getDeletedConns,
|
||||
getConnData,
|
||||
setConnDeleted,
|
||||
getDeletedConns,
|
||||
getDeletedConnIds,
|
||||
getRcvConn,
|
||||
deleteConn,
|
||||
upgradeRcvConnToDuplex,
|
||||
@@ -1404,6 +1406,18 @@ getAnyConn deleted' dbConn connId =
|
||||
(Nothing, Nothing, _) -> Right $ SomeConn SCNew (NewConnection cData)
|
||||
_ -> Left SEConnNotFound
|
||||
|
||||
getConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
|
||||
getConns = getAnyConns_ False
|
||||
|
||||
getDeletedConns :: DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
|
||||
getDeletedConns = getAnyConns_ True
|
||||
|
||||
getAnyConns_ :: Bool -> DB.Connection -> [ConnId] -> IO [Either StoreError SomeConn]
|
||||
getAnyConns_ deleted' db connIds = forM connIds $ E.handle handleDBError . getAnyConn deleted' db
|
||||
where
|
||||
handleDBError :: E.SomeException -> IO (Either StoreError SomeConn)
|
||||
handleDBError = pure . Left . SEInternal . bshow
|
||||
|
||||
getConnData :: DB.Connection -> ConnId -> IO (Maybe (ConnData, ConnectionMode))
|
||||
getConnData dbConn connId' =
|
||||
maybeFirstRow cData $ DB.query dbConn "SELECT user_id, conn_id, conn_mode, smp_agent_version, enable_ntfs, duplex_handshake, deleted FROM connections WHERE conn_id = ?;" (Only connId')
|
||||
@@ -1413,8 +1427,8 @@ getConnData dbConn connId' =
|
||||
setConnDeleted :: DB.Connection -> ConnId -> IO ()
|
||||
setConnDeleted db connId = DB.execute db "UPDATE connections SET deleted = ? WHERE conn_id = ?" (True, connId)
|
||||
|
||||
getDeletedConns :: DB.Connection -> IO [ConnId]
|
||||
getDeletedConns db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
|
||||
getDeletedConnIds :: DB.Connection -> IO [ConnId]
|
||||
getDeletedConnIds db = map fromOnly <$> DB.query db "SELECT conn_id FROM connections WHERE deleted = ?" (Only True)
|
||||
|
||||
-- | returns all connection queues, the first queue is the primary one
|
||||
getRcvQueuesByConnId_ :: DB.Connection -> ConnId -> IO (Maybe (NonEmpty RcvQueue))
|
||||
|
||||
@@ -26,6 +26,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..))
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (isAsciiLower, isDigit)
|
||||
import Data.Default (def)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as L
|
||||
@@ -70,11 +71,14 @@ instance StrEncoding TransportHost where
|
||||
strP =
|
||||
A.choice
|
||||
[ THIPv4 <$> ((,,,) <$> ipNum <*> ipNum <*> ipNum <*> A.decimal),
|
||||
THOnionHost <$> ((<>) <$> A.takeTill (== '.') <*> A.string ".onion"),
|
||||
THDomainName . B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
|
||||
THOnionHost <$> ((<>) <$> A.takeWhile (\c -> isAsciiLower c || isDigit c) <*> A.string ".onion"),
|
||||
THDomainName . B.unpack <$> (notOnion <$?> A.takeWhile1 (A.notInClass ":#,;/ \n\r\t"))
|
||||
]
|
||||
where
|
||||
ipNum = A.decimal <* A.char '.'
|
||||
ipNum = validIP <$?> (A.decimal <* A.char '.')
|
||||
validIP :: Int -> Either String Word8
|
||||
validIP n = if 0 <= n && n <= 255 then Right $ fromIntegral n else Left "invalid IP address"
|
||||
notOnion s = if ".onion" `B.isSuffixOf` s then Left "invalid onion host" else Right s
|
||||
|
||||
instance ToJSON TransportHost where
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
@@ -56,10 +56,10 @@ import Simplex.Messaging.Version
|
||||
import Test.Hspec
|
||||
import UnliftIO
|
||||
|
||||
(##>) :: MonadIO m => m (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
|
||||
(##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> ATransmission 'Agent -> m ()
|
||||
a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t)
|
||||
|
||||
(=##>) :: MonadIO m => m (ATransmission 'Agent) -> (ATransmission 'Agent -> Bool) -> m ()
|
||||
(=##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> (ATransmission 'Agent -> Bool) -> m ()
|
||||
a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p)
|
||||
|
||||
get :: MonadIO m => AgentClient -> m (ATransmission 'Agent)
|
||||
@@ -85,10 +85,10 @@ agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = vr11}
|
||||
vr11 :: VersionRange
|
||||
vr11 = mkVersionRange 1 1
|
||||
|
||||
runRight_ :: ExceptT AgentErrorType IO () -> Expectation
|
||||
runRight_ :: HasCallStack => ExceptT AgentErrorType IO () -> Expectation
|
||||
runRight_ action = runExceptT action `shouldReturn` Right ()
|
||||
|
||||
runRight :: ExceptT AgentErrorType IO a -> IO a
|
||||
runRight :: HasCallStack => ExceptT AgentErrorType IO a -> IO a
|
||||
runRight action =
|
||||
runExceptT action >>= \case
|
||||
Right x -> pure x
|
||||
@@ -240,7 +240,7 @@ runTestCfg2 aliceCfg bobCfg baseMsgId runTest = do
|
||||
bob <- getSMPAgentClient bobCfg {database = testDB2} initAgentServers
|
||||
runTest alice bob baseMsgId
|
||||
|
||||
runAgentClientTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
||||
runAgentClientTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
||||
runAgentClientTest alice bob baseId = do
|
||||
runRight_ $ do
|
||||
(bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing
|
||||
@@ -275,7 +275,7 @@ runAgentClientTest alice bob baseId = do
|
||||
where
|
||||
msgId = subtract baseId
|
||||
|
||||
runAgentClientContactTest :: AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTest :: HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()
|
||||
runAgentClientContactTest alice bob baseId = do
|
||||
runRight_ $ do
|
||||
(_, qInfo) <- createConnection alice 1 True SCMContact Nothing
|
||||
@@ -312,7 +312,7 @@ runAgentClientContactTest alice bob baseId = do
|
||||
where
|
||||
msgId = subtract baseId
|
||||
|
||||
noMessages :: AgentClient -> String -> Expectation
|
||||
noMessages :: HasCallStack => AgentClient -> String -> Expectation
|
||||
noMessages c err = tryGet `shouldReturn` ()
|
||||
where
|
||||
tryGet =
|
||||
@@ -320,7 +320,7 @@ noMessages c err = tryGet `shouldReturn` ()
|
||||
Just msg -> error $ err <> ": " <> show msg
|
||||
_ -> return ()
|
||||
|
||||
testAsyncInitiatingOffline :: IO ()
|
||||
testAsyncInitiatingOffline :: HasCallStack => IO ()
|
||||
testAsyncInitiatingOffline = do
|
||||
alice <- getSMPAgentClient agentCfg initAgentServers
|
||||
bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
|
||||
@@ -337,7 +337,7 @@ testAsyncInitiatingOffline = do
|
||||
get bob ##> ("", aliceId, CON)
|
||||
exchangeGreetings alice' bobId bob aliceId
|
||||
|
||||
testAsyncJoiningOfflineBeforeActivation :: IO ()
|
||||
testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO ()
|
||||
testAsyncJoiningOfflineBeforeActivation = do
|
||||
alice <- getSMPAgentClient agentCfg initAgentServers
|
||||
bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
|
||||
@@ -354,7 +354,7 @@ testAsyncJoiningOfflineBeforeActivation = do
|
||||
get bob' ##> ("", aliceId, CON)
|
||||
exchangeGreetings alice bobId bob' aliceId
|
||||
|
||||
testAsyncBothOffline :: IO ()
|
||||
testAsyncBothOffline :: HasCallStack => IO ()
|
||||
testAsyncBothOffline = do
|
||||
alice <- getSMPAgentClient agentCfg initAgentServers
|
||||
bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
|
||||
@@ -374,7 +374,7 @@ testAsyncBothOffline = do
|
||||
get bob' ##> ("", aliceId, CON)
|
||||
exchangeGreetings alice' bobId bob' aliceId
|
||||
|
||||
testAsyncServerOffline :: ATransport -> IO ()
|
||||
testAsyncServerOffline :: HasCallStack => ATransport -> IO ()
|
||||
testAsyncServerOffline t = do
|
||||
alice <- getSMPAgentClient agentCfg initAgentServers
|
||||
bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
|
||||
@@ -400,7 +400,7 @@ testAsyncServerOffline t = do
|
||||
get bob ##> ("", aliceId, CON)
|
||||
exchangeGreetings alice bobId bob aliceId
|
||||
|
||||
testAsyncHelloTimeout :: IO ()
|
||||
testAsyncHelloTimeout :: HasCallStack => IO ()
|
||||
testAsyncHelloTimeout = do
|
||||
-- this test would only work if any of the agent is v1, there is no HELLO timeout in v2
|
||||
alice <- getSMPAgentClient agentCfgV1 initAgentServers
|
||||
@@ -411,7 +411,7 @@ testAsyncHelloTimeout = do
|
||||
aliceId <- joinConnection bob 1 True cReq "bob's connInfo"
|
||||
get bob ##> ("", aliceId, ERR $ CONN NOT_ACCEPTED)
|
||||
|
||||
testDuplicateMessage :: ATransport -> IO ()
|
||||
testDuplicateMessage :: HasCallStack => ATransport -> IO ()
|
||||
testDuplicateMessage t = do
|
||||
alice <- getSMPAgentClient agentCfg initAgentServers
|
||||
bob <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
|
||||
@@ -791,11 +791,10 @@ testDeleteUserQuietly = do
|
||||
exchangeGreetingsMsgId 6 a bId b aId
|
||||
liftIO $ noMessages a "nothing else should be delivered to alice"
|
||||
|
||||
testUsersNoServer :: ATransport -> IO ()
|
||||
testUsersNoServer :: HasCallStack => ATransport -> IO ()
|
||||
testUsersNoServer t = do
|
||||
a <- getSMPAgentClient agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers
|
||||
b <- getSMPAgentClient agentCfg {database = testDB2} initAgentServers
|
||||
liftIO $ print 1
|
||||
(aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn t testPort $ \_ -> runRight $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
@@ -803,26 +802,18 @@ testUsersNoServer t = do
|
||||
(aId', bId') <- makeConnectionForUsers a auId b 1
|
||||
exchangeGreetingsMsgId 4 a bId' b aId'
|
||||
pure (aId, bId, auId, aId', bId')
|
||||
liftIO $ print 2
|
||||
get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
|
||||
get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False
|
||||
get b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False
|
||||
liftIO $ print 3
|
||||
runRight_ $ do
|
||||
deleteUser a auId True
|
||||
liftIO $ print 4
|
||||
get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False
|
||||
liftIO $ print 4.1
|
||||
get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False
|
||||
liftIO $ print 4.2
|
||||
get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False
|
||||
liftIO $ print 5
|
||||
liftIO $ noMessages a "nothing else should be delivered to alice"
|
||||
withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do
|
||||
liftIO $ print 6
|
||||
get a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False
|
||||
get b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False
|
||||
liftIO $ print 7
|
||||
exchangeGreetingsMsgId 6 a bId b aId
|
||||
|
||||
testSwitchConnection :: InitialAgentServers -> IO ()
|
||||
@@ -859,28 +850,23 @@ phase c connId d p =
|
||||
SWITCH {} <- pure r
|
||||
pure ()
|
||||
|
||||
testSwitchAsync :: InitialAgentServers -> IO ()
|
||||
testSwitchAsync :: HasCallStack => InitialAgentServers -> IO ()
|
||||
testSwitchAsync servers = do
|
||||
liftIO $ print 1
|
||||
(aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do
|
||||
(aId, bId) <- makeConnection a b
|
||||
exchangeGreetingsMsgId 4 a bId b aId
|
||||
pure (aId, bId)
|
||||
liftIO $ print 2
|
||||
let withA' = session withA bId
|
||||
withB' = session withB aId
|
||||
withA' $ \a -> do
|
||||
switchConnectionAsync a "" bId
|
||||
phase a bId QDRcv SPStarted
|
||||
liftIO $ print 3
|
||||
withB' $ \b -> phase b aId QDSnd SPStarted
|
||||
withA' $ \a -> phase a bId QDRcv SPConfirmed
|
||||
liftIO $ print 4
|
||||
withB' $ \b -> do
|
||||
phase b aId QDSnd SPConfirmed
|
||||
phase b aId QDSnd SPCompleted
|
||||
withA' $ \a -> phase a bId QDRcv SPCompleted
|
||||
liftIO $ print 5
|
||||
withA $ \a -> withB $ \b -> runRight_ $ do
|
||||
subscribeConnection a bId
|
||||
subscribeConnection b aId
|
||||
@@ -956,7 +942,7 @@ testRatchetAdHash = do
|
||||
ad2 <- getConnectionRatchetAdHash b aId
|
||||
liftIO $ ad1 `shouldBe` ad2
|
||||
|
||||
testTwoUsers :: IO ()
|
||||
testTwoUsers :: HasCallStack => IO ()
|
||||
testTwoUsers = do
|
||||
let nc = netCfg initAgentServers
|
||||
a <- getSMPAgentClient agentCfg initAgentServers
|
||||
@@ -1021,12 +1007,13 @@ testTwoUsers = do
|
||||
exchangeGreetingsMsgId 8 a bId2 b aId2
|
||||
exchangeGreetingsMsgId 8 a bId2' b aId2'
|
||||
where
|
||||
hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO ()
|
||||
hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n
|
||||
|
||||
exchangeGreetings :: AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
||||
exchangeGreetings :: HasCallStack => AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
||||
exchangeGreetings = exchangeGreetingsMsgId 4
|
||||
|
||||
exchangeGreetingsMsgId :: Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
||||
exchangeGreetingsMsgId :: HasCallStack => Int64 -> AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO ()
|
||||
exchangeGreetingsMsgId msgId alice bobId bob aliceId = do
|
||||
msgId1 <- sendMessage alice bobId SMP.noMsgFlags "hello"
|
||||
liftIO $ msgId1 `shouldBe` msgId
|
||||
|
||||
@@ -1,4 +1,7 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module CoreTests.EncodingTests where
|
||||
|
||||
@@ -10,7 +13,9 @@ import Data.Int (Int64)
|
||||
import Data.Time.Clock.System (SystemTime (..), getSystemTime, utcToSystemTime)
|
||||
import Data.Time.ISO8601 (parseISO8601)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck (modifyMaxSuccess)
|
||||
import Test.QuickCheck
|
||||
@@ -39,8 +44,36 @@ encodingTests = modifyMaxSuccess (const 1000) $ do
|
||||
testSystemTime t'
|
||||
it "parse(encode(SystemTime) should equal the same Int64" . property $
|
||||
\i -> parseAll smpP (smpEncode i) == Right (i :: Int64)
|
||||
describe "Encoding transport hosts" $ do
|
||||
describe "domain name hosts" $ do
|
||||
it "should encode / decode domain name" $ THDomainName "smp.simplex.im" #==# "smp.simplex.im"
|
||||
it "should not allow whitespace or punctuation" $ do
|
||||
shouldNotParse @TransportHost "smp,simplex.im" "endOfInput"
|
||||
shouldNotParse @TransportHost "smp:simplex.im" "endOfInput"
|
||||
shouldNotParse @TransportHost "smp#simplex.im" "endOfInput"
|
||||
shouldNotParse @TransportHost "smp simplex.im" "endOfInput"
|
||||
shouldNotParse @TransportHost "smp\nsimplex.im" "endOfInput"
|
||||
describe "onion hosts" $ do
|
||||
it "should encode / decode onion host" $ THOnionHost "beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion" #==# "beccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion"
|
||||
it "should only allow latin letters and digits" $ do
|
||||
shouldNotParse @TransportHost "beccx4yfxxbvyhqypaavemqurytl 6hozr47wfc7uuecacjqdvwpw2xid.onion" "endOfInput"
|
||||
shouldNotParse @TransportHost "beccx4yfxxbvyhqypaavemqurytl\n6hozr47wfc7uuecacjqdvwpw2xid.onion" "endOfInput"
|
||||
shouldNotParse @TransportHost "bèccx4yfxxbvyhqypaavemqurytl6hozr47wfc7uuecacjqdvwpw2xid.onion" "Failed reading: empty"
|
||||
describe "IP address hosts" $ do
|
||||
it "should encode / decode IP address" $ THIPv4 (192, 168, 0, 1) #==# "192.168.0.1"
|
||||
it "should be valid" $ do
|
||||
THDomainName "192.168.1" #==# "192.168.1"
|
||||
THDomainName "192.256.0.1" #==# "192.256.0.1"
|
||||
THDomainName "192.168.0.-1" #==# "192.168.0.-1"
|
||||
shouldNotParse @TransportHost "192.168.0.0.1" "endOfInput"
|
||||
where
|
||||
testSystemTime :: SystemTime -> Expectation
|
||||
testSystemTime t = do
|
||||
smpEncode t `shouldBe` smpEncode (systemSeconds t)
|
||||
parseAll smpP (smpEncode t) `shouldBe` Right t {systemNanoseconds = 0}
|
||||
smpDecode (smpEncode t) `shouldBe` Right t {systemNanoseconds = 0}
|
||||
(#==#) :: (StrEncoding s, Eq s, Show s) => s -> ByteString -> Expectation
|
||||
(#==#) x s = do
|
||||
strEncode x `shouldBe` s
|
||||
strDecode s `shouldBe` Right x
|
||||
shouldNotParse :: forall s. (StrEncoding s, Eq s, Show s) => ByteString -> String -> Expectation
|
||||
shouldNotParse s err = strDecode s `shouldBe` (Left err :: Either String s)
|
||||
|
||||
+16
-15
@@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
@@ -91,25 +92,25 @@ cfg =
|
||||
logTLSErrors = True
|
||||
}
|
||||
|
||||
withSmpServerStoreMsgLogOnV2 :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
|
||||
withSmpServerStoreMsgLogOnV2 :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withSmpServerStoreMsgLogOnV2 t = withSmpServerConfigOn t cfgV2 {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile}
|
||||
|
||||
withSmpServerStoreMsgLogOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
|
||||
withSmpServerStoreMsgLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withSmpServerStoreMsgLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile, serverStatsBackupFile = Just testServerStatsBackupFile}
|
||||
|
||||
withSmpServerStoreLogOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
|
||||
withSmpServerStoreLogOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withSmpServerStoreLogOn t = withSmpServerConfigOn t cfg {storeLogFile = Just testStoreLogFile, serverStatsBackupFile = Just testServerStatsBackupFile}
|
||||
|
||||
withSmpServerConfigOn :: ATransport -> ServerConfig -> ServiceName -> (ThreadId -> IO a) -> IO a
|
||||
withSmpServerConfigOn :: HasCallStack => ATransport -> ServerConfig -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withSmpServerConfigOn t cfg' port' =
|
||||
serverBracket
|
||||
(\started -> runSMPServerBlocking started cfg' {transports = [(port', t)]})
|
||||
(pure ())
|
||||
|
||||
withSmpServerThreadOn :: ATransport -> ServiceName -> (ThreadId -> IO a) -> IO a
|
||||
withSmpServerThreadOn :: HasCallStack => ATransport -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a
|
||||
withSmpServerThreadOn t = withSmpServerConfigOn t cfg
|
||||
|
||||
serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a
|
||||
serverBracket :: (HasCallStack, MonadUnliftIO m) => (TMVar Bool -> m ()) -> m () -> (HasCallStack => ThreadId -> m a) -> m a
|
||||
serverBracket process afterProcess f = do
|
||||
started <- newEmptyTMVarIO
|
||||
E.bracket
|
||||
@@ -122,16 +123,16 @@ serverBracket process afterProcess f = do
|
||||
Nothing -> error $ "server did not " <> s
|
||||
_ -> pure ()
|
||||
|
||||
withSmpServerOn :: ATransport -> ServiceName -> IO a -> IO a
|
||||
withSmpServerOn :: HasCallStack => ATransport -> ServiceName -> IO a -> IO a
|
||||
withSmpServerOn t port' = withSmpServerThreadOn t port' . const
|
||||
|
||||
withSmpServer :: ATransport -> IO a -> IO a
|
||||
withSmpServer :: HasCallStack => ATransport -> IO a -> IO a
|
||||
withSmpServer t = withSmpServerOn t testPort
|
||||
|
||||
runSmpTest :: forall c a. Transport c => (THandle c -> IO a) -> IO a
|
||||
runSmpTest :: forall c a. (HasCallStack, Transport c) => (HasCallStack => THandle c -> IO a) -> IO a
|
||||
runSmpTest test = withSmpServer (transport @c) $ testSMPClient test
|
||||
|
||||
runSmpTestN :: forall c a. Transport c => Int -> ([THandle c] -> IO a) -> IO a
|
||||
runSmpTestN :: forall c a. (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] -> IO a) -> IO a
|
||||
runSmpTestN nClients test = withSmpServer (transport @c) $ run nClients []
|
||||
where
|
||||
run :: Int -> [THandle c] -> IO a
|
||||
@@ -154,25 +155,25 @@ smpServerTest _ t = runSmpTest $ \h -> tPut' h t >> tGet' h
|
||||
[(Nothing, _, (CorrId corrId, qId, Right cmd))] <- tGet h
|
||||
pure (Nothing, corrId, qId, cmd)
|
||||
|
||||
smpTest :: Transport c => TProxy c -> (THandle c -> IO ()) -> Expectation
|
||||
smpTest :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> IO ()) -> Expectation
|
||||
smpTest _ test' = runSmpTest test' `shouldReturn` ()
|
||||
|
||||
smpTestN :: Transport c => Int -> ([THandle c] -> IO ()) -> Expectation
|
||||
smpTestN :: (HasCallStack, Transport c) => Int -> (HasCallStack => [THandle c] -> IO ()) -> Expectation
|
||||
smpTestN n test' = runSmpTestN n test' `shouldReturn` ()
|
||||
|
||||
smpTest2 :: Transport c => TProxy c -> (THandle c -> THandle c -> IO ()) -> Expectation
|
||||
smpTest2 :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> IO ()) -> Expectation
|
||||
smpTest2 _ test' = smpTestN 2 _test
|
||||
where
|
||||
_test [h1, h2] = test' h1 h2
|
||||
_test _ = error "expected 2 handles"
|
||||
|
||||
smpTest3 :: Transport c => TProxy c -> (THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
|
||||
smpTest3 :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
|
||||
smpTest3 _ test' = smpTestN 3 _test
|
||||
where
|
||||
_test [h1, h2, h3] = test' h1 h2 h3
|
||||
_test _ = error "expected 3 handles"
|
||||
|
||||
smpTest4 :: Transport c => TProxy c -> (THandle c -> THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
|
||||
smpTest4 :: (HasCallStack, Transport c) => TProxy c -> (HasCallStack => THandle c -> THandle c -> THandle c -> THandle c -> IO ()) -> Expectation
|
||||
smpTest4 _ test' = smpTestN 4 _test
|
||||
where
|
||||
_test [h1, h2, h3, h4] = test' h1 h2 h3 h4
|
||||
|
||||
+15
-14
@@ -23,19 +23,20 @@ main :: IO ()
|
||||
main = do
|
||||
setLogLevel LogError -- LogInfo
|
||||
withGlobalLogging logCfg $ do
|
||||
createDirectoryIfMissing False "tests/tmp"
|
||||
setEnv "APNS_KEY_ID" "H82WD9K9AQ"
|
||||
setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8"
|
||||
hspec $ do
|
||||
describe "Core tests" $ do
|
||||
describe "Encoding tests" encodingTests
|
||||
describe "Protocol error tests" protocolErrorTests
|
||||
describe "Version range" versionRangeTests
|
||||
describe "Encryption tests" cryptoTests
|
||||
describe "Retry interval tests" retryIntervalTests
|
||||
describe "SMP server via TLS" $ serverTests (transport @TLS)
|
||||
describe "SMP server via WebSockets" $ serverTests (transport @WS)
|
||||
describe "Notifications server" $ ntfServerTests (transport @TLS)
|
||||
describe "SMP client agent" $ agentTests (transport @TLS)
|
||||
describe "Server CLIs" cliTests
|
||||
removeDirectoryRecursive "tests/tmp"
|
||||
hspec
|
||||
. before_ (createDirectoryIfMissing False "tests/tmp")
|
||||
. after_ (removeDirectoryRecursive "tests/tmp")
|
||||
$ do
|
||||
describe "Core tests" $ do
|
||||
describe "Encoding tests" encodingTests
|
||||
describe "Protocol error tests" protocolErrorTests
|
||||
describe "Version range" versionRangeTests
|
||||
describe "Encryption tests" cryptoTests
|
||||
describe "Retry interval tests" retryIntervalTests
|
||||
describe "SMP server via TLS" $ serverTests (transport @TLS)
|
||||
describe "SMP server via WebSockets" $ serverTests (transport @WS)
|
||||
describe "Notifications server" $ ntfServerTests (transport @TLS)
|
||||
describe "SMP client agent" $ agentTests (transport @TLS)
|
||||
describe "Server CLIs" cliTests
|
||||
|
||||
Reference in New Issue
Block a user