diff --git a/CHANGELOG.md b/CHANGELOG.md index 28921a626..40a50a845 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: diff --git a/package.yaml b/package.yaml index 04d8c773d..9af86a4ca 100644 --- a/package.yaml +++ b/package.yaml @@ -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>, diff --git a/simplexmq.cabal b/simplexmq.cabal index f60c6ab93..0afb992a9 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -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 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index d45f15c43..e132cab41 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index b683a2786..400e58c14 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -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 diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index a8d7a7bab..810f68b6d 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -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)) diff --git a/src/Simplex/Messaging/Transport/Client.hs b/src/Simplex/Messaging/Transport/Client.hs index f7af991a4..1a7f81992 100644 --- a/src/Simplex/Messaging/Transport/Client.hs +++ b/src/Simplex/Messaging/Transport/Client.hs @@ -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 diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 1a5c9c485..fdf931df0 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -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 diff --git a/tests/CoreTests/EncodingTests.hs b/tests/CoreTests/EncodingTests.hs index 52ed73807..a89499777 100644 --- a/tests/CoreTests/EncodingTests.hs +++ b/tests/CoreTests/EncodingTests.hs @@ -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) diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index b005699d3..8fb553bf1 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -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 diff --git a/tests/Test.hs b/tests/Test.hs index c710a58df..287d5b50b 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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