From bb32c9caad6ad88db16140206c34445ac8c2a741 Mon Sep 17 00:00:00 2001 From: "Evgeny @ SimpleX Chat" <259188159+evgeny-simplex@users.noreply.github.com> Date: Thu, 8 Oct 2026 14:19:58 +0000 Subject: [PATCH] tests: execute in parallel --- simplexmq.cabal | 2 +- src/Simplex/FileTransfer/Agent.hs | 11 +- src/Simplex/Messaging/Agent.hs | 88 ++-- src/Simplex/Messaging/Agent/Client.hs | 2 +- src/Simplex/Messaging/Agent/Protocol.hs | 3 + src/Simplex/Messaging/Agent/Store.hs | 1 + .../Messaging/Agent/Store/AgentStore.hs | 5 + src/Simplex/Messaging/Client.hs | 6 +- tests/AgentTests.hs | 19 +- tests/AgentTests/FunctionalAPITests.hs | 416 ++++++++++-------- tests/AgentTests/NotificationTests.hs | 54 +-- tests/AgentTests/ResolveNameTests.hs | 30 +- tests/AgentTests/ServerChoice.hs | 4 +- tests/CLITests.hs | 42 +- tests/CoreTests/CryptoFileTests.hs | 16 +- tests/CoreTests/CryptoTests.hs | 8 +- tests/CoreTests/MsgStoreTests.hs | 73 ++- tests/CoreTests/StoreLogTests.hs | 8 +- tests/CoreTests/XFTPStoreTests.hs | 32 +- tests/FileDescriptionTests.hs | 10 +- tests/NamesResolverServer.hs | 7 +- tests/NtfClient.hs | 58 +-- tests/NtfServerTests.hs | 4 +- tests/RSLVTests.hs | 44 +- tests/SMPAgentClient.hs | 60 +-- tests/SMPClient.hs | 151 +++---- tests/SMPProxyTests.hs | 116 ++--- tests/ServerTests.hs | 25 +- tests/Test.hs | 214 ++++----- tests/Util.hs | 99 ++++- tests/XFTPAgent.hs | 93 ++-- tests/XFTPCLI.hs | 48 +- tests/XFTPClient.hs | 93 ++-- tests/XFTPServerTests.hs | 101 +++-- tests/XFTPWebTests.hs | 49 +-- 35 files changed, 1083 insertions(+), 909 deletions(-) diff --git a/simplexmq.cabal b/simplexmq.cabal index ef46fb723..b0183c30c 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -600,7 +600,7 @@ test-suite simplexmq-test default-extensions: StrictData -- add -fhpc to ghc-options to run tests with coverage - ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N1 + ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -O2 -threaded -rtsopts -with-rtsopts=-A64M -with-rtsopts=-N build-depends: base , aeson diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs index b0e8c056a..f31922117 100644 --- a/src/Simplex/FileTransfer/Agent.hs +++ b/src/Simplex/FileTransfer/Agent.hs @@ -279,6 +279,7 @@ retryOnError name loop done e = do rcvWorkerInternalError :: AgentClient -> DBRcvFileId -> RcvFileId -> Maybe RcvFileId -> Maybe FilePath -> AgentErrorType -> AM () rcvWorkerInternalError c rcvFileId rcvFileEntityId redirectEntityId_ tmpPath err = do + liftIO $ throwWhenInactive c lift $ forM_ tmpPath (removePath <=< toFSFilePath) withStore' c $ \db -> updateRcvFileError db rcvFileId (show err) notify c (fromMaybe rcvFileEntityId redirectEntityId_) (RFERR err) @@ -318,9 +319,6 @@ runXFTPRcvLocalWorker c Worker {doWork} = do withStore' c (`updateRcvFileComplete` rcvFileId) Just RcvFileRedirect {redirectFileInfo, redirectDbId} -> do let RedirectFileInfo {size = redirectSize, digest = redirectDigest} = redirectFileInfo - lift $ forM_ tmpPath (removePath <=< toFSFilePath) - liftIO $ waitUntilForeground c - withStore' c (`updateRcvFileComplete` rcvFileId) -- proceed with redirect yaml <- liftError (FILE . FILE_IO . show) (CF.readFile $ CryptoFile fsSavePath cfArgs) `allFinally` (lift $ toFSFilePath fsSavePath >>= removePath) next@FileDescription {chunks = nextChunks} <- case strDecode (LB.toStrict yaml) of @@ -330,9 +328,12 @@ runXFTPRcvLocalWorker c Worker {doWork} = do | dstSize /= redirectSize -> throwE . FILE $ REDIRECT "size mismatch" | dstDigest /= redirectDigest -> throwE . FILE $ REDIRECT "digest mismatch" | otherwise -> pure fd + liftIO $ waitUntilForeground c -- register and download chunks from the actual file - withStore c $ \db -> updateRcvFileRedirect db redirectDbId next + withStore c $ \db -> updateRcvFileComplete db rcvFileId >> updateRcvFileRedirect db redirectDbId next forM_ nextChunks (downloadChunk c) + flip catchAllErrors (\e -> logError $ "XFTP rcv worker error: " <> tshow e) $ + lift $ forM_ tmpPath (removePath <=< toFSFilePath) where getChunkPaths :: [RcvFileChunk] -> AM [FilePath] getChunkPaths [] = pure [] @@ -512,6 +513,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do sndWorkerInternalError :: AgentClient -> DBSndFileId -> SndFileId -> Maybe FilePath -> AgentErrorType -> AM () sndWorkerInternalError c sndFileId sndFileEntityId prefixPath err = do + liftIO $ throwWhenInactive c lift . forM_ prefixPath $ removePath <=< toFSFilePath withStore' c $ \db -> updateSndFileError db sndFileId (show err) notify c sndFileEntityId $ SFERR err @@ -733,6 +735,7 @@ runXFTPDelWorker c srv Worker {doWork} = do delWorkerInternalError :: AgentClient -> Int64 -> AgentErrorType -> AM () delWorkerInternalError c deletedSndChunkReplicaId e = do + liftIO $ throwWhenInactive c withStore' c $ \db -> deleteDeletedSndChunkReplica db deletedSndChunkReplicaId notify c "" $ SFERR e diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 05df98ecc..3226aad1a 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -2295,9 +2295,9 @@ runCommandProcessing c@AgentClient {subQ} connId server_ Worker {doWork} = do -- we may add more statistics special to queue rotation later on, -- not accounting secure during rotation for now: -- atomically $ incSMPServerStat c userId server connSecured - withStore' c $ \db -> setRcvQueueStatus db rq' Secured + rq1' <- withStore' c $ \db -> setRcvQueueStatus db rq' Secured >> setRcvSwitchStatus db rq1 (Just RSSendingQUSE) void . enqueueMessages c cData sqs SMP.noMsgFlags $ QUSE [((server, sndId), True)] - rq1' <- withStore' c $ \db -> setRcvSwitchStatus db rq1 (Just RSSendingQUSE) <* deleteCommand db cmdId + withStore' c (`deleteCommand` cmdId) let rqs' = updatedQs rq1' rqs conn' = DuplexConnection cData rqs' sqs cStats <- connectionStats c conn' @@ -2893,22 +2893,27 @@ synchronizeRatchet' c connId pqSupport' force = withConnLock c connId "synchroni _ -> throwE $ CMD PROHIBITED "synchronizeRatchet: not duplex" ackQueueMessage :: AgentClient -> RcvQueue -> SMP.MsgId -> AM (Maybe ATransmission) -ackQueueMessage c rq@RcvQueue {userId, connId, server} srvMsgId = do +ackQueueMessage c rq@RcvQueue {userId, connId, server, rcvSwchStatus} srvMsgId = do atomically $ incSMPServerStat c userId server ackAttempts tryAllErrors (sendAck c rq srvMsgId) >>= \case - Right _ -> sendMsgNtf ackMsgs - Left (SMP _ SMP.NO_MSG) -> sendMsgNtf ackNoMsgErrs + Right msg_ -> sendMsgNtf ackMsgs $ isNothing msg_ && rcvSwchStatus == Just RSReceivedQEND + Left (SMP _ SMP.NO_MSG) -> sendMsgNtf ackNoMsgErrs False Left e -> do unless (temporaryOrHostError e) $ atomically $ incSMPServerStat c userId server ackOtherErrs throwE e where - sendMsgNtf stat = do + sendMsgNtf stat drained = do atomically $ incSMPServerStat c userId server stat ifM (liftIO $ hasGetLock c rq) (do atomically $ releaseGetLock c rq brokerTs_ <- eitherToMaybe <$> tryAllErrors (withStore c $ \db -> getRcvMsgBrokerTs db connId srvMsgId) pure $ Just ("", connId, AEvt SAEConn $ MSGNTF srvMsgId brokerTs_)) - (pure Nothing) + (Nothing <$ when drained (deleteRcvQueueAsync c rq)) + +deleteRcvQueueAsync :: AgentClient -> RcvQueue -> AM () +deleteRcvQueueAsync c rq@RcvQueue {connId, server, rcvId} = do + withStore' c (`setRcvQueueDeleted` rq) + enqueueCommand c "" connId (Just server) $ AInternalCommand $ ICDeleteRcvQueue rcvId -- | Suspend SMP agent connection (OFF command) in Reader monad suspendConnection' :: AgentClient -> NetworkRequestMode -> ConnId -> AM () @@ -3438,6 +3443,7 @@ cleanupManager c@AgentClient {subQ} = do run SFERR deleteSndFilesPrefixPaths run SFERR deleteExpiredReplicasForDeletion run ERR deleteExpiredServiceReqs + run ERR expireEndedRcvQueues liftIO $ threadDelay' int where run :: forall e. AEntityI e => (AgentErrorType -> AEvent e) -> AM () -> AM' () @@ -3495,6 +3501,20 @@ cleanupManager c@AgentClient {subQ} = do deleteExpiredServiceRequests db $ addUTCTime (negate serviceResponseTimeout) now getExpiredServiceConns db now deleteConnectionsAsync' c False expiredConns + expireEndedRcvQueues = do + maxErrs <- asks $ deleteErrorCount . config + connIds <- withStore' c getEndedRcvQueueConnIds + forM_ connIds $ \connId -> flip catchAllErrors (notify connId . ERR) $ + withConnLock c connId "cleanupManager" $ + withStore c (`getConn` connId) >>= \case + SomeConn _ (DuplexConnection _ rqs _) -> do + let (ended, current) = L.partition ((Just RSReceivedQEND ==) . rcvSwchStatus) rqs + whenM (anyM $ map (atomically . hasActiveSubscription c) current) $ + forM_ ended $ \rq -> + if deleteErrors rq + 1 < maxErrs + then withStore' c (`incRcvDeleteErrors` rq) + else deleteRcvQueueAsync c rq + _ -> pure () notify :: forall e. AEntityI e => AEntityId -> AEvent e -> AM () notify entId cmd = atomically $ writeTBQueue subQ ("", entId, AEvt (sAEntity @e) cmd) @@ -4027,21 +4047,21 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar liftIO $ mapM_ (deleteConnSndQueue db connId) delSqs addConnSndQueue db connId (sq_ :: NewSndQueue) {primary = True, dbReplaceQueueId = Just dbQueueId} logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId <> " " <> logSecret (senderId queueAddress) - swchStatus <- - if connAgentVersion >= rpcAddressSMPAgentVersion - then do - withStore' c $ \db -> copyPendingSndDeliveries db sq sq2 - enqueueCommand c "" connId (Just $ qServer sq2) $ AInternalCommand $ ICQSndSecure (snd $ qAddress sq2) - pure SSSecuringQueue - else do - let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} - void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', C.toPublic sndPrivateKey)] - pure SSSendingQKEY - sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just swchStatus - let sqs'' = updatedQs sq1 sqs' <> [sq2] - conn' = DuplexConnection cData' rqs sqs'' - cStats <- connectionStats c conn' - notify $ SWITCH QDSnd SPStarted cStats + let switchStarted swchStatus = do + sq1 <- withStore' c $ \db -> setSndSwitchStatus db sq $ Just swchStatus + let sqs'' = updatedQs sq1 sqs' <> [sq2] + conn' = DuplexConnection cData' rqs sqs'' + cStats <- connectionStats c conn' + notify $ SWITCH QDSnd SPStarted cStats + if connAgentVersion >= rpcAddressSMPAgentVersion + then do + withStore' c $ \db -> copyPendingSndDeliveries db sq sq2 + enqueueCommand c "" connId (Just $ qServer sq2) $ AInternalCommand $ ICQSndSecure (snd $ qAddress sq2) + switchStarted SSSecuringQueue + else do + switchStarted SSSendingQKEY + let sqInfo' = (sqInfo :: SMPQueueInfo) {queueAddress = queueAddress {dhPublicKey}} + void . enqueueMessages c cData' sqs SMP.noMsgFlags $ QKEY [(sqInfo', C.toPublic sndPrivateKey)] _ -> qError "QADD: won't delete all snd queues in connection" _ -> qError "QADD: replaced queue address is not found in connection" _ -> throwE $ AGENT A_VERSION @@ -4094,19 +4114,23 @@ processSMPTransmissions c@AgentClient {subQ} (tSess@(userId, srv, _), THandlePar -- processed by queue recipient qEndMsg :: SMP.MsgId -> NonEmpty SndQAddr -> Connection 'CDuplex -> AM () qEndMsg srvMsgId addrs (DuplexConnection cData'@ConnData {enableNtfs} rqs sqs) = - case L.partition (\rq' -> any (`sameQAddress` sndAddress rq') addrs) rqs of + case L.partition isRemoved rqs of (removed@(_ : _), keptRq : keptRqs) -> do logServer "<--" c srv rId $ "MSG :" <> logSecret' srvMsgId - forM_ removed $ \rq'@RcvQueue {server = rmServer, rcvId} -> do - withStore' c $ \db -> setRcvQueueDeleted db rq' - enqueueCommand c "" connId (Just rmServer) $ AInternalCommand $ ICDeleteRcvQueue rcvId - when enableNtfs $ do - ns <- asks ntfSupervisor - liftIO $ sendNtfSubCommand ns (NSCCreate, [connId]) - let conn' = DuplexConnection cData' (keptRq :| keptRqs) sqs - cStats <- connectionStats c conn' - notify $ SWITCH QDRcv SPCompleted cStats + let completed = any ((Just RSReceivedQEND ==) . rcvSwchStatus) removed + if isRemoved rq + then mapM_ (deleteRcvQueueAsync c) removed + else withStore' c $ \db -> forM_ removed $ \rq' -> setRcvSwitchStatus db rq' $ Just RSReceivedQEND + unless completed $ do + when enableNtfs $ do + ns <- asks ntfSupervisor + liftIO $ sendNtfSubCommand ns (NSCCreate, [connId]) + let conn' = DuplexConnection cData' (keptRq :| keptRqs) sqs + cStats <- connectionStats c conn' + notify $ SWITCH QDRcv SPCompleted cStats _ -> pure () + where + isRemoved rq' = any (`sameQAddress` sndAddress rq') addrs qError :: String -> AM a qError = throwE . AGENT . A_QUEUE diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index 3d8f8c1bd..d6624cf17 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -2080,7 +2080,7 @@ disableQueuesNtfs c = sendTSessionBatches "NDEL" (mkSMPTSession . snd) disableQu queueCreds :: DisableQueueNtfReq -> (SMP.RecipientId, SMP.RcvPrivateAuthKey) queueCreds (_, RcvQueue {rcvPrivateKey, rcvId}) = (rcvId, rcvPrivateKey) -sendAck :: AgentClient -> RcvQueue -> MsgId -> AM () +sendAck :: AgentClient -> RcvQueue -> MsgId -> AM (Maybe SMP.RcvMessage) sendAck c rq@RcvQueue {rcvId, rcvPrivateKey} msgId = withSMPClient c NRMBackground rq ("ACK:" <> logSecret' msgId) $ \smp -> ackSMPMessage smp rcvPrivateKey rcvId msgId diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index 5f7977e45..3ea9f3b1a 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -612,6 +612,7 @@ data RcvSwitchStatus | RSSendingQADD | RSSendingQUSE | RSReceivedMessage + | RSReceivedQEND deriving (Eq, Show) instance StrEncoding RcvSwitchStatus where @@ -620,12 +621,14 @@ instance StrEncoding RcvSwitchStatus where RSSendingQADD -> "sending_qadd" RSSendingQUSE -> "sending_quse" RSReceivedMessage -> "received_message" + RSReceivedQEND -> "received_qend" strP = A.takeTill (== ' ') >>= \case "switch_started" -> pure RSSwitchStarted "sending_qadd" -> pure RSSendingQADD "sending_quse" -> pure RSSendingQUSE "received_message" -> pure RSReceivedMessage + "received_qend" -> pure RSReceivedQEND _ -> fail "bad RcvSwitchStatus" instance ToField RcvSwitchStatus where toField = toField . decodeLatin1 . strEncode diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index e75cdb05e..67415c718 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -219,6 +219,7 @@ canAbortRcvSwitch ConnData {connAgentVersion} = maybe False canAbort . rcvSwchSt -- if switch is in RSReceivedMessage status, aborting switch (deleting new queue) -- will break the connection because the sender would have original queue deleted RSReceivedMessage -> False + RSReceivedQEND -> False data ClientNtfCreds = ClientNtfCreds { -- | key pair to be used by the notification server to authorize transmissions diff --git a/src/Simplex/Messaging/Agent/Store/AgentStore.hs b/src/Simplex/Messaging/Agent/Store/AgentStore.hs index 21c087d46..c6d8c503b 100644 --- a/src/Simplex/Messaging/Agent/Store/AgentStore.hs +++ b/src/Simplex/Messaging/Agent/Store/AgentStore.hs @@ -100,6 +100,7 @@ module Simplex.Messaging.Agent.Store.AgentStore setSndQueuePrimary, deleteConnRcvQueue, incRcvDeleteErrors, + getEndedRcvQueueConnIds, deleteConnSndQueue, getPrimaryRcvQueue, getRcvQueue, @@ -763,6 +764,10 @@ incRcvDeleteErrors :: DB.Connection -> RcvQueue -> IO () incRcvDeleteErrors db RcvQueue {connId, dbQueueId} = DB.execute db "UPDATE rcv_queues SET delete_errors = delete_errors + 1 WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) +getEndedRcvQueueConnIds :: DB.Connection -> IO [ConnId] +getEndedRcvQueueConnIds db = + map fromOnly <$> DB.query db "SELECT conn_id FROM rcv_queues WHERE switch_status = ? AND deleted = 0" (Only RSReceivedQEND) + deleteConnRcvQueue :: DB.Connection -> RcvQueue -> IO () deleteConnRcvQueue db RcvQueue {connId, dbQueueId} = DB.execute db "DELETE FROM rcv_queues WHERE conn_id = ? AND rcv_queue_id = ?" (connId, dbQueueId) diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index 7a2eedeb9..e2341f931 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -1091,11 +1091,11 @@ resolvedNameOrNotFound d NameResponse {registration} = case registration of -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#acknowledge-message-delivery -- This command is always sent in background request mode -ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO () +ackSMPMessage :: SMPClient -> RcvPrivateAuthKey -> QueueId -> MsgId -> ExceptT SMPClientError IO (Maybe RcvMessage) ackSMPMessage c rpKey rId msgId = sendSMPCommand c NRMBackground (Just rpKey) rId (ACK msgId) >>= \case - OK -> return () - cmd@MSG {} -> liftIO $ writeSMPMessage c rId cmd + OK -> pure Nothing + cmd@(MSG msg) -> liftIO (writeSMPMessage c rId cmd) $> Just msg r -> throwE $ unexpectedResponse r -- | Irreversibly suspend SMP queue. diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 36dc92a95..80539aa49 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -19,17 +19,12 @@ import Simplex.Messaging.Server.Env.STM (AStoreType (..)) import Simplex.Messaging.Transport (ASrvTransport) import Test.Hspec hiding (fit, it) -#if defined(dbPostgres) -import Fixtures -import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) -#else +#if !defined(dbPostgres) import AgentTests.SQLiteTests (storeTests) #endif #if defined(dbServerPostgres) import AgentTests.NotificationTests (notificationTests) -import SMPClient (postgressBracket) -import NtfClient (ntfTestServerDBConnectInfo) #endif agentCoreTests :: Spec @@ -42,16 +37,10 @@ agentCoreTests = do agentTests :: (ASrvTransport, AStoreType) -> Spec agentTests ps = do -#if defined(dbPostgres) - after_ (dropAllSchemasExceptSystem testDBConnectInfo) $ do -#else - do -#endif - describe "Functional API" $ functionalAPITests ps - describe "Chosen servers" serverChoiceTests + describe "Functional API" $ functionalAPITests ps + describe "Chosen servers" serverChoiceTests #if defined(dbServerPostgres) - around_ (postgressBracket ntfTestServerDBConnectInfo) $ - describe "Notification tests" $ notificationTests ps + describe "Notification tests" $ notificationTests ps #endif #if !defined(dbPostgres) describe "SQLite store" storeTests diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 0467306f5..040a8700e 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -20,6 +20,7 @@ module AgentTests.FunctionalAPITests ( functionalAPITests, + functionalAPITimingTests, testServerMatrix2, withAgentClientsCfg2, withAgentClientsCfgServers2, @@ -230,7 +231,7 @@ pattern Rcvd agentMsgId <- RCVD MsgMeta {integrity = MsgOk} [MsgReceipt {agentMs pattern Rcvd' :: AgentMsgId -> AgentMsgId -> AEvent 'AEConn pattern Rcvd' aMsgId rcvdMsgId <- RCVD MsgMeta {integrity = MsgOk, recipient = (aMsgId, _)} [MsgReceipt {agentMsgId = rcvdMsgId, msgRcptStatus = MROk}] -smpCfgVPrev :: ProtocolClientConfig SMPVersion +smpCfgVPrev :: HasTestEnv => ProtocolClientConfig SMPVersion smpCfgVPrev = (smpCfg agentCfg) { serverVRange = prevRange $ serverVRange $ smpCfg agentCfg, @@ -241,10 +242,10 @@ smpCfgVPrev = -- ntfCfgVPrev = (ntfCfg agentCfg) {clientALPN = Nothing, serverVRange = V.mkVersionRange (VersionNTF 1) (VersionNTF 1)} -- currently, previous e2e version is not supported -agentCfgVPrev :: AgentConfig +agentCfgVPrev :: HasTestEnv => AgentConfig agentCfgVPrev = agentCfgVPrevPQ -- {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} -agentCfgVPrevPQ :: AgentConfig +agentCfgVPrevPQ :: HasTestEnv => AgentConfig agentCfgVPrevPQ = agentCfg { sndAuthAlg = C.AuthAlg C.SEd25519, @@ -254,7 +255,7 @@ agentCfgVPrevPQ = -- ntfCfg = ntfCfgVPrev -- previous version is not supported } -agentCfgRatchetVPrev :: AgentConfig +agentCfgRatchetVPrev :: HasTestEnv => AgentConfig agentCfgRatchetVPrev = agentCfg {e2eEncryptVRange = prevRange $ e2eEncryptVRange agentCfg} mkVersionRange :: Word16 -> Word16 -> VersionRange v @@ -550,6 +551,10 @@ functionalAPITests ps = do testServerMatrix2 ps testFastSwitchConnection it "should switch delivery to the new queue when the old server is down" $ testFastSwitchDeadOldServer ps + it "should drain the old queue after QEND on the new queue" $ + testFastSwitchDrainOldQueue ps + it "should drain the old queue after QEND on the new queue and restart" $ + testFastSwitchDrainOldQueueRestart ps describe "should switch delivery to the new queue" $ testServerMatrix2 ps testSwitchConnection describe "should switch to new queue asynchronously" $ @@ -587,12 +592,15 @@ functionalAPITests ps = do it "auth, disabled" $ testBasicAuth ps False (Nothing, v) (Just "abcd", v) (Just "abcd", v) sqSecured baseId `shouldReturn` 0 describe "SMP server test via agent API" $ do it "should pass without basic auth" $ testSMPServerConnectionTest ps Nothing (noAuthSrv testSMPServer2) `shouldReturn` Right (Just (Right testServerInformation)) - let srv1 = testSMPServer2 {keyHash = "1234"} + let srv1 :: HasTestEnv => SMPServer + srv1 = testSMPServer2 {keyHash = "1234"} it "should fail with incorrect fingerprint" $ do testSMPServerConnectionTest ps Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) describe "server with password" $ do let auth = Just "abcd" + srv :: HasTestEnv => Maybe BasicAuth -> SMPServerWithAuth srv = ProtoServerWithAuth testSMPServer2 + authErr :: HasTestEnv => ProtocolTestFailure authErr = ProtocolTestFailure TSCreateQueue $ SMP (B.unpack $ strEncode testSMPServer2) AUTH it "should pass with correct password" $ testSMPServerConnectionTest ps auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation)) it "should fail without password" $ testSMPServerConnectionTest ps auth (srv Nothing) `shouldReturn` Left authErr @@ -603,6 +611,9 @@ functionalAPITests ps = do describe "Delivery receipts" $ do it "should send and receive delivery receipt" $ withSmpServer ps testDeliveryReceipts it "send delivery receipts concurrently with messages" $ testDeliveryReceiptsConcurrent ps + +functionalAPITimingTests :: (ASrvTransport, AStoreType) -> Spec +functionalAPITimingTests ps = do describe "user network info" $ do it "should wait for user network" testWaitForUserNetwork it "should not reset online to offline if happens too quickly" testDoNotResetOnlineToOffline @@ -615,7 +626,7 @@ functionalAPITests ps = do it "should create client notice" $ testClientNotice ps #endif -testBasicAuth :: (ASrvTransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int +testBasicAuth :: HasTestEnv => (ASrvTransport, AStoreType) -> Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int testBasicAuth (t, msType) allowNewQueues srv@(srvAuth, srvVersion) clnt1 clnt2 sqSecured baseId = do let testCfg = updateCfg (cfgMS msType) $ \cfg' -> cfg' {allowNewQueues, newQueueBasicAuth = srvAuth, smpServerVRange = V.mkVersionRange minServerSMPRelayVersion srvVersion} canCreate1 = canCreateQueue allowNewQueues srv clnt1 @@ -632,7 +643,7 @@ canCreateQueue :: Bool -> (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, Ver canCreateQueue allowNew (srvAuth, _) (clntAuth, _) = allowNew && (isNothing srvAuth || srvAuth == clntAuth) -testMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (HasTestEnv => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2 ps runTest = do it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True it "current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False @@ -640,7 +651,7 @@ testMatrix2 ps runTest = do it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrev agentCfg 1 $ runTest PQSupportOff True False it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrev 1 $ runTest PQSupportOff True False -testMatrix2Stress :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testMatrix2Stress :: HasCallStack => (ASrvTransport, AStoreType) -> (HasTestEnv => PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testMatrix2Stress ps runTest = do it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 aCfg aCfg initAgentServersProxy 1 $ runTest PQSupportOn True it "current" $ withSmpServer ps $ runTestCfg2 aCfg aCfg 1 $ runTest PQSupportOn False @@ -648,6 +659,7 @@ testMatrix2Stress ps runTest = do it "prev to current" $ withSmpServer ps $ runTestCfg2 aCfgVPrev aCfg 1 $ runTest PQSupportOff False it "current to prev" $ withSmpServer ps $ runTestCfg2 aCfg aCfgVPrev 1 $ runTest PQSupportOff False where + aCfg, aCfgVPrev :: HasTestEnv => AgentConfig aCfg = agentCfg {messageRetryInterval = fastMessageRetryInterval} aCfgVPrev = agentCfgVPrev {messageRetryInterval = fastMessageRetryInterval} @@ -658,7 +670,7 @@ testBasicMatrix2 ps runTest = do it "prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgVPrevPQ agentCfg 1 runTest it "current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgVPrevPQ 1 runTest -testRatchetMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec +testRatchetMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (HasTestEnv => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> Spec testRatchetMatrix2 ps runTest = do it "current, via proxy" $ withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 $ runTest PQSupportOn True True it "ratchet current" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfg 1 $ runTest PQSupportOn True False @@ -666,23 +678,23 @@ testRatchetMatrix2 ps runTest = do it "ratchets prev to current" $ withSmpServer ps $ runTestCfg2 agentCfgRatchetVPrev agentCfg 1 $ runTest PQSupportOff True False it "ratchets current to prev" $ withSmpServer ps $ runTestCfg2 agentCfg agentCfgRatchetVPrev 1 $ runTest PQSupportOff True False -testServerMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (InitialAgentServers -> IO ()) -> Spec +testServerMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (HasTestEnv => InitialAgentServers -> IO ()) -> Spec testServerMatrix2 ps runTest = do it "1 server" $ withSmpServer ps $ runTest initAgentServers it "2 servers" $ withSmpServers2 ps $ runTest initAgentServers2 -testProxyMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (Bool -> AgentClient -> AgentClient -> IO ()) -> Spec +testProxyMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (HasTestEnv => Bool -> AgentClient -> AgentClient -> IO ()) -> Spec testProxyMatrix ps runTest = do it "2 servers, directly" $ withSmpServers2 ps $ withAgentClientsServers2 (agentCfg, initAgentServers) (agentCfg, initAgentServers2) $ runTest False it "2 servers, via proxy" $ withSmpServersProxy2 ps $ withAgentClientsServers2 (agentCfg, initAgentServersProxy) (agentCfg, initAgentServersProxy2) $ runTest True -testPQMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +testPQMatrix2 :: HasCallStack => (ASrvTransport, AStoreType) -> ((HasCallStack, HasTestEnv) => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2 = pqMatrix2_ True -testPQMatrix2NoInv :: HasCallStack => (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +testPQMatrix2NoInv :: HasCallStack => (ASrvTransport, AStoreType) -> ((HasCallStack, HasTestEnv) => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix2NoInv = pqMatrix2_ False -pqMatrix2_ :: HasCallStack => Bool -> (ASrvTransport, AStoreType) -> (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec +pqMatrix2_ :: HasCallStack => Bool -> (ASrvTransport, AStoreType) -> ((HasCallStack, HasTestEnv) => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec pqMatrix2_ pqInv ps test = do it "dh/dh handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOff) it "dh/pq handshake" $ runTest $ \a b -> test (a, IKPQOff) (b, PQSupportOn) @@ -692,12 +704,13 @@ pqMatrix2_ pqInv ps test = do it "pq-inv/dh handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOff) it "pq-inv/pq handshake" $ runTest $ \a b -> test (a, IKUsePQ) (b, PQSupportOn) where + runTest :: HasTestEnv => (AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () runTest = withSmpServerProxy ps . runTestCfgServers2 agentCfg agentCfg initAgentServersProxy 1 testPQMatrix3 :: HasCallStack => (ASrvTransport, AStoreType) -> - (HasCallStack => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> + ((HasCallStack, HasTestEnv) => (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO ()) -> Spec testPQMatrix3 ps test = do it "dh" $ runTest $ \a b c -> test (a, IKPQOff) (b, PQSupportOff) (c, PQSupportOff) @@ -709,52 +722,54 @@ testPQMatrix3 ps test = do it "pq/pq/dh" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOff) it "pq" $ runTest $ \a b c -> test (a, IKPQOn) (b, PQSupportOn) (c, PQSupportOn) where + runTest :: HasTestEnv => (AgentClient -> AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () runTest test' = withSmpServerProxy ps $ runTestCfgServers2 agentCfg agentCfg servers 1 $ \a b baseMsgId -> withAgent 3 agentCfg servers testDB3 $ \c -> test' a b c baseMsgId + servers :: HasTestEnv => InitialAgentServers servers = initAgentServersProxy -runTestCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () +runTestCfg2 :: (HasCallStack, HasTestEnv) => AgentConfig -> AgentConfig -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () runTestCfg2 aCfg bCfg = runTestCfgServers2 aCfg bCfg initAgentServers {-# INLINE runTestCfg2 #-} -runTestCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () +runTestCfgServers2 :: (HasCallStack, HasTestEnv) => AgentConfig -> AgentConfig -> InitialAgentServers -> AgentMsgId -> (HasCallStack => AgentClient -> AgentClient -> AgentMsgId -> IO ()) -> IO () runTestCfgServers2 aCfg bCfg servers baseMsgId runTest = withAgentClientsCfgServers2 aCfg bCfg servers $ \a b -> runTest a b baseMsgId {-# INLINE runTestCfgServers2 #-} -withAgentClientsCfgServers2 :: HasCallStack => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a +withAgentClientsCfgServers2 :: (HasCallStack, HasTestEnv) => AgentConfig -> AgentConfig -> InitialAgentServers -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a withAgentClientsCfgServers2 aCfg bCfg servers runTest = withAgent 1 aCfg servers testDB $ \a -> withAgent 2 bCfg servers testDB2 $ \b -> runTest a b -withAgentClientsServers2 :: HasCallStack => (AgentConfig, InitialAgentServers) -> (AgentConfig, InitialAgentServers) -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a +withAgentClientsServers2 :: (HasCallStack, HasTestEnv) => (AgentConfig, InitialAgentServers) -> (AgentConfig, InitialAgentServers) -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a withAgentClientsServers2 (aCfg, aServers) (bCfg, bServers) runTest = withAgent 1 aCfg aServers testDB $ \a -> withAgent 2 bCfg bServers testDB2 $ \b -> runTest a b -withAgentClientsCfg2 :: HasCallStack => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a +withAgentClientsCfg2 :: (HasCallStack, HasTestEnv) => AgentConfig -> AgentConfig -> (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a withAgentClientsCfg2 aCfg bCfg = withAgentClientsCfgServers2 aCfg bCfg initAgentServers {-# INLINE withAgentClientsCfg2 #-} -withAgentClients2 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a +withAgentClients2 :: (HasCallStack, HasTestEnv) => (HasCallStack => AgentClient -> AgentClient -> IO a) -> IO a withAgentClients2 = withAgentClientsCfg2 agentCfg agentCfg {-# INLINE withAgentClients2 #-} -withAgentClients3 :: HasCallStack => (HasCallStack => AgentClient -> AgentClient -> AgentClient -> IO ()) -> IO () +withAgentClients3 :: (HasCallStack, HasTestEnv) => (HasCallStack => AgentClient -> AgentClient -> AgentClient -> IO ()) -> IO () withAgentClients3 runTest = withAgentClients2 $ \a b -> withAgent 3 agentCfg initAgentServers testDB3 $ \c -> runTest a b c -runAgentClientTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientTest :: (HasCallStack, HasTestEnv) => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientTest pqSupport _sqSecured viaProxy alice bob baseId = runAgentClientTestPQ viaProxy (alice, IKLinkPQ pqSupport) (bob, pqSupport) baseId -runAgentClientTestPQ :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () +runAgentClientTestPQ :: (HasCallStack, HasTestEnv) => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do (bobId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMInvitation Nothing Nothing aPQ False SMSubscribe @@ -797,7 +812,7 @@ runAgentClientTestPQ viaProxy (alice, aPQ) (bob, bPQ) baseId = pqConnectionMode :: InitialKeys -> PQSupport -> Bool pqConnectionMode pqMode1 pqMode2 = supportPQ (CR.connPQEncryption pqMode1) && supportPQ pqMode2 -runAgentClientStressTestOneWay :: HasCallStack => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientStressTestOneWay :: (HasCallStack, HasTestEnv) => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientStressTestOneWay n pqSupport viaProxy alice bob baseId = runRight_ $ do let pqEnc = PQEncryption $ supportPQ pqSupport (aliceId, bobId) <- makeConnection_ pqSupport alice bob @@ -829,7 +844,7 @@ runAgentClientStressTestOneWay n pqSupport viaProxy alice bob baseId = runRight_ where msgId = subtract baseId . fst -runAgentClientStressTestConc :: HasCallStack => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientStressTestConc :: (HasCallStack, HasTestEnv) => Int64 -> PQSupport -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientStressTestConc n pqSupport viaProxy alice bob _baseId = runRight_ $ do (aliceId, bobId) <- makeConnection_ pqSupport alice bob amId <- newTVarIO 0 @@ -889,7 +904,7 @@ runAgentClientStressTestConc n pqSupport viaProxy alice bob _baseId = runRight_ loop (s, m, r, o - 1) _ -> liftIO $ expectationFailure $ "unexpected: " <> show r -testEnablePQEncryption :: HasCallStack => IO () +testEnablePQEncryption :: (HasCallStack, HasTestEnv) => IO () testEnablePQEncryption = withAgentClients2 $ \ca cb -> runRight_ $ do g <- liftIO C.newRandom @@ -956,7 +971,7 @@ sndRcv pqEnc pqEnc' ((c1, id1), mId, msg) (c2, id2) = do get c2 =##> \case ("", connId, Msg' mId' pq msg') -> connId == id1 && mId' == mId && msg' == msg && pq == pqEnc; _ -> False ackMessage c2 id1 mId Nothing -testAgentClient3 :: HasCallStack => IO () +testAgentClient3 :: (HasCallStack, HasTestEnv) => IO () testAgentClient3 = withAgentClients3 $ \a b c -> runRight_ $ do (aIdForB, bId) <- makeConnection a b @@ -979,11 +994,11 @@ testAgentClient3 = get c =##> \case ("", connId, Msg "c5") -> connId == aIdForC; _ -> False ackMessage c aIdForC 3 Nothing -runAgentClientContactTest :: HasCallStack => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () +runAgentClientContactTest :: (HasCallStack, HasTestEnv) => PQSupport -> SndQueueSecured -> Bool -> AgentClient -> AgentClient -> AgentMsgId -> IO () runAgentClientContactTest pqSupport sqSecured viaProxy alice bob baseId = runAgentClientContactTestPQ sqSecured viaProxy (alice, IKLinkPQ pqSupport) (bob, pqSupport) baseId -runAgentClientContactTestPQ :: HasCallStack => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () +runAgentClientContactTestPQ :: (HasCallStack, HasTestEnv) => SndQueueSecured -> Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientContactTestPQ sqSecured viaProxy (alice, aPQ) (bob, bPQ) baseId = runRight_ $ do (_, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing aPQ False SMSubscribe @@ -1037,7 +1052,7 @@ allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc = do exchangeGreetings_ pqEnc alice bobId bob aliceId -- DR-advertising contact address, across accept/join modes, InitialKeys, and joiner PQ -runAgentClientContactDRTest_ :: HasCallStack => Bool -> Bool -> InitialKeys -> Bool -> PQSupport -> (ASrvTransport, AStoreType) -> IO () +runAgentClientContactDRTest_ :: (HasCallStack, HasTestEnv) => Bool -> Bool -> InitialKeys -> Bool -> PQSupport -> (ASrvTransport, AStoreType) -> IO () runAgentClientContactDRTest_ asyncAccept asyncJoin addrIK useDR bPQ ps = withSmpServer ps $ withAgentClients2 $ \alice bob -> do g <- C.newRandom rootKey <- atomically $ C.generateKeyPair g @@ -1077,7 +1092,7 @@ runAgentClientContactDRTest_ asyncAccept asyncJoin addrIK useDR bPQ ps = withSmp allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc -- DR advertising via createConnection (sync) and createConnectionAsync (async NEW), reaching newRcvConnSrv -runCreateConnectionDRTest_ :: HasCallStack => Bool -> InitialKeys -> PQSupport -> (ASrvTransport, AStoreType) -> IO () +runCreateConnectionDRTest_ :: (HasCallStack, HasTestEnv) => Bool -> InitialKeys -> PQSupport -> (ASrvTransport, AStoreType) -> IO () runCreateConnectionDRTest_ asyncNew addrIK bPQ ps = withSmpServer ps $ withAgentClients2 $ \alice bob -> do let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing} pqEnc = PQEncryption $ pqConnectionMode addrIK bPQ @@ -1129,7 +1144,7 @@ joinContactDR alice requester connReq addrIK pqEnc = do ("", _, A.CONF confId _ _ "alice's connInfo") <- get requester allowConfirmGreet alice reqId requester aliceId confId addrIK pqEnc -testAddressKeyRotation :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testAddressKeyRotation :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testAddressKeyRotation ps = withSmpServer ps $ withAgentClients3 $ \alice bob carol -> do g <- C.newRandom rootKey <- atomically $ C.generateKeyPair g @@ -1156,7 +1171,7 @@ testAddressKeyRotation ps = withSmpServer ps $ withAgentClients3 $ \alice bob ca void $ A.joinConnection bob NRMInteractive 1 aId True connReq1 "bob's connInfo" PQSupportOn SMSubscribe get alice =##> \case ("", _, A.ERR _) -> True; _ -> False -testAddDRViaSetConnShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testAddDRViaSetConnShortLink :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testAddDRViaSetConnShortLink ps = withSmpServer ps $ withAgentClients2 $ \alice bob -> do g <- C.newRandom rootKey <- atomically $ C.generateKeyPair g @@ -1174,7 +1189,7 @@ testAddDRViaSetConnShortLink ps = withSmpServer ps $ withAgentClients2 $ \alice liftIO $ ratchetKeys cd1 `shouldSatisfy` isJust -- updating a DR address's link data must preserve the stored ratchet keys -testAddressUpdatePreservesDRKeys :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testAddressUpdatePreservesDRKeys :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testAddressUpdatePreservesDRKeys ps = withSmpServer ps $ withAgentClients2 $ \alice bob -> do g <- C.newRandom rootKey <- atomically $ C.generateKeyPair g @@ -1205,7 +1220,7 @@ testAddressUpdatePreservesDRKeys ps = withSmpServer ps $ withAgentClients2 $ \al allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc -- a DR accept that fails at the network step after committing send queue + ratchet must resume on retry -testAcceptContactDRResumeAfterOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testAcceptContactDRResumeAfterOffline :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testAcceptContactDRResumeAfterOffline ps = withAgentClients2 $ \alice bob -> do g <- C.newRandom rootKey <- atomically $ C.generateKeyPair g @@ -1237,7 +1252,7 @@ testAcceptContactDRResumeAfterOffline ps = withAgentClients2 $ \alice bob -> do ("", _, A.CONF confId _ _ "alice's connInfo") <- get bob allowConfirmGreet alice bobId bob aliceId confId addrIK pqEnc -runAgentClientContactTestPQ3 :: HasCallStack => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () +runAgentClientContactTestPQ3 :: (HasCallStack, HasTestEnv) => Bool -> (AgentClient, InitialKeys) -> (AgentClient, PQSupport) -> (AgentClient, PQSupport) -> AgentMsgId -> IO () runAgentClientContactTestPQ3 viaProxy (alice, aPQ) (bob, bPQ) (tom, tPQ) baseId = runRight_ $ do (_, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing aPQ False SMSubscribe (bAliceId, bobId, abPQEnc) <- connectViaContact bob bPQ qInfo @@ -1289,7 +1304,7 @@ noMessages_ ingoreQCONT c err = tryGet `shouldReturn` () Just msg -> error $ err <> ": " <> show msg Nothing -> return () -testRejectContactRequest :: HasCallStack => IO () +testRejectContactRequest :: (HasCallStack, HasTestEnv) => IO () testRejectContactRequest = withAgentClients2 $ \alice bob -> runRight_ $ do (_addrConnId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn False SMSubscribe @@ -1301,7 +1316,7 @@ testRejectContactRequest = rejectContact alice NRMInteractive 1 invId Nothing liftIO $ noMessages bob "nothing delivered to bob" -testRejectContactRequestDR :: HasCallStack => IO () +testRejectContactRequestDR :: (HasCallStack, HasTestEnv) => IO () testRejectContactRequestDR = withAgentClients2 $ \alice bob -> runRight_ $ do let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing} @@ -1313,7 +1328,7 @@ testRejectContactRequestDR = ("", _, A.RJCT "not now") <- get bob pure () -testRejectContactRequestDRAsync :: HasCallStack => IO () +testRejectContactRequestDRAsync :: (HasCallStack, HasTestEnv) => IO () testRejectContactRequestDRAsync = withAgentClients2 $ \alice bob -> runRight_ $ do let userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing} @@ -1328,7 +1343,7 @@ testRejectContactRequestDRAsync = serviceUserLinkData :: UserConnLinkData 'CMContact serviceUserLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData = UserLinkData "test user data", ratchetKeys = Nothing} -testServiceRequestResponse :: HasCallStack => IO () +testServiceRequestResponse :: (HasCallStack, HasTestEnv) => IO () testServiceRequestResponse = withAgentClients2 $ \service client -> runRight_ $ do (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe @@ -1342,7 +1357,7 @@ testServiceRequestResponse = liftIO $ resp `shouldBe` "service response" liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose -testServiceRequestResponseAsync :: HasCallStack => IO () +testServiceRequestResponseAsync :: (HasCallStack, HasTestEnv) => IO () testServiceRequestResponseAsync = withAgentClients2 $ \service client -> runRight_ $ do (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe @@ -1356,7 +1371,7 @@ testServiceRequestResponseAsync = liftIO $ resp `shouldBe` "service response" liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose -testServiceRequestRejected :: HasCallStack => IO () +testServiceRequestRejected :: (HasCallStack, HasTestEnv) => IO () testServiceRequestRejected = withAgentClients2 $ \service client -> runRight_ $ do (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe @@ -1368,7 +1383,7 @@ testServiceRequestRejected = liftIO $ resp `shouldBe` Left (AGENT (A_SERVICE (ASERejected "not allowed"))) liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose -testSignedServiceRequest :: HasCallStack => IO () +testSignedServiceRequest :: (HasCallStack, HasTestEnv) => IO () testSignedServiceRequest = withAgentClients2 $ \service client -> runRight_ $ do (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe @@ -1383,7 +1398,7 @@ testSignedServiceRequest = liftIO $ resp `shouldBe` "service response" liftIO $ threadDelay 250000 -- let the async teardown of the reply queues settle before dispose -testSignedServiceRequestAsync :: HasCallStack => IO () +testSignedServiceRequestAsync :: (HasCallStack, HasTestEnv) => IO () testSignedServiceRequestAsync = withAgentClients2 $ \service client -> runRight_ $ do (_addrConnId, CCLink connReq _) <- A.createConnection service NRMInteractive 1 True True SCMContact (Just serviceUserLinkData) Nothing IKPQOn True SMSubscribe @@ -1401,7 +1416,7 @@ testSignedServiceRequestAsync = -- server down, send, up, receive, down, reply, up, receive response. -- The request send retries the outage (bounded by serviceRequestTimeout) until the server is back; the reply is -- queued while the server is down and delivered on reconnect (async reply via ICReplyDel); the blocking call receives it. -testServiceRequestResilient :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testServiceRequestResilient :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testServiceRequestResilient ps = withAgentClients2 $ \service client -> do -- server up: create the service address connReq <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do @@ -1427,7 +1442,7 @@ testServiceRequestResilient ps = withAgentClients2 $ \service client -> do wait reqAsync resp `shouldBe` Right "resilient response" -testUpdateConnectionUserId :: HasCallStack => IO () +testUpdateConnectionUserId :: (HasCallStack, HasTestEnv) => IO () testUpdateConnectionUserId = withAgentClients2 $ \alice bob -> runRight_ $ do (connId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -1444,7 +1459,7 @@ testUpdateConnectionUserId = get bob ##> ("", aliceId, A.INFO PQSupportOn "alice's connInfo") get bob ##> ("", aliceId, A.CON pqEnc) -testAsyncInitiatingOffline :: HasCallStack => IO () +testAsyncInitiatingOffline :: (HasCallStack, HasTestEnv) => IO () testAsyncInitiatingOffline = withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> runRight_ $ do alice <- liftIO $ getSMPAgentClient' 1 agentCfg initAgentServers testDB @@ -1480,7 +1495,7 @@ testAsyncInitiatingOffline = exchangeGreetingsMsgId 4 alice' bobId bob aliceId liftIO $ disposeAgentClient alice' -testAsyncJoiningOfflineBeforeActivation :: HasCallStack => IO () +testAsyncJoiningOfflineBeforeActivation :: (HasCallStack, HasTestEnv) => IO () testAsyncJoiningOfflineBeforeActivation = withAgent 1 agentCfg initAgentServers testDB $ \alice -> runRight_ $ do bob <- liftIO $ getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -1498,7 +1513,7 @@ testAsyncJoiningOfflineBeforeActivation = exchangeGreetings alice bobId bob' aliceId liftIO $ disposeAgentClient bob' -testAsyncBothOffline :: HasCallStack => IO () +testAsyncBothOffline :: (HasCallStack, HasTestEnv) => IO () testAsyncBothOffline = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -1521,7 +1536,7 @@ testAsyncBothOffline = do liftIO $ disposeAgentClient alice' liftIO $ disposeAgentClient bob' -testAsyncServerOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testAsyncServerOffline :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do -- create connection and shutdown the server (bobId, cReq) <- withSmpServerStoreLogOn ps testPort $ \_ -> @@ -1547,7 +1562,7 @@ testAsyncServerOffline ps = withAgentClients2 $ \alice bob -> do get bob ##> ("", aliceId, CON) exchangeGreetings alice bobId bob aliceId -testAllowConnectionClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testAllowConnectionClientRestart :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testAllowConnectionClientRestart ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB @@ -1586,7 +1601,7 @@ testAllowConnectionClientRestart ps@(t, ASType qsType _) = do disposeAgentClient alice2 disposeAgentClient bob -testInvitationErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO () +testInvitationErrors :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> Bool -> IO () testInvitationErrors ps restart = do a <- getAgentA b <- getAgentB @@ -1639,10 +1654,10 @@ testInvitationErrors ps restart = do disposeAgentClient a disposeAgentClient b' -restartAgentA :: Bool -> AgentClient -> [ConnId] -> IO AgentClient +restartAgentA :: HasTestEnv => Bool -> AgentClient -> [ConnId] -> IO AgentClient restartAgentA = restartAgent_ getAgentA -restartAgentB :: Bool -> AgentClient -> [ConnId] -> IO AgentClient +restartAgentB :: HasTestEnv => Bool -> AgentClient -> [ConnId] -> IO AgentClient restartAgentB = restartAgent_ getAgentB restartAgent_ :: IO AgentClient -> Bool -> AgentClient -> [ConnId] -> IO AgentClient @@ -1656,7 +1671,7 @@ restartAgent_ getAgent restart c cIds pure c' | otherwise = pure c -testContactErrors :: HasCallStack => (ASrvTransport, AStoreType) -> Bool -> IO () +testContactErrors :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> Bool -> IO () testContactErrors ps restart = do a <- getAgentA b <- getAgentB @@ -1729,19 +1744,19 @@ testContactErrors ps restart = do disposeAgentClient a'' disposeAgentClient b'' -getAgentA :: IO AgentClient +getAgentA :: HasTestEnv => IO AgentClient getAgentA = getSMPAgentClient' 1 agentCfg initAgentServers testDB -getAgentB :: IO AgentClient +getAgentB :: HasTestEnv => IO AgentClient getAgentB = getSMPAgentClient' 2 agentCfg (initAgentServers {smp = userServers [testSMPServer2]}) testDB2 -withServer1 :: (ASrvTransport, AStoreType) -> IO a -> IO a +withServer1 :: HasTestEnv => (ASrvTransport, AStoreType) -> IO a -> IO a withServer1 ps = withSmpServerStoreLogOn ps testPort . const -withServer2 :: (ASrvTransport, AStoreType) -> IO a -> IO a +withServer2 :: HasTestEnv => (ASrvTransport, AStoreType) -> IO a -> IO a withServer2 (t, ASType qsType _) = withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 . const -testInvitationShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () +testInvitationShortLink :: (HasCallStack, HasTestEnv) => Bool -> AgentClient -> AgentClient -> IO () testInvitationShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do let userData = UserLinkData "some user data" @@ -1803,7 +1818,7 @@ relayLink1 = either error id $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406 relayLink2 :: ConnShortLink 'CMContact relayLink2 = either error id $ strDecode "https://localhost/a#4AkRDmhf64tdRlN406g8lJRg5OCmhD6ynIhi6glOcCM" -testContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () +testContactShortLink :: (HasCallStack, HasTestEnv) => Bool -> AgentClient -> AgentClient -> IO () testContactShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do let userData = UserLinkData "some user data" @@ -1855,7 +1870,7 @@ testContactShortLink viaProxy a b = Left (SMP _ AUTH) <- runExceptT $ getConnShortLink c 1 shortLink pure () -testAddContactShortLink :: HasCallStack => Bool -> AgentClient -> AgentClient -> IO () +testAddContactShortLink :: (HasCallStack, HasTestEnv) => Bool -> AgentClient -> AgentClient -> IO () testAddContactShortLink viaProxy a b = withAgent 3 agentCfg initAgentServers testDB3 $ \c -> do (contactId, CCLink connReq0 Nothing) <- runRight $ A.createConnection a NRMInteractive 1 True True SCMContact Nothing Nothing CR.IKPQOn False SMSubscribe @@ -1901,7 +1916,7 @@ testAddContactShortLink viaProxy a b = connReq4 `shouldBe` connReq updatedCtData' `shouldBe` updatedCtData -testInvitationShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testInvitationShortLinkRestart :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testInvitationShortLinkRestart ps = withAgentClients2 $ \a b -> do let userData = UserLinkData "some user data" newLinkData = UserInvLinkData userData @@ -1914,7 +1929,7 @@ testInvitationShortLinkRestart ps = withAgentClients2 $ \a b -> do connReq' `shouldBe` connReq linkUserData connData' `shouldBe` userData -testContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testContactShortLinkRestart :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do let userData = UserLinkData "some user data" userCtData = UserContactData {direct = True, owners = [], relays = [], userData, ratchetKeys = Nothing} @@ -1938,7 +1953,7 @@ testContactShortLinkRestart ps = withAgentClients2 $ \a b -> do linkConnReq fd4 `shouldBe` connReq updatedCtData' `shouldBe` updatedCtData -testAddContactShortLinkRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testAddContactShortLinkRestart :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do let userData = UserLinkData "some user data" userCtData = UserContactData {direct = True, owners = [], relays = [], userData, ratchetKeys = Nothing} @@ -1963,7 +1978,7 @@ testAddContactShortLinkRestart ps = withAgentClients2 $ \a b -> do linkConnReq fd4 `shouldBe` connReq updatedCtData' `shouldBe` updatedCtData -testOldContactQueueShortLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testOldContactQueueShortLink :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testOldContactQueueShortLink ps@(_, msType) = withAgentClients2 $ \a b -> do (contactId, CCLink connReq Nothing) <- withSmpServer ps $ runRight $ A.createConnection a NRMInteractive 1 True True SCMContact Nothing Nothing CR.IKPQOn False SMOnlyCreate @@ -2019,7 +2034,7 @@ replaceSubstringInFile filePath oldText newText = do let newContent = T.replace oldText newText content T.writeFile filePath newContent -testPrepareCreateConnectionLink :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testPrepareCreateConnectionLink :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testPrepareCreateConnectionLink ps = withSmpServer ps $ withAgentClients2 $ \a b -> do let userData = UserLinkData "test user data" userCtData = UserContactData {direct = True, owners = [], relays = [], userData, ratchetKeys = Nothing} @@ -2056,7 +2071,7 @@ connReqWithKeys cr rk = case cr of BCRInvitationUri crData e2eParams -> CRInvitationUri crData e2eParams BCRContactUri crData -> CRContactUri crData rk -testIncreaseConnAgentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testIncreaseConnAgentVersion :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testIncreaseConnAgentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 6 7} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 6 7} initAgentServers testDB2 @@ -2121,7 +2136,7 @@ checkVersion c connId v = do ConnectionStats {connAgentVersion} <- getConnectionServers c connId liftIO $ connAgentVersion `shouldBe` VersionSMPA v -testIncreaseConnAgentVersionMaxCompatible :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testIncreaseConnAgentVersionMaxCompatible :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testIncreaseConnAgentVersionMaxCompatible ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 6 7} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 6 7} initAgentServers testDB2 @@ -2151,7 +2166,7 @@ testIncreaseConnAgentVersionMaxCompatible ps = do disposeAgentClient alice2 disposeAgentClient bob2 -testIncreaseConnAgentVersionStartDifferentVersion :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testIncreaseConnAgentVersionStartDifferentVersion :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testIncreaseConnAgentVersionStartDifferentVersion ps = do alice <- getSMPAgentClient' 1 agentCfg {smpAgentVRange = mkVersionRange 6 7} initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg {smpAgentVRange = mkVersionRange 6 8} initAgentServers testDB2 @@ -2177,7 +2192,7 @@ testIncreaseConnAgentVersionStartDifferentVersion ps = do disposeAgentClient alice2 disposeAgentClient bob -testDeliverClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testDeliverClientRestart :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testDeliverClientRestart ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -2208,7 +2223,7 @@ testDeliverClientRestart ps = do disposeAgentClient alice disposeAgentClient bob2 -testDuplicateMessage :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testDuplicateMessage :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testDuplicateMessage ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -2260,7 +2275,7 @@ testDuplicateMessage ps = do disposeAgentClient alice2 disposeAgentClient bob2 -testSkippedMessages :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testSkippedMessages :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testSkippedMessages (t, msType) = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -2311,7 +2326,7 @@ testSkippedMessages (t, msType) = do where cfg' = withServerCfg (cfgMS msType) $ \cfg_ -> ASrvCfg SQSMemory SMSMemory cfg_ {serverStoreCfg = SSCMemory $ Just $ StorePaths testStoreLogFile Nothing} -testDeliveryAfterSubscriptionError :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testDeliveryAfterSubscriptionError :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testDeliveryAfterSubscriptionError ps = do (aId, bId) <- withAgentClients2 $ \a b -> do (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ makeConnection a b @@ -2329,7 +2344,7 @@ testDeliveryAfterSubscriptionError ps = do withUP b aId $ \case ("", c, Msg "hello") -> c == aId; _ -> False ackMessage b aId 2 Nothing -testMsgDeliveryQuotaExceeded :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testMsgDeliveryQuotaExceeded :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testMsgDeliveryQuotaExceeded ps = withAgentClients2 $ \a b -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -2357,7 +2372,7 @@ testMsgDeliveryQuotaExceeded ps = get a =##> \case ("", c, SENT 6) -> bId == c; _ -> False liftIO $ concurrently_ (noMessages a "no more events") (noMessages b "no more events") -testExpireMessage :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testExpireMessage :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testExpireMessage ps = withAgent 1 agentCfg {messageTimeout = 1.5, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do @@ -2373,7 +2388,7 @@ testExpireMessage ps = withUP b aId $ \case ("", _, MsgErr 2 (MsgSkipped 2 2) "2") -> True; _ -> False ackMessage b aId 2 Nothing -testExpireManyMessages :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testExpireManyMessages :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testExpireManyMessages ps = withAgent 1 agentCfg {messageTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB $ \a -> withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do @@ -2412,7 +2427,7 @@ withUP a bId p = \case (corrId, c, AEvt SAEConn cmd) -> c == bId && p (corrId, c, cmd); _ -> False ] -testExpireMessageQuota :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testExpireMessageQuota :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testExpireMessageQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 1, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -2440,7 +2455,7 @@ testExpireMessageQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ where cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2} -testExpireManyMessagesQuota :: (ASrvTransport, AStoreType) -> IO () +testExpireManyMessagesQuota :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do a <- getSMPAgentClient' 1 agentCfg {quotaExceededTimeout = 2, messageRetryInterval = fastMessageRetryInterval} initAgentServers testDB b <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -2479,7 +2494,7 @@ testExpireManyMessagesQuota (t, msType) = withSmpServerConfigOn t cfg' testPort where cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2} -testJoinFullContactAsync :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testJoinFullContactAsync :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testJoinFullContactAsync (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do (contactId, qInfo) <- fillContactAddress withAgent 2 agentCfg {commandQuotaRetryInterval = fastRetryInterval} initAgentServers testDB2 $ \bob -> do @@ -2498,7 +2513,7 @@ testJoinFullContactAsync (t, msType) = withSmpServerConfigOn t cfg' testPort $ \ where cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2} -testJoinFullContactAsyncExpire :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testJoinFullContactAsyncExpire :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testJoinFullContactAsyncExpire (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do (_, qInfo) <- fillContactAddress withAgent 2 agentCfg {quotaExceededTimeout = 2, commandQuotaRetryInterval = fastRetryInterval} initAgentServers testDB2 $ \bob -> do @@ -2512,7 +2527,7 @@ testJoinFullContactAsyncExpire (t, msType) = withSmpServerConfigOn t cfg' testPo where cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 1, maxJournalMsgCount = 2} -fillContactAddress :: HasCallStack => IO (ConnId, ConnectionRequestUri 'CMContact) +fillContactAddress :: (HasCallStack, HasTestEnv) => IO (ConnId, ConnectionRequestUri 'CMContact) fillContactAddress = do (contactId, qInfo) <- withAgent 1 agentCfg initAgentServers testDB $ \alice -> runRight $ do (contactId, CCLink qInfo Nothing) <- A.createConnection alice NRMInteractive 1 True True SCMContact Nothing Nothing IKPQOn False SMSubscribe @@ -2522,7 +2537,7 @@ fillContactAddress = do void $ A.joinConnection carol NRMInteractive 1 aliceId True qInfo "carol's connInfo" PQSupportOn SMSubscribe pure (contactId, qInfo) -testDropMsgAfterRcvAttempts :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testDropMsgAfterRcvAttempts :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testDropMsgAfterRcvAttempts ps = withSmpServerStoreLogOn ps testPort $ \_ -> do let rcvCfg = agentCfg {rcvExpireCount = 2, rcvExpireInterval = 1} @@ -2554,7 +2569,7 @@ testDropMsgAfterRcvAttempts ps = disposeAgentClient bob3 disposeAgentClient alice -testRatchetSync :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSync :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSync ps = withAgentClients2 $ \alice bob -> withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId, bob2) <- setupDesynchronizedRatchet alice bob @@ -2568,7 +2583,7 @@ testRatchetSync ps = withAgentClients2 $ \alice bob -> exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient bob2 -setupDesynchronizedRatchet :: HasCallStack => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) +setupDesynchronizedRatchet :: (HasCallStack, HasTestEnv) => AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) setupDesynchronizedRatchet alice bob = do (aliceId, bobId) <- runRight $ makeConnection alice bob runRight_ $ do @@ -2628,7 +2643,7 @@ ratchetSyncP' cId rss = \case cId' == cId && rss' == rss && ratchetSyncState == rss _ -> False -testRatchetSyncServerOffline :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncServerOffline :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncServerOffline ps = withAgentClients2 $ \alice bob -> do (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob @@ -2654,7 +2669,7 @@ serverUpP = \case ("", "", AEvt SAENone (UP _ _)) -> True _ -> False -testRatchetSyncClientRestart :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncClientRestart :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncClientRestart ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -2679,7 +2694,7 @@ testRatchetSyncClientRestart ps = do disposeAgentClient bob disposeAgentClient bob3 -testRatchetSyncSuspendForeground :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncSuspendForeground :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncSuspendForeground ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -2708,7 +2723,7 @@ testRatchetSyncSuspendForeground ps = do disposeAgentClient bob disposeAgentClient bob2 -testRatchetSyncSimultaneous :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncSimultaneous :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncSimultaneous ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bob <- getSMPAgentClient' 2 agentCfg initAgentServers testDB2 @@ -2736,7 +2751,7 @@ testRatchetSyncSimultaneous ps = do disposeAgentClient bob disposeAgentClient bob2 -testRatchetSyncReplayedKey :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncReplayedKey :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncReplayedKey ps = withAgentClients2 $ \alice bob -> do (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob @@ -2757,7 +2772,7 @@ testRatchetSyncReplayedKey ps = withAgentClients2 $ \alice bob -> do runRight_ $ exchangeGreetingsMsgIds alice bobId 10 bob2 aliceId 7 disposeAgentClient bob2 -testRatchetSyncRepeated :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncRepeated :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncRepeated ps = withAgentClients2 $ \alice bob -> do (aliceId, bobId, bob2) <- startRatchetSyncOffline ps alice bob ConnectionStats {ratchetSyncState = rss2} <- runRight $ synchronizeRatchet bob2 aliceId PQSupportOn True @@ -2778,7 +2793,7 @@ testRatchetSyncRepeated ps = withAgentClients2 $ \alice bob -> do map fst <$> processedRatchetKeyHashes bob2 `shouldReturn` [aliceId, aliceId] disposeAgentClient bob2 -testRatchetSyncFailedKeyNotProcessed :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncFailedKeyNotProcessed :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncFailedKeyNotProcessed ps = withAgentClients2 $ \alice bob -> do (aliceId, bobId, bob2) <- startRatchetSyncOffline ps alice bob withTransaction (store $ agentEnv bob2) $ \db -> @@ -2797,7 +2812,7 @@ testRatchetSyncFailedKeyNotProcessed ps = withAgentClients2 $ \alice bob -> do (_, cId', AEvt SAEConn (ERR (A.INTERNAL e))) -> cId' == cId && "SEX3dhKeysNotFound" `isPrefixOf` e _ -> False -testRatchetSyncFailedRecreationNoReply :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncFailedRecreationNoReply :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncFailedRecreationNoReply ps = withAgentClients2 $ \alice bob -> do (_, bobId, bob2) <- startRatchetSyncOffline ps alice bob aliceSndMsgs <- sndMessages alice @@ -2816,7 +2831,7 @@ testRatchetSyncFailedRecreationNoReply ps = withAgentClients2 $ \alice bob -> do (_, cId', AEvt SAEConn (ERR (A.INTERNAL e))) -> cId' == cId && "ratchet insert failed" `isInfixOf` e _ -> False -testRatchetSyncStartFailedNoKey :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testRatchetSyncStartFailedNoKey :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testRatchetSyncStartFailedNoKey ps = withAgentClients2 $ \alice bob -> do (aliceId, _, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob @@ -2831,7 +2846,7 @@ testRatchetSyncStartFailedNoKey ps = withAgentClients2 $ \alice bob -> do sndMessages bob2 `shouldReturn` bobSndMsgs disposeAgentClient bob2 -startRatchetSyncOffline :: HasCallStack => (ASrvTransport, AStoreType) -> AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) +startRatchetSyncOffline :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> AgentClient -> AgentClient -> IO (ConnId, ConnId, AgentClient) startRatchetSyncOffline ps alice bob = do (aliceId, bobId, bob2) <- withSmpServerStoreMsgLogOn ps testPort $ \_ -> setupDesynchronizedRatchet alice bob @@ -2857,7 +2872,7 @@ getMSGNTF :: AgentClient -> ConnId -> ExceptT AgentErrorType IO () getMSGNTF c cId = get c =##> \case ("", c', MSGNTF {}) -> c' == cId; _ -> False -testOnlyCreatePull :: IO () +testOnlyCreatePull :: HasTestEnv => IO () testOnlyCreatePull = withAgentClients2 $ \alice bob -> runRight_ $ do (bobId, qInfo) <- createConnection alice 1 True SCMInvitation Nothing SMOnlyCreate (aliceId, sqSecured) <- joinConnection bob 1 True qInfo "bob's connInfo" SMOnlyCreate @@ -2910,7 +2925,7 @@ makeConnectionForUsers_ pqSupport alice aliceUserId bob bobUserId = do get bob ##> ("", aliceId, A.CON pqEnc) pure (aliceId, bobId) -testInactiveNoSubs :: (ASrvTransport, AStoreType) -> IO () +testInactiveNoSubs :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testInactiveNoSubs (t, msType) = do let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> @@ -2920,7 +2935,7 @@ testInactiveNoSubs (t, msType) = do Just (_, _, AEvt SAENone (DISCONNECT _ _)) <- timeout 5000000 $ atomically (readTBQueue $ subQ alice) pure () -testInactiveWithSubs :: (ASrvTransport, AStoreType) -> IO () +testInactiveWithSubs :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testInactiveWithSubs (t, msType) = do let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> @@ -2931,7 +2946,7 @@ testInactiveWithSubs (t, msType) = do -- and after 2 sec of inactivity no DOWN is sent as we have a live subscription liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing -testActiveClientNotDisconnected :: (ASrvTransport, AStoreType) -> IO () +testActiveClientNotDisconnected :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testActiveClientNotDisconnected (t, msType) = do let cfg' = updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}} withSmpServerConfigOn t cfg' testPort $ \_ -> @@ -2958,7 +2973,7 @@ testActiveClientNotDisconnected (t, msType) = do liftIO $ timeout 1200000 (get alice) `shouldReturn` Nothing milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000) -testSuspendingAgent :: IO () +testSuspendingAgent :: HasTestEnv => IO () testSuspendingAgent = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -2974,7 +2989,7 @@ testSuspendingAgent = liftIO $ foregroundAgent b get b =##> \case ("", c, Msg "hello 2") -> c == aId; _ -> False -testSuspendingAgentCompleteSending :: (ASrvTransport, AStoreType) -> IO () +testSuspendingAgentCompleteSending :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b @@ -3005,7 +3020,7 @@ testSuspendingAgentCompleteSending ps = withAgentClients2 $ \a b -> do get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False ackMessage a bId 4 Nothing -testSuspendingAgentTimeout :: (ASrvTransport, AStoreType) -> IO () +testSuspendingAgentTimeout :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do (aId, _) <- withSmpServer ps . runRight $ do (aId, bId) <- makeConnection a b @@ -3024,7 +3039,7 @@ testSuspendingAgentTimeout ps = withAgentClients2 $ \a b -> do ("", "", SUSPENDED) <- nGet b pure () -testBatchedSubscriptions :: Int -> Int -> (ASrvTransport, AStoreType) -> IO () +testBatchedSubscriptions :: HasTestEnv => Int -> Int -> (ASrvTransport, AStoreType) -> IO () testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = do (conns, conns') <- withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do conns <- runServers $ do @@ -3093,7 +3108,7 @@ testBatchedSubscriptions nCreate nDel ps@(t, ASType qsType _) = do killThread t1 pure res -testBatchedPendingMessages :: Int -> Int -> IO () +testBatchedPendingMessages :: HasTestEnv => Int -> Int -> IO () testBatchedPendingMessages nCreate nMsgs = withA $ \a -> do conns <- withB $ \b -> runRight $ do @@ -3114,7 +3129,7 @@ testBatchedPendingMessages nCreate nMsgs = withA = withAgent 1 agentCfg initAgentServers testDB withB = withAgent 2 agentCfg initAgentServers testDB2 -testSendMessagesB :: IO () +testSendMessagesB :: HasTestEnv => IO () testSendMessagesB = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b let msg cId body = Right (cId, PQEncOn, SMP.noMsgFlags, vrValue body) @@ -3126,7 +3141,7 @@ testSendMessagesB = withAgentClients2 $ \a b -> runRight_ $ do receiveMsg b aId 3 "msg 2" receiveMsg b aId 4 "msg 3" -testSendMessagesB2 :: IO () +testSendMessagesB2 :: HasTestEnv => IO () testSendMessagesB2 = withAgentClients3 $ \a b c -> runRight_ $ do (abId, bId) <- makeConnection a b (acId, cId) <- makeConnection a c @@ -3226,7 +3241,7 @@ testAsyncCommands alice bob baseId = where msgId = subtract baseId -testSetConnShortLinkAsync :: (ASrvTransport, AStoreType) -> IO () +testSetConnShortLinkAsync :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testSetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do let userData = UserLinkData "test user data" @@ -3258,7 +3273,7 @@ testSetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, CON) -testGetConnShortLinkAsync :: (ASrvTransport, AStoreType) -> IO () +testGetConnShortLinkAsync :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do let userData = UserLinkData "test user data" @@ -3286,7 +3301,7 @@ testGetConnShortLinkAsync ps = withAgentClients2 $ \alice bob -> get alice ##> ("", bobId, CON) get bob ##> ("", aliceId, CON) -testAsyncCommandsRestore :: (ASrvTransport, AStoreType) -> IO () +testAsyncCommandsRestore :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testAsyncCommandsRestore ps = do alice <- getSMPAgentClient' 1 agentCfg initAgentServers testDB bobId <- runRight $ do @@ -3341,7 +3356,7 @@ testAcceptContactAsync alice bob baseId = where msgId = subtract baseId -testDeleteConnectionAsync :: (ASrvTransport, AStoreType) -> IO () +testDeleteConnectionAsync :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testDeleteConnectionAsync ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \a -> do connIds <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do @@ -3357,7 +3372,7 @@ testDeleteConnectionAsync ps = get a =##> \case ("", "", DEL_CONNS cs) -> length cs == 3 && all (`elem` connIds) cs; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" -testWaitDeliveryNoPending :: (ASrvTransport, AStoreType) -> IO () +testWaitDeliveryNoPending :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob -> withSmpServerStoreLogOn ps testPort $ \_ -> runRight_ $ do (aliceId, bobId) <- makeConnection alice bob @@ -3385,7 +3400,7 @@ testWaitDeliveryNoPending ps = withAgentClients2 $ \alice bob -> baseId = 1 msgId = subtract baseId -testWaitDelivery :: (ASrvTransport, AStoreType) -> IO () +testWaitDelivery :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testWaitDelivery ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do @@ -3439,7 +3454,7 @@ testWaitDelivery ps = baseId = 1 msgId = subtract baseId -testWaitDeliveryAUTHErr :: (ASrvTransport, AStoreType) -> IO () +testWaitDeliveryAUTHErr :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testWaitDeliveryAUTHErr ps = withAgent 1 agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do @@ -3482,7 +3497,7 @@ testWaitDeliveryAUTHErr ps = baseId = 1 msgId = subtract baseId -testWaitDeliveryTimeout :: (ASrvTransport, AStoreType) -> IO () +testWaitDeliveryTimeout :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testWaitDeliveryTimeout ps = do aliceId <- withAgent 1 agentCfg {connDeleteDeliveryTimeout = 1, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do @@ -3527,7 +3542,7 @@ testWaitDeliveryTimeout ps = do baseId = 1 msgId = subtract baseId -testWaitDeliveryTimeout2 :: (ASrvTransport, AStoreType) -> IO () +testWaitDeliveryTimeout2 :: HasTestEnv => (ASrvTransport, AStoreType) -> IO () testWaitDeliveryTimeout2 ps = withAgent 1 agentCfg {connDeleteDeliveryTimeout = 2, messageRetryInterval = fastMessageRetryInterval, initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} initAgentServers testDB $ \alice -> withAgent 2 agentCfg initAgentServers testDB2 $ \bob -> do @@ -3579,7 +3594,7 @@ networkOrTimeoutError = \case NETWORK _ -> True _ -> False -testJoinConnectionAsyncReplyError :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testJoinConnectionAsyncReplyError :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do let initAgentServersSrv2 = initAgentServers {smp = userServers [testSMPServer2]} withAgent 1 agentCfg initAgentServers testDB $ \a -> @@ -3621,7 +3636,7 @@ testJoinConnectionAsyncReplyError ps@(t, ASType qsType _) = do get b ##> ("", aId, CON) exchangeGreetings a bId b aId -testUsers :: IO () +testUsers :: HasTestEnv => IO () testUsers = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -3636,7 +3651,7 @@ testUsers = exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" -testDeleteUserQuietly :: IO () +testDeleteUserQuietly :: HasTestEnv => IO () testDeleteUserQuietly = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -3648,7 +3663,7 @@ testDeleteUserQuietly = exchangeGreetingsMsgId 4 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" -testUsersNoServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testUsersNoServer :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do (aId, bId, auId, _aId', bId') <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b @@ -3674,10 +3689,10 @@ testUsersNoServer ps = withAgentClientsCfg2 aCfg agentCfg $ \a b -> do aCfg = agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} -- fast rotation runs at agent version 8+; these tests pin to v7 to exercise the QKEY/QUSE slow path and switch abort -agentCfgV7 :: AgentConfig +agentCfgV7 :: HasTestEnv => AgentConfig agentCfgV7 = agentCfg {smpAgentVRange = mkVersionRange 6 7} -testSwitchConnection :: InitialAgentServers -> IO () +testSwitchConnection :: HasTestEnv => InitialAgentServers -> IO () testSwitchConnection servers = withAgentClientsCfgServers2 agentCfgV7 agentCfgV7 servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -3703,7 +3718,7 @@ switchComplete a bId b aId = do phaseSnd b aId SPCompleted [Nothing] phaseRcv a bId SPCompleted [Nothing] -testFastSwitchConnection :: InitialAgentServers -> IO () +testFastSwitchConnection :: HasTestEnv => InitialAgentServers -> IO () testFastSwitchConnection servers = withAgentClientsCfgServers2 agentCfg agentCfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -3725,11 +3740,11 @@ fastSwitchComplete a bId b aId = do -- A's old receive queue is on server1 (stopped after the connection is set up); B's queue and the new queue are on server2. -- Fast rotation completes over the live server: B secures the new queue and sends the confirmation and QEND on it, -- so the recipient moves to it and removes the old queue without the old server. -testFastSwitchDeadOldServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testFastSwitchDeadOldServer :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testFastSwitchDeadOldServer ps@(t, ASType qsType _) = do let bServers = initAgentServers {smp = userServers [testSMPServer2]} withSmpServerConfigOn t (cfgJ2QS qsType) testPort2 $ \_ -> - withAgent 1 agentCfg initAgentServers testDB $ \a -> + withAgent 1 aCfg initAgentServers testDB $ \a -> withAgent 2 agentCfg bServers testDB2 $ \b -> do (aId, bId) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do (aId, bId) <- makeConnection a b @@ -3745,7 +3760,10 @@ testFastSwitchDeadOldServer ps@(t, ASType qsType _) = do queuedReceived <- drainSwitchCompletedRcvMsg a bId "queued while down" liftIO $ queuedReceived `shouldBe` True drainSwitchCompleted b aId QDSnd + waitOneRcvQueue a bId exchangeGreetingsMsgId 7 a bId b aId + where + aCfg = agentCfg {initialCleanupDelay = 10000, cleanupInterval = 10000, deleteErrorCount = 3} -- drains switch and network events until the connection reports SPCompleted in the given direction, -- tolerating DOWN/UP and intermediate phases (the old server is stopped mid-rotation) @@ -3765,6 +3783,69 @@ drainSwitchCompletedRcvMsg c connId body = go False (_, connId', AEvt SAEConn (Msg' mId _ body')) | connId' == connId && body' == body -> ackMessage c connId' mId Nothing >> go True _ -> go seen +testFastSwitchDrainOldQueue :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () +testFastSwitchDrainOldQueue ps = + withSmpServers2 ps $ withAgentClients2 $ \a b -> runRight_ $ do + (aId, bId, aM1Id) <- endSwitchOnNewQueue a b + ackMessage a bId aM1Id Nothing + drainOldQueue a bId b aId + +testFastSwitchDrainOldQueueRestart :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () +testFastSwitchDrainOldQueueRestart ps = + withSmpServers2 ps $ + withAgent 2 agentCfg initAgentServers testDB2 $ \b -> do + (aId, bId, _) <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ endSwitchOnNewQueue a b + withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do + subscribeConnection a bId + drainOldQueue a bId b aId + +endSwitchOnNewQueue :: (HasCallStack, HasTestEnv) => AgentClient -> AgentClient -> ExceptT AgentErrorType IO (ConnId, ConnId, AgentMsgId) +endSwitchOnNewQueue a b = do + (aId, bId) <- makeConnection a b + exchangeGreetings a bId b aId + liftIO $ setProtocolServers a 1 [noAuthSrvCfg testSMPServer2] + m1Id <- sendMessage b aId SMP.noMsgFlags "m1" + get b ##> ("", aId, SENT m1Id) + ("", c, Msg' aM1Id _ "m1") <- get a + liftIO $ c `shouldBe` bId + m2Id <- sendMessage b aId SMP.noMsgFlags "m2" + get b ##> ("", aId, SENT m2Id) + _ <- switchConnectionAsync a "" bId + fastSwitchComplete a bId b aId + stats <- getConnectionServers a bId + liftIO $ rcvSwchStatuses' stats `shouldMatchList` [Nothing, Just RSReceivedQEND] + pure (aId, bId, aM1Id) + +drainOldQueue :: HasCallStack => AgentClient -> ConnId -> AgentClient -> ConnId -> ExceptT AgentErrorType IO () +drainOldQueue a bId b aId = do + ("", c, MSG MsgMeta {recipient = (aM2Id, _)} _ "m2") <- get a + liftIO $ c `shouldBe` bId + ackMessage a bId aM2Id Nothing + waitOneRcvQueue a bId + bMsgId <- sendMessage b aId SMP.noMsgFlags "hello" + get b ##> ("", aId, SENT bMsgId) + ("", c', MSG MsgMeta {recipient = (aMsgId, _)} _ "hello") <- get a + liftIO $ c' `shouldBe` bId + ackMessage a bId aMsgId Nothing + aMsgId' <- sendMessage a bId SMP.noMsgFlags "hello too" + get a ##> ("", bId, SENT aMsgId') + ("", c'', MSG MsgMeta {recipient = (bMsgId', _)} _ "hello too") <- get b + liftIO $ c'' `shouldBe` aId + ackMessage b aId bMsgId' Nothing + liftIO $ noMessages a "nothing else should be delivered to alice" + liftIO $ noMessages b "nothing else should be delivered to bob" + +waitOneRcvQueue :: HasCallStack => AgentClient -> ConnId -> ExceptT AgentErrorType IO () +waitOneRcvQueue c connId = go (300 :: Int) + where + go n = do + stats <- getConnectionServers c connId + case rcvSwchStatuses' stats of + [Nothing] -> pure () + statuses + | n > 0 -> liftIO (threadDelay 100000) >> go (n - 1) + | otherwise -> liftIO $ expectationFailure $ "old receive queue was not deleted: " <> show statuses + phaseRcv :: AgentClient -> ByteString -> SwitchPhase -> [Maybe RcvSwitchStatus] -> ExceptT AgentErrorType IO () phaseRcv c connId p swchStatuses = phase c connId QDRcv p (\stats -> rcvSwchStatuses' stats `shouldMatchList` swchStatuses) @@ -3792,7 +3873,7 @@ phase c connId d p statsExpectation = SWITCH {} <- pure r pure () -testSwitchAsync :: HasCallStack => InitialAgentServers -> IO () +testSwitchAsync :: (HasCallStack, HasTestEnv) => InitialAgentServers -> IO () testSwitchAsync servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b @@ -3837,7 +3918,7 @@ sessionSubscribe withC connIds a = liftIO $ noMessages c "nothing else should be delivered" pure r -testSwitchDelete :: InitialAgentServers -> IO () +testSwitchDelete :: HasTestEnv => InitialAgentServers -> IO () testSwitchDelete servers = withAgentClientsCfgServers2 agentCfgV7 agentCfgV7 servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -3851,7 +3932,7 @@ testSwitchDelete servers = get a =##> \case ("", "", DEL_CONNS [c]) -> c == bId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" -testAbortSwitchStarted :: HasCallStack => InitialAgentServers -> IO () +testAbortSwitchStarted :: (HasCallStack, HasTestEnv) => InitialAgentServers -> IO () testAbortSwitchStarted servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b @@ -3901,7 +3982,7 @@ testAbortSwitchStarted servers = do withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfgV7 servers testDB2 -testAbortSwitchStartedReinitiate :: HasCallStack => InitialAgentServers -> IO () +testAbortSwitchStartedReinitiate :: (HasCallStack, HasTestEnv) => InitialAgentServers -> IO () testAbortSwitchStartedReinitiate servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b @@ -3968,7 +4049,7 @@ errQueueNotFoundP cId = \case (_, cId', AEvt SAEConn (ERR AGENT {agentErr = A_QUEUE {queueErr = "QKEY: queue address not found in connection"}})) -> cId' == cId _ -> False -testCannotAbortSwitchSecured :: HasCallStack => InitialAgentServers -> IO () +testCannotAbortSwitchSecured :: (HasCallStack, HasTestEnv) => InitialAgentServers -> IO () testCannotAbortSwitchSecured servers = do (aId, bId) <- withA $ \a -> withB $ \b -> runRight $ do (aId, bId) <- makeConnection a b @@ -4006,7 +4087,7 @@ testCannotAbortSwitchSecured servers = do withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfgV7 servers testDB2 -testSwitch2Connections :: HasCallStack => InitialAgentServers -> IO () +testSwitch2Connections :: (HasCallStack, HasTestEnv) => InitialAgentServers -> IO () testSwitch2Connections servers = do (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do (aId1, bId1) <- makeConnection a b @@ -4064,7 +4145,7 @@ testSwitch2Connections servers = do withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfgV7 servers testDB2 -testSwitch2ConnectionsAbort1 :: HasCallStack => InitialAgentServers -> IO () +testSwitch2ConnectionsAbort1 :: (HasCallStack, HasTestEnv) => InitialAgentServers -> IO () testSwitch2ConnectionsAbort1 servers = do (aId1, bId1, aId2, bId2) <- withA $ \a -> withB $ \b -> runRight $ do (aId1, bId1) <- makeConnection a b @@ -4117,7 +4198,7 @@ testSwitch2ConnectionsAbort1 servers = do withB :: (AgentClient -> IO a) -> IO a withB = withAgent 2 agentCfgV7 servers testDB2 -testCreateQueueAuth :: HasCallStack => (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int +testCreateQueueAuth :: (HasCallStack, HasTestEnv) => (Maybe BasicAuth, VersionSMP) -> (Maybe BasicAuth, VersionSMP) -> SndQueueSecured -> AgentMsgId -> IO Int testCreateQueueAuth clnt1 clnt2 sqSecured baseId = do a <- getClient 1 clnt1 testDB b <- getClient 2 clnt2 testDB2 @@ -4149,7 +4230,7 @@ testCreateQueueAuth clnt1 clnt2 sqSecured baseId = do sndAuthAlg = C.AuthAlg C.SX25519 in getSMPAgentClient' clientId agentCfg {smpCfg, sndAuthAlg} servers db -testSMPServerConnectionTest :: (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) +testSMPServerConnectionTest :: HasTestEnv => (ASrvTransport, AStoreType) -> Maybe BasicAuth -> SMPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testSMPServerConnectionTest (t, msType) newQueueBasicAuth srv = withSmpServerConfigOn t cfg' testPort2 $ \_ -> do -- initially passed server is not running @@ -4172,7 +4253,7 @@ testServerInformation = serverCountry = Nothing } -testConnectionVerifyCodes :: HasCallStack => IO () +testConnectionVerifyCodes :: (HasCallStack, HasTestEnv) => IO () testConnectionVerifyCodes = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -4190,7 +4271,7 @@ testConnectionVerifyCodes = codes1'' <- getConnectionVerifyCodes a bId liftIO $ codes1'' `shouldBe` codes1 -testDeliveryReceipts :: HasCallStack => IO () +testDeliveryReceipts :: (HasCallStack, HasTestEnv) => IO () testDeliveryReceipts = withAgentClients2 $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -4210,7 +4291,7 @@ testDeliveryReceipts = ackMessage b aId 5 (Just "") `catchError` \case (A.CMD PROHIBITED _) -> pure (); e -> liftIO $ expectationFailure ("unexpected error " <> show e) ackMessage b aId 5 Nothing -testDeliveryReceiptsConcurrent :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testDeliveryReceiptsConcurrent :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testDeliveryReceiptsConcurrent (t, msType) = withSmpServerConfigOn t cfg' testPort $ \_ -> do withAgentClients2 $ \a b -> do @@ -4261,7 +4342,7 @@ testDeliveryReceiptsConcurrent (t, msType) = Just r -> pure r _ -> error "timeout" -testTwoUsers :: HasCallStack => IO () +testTwoUsers :: (HasCallStack, HasTestEnv) => IO () testTwoUsers = withAgentClients2 $ \a b -> do let nc = netCfg initAgentServers sessionMode nc `shouldBe` TSMSession @@ -4284,10 +4365,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do liftIO $ threadDelay 250000 setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 - ("", "", DOWN _ _) <- nGet a - ("", "", DOWN _ _) <- nGet a - ("", "", UP _ _) <- nGet a - ("", "", UP _ _) <- nGet a + reconnected a [[bId1], [bId1']] [bId1, bId1'] a `hasClients` 1 aUserId2 <- createUser a False [noAuthSrvCfg testSMPServer] [noAuthSrvCfg testXFTPServer] @@ -4299,12 +4377,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do b `hasClients` 1 setNetworkConfig a nc {sessionMode = TSMEntity} liftIO $ threadDelay 250000 - ("", "", DOWN _ _) <- nGet a - ("", "", DOWN _ _) <- nGet a - ("", "", UP _ _) <- nGet a - ("", "", UP _ _) <- nGet a - ("", "", UP _ _) <- nGet a - ("", "", UP _ _) <- nGet a + reconnected a [[bId1, bId1'], [bId2, bId2']] [bId1, bId1', bId2, bId2'] a `hasClients` 4 exchangeGreetingsMsgId 6 a bId1 b aId1 exchangeGreetingsMsgId 6 a bId1' b aId1' @@ -4313,15 +4386,7 @@ testTwoUsers = withAgentClients2 $ \a b -> do liftIO $ threadDelay 250000 setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 - ("", "", DOWN _ _) <- nGet a - ("", "", DOWN _ _) <- nGet a - ("", "", DOWN _ _) <- nGet a - -- to avoice race condition - nGet a =##> \case ("", "", DOWN _ _) -> True; ("", "", UP _ _) -> True; _ -> False - nGet a =##> \case ("", "", UP _ _) -> True; ("", "", DOWN _ _) -> True; _ -> False - ("", "", UP _ _) <- nGet a - ("", "", UP _ _) <- nGet a - ("", "", UP _ _) <- nGet a + reconnected a [[bId1], [bId1'], [bId2], [bId2']] [bId1, bId1', bId2, bId2'] a `hasClients` 2 exchangeGreetingsMsgId 8 a bId1 b aId1 exchangeGreetingsMsgId 8 a bId1' b aId1' @@ -4330,8 +4395,15 @@ testTwoUsers = withAgentClients2 $ \a b -> do where hasClients :: HasCallStack => AgentClient -> Int -> ExceptT AgentErrorType IO () hasClients c n = liftIO $ M.size <$> readTVarIO (smpClients c) `shouldReturn` n + reconnected :: HasCallStack => AgentClient -> [[ConnId]] -> [ConnId] -> ExceptT AgentErrorType IO () + reconnected c downs ups = liftIO $ getInAnyOrder c $ map down downs <> map up ups + where + down :: [ConnId] -> ATransmission -> Bool + down cs = \case ("", "", AEvt SAENone (DOWN _ cs')) -> S.fromList cs' == S.fromList cs; _ -> False + up :: ConnId -> ATransmission -> Bool + up cId = \case ("", "", AEvt SAENone (UP _ [cId'])) -> cId' == cId; _ -> False -testClientServiceConnection :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testClientServiceConnection :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testClientServiceConnection ps = do ((sId, uId), qIdHash) <- withSmpServerStoreLogOn ps testPort $ \_ -> do conns@(sId, uId) <- withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> runRight $ do @@ -4384,7 +4456,7 @@ testClientServiceConnection ps = do exchangeGreetingsMsgId 4 user sId' service uId' exchangeGreetingsMsgId 10 service uId user sId -testClientServiceIDChange :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testClientServiceIDChange :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testClientServiceIDChange ps@(_, ASType qs _) = do (sId, uId) <- withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do conns <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ do @@ -4441,7 +4513,7 @@ testClientServiceIDChange ps@(_, ASType qs _) = do -- | Test that service subscription is correctly cleared and re-established -- when server temporarily stops supporting services (askClientCert = False). -testServiceUnavailableClearsPending :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testServiceUnavailableClearsPending :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testServiceUnavailableClearsPending (t, msType) = do -- Same agent across all phases to test pendingServiceSub persistence withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do @@ -4489,7 +4561,7 @@ testServiceUnavailableClearsPending (t, msType) = do -- | Test that service subscription recovers when service ID changes on reconnect. -- Server restart with deleted service causes new service ID, triggering SSErrorServiceId. -- Queues should be unassociated, resubscribed, and re-associated with new service. -testServiceIdChangeOnReconnect :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testServiceIdChangeOnReconnect :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testServiceIdChangeOnReconnect ps@(_, ASType qs _) = do withAgentClientsServers2 (agentCfg, initAgentServersClientService) (agentCfg, initAgentServers) $ \service user -> do -- Phase 1: Establish connection with active service subscription @@ -4530,7 +4602,7 @@ testServiceIdChangeOnReconnect ps@(_, ASType qs _) = do -- | Test that subscribeAllConnections handles service unavailable on startup. -- Agent has service credentials but server doesn't support services (askClientCert = False). -testServiceUnavailableOnStartup :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testServiceUnavailableOnStartup :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testServiceUnavailableOnStartup (t, msType) = do let srv = initAgentServersClientService noSrv = initAgentServers @@ -4564,7 +4636,7 @@ testServiceUnavailableOnStartup (t, msType) = do ("", "", UP _ [_]) <- nGet user exchangeGreetingsMsgId 6 service uId user sId -testMigrateConnectionsToService :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testMigrateConnectionsToService :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testMigrateConnectionsToService ps = do (((sId1, uId1), (uId2, sId2)), ((sId3, uId3), (uId4, sId4)), ((sId5, uId5), (uId6, sId6))) <- withSmpServerStoreLogOn ps testPort $ \_ -> do @@ -4740,7 +4812,7 @@ insertUser :: DBStore -> IO () insertUser st = withTransaction st (`DB.execute_` "INSERT INTO users (user_id) VALUES (1)") #endif -testServerMultipleIdentities :: HasCallStack => IO () +testServerMultipleIdentities :: (HasCallStack, HasTestEnv) => IO () testServerMultipleIdentities = withAgentClients2 $ \alice bob -> runRight_ $ do (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -4770,13 +4842,13 @@ testServerMultipleIdentities = [ SMPQueueUri supportedSMPClientVRange queueAddr - { smpServer = SMPServer "localhost" "5001" (C.KeyHash "\215m\248\251") + { smpServer = SMPServer "localhost" testPort (C.KeyHash "\215m\248\251") } ] } testE2ERatchetParams12 -testWaitForUserNetwork :: IO () +testWaitForUserNetwork :: HasTestEnv => IO () testWaitForUserNetwork = withAgent 1 aCfg initAgentServers testDB $ \a -> do noNetworkDelay a setUserNetworkInfo a $ UserNetworkInfo UNNone False @@ -4793,7 +4865,7 @@ testWaitForUserNetwork = withAgent 1 aCfg initAgentServers testDB $ \a -> do where aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0} -testDoNotResetOnlineToOffline :: IO () +testDoNotResetOnlineToOffline :: HasTestEnv => IO () testDoNotResetOnlineToOffline = withAgent 1 aCfg initAgentServers testDB $ \a -> do noNetworkDelay a setUserNetworkInfo a $ UserNetworkInfo UNWifi False @@ -4814,7 +4886,7 @@ testDoNotResetOnlineToOffline = withAgent 1 aCfg initAgentServers testDB $ \a -> where aCfg = agentCfg {userNetworkInterval = 100000, userOfflineDelay = 0.1} -testResumeMultipleThreads :: IO () +testResumeMultipleThreads :: HasTestEnv => IO () testResumeMultipleThreads = withAgent 1 aCfg initAgentServers testDB $ \a -> do noNetworkDelay a setUserNetworkInfo a $ UserNetworkInfo UNNone False @@ -4835,7 +4907,7 @@ testResumeMultipleThreads = withAgent 1 aCfg initAgentServers testDB $ \a -> do where aCfg = agentCfg {userOfflineDelay = 0} -testServerQueueInfo :: IO () +testServerQueueInfo :: HasTestEnv => IO () testServerQueueInfo = do withAgentClients2 $ \alice bob -> runRight_ $ do (bobId, cReq) <- createConnection alice 1 True SCMInvitation Nothing SMSubscribe @@ -4891,11 +4963,11 @@ testServerQueueInfo = do Just _ <- checkMsgQ bob aliceId 2 get bob =##> \case ("", c, Msg' mId PQEncOn "hello 4") -> c == aliceId && mId == msgId4; _ -> False ackMessage bob aliceId msgId4 Nothing - liftIO $ threadDelay 200000 - Just _ <- checkMsgQ bob aliceId 1 -- the one that did not fit now accepted get alice ##> ("", bobId, QCONT) get alice ##> ("", bobId, SENT msgId5) liftIO $ threadDelay 200000 + Just _ <- checkMsgQ bob aliceId 1 -- the one that did not fit now accepted + liftIO $ threadDelay 200000 Just _srvMsgId <- checkQ bob aliceId True (Just QNoSub) 1 (Just MTMessage) get bob =##> \case ("", c, Msg' mId PQEncOn "hello: quota exceeded") -> c == aliceId && mId == msgId5 + 1; _ -> False ackMessage bob aliceId (msgId5 + 1) Nothing @@ -4921,7 +4993,7 @@ testServerQueueInfo = do qDelivered <$> qiSub `shouldBe` Just msgId_ pure msgId_ -testClientNotice :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testClientNotice :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testClientNotice ps = do withAgent 1 agentCfg initAgentServers testDB $ \c -> do (cId, _) <- withSmpServerStoreLogOn ps testPort $ \_ -> runRight $ diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index d81c08a41..8cde7213f 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -138,7 +138,8 @@ notificationTests ps@(t, _) = do testNtfTokenReRegisterInvalidOnCheck t apns describe "notification server tests" $ do it "should pass" $ testRunNTFServerTests t testNtfServer `shouldReturn` Right Nothing - let srv1 = testNtfServer {keyHash = "1234"} + let srv1 :: HasTestEnv => NtfServer + srv1 = testNtfServer {keyHash = "1234"} it "should fail with incorrect fingerprint" $ do testRunNTFServerTests t srv1 `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) describe "Managing notification subscriptions" $ do @@ -186,7 +187,7 @@ notificationTests ps@(t, _) = do testNotificationsNewToken apns ntf it "should migrate to service subscriptions" $ testMigrateToServiceSubscriptions ps -testNtfMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec +testNtfMatrix :: HasCallStack => (ASrvTransport, AStoreType) -> (HasTestEnv => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> Spec testNtfMatrix ps@(_, msType) runTest = do describe "next and current" $ do it "curr servers; curr clients" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfg runTest @@ -200,6 +201,7 @@ testNtfMatrix ps@(_, msType) runTest = do it "servers: curr SMP, curr NTF; clients: curr/prev" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfg agentCfgVPrevPQ runTest it "servers: curr SMP, curr NTF; clients: prev/curr" $ runNtfTestCfg ps 1 cfg' ntfServerCfg agentCfgVPrevPQ agentCfg runTest where + cfg', cfgVPrev' :: HasTestEnv => AServerConfig cfg' = cfgMS msType cfgVPrev' = cfgVPrev msType @@ -212,7 +214,7 @@ checkNtfToken c = A.checkNtfToken c NRMInteractive verifyNtfToken :: AgentClient -> DeviceToken -> C.CbNonce -> ByteString -> AE () verifyNtfToken c = A.verifyNtfToken c NRMInteractive -runNtfTestCfg :: HasCallStack => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () +runNtfTestCfg :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> AgentMsgId -> AServerConfig -> NtfServerConfig -> AgentConfig -> AgentConfig -> (APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO ()) -> IO () runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do ASSCfg qt mt serverStoreCfg <- pure $ testServerStoreConfig msType let smpCfg' = withServerCfg smpCfg $ \cfg_ -> ASrvCfg qt mt cfg_ {serverStoreCfg} @@ -222,7 +224,7 @@ runNtfTestCfg (t, msType) baseId smpCfg ntfCfg aCfg bCfg runTest = do withAgentClientsCfg2 aCfg bCfg $ runTest apns baseId threadDelay 100000 -testNotificationToken :: APNSMockServer -> IO () +testNotificationToken :: HasTestEnv => APNSMockServer -> IO () testNotificationToken apns = do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" @@ -246,7 +248,7 @@ v .-> key = do -- logCfg :: LogConfig -- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} -testNtfTokenRepeatRegistration :: APNSMockServer -> IO () +testNtfTokenRepeatRegistration :: HasTestEnv => APNSMockServer -> IO () testNtfTokenRepeatRegistration apns = do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" @@ -265,7 +267,7 @@ testNtfTokenRepeatRegistration apns = do NTActive <- checkNtfToken a tkn pure () -testNtfTokenSecondRegistration :: APNSMockServer -> IO () +testNtfTokenSecondRegistration :: HasTestEnv => APNSMockServer -> IO () testNtfTokenSecondRegistration apns = withAgentClients2 $ \a a' -> runRight_ $ do let tkn = DeviceToken PPApnsTest "abcd" @@ -295,7 +297,7 @@ testNtfTokenSecondRegistration apns = NTActive <- checkNtfToken a' tkn pure () -testNtfTokenServerRestart :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenServerRestart :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestart t apns = do let tkn = DeviceToken PPApnsTest "abcd" ntfData <- withAgent 1 agentCfg initAgentServers testDB $ \a -> @@ -316,7 +318,7 @@ testNtfTokenServerRestart t apns = do NTActive <- checkNtfToken a' tkn pure () -testNtfTokenServerRestartReverify :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenServerRestartReverify :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReverify t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a -> do @@ -339,7 +341,7 @@ testNtfTokenServerRestartReverify t apns = do NTActive <- checkNtfToken a' tkn pure () -testNtfTokenServerRestartReverifyTimeout :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenServerRestartReverifyTimeout :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReverifyTimeout t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do @@ -374,7 +376,7 @@ testNtfTokenServerRestartReverifyTimeout t apns = do NTActive <- checkNtfToken a' tkn pure () -testNtfTokenServerRestartReregister :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenServerRestartReregister :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReregister t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a -> @@ -398,7 +400,7 @@ testNtfTokenServerRestartReregister t apns = do NTActive <- checkNtfToken a' tkn pure () -testNtfTokenServerRestartReregisterTimeout :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenServerRestartReregisterTimeout :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenServerRestartReregisterTimeout t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers testDB $ \a@AgentClient {agentEnv = Env {store}} -> do @@ -439,7 +441,7 @@ getTestNtfTokenPort a = Just NtfToken {ntfServer = ProtocolServer {port}} -> pure port Nothing -> error "no active NtfToken" -testNtfTokenMultipleServers :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenMultipleServers :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenMultipleServers t apns = do let tkn = DeviceToken PPApnsTest "abcd" withAgent 1 agentCfg initAgentServers2 testDB $ \a -> @@ -463,7 +465,7 @@ testNtfTokenMultipleServers t apns = do Left _ <- tryError (checkNtfToken a tkn) pure () -testNtfTokenChangeServers :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenChangeServers :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenChangeServers t apns = withNtfServerThreadOn t ntfTestPort ntfTestDBCfg $ \ntf -> do tkn1 <- withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do @@ -493,7 +495,7 @@ testNtfTokenChangeServers t apns = tkn <- registerTestToken a "qwer" NMInstant apns checkNtfToken a tkn >>= \r -> liftIO $ r `shouldBe` NTActive -testNtfTokenReRegisterInvalid :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenReRegisterInvalid :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenReRegisterInvalid t apns = do tkn <- withNtfServer t $ do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do @@ -518,7 +520,7 @@ testNtfTokenReRegisterInvalid t apns = do NTActive <- checkNtfToken a tkn1 pure () -testNtfTokenReRegisterInvalidOnCheck :: ASrvTransport -> APNSMockServer -> IO () +testNtfTokenReRegisterInvalidOnCheck :: HasTestEnv => ASrvTransport -> APNSMockServer -> IO () testNtfTokenReRegisterInvalidOnCheck t apns = do tkn <- withNtfServer t $ do withAgent 1 agentCfg initAgentServers testDB $ \a -> runRight $ do @@ -543,13 +545,13 @@ testNtfTokenReRegisterInvalidOnCheck t apns = do NTActive <- checkNtfToken a tkn1 pure () -testRunNTFServerTests :: ASrvTransport -> NtfServer -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) +testRunNTFServerTests :: HasTestEnv => ASrvTransport -> NtfServer -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testRunNTFServerTests t srv = withNtfServer t $ withAgent 1 agentCfg initAgentServers testDB $ \a -> testProtocolServer a NRMInteractive 1 (ProtoServerWithAuth srv Nothing) -testNotificationSubscriptionExistingConnection :: APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () +testNotificationSubscriptionExistingConnection :: HasTestEnv => APNSMockServer -> AgentMsgId -> AgentClient -> AgentClient -> IO () testNotificationSubscriptionExistingConnection apns baseId alice@AgentClient {agentEnv = Env {config = aliceCfg, store}} bob = do (bobId, aliceId, nonce, message) <- runRight $ do -- establish connection @@ -662,7 +664,7 @@ registerTestToken a token mode apns = do NTActive <- checkNtfToken a tkn pure tkn -testChangeNotificationsMode :: HasCallStack => APNSMockServer -> IO () +testChangeNotificationsMode :: (HasCallStack, HasTestEnv) => APNSMockServer -> IO () testChangeNotificationsMode apns = withAgentClients2 $ \alice bob -> runRight_ $ do -- establish connection @@ -725,7 +727,7 @@ testChangeNotificationsMode apns = baseId = 1 msgId = subtract baseId -testChangeToken :: APNSMockServer -> IO () +testChangeToken :: HasTestEnv => APNSMockServer -> IO () testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> do (aliceId, bobId) <- withAgent 2 agentCfg initAgentServers testDB $ \alice -> runRight $ do -- establish connection @@ -765,7 +767,7 @@ testChangeToken apns = withAgent 1 agentCfg initAgentServers testDB2 $ \bob -> d baseId = 1 msgId = subtract baseId -testNotificationsStoreLog :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsStoreLog :: HasTestEnv => (ASrvTransport, AStoreType) -> APNSMockServer -> IO () testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do withSmpServerStoreMsgLogOn ps testPort $ \_ -> do (aliceId, bobId) <- withNtfServer t $ runRight $ do @@ -800,7 +802,7 @@ testNotificationsStoreLog ps@(t, _) apns = withAgentClients2 $ \alice bob -> do withNtfServer t $ runRight_ $ do void $ messageNotificationData alice apns -testNotificationsSMPRestart :: (ASrvTransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsSMPRestart :: HasTestEnv => (ASrvTransport, AStoreType) -> APNSMockServer -> IO () testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do (aliceId, bobId) <- withSmpServerStoreLogOn ps testPort $ \threadId -> runRight $ do (aliceId, bobId) <- makeConnection alice bob @@ -828,7 +830,7 @@ testNotificationsSMPRestart ps apns = withAgentClients2 $ \alice bob -> do get alice =##> \case ("", c, Msg "hello again") -> c == bobId; _ -> False liftIO $ killThread threadId -testNotificationsSMPRestartBatch :: Int -> (ASrvTransport, AStoreType) -> APNSMockServer -> IO () +testNotificationsSMPRestartBatch :: HasTestEnv => Int -> (ASrvTransport, AStoreType) -> APNSMockServer -> IO () testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns = withAgentClientsCfgServers2 agentCfg agentCfg initAgentServers2 $ \a b -> do threadDelay 1000000 @@ -874,7 +876,7 @@ testNotificationsSMPRestartBatch n ps@(t, ASType qsType _) apns = killThread t1 pure res -testSwitchNotifications :: AgentConfig -> (AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()) -> InitialAgentServers -> APNSMockServer -> IO () +testSwitchNotifications :: HasTestEnv => AgentConfig -> (AgentClient -> ByteString -> AgentClient -> ByteString -> ExceptT AgentErrorType IO ()) -> InitialAgentServers -> APNSMockServer -> IO () testSwitchNotifications cfg completeSwitch servers apns = withAgentClientsCfgServers2 cfg cfg servers $ \a b -> runRight_ $ do (aId, bId) <- makeConnection a b @@ -893,7 +895,7 @@ testSwitchNotifications cfg completeSwitch servers apns = liftIO $ threadDelay 500000 testMessage "hello again" -testNotificationsOldToken :: APNSMockServer -> IO () +testNotificationsOldToken :: HasTestEnv => APNSMockServer -> IO () testNotificationsOldToken apns = withAgentClients3 $ \a b c -> runRight_ $ do (abId, baId) <- makeConnection a b @@ -912,7 +914,7 @@ testNotificationsOldToken apns = let testMessageAC = testMessage_ apns a acId c caId testMessageAC "greetings" -testNotificationsNewToken :: APNSMockServer -> ThreadId -> IO () +testNotificationsNewToken :: HasTestEnv => APNSMockServer -> ThreadId -> IO () testNotificationsNewToken apns oldNtf = withAgentClients3 $ \a b c -> runRight_ $ do (abId, baId) <- makeConnection a b @@ -934,7 +936,7 @@ testNotificationsNewToken apns oldNtf = let testMessageAC = testMessage_ apns a acId c caId testMessageAC "greetings" -testMigrateToServiceSubscriptions :: HasCallStack => (ASrvTransport, AStoreType) -> IO () +testMigrateToServiceSubscriptions :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO () testMigrateToServiceSubscriptions ps@(t, msType) = withAgentClients2 $ \a b -> do (c1, c2, c3) <- withSmpServerConfigOn t cfgNoService testPort $ \_ -> do (c1, c2) <- withAPNSMockServer $ \apns -> do diff --git a/tests/AgentTests/ResolveNameTests.hs b/tests/AgentTests/ResolveNameTests.hs index d8507194e..6fc538432 100644 --- a/tests/AgentTests/ResolveNameTests.hs +++ b/tests/AgentTests/ResolveNameTests.hs @@ -32,7 +32,7 @@ import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.SimplexName (SimplexDomain (..), SimplexTLD (..)) import Simplex.Messaging.Transport import Test.Hspec hiding (fit, it) -import Util (it) +import Util (HasTestEnv, it) nameSrvCfg :: SMPServer -> ServerCfg 'SMP.PSMP nameSrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = False, names = True} (Just 1) . SMP.noAuthSrv @@ -40,16 +40,16 @@ nameSrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = False, na proxySrvCfg :: SMPServer -> ServerCfg 'SMP.PSMP proxySrvCfg = presetServerCfg True ServerRoles {storage = True, proxy = True, names = False} (Just 1) . SMP.noAuthSrv -oneSrv :: ServerCfg 'SMP.PSMP -> InitialAgentServers +oneSrv :: HasTestEnv => ServerCfg 'SMP.PSMP -> InitialAgentServers oneSrv cfg_ = (initAgentServersProxy_ SPMNever SPFProhibit) {smp = [(1, [cfg_])]} -withDirectResolver :: (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a +withDirectResolver :: HasTestEnv => (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a withDirectResolver (st, body) k = NRS.withResolverServer (NRS.resolveResp st body) $ \port _ -> withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort $ \_ -> withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k -withProxyAndResolver :: (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a +withProxyAndResolver :: HasTestEnv => (Status, LB.ByteString) -> (AgentClient -> IO a) -> IO a withProxyAndResolver (st, body) k = NRS.withResolverServer (NRS.resolveResp st body) $ \port _ -> withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> @@ -59,12 +59,12 @@ withProxyAndResolver (st, body) k = -- only testSMPServer2 (the resolver) has the names role; testSMPServer is the proxy proxyServers = (initAgentServersProxy_ SPMAlways SPFProhibit) {smp = [(1, [proxySrvCfg testSMPServer, nameSrvCfg testSMPServer2])]} -withNoResolver :: (AgentClient -> IO a) -> IO a +withNoResolver :: HasTestEnv => (AgentClient -> IO a) -> IO a withNoResolver k = withSmpServerConfigOn (transport @TLS) memCfg testPort $ \_ -> withAgent 1 agentCfg (oneSrv (nameSrvCfg testSMPServer)) testDB k -withNoNameServers :: (AgentClient -> IO a) -> IO a +withNoNameServers :: HasTestEnv => (AgentClient -> IO a) -> IO a withNoNameServers k = withAgent 1 agentCfg (oneSrv (proxySrvCfg testSMPServer)) testDB k resolveNameTests :: Spec @@ -88,7 +88,7 @@ resolveNameTests = do describe "name availability" $ it "an unregistered name answers as available" testAvailSuccess -testAvailSuccess :: HasCallStack => IO () +testAvailSuccess :: (HasCallStack, HasTestEnv) => IO () testAvailSuccess = withDirectResolver (status200, availableBody) $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" []) @@ -98,7 +98,7 @@ testAvailSuccess = -- | 404 is a resolver that predates /v2/resolve: no status from that endpoint -- means "not registered", since an unregistered name answers NRAvailable. -testDirectResolverErr :: HasCallStack => IO () +testDirectResolverErr :: (HasCallStack, HasTestEnv) => IO () testDirectResolverErr = withDirectResolver (status404, "{}") $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" []) @@ -106,7 +106,7 @@ testDirectResolverErr = Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure () _ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r -testProxyResolverErr :: HasCallStack => IO () +testProxyResolverErr :: (HasCallStack, HasTestEnv) => IO () testProxyResolverErr = withProxyAndResolver (status404, "{}") $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" []) @@ -114,7 +114,7 @@ testProxyResolverErr = Left (SMP host (SMP.NAME (SMP.RESOLVER _))) | testPort `isInfixOf` host -> pure () _ -> expectationFailure $ "expected Left (SMP testPort <> "> (NAME (RESOLVER _))), got: " <> show r -testTestingTldResolverErr :: HasCallStack => IO () +testTestingTldResolverErr :: (HasCallStack, HasTestEnv) => IO () testTestingTldResolverErr = withDirectResolver (status404, "{}") $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDTesting "bob" []) @@ -122,7 +122,7 @@ testTestingTldResolverErr = Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure () _ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r -testWebTldResolverErr :: HasCallStack => IO () +testWebTldResolverErr :: (HasCallStack, HasTestEnv) => IO () testWebTldResolverErr = withDirectResolver (status404, "{}") $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDWeb "example.com" []) @@ -130,7 +130,7 @@ testWebTldResolverErr = Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure () _ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER _))), got: " <> show r -testNoResolver :: HasCallStack => IO () +testNoResolver :: (HasCallStack, HasTestEnv) => IO () testNoResolver = withNoResolver $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" []) @@ -138,7 +138,7 @@ testNoResolver = Left (SMP _ (SMP.NAME SMP.NO_RESOLVER)) -> pure () _ -> expectationFailure $ "expected Left (SMP _ (NAME NO_RESOLVER)), got: " <> show r -testNoNameServers :: HasCallStack => IO () +testNoNameServers :: (HasCallStack, HasTestEnv) => IO () testNoNameServers = withNoNameServers $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" []) @@ -146,7 +146,7 @@ testNoNameServers = Left NO_NAME_SERVERS -> pure () _ -> expectationFailure $ "expected Left NO_NAME_SERVERS, got: " <> show r -testBackendError :: HasCallStack => IO () +testBackendError :: (HasCallStack, HasTestEnv) => IO () testBackendError = withDirectResolver (status502, "{}") $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" []) @@ -154,7 +154,7 @@ testBackendError = Left (SMP _ (SMP.NAME (SMP.RESOLVER _))) -> pure () _ -> expectationFailure $ "expected Left (SMP _ (NAME (RESOLVER ..))), got: " <> show r -testDirectSuccess :: HasCallStack => IO () +testDirectSuccess :: (HasCallStack, HasTestEnv) => IO () testDirectSuccess = withDirectResolver (status200, registeredBody testNameRecord) $ \c -> do r <- runExceptT $ resolveSimplexName c NRMInteractive 1 (SimplexDomain TLDSimplex "alice" []) diff --git a/tests/AgentTests/ServerChoice.hs b/tests/AgentTests/ServerChoice.hs index a5808f6a7..8cffd9e15 100644 --- a/tests/AgentTests/ServerChoice.hs +++ b/tests/AgentTests/ServerChoice.hs @@ -57,7 +57,7 @@ storageOnly = ServerRoles {storage = True, proxy = False, names = False} proxyOnly :: ServerRoles proxyOnly = ServerRoles {storage = False, proxy = True, names = False} -initServers :: InitialAgentServers +initServers :: HasTestEnv => InitialAgentServers initServers = InitialAgentServers { smp = M.fromList [(1, testSMPServers)], @@ -70,7 +70,7 @@ initServers = presetServers = [] } -testChooseDifferentOperator :: IO () +testChooseDifferentOperator :: HasTestEnv => IO () testChooseDifferentOperator = withAgent 1 agentCfg initServers testDB $ \c -> runRight_ $ do -- chooses the only operator with storage role srv1 <- withAgentEnv c $ getNextServer c 1 storageSrvs [] diff --git a/tests/CLITests.hs b/tests/CLITests.hs index b177d6004..9e739a7ad 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -49,32 +49,32 @@ import Util import qualified Data.ByteString.Char8 as B import qualified Database.PostgreSQL.Simple as PSQL import Database.PostgreSQL.Simple.Types (Query (..)) -import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestStoreDBOpts) +import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBConnstr, ntfTestServerDBOpts) import SMPClient (postgressBracket) import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Notifications.Server.Main #endif -cfgPath :: FilePath -cfgPath = "tests/tmp/cli/etc/opt/simplex" +cfgPath :: HasTestEnv => FilePath +cfgPath = testPath "cli/etc/opt/simplex" -logPath :: FilePath -logPath = "tests/tmp/cli/etc/var/simplex" +logPath :: HasTestEnv => FilePath +logPath = testPath "cli/etc/var/simplex" -webPath :: FilePath -webPath = "tests/tmp/cli/var/www" +webPath :: HasTestEnv => FilePath +webPath = testPath "cli/var/www" -ntfCfgPath :: FilePath -ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications" +ntfCfgPath :: HasTestEnv => FilePath +ntfCfgPath = testPath "cli/etc/opt/simplex-notifications" -ntfLogPath :: FilePath -ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications" +ntfLogPath :: HasTestEnv => FilePath +ntfLogPath = testPath "cli/etc/var/simplex-notifications" -fileCfgPath :: FilePath -fileCfgPath = "tests/tmp/cli/etc/opt/simplex-files" +fileCfgPath :: HasTestEnv => FilePath +fileCfgPath = testPath "cli/etc/opt/simplex-files" -fileLogPath :: FilePath -fileLogPath = "tests/tmp/cli/etc/var/simplex-files" +fileLogPath :: HasTestEnv => FilePath +fileLogPath = testPath "cli/etc/var/simplex-files" cliTests :: Spec cliTests = do @@ -87,7 +87,7 @@ cliTests = do it "static files" smpServerTestStatic it "cloud scripts disable embedded web without certificates" smpCloudScriptsDisableWeb #if defined(dbServerPostgres) - around_ (postgressBracket ntfTestServerDBConnectInfo) $ before_ (createNtfSchema ntfTestServerDBConnectInfo ntfTestStoreDBOpts) $ + around_ (postgressBracket ntfTestServerDBConnectInfo) $ before_ (createNtfSchema ntfTestServerDBConnectInfo ntfTestServerDBOpts) $ describe "Ntf server CLI" $ do it "should initialize, start and delete the server (no store log)" $ ntfServerTest False it "should initialize, start and delete the server (with store log)" $ ntfServerTest True @@ -96,7 +96,7 @@ cliTests = do it "should initialize, start and delete the server (no store log)" $ xftpServerTest False it "should initialize, start and delete the server (with store log)" $ xftpServerTest True -smpServerTest :: Bool -> Bool -> IO () +smpServerTest :: HasTestEnv => Bool -> Bool -> IO () smpServerTest storeLog basicAuth = do -- init capture_ (withArgs (["init", "-y"] <> ["--disable-store-log" | not storeLog] <> ["--no-password" | not basicAuth]) $ smpServerCLI cfgPath logPath) @@ -137,7 +137,7 @@ smpServerTest storeLog basicAuth = do >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`)) doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False -smpServerTestStatic :: HasCallStack => IO () +smpServerTestStatic :: (HasCallStack, HasTestEnv) => IO () smpServerTestStatic = do let iniFile = cfgPath <> "/smp-server.ini" capture_ (withArgs ["init", "-y", "--no-password", "--web-path", webPath] $ smpServerCLI cfgPath logPath) @@ -225,7 +225,7 @@ createNtfSchema connInfo DBOpts {schema} = do void $ PSQL.execute_ db $ Query $ "CREATE SCHEMA " <> schema PSQL.close db -ntfServerTest :: Bool -> IO () +ntfServerTest :: HasTestEnv => Bool -> IO () ntfServerTest storeLog = do capture_ (withArgs (["init", "--database=" <> B.unpack ntfTestServerDBConnstr] <> ["--disable-store-log" | not storeLog]) $ ntfServerCLI ntfCfgPath ntfLogPath) >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> ntfCfgPath <> "/ntf-server.ini") `isPrefixOf`)) @@ -244,9 +244,9 @@ ntfServerTest storeLog = do doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False #endif -xftpServerTest :: Bool -> IO () +xftpServerTest :: HasTestEnv => Bool -> IO () xftpServerTest storeLog = do - capture_ (withArgs (["init", "-p", "tests/tmp", "-q", "10gb"] <> ["--disable-store-log" | not storeLog]) $ xftpServerCLI fileCfgPath fileLogPath) + capture_ (withArgs (["init", "-p", testDir, "-q", "10gb"] <> ["--disable-store-log" | not storeLog]) $ xftpServerCLI fileCfgPath fileLogPath) >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> fileCfgPath <> "/file-server.ini") `isPrefixOf`)) Right ini <- readIniFile $ fileCfgPath <> "/file-server.ini" lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off") diff --git a/tests/CoreTests/CryptoFileTests.hs b/tests/CoreTests/CryptoFileTests.hs index ce9fa7c35..40ee73579 100644 --- a/tests/CoreTests/CryptoFileTests.hs +++ b/tests/CoreTests/CryptoFileTests.hs @@ -24,10 +24,10 @@ cryptoFileTests = do it "should put/read file" testPutReadFile it "should fail reading empty or small file" testSmallFile -testFilePath :: FilePath -testFilePath = "tests/tmp/testcryptofile" +testFilePath :: HasTestEnv => FilePath +testFilePath = testPath "testcryptofile" -testWriteReadFile :: IO () +testWriteReadFile :: HasTestEnv => IO () testWriteReadFile = do g <- C.newRandom s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g @@ -39,7 +39,7 @@ testWriteReadFile = do s' <- CF.readFile file liftIO $ s `shouldBe` s' -testPutGetFile :: IO () +testPutGetFile :: HasTestEnv => IO () testPutGetFile = do g <- C.newRandom s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g @@ -59,7 +59,7 @@ testPutGetFile = do CF.hGetTag h liftIO $ (s <> s') `shouldBe` LB.fromStrict (s1 <> s2 <> s3) -testWriteGetFile :: IO () +testWriteGetFile :: HasTestEnv => IO () testWriteGetFile = do g <- C.newRandom s <- atomically $ LB.fromStrict <$> C.randomBytes 100000 g @@ -73,7 +73,7 @@ testWriteGetFile = do liftIO $ runExceptT (CF.hGetTag h) `shouldReturn` Left FTCEInvalidAuthTag liftIO $ s `shouldBe` LB.fromStrict (s' <> s'') -testPutReadFile :: IO () +testPutReadFile :: HasTestEnv => IO () testPutReadFile = do g <- C.newRandom s <- atomically $ LB.fromStrict <$> C.randomBytes 50000 g @@ -92,7 +92,7 @@ testPutReadFile = do s'' <- CF.readFile file liftIO $ (s <> s') `shouldBe` s'' -testSmallFile :: IO () +testSmallFile :: HasTestEnv => IO () testSmallFile = do g <- C.newRandom file <- atomically $ mkCryptoFile g @@ -101,5 +101,5 @@ testSmallFile = do LB.writeFile testFilePath "123" runExceptT (CF.readFile file) `shouldReturn` Left FTCEInvalidFileSize -mkCryptoFile :: TVar ChaChaDRG -> STM CryptoFile +mkCryptoFile :: HasTestEnv => TVar ChaChaDRG -> STM CryptoFile mkCryptoFile g = CryptoFile testFilePath . Just <$> CF.randomArgs g diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index 268611990..ad5550b55 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -146,9 +146,9 @@ instance Eq C.APrivateKey where Just Refl -> k == k' Nothing -> False -testPadUnpadFile :: IO () +testPadUnpadFile :: HasTestEnv => IO () testPadUnpadFile = do - let f = "tests/tmp/testpad" + let f = testPath "testpad" paddedLen = 1024 * 1024 len = 1000000 s = LB.replicate len 'a' @@ -208,7 +208,7 @@ testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random s g <- C.newRandom k <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g - let f = "tests/tmp/testsecretbox" + let f = testPath "testsecretbox" paddedLen = 4 * 1024 * 1024 len = 4 * 1000 * 1000 :: Int64 s = LC.fastReplicate len 'a' @@ -236,7 +236,7 @@ testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a r g <- C.newRandom k <- atomically $ C.randomSbKey g nonce <- atomically $ C.randomCbNonce g - let f = "tests/tmp/testsecretbox" + let f = testPath "testsecretbox" paddedLen = 4 * 1024 * 1024 len = 4 * 1000 * 1000 :: Int64 s = LC.fastReplicate len 'a' diff --git a/tests/CoreTests/MsgStoreTests.hs b/tests/CoreTests/MsgStoreTests.hs index d4a2d7582..0352f0f65 100644 --- a/tests/CoreTests/MsgStoreTests.hs +++ b/tests/CoreTests/MsgStoreTests.hs @@ -58,50 +58,47 @@ import Simplex.Messaging.Agent.Store.Postgres.Common import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) import Simplex.Messaging.Server.MsgStore.Postgres import Simplex.Messaging.Server.QueueStore.Postgres -import SMPClient (postgressBracket, testServerDBConnectInfo, testStoreDBOpts) +import SMPClient (testStoreDBOpts) #endif msgStoreTests :: Spec msgStoreTests = do - around (withMsgStore testSMTStoreConfig) $ describe "STM message store" someMsgStoreTests - around (withMsgStore $ testJournalStoreCfg MQStoreCfg) $ describe "Journal message store" $ do - someMsgStoreTests - journalMsgStoreTests - it "should export and import journal store" testExportImportStore + describe "STM message store" $ someMsgStoreTests testSMTStoreConfig + describe "Journal message store" $ do + someMsgStoreTests $ testJournalStoreCfg MQStoreCfg + journalMsgStoreTests $ testJournalStoreCfg MQStoreCfg + it "should export and import journal store" $ withMsgStore (testJournalStoreCfg MQStoreCfg) testExportImportStore #if defined(dbServerPostgres) - around_ (postgressBracket testServerDBConnectInfo) $ do - around (withMsgStore $ testJournalStoreCfg $ PQStoreCfg testPostgresStoreCfg) $ - describe "Postgres+journal message store" $ do - someMsgStoreTests - journalMsgStoreTests - around (withMsgStore testPostgresStoreConfig) $ - describe "Postgres-only message store" $ do - someMsgStoreTests - it "should correctly update message counts and canWrite flag" testUpdateMessageCounts - it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" testResetMessageCounts - it "should expire messages across commit batches" testExpireMessagesInBatches + describe "Postgres+journal message store" $ do + someMsgStoreTests $ testJournalStoreCfg $ PQStoreCfg testPostgresStoreCfg + journalMsgStoreTests $ testJournalStoreCfg $ PQStoreCfg testPostgresStoreCfg + describe "Postgres-only message store" $ do + someMsgStoreTests testPostgresStoreConfig + it "should correctly update message counts and canWrite flag" $ withMsgStore testPostgresStoreConfig testUpdateMessageCounts + it "tryDelPeekMsg (ACK not from NSE) should reset message counts when queue is empty" $ withMsgStore testPostgresStoreConfig testResetMessageCounts + it "should expire messages across commit batches" $ withMsgStore testPostgresStoreConfig testExpireMessagesInBatches #endif describe "Journal message store: queue state backup expiration" $ do it "should remove old queue state backups" testRemoveQueueStateBackups it "should expire messages in idle queues" testExpireIdleQueues where - journalMsgStoreTests :: SpecWith (JournalMsgStore s) - journalMsgStoreTests = do + journalMsgStoreTests :: (HasTestEnv => JournalStoreConfig s) -> Spec + journalMsgStoreTests cfg = do describe "queue state" $ do - it "should restore queue state from the last line" testQueueState - it "should recover when message is written and state is not" testMessageState - it "should remove journal files when queue is empty" testRemoveJournals + it "should restore queue state from the last line" $ withMsgStore cfg testQueueState + it "should recover when message is written and state is not" $ withMsgStore cfg testMessageState + it "should remove journal files when queue is empty" $ withMsgStore cfg testRemoveJournals describe "missing files" $ do - it "should create read file when missing" testReadFileMissing - it "should switch to write file when read file missing" testReadFileMissingSwitch - it "should create write file when missing" testWriteFileMissing - it "should create read file when read and write files are missing" testReadAndWriteFilesMissing - someMsgStoreTests :: MsgStoreClass s => SpecWith s - someMsgStoreTests = do - it "should get queue and store/read messages" testGetQueue - it "should write/ack messages" testWriteAckMessages - it "should not fail on EOF when changing read journal" testChangeReadJournal - it "should not add link data to secured messaging queue" testLinkDataSecuredQueue + it "should create read file when missing" $ withMsgStore cfg testReadFileMissing + it "should switch to write file when read file missing" $ withMsgStore cfg testReadFileMissingSwitch + it "should create write file when missing" $ withMsgStore cfg testWriteFileMissing + it "should create read file when read and write files are missing" $ withMsgStore cfg testReadAndWriteFilesMissing + someMsgStoreTests :: MsgStoreClass s => (HasTestEnv => MsgStoreConfig s) -> Spec + someMsgStoreTests cfg = do + it "should get queue and store/read messages" $ withMsgStore cfg testGetQueue + it "should write/ack messages" $ withMsgStore cfg testWriteAckMessages + it "should not fail on EOF when changing read journal" $ withMsgStore cfg testChangeReadJournal + it "should not add link data to secured messaging queue" $ withMsgStore cfg testLinkDataSecuredQueue -- TODO constrain to STM stores? withMsgStore :: MsgStoreClass s => MsgStoreConfig s -> (s -> IO ()) -> IO () @@ -110,7 +107,7 @@ withMsgStore cfg = bracket (newMsgStore cfg) closeMsgStore testSMTStoreConfig :: STMStoreConfig testSMTStoreConfig = STMStoreConfig {storePath = Nothing, quota = 3} -testJournalStoreCfg :: QStoreCfg s -> JournalStoreConfig s +testJournalStoreCfg :: HasTestEnv => QStoreCfg s -> JournalStoreConfig s testJournalStoreCfg queueStoreCfg = JournalStoreConfig { storePath = testStoreMsgsDir, @@ -126,14 +123,14 @@ testJournalStoreCfg queueStoreCfg = } #if defined(dbServerPostgres) -testPostgresStoreConfig :: PostgresMsgStoreCfg +testPostgresStoreConfig :: HasTestEnv => PostgresMsgStoreCfg testPostgresStoreConfig = PostgresMsgStoreCfg { queueStoreCfg = testPostgresStoreCfg, quota = 3 } -testPostgresStoreCfg :: PostgresStoreCfg +testPostgresStoreCfg :: HasTestEnv => PostgresStoreCfg testPostgresStoreCfg = PostgresStoreCfg { dbOpts = testStoreDBOpts, @@ -295,7 +292,7 @@ testLinkDataSecuredQueue ms = do void $ ExceptT $ deleteQueue ms q void $ ExceptT $ deleteQueue ms cq -testExportImportStore :: JournalMsgStore 'QSMemory -> IO () +testExportImportStore :: HasTestEnv => JournalMsgStore 'QSMemory -> IO () testExportImportStore ms = do g <- C.newRandom (rId1, qr1) <- testNewQueueRec g QMMessaging @@ -608,7 +605,7 @@ testRemoveJournals ms = do journalFilesCount dir = length . filter ("messages." `isPrefixOf`) <$> listDirectory dir stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir -testRemoveQueueStateBackups :: IO () +testRemoveQueueStateBackups :: HasTestEnv => IO () testRemoveQueueStateBackups = do g <- C.newRandom (rId, qr) <- testNewQueueRec g QMMessaging @@ -644,7 +641,7 @@ testRemoveQueueStateBackups = do where stateBackupCount dir = length . filter (".bak" `isSuffixOf`) <$> listDirectory dir -testExpireIdleQueues :: IO () +testExpireIdleQueues :: HasTestEnv => IO () testExpireIdleQueues = do g <- C.newRandom (rId, qr) <- testNewQueueRec g QMMessaging diff --git a/tests/CoreTests/StoreLogTests.hs b/tests/CoreTests/StoreLogTests.hs index 81a0535d5..3c030a143 100644 --- a/tests/CoreTests/StoreLogTests.hs +++ b/tests/CoreTests/StoreLogTests.hs @@ -177,10 +177,10 @@ testSMPStoreLog testSuite tests = closeStoreLog l replicateM_ 3 $ testReadWrite t #if defined(dbServerPostgres) - (sCnt, qCnt) <- importStoreLogToDatabase "tests/tmp/" testStoreLogFile testStoreDBOpts + (sCnt, qCnt) <- importStoreLogToDatabase testDir testStoreLogFile testStoreDBOpts fromIntegral (sCnt + qCnt) `shouldBe` length (compacted t) imported <- B.readFile $ testStoreLogFile <> ".bak" - (sCnt', qCnt') <- exportDatabaseToStoreLog "tests/tmp/" testStoreDBOpts testStoreLogFile + (sCnt', qCnt') <- exportDatabaseToStoreLog testDir testStoreDBOpts testStoreLogFile sCnt' `shouldBe` fromIntegral sCnt qCnt' `shouldBe` fromIntegral qCnt exported <- B.readFile testStoreLogFile @@ -207,8 +207,8 @@ deriving instance Eq FileRecipient deriving instance Eq FileStoreLogRecord -testFileStoreLogFile :: FilePath -testFileStoreLogFile = "tests/tmp/xftp-server-store.log" +testFileStoreLogFile :: HasTestEnv => FilePath +testFileStoreLogFile = testPath "xftp-server-store.log" fileExpirationTests :: Spec fileExpirationTests = diff --git a/tests/CoreTests/XFTPStoreTests.hs b/tests/CoreTests/XFTPStoreTests.hs index 52c7cedfa..cb121b8d8 100644 --- a/tests/CoreTests/XFTPStoreTests.hs +++ b/tests/CoreTests/XFTPStoreTests.hs @@ -47,7 +47,7 @@ xftpMigrationTests = describe "XFTP migration round-trip" $ do -- Test helpers -withPgStore :: (PostgresFileStore -> IO ()) -> IO () +withPgStore :: HasTestEnv => (PostgresFileStore -> IO ()) -> IO () withPgStore test = do st <- newFileStore testXFTPPostgresCfg :: IO PostgresFileStore test st @@ -75,7 +75,7 @@ testExpiresAt = RoundedSystemTime 2000000 -- Tests -testAddGetFileSender :: Expectation +testAddGetFileSender :: HasTestEnv => Expectation testAddGetFileSender = withPgStore $ \st -> do g <- C.newRandom (sk, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -91,7 +91,7 @@ testAddGetFileSender = withPgStore $ \st -> do key `shouldBe` sk Left e -> expectationFailure $ "getFile failed: " <> show e -testAddGetFileRecipient :: Expectation +testAddGetFileRecipient :: HasTestEnv => Expectation testAddGetFileRecipient = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -106,7 +106,7 @@ testAddGetFileRecipient = withPgStore $ \st -> do key `shouldBe` rcpKey Left e -> expectationFailure $ "getFile failed: " <> show e -testDuplicateFile :: Expectation +testDuplicateFile :: HasTestEnv => Expectation testDuplicateFile = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -114,12 +114,12 @@ testDuplicateFile = withPgStore $ \st -> do addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Right () addFile st testSenderId fileInfo testCreatedAt Nothing EntityActive `shouldReturn` Left DUPLICATE_ -testGetNonexistent :: Expectation +testGetNonexistent :: HasTestEnv => Expectation testGetNonexistent = withPgStore $ \st -> do getFile st SFSender testSenderId >>= (`shouldBe` Left AUTH) . fmap (const ()) getFile st SFRecipient testRecipientId >>= (`shouldBe` Left AUTH) . fmap (const ()) -testSetFilePath :: Expectation +testSetFilePath :: HasTestEnv => Expectation testSetFilePath = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -134,7 +134,7 @@ testSetFilePath = withPgStore $ \st -> do Right (FileRec {filePath}, _) -> readTVarIO filePath `shouldReturn` Just "/tmp/test_file" Left e -> expectationFailure $ "getFile failed: " <> show e -testDuplicateRecipient :: Expectation +testDuplicateRecipient :: HasTestEnv => Expectation testDuplicateRecipient = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -144,7 +144,7 @@ testDuplicateRecipient = withPgStore $ \st -> do addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Right () addRecipient st testSenderId (FileRecipient testRecipientId rcpKey) `shouldReturn` Left DUPLICATE_ -testDeleteFileCascade :: Expectation +testDeleteFileCascade :: HasTestEnv => Expectation testDeleteFileCascade = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -157,7 +157,7 @@ testDeleteFileCascade = withPgStore $ \st -> do getFile st SFSender testSenderId >>= (`shouldBe` Left AUTH) . fmap (const ()) getFile st SFRecipient testRecipientId >>= (`shouldBe` Left AUTH) . fmap (const ()) -testBlockFile :: Expectation +testBlockFile :: HasTestEnv => Expectation testBlockFile = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -170,7 +170,7 @@ testBlockFile = withPgStore $ \st -> do Right (FileRec {fileStatus}, _) -> readTVarIO fileStatus `shouldReturn` EntityBlocked blockInfo Left e -> expectationFailure $ "getFile failed: " <> show e -testAckFile :: Expectation +testAckFile :: HasTestEnv => Expectation testAckFile = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -186,7 +186,7 @@ testAckFile = withPgStore $ \st -> do Right _ -> pure () Left e -> expectationFailure $ "getFile failed: " <> show e -testExpiredFiles :: Expectation +testExpiredFiles :: HasTestEnv => Expectation testExpiredFiles = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -207,7 +207,7 @@ testExpiredFiles = withPgStore $ \st -> do sz `shouldBe` 128000 _ -> expectationFailure "expected 1 expired file" -testExpiredFilesStoredExpiration :: Expectation +testExpiredFilesStoredExpiration :: HasTestEnv => Expectation testExpiredFilesStoredExpiration = withPgStore $ \st -> do g <- C.newRandom (sndKey, _) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -219,7 +219,7 @@ testExpiredFilesStoredExpiration = withPgStore $ \st -> do expired <- expiredFiles st (RoundedSystemTime 500000) 0 100 map (\(sId, _, _) -> sId) expired `shouldBe` [EntityId "expired_file____"] -testStorageAndCount :: Expectation +testStorageAndCount :: HasTestEnv => Expectation testStorageAndCount = withPgStore $ \st -> do testStorageAndCountForStore st @@ -250,10 +250,10 @@ testStorageAndCountForStore st = do -- Migration round-trip test -testMigrationRoundTrip :: Expectation +testMigrationRoundTrip :: HasTestEnv => Expectation testMigrationRoundTrip = do - let storeLogPath = "tests/tmp/xftp-migration-test.log" - storeLogPath2 = "tests/tmp/xftp-migration-test2.log" + let storeLogPath = testPath "xftp-migration-test.log" + storeLogPath2 = testPath "xftp-migration-test2.log" -- 1. Create STM store with test data stmStore <- newFileStore () :: IO STMFileStore g <- C.newRandom diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs index b4b8ffd28..ad4557476 100644 --- a/tests/FileDescriptionTests.hs +++ b/tests/FileDescriptionTests.hs @@ -33,8 +33,8 @@ fileDescriptionTests = do fileDescPath :: FilePath fileDescPath = "tests/fixtures/file_description.yaml" -tmpFileDescPath :: FilePath -tmpFileDescPath = "tests/tmp/file_description.yaml" +tmpFileDescPath :: HasTestEnv => FilePath +tmpFileDescPath = testPath "file_description.yaml" testSbKey :: C.SbKey testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY=" @@ -144,7 +144,7 @@ testParseYAMLFileDescription = do yfd <- Y.decodeFileThrow fileDescPath yfd `shouldBe` yamlFileDesc -testSerializeYAMLFileDescription :: IO () +testSerializeYAMLFileDescription :: HasTestEnv => IO () testSerializeYAMLFileDescription = withRemoveTmpFile $ do Y.encodeFile tmpFileDescPath yamlFileDesc fdSer <- B.readFile tmpFileDescPath @@ -158,7 +158,7 @@ testParseFileDescription = do Left e -> expectationFailure $ show e Right fd -> fd `shouldBe` fileDesc -testSerializeFileDescription :: IO () +testSerializeFileDescription :: HasTestEnv => IO () testSerializeFileDescription = withRemoveTmpFile $ do B.writeFile tmpFileDescPath $ strEncode fileDesc fdSer <- B.readFile tmpFileDescPath @@ -177,7 +177,7 @@ testFileDescriptionURIExtras = do let descr = FileDescriptionURI SSSimplex vfd $ Just "{\"something\":\"extra\",\"more\":true}" strDecode (strEncode descr) `shouldBe` Right descr -withRemoveTmpFile :: IO () -> IO () +withRemoveTmpFile :: HasTestEnv => IO () -> IO () withRemoveTmpFile = bracket_ (pure ()) diff --git a/tests/NamesResolverServer.hs b/tests/NamesResolverServer.hs index 054d55e40..e7f57b2fb 100644 --- a/tests/NamesResolverServer.hs +++ b/tests/NamesResolverServer.hs @@ -30,6 +30,7 @@ import SMPClient (AServerConfig (..), cfgMS, proxyCfgMS, testStoreLogFile2, test import Simplex.Messaging.Server.Env.STM (AStoreType (..), ServerConfig (..), ServerStoreCfg (..), StorePaths (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Server.Names (NamesConfig (..)) +import Util (HasTestEnv) -- | Run an action with a local HTTP resolver on a free port. withResolverServer :: ([Text] -> (Status, LB.ByteString)) -> (Int -> IORef [[Text]] -> IO a) -> IO a @@ -64,13 +65,13 @@ testNamesConfig port = resolverMaxResponseBytes = 65536 } -memCfg :: AServerConfig +memCfg :: HasTestEnv => AServerConfig memCfg = cfgMS (ASType SQSMemory SMSMemory) -memProxyCfg :: AServerConfig +memProxyCfg :: HasTestEnv => AServerConfig memProxyCfg = proxyCfgMS (ASType SQSMemory SMSMemory) -memCfg2 :: AServerConfig +memCfg2 :: HasTestEnv => AServerConfig memCfg2 = case memCfg of ASrvCfg qt mt c -> ASrvCfg qt mt c {serverStoreCfg = newStoreCfg (serverStoreCfg c)} where diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index b0ee811d3..79dac6dd3 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -60,30 +60,31 @@ import UnliftIO.Async import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import UnliftIO.STM +import Util testHost :: NonEmpty TransportHost testHost = "localhost" -apnsTestPort :: ServiceName -apnsTestPort = "6010" +apnsTestPort :: HasTestEnv => ServiceName +apnsTestPort = testServerPort 5 testKeyHash :: C.KeyHash testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=" -ntfTestStoreLogFile :: FilePath -ntfTestStoreLogFile = "tests/tmp/ntf-server-store.log" +ntfTestStoreLogFile :: HasTestEnv => FilePath +ntfTestStoreLogFile = testPath "ntf-server-store.log" -ntfTestStoreLogFile2 :: FilePath -ntfTestStoreLogFile2 = "tests/tmp/ntf-server-store.log.2" +ntfTestStoreLogFile2 :: HasTestEnv => FilePath +ntfTestStoreLogFile2 = testPath "ntf-server-store.log.2" -ntfTestStoreLastNtfsFile :: FilePath -ntfTestStoreLastNtfsFile = "tests/tmp/ntf-server-last-notifications.log" +ntfTestStoreLastNtfsFile :: HasTestEnv => FilePath +ntfTestStoreLastNtfsFile = testPath "ntf-server-last-notifications.log" -ntfTestPrometheusMetricsFile :: FilePath -ntfTestPrometheusMetricsFile = "tests/tmp/ntf-server-metrics.txt" +ntfTestPrometheusMetricsFile :: HasTestEnv => FilePath +ntfTestPrometheusMetricsFile = testPath "ntf-server-metrics.txt" -ntfTestStoreDBOpts :: DBOpts -ntfTestStoreDBOpts = +ntfTestServerDBOpts :: DBOpts +ntfTestServerDBOpts = DBOpts { connstr = ntfTestServerDBConnstr, schema = "ntf_server", @@ -91,8 +92,11 @@ ntfTestStoreDBOpts = createSchema = True } -ntfTestStoreDBOpts2 :: DBOpts -ntfTestStoreDBOpts2 = ntfTestStoreDBOpts {schema = "smp_server2"} +ntfTestStoreDBOpts :: HasTestEnv => DBOpts +ntfTestStoreDBOpts = ntfTestServerDBOpts {schema = testSchemaName "ntf_server"} + +ntfTestStoreDBOpts2 :: HasTestEnv => DBOpts +ntfTestStoreDBOpts2 = ntfTestStoreDBOpts {schema = testSchemaName "smp_server2"} ntfTestServerDBConnstr :: ByteString ntfTestServerDBConnstr = "postgresql://ntf_test_server_user@/ntf_test_server_db" @@ -104,7 +108,7 @@ ntfTestServerDBConnectInfo = connectDatabase = "ntf_test_server_db" } -ntfTestDBCfg :: PostgresStoreCfg +ntfTestDBCfg :: HasTestEnv => PostgresStoreCfg ntfTestDBCfg = PostgresStoreCfg { dbOpts = ntfTestStoreDBOpts, @@ -113,10 +117,10 @@ ntfTestDBCfg = deletedTTL = 86400 } -ntfTestDBCfg2 :: PostgresStoreCfg +ntfTestDBCfg2 :: HasTestEnv => PostgresStoreCfg ntfTestDBCfg2 = ntfTestDBCfg {dbOpts = ntfTestStoreDBOpts2, dbStoreLogPath = Just ntfTestStoreLogFile2} -testNtfClient :: Transport c => (THandleNTF c 'TClient -> IO a) -> IO a +testNtfClient :: (HasTestEnv, Transport c) => (THandleNTF c 'TClient -> IO a) -> IO a testNtfClient client = do Right host <- pure $ chooseTransportHost defaultNetworkConfig testHost runTransportClient defaultTransportClientConfig Nothing host ntfTestPort (Just testKeyHash) $ \h -> @@ -124,7 +128,7 @@ testNtfClient client = do Right th -> client th Left e -> error $ show e -ntfServerCfg :: NtfServerConfig +ntfServerCfg :: HasTestEnv => NtfServerConfig ntfServerCfg = NtfServerConfig { transports = [], @@ -151,7 +155,7 @@ ntfServerCfg = -- stats config logStatsInterval = Nothing, logStatsStartTime = 0, - serverStatsLogFile = "tests/ntf-server-stats.daily.log", + serverStatsLogFile = testPath "ntf-server-stats.daily.log", serverStatsBackupFile = Nothing, prometheusInterval = Nothing, prometheusMetricsFile = ntfTestPrometheusMetricsFile, @@ -171,7 +175,7 @@ ntfServerCfg = -- smpCfg' = smpCfg smpAgentCfg' -- serverVRange' = serverVRange smpCfg' -withNtfServerThreadOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a +withNtfServerThreadOn :: (HasCallStack, HasTestEnv) => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => ThreadId -> IO a) -> IO a withNtfServerThreadOn t port' dbStoreConfig = withNtfServerCfg ntfServerCfg {transports = [(port', t, False)], dbStoreConfig} @@ -184,18 +188,18 @@ withNtfServerCfg cfg@NtfServerConfig {transports} = (\started -> runNtfServerBlocking started cfg) (pure ()) -withNtfServerOn :: HasCallStack => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a +withNtfServerOn :: (HasCallStack, HasTestEnv) => ASrvTransport -> ServiceName -> PostgresStoreCfg -> (HasCallStack => IO a) -> IO a withNtfServerOn t port' dbStoreConfig = withNtfServerThreadOn t port' dbStoreConfig . const -withNtfServer :: HasCallStack => ASrvTransport -> (HasCallStack => IO a) -> IO a +withNtfServer :: (HasCallStack, HasTestEnv) => ASrvTransport -> (HasCallStack => IO a) -> IO a withNtfServer t = withNtfServerOn t ntfTestPort ntfTestDBCfg -runNtfTest :: forall c a. Transport c => (THandleNTF c 'TClient -> IO a) -> IO a +runNtfTest :: forall c a. (HasTestEnv, Transport c) => (THandleNTF c 'TClient -> IO a) -> IO a runNtfTest test = withNtfServer (transport @c) $ testNtfClient test ntfServerTest :: forall c smp. - (Transport c, Encoding smp) => + (HasTestEnv, Transport c, Encoding smp) => TProxy c 'TServer -> (Maybe TAuthorizations, ByteString, ByteString, smp) -> IO (Maybe TAuthorizations, ByteString, ByteString, NtfResponse) @@ -210,7 +214,7 @@ ntfServerTest _ t = runNtfTest $ \h -> tPut' h t >> tGet' h [(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h pure (Nothing, corrId, qId, cmd) -ntfTest :: Transport c => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation +ntfTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleNTF c 'TClient -> IO ()) -> Expectation ntfTest _ test' = runNtfTest test' `shouldReturn` () data APNSMockRequest = APNSMockRequest @@ -225,7 +229,7 @@ data APNSMockServer = APNSMockServer http2Server :: HTTP2Server } -apnsMockServerConfig :: HTTP2ServerConfig +apnsMockServerConfig :: HasTestEnv => HTTP2ServerConfig apnsMockServerConfig = HTTP2ServerConfig { qSize = 2, @@ -242,7 +246,7 @@ apnsMockServerConfig = transportConfig = mkTransportServerConfig True Nothing False } -withAPNSMockServer :: (APNSMockServer -> IO a) -> IO a +withAPNSMockServer :: HasTestEnv => (APNSMockServer -> IO a) -> IO a withAPNSMockServer = E.bracket (getAPNSMockServer apnsMockServerConfig) closeAPNSMockServer deriving instance Generic APNSAlertBody diff --git a/tests/NtfServerTests.hs b/tests/NtfServerTests.hs index 7fd430fef..d69181f48 100644 --- a/tests/NtfServerTests.hs +++ b/tests/NtfServerTests.hs @@ -69,13 +69,13 @@ ntfSyntaxTests (ATransport t) = do it "token ID" $ (sampleSig, "abcd", "12345678", (TNEW_, ' ', ('T', 'A', 'T', "abcd" :: ByteString), samplePubKey, sampleDhPubKey)) >#> ("", "abcd", "12345678", NRErr $ CMD HAS_AUTH) where (>#>) :: - Encoding smp => + (HasTestEnv, Encoding smp) => (Maybe TAuthorizations, ByteString, ByteString, smp) -> (Maybe TAuthorizations, ByteString, ByteString, NtfResponse) -> Expectation command >#> response = withAPNSMockServer $ \_ -> ntfServerTest t command `shouldReturn` response -testApnsTestProviderRejected :: ASrvTransport -> Expectation +testApnsTestProviderRejected :: HasTestEnv => ASrvTransport -> Expectation testApnsTestProviderRejected (ATransport (t :: TProxy c 'TServer)) = do g <- C.newRandom (tknPub, tknKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g diff --git a/tests/RSLVTests.hs b/tests/RSLVTests.hs index 9263b6953..4fc631b63 100644 --- a/tests/RSLVTests.hs +++ b/tests/RSLVTests.hs @@ -51,22 +51,22 @@ import Simplex.Messaging.SimplexName (SimplexDomain) import Simplex.Messaging.Transport import Simplex.Messaging.Version (mkVersionRange) import Test.Hspec hiding (fit, it) -import Util (it) +import Util (HasTestEnv, it) domain :: Text -> SimplexDomain domain = either error id . strDecode . encodeUtf8 -withResolverServer :: (Status, LB.ByteString) -> IO a -> IO a +withResolverServer :: HasTestEnv => (Status, LB.ByteString) -> IO a -> IO a withResolverServer (st, body) runTest = NRS.withResolverServer (NRS.resolveResp st body) $ \port _ -> withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const runTest) -withResolverServerReqs :: (Status, LB.ByteString) -> (IORef [[Text]] -> IO a) -> IO a +withResolverServerReqs :: HasTestEnv => (Status, LB.ByteString) -> (IORef [[Text]] -> IO a) -> IO a withResolverServerReqs (st, body) runTest = NRS.withResolverServer (NRS.resolveResp st body) $ \port reqs -> withSmpServerConfigOn (transport @TLS) (withNames port memCfg) testPort (const (runTest reqs)) -withProxyAndResolver :: (Status, LB.ByteString) -> IO a -> IO a +withProxyAndResolver :: HasTestEnv => (Status, LB.ByteString) -> IO a -> IO a withProxyAndResolver (st, body) runTest = NRS.withResolverServer (NRS.resolveResp st body) $ \port _ -> withSmpServerConfigOn (transport @TLS) memProxyCfg testPort $ \_ -> @@ -105,7 +105,7 @@ rslvTests = do -- | /v2/resolve answers 200, 400 or 502, so a 404 is a resolver that predates -- the route, not a name that does not exist. -testRslvBackendNotFound :: IO () +testRslvBackendNotFound :: HasTestEnv => IO () testRslvBackendNotFound = withResolverServer (status404, "{}") $ testSMPClient @TLS $ \h -> do @@ -113,21 +113,21 @@ testRslvBackendNotFound = corrId `shouldBe` CorrId "rs01" resp `shouldBe` Right (ERR (NAME (RESOLVER "HTTP 404"))) -testRslvBackendHttpErr :: IO () +testRslvBackendHttpErr :: HasTestEnv => IO () testRslvBackendHttpErr = withResolverServer (status502, "{}") $ testSMPClient @TLS $ \h -> do (_, _, resp) <- sendRslv h "rs05" (domain "alice.simplex") resp `shouldBe` Right (ERR (NAME (RESOLVER "HTTP 502"))) -testRslvDisabled :: IO () +testRslvDisabled :: HasTestEnv => IO () testRslvDisabled = withSmpServerConfigOn (transport @TLS) memCfg testPort $ const $ testSMPClient @TLS $ \h -> do (_, _, resp) <- sendRslv h "rs06" (domain "alice.simplex") resp `shouldBe` Right (ERR (NAME NO_RESOLVER)) -testRslvVersion :: IO () +testRslvVersion :: HasTestEnv => IO () testRslvVersion = withResolverServer (status200, registeredBody testNameRecord) $ do g <- C.newRandom @@ -141,7 +141,7 @@ testRslvVersion = Left (PCETransportError TEVersion) -> pure () _ -> expectationFailure $ "expected Left (PCETransportError TEVersion), got: " <> show r -forwardedResolveAlice :: IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse)) +forwardedResolveAlice :: HasTestEnv => IO (Either SMPClientError (Either ProxyClientError SMP.NameResponse)) forwardedResolveAlice = do g <- C.newRandom ts <- getCurrentTime @@ -153,21 +153,21 @@ forwardedResolveAlice = do sess <- runExceptT' (connectSMPProxiedRelay pc NRMInteractive relayServ Nothing) runExceptT (proxyResolveName pc NRMInteractive sess (domain "alice.simplex")) -testRslvForwarded :: IO () +testRslvForwarded :: HasTestEnv => IO () testRslvForwarded = withProxyAndResolver (status404, "{}") $ forwardedResolveAlice >>= \r -> case r of Left (PCEProtocolError (SMP.NAME (SMP.RESOLVER _))) -> pure () _ -> expectationFailure $ "expected Left (PCEProtocolError (NAME (RESOLVER _))), got: " <> show r -testRslvForwardedSuccess :: IO () +testRslvForwardedSuccess :: HasTestEnv => IO () testRslvForwardedSuccess = withProxyAndResolver (status200, registeredBody testNameRecord) $ forwardedResolveAlice >>= \r -> case r of Right (Right NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord _ -> expectationFailure $ "expected Right (Right NRRegistered), got: " <> show r -testRslvSuccess :: IO () +testRslvSuccess :: HasTestEnv => IO () testRslvSuccess = withResolverServer (status200, registeredBody testNameRecord) $ testSMPClient @TLS $ \h -> do @@ -177,7 +177,7 @@ testRslvSuccess = Right (RNAME NameResponse {registration = NRRegistered {nameRecord}}) -> nameRecord `shouldBe` testNameRecord _ -> expectationFailure $ "expected Right (RNAME NRRegistered), got: " <> show resp -testRslvAvailable :: IO () +testRslvAvailable :: HasTestEnv => IO () testRslvAvailable = withResolverServer (status200, availableBody) $ testSMPClient @TLS $ \h -> do @@ -185,7 +185,7 @@ testRslvAvailable = corrId `shouldBe` CorrId "na01" resp `shouldBe` Right (RNAME (resolved (NRAvailable testPricing))) -testRslvReserved :: IO () +testRslvReserved :: HasTestEnv => IO () testRslvReserved = withResolverServer (status200, reservedBody) $ testSMPClient @TLS $ \h -> do @@ -194,7 +194,7 @@ testRslvReserved = -- | A client that predates v22 must see exactly what it saw before: the record -- for a name that resolves, and NOT_FOUND for one that does not. -oldClient :: IO SMPClient +oldClient :: HasTestEnv => IO SMPClient oldClient = do g <- C.newRandom ts <- getCurrentTime @@ -205,14 +205,14 @@ oldClient = do pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) oldCfg [] Nothing ts (\_ -> pure ()) either (fail . show) pure pcE -testRslvOldClientRecord :: IO () +testRslvOldClientRecord :: HasTestEnv => IO () testRslvOldClientRecord = withResolverServer (status200, registeredBody testNameRecord) $ do pc <- oldClient r <- runExceptT' (directResolveName pc NRMInteractive (domain "alice.simplex")) r `shouldBe` NameResponse Nothing (NRRegistered Nothing Nothing Nothing testNameRecord) -testRslvOldClientNotFound :: IO () +testRslvOldClientNotFound :: HasTestEnv => IO () testRslvOldClientNotFound = withResolverServer (status200, availableBody) $ do pc <- oldClient @@ -221,7 +221,7 @@ testRslvOldClientNotFound = Left (PCEProtocolError (SMP.NAME SMP.NOT_FOUND)) -> pure () _ -> expectationFailure $ "expected Left (PCEProtocolError (NAME NOT_FOUND)), got: " <> show r -testRslvForwardedAvailable :: IO () +testRslvForwardedAvailable :: HasTestEnv => IO () testRslvForwardedAvailable = withProxyAndResolver (status200, availableBody) $ forwardedResolveAlice >>= \r -> case r of @@ -238,7 +238,7 @@ resolvePaths reqs = filter isResolve <$> readIORef reqs where isResolve = \case ("v2" : "resolve" : _) -> True; _ -> False -currentClient :: IO SMPClient +currentClient :: HasTestEnv => IO SMPClient currentClient = do g <- C.newRandom ts <- getCurrentTime @@ -246,7 +246,7 @@ currentClient = do pcE <- getProtocolClient g NRMInteractive (1, srv, Nothing) defaultSMPClientConfig [] Nothing ts (\_ -> pure ()) either (fail . show) pure pcE -testRslvSendsTheHash :: IO () +testRslvSendsTheHash :: HasTestEnv => IO () testRslvSendsTheHash = withResolverServerReqs (status200, registeredBody testNameRecord) $ \reqs -> do pc <- currentClient @@ -257,7 +257,7 @@ testRslvSendsTheHash = NameResponse {registration = NRRegistered {nameRecord}} -> SMP.nrName nameRecord `shouldBe` "alice.simplex" _ -> expectationFailure $ "expected NRRegistered, got: " <> show r -testSubnameKeepsItsLabels :: IO () +testSubnameKeepsItsLabels :: HasTestEnv => IO () testSubnameKeepsItsLabels = withResolverServerReqs (status200, availableBody) $ \reqs -> do pc <- currentClient @@ -266,7 +266,7 @@ testSubnameKeepsItsLabels = -- a hashed query does not tell the router the name, so the record's own name is -- checked against the one that was asked for -testRslvWrongName :: IO () +testRslvWrongName :: HasTestEnv => IO () testRslvWrongName = withResolverServer (status200, registeredBody testNameRecord {SMP.nrName = "mallory.simplex"}) $ do pc <- currentClient diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 159460828..ce289ea8b 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -6,6 +6,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -15,50 +16,51 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import SMPClient (ntfTestPort, testPort) +import SMPClient (ntfTestPort, ntfTestPort2, testHost, testHost2, testKeyHash, testPort, testPort2) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Client (NetworkTimeout (..), ProtocolClientConfig (..), SMPProxyFallback (..), SMPProxyMode (..), defaultNetworkConfig, defaultSMPClientConfig) import Simplex.Messaging.Notifications.Client (defaultNTFClientConfig) -import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer) +import Simplex.Messaging.Protocol (NtfServer, ProtoServerWithAuth (..), ProtocolServer, pattern NtfServer) import Simplex.Messaging.Transport +import Util import XFTPClient (testXFTPServer) -- name fixtures are reused, but they are used as schema name instead of database file path #if defined(dbPostgres) -testDB :: String -testDB = "smp_agent_test_protocol_schema" +testDB :: HasTestEnv => String +testDB = testSchemaName "smp_agent_test_protocol_schema" -testDB2 :: String -testDB2 = "smp_agent2_test_protocol_schema" +testDB2 :: HasTestEnv => String +testDB2 = testSchemaName "smp_agent2_test_protocol_schema" -testDB3 :: String -testDB3 = "smp_agent3_test_protocol_schema" +testDB3 :: HasTestEnv => String +testDB3 = testSchemaName "smp_agent3_test_protocol_schema" #else -testDB :: FilePath -testDB = "tests/tmp/smp-agent.test.protocol.db" +testDB :: HasTestEnv => FilePath +testDB = testPath "smp-agent.test.protocol.db" -testDB2 :: FilePath -testDB2 = "tests/tmp/smp-agent2.test.protocol.db" +testDB2 :: HasTestEnv => FilePath +testDB2 = testPath "smp-agent2.test.protocol.db" -testDB3 :: FilePath -testDB3 = "tests/tmp/smp-agent3.test.protocol.db" +testDB3 :: HasTestEnv => FilePath +testDB3 = testPath "smp-agent3.test.protocol.db" #endif -testSMPServer :: SMPServer -testSMPServer = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001" +testSMPServer :: HasTestEnv => SMPServer +testSMPServer = SMPServer testHost testPort testKeyHash -testSMPServer2 :: SMPServer -testSMPServer2 = "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@127.0.0.1:5002" +testSMPServer2 :: HasTestEnv => SMPServer +testSMPServer2 = SMPServer testHost2 testPort2 testKeyHash -testNtfServer :: NtfServer -testNtfServer = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001" +testNtfServer :: HasTestEnv => NtfServer +testNtfServer = NtfServer testHost ntfTestPort testKeyHash -testNtfServer2 :: NtfServer -testNtfServer2 = "ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6002" +testNtfServer2 :: HasTestEnv => NtfServer +testNtfServer2 = NtfServer testHost ntfTestPort2 testKeyHash -initAgentServers :: InitialAgentServers +initAgentServers :: HasTestEnv => InitialAgentServers initAgentServers = InitialAgentServers { smp = userServers [testSMPServer], @@ -71,23 +73,23 @@ initAgentServers = presetServers = [] } -initAgentServers2 :: InitialAgentServers +initAgentServers2 :: HasTestEnv => InitialAgentServers initAgentServers2 = initAgentServers {smp = userServers [testSMPServer, testSMPServer2]} -initAgentServersProxy :: InitialAgentServers +initAgentServersProxy :: HasTestEnv => InitialAgentServers initAgentServersProxy = initAgentServersProxy_ SPMAlways SPFProhibit -initAgentServersProxy_ :: SMPProxyMode -> SMPProxyFallback -> InitialAgentServers +initAgentServersProxy_ :: HasTestEnv => SMPProxyMode -> SMPProxyFallback -> InitialAgentServers initAgentServersProxy_ smpProxyMode smpProxyFallback = initAgentServers {netCfg = (netCfg initAgentServers) {smpProxyMode, smpProxyFallback}} -initAgentServersProxy2 :: InitialAgentServers +initAgentServersProxy2 :: HasTestEnv => InitialAgentServers initAgentServersProxy2 = initAgentServersProxy {smp = userServers [testSMPServer2]} -initAgentServersClientService :: InitialAgentServers +initAgentServersClientService :: HasTestEnv => InitialAgentServers initAgentServersClientService = initAgentServers {useServices = M.fromList [(1, True)]} -agentCfg :: AgentConfig +agentCfg :: HasTestEnv => AgentConfig agentCfg = defaultAgentConfig { tcpPort = Nothing, diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index f1d5af1db..a9d06fbab 100644 --- a/tests/SMPClient.hs +++ b/tests/SMPClient.hs @@ -72,29 +72,29 @@ testHost = "localhost" testHost2 :: NonEmpty TransportHost testHost2 = "127.0.0.1" -testPort :: ServiceName -testPort = "5001" +testPort :: HasTestEnv => ServiceName +testPort = testServerPort 1 -testPort2 :: ServiceName -testPort2 = "5002" +testPort2 :: HasTestEnv => ServiceName +testPort2 = testServerPort 2 -ntfTestPort :: ServiceName -ntfTestPort = "6001" +ntfTestPort :: HasTestEnv => ServiceName +ntfTestPort = testServerPort 3 -ntfTestPort2 :: ServiceName -ntfTestPort2 = "6002" +ntfTestPort2 :: HasTestEnv => ServiceName +ntfTestPort2 = testServerPort 4 testKeyHash :: C.KeyHash testKeyHash = "LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=" -testStoreLogFile :: FilePath -testStoreLogFile = "tests/tmp/smp-server-store.log" +testStoreLogFile :: HasTestEnv => FilePath +testStoreLogFile = testPath "smp-server-store.log" -testStoreLogFile2 :: FilePath -testStoreLogFile2 = "tests/tmp/smp-server-store.log.2" +testStoreLogFile2 :: HasTestEnv => FilePath +testStoreLogFile2 = testPath "smp-server-store.log.2" -testStoreDBOpts :: DBOpts -testStoreDBOpts = +testServerDBOpts :: DBOpts +testServerDBOpts = DBOpts { connstr = testServerDBConnstr, schema = "smp_server", @@ -102,8 +102,11 @@ testStoreDBOpts = createSchema = True } -testStoreDBOpts2 :: DBOpts -testStoreDBOpts2 = testStoreDBOpts {schema = "smp_server2"} +testStoreDBOpts :: HasTestEnv => DBOpts +testStoreDBOpts = testServerDBOpts {schema = testSchemaName "smp_server"} + +testStoreDBOpts2 :: HasTestEnv => DBOpts +testStoreDBOpts2 = testStoreDBOpts {schema = testSchemaName "smp_server2"} testServerDBConnstr :: ByteString testServerDBConnstr = "postgresql://test_server_user@/test_server_db" @@ -117,48 +120,48 @@ testServerDBConnectInfo = } #endif -testStoreMsgsFile :: FilePath -testStoreMsgsFile = "tests/tmp/smp-server-messages.log" +testStoreMsgsFile :: HasTestEnv => FilePath +testStoreMsgsFile = testPath "smp-server-messages.log" -testStoreMsgsFile2 :: FilePath -testStoreMsgsFile2 = "tests/tmp/smp-server-messages.log.2" +testStoreMsgsFile2 :: HasTestEnv => FilePath +testStoreMsgsFile2 = testPath "smp-server-messages.log.2" -testStoreMsgsDir :: FilePath -testStoreMsgsDir = "tests/tmp/messages" +testStoreMsgsDir :: HasTestEnv => FilePath +testStoreMsgsDir = testPath "messages" -testStoreMsgsDir2 :: FilePath -testStoreMsgsDir2 = "tests/tmp/messages.2" +testStoreMsgsDir2 :: HasTestEnv => FilePath +testStoreMsgsDir2 = testPath "messages.2" -testStoreNtfsFile :: FilePath -testStoreNtfsFile = "tests/tmp/smp-server-ntfs.log" +testStoreNtfsFile :: HasTestEnv => FilePath +testStoreNtfsFile = testPath "smp-server-ntfs.log" -testStoreNtfsFile2 :: FilePath -testStoreNtfsFile2 = "tests/tmp/smp-server-ntfs.log.2" +testStoreNtfsFile2 :: HasTestEnv => FilePath +testStoreNtfsFile2 = testPath "smp-server-ntfs.log.2" -testPrometheusMetricsFile :: FilePath -testPrometheusMetricsFile = "tests/tmp/smp-server-metrics.txt" +testPrometheusMetricsFile :: HasTestEnv => FilePath +testPrometheusMetricsFile = testPath "smp-server-metrics.txt" -testServerStatsBackupFile :: FilePath -testServerStatsBackupFile = "tests/tmp/smp-server-stats.log" +testServerStatsBackupFile :: HasTestEnv => FilePath +testServerStatsBackupFile = testPath "smp-server-stats.log" -xit' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) -xit' d = if os == "linux" then skip "skipped on Linux" . it d else it d +xit' :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a) +xit' d t = if os == "linux" then skip "skipped on Linux" $ it d t else it d t -xit'' :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) -xit'' d = skipOnCI . it d +xit'' :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a) +xit'' d t = skipOnCI $ it d t skipOnCI :: SpecWith a -> SpecWith a skipOnCI t = ifM (runIO envCI) (skip "skipped on CI" t) t -testSMPClient :: Transport c => (THandleSMP c 'TClient -> IO a) -> IO a +testSMPClient :: (HasTestEnv, Transport c) => (THandleSMP c 'TClient -> IO a) -> IO a testSMPClient = testSMPClientVR supportedClientSMPRelayVRange -testSMPClientVR :: Transport c => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a +testSMPClientVR :: (HasTestEnv, Transport c) => VersionRangeSMP -> (THandleSMP c 'TClient -> IO a) -> IO a testSMPClientVR vr client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost testSMPClient_ useHost testPort vr Nothing client -testSMPServiceClient :: Transport c => (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a +testSMPServiceClient :: (HasTestEnv, Transport c) => (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a testSMPServiceClient serviceCreds client = do Right useHost <- pure $ chooseTransportHost defaultNetworkConfig testHost testSMPClient_ useHost testPort supportedClientSMPRelayVRange (Just serviceCreds) client @@ -181,13 +184,13 @@ testSMPClient_ host port vr serviceCreds_ client = do where clientALPN = Just alpnSupportedSMPHandshakes -runSMPClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a +runSMPClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> IO a runSMPClient _ test' = testSMPClient test' -runSMPServiceClient :: Transport c => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a +runSMPServiceClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (TLS.Credential, C.KeyPairEd25519) -> (THandleSMP c 'TClient -> IO a) -> IO a runSMPServiceClient _ serviceCreds test' = testSMPServiceClient serviceCreds test' -testNtfServiceClient :: Transport c => TProxy c 'TServer -> C.KeyPairEd25519 -> (THandleSMP c 'TClient -> IO a) -> IO a +testNtfServiceClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> C.KeyPairEd25519 -> (THandleSMP c 'TClient -> IO a) -> IO a testNtfServiceClient _ keys client = do tlsNtfServerCreds <- loadServerCredential ntfTestServerCredentials serviceCertHash <- loadFingerprint ntfTestServerCredentials @@ -211,13 +214,13 @@ ntfTestServerCredentials = certificateFile = "tests/fixtures/server.crt" } -cfg :: AServerConfig +cfg :: HasTestEnv => AServerConfig cfg = cfgMS (ASType SQSMemory SMSJournal) -cfgJ2 :: AServerConfig +cfgJ2 :: HasTestEnv => AServerConfig cfgJ2 = journalCfg cfg testStoreLogFile2 testStoreMsgsDir2 -cfgJ2QS :: SQSType s -> AServerConfig +cfgJ2QS :: HasTestEnv => SQSType s -> AServerConfig cfgJ2QS = \case SQSMemory -> journalCfg (cfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2 SQSPostgres -> journalCfgDB (cfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2 @@ -231,7 +234,7 @@ journalCfgDB (ASrvCfg _ _ cfg') dbOpts storeMsgsPath' = let storeCfg = PostgresStoreCfg {dbOpts, dbStoreLogPath = Nothing, confirmMigrations = MCYesUp, deletedTTL = 86400} in ASrvCfg SQSPostgres SMSJournal cfg' {serverStoreCfg = SSCDatabaseJournal {storeCfg, storeMsgsPath'}} -cfgMS :: AStoreType -> AServerConfig +cfgMS :: HasTestEnv => AStoreType -> AServerConfig cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> ServerConfig { transports = [], @@ -257,7 +260,7 @@ cfgMS msType = withStoreCfg (testServerStoreConfig msType) $ \serverStoreCfg -> inactiveClientExpiration = Just defaultInactiveClientExpiration, logStatsInterval = Nothing, logStatsStartTime = 0, - serverStatsLogFile = "tests/tmp/smp-server-stats.daily.log", + serverStatsLogFile = testPath "smp-server-stats.daily.log", serverStatsBackupFile = Nothing, prometheusInterval = Nothing, prometheusMetricsFile = testPrometheusMetricsFile, @@ -288,10 +291,10 @@ withStoreCfg (ASSCfg qt mt storeCfg) f = ASrvCfg qt mt (f storeCfg) defaultStartOptions :: StartOptions defaultStartOptions = StartOptions {maintenance = False, compactLog = False, logLevel = testLogLevel, skipWarnings = False, confirmMigrations = MCYesUp} -testServerStoreConfig :: AStoreType -> AServerStoreCfg +testServerStoreConfig :: HasTestEnv => AStoreType -> AServerStoreCfg testServerStoreConfig = serverStoreConfig_ False -serverStoreConfig_ :: Bool -> AStoreType -> AServerStoreCfg +serverStoreConfig_ :: HasTestEnv => Bool -> AStoreType -> AServerStoreCfg serverStoreConfig_ useDbStoreLog = \case ASType SQSMemory SMSMemory -> ASSCfg SQSMemory SMSMemory $ SSCMemory $ Just StorePaths {storeLogFile = testStoreLogFile, storeMsgsFile = Just testStoreMsgsFile} @@ -307,7 +310,7 @@ serverStoreConfig_ useDbStoreLog = \case dbStoreLogPath = if useDbStoreLog then Just testStoreLogFile else Nothing storeCfg = PostgresStoreCfg {dbOpts = testStoreDBOpts, dbStoreLogPath, confirmMigrations = MCYesUp, deletedTTL = 86400} -cfgVPrev :: AStoreType -> AServerConfig +cfgVPrev :: HasTestEnv => AStoreType -> AServerConfig cfgVPrev msType = updateCfg (cfgMS msType) $ \cfg' -> cfg' {smpServerVRange = prevRange $ smpServerVRange cfg'} prevRange :: VersionRange v -> VersionRange v @@ -319,10 +322,10 @@ prevVersion (Version v) = Version (v - 1) nextVersion :: Version v -> Version v nextVersion (Version v) = Version (v + 1) -proxyCfg :: AServerConfig +proxyCfg :: HasTestEnv => AServerConfig proxyCfg = proxyCfgMS (ASType SQSMemory SMSJournal) -proxyCfgMS :: AStoreType -> AServerConfig +proxyCfgMS :: HasTestEnv => AStoreType -> AServerConfig proxyCfgMS msType = updateCfg (cfgMS msType) $ \cfg' -> let smpAgentCfg' = smpAgentCfg cfg' @@ -331,17 +334,17 @@ proxyCfgMS msType = smpAgentCfg = smpAgentCfg' {smpCfg = (smpCfg smpAgentCfg') {agreeSecret = True, proxyServer = True, serverVRange = supportedProxyClientSMPRelayVRange}} } -proxyCfgJ2 :: AServerConfig +proxyCfgJ2 :: HasTestEnv => AServerConfig proxyCfgJ2 = journalCfg proxyCfg testStoreLogFile2 testStoreMsgsDir2 -proxyCfgJ2QS :: SQSType qs -> AServerConfig +proxyCfgJ2QS :: HasTestEnv => SQSType qs -> AServerConfig proxyCfgJ2QS = \case SQSMemory -> journalCfg (proxyCfgMS $ ASType SQSMemory SMSJournal) testStoreLogFile2 testStoreMsgsDir2 SQSPostgres -> journalCfgDB (proxyCfgMS $ ASType SQSPostgres SMSJournal) testStoreDBOpts2 testStoreMsgsDir2 -- Proxy config with a short relay-connection timeout, to bound how long a failing -- proxy->relay connection attempt blocks in the relay reconnection tests. -proxyCfgShortTimeout :: AServerConfig +proxyCfgShortTimeout :: HasTestEnv => AServerConfig proxyCfgShortTimeout = updateCfg proxyCfg $ \cfg' -> let aCfg = smpAgentCfg cfg' @@ -349,7 +352,7 @@ proxyCfgShortTimeout = nt = NetworkTimeout {backgroundTimeout = 4_000000, interactiveTimeout = 4_000000} in cfg' {smpAgentCfg = aCfg {smpCfg = cCfg {networkConfig = (networkConfig cCfg) {tcpConnectTimeout = nt}}}} -proxyCfgVPrev :: AStoreType -> AServerConfig +proxyCfgVPrev :: HasTestEnv => AStoreType -> AServerConfig proxyCfgVPrev msType = updateCfg (proxyCfgMS msType) $ \cfg' -> let aCfg = smpAgentCfg cfg' @@ -359,11 +362,11 @@ proxyCfgVPrev msType = smpAgentCfg = aCfg {smpCfg = cCfg {serverVRange = prevRange $ serverVRange cCfg}} } -withSmpServerStoreMsgLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerStoreMsgLogOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreMsgLogOn (t, msType) = withSmpServerConfigOn t $ updateCfg (cfgMS msType) $ \cfg' -> cfg' {storeNtfsFile = Just testStoreNtfsFile, serverStatsBackupFile = Just testServerStatsBackupFile} -withSmpServerStoreLogOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerStoreLogOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerStoreLogOn (t, msType) = withSmpServerConfigOn t $ updateCfg (cfgMS msType) $ \cfg' -> cfg' {serverStatsBackupFile = Just testServerStatsBackupFile} @@ -379,7 +382,7 @@ withSmpServerConfigOn t (ASrvCfg _ _ cfg') port' = (\started -> runSMPServerBlocking started cfg' {transports = [(port', t, False)]} Nothing) (threadDelay 10000) -withSmpServerThreadOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a +withSmpServerThreadOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> (HasCallStack => ThreadId -> IO a) -> IO a withSmpServerThreadOn (t, msType) = withSmpServerConfigOn t (cfgMS msType) serverBracket :: HasCallStack => (TMVar Bool -> IO ()) -> IO () -> (HasCallStack => ThreadId -> IO a) -> IO a @@ -409,28 +412,28 @@ withStallingServerOn port action = (pure ()) (const action) -withSmpServerOn :: HasCallStack => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a +withSmpServerOn :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> ServiceName -> IO a -> IO a withSmpServerOn ps port' = withSmpServerThreadOn ps port' . const -withSmpServer :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a +withSmpServer :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a withSmpServer ps = withSmpServerOn ps testPort -withSmpServerProxy :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a +withSmpServerProxy :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a withSmpServerProxy (t, msType) = withSmpServerConfigOn t (proxyCfgMS msType) testPort . const -withSmpServers2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a +withSmpServers2 :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a withSmpServers2 ps@(t, ASType qs _ms) = withSmpServer ps . withSmpServerConfigOn t (cfgJ2QS qs) testPort2 . const -withSmpServersProxy2 :: HasCallStack => (ASrvTransport, AStoreType) -> IO a -> IO a +withSmpServersProxy2 :: (HasCallStack, HasTestEnv) => (ASrvTransport, AStoreType) -> IO a -> IO a withSmpServersProxy2 ps@(t, ASType qs _ms) = withSmpServerProxy ps . withSmpServerConfigOn t (proxyCfgJ2QS qs) testPort2 . const -runSmpTest :: forall c a. (HasCallStack, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a +runSmpTest :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO a) -> IO a runSmpTest msType test = withSmpServerConfigOn (transport @c) (cfgMS msType) testPort $ \_ -> testSMPClient test -runSmpTestN :: forall c a. (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a +runSmpTestN :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a runSmpTestN msType = runSmpTestNCfg (cfgMS msType) supportedClientSMPRelayVRange -runSmpTestNCfg :: forall c a. (HasCallStack, Transport c) => AServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a +runSmpTestNCfg :: forall c a. (HasCallStack, HasTestEnv, Transport c) => AServerConfig -> VersionRangeSMP -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO a) -> IO a runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c) srvCfg testPort $ \_ -> run nClients [] where run :: Int -> [THandleSMP c 'TClient] -> IO a @@ -439,7 +442,7 @@ runSmpTestNCfg srvCfg clntVR nClients test = withSmpServerConfigOn (transport @c smpServerTest :: forall c smp. - (Transport c, Encoding smp) => + (HasTestEnv, Transport c, Encoding smp) => TProxy c 'TServer -> (Maybe TAuthorizations, ByteString, ByteString, smp) -> IO (Maybe TAuthorizations, ByteString, ByteString, BrokerMsg) @@ -454,30 +457,30 @@ smpServerTest _ t = runSmpTest (ASType SQSMemory SMSJournal) $ \h -> tPut' h t > [(CorrId corrId, EntityId qId, Right cmd)] <- tGetClient h pure (Nothing, corrId, qId, cmd) -smpTest :: (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest :: (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> IO ()) -> Expectation smpTest _ msType test' = runSmpTest msType test' `shouldReturn` () -smpTestN :: (HasCallStack, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation +smpTestN :: (HasCallStack, HasTestEnv, Transport c) => AStoreType -> Int -> (HasCallStack => [THandleSMP c 'TClient] -> IO ()) -> Expectation smpTestN msType n test' = runSmpTestN msType n test' `shouldReturn` () -smpTest2 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest2 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest2 t msType = smpTest2Cfg (cfgMS msType) supportedClientSMPRelayVRange t -smpTest2Cfg :: forall c. (HasCallStack, Transport c) => AServerConfig -> VersionRangeSMP -> TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest2Cfg :: forall c. (HasCallStack, HasTestEnv, Transport c) => AServerConfig -> VersionRangeSMP -> TProxy c 'TServer -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest2Cfg srvCfg clntVR _ test' = runSmpTestNCfg srvCfg clntVR 2 _test `shouldReturn` () where _test :: HasCallStack => [THandleSMP c 'TClient] -> IO () _test [h1, h2] = test' h1 h2 _test _ = error "expected 2 handles" -smpTest3 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest3 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest3 _ msType test' = smpTestN msType 3 _test where _test :: HasCallStack => [THandleSMP c 'TClient] -> IO () _test [h1, h2, h3] = test' h1 h2 h3 _test _ = error "expected 3 handles" -smpTest4 :: forall c. (HasCallStack, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation +smpTest4 :: forall c. (HasCallStack, HasTestEnv, Transport c) => TProxy c 'TServer -> AStoreType -> (HasCallStack => THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO ()) -> Expectation smpTest4 _ msType test' = smpTestN msType 4 _test where _test :: HasCallStack => [THandleSMP c 'TClient] -> IO () diff --git a/tests/SMPProxyTests.hs b/tests/SMPProxyTests.hs index 91bae09a6..94c9227e0 100644 --- a/tests/SMPProxyTests.hs +++ b/tests/SMPProxyTests.hs @@ -45,13 +45,9 @@ import Simplex.Messaging.Util (bshow, tshow) import Simplex.Messaging.Version (mkVersionRange) import System.FilePath (splitExtensions) import System.Random (randomRIO) -import Test.Hspec hiding (fit, it) +import Test.Hspec hiding (fit, it, xit) import UnliftIO import Util -#if defined(dbPostgres) -import Fixtures -import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) -#endif smpProxyTests :: SpecWith AStoreType smpProxyTests = do @@ -76,73 +72,71 @@ smpProxyTests = do it "relay rejects forwarded command with changed version" $ \_ -> testChangedFwdVersion describe "deliver message via SMP proxy" $ do - let srv1 = SMPServer testHost testPort testKeyHash + let srv1, srv2 :: HasTestEnv => SMPServer + srv1 = SMPServer testHost testPort testKeyHash srv2 = SMPServer testHost2 testPort2 testKeyHash describe "client API" $ do let maxLen = maxMessageLength describe "one server" $ do - it "deliver via proxy" . oneServer $ do + it "deliver via proxy" $ oneServer $ do deliverMessageViaProxy srv1 srv1 C.SEd448 "hello 1" "hello 2" describe "two servers" $ do - let proxyServ = srv1 + let proxyServ, relayServ :: HasTestEnv => SMPServer + proxyServ = srv1 relayServ = srv2 (msg1, msg2) <- runIO $ do g <- C.newRandom atomically $ (,) <$> C.randomBytes maxLen g <*> C.randomBytes maxLen g - it "deliver via proxy" . twoServersFirstProxy $ + it "deliver via proxy" $ twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SEd448 "hello 1" "hello 2" - it "max message size, Ed448 keys" . twoServersFirstProxy $ + it "max message size, Ed448 keys" $ twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SEd448 msg1 msg2 - it "max message size, Ed25519 keys" . twoServersFirstProxy $ + it "max message size, Ed25519 keys" $ twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SEd25519 msg1 msg2 - it "max message size, X25519 keys" . twoServersFirstProxy $ + it "max message size, X25519 keys" $ twoServersFirstProxy $ deliverMessageViaProxy proxyServ relayServ C.SX25519 msg1 msg2 describe "version compatibility" $ do let deliver clientVR = deliverMessagesViaProxyVR clientVR srv1 srv2 C.SEd448 ["hello 1"] ["hello 2"] - it "prev client" . twoServersFirstProxy $ deliver (prevRange supportedClientSMPRelayVRange) - it "prev proxy" . twoServersPrevProxy $ deliver supportedClientSMPRelayVRange - it "prev relay" . twoServersPrevRelay $ deliver supportedClientSMPRelayVRange + it "prev client" $ twoServersFirstProxy $ deliver (prevRange supportedClientSMPRelayVRange) + it "prev proxy" $ twoServersPrevProxy $ deliver supportedClientSMPRelayVRange + it "prev relay" $ twoServersPrevRelay $ deliver supportedClientSMPRelayVRange describe "stress test 1k" $ do let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n]) - it "1x1000" . twoServersFirstProxy $ deliver 1000 - it "5x200" . twoServersFirstProxy $ 5 `inParrallel` deliver 200 - it "10x100" . twoServersFirstProxy $ 10 `inParrallel` deliver 100 + it "1x1000" $ twoServersFirstProxy $ deliver 1000 + it "5x200" $ twoServersFirstProxy $ 5 `inParrallel` deliver 200 + it "10x100" $ twoServersFirstProxy $ 10 `inParrallel` deliver 100 describe "stress test - no host" $ do - it "1x1000, no delay" . oneServer $ proxyConnectDeadRelay 1000 0 srv1 - xit "1x1000, 100ms" . oneServer $ proxyConnectDeadRelay 1000 100000 srv1 - xit "100x1000, 100ms" . oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1) + it "1x1000, no delay" $ oneServer $ proxyConnectDeadRelay 1000 0 srv1 + xit "1x1000, 100ms" $ oneServer $ proxyConnectDeadRelay 1000 100000 srv1 + xit "100x1000, 100ms" $ oneServer $ 100 `inParrallel` (randomRIO (0, 1000000) >>= threadDelay >> proxyConnectDeadRelay 1000 100000 srv1) xdescribe "stress test 10k" $ do let deliver n = deliverMessagesViaProxy srv1 srv2 C.SEd448 [] (map bshow [1 :: Int .. n]) - it "1x10000" . twoServersFirstProxy $ deliver 10000 - it "5x2000" . twoServersFirstProxy $ 5 `inParrallel` deliver 2000 - it "10x1000" . twoServersFirstProxy $ 10 `inParrallel` deliver 1000 - it "100x100 N1" . twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100 - it "100x100 N4 C1" . twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 - it "100x100 N4 C2" . twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 - it "100x100 N4 C16" . twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 - it "100x100 N" . twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100 - it "500x20" . twoServersFirstProxy $ 500 `inParrallel` deliver 20 -#if defined(dbPostgres) - after_ (dropAllSchemasExceptSystem testDBConnectInfo) . describe "agent API" $ do -#else + it "1x10000" $ twoServersFirstProxy $ deliver 10000 + it "5x2000" $ twoServersFirstProxy $ 5 `inParrallel` deliver 2000 + it "10x1000" $ twoServersFirstProxy $ 10 `inParrallel` deliver 1000 + it "100x100 N1" $ twoServersFirstProxy $ withNumCapabilities 1 $ 100 `inParrallel` deliver 100 + it "100x100 N4 C1" $ twoServersNoConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 + it "100x100 N4 C2" $ twoServersFirstProxy $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 + it "100x100 N4 C16" $ twoServersMoreConc $ withNumCapabilities 4 $ 100 `inParrallel` deliver 100 + it "100x100 N" $ twoServersFirstProxy $ withNCPUCapabilities $ 100 `inParrallel` deliver 100 + it "500x20" $ twoServersFirstProxy $ 500 `inParrallel` deliver 20 describe "agent API" $ do -#endif describe "one server" $ do - it "always via proxy" . oneServer $ + it "always via proxy" $ oneServer $ agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv1], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1 - it "without proxy" . oneServer $ + it "without proxy" $ oneServer $ agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv1], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 describe "two servers" $ do it "always via proxy" $ \msType -> twoServers (agentDeliverMessageViaProxy ([srv1], SPMAlways, True) ([srv2], SPMAlways, True) C.SEd448 "hello 1" "hello 2" 1) msType - it "both via proxy" . twoServers $ + it "both via proxy" $ twoServers $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMUnknown, True) C.SEd448 "hello 1" "hello 2" 1 - it "first via proxy" . twoServers $ + it "first via proxy" $ twoServers $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 - it "without proxy" . twoServers $ + it "without proxy" $ twoServers $ agentDeliverMessageViaProxy ([srv1], SPMNever, False) ([srv2], SPMNever, False) C.SEd448 "hello 1" "hello 2" 1 - it "first via proxy for unknown" . twoServers $ + it "first via proxy for unknown" $ twoServers $ agentDeliverMessageViaProxy ([srv1], SPMUnknown, True) ([srv1, srv2], SPMUnknown, False) C.SEd448 "hello 1" "hello 2" 1 it "retries sending when destination or proxy relay is offline" $ \_ -> agentViaProxyRetryOffline @@ -150,14 +144,11 @@ smpProxyTests = do agentViaProxyRetryNoSession describe "stress test 1k" $ do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) - it "2 agents, 250 messages" . oneServer $ deliver 2 250 - it "5 agents, 10 pairs, 50 messages, N1" . oneServer . withNumCapabilities 1 $ deliver 5 50 - it "5 agents, 10 pairs, 50 messages. N4" . oneServer . withNumCapabilities 4 $ deliver 5 50 + it "2 agents, 250 messages" $ oneServer $ deliver 2 250 xdescribe "stress test 10k" $ do let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [srv1]) (map bshow [1 :: Int .. nMsgs]) - it "25 agents, 300 pairs, 17 messages" . oneServer . withNumCapabilities 4 $ deliver 25 17 + it "25 agents, 300 pairs, 17 messages" $ oneServer $ withNumCapabilities 4 $ deliver 25 17 where - oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) testPort $ const test twoServers test msType = twoServers_ (proxyCfgMS msType) (proxyCfgMS msType) test msType twoServersFirstProxy test msType = twoServers_ (proxyCfgMS msType) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType twoServersMoreConc test msType = twoServers_ (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {serverClientConcurrency = 128}) (updateCfg (cfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) test msType @@ -165,7 +156,7 @@ smpProxyTests = do twoServersPrevProxy test msType = twoServers_ (proxyCfgVPrev msType) (cfgMS msType) test msType twoServersPrevRelay test msType = twoServers_ (proxyCfgMS msType) (prevServerVRange $ cfgMS msType) test msType prevServerVRange cfg' = updateCfg cfg' $ \cfg_ -> cfg_ {smpServerVRange = prevRange $ smpServerVRange cfg_} - twoServers_ :: AServerConfig -> AServerConfig -> IO () -> AStoreType -> IO () + twoServers_ :: HasTestEnv => AServerConfig -> AServerConfig -> IO () -> AStoreType -> IO () twoServers_ cfg1 cfg2 runTest (ASType qsType _) = withSmpServerConfigOn (transport @TLS) cfg1 testPort $ \_ -> let cfg2' = case qsType of @@ -173,6 +164,15 @@ smpProxyTests = do SQSPostgres -> journalCfgDB cfg2 testStoreDBOpts2 testStoreMsgsDir2 in withSmpServerConfigOn (transport @TLS) cfg2' testPort2 $ const runTest +smpProxyCapabilityTests :: SpecWith AStoreType +smpProxyCapabilityTests = do + let deliver nAgents nMsgs = agentDeliverMessagesViaProxyConc (replicate nAgents [testSMPServer]) (map bshow [1 :: Int .. nMsgs]) + it "5 agents, 10 pairs, 50 messages, N1" $ oneServer $ withNumCapabilities 1 $ deliver 5 50 + it "5 agents, 10 pairs, 50 messages. N4" $ oneServer $ withNumCapabilities 4 $ deliver 5 50 + +oneServer :: HasTestEnv => IO a -> AStoreType -> IO a +oneServer test msType = withSmpServerConfigOn (transport @TLS) (updateCfg (proxyCfgMS msType) $ \cfg_ -> cfg_ {msgQueueQuota = 128, maxJournalMsgCount = 256}) testPort $ const test + deliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => SMPServer -> SMPServer -> C.SAlgorithm a -> ByteString -> ByteString -> IO () deliverMessageViaProxy proxyServ relayServ alg msg msg' = deliverMessagesViaProxy proxyServ relayServ alg [msg] [msg'] @@ -239,7 +239,7 @@ proxyConnectDeadRelay n d proxyServ = do Right !_noWay -> error "got unexpected client" Left !_err -> threadDelay d -agentDeliverMessageViaProxy :: (C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO () +agentDeliverMessageViaProxy :: (HasTestEnv, C.AlgorithmI a, C.AuthAlgorithm a) => (NonEmpty SMPServer, SMPProxyMode, Bool) -> (NonEmpty SMPServer, SMPProxyMode, Bool) -> C.SAlgorithm a -> ByteString -> ByteString -> AgentMsgId -> IO () agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, bViaProxy) alg msg1 msg2 baseId = withAgent 1 aCfg (servers aTestCfg) testDB $ \alice -> withAgent 2 aCfg (servers bTestCfg) testDB2 $ \bob -> runRight_ $ do @@ -278,7 +278,7 @@ agentDeliverMessageViaProxy aTestCfg@(aSrvs, _, aViaProxy) bTestCfg@(bSrvs, _, b aCfg = agentCfg {sndAuthAlg = C.AuthAlg alg, rcvAuthAlg = C.AuthAlg alg} servers (srvs, smpProxyMode, _) = (initAgentServersProxy_ smpProxyMode SPFAllow) {smp = userServers srvs} -agentDeliverMessagesViaProxyConc :: [NonEmpty SMPServer] -> [MsgBody] -> IO () +agentDeliverMessagesViaProxyConc :: HasTestEnv => [NonEmpty SMPServer] -> [MsgBody] -> IO () agentDeliverMessagesViaProxyConc agentServers msgs = withAgents $ \agents -> do let pairs = combinations 2 agents @@ -345,7 +345,7 @@ agentDeliverMessagesViaProxyConc agentServers msgs = aCfg = agentCfg {sndAuthAlg = C.AuthAlg C.SEd448, rcvAuthAlg = C.AuthAlg C.SEd448} servers srvs = (initAgentServersProxy_ SPMAlways SPFAllow) {smp = userServers srvs} -agentViaProxyRetryOffline :: IO () +agentViaProxyRetryOffline :: HasTestEnv => IO () agentViaProxyRetryOffline = do let srv1 = SMPServer testHost testPort testKeyHash srv2 = SMPServer testHost testPort2 testKeyHash @@ -418,7 +418,7 @@ agentViaProxyRetryOffline = do msgId = subtract baseId . fst servers srv = initAgentServersProxy {smp = userServers [srv]} -agentViaProxyRetryNoSession :: IO () +agentViaProxyRetryNoSession :: HasTestEnv => IO () agentViaProxyRetryNoSession = do let srv1 = SMPServer testHost testPort testKeyHash srv2 = SMPServer testHost testPort2 testKeyHash @@ -438,14 +438,14 @@ agentViaProxyRetryNoSession = do withServer2 = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 servers srv = initAgentServersProxy {smp = userServers [srv]} -testNoProxy :: AStoreType -> IO () +testNoProxy :: HasTestEnv => AStoreType -> IO () testNoProxy msType = do withSmpServerConfigOn (transport @TLS) (cfgMS msType) testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do (_, _, reply) <- sendRecv th (Nothing, "0", NoEntity, SMP.PRXY testSMPServer Nothing) reply `shouldBe` Right (SMP.ERR $ SMP.PROXY SMP.BASIC_AUTH) -testProxyAuth :: AStoreType -> IO () +testProxyAuth :: HasTestEnv => AStoreType -> IO () testProxyAuth msType = do withSmpServerConfigOn (transport @TLS) proxyCfgAuth testPort $ \_ -> do testSMPClient_ "127.0.0.1" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do @@ -456,12 +456,12 @@ testProxyAuth msType = do -- Connect a sender client to the proxy and request a relay session to testSMPServer2 (PRXY). -- On success the reply is PKEY; otherwise it is the proxy error for the relay connection. -requestRelaySession :: IO (Either SMP.ErrorType SMP.BrokerMsg) +requestRelaySession :: HasTestEnv => IO (Either SMP.ErrorType SMP.BrokerMsg) requestRelaySession = testSMPClient_ "localhost" testPort supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> (\(_, _, reply) -> reply) <$> sendRecv th (Nothing, "1", NoEntity, SMP.PRXY testSMPServer2 Nothing) -testChangedFwdVersion :: IO () +testChangedFwdVersion :: HasTestEnv => IO () testChangedFwdVersion = withSmpServerConfigOn (transport @TLS) cfg testPort $ \_ -> do g <- C.newRandom @@ -479,7 +479,7 @@ testChangedFwdVersion = -- Shared "phase 2" of the reconnection tests: start a healthy relay, confirm it is reachable -- directly (PING, not via the proxy) so a proxy failure can only mean the proxy didn't reconnect, -- let any stored connection error expire, then require the proxy to establish the session (PKEY). -requireProxyReconnect :: IO () +requireProxyReconnect :: HasTestEnv => IO () requireProxyReconnect = withSmpServerConfigOn (transport @TLS) proxyCfgJ2 testPort2 $ \_ -> do testSMPClient_ "127.0.0.1" testPort2 supportedServerSMPRelayVRange Nothing $ \(th :: THandleSMP TLS 'TClient) -> do @@ -494,7 +494,7 @@ requireProxyReconnect = -- The connect fails by timing out (storing a Left error that self-heals via persistErrorInterval), -- so once a healthy relay is running the proxy reconnects. This proves the stalling relay alone -- does not cause the permanent failure - only the mid-connection disconnect does. -testProxyRecoversWithoutDisconnect :: IO () +testProxyRecoversWithoutDisconnect :: HasTestEnv => IO () testProxyRecoversWithoutDisconnect = withSmpServerConfigOn (transport @TLS) proxyCfgShortTimeout testPort $ \_ -> do withStallingServerOn testPort2 $ @@ -516,7 +516,7 @@ testProxyRecoversWithoutDisconnect = -- The stalling relay (accepts TCP, never completes TLS) holds the connect open long enough to -- interleave the disconnect. Phase 2 (requireProxyReconnect) is identical to the control above; -- the only difference is this disconnect. -testProxyReconnectAfterRelayRestart :: IO () +testProxyReconnectAfterRelayRestart :: HasTestEnv => IO () testProxyReconnectAfterRelayRestart = withSmpServerConfigOn (transport @TLS) proxyCfgShortTimeout testPort $ \_ -> do -- disconnect the sender 1s into the 4s connect to the stalling relay, killing the in-flight worker @@ -530,7 +530,7 @@ testProxyReconnectAfterRelayRestart = -- skipped and the empty var is left in smpClients, so every later connection to that server times -- out on it. Phase 1 cancels a connect to a stalling relay; phase 2 requires a fresh connect to a -- healthy relay to succeed. -testAgentClientReconnectAfterCancel :: IO () +testAgentClientReconnectAfterCancel :: HasTestEnv => IO () testAgentClientReconnectAfterCancel = withAgent 1 agentCfg agentServersLeak testDB $ \a -> do withStallingServerOn testPort2 $ do diff --git a/tests/ServerTests.hs b/tests/ServerTests.hs index 116b4f0ec..09cfb963c 100644 --- a/tests/ServerTests.hs +++ b/tests/ServerTests.hs @@ -61,7 +61,7 @@ import System.IO (IOMode (..), withFile) import System.TimeIt (timeItT) import System.Timeout import Test.HUnit -import Test.Hspec hiding (fit, it) +import Test.Hspec hiding (fit, it, xit) import Util #if defined(dbServerPostgres) @@ -96,7 +96,6 @@ serverTests = do describe "Restore messages" testRestoreMessages describe "Restore messages (old / v2)" testRestoreExpireMessages describe "Save prometheus metrics" testPrometheusMetrics - describe "Timing of AUTH error" testTiming describe "Message notifications" $ do testMessageNotifications testMessageServiceNotifications @@ -1034,15 +1033,15 @@ testWithStoreLog = logSize testStoreLogFile `shouldReturn` (if compacting then 1 else 6) removeFile testStoreLogFile where - runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation + runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () killThread server - runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation + runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () -serverStoreLogCfg :: AStoreType -> (AServerConfig, Bool) +serverStoreLogCfg :: HasTestEnv => AStoreType -> (AServerConfig, Bool) serverStoreLogCfg msType = let cfg' = withServerCfg (cfgMS msType) $ \cfg_ -> @@ -1141,12 +1140,12 @@ testRestoreMessages = whenM (doesDirectoryExist testStoreMsgsDir) $ removeDirectoryRecursive testStoreMsgsDir removeFile testServerStatsBackupFile where - runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation + runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () killThread server - runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation + runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () checkStats :: ServerStatsData -> [RecipientId] -> Int -> Int -> Expectation @@ -1216,7 +1215,7 @@ testRestoreExpireMessages = Right ServerStatsData {_msgExpired} <- strDecode <$> B.readFile testServerStatsBackupFile _msgExpired `shouldBe` 2 where - exportStoreMessages :: AStoreType -> IO () + exportStoreMessages :: HasTestEnv => AStoreType -> IO () exportStoreMessages = \case ASType _ SMSJournal -> export ASType _ SMSPostgres -> exportDB @@ -1240,12 +1239,12 @@ testRestoreExpireMessages = readWriteQueueStore True (mkQueue ms True) testStoreLogFile (stmQueueStore ms) >>= closeStoreLog removeFileIfExists testStoreMsgsFile pure ms - runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation + runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> ThreadId -> Expectation runTest _ test' server = do testSMPClient test' `shouldReturn` () killThread server - runClient :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation + runClient :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO ()) -> Expectation runClient _ test' = testSMPClient test' `shouldReturn` () testPrometheusMetrics :: SpecWith (ASrvTransport, AStoreType) @@ -1511,7 +1510,7 @@ testServiceNotificationsTwoRestarts = Resp "3.2" _ (SOK Nothing) <- signSendRecv rh rKey ("3.2", rId, SUB) deliverMessage rh rId rKey sh sId sKey nh "hello 3" dec where - runTest2 :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a + runTest2 :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a runTest2 _ test' server = do a <- testSMPClient $ \h1 -> testSMPClient $ \h2 -> test' h1 h2 killThread server @@ -1602,7 +1601,7 @@ testBlockMessageQueue = Resp "dabc" sId2 (ERR (BLOCKED (BlockingInfo BRContent Nothing))) <- signSendRecv h sKey ("dabc", sId, SKEY sPub) (sId2, sId) #== "same queue ID in response" where - runTest :: Transport c => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a + runTest :: (HasTestEnv, Transport c) => TProxy c 'TServer -> (THandleSMP c 'TClient -> IO a) -> ThreadId -> IO a runTest _ test' server = do a <- testSMPClient test' killThread server @@ -1830,7 +1829,7 @@ serverSyntaxTests (ATransport t) = do it "no signature" $ ("", "cdab", "12345678", cmd) >#> ("", "cdab", "12345678", ERR $ CMD NO_AUTH) it "no queue ID" $ (sampleSig, "dabc", "", cmd) >#> ("", "dabc", "", ERR $ CMD NO_AUTH) (>#>) :: - Encoding smp => + (HasTestEnv, Encoding smp) => (Maybe TAuthorizations, ByteString, ByteString, smp) -> (Maybe TAuthorizations, ByteString, ByteString, BrokerMsg) -> Expectation diff --git a/tests/Test.hs b/tests/Test.hs index 16375bcc6..b769d0f8e 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,11 +1,10 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} import AgentTests (agentCoreTests, agentTests) +import AgentTests.FunctionalAPITests (functionalAPITimingTests) import CLITests -import Control.Concurrent (threadDelay) -import qualified Control.Exception as E +import Control.Exception (bracket_) import Control.Logger.Simple import CoreTests.BatchingTests import CoreTests.CryptoFileTests @@ -19,18 +18,16 @@ import CoreTests.TSessionSubs import CoreTests.UtilTests import CoreTests.VersionRangeTests import FileDescriptionTests (fileDescriptionTests) -import GHC.IO.Exception (IOException (..)) -import qualified GHC.IO.Exception as IOException import RSLVTests (rslvTests) import RemoteControl (remoteControlTests) import SMPNamesTests (smpNamesTests) -import SMPProxyTests (smpProxyTests) +import SMPProxyTests (smpProxyCapabilityTests, smpProxyTests) import ServerTests import Simplex.Messaging.Server.Env.STM (AStoreType (..)) import Simplex.Messaging.Server.MsgStore.Types (SMSType (..), SQSType (..)) import Simplex.Messaging.Transport (TLS, Transport (..)) -- import Simplex.Messaging.Transport.WebSockets (WS) -import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) +import System.Directory (createDirectory, removePathForcibly) import System.Environment (setEnv) import Test.Hspec hiding (fit, it) import Util @@ -44,18 +41,18 @@ import XFTPWebTests (xftpWebTests) #if defined(dbPostgres) import Fixtures -import SMPAgentClient (testDB) import Simplex.Messaging.Agent.Store.Postgres.Migrations.App -import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) #else import AgentTests.SchemaDump (schemaDumpTest) +import System.Directory (listDirectory) +import System.FilePath (()) #endif #if defined(dbServerPostgres) import CoreTests.XFTPStoreTests (xftpStoreTests, xftpMigrationTests) import NtfServerTests (ntfServerTests) -import NtfClient (ntfTestServerDBConnectInfo, ntfTestStoreDBOpts) -import SMPClient (testServerDBConnectInfo, testStoreDBOpts) +import NtfClient (ntfTestServerDBConnectInfo, ntfTestServerDBOpts) +import SMPClient (testServerDBConnectInfo, testServerDBOpts) import Simplex.Messaging.Notifications.Server.Store.Migrations (ntfServerMigrations) import Simplex.Messaging.Server.QueueStore.Postgres.Migrations (serverMigrations) import XFTPClient (testXFTPDBConnectInfo) @@ -75,76 +72,54 @@ main = do withGlobalLogging logCfg $ do setEnv "APNS_KEY_ID" "H82WD9K9AQ" setEnv "APNS_KEY_FILE" "./tests/fixtures/AuthKey_H82WD9K9AQ.p8" - hspec + withTmpDir . hspec #if defined(dbPostgres) . aroundAll_ (postgressBracket testDBConnectInfo) #endif - . before_ (createDirectoryIfMissing False "tests/tmp") - . after_ (eventuallyRemove "tests/tmp" 3) - $ do - describe "Core tests" $ do - describe "Batching tests" batchingTests - describe "Encoding tests" encodingTests - describe "Version range" versionRangeTests - describe "Encryption tests" cryptoTests - describe "Encrypted files tests" cryptoFileTests - describe "Message store tests" msgStoreTests - describe "Retry interval tests" retryIntervalTests - describe "SOCKS settings tests" socksSettingsTests #if defined(dbServerPostgres) - around_ (postgressBracket testServerDBConnectInfo) $ - describe "Store log tests" storeLogTests -#else - describe "Store log tests" storeLogTests + . aroundAll_ (postgressBracket testServerDBConnectInfo) + . aroundAll_ (postgressBracket ntfTestServerDBConnectInfo) + . aroundAll_ (postgressBracket testXFTPDBConnectInfo) #endif - describe "XFTP store log tests" fileStoreLogTests - fileExpirationTests - describe "TSessionSubs tests" tSessionSubsTests - describe "Util tests" utilTests - describe "Names resolver tests" smpNamesTests - describe "RSLV functional API tests" rslvTests - describe "Agent core tests" agentCoreTests + $ do + parallel $ do + describe "Core tests" $ do + describe "Batching tests" batchingTests + describe "Encoding tests" encodingTests + describe "Version range" versionRangeTests + describe "Encryption tests" cryptoTests + describe "Encrypted files tests" cryptoFileTests + describe "Message store tests" msgStoreTests + describe "SOCKS settings tests" socksSettingsTests + describe "Store log tests" storeLogTests + describe "XFTP store log tests" fileStoreLogTests + fileExpirationTests + describe "TSessionSubs tests" tSessionSubsTests + describe "Util tests" utilTests + describe "Names resolver tests" smpNamesTests + describe "RSLV functional API tests" rslvTests + describe "Agent core tests" agentCoreTests #if defined(dbServerPostgres) - around_ (postgressBracket testServerDBConnectInfo) $ - describe "SMP server schema dump" $ - postgresSchemaDumpTest - serverMigrations - [ "20250320_short_links", -- snd_secure moves to the bottom on down migration - "20260918_expire_messages" -- msg_queue_expire moves to the bottom on down migration - ] -- skipComparisonForDownMigrations - testStoreDBOpts - "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql" - around_ (postgressBracket testServerDBConnectInfo) $ do -- xdescribe "SMP server via TLS, postgres+jornal message store" $ -- before (pure (transport @TLS, ASType SQSPostgres SMSJournal)) serverTests describe "SMP server via TLS, postgres-only message store" $ before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) serverTests #endif - describe "SMP server via TLS, jornal message store" $ do - describe "SMP syntax" $ serverSyntaxTests (transport @TLS) - before (pure (transport @TLS, ASType SQSMemory SMSJournal)) serverTests - describe "SMP server via TLS, memory message store" $ - before (pure (transport @TLS, ASType SQSMemory SMSMemory)) serverTests - -- xdescribe "SMP server via WebSockets" $ do - -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) - -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests + describe "SMP server via TLS, jornal message store" $ do + describe "SMP syntax" $ serverSyntaxTests (transport @TLS) + before (pure (transport @TLS, ASType SQSMemory SMSJournal)) serverTests + describe "SMP server via TLS, memory message store" $ + before (pure (transport @TLS, ASType SQSMemory SMSMemory)) serverTests + -- xdescribe "SMP server via WebSockets" $ do + -- describe "SMP syntax" $ serverSyntaxTests (transport @WS) + -- before (pure (transport @WS, ASType SQSMemory SMSJournal)) serverTests #if defined(dbServerPostgres) - around_ (postgressBracket ntfTestServerDBConnectInfo) $ - describe "Ntf server schema dump" $ - postgresSchemaDumpTest - ntfServerMigrations - [] -- skipComparisonForDownMigrations - ntfTestStoreDBOpts - "src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql" - around_ (postgressBracket ntfTestServerDBConnectInfo) $ do describe "Notifications server (SMP server: memory store)" $ ntfServerTests (transport @TLS, ASType SQSMemory SMSMemory) - around_ (postgressBracket testServerDBConnectInfo) $ do - -- xdescribe "Notifications server (SMP server: postgres+jornal store)" $ - -- ntfServerTests (transport @TLS, ASType SQSPostgres SMSJournal) - describe "Notifications server (SMP server: postgres-only store)" $ - ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres) - around_ (postgressBracket testServerDBConnectInfo) $ do + -- xdescribe "Notifications server (SMP server: postgres+jornal store)" $ + -- ntfServerTests (transport @TLS, ASType SQSPostgres SMSJournal) + describe "Notifications server (SMP server: postgres-only store)" $ + ntfServerTests (transport @TLS, ASType SQSPostgres SMSPostgres) -- xdescribe "SMP client agent, postgres+jornal message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSJournal) describe "SMP client agent, server postgres-only message store" $ agentTests (transport @TLS, ASType SQSPostgres SMSPostgres) -- xdescribe "SMP proxy, postgres+jornal message store" $ @@ -152,55 +127,86 @@ main = do describe "SMP proxy, postgres-only message store" $ before (pure $ ASType SQSPostgres SMSPostgres) smpProxyTests #endif - -- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal) - describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory) - describe "SMP proxy, jornal message store" $ - before (pure $ ASType SQSMemory SMSJournal) smpProxyTests - describe "XFTP" $ do - describe "XFTP server" $ - before (pure $ AFSType SFSMemory) xftpServerTests - describe "XFTP file description" fileDescriptionTests - describe "XFTP CLI (memory)" $ - before (pure $ AFSType SFSMemory) xftpCLIFileTests - describe "XFTP agent" $ - before (pure $ AFSType SFSMemory) xftpAgentTests + -- xdescribe "SMP client agent, server jornal message store" $ agentTests (transport @TLS, ASType SQSMemory SMSJournal) + describe "SMP client agent, server memory message store" $ agentTests (transport @TLS, ASType SQSMemory SMSMemory) + describe "SMP proxy, jornal message store" $ + before (pure $ ASType SQSMemory SMSJournal) smpProxyTests + describe "XFTP" $ do + describe "XFTP server" $ + before (pure $ AFSType SFSMemory) xftpServerTests + describe "XFTP file description" fileDescriptionTests + describe "XFTP agent" $ + before (pure $ AFSType SFSMemory) xftpAgentTests #if defined(dbServerPostgres) - around_ (postgressBracket testXFTPDBConnectInfo) $ do describe "XFTP Postgres store operations" xftpStoreTests describe "XFTP migration round-trip" xftpMigrationTests describe "XFTP server (PostgreSQL)" $ before (pure $ AFSType SFSPostgres) xftpServerTests describe "XFTP agent (PostgreSQL)" $ before (pure $ AFSType SFSPostgres) xftpAgentTests +#endif + describe "XFTP Web Client" xftpWebTests + describe "XRCP" remoteControlTests + describe "Web" webTests + sequential $ do + describe "Core tests" $ describe "Retry interval tests" retryIntervalTests +#if defined(dbServerPostgres) + describe "SMP server via TLS, postgres-only message store" $ + before (pure (transport @TLS, ASType SQSPostgres SMSPostgres)) $ describe "Timing of AUTH error" testTiming +#endif + describe "SMP server via TLS, jornal message store" $ + before (pure (transport @TLS, ASType SQSMemory SMSJournal)) $ describe "Timing of AUTH error" testTiming + describe "SMP server via TLS, memory message store" $ + before (pure (transport @TLS, ASType SQSMemory SMSMemory)) $ describe "Timing of AUTH error" testTiming +#if defined(dbServerPostgres) + describe "SMP client agent, server postgres-only message store" $ + describe "Functional API" $ functionalAPITimingTests (transport @TLS, ASType SQSPostgres SMSPostgres) +#endif + describe "SMP client agent, server memory message store" $ + describe "Functional API" $ functionalAPITimingTests (transport @TLS, ASType SQSMemory SMSMemory) +#if defined(dbServerPostgres) + describe "SMP proxy capabilities, postgres-only message store" $ + before (pure $ ASType SQSPostgres SMSPostgres) smpProxyCapabilityTests +#endif + describe "SMP proxy capabilities, jornal message store" $ + before (pure $ ASType SQSMemory SMSJournal) smpProxyCapabilityTests + describe "XFTP CLI (memory)" $ + before (pure $ AFSType SFSMemory) xftpCLIFileTests +#if defined(dbServerPostgres) describe "XFTP CLI (PostgreSQL)" $ before (pure $ AFSType SFSPostgres) xftpCLIFileTests #endif -#if defined(dbPostgres) - describe "XFTP Web Client" $ xftpWebTests (dropAllSchemasExceptSystem testDBConnectInfo) -#else - describe "XFTP Web Client" $ xftpWebTests (pure ()) + describe "Server CLIs" cliTests +#if defined(dbServerPostgres) + around_ (postgressBracket testServerDBConnectInfo) $ + describe "SMP server schema dump" $ + postgresSchemaDumpTest + serverMigrations + [ "20250320_short_links", -- snd_secure moves to the bottom on down migration + "20260918_expire_messages" -- msg_queue_expire moves to the bottom on down migration + ] -- skipComparisonForDownMigrations + testServerDBOpts + "src/Simplex/Messaging/Server/QueueStore/Postgres/server_schema.sql" + around_ (postgressBracket ntfTestServerDBConnectInfo) $ + describe "Ntf server schema dump" $ + postgresSchemaDumpTest + ntfServerMigrations + [] -- skipComparisonForDownMigrations + ntfTestServerDBOpts + "src/Simplex/Messaging/Notifications/Server/Store/ntf_server_schema.sql" #endif - describe "XRCP" remoteControlTests - describe "Web" webTests - describe "Server CLIs" cliTests #if defined(dbPostgres) - around_ (postgressBracket testDBConnectInfo) $ - describe "Agent PostgreSQL schema dump" $ - postgresSchemaDumpTest - appMigrations - ["20250322_short_links"] -- snd_secure and last_broker_ts columns swap order on down migration - (testDBOpts testDB) - "src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql" + around_ (postgressBracket testDBConnectInfo) $ + describe "Agent PostgreSQL schema dump" $ + postgresSchemaDumpTest + appMigrations + ["20250322_short_links"] -- snd_secure and last_broker_ts columns swap order on down migration + (testDBOpts "smp_agent_test_protocol_schema") + "src/Simplex/Messaging/Agent/Store/Postgres/Migrations/agent_postgres_schema.sql" #else - describe "Agent SQLite schema dump" schemaDumpTest + after_ (listDirectory tmpDir >>= mapM_ (removeFileIfExists . (tmpDir ))) $ + describe "Agent SQLite schema dump" schemaDumpTest #endif -eventuallyRemove :: FilePath -> Int -> IO () -eventuallyRemove path retries = case retries of - 0 -> action - n -> - action `E.catch` \ioe@IOError {ioe_type, ioe_filename} -> case ioe_type of - IOException.UnsatisfiedConstraints | ioe_filename == Just path -> threadDelay 1000000 >> eventuallyRemove path (n - 1) - _ -> E.throwIO ioe - where - action = removeDirectoryRecursive path +withTmpDir :: IO a -> IO a +withTmpDir = bracket_ (removePathForcibly tmpDir >> createDirectory tmpDir) (eventuallyRemove tmpDir 3) diff --git a/tests/Util.hs b/tests/Util.hs index 9a4049d68..dbd824eba 100644 --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,21 +1,33 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module Util where +import Control.Concurrent (threadDelay) import Control.Concurrent.Async +import Control.Concurrent.STM import Control.Exception as E import Control.Logger.Simple import Control.Monad (replicateM, when) import Data.Either (partitionEithers) import Data.List (tails) +import Data.String (IsString (..)) import GHC.Conc (getNumCapabilities, getNumProcessors, setNumCapabilities) -import System.Directory (doesFileExist, removeFile) +import GHC.IO.Exception (IOException (..)) +import qualified GHC.IO.Exception as IOException +import Network.Socket (ServiceName) +import System.Directory (createDirectoryIfMissing, doesFileExist, removeDirectoryRecursive, removeFile) import System.Environment (lookupEnv) +import System.FilePath (()) +import System.IO.Unsafe (unsafePerformIO) import System.Process (callCommand) import System.Timeout (timeout) -import Test.Hspec hiding (fit, it) +import Test.Hspec hiding (fit, it, xit) import qualified Test.Hspec as Hspec import Test.Hspec.Core.Spec (Example (..), Result (..), ResultStatus (..)) @@ -44,7 +56,70 @@ removeFileIfExists filePath = do fileExists <- doesFileExist filePath when fileExists $ removeFile filePath -newtype TestWrapper a = TestWrapper a +data TestEnv = TestEnv + { testNo :: Int, + portBase :: Int + } + +type HasTestEnv = (?testEnv :: TestEnv) + +tmpDir :: FilePath +tmpDir = "tests/tmp" + +testDir :: HasTestEnv => FilePath +testDir = tmpDir show (testNo ?testEnv) + +testPath :: HasTestEnv => FilePath -> FilePath +testPath = (testDir ) + +testServerPort :: HasTestEnv => Int -> ServiceName +testServerPort offset = show (portBase ?testEnv + offset) + +testSchemaName :: (HasTestEnv, IsString s) => String -> s +testSchemaName name = fromString $ "test" <> show (testNo ?testEnv) <> "_" <> name + +senderFiles :: HasTestEnv => FilePath +senderFiles = testPath "xftp-sender-files" + +recipientFiles :: HasTestEnv => FilePath +recipientFiles = testPath "xftp-recipient-files" + +testCounter :: TVar Int +testCounter = unsafePerformIO $ newTVarIO 0 +{-# NOINLINE testCounter #-} + +portBases :: TVar [Int] +portBases = unsafePerformIO $ newTVarIO [10000, 10010 .. 19990] +{-# NOINLINE portBases #-} + +withTestEnv :: (HasTestEnv => IO a) -> IO a +withTestEnv action = + bracket takePortBase releasePortBase $ \portBase -> do + testNo <- atomically $ stateTVar testCounter $ \n -> (n, n + 1) + let ?testEnv = TestEnv {testNo, portBase} + bracket_ + (mapM_ (createDirectoryIfMissing True) [senderFiles, recipientFiles]) + (eventuallyRemove testDir 3) + action + where + takePortBase = + atomically $ + readTVar portBases >>= \case + b : bs -> b <$ writeTVar portBases bs + [] -> retry + releasePortBase b = atomically $ modifyTVar' portBases (<> [b]) + +eventuallyRemove :: FilePath -> Int -> IO () +eventuallyRemove path retries = case retries of + 0 -> action + n -> + action `E.catch` \ioe@IOError {ioe_type, ioe_filename} -> case ioe_type of + IOException.UnsatisfiedConstraints | ioe_filename == Just path -> threadDelay 1000000 >> eventuallyRemove path (n - 1) + _ -> E.throwIO ioe + where + action = removeDirectoryRecursive path + +data TestWrapper a = TestWrapper (HasTestEnv => a) -- TODO [ntfdb] running wiht LogWarn level shows potential issue "Queue count differs" testLogLevel :: LogLevel @@ -56,11 +131,12 @@ instance Example a => Example (TestWrapper a) where ci <- envCI runTest `E.catches` [E.Handler (onTestFailure ci), E.Handler (onTestException ci)] where - tt = 120 + tt = 300 runTest = - timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case - Just r -> pure r - Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds" + withTestEnv $ + timeout (tt * 1000000) (evaluateExample action params hooks state) `finally` callCommand "sync" >>= \case + Just r -> pure r + Nothing -> throwIO $ userError $ "test timed out after " <> show tt <> " seconds" onTestFailure :: Bool -> ResultStatus -> IO Result onTestFailure ci = \case Failure loc_ reason | ci -> do @@ -80,8 +156,11 @@ instance Example a => Example (TestWrapper a) where envCI :: IO Bool envCI = (Just "true" ==) <$> lookupEnv "CI" -it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) +it :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a) it label action = Hspec.it label (TestWrapper action) -fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) -fit = fmap focus . it +fit :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a) +fit label action = focus $ it label action + +xit :: (HasCallStack, Example a) => String -> (HasTestEnv => a) -> SpecWith (Arg a) +xit label action = Hspec.xit label (TestWrapper action) diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs index 2d513313d..eda83f4f1 100644 --- a/tests/XFTPAgent.hs +++ b/tests/XFTPAgent.hs @@ -48,34 +48,25 @@ import Simplex.Messaging.Crypto.Entitlement (Entitlement (..), MasterKey (..), s import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs) import qualified Simplex.Messaging.Crypto.File as CF import Simplex.Messaging.Encoding.String (StrEncoding (..)) -import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServerWithAuth) +import Simplex.Messaging.Protocol (BasicAuth, NetworkError (..), ProtoServerWithAuth (..), ProtocolServer (..), XFTPServer, XFTPServerWithAuth) import Simplex.Messaging.Server.Expiration (ExpirationConfig (..)) import Simplex.Messaging.Server.Information (ServerPublicInfo) import Simplex.Messaging.Transport (EntitlementConfig (..)) import Simplex.Messaging.Util (tshow) import System.Directory (doesDirectoryExist, doesFileExist, getFileSize, listDirectory, removeFile) import System.FilePath (()) -import Test.Hspec hiding (fit, it) +import Test.Hspec hiding (fit, it, xit) import UnliftIO import UnliftIO.Concurrent import Util -import XFTPCLI import XFTPClient -#if defined(dbPostgres) -import Fixtures -import Simplex.Messaging.Agent.Store.Postgres.Util (dropAllSchemasExceptSystem) -#endif pattern SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> AEvent 'AESndFile pattern SFDONE sndDescr rcvDescrs <- A.SFDONE sndDescr rcvDescrs _ xftpAgentTests :: SpecWith AFStoreType xftpAgentTests = - around_ testBracket -#if defined(dbPostgres) - . after_ (dropAllSchemasExceptSystem testDBConnectInfo) -#endif - . describe "agent XFTP API" $ do + describe "agent XFTP API" $ do it "should send and receive file" $ withXFTPServer testXFTPAgentSendReceive -- uncomment CPP option slow_servers and run hpack to run this test xit "should send and receive file with slow server responses" $ \_ -> @@ -100,18 +91,21 @@ xftpAgentTests = it "should request additional recipient IDs when number of recipients exceeds maximum per request" testXFTPAgentRequestAdditionalRecipientIDs describe "XFTP server test via agent API" $ do it "should pass without basic auth" $ \_ -> testXFTPServerTest Nothing (noAuthSrv testXFTPServer2) `shouldReturn` Right (Just (Right testServerInformation)) - let srv1 = testXFTPServer2 {keyHash = "1234"} + let srv1 :: HasTestEnv => XFTPServer + srv1 = testXFTPServer2 {keyHash = "1234"} it "should fail with incorrect fingerprint" $ \_ -> do testXFTPServerTest Nothing (noAuthSrv srv1) `shouldReturn` Left (ProtocolTestFailure TSConnect $ BROKER (B.unpack $ strEncode srv1) $ NETWORK NEUnknownCAError) describe "server with password" $ do let auth = Just "abcd" + srv :: HasTestEnv => Maybe BasicAuth -> XFTPServerWithAuth srv = ProtoServerWithAuth testXFTPServer2 + authErr :: HasTestEnv => ProtocolTestFailure authErr = ProtocolTestFailure TSCreateFile $ XFTP (B.unpack $ strEncode testXFTPServer2) AUTH it "should pass with correct password" $ \_ -> testXFTPServerTest auth (srv auth) `shouldReturn` Right (Just (Right testServerInformation)) it "should fail without password" $ \_ -> testXFTPServerTest auth (srv Nothing) `shouldReturn` Left authErr it "should fail with incorrect password" $ \_ -> testXFTPServerTest auth (srv $ Just "wrong") `shouldReturn` Left authErr -testXFTPServerTest :: HasCallStack => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) +testXFTPServerTest :: (HasCallStack, HasTestEnv) => Maybe BasicAuth -> XFTPServerWithAuth -> IO (Either ProtocolTestFailure (Maybe (Either String ServerPublicInfo))) testXFTPServerTest newFileBasicAuth srv = withXFTPServerCfg testXFTPServerConfig {newFileBasicAuth, xftpPort = xftpTestPort2, information = Just testServerInformation} $ \_ -> -- initially passed server is not running @@ -143,7 +137,7 @@ checkProgress (prev, expected) (progress, total) loop | progress < total = loop progress | otherwise = pure () -testXFTPAgentSendReceive :: HasCallStack => IO () +testXFTPAgentSendReceive :: (HasCallStack, HasTestEnv) => IO () testXFTPAgentSendReceive = do filePath <- createRandomFile -- send file, delete snd file internally @@ -160,7 +154,7 @@ testXFTPAgentSendReceive = do rfId <- runRight $ testReceive rcp rfd originalFilePath xftpDeleteRcvFile rcp rfId -testXFTPAgentSendReceiveEncrypted :: HasCallStack => AFStoreType -> IO () +testXFTPAgentSendReceiveEncrypted :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do g <- C.newRandom filePath <- createRandomFile @@ -181,7 +175,7 @@ testXFTPAgentSendReceiveEncrypted = withXFTPServer $ do rfId <- runRight $ testReceiveCF rcp rfd cfArgs originalFilePath xftpDeleteRcvFile rcp rfId -testXFTPAgentSendReceiveRedirect :: HasCallStack => AFStoreType -> IO () +testXFTPAgentSendReceiveRedirect :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentSendReceiveRedirect = withXFTPServer $ do --- sender filePathIn <- createRandomFile @@ -239,7 +233,7 @@ testXFTPAgentSendReceiveRedirect = withXFTPServer $ do inBytes <- B.readFile filePathIn B.readFile out `shouldReturn` inBytes -testXFTPAgentSendReceiveNoRedirect :: HasCallStack => AFStoreType -> IO () +testXFTPAgentSendReceiveNoRedirect :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do --- sender let fileSize = mb 5 @@ -280,7 +274,7 @@ testXFTPAgentSendReceiveNoRedirect = withXFTPServer $ do inBytes <- B.readFile filePathIn B.readFile out `shouldReturn` inBytes -testXFTPAgentPrepareReceive :: HasCallStack => AFStoreType -> IO () +testXFTPAgentPrepareReceive :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentPrepareReceive = withXFTPServer $ do filePath <- createRandomFile (_, _, rfd1, rfd2) <- withAgent 1 agentCfg initAgentServers testDB $ \sndr -> runRight $ testSend sndr filePath @@ -305,7 +299,7 @@ testXFTPAgentPrepareReceive = withXFTPServer $ do file <- B.readFile filePath B.readFile path `shouldReturn` file -testXFTPAgentPrepareSend :: HasCallStack => AFStoreType -> IO () +testXFTPAgentPrepareSend :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentPrepareSend = withXFTPServer $ do filePath1 <- createRandomFile' "testfile1" filePath2 <- createRandomFile' "testfile2" @@ -343,11 +337,12 @@ testXFTPAgentSendReceiveMatrix = do it "old sender, new recipient" $ run newServer oldClient newClient it "old clients" $ run newServer oldClient oldClient where + oldClient, newClient :: HasTestEnv => AgentConfig oldClient = agentCfg {xftpCfg = (xftpCfg agentCfg) {clientALPN = Nothing}} newClient = agentCfg oldServer = withXFTPServerCfgNoALPN newServer = withXFTPServerCfg - run :: HasCallStack => (HasCallStack => XFTPServerConfig STMFileStore -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO () + run :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPServerConfig STMFileStore -> (ThreadId -> IO ()) -> IO ()) -> AgentConfig -> AgentConfig -> IO () run withServer sender receiver = withServer testXFTPServerConfig $ \_t -> do filePath <- createRandomFile_ (kb 319 :: Integer) "testfile" @@ -358,26 +353,26 @@ testXFTPAgentSendReceiveMatrix = do rfId <- runRight $ testReceiveCF' rcp rfd Nothing filePath (kb 320) xftpDeleteRcvFile rcp rfId -createRandomFile :: HasCallStack => IO FilePath +createRandomFile :: (HasCallStack, HasTestEnv) => IO FilePath createRandomFile = createRandomFile' "testfile" -createRandomFile' :: HasCallStack => FilePath -> IO FilePath +createRandomFile' :: (HasCallStack, HasTestEnv) => FilePath -> IO FilePath createRandomFile' = createRandomFile_ (mb 17 :: Integer) -createRandomFile_ :: (HasCallStack, Integral s, Show s) => s -> FilePath -> IO FilePath +createRandomFile_ :: (HasCallStack, HasTestEnv, Integral s) => s -> FilePath -> IO FilePath createRandomFile_ size fileName = do let filePath = senderFiles fileName - xftpCLI ["rand", filePath, show size] `shouldReturn` ["File created: " <> filePath] + B.writeFile filePath =<< atomically . C.randomBytes (fromIntegral size) =<< C.newRandom getFileSize filePath `shouldReturn` toInteger size pure filePath -testSend :: HasCallStack => AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient) +testSend :: (HasCallStack, HasTestEnv) => AgentClient -> FilePath -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient) testSend sndr = testSendCF sndr . CF.plain -testSendCF :: HasCallStack => AgentClient -> CryptoFile -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient) +testSendCF :: (HasCallStack, HasTestEnv) => AgentClient -> CryptoFile -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient) testSendCF sndr file = testSendCF' sndr file $ mb 18 -testSendCF' :: HasCallStack => AgentClient -> CryptoFile -> Int64 -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient) +testSendCF' :: (HasCallStack, HasTestEnv) => AgentClient -> CryptoFile -> Int64 -> ExceptT AgentErrorType IO (SndFileId, ValidFileDescription 'FSender, ValidFileDescription 'FRecipient, ValidFileDescription 'FRecipient) testSendCF' sndr file size = do xftpStartWorkers sndr (Just senderFiles) sfId <- xftpSendFile sndr 1 file 2 @@ -392,7 +387,7 @@ testNoRedundancy :: HasCallStack => ValidFileDescription 'FRecipient -> IO () testNoRedundancy (ValidFileDescription FileDescription {chunks}) = all (\FileChunk {replicas} -> length replicas == 1) chunks `shouldBe` True -testXFTPAgentEntitlement :: HasCallStack => IO () +testXFTPAgentEntitlement :: (HasCallStack, HasTestEnv) => IO () testXFTPAgentEntitlement = do Right (issuerPk, issuerSk) <- bbsKeyGen now <- getCurrentTime @@ -429,10 +424,10 @@ testXFTPAgentEntitlement = do ("", _, SFPROG _ _) -> waitSndDone sndr r -> error $ "Expected SFDONE, got " <> show r -testReceive :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId +testReceive :: (HasCallStack, HasTestEnv) => AgentClient -> ValidFileDescription 'FRecipient -> FilePath -> ExceptT AgentErrorType IO RcvFileId testReceive rcp rfd = testReceiveCF rcp rfd Nothing -testReceiveCF :: HasCallStack => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId +testReceiveCF :: (HasCallStack, HasTestEnv) => AgentClient -> ValidFileDescription 'FRecipient -> Maybe CryptoFileArgs -> FilePath -> ExceptT AgentErrorType IO RcvFileId testReceiveCF rcp rfd cfArgs originalFilePath = do xftpStartWorkers rcp (Just recipientFiles) testReceiveCF' rcp rfd cfArgs originalFilePath $ mb 18 @@ -454,7 +449,7 @@ testReceiveCF' rcp rfd cfArgs originalFilePath size = do logCfgNoLogs :: LogConfig logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False} -testXFTPAgentReceiveRestore :: HasCallStack => IO () +testXFTPAgentReceiveRestore :: (HasCallStack, HasTestEnv) => IO () testXFTPAgentReceiveRestore = do filePath <- createRandomFile @@ -498,7 +493,7 @@ testXFTPAgentReceiveRestore = do -- tmp path should be removed after receiving file doesDirectoryExist tmpPath `shouldReturn` False -testXFTPAgentReceiveCleanup :: HasCallStack => IO () +testXFTPAgentReceiveCleanup :: (HasCallStack, HasTestEnv) => IO () testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do filePath <- createRandomFile @@ -523,13 +518,14 @@ testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do -- receive file - should fail with AUTH error withAgent 3 agentCfg initAgentServers testDB2 $ \rcp' -> do runRight_ $ xftpStartWorkers rcp' (Just recipientFiles) - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- rfGet rcp' + ("", rfId', RFERR (XFTP srv AUTH)) <- rfGet rcp' rfId' `shouldBe` rfId + srv `shouldBe` testXFTPServerStr -- tmp path should be removed after permanent error doesDirectoryExist tmpPath `shouldReturn` False -testXFTPAgentSendRestore :: HasCallStack => IO () +testXFTPAgentSendRestore :: (HasCallStack, HasTestEnv) => IO () testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do filePath <- createRandomFile @@ -576,7 +572,7 @@ testXFTPAgentSendRestore = withGlobalLogging logCfgNoLogs $ do withAgent 4 agentCfg initAgentServers testDB2 $ \rcp -> runRight_ . void $ testReceive rcp rfd1 filePath -testXFTPAgentSendCleanup :: HasCallStack => IO () +testXFTPAgentSendCleanup :: (HasCallStack, HasTestEnv) => IO () testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do filePath <- createRandomFile @@ -602,15 +598,16 @@ testXFTPAgentSendCleanup = withGlobalLogging logCfgNoLogs $ do -- send file - should fail with AUTH error withAgent 2 agentCfg initAgentServers testDB $ \sndr' -> do runRight_ $ xftpStartWorkers sndr' (Just senderFiles) - ("", sfId', SFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + ("", sfId', SFERR (XFTP srv AUTH)) <- sfGet sndr' sfId' `shouldBe` sfId + srv `shouldBe` testXFTPServerStr -- prefix path should be removed after permanent error doesDirectoryExist prefixPath `shouldReturn` False doesFileExist encPath `shouldReturn` False -testXFTPAgentDelete :: HasCallStack => AFStoreType -> IO () +testXFTPAgentDelete :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentDelete = withGlobalLogging logCfgNoLogs . withXFTPServer test where test = do @@ -639,11 +636,12 @@ testXFTPAgentDelete = withGlobalLogging logCfgNoLogs . withXFTPServer test withAgent 3 agentCfg initAgentServers testDB2 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + ("", rfId', RFERR (XFTP srv AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId + liftIO $ srv `shouldBe` testXFTPServerStr -testXFTPAgentDeleteRestore :: HasCallStack => IO () +testXFTPAgentDeleteRestore :: (HasCallStack, HasTestEnv) => IO () testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do filePath <- createRandomFile @@ -677,11 +675,12 @@ testXFTPAgentDeleteRestore = withGlobalLogging logCfgNoLogs $ do withAgent 5 agentCfg initAgentServers testDB3 $ \rcp2 -> runRight $ do xftpStartWorkers rcp2 (Just recipientFiles) rfId <- xftpReceiveFile rcp2 1 rfd2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + ("", rfId', RFERR (XFTP srv AUTH)) <- rfGet rcp2 liftIO $ rfId' `shouldBe` rfId + liftIO $ srv `shouldBe` testXFTPServerStr -testXFTPAgentDeleteOnServer :: HasCallStack => AFStoreType -> IO () +testXFTPAgentDeleteOnServer :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer test where test = do @@ -713,14 +712,15 @@ testXFTPAgentDeleteOnServer = withGlobalLogging logCfgNoLogs . withXFTPServer te runRight_ . void $ do -- receive file 1 again rfId1 <- xftpReceiveFile rcp 1 rfd1_2 Nothing True - ("", rfId1', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + ("", rfId1', RFERR (XFTP srv AUTH)) <- rfGet rcp liftIO $ rfId1 `shouldBe` rfId1' + liftIO $ srv `shouldBe` testXFTPServerStr -- receive file 2 testReceive' rcp rfd2 filePath2 -testXFTPAgentExpiredOnServer :: HasCallStack => AFStoreType -> IO () +testXFTPAgentExpiredOnServer :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $ withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration = fastExpiration}) . const $ do filePath1 <- createRandomFile' "testfile1" @@ -745,9 +745,10 @@ testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $ -- receive file 1 again - should fail with AUTH error runRight $ do rfId <- xftpReceiveFile rcp 1 rfd1_2 Nothing True - ("", rfId', RFERR (XFTP "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" AUTH)) <- + ("", rfId', RFERR (XFTP srv AUTH)) <- rfGet rcp liftIO $ rfId' `shouldBe` rfId + liftIO $ srv `shouldBe` testXFTPServerStr -- create and send file 2 filePath2 <- createRandomFile' "testfile2" @@ -760,7 +761,7 @@ testXFTPAgentExpiredOnServer fsType = withGlobalLogging logCfgNoLogs $ where fastExpiration = ExpirationConfig {ttl = 2, checkInterval = 1} -testXFTPAgentRequestAdditionalRecipientIDs :: HasCallStack => AFStoreType -> IO () +testXFTPAgentRequestAdditionalRecipientIDs :: (HasCallStack, HasTestEnv) => AFStoreType -> IO () testXFTPAgentRequestAdditionalRecipientIDs = withXFTPServer $ do filePath <- createRandomFile diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs index 3fe2f3bf5..6ec442aab 100644 --- a/tests/XFTPCLI.hs +++ b/tests/XFTPCLI.hs @@ -1,6 +1,6 @@ -module XFTPCLI (xftpCLIFileTests, xftpCLI, senderFiles, recipientFiles, testBracket) where +module XFTPCLI (xftpCLIFileTests, xftpCLI) where -import Control.Exception (bracket_, try) +import Control.Exception (try) import qualified Data.ByteString as LB import Data.List (isInfixOf, isPrefixOf, isSuffixOf) import Simplex.FileTransfer.Client.Main @@ -10,7 +10,7 @@ import Simplex.FileTransfer.Client.Main ) import Simplex.FileTransfer.Description (kb, mb) import Simplex.FileTransfer.Util (safeFileNameStr, uniqueCombine) -import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, removeDirectoryRecursive) +import System.Directory (getFileSize, listDirectory) import System.Environment (withArgs) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (takeFileName, ()) @@ -21,7 +21,7 @@ import Simplex.FileTransfer.Server.Env (AFStoreType) import XFTPClient (cfgFS, cfgFS2, withXFTPServer, withXFTPServerConfigOn, testXFTPServerStr, testXFTPServerStr2, xftpServerFiles, xftpServerFiles2) xftpCLIFileTests :: SpecWith AFStoreType -xftpCLIFileTests = around_ testBracket $ do +xftpCLIFileTests = do it "shows experimental deprecation notice in help" $ \_ -> testXFTPCLIHelpDeprecationNotice it "should send and receive file" $ withXFTPServer testXFTPCLISendReceive_ @@ -43,20 +43,6 @@ xftpCLIFileTests = around_ testBracket $ do sanitized n = let n' = safeFileNameStr n in n' /= "" && n' /= "." && n' /= ".." bareName n = let n' = safeFileNameStr n in n' == takeFileName n' -testBracket :: IO () -> IO () -testBracket = - bracket_ - (mapM_ (createDirectoryIfMissing False) testDirs) - (mapM_ removeDirectoryRecursive testDirs) - where - testDirs = [xftpServerFiles, xftpServerFiles2, senderFiles, recipientFiles] - -senderFiles :: FilePath -senderFiles = "tests/tmp/xftp-sender-files" - -recipientFiles :: FilePath -recipientFiles = "tests/tmp/xftp-recipient-files" - xftpCLI :: [String] -> IO [String] xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI) @@ -66,7 +52,7 @@ testXFTPCLIHelpDeprecationNotice = do result `shouldBe` (Left ExitSuccess :: Either ExitCode ()) unwords (words output) `shouldSatisfy` (xftpClientDeprecationNotice `isInfixOf`) -testXFTPCLISendReceive_ :: IO () +testXFTPCLISendReceive_ :: HasTestEnv => IO () testXFTPCLISendReceive_ = do let filePath = senderFiles "testfile" xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] @@ -75,7 +61,7 @@ testXFTPCLISendReceive_ = do let fdRcv1 = filePath <> ".xftp" "rcv1.xftp" fdRcv2 = filePath <> ".xftp" "rcv2.xftp" fdSnd = filePath <> ".xftp" "snd.xftp.private" - progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"] + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=" <> testDir] progress `shouldSatisfy` uploadProgress let (sendInfo, sendRest) = splitAt 4 sendResult sendInfo @@ -90,19 +76,19 @@ testXFTPCLISendReceive_ = do testInfoFile fdRcv2 "Recipient" testReceiveFile fdRcv2 "testfile_1" file testInfoFile fdSnd "Sender" - xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"] + xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=" <> testDir] `shouldThrow` anyException where testInfoFile fd party = do xftpCLI ["info", fd] `shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"] testReceiveFile fd fileName file = do - progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"] + progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=" <> testDir, "-y"] progress `shouldSatisfy` downloadProgress fileName recvResult `shouldBe` ["File description " <> fd <> " is deleted."] LB.readFile (recipientFiles fileName) `shouldReturn` file -testXFTPCLISendReceive2servers_ :: IO () +testXFTPCLISendReceive2servers_ :: HasTestEnv => IO () testXFTPCLISendReceive2servers_ = do let filePath = senderFiles "testfile" xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] @@ -111,7 +97,7 @@ testXFTPCLISendReceive2servers_ = do let fdRcv1 = filePath <> ".xftp" "rcv1.xftp" fdRcv2 = filePath <> ".xftp" "rcv2.xftp" fdSnd = filePath <> ".xftp" "snd.xftp.private" - progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"] + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=" <> testDir] progress `shouldSatisfy` uploadProgress let (sendInfo, sendRest) = splitAt 4 sendResult sendInfo @@ -135,12 +121,12 @@ testXFTPCLISendReceive2servers_ = do srv1 `shouldContain` testXFTPServerStr srv2 `shouldContain` testXFTPServerStr2 _ -> print srvs >> error "more than 2 servers returned" - progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"] + progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=" <> testDir, "-y"] progress `shouldSatisfy` downloadProgress fileName recvResult `shouldBe` ["File description " <> fd <> " is deleted."] LB.readFile (recipientFiles fileName) `shouldReturn` file -testXFTPCLIDelete_ :: IO () +testXFTPCLIDelete_ :: HasTestEnv => IO () testXFTPCLIDelete_ = do let filePath = senderFiles "testfile" xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] @@ -149,7 +135,7 @@ testXFTPCLIDelete_ = do let fdRcv1 = filePath <> ".xftp" "rcv1.xftp" fdRcv2 = filePath <> ".xftp" "rcv2.xftp" fdSnd = filePath <> ".xftp" "snd.xftp.private" - progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"] + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=" <> testDir] progress `shouldSatisfy` uploadProgress let (sendInfo, sendRest) = splitAt 4 sendResult sendInfo @@ -161,7 +147,7 @@ testXFTPCLIDelete_ = do sendRest `shouldSatisfy` any ("https://" `isPrefixOf`) xftpCLI ["del", fdRcv1] `shouldThrow` anyException - progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp", "-y"] + progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=" <> testDir, "-y"] progress1 `shouldSatisfy` downloadProgress "testfile" recvResult `shouldBe` ["File description " <> fdRcv1 <> " is deleted."] LB.readFile (recipientFiles "testfile") `shouldReturn` file @@ -172,10 +158,10 @@ testXFTPCLIDelete_ = do `shouldReturn` ["File deleted! \r", "File description " <> fdSnd <> " is deleted."] listDirectory xftpServerFiles >>= (`shouldBe` []) listDirectory xftpServerFiles2 >>= (`shouldBe` []) - xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"] + xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=" <> testDir] `shouldThrow` anyException -testReceivedFileNameCombine :: IO () +testReceivedFileNameCombine :: HasTestEnv => IO () testReceivedFileNameCombine = uniqueCombine recipientFiles "../../escaped.txt" `shouldReturn` (recipientFiles "escaped.txt") @@ -202,7 +188,7 @@ uploadProgress s = && "Uploading file..." `isInfixOf` s && "File uploaded!" `isInfixOf` s -downloadProgress :: FilePath -> String -> Bool +downloadProgress :: HasTestEnv => FilePath -> String -> Bool downloadProgress fileName s = "Downloading file..." `isPrefixOf` s && "Decrypting file..." `isInfixOf` s diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs index 772b1b692..688c90eda 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -26,11 +26,14 @@ import Simplex.Messaging.Crypto.File (CryptoFile) import Simplex.Messaging.Protocol (XFTPServer) import Simplex.Messaging.Transport.HTTP2 (httpALPN) import Simplex.Messaging.Transport.Server +import System.Directory (createDirectoryIfMissing) import Test.Hspec hiding (fit, it) +import Util #if defined(dbServerPostgres) import Control.Monad (void) import qualified Database.PostgreSQL.Simple as PSQL import Database.PostgreSQL.Simple (ConnectInfo (..), defaultConnectInfo) +import Database.PostgreSQL.Simple.Types (Query (..)) import Simplex.FileTransfer.Server.Store.Postgres.Config (PostgresFileStoreCfg (..), defaultXFTPDBOpts) import Simplex.Messaging.Agent.Store.Postgres.Options (DBOpts (..)) import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation (..)) @@ -44,7 +47,7 @@ data AXFTPServerConfig = forall s. FileStoreClass s => AXFTPSrvCfg (XFTPServerCo updateXFTPCfg :: AXFTPServerConfig -> (forall s. XFTPServerConfig s -> XFTPServerConfig s) -> AXFTPServerConfig updateXFTPCfg (AXFTPSrvCfg cfg) f = AXFTPSrvCfg (f cfg) -cfgFS :: AFStoreType -> AXFTPServerConfig +cfgFS :: HasTestEnv => AFStoreType -> AXFTPServerConfig cfgFS (AFSType fs) = case fs of SFSMemory -> AXFTPSrvCfg testXFTPServerConfig #if defined(dbServerPostgres) @@ -53,7 +56,7 @@ cfgFS (AFSType fs) = case fs of SFSPostgres -> error "no postgres support" #endif -cfgFS2 :: AFStoreType -> AXFTPServerConfig +cfgFS2 :: HasTestEnv => AFStoreType -> AXFTPServerConfig cfgFS2 (AFSType fs) = case fs of SFSMemory -> AXFTPSrvCfg testXFTPServerConfig2 #if defined(dbServerPostgres) @@ -73,12 +76,12 @@ testXFTPDBConnectInfo = connectDatabase = "test_xftp_server_db" } -testXFTPPostgresCfg :: PostgresFileStoreCfg +testXFTPPostgresCfg :: HasTestEnv => PostgresFileStoreCfg testXFTPPostgresCfg = PostgresFileStoreCfg { dbOpts = defaultXFTPDBOpts { connstr = "postgresql://test_xftp_server_user@/test_xftp_server_db", - schema = "xftp_server_test", + schema = testSchemaName "xftp_server_test", poolSize = 10, createSchema = True }, @@ -86,94 +89,94 @@ testXFTPPostgresCfg = confirmMigrations = MCYesUp } -clearXFTPPostgresStore :: IO () +clearXFTPPostgresStore :: HasTestEnv => IO () clearXFTPPostgresStore = do - let DBOpts {connstr} = dbOpts testXFTPPostgresCfg + let DBOpts {connstr, schema} = dbOpts testXFTPPostgresCfg conn <- PSQL.connectPostgreSQL connstr - void $ PSQL.execute_ conn "SET search_path TO xftp_server_test,public" + void $ PSQL.execute_ conn $ Query $ "SET search_path TO " <> schema <> ",public" void $ PSQL.execute_ conn "DELETE FROM files" PSQL.close conn #endif -xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> AFStoreType -> Expectation +xftpTest :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> IO ()) -> AFStoreType -> Expectation xftpTest test fsType = withXFTPServerConfigOn (cfgFS fsType) (\_ -> testXFTPClient test) `shouldReturn` () -xftpTestN :: HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> AFStoreType -> Expectation +xftpTestN :: (HasCallStack, HasTestEnv) => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> AFStoreType -> Expectation xftpTestN nClients test fsType = withXFTPServerConfigOn (cfgFS fsType) (\_ -> run nClients []) `shouldReturn` () where run :: Int -> [XFTPClient] -> IO () run 0 hs = test hs run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs) -xftpTest2 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation +xftpTest2 :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation xftpTest2 test = xftpTestN 2 _test where _test [h1, h2] = test h1 h2 _test _ = error "expected 2 handles" -xftpTest4 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation +xftpTest4 :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> XFTPClient -> XFTPClient -> XFTPClient -> IO ()) -> AFStoreType -> Expectation xftpTest4 test = xftpTestN 4 _test where _test [h1, h2, h3, h4] = test h1 h2 h3 h4 _test _ = error "expected 4 handles" -withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerStoreLogOn :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {serverStoreCfg = XSCMemory (Just testXFTPLogFile), storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile} withXFTPServerCfgNoALPN :: (HasCallStack, FileStoreClass s) => XFTPServerConfig s -> (HasCallStack => ThreadId -> IO a) -> IO a withXFTPServerCfgNoALPN cfg = withXFTPServerCfg cfg {transportConfig = (transportConfig cfg) {serverALPN = Nothing}} withXFTPServerCfg :: (HasCallStack, FileStoreClass s) => XFTPServerConfig s -> (HasCallStack => ThreadId -> IO a) -> IO a -withXFTPServerCfg cfg = +withXFTPServerCfg cfg@XFTPServerConfig {filesPath} = serverBracket - (\started -> runXFTPServerBlocking started cfg) + (\started -> createDirectoryIfMissing True filesPath >> runXFTPServerBlocking started cfg) (threadDelay 10000) -withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerThreadOn :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig -withXFTPServer :: HasCallStack => IO a -> AFStoreType -> IO a +withXFTPServer :: (HasCallStack, HasTestEnv) => IO a -> AFStoreType -> IO a withXFTPServer test fsType = withXFTPServerConfigOn (cfgFS fsType) $ const test -withXFTPServer2 :: HasCallStack => IO a -> AFStoreType -> IO a +withXFTPServer2 :: (HasCallStack, HasTestEnv) => IO a -> AFStoreType -> IO a withXFTPServer2 test fsType = withXFTPServerConfigOn (cfgFS2 fsType) $ const test -- Constants -xftpTestPort :: ServiceName -xftpTestPort = "8000" +xftpTestPort :: HasTestEnv => ServiceName +xftpTestPort = testServerPort 6 -xftpTestPort2 :: ServiceName -xftpTestPort2 = "8001" +xftpTestPort2 :: HasTestEnv => ServiceName +xftpTestPort2 = testServerPort 7 -testXFTPServer :: XFTPServer +testXFTPServer :: HasTestEnv => XFTPServer testXFTPServer = fromString testXFTPServerStr -testXFTPServer2 :: XFTPServer +testXFTPServer2 :: HasTestEnv => XFTPServer testXFTPServer2 = fromString testXFTPServerStr2 -testXFTPServerStr :: String -testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8000" +testXFTPServerStr :: HasTestEnv => String +testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:" <> xftpTestPort -testXFTPServerStr2 :: String -testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:8001" +testXFTPServerStr2 :: HasTestEnv => String +testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:" <> xftpTestPort2 -xftpServerFiles :: FilePath -xftpServerFiles = "tests/tmp/xftp-server-files" +xftpServerFiles :: HasTestEnv => FilePath +xftpServerFiles = testPath "xftp-server-files" -xftpServerFiles2 :: FilePath -xftpServerFiles2 = "tests/tmp/xftp-server-files2" +xftpServerFiles2 :: HasTestEnv => FilePath +xftpServerFiles2 = testPath "xftp-server-files2" -testXFTPLogFile :: FilePath -testXFTPLogFile = "tests/tmp/xftp-server-store.log" +testXFTPLogFile :: HasTestEnv => FilePath +testXFTPLogFile = testPath "xftp-server-store.log" -testXFTPStatsBackupFile :: FilePath -testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log" +testXFTPStatsBackupFile :: HasTestEnv => FilePath +testXFTPStatsBackupFile = testPath "xftp-server-stats.log" -xftpTestPrometheusMetricsFile :: FilePath -xftpTestPrometheusMetricsFile = "tests/tmp/xftp-server-metrics.txt" +xftpTestPrometheusMetricsFile :: HasTestEnv => FilePath +xftpTestPrometheusMetricsFile = testPath "xftp-server-metrics.txt" -testXFTPServerConfig :: XFTPServerConfig STMFileStore +testXFTPServerConfig :: HasTestEnv => XFTPServerConfig STMFileStore testXFTPServerConfig = XFTPServerConfig { xftpPort = xftpTestPort, @@ -204,7 +207,7 @@ testXFTPServerConfig = information = Nothing, logStatsInterval = Nothing, logStatsStartTime = 0, - serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", + serverStatsLogFile = testPath "xftp-server-stats.daily.log", serverStatsBackupFile = Nothing, prometheusInterval = Nothing, prometheusMetricsFile = xftpTestPrometheusMetricsFile, @@ -213,23 +216,23 @@ testXFTPServerConfig = webStaticPath = Nothing } -testXFTPServerConfig2 :: XFTPServerConfig STMFileStore +testXFTPServerConfig2 :: HasTestEnv => XFTPServerConfig STMFileStore testXFTPServerConfig2 = testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} testXFTPClientConfig :: XFTPClientConfig testXFTPClientConfig = defaultXFTPClientConfig -testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a +testXFTPClient :: (HasCallStack, HasTestEnv) => (HasCallStack => XFTPClient -> IO a) -> IO a testXFTPClient = testXFTPClientWith testXFTPClientConfig -testXFTPClientWith :: HasCallStack => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a +testXFTPClientWith :: (HasCallStack, HasTestEnv) => XFTPClientConfig -> (HasCallStack => XFTPClient -> IO a) -> IO a testXFTPClientWith cfg client = do ts <- getCurrentTime getXFTPClient (1, testXFTPServer, Nothing) cfg [] ts (\_ -> pure Nothing) (\_ -> pure ()) >>= \case Right c -> client c Left e -> error $ show e -testXFTPServerConfigSNI :: XFTPServerConfig STMFileStore +testXFTPServerConfigSNI :: HasTestEnv => XFTPServerConfig STMFileStore testXFTPServerConfigSNI = testXFTPServerConfig { httpCredentials = @@ -245,10 +248,10 @@ testXFTPServerConfigSNI = } } -withXFTPServerSNI :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerSNI :: (HasCallStack, HasTestEnv) => (HasCallStack => ThreadId -> IO a) -> IO a withXFTPServerSNI = withXFTPServerCfg testXFTPServerConfigSNI -testXFTPServerConfigEd25519SNI :: XFTPServerConfig STMFileStore +testXFTPServerConfigEd25519SNI :: HasTestEnv => XFTPServerConfig STMFileStore testXFTPServerConfigEd25519SNI = testXFTPServerConfig { xftpCredentials = diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 693856d9f..a5a28feb8 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -47,7 +47,7 @@ import Simplex.Messaging.Transport.HTTP2 (HTTP2Body (..)) import qualified Simplex.Messaging.Transport.HTTP2.Client as HC import Simplex.Messaging.Transport.Server (loadFileFingerprint) import Simplex.Messaging.Transport.Shared (ChainCertificates (..), chainIdCaCerts) -import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile) +import System.Directory (removeFile) import System.FilePath (()) import Test.Hspec hiding (fit, it) import UnliftIO.STM @@ -55,8 +55,7 @@ import Util import XFTPClient xftpServerTests :: SpecWith AFStoreType -xftpServerTests = - before_ (createDirectoryIfMissing False xftpServerFiles) . after_ (removeDirectoryRecursive xftpServerFiles) $ do +xftpServerTests = do describe "XFTP file chunk delivery" $ do it "should create, upload and receive file chunk (1 client)" testFileChunkDelivery it "should create, upload and receive file chunk (2 clients)" testFileChunkDelivery2 @@ -90,8 +89,8 @@ xftpServerTests = chSize :: Integral a => a chSize = kb 128 -testChunkPath :: FilePath -testChunkPath = "tests/tmp/chunk1" +testChunkPath :: HasTestEnv => FilePath +testChunkPath = testPath "chunk1" createTestChunk :: FilePath -> IO ByteString createTestChunk fp = do @@ -103,16 +102,16 @@ createTestChunk fp = do createXFTPChunk :: XFTPClient -> C.APrivateAuthKey -> FileInfo -> NonEmpty C.APublicAuthKey -> Maybe BasicAuth -> ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) createXFTPChunk c spKey file rcps auth = (\(sId, rIds, _) -> (sId, rIds)) <$> A.createXFTPChunk c spKey file rcps auth Nothing -readChunk :: XFTPFileId -> IO ByteString +readChunk :: HasTestEnv => XFTPFileId -> IO ByteString readChunk sId = B.readFile (xftpServerFiles B.unpack (B64.encode $ unEntityId sId)) -testFileChunkDelivery :: AFStoreType -> Expectation +testFileChunkDelivery :: HasTestEnv => AFStoreType -> Expectation testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c -testFileChunkDelivery2 :: AFStoreType -> Expectation +testFileChunkDelivery2 :: HasTestEnv => AFStoreType -> Expectation testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelivery s r -runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () +runTestFileChunkDelivery :: HasTestEnv => XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkDelivery s r = do g <- liftIO C.newRandom (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -127,12 +126,12 @@ runTestFileChunkDelivery s r = do uploadXFTPChunk s spKey sId' chunkSpec `catchError` (liftIO . (`shouldBe` PCEProtocolError DIGEST)) liftIO $ readChunk sId `shouldReturn` bytes - downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong")) + downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk1") chSize (digest <> "_wrong")) `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST)) - downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest + liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes -testFileChunkDeliveryAddRecipients :: AFStoreType -> Expectation +testFileChunkDeliveryAddRecipients :: HasTestEnv => AFStoreType -> Expectation testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do g <- liftIO C.newRandom (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -149,17 +148,17 @@ testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do let testReceiveChunk r rpKey rId fPath = do downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec fPath chSize digest liftIO $ B.readFile fPath `shouldReturn` bytes - testReceiveChunk r1 rpKey1 rId1 "tests/tmp/received_chunk1" - testReceiveChunk r2 rpKey2 rId2 "tests/tmp/received_chunk2" - testReceiveChunk r3 rpKey3 rId3 "tests/tmp/received_chunk3" + testReceiveChunk r1 rpKey1 rId1 (testPath "received_chunk1") + testReceiveChunk r2 rpKey2 rId2 (testPath "received_chunk2") + testReceiveChunk r3 rpKey3 rId3 (testPath "received_chunk3") -testFileChunkDelete :: AFStoreType -> Expectation +testFileChunkDelete :: HasTestEnv => AFStoreType -> Expectation testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c -testFileChunkDelete2 :: AFStoreType -> Expectation +testFileChunkDelete2 :: HasTestEnv => AFStoreType -> Expectation testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r -runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () +runTestFileChunkDelete :: HasTestEnv => XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO () runTestFileChunkDelete s r = do g <- liftIO C.newRandom (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -171,18 +170,18 @@ runTestFileChunkDelete s r = do (sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing uploadXFTPChunk s spKey sId chunkSpec - downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + downloadXFTPChunk g r rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest + liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes deleteXFTPChunk s spKey sId liftIO $ readChunk sId `shouldThrow` \(e :: SomeException) -> "does not exist" `isInfixOf` show e - downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk2") chSize digest) `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) deleteXFTPChunk s spKey sId `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) -testWrongChunkSize :: AFStoreType -> Expectation +testWrongChunkSize :: HasTestEnv => AFStoreType -> Expectation testWrongChunkSize = xftpTest $ \c -> do g <- C.newRandom (sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g @@ -194,7 +193,7 @@ testWrongChunkSize = xftpTest $ \c -> do void (createXFTPChunk c spKey file [rcvKey] Nothing) `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE)) -testFileChunkExpiration :: AFStoreType -> Expectation +testFileChunkExpiration :: HasTestEnv => AFStoreType -> Expectation testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileExpiration}) $ \_ -> testXFTPClient $ \c -> runRight_ $ do g <- liftIO C.newRandom @@ -207,18 +206,18 @@ testFileChunkExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fs (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing uploadXFTPChunk c spKey sId chunkSpec - downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest + liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes liftIO $ threadDelay 1000000 - downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest) + downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec (testPath "received_chunk2") chSize digest) `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) deleteXFTPChunk c spKey sId `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) where fileExpiration = ExpirationConfig {ttl = 1, checkInterval = 1} -testInactiveClientExpiration :: AFStoreType -> Expectation +testInactiveClientExpiration :: HasTestEnv => AFStoreType -> Expectation testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {inactiveClientExpiration}) $ \_ -> runRight_ $ do disconnected <- newEmptyTMVarIO ts <- liftIO getCurrentTime @@ -234,7 +233,7 @@ testInactiveClientExpiration fsType = withXFTPServerConfigOn (updateXFTPCfg (cfg where inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1} -testFileStorageQuota :: AFStoreType -> Expectation +testFileStorageQuota :: HasTestEnv => AFStoreType -> Expectation testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {fileSizeQuota = Just $ chSize * 2}) $ \_ -> testXFTPClient $ \c -> runRight_ $ do g <- liftIO C.newRandom @@ -245,8 +244,8 @@ testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsTyp let file = FileInfo {sndKey, size = chSize, digest} chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} download rId = do - downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest + liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes (sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing uploadXFTPChunk c spKey sId1 chunkSpec download rId1 @@ -262,7 +261,7 @@ testFileStorageQuota fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsTyp uploadXFTPChunk c spKey sId3 chunkSpec download rId3 -testFileLog :: AFStoreType -> Expectation +testFileLog :: HasTestEnv => AFStoreType -> Expectation testFileLog _ = do g <- C.newRandom bytes <- liftIO $ createTestChunk testChunkPath @@ -298,9 +297,9 @@ testFileLog _ = do rId1 <- liftIO $ readTVarIO rIdVar1 rId2 <- liftIO $ readTVarIO rIdVar2 -- recipients and sender get AUTH error because server restarted without log - downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest) + downloadXFTPChunk g c rpKey1 rId1 (XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest) `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) - downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest) + downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest) `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) deleteXFTPChunk c spKey sId `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) @@ -331,10 +330,10 @@ testFileLog _ = do removeFile testXFTPStatsBackupFile where download g c rpKey rId digest bytes = do - downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk1") chSize digest + liftIO $ B.readFile (testPath "received_chunk1") `shouldReturn` bytes -testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> AFStoreType -> IO () +testFileBasicAuth :: HasTestEnv => Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> AFStoreType -> IO () testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success fsType = withXFTPServerConfigOn (updateXFTPCfg (cfgFS fsType) $ \c -> c {allowNewFiles, newFileBasicAuth}) $ \_ -> testXFTPClient $ \c -> do @@ -350,13 +349,13 @@ testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success fsType = then do (sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth uploadXFTPChunk c spKey sId chunkSpec - downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk") chSize digest + liftIO $ B.readFile (testPath "received_chunk") `shouldReturn` bytes else do void (createXFTPChunk c spKey file [rcvKey] clntAuth) `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) -testFileSkipCommitted :: AFStoreType -> IO () +testFileSkipCommitted :: HasTestEnv => AFStoreType -> IO () testFileSkipCommitted fsType = withXFTPServerConfigOn (cfgFS fsType) $ \_ -> testXFTPClient $ \c -> do @@ -372,8 +371,8 @@ testFileSkipCommitted fsType = uploadXFTPChunk c spKey sId chunkSpec void . liftIO $ createTestChunk testChunkPath -- trash chunk contents uploadXFTPChunk c spKey sId chunkSpec -- upload again to get FROk without getting stuck - downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk" chSize digest - liftIO $ B.readFile "tests/tmp/received_chunk" `shouldReturn` bytes -- new chunk content got ignored + downloadXFTPChunk g c rpKey rId $ XFTPRcvChunkSpec (testPath "received_chunk") chSize digest + liftIO $ B.readFile (testPath "received_chunk") `shouldReturn` bytes -- new chunk content got ignored -- SNI and CORS tests @@ -386,7 +385,7 @@ getCerts tls = let X.CertificateChain cc = tlsPeerCert tls in map (X.signedObject . X.getSigned) cc -testSNICertSelection :: Expectation +testSNICertSelection :: HasTestEnv => Expectation testSNICertSelection = withXFTPServerSNI $ \_ -> do Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt" @@ -399,7 +398,7 @@ testSNICertSelection = leaf : _ -> expectationFailure $ "Expected RSA cert, got: " <> show (X.certPubKey leaf) [] -> expectationFailure "Empty certificate chain" -testNoSNICertSelection :: Expectation +testNoSNICertSelection :: HasTestEnv => Expectation testNoSNICertSelection = withXFTPServerSNI $ \_ -> do Fingerprint fpXFTP <- loadFileFingerprint "tests/fixtures/ca.crt" @@ -412,7 +411,7 @@ testNoSNICertSelection = leaf : _ -> expectationFailure $ "Expected Ed448 cert, got: " <> show (X.certPubKey leaf) [] -> expectationFailure "Empty certificate chain" -testCORSHeaders :: Expectation +testCORSHeaders :: HasTestEnv => Expectation testCORSHeaders = withXFTPServerSNI $ \_ -> do Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt" @@ -426,7 +425,7 @@ testCORSHeaders = lookupResponseHeader "access-control-allow-origin" response `shouldBe` Just "*" lookupResponseHeader "access-control-expose-headers" response `shouldBe` Just "*" -testCORSPreflight :: Expectation +testCORSPreflight :: HasTestEnv => Expectation testCORSPreflight = withXFTPServerSNI $ \_ -> do Fingerprint fpHTTP <- loadFileFingerprint "tests/fixtures/web_ca.crt" @@ -442,7 +441,7 @@ testCORSPreflight = lookupResponseHeader "access-control-allow-headers" response `shouldBe` Just "*" lookupResponseHeader "access-control-max-age" response `shouldBe` Just "86400" -testNoCORSWithoutSNI :: Expectation +testNoCORSWithoutSNI :: HasTestEnv => Expectation testNoCORSWithoutSNI = withXFTPServerSNI $ \_ -> do Fingerprint fpXFTP <- loadFileFingerprint "tests/fixtures/ca.crt" @@ -455,11 +454,11 @@ testNoCORSWithoutSNI = HC.HTTP2Response {HC.response} <- either (error . show) pure =<< HC.sendRequest h2 req (Just 5000000) lookupResponseHeader "access-control-allow-origin" response `shouldBe` Nothing -testFileChunkDeliverySNI :: Expectation +testFileChunkDeliverySNI :: HasTestEnv => Expectation testFileChunkDeliverySNI = withXFTPServerSNI $ \_ -> testXFTPClient $ \c -> runRight_ $ runTestFileChunkDelivery c c -testWebHandshake :: Expectation +testWebHandshake :: HasTestEnv => Expectation testWebHandshake = withXFTPServerSNI $ \_ -> do Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt" @@ -501,7 +500,7 @@ testWebHandshake = let ackBody = bodyHead (HC.respBody resp2) B.length ackBody `shouldBe` 0 -testWebReHandshake :: Expectation +testWebReHandshake :: HasTestEnv => Expectation testWebReHandshake = withXFTPServerSNI $ \_ -> do Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt" @@ -535,7 +534,7 @@ testWebReHandshake = resp2b <- either (error . show) pure =<< HC.sendRequest h2 (H2.requestBuilder "POST" "/" [] $ byteString clientHsPadded) (Just 5000000) B.length (bodyHead (HC.respBody resp2b)) `shouldBe` 0 -testStaleWebSession :: Expectation +testStaleWebSession :: HasTestEnv => Expectation testStaleWebSession = withXFTPServerSNI $ \_ -> do Fingerprint fpWeb <- loadFileFingerprint "tests/fixtures/web_ca.crt" diff --git a/tests/XFTPWebTests.hs b/tests/XFTPWebTests.hs index b56fbef72..3e24809a9 100644 --- a/tests/XFTPWebTests.hs +++ b/tests/XFTPWebTests.hs @@ -51,7 +51,6 @@ import AgentTests.FunctionalAPITests (rfGet, runRight, runRight_, sfGet, withAge import Simplex.Messaging.Agent (AgentClient, xftpReceiveFile, xftpStartWorkers) import Simplex.Messaging.Agent.Protocol (AEvent (..)) import SMPAgentClient (agentCfg, initAgentServers, testDB) -import XFTPCLI (recipientFiles, senderFiles, testBracket) import qualified Simplex.Messaging.Crypto.File as CF xftpWebDir :: FilePath @@ -168,8 +167,8 @@ impAddr = "import * as Addr from './dist/protocol/address.js';" jsOut :: String -> String jsOut expr = "process.stdout.write(Buffer.from(" <> expr <> "));" -xftpWebTests :: IO () -> Spec -xftpWebTests dbCleanup = do +xftpWebTests :: Spec +xftpWebTests = do xftpWebSourceHygieneTests distExists <- runIO $ doesDirectoryExist (xftpWebDir <> "/dist") if distExists @@ -189,7 +188,7 @@ xftpWebTests dbCleanup = do tsClientTests tsDownloadTests tsAddressTests - tsIntegrationTests dbCleanup + tsIntegrationTests else it "skipped (run 'cd xftp-web && npm install && npm run build' first)" $ pendingWith "TS project not compiled" @@ -2847,9 +2846,8 @@ tsAddressTests = describe "protocol/address" $ do -- ── integration ─────────────────────────────────────────────────── -tsIntegrationTests :: IO () -> Spec -tsIntegrationTests dbCleanup = describe "integration" $ - around_ testBracket . after_ dbCleanup $ do +tsIntegrationTests :: Spec +tsIntegrationTests = describe "integration" $ do it "web handshake with Ed25519 identity verification" $ webHandshakeTest testXFTPServerConfigEd25519SNI "tests/fixtures/ed25519/ca.crt" it "web handshake with Ed448 identity verification" $ @@ -2872,7 +2870,7 @@ tsIntegrationTests dbCleanup = describe "integration" $ it "cross-language: Haskell upload, TS download" $ haskellUploadTsDownloadTest testXFTPServerConfigSNI -webHandshakeTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation +webHandshakeTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation webHandshakeTest cfg caFile = do withXFTPServerCfg cfg $ \_ -> do Fingerprint fp <- loadFileFingerprint caFile @@ -2914,7 +2912,7 @@ webHandshakeTest cfg caFile = do <> jsOut "new Uint8Array([idOk ? 1 : 0, ack.length === 0 ? 1 : 0])" result `shouldBe` B.pack [1, 1] -pingTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation +pingTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation pingTest cfg caFile = do withXFTPServerCfg cfg $ \_ -> do Fingerprint fp <- loadFileFingerprint caFile @@ -2936,9 +2934,8 @@ pingTest cfg caFile = do <> jsOut "new Uint8Array([1])" result `shouldBe` B.pack [1] -fullRoundTripTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation +fullRoundTripTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation fullRoundTripTest cfg caFile = do - createDirectoryIfMissing False "tests/tmp/xftp-server-files" withXFTPServerCfg cfg $ \_ -> do Fingerprint fp <- loadFileFingerprint caFile let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp @@ -3017,9 +3014,8 @@ agentURIRoundTripTest = do <> jsOut "new Uint8Array([match])" result `shouldBe` B.pack [1] -agentUploadDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation +agentUploadDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation agentUploadDownloadTest cfg caFile = do - createDirectoryIfMissing False "tests/tmp/xftp-server-files" withXFTPServerCfg cfg $ \_ -> do Fingerprint fp <- loadFileFingerprint caFile let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp @@ -3050,9 +3046,8 @@ agentUploadDownloadTest cfg caFile = do <> jsOut "new Uint8Array([nameMatch, sizeMatch, dataMatch])" result `shouldBe` B.pack [1, 1, 1] -agentDeleteTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation +agentDeleteTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation agentDeleteTest cfg caFile = do - createDirectoryIfMissing False "tests/tmp/xftp-server-files" withXFTPServerCfg cfg $ \_ -> do Fingerprint fp <- loadFileFingerprint caFile let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp @@ -3082,9 +3077,8 @@ agentDeleteTest cfg caFile = do <> jsOut "new Uint8Array([deleted])" result `shouldBe` B.pack [1] -agentRedirectTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation +agentRedirectTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation agentRedirectTest cfg caFile = do - createDirectoryIfMissing False "tests/tmp/xftp-server-files" withXFTPServerCfg cfg $ \_ -> do Fingerprint fp <- loadFileFingerprint caFile let fpStr = map (toEnum . fromIntegral) $ B.unpack $ strEncode fp @@ -3116,9 +3110,8 @@ agentRedirectTest cfg caFile = do <> jsOut "new Uint8Array([hasRedirect, nameMatch, sizeMatch, dataMatch])" result `shouldBe` B.pack [1, 1, 1, 1] -tsUploadHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation +tsUploadHaskellDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation tsUploadHaskellDownloadTest cfg caFile = do - createDirectoryIfMissing False "tests/tmp/xftp-server-files" createDirectoryIfMissing False recipientFiles withXFTPServerCfg cfg $ \_ -> do Fingerprint fp <- loadFileFingerprint caFile @@ -3151,9 +3144,8 @@ tsUploadHaskellDownloadTest cfg caFile = do downloadedData <- B.readFile outPath downloadedData `shouldBe` originalData -tsUploadRedirectHaskellDownloadTest :: XFTPServerConfig STMFileStore -> FilePath -> Expectation +tsUploadRedirectHaskellDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> FilePath -> Expectation tsUploadRedirectHaskellDownloadTest cfg caFile = do - createDirectoryIfMissing False "tests/tmp/xftp-server-files" createDirectoryIfMissing False recipientFiles withXFTPServerCfg cfg $ \_ -> do Fingerprint fp <- loadFileFingerprint caFile @@ -3186,9 +3178,8 @@ tsUploadRedirectHaskellDownloadTest cfg caFile = do downloadedData <- B.readFile outPath downloadedData `shouldBe` originalData -haskellUploadTsDownloadTest :: XFTPServerConfig STMFileStore -> Expectation +haskellUploadTsDownloadTest :: HasTestEnv => XFTPServerConfig STMFileStore -> Expectation haskellUploadTsDownloadTest cfg = do - createDirectoryIfMissing False "tests/tmp/xftp-server-files" createDirectoryIfMissing False senderFiles let filePath = senderFiles <> "/hs-to-ts.bin" originalData <- B.pack <$> replicateM 50000 (randomIO :: IO Word8) @@ -3201,8 +3192,8 @@ haskellUploadTsDownloadTest cfg = do (_, _, SFDONE _ [rfd] _) <- sfGet sndr pure rfd let yamlDesc = strEncode vfd - tmpYaml = "tests/tmp/hs-to-ts-desc.yaml" - tmpData = "tests/tmp/hs-to-ts-data.bin" + tmpYaml = testPath "hs-to-ts-desc.yaml" + tmpData = testPath "hs-to-ts-data.bin" B.writeFile tmpYaml yamlDesc B.writeFile tmpData originalData result <- @@ -3212,8 +3203,12 @@ haskellUploadTsDownloadTest cfg = do \import * as Agent from './dist/agent.js';\ \import {decodeFileDescription, validateFileDescription} from './dist/protocol/description.js';\ \await sodium.ready;\ - \const yaml = fs.readFileSync('../tests/tmp/hs-to-ts-desc.yaml', 'utf-8');\ - \const expected = new Uint8Array(fs.readFileSync('../tests/tmp/hs-to-ts-data.bin'));\ + \const yaml = fs.readFileSync('../" + <> tmpYaml + <> "', 'utf-8');\ + \const expected = new Uint8Array(fs.readFileSync('../" + <> tmpData + <> "'));\ \const fd = decodeFileDescription(yaml);\ \const err = validateFileDescription(fd);\ \if (err) throw new Error(err);\