mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 20:45:52 +00:00
416f1b1721
* smp: command authorization
* fix encoding, most tests
* remove old tests
* authorize via crypto_box
* extract authenticator to Crypto module
* make TransmissionAuth Maybe
* rfc
* support authenticators in NTF protocol, test matrix (no backwards compatibility yet from new clients to old servers)
* fix/add tests, add version config to "small" agent
* separate client and server versions for SMP protocol
* test batching SMP v7
* do not send session ID in each transmission
* refactor auth verification in the server, split tests
* server "warm up" fixes timing test
* uncomment SUB timing test
* comments, disable two timing tests
* rename version
* increase auth timing test failure threshold
* use different algorithms to authorize snd/rcv commands, use random correlation ID
* transport: fetch and store server certificate (#985)
* THandleParams (WIP, does not compile)
* transport: fetch and store server certificate
* smp: add getOnlinePubKey example to smpClientHandshake
* add server certs and sign authPub
* cleanup
* update
* style
* load server certs from test fixtures
* sign ntf authPubKey
* fix onServerCertificate
* increase delay before sending messages
* require certificate with key in SMP server handshake
---------
Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>
* remove dhSecret from THandle
* remove v8, merge all changes to one version
* parameterize THandle
* rfc: transmission ecnryption
* Revert "parameterize THandle"
This reverts commit 75adfc94fb.
* use batch syntax for ntf server commands
* separate encodeTransmission when there is no key
* typo
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
* rename
* diff
---------
Co-authored-by: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
375 lines
17 KiB
Haskell
375 lines
17 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module XFTPServerTests where
|
|
|
|
import AgentTests.FunctionalAPITests (runRight_)
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Exception (SomeException)
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.IO.Unlift
|
|
import qualified Data.ByteString.Base64.URL as B64
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as B
|
|
import qualified Data.ByteString.Lazy.Char8 as LB
|
|
import Data.List (isInfixOf)
|
|
import ServerTests (logSize)
|
|
import Simplex.FileTransfer.Client
|
|
import Simplex.FileTransfer.Description (kb)
|
|
import Simplex.FileTransfer.Protocol (FileInfo (..), XFTPErrorType (..))
|
|
import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..))
|
|
import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
|
|
import Simplex.Messaging.Client (ProtocolClientError (..))
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
|
import Simplex.Messaging.Protocol (BasicAuth, SenderId)
|
|
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
|
import Simplex.Messaging.Util (liftIOEither)
|
|
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
|
|
import System.FilePath ((</>))
|
|
import Test.Hspec
|
|
import UnliftIO.STM
|
|
import XFTPClient
|
|
|
|
xftpServerTests :: Spec
|
|
xftpServerTests =
|
|
before_ (createDirectoryIfMissing False xftpServerFiles)
|
|
. after_ (removeDirectoryRecursive xftpServerFiles)
|
|
. 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
|
|
it "should create, add recipients, upload and receive file chunk" testFileChunkDeliveryAddRecipients
|
|
it "should delete file chunk (1 client)" testFileChunkDelete
|
|
it "should delete file chunk (2 clients)" testFileChunkDelete2
|
|
it "should acknowledge file chunk reception (1 client)" testFileChunkAck
|
|
it "should acknowledge file chunk reception (2 clients)" testFileChunkAck2
|
|
it "should not allow chunks of wrong size" testWrongChunkSize
|
|
it "should expire chunks after set interval" testFileChunkExpiration
|
|
it "should disconnect inactive clients" testInactiveClientExpiration
|
|
it "should not allow uploading chunks after specified storage quota" testFileStorageQuota
|
|
it "should store file records to log and restore them after server restart" testFileLog
|
|
describe "XFTP basic auth" $ do
|
|
-- allow FNEW | server auth | clnt auth | success
|
|
it "prohibited without basic auth" $ testFileBasicAuth True (Just "pwd") Nothing False
|
|
it "prohibited when auth is incorrect" $ testFileBasicAuth True (Just "pwd") (Just "wrong") False
|
|
it "prohibited when FNEW disabled" $ testFileBasicAuth False (Just "pwd") (Just "pwd") False
|
|
it "allowed with correct basic auth" $ testFileBasicAuth True (Just "pwd") (Just "pwd") True
|
|
it "allowed with auth on server without auth" $ testFileBasicAuth True Nothing (Just "any") True
|
|
|
|
chSize :: Integral a => a
|
|
chSize = kb 128
|
|
|
|
testChunkPath :: FilePath
|
|
testChunkPath = "tests/tmp/chunk1"
|
|
|
|
createTestChunk :: FilePath -> IO ByteString
|
|
createTestChunk fp = do
|
|
g <- C.newRandom
|
|
bytes <- atomically $ C.randomBytes chSize g
|
|
B.writeFile fp bytes
|
|
pure bytes
|
|
|
|
readChunk :: SenderId -> IO ByteString
|
|
readChunk sId = B.readFile (xftpServerFiles </> B.unpack (B64.encode sId))
|
|
|
|
testFileChunkDelivery :: Expectation
|
|
testFileChunkDelivery = xftpTest $ \c -> runRight_ $ runTestFileChunkDelivery c c
|
|
|
|
testFileChunkDelivery2 :: Expectation
|
|
testFileChunkDelivery2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelivery s r
|
|
|
|
runTestFileChunkDelivery :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
|
runTestFileChunkDelivery s r = do
|
|
g <- liftIO C.newRandom
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
bytes <- liftIO $ createTestChunk testChunkPath
|
|
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
|
let file = FileInfo {sndKey, size = chSize, digest}
|
|
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
|
(sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
|
|
uploadXFTPChunk s spKey sId chunkSpec
|
|
(sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey] Nothing
|
|
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"))
|
|
`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
|
|
|
|
testFileChunkDeliveryAddRecipients :: Expectation
|
|
testFileChunkDeliveryAddRecipients = xftpTest4 $ \s r1 r2 r3 -> runRight_ $ do
|
|
g <- liftIO C.newRandom
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey3, rpKey3) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
bytes <- liftIO $ createTestChunk testChunkPath
|
|
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
|
let file = FileInfo {sndKey, size = chSize, digest}
|
|
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
|
(sId, [rId1]) <- createXFTPChunk s spKey file [rcvKey1] Nothing
|
|
[rId2, rId3] <- addXFTPRecipients s spKey sId [rcvKey2, rcvKey3]
|
|
uploadXFTPChunk s spKey sId chunkSpec
|
|
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"
|
|
|
|
testFileChunkDelete :: Expectation
|
|
testFileChunkDelete = xftpTest $ \c -> runRight_ $ runTestFileChunkDelete c c
|
|
|
|
testFileChunkDelete2 :: Expectation
|
|
testFileChunkDelete2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkDelete s r
|
|
|
|
runTestFileChunkDelete :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
|
runTestFileChunkDelete s r = do
|
|
g <- liftIO C.newRandom
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
bytes <- liftIO $ createTestChunk testChunkPath
|
|
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
|
let file = FileInfo {sndKey, size = chSize, digest}
|
|
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
|
(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
|
|
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)
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
deleteXFTPChunk s spKey sId
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
|
|
testFileChunkAck :: Expectation
|
|
testFileChunkAck = xftpTest $ \c -> runRight_ $ runTestFileChunkAck c c
|
|
|
|
testFileChunkAck2 :: Expectation
|
|
testFileChunkAck2 = xftpTest2 $ \s r -> runRight_ $ runTestFileChunkAck s r
|
|
|
|
runTestFileChunkAck :: XFTPClient -> XFTPClient -> ExceptT XFTPClientError IO ()
|
|
runTestFileChunkAck s r = do
|
|
g <- liftIO C.newRandom
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
bytes <- liftIO $ createTestChunk testChunkPath
|
|
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
|
let file = FileInfo {sndKey, size = chSize, digest}
|
|
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
|
(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
|
|
ackXFTPChunk r rpKey rId
|
|
liftIO $ readChunk sId `shouldReturn` bytes
|
|
downloadXFTPChunk g r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
ackXFTPChunk r rpKey rId
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
|
|
testWrongChunkSize :: Expectation
|
|
testWrongChunkSize = xftpTest $ \c -> do
|
|
g <- C.newRandom
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey, _rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
B.writeFile testChunkPath =<< atomically (C.randomBytes (kb 96) g)
|
|
digest <- LC.sha256Hash <$> LB.readFile testChunkPath
|
|
let file = FileInfo {sndKey, size = kb 96, digest}
|
|
runRight_ $
|
|
void (createXFTPChunk c spKey file [rcvKey] Nothing)
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE))
|
|
|
|
testFileChunkExpiration :: Expectation
|
|
testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $
|
|
\_ -> testXFTPClient $ \c -> runRight_ $ do
|
|
g <- liftIO C.newRandom
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
bytes <- liftIO $ createTestChunk testChunkPath
|
|
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
|
let file = FileInfo {sndKey, size = chSize, digest}
|
|
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
|
(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
|
|
|
|
liftIO $ threadDelay 1000000
|
|
downloadXFTPChunk g c rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk2" chSize digest)
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
deleteXFTPChunk c spKey sId
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
where
|
|
fileExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
|
|
|
|
testInactiveClientExpiration :: Expectation
|
|
testInactiveClientExpiration = withXFTPServerCfg testXFTPServerConfig {inactiveClientExpiration} $ \_ -> runRight_ $ do
|
|
disconnected <- newEmptyTMVarIO
|
|
c <- liftIOEither $ getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> atomically $ putTMVar disconnected ())
|
|
pingXFTP c
|
|
liftIO $ do
|
|
threadDelay 100000
|
|
atomically (tryReadTMVar disconnected) `shouldReturn` Nothing
|
|
pingXFTP c
|
|
liftIO $ do
|
|
threadDelay 3000000
|
|
atomically (tryTakeTMVar disconnected) `shouldReturn` Just ()
|
|
where
|
|
inactiveClientExpiration = Just ExpirationConfig {ttl = 1, checkInterval = 1}
|
|
|
|
testFileStorageQuota :: Expectation
|
|
testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $
|
|
\_ -> testXFTPClient $ \c -> runRight_ $ do
|
|
g <- liftIO C.newRandom
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
bytes <- liftIO $ createTestChunk testChunkPath
|
|
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
|
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
|
|
(sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
|
uploadXFTPChunk c spKey sId1 chunkSpec
|
|
download rId1
|
|
(sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
|
uploadXFTPChunk c spKey sId2 chunkSpec
|
|
download rId2
|
|
|
|
(sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
|
uploadXFTPChunk c spKey sId3 chunkSpec
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA))
|
|
|
|
deleteXFTPChunk c spKey sId1
|
|
uploadXFTPChunk c spKey sId3 chunkSpec
|
|
download rId3
|
|
|
|
testFileLog :: Expectation
|
|
testFileLog = do
|
|
g <- C.newRandom
|
|
bytes <- liftIO $ createTestChunk testChunkPath
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey1, rpKey1) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey2, rpKey2) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath
|
|
sIdVar <- newTVarIO ""
|
|
rIdVar1 <- newTVarIO ""
|
|
rIdVar2 <- newTVarIO ""
|
|
|
|
threadDelay 100000
|
|
|
|
withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
|
|
let file = FileInfo {sndKey, size = chSize, digest}
|
|
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
|
(sId, [rId1, rId2]) <- createXFTPChunk c spKey file [rcvKey1, rcvKey2] Nothing
|
|
liftIO $
|
|
atomically $ do
|
|
writeTVar sIdVar sId
|
|
writeTVar rIdVar1 rId1
|
|
writeTVar rIdVar2 rId2
|
|
uploadXFTPChunk c spKey sId chunkSpec
|
|
download g c rpKey1 rId1 digest bytes
|
|
download g c rpKey2 rId2 digest bytes
|
|
logSize testXFTPLogFile `shouldReturn` 3
|
|
logSize testXFTPStatsBackupFile `shouldReturn` 14
|
|
|
|
threadDelay 100000
|
|
|
|
withXFTPServerThreadOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
|
|
sId <- liftIO $ readTVarIO sIdVar
|
|
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)
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
downloadXFTPChunk g c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest)
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
deleteXFTPChunk c spKey sId
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
|
|
threadDelay 100000
|
|
|
|
withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
|
|
rId1 <- liftIO $ readTVarIO rIdVar1
|
|
rId2 <- liftIO $ readTVarIO rIdVar2
|
|
-- recipient 1 can download, acknowledges - +1 to log
|
|
download g c rpKey1 rId1 digest bytes
|
|
ackXFTPChunk c rpKey1 rId1
|
|
-- recipient 2 can download
|
|
download g c rpKey2 rId2 digest bytes
|
|
logSize testXFTPLogFile `shouldReturn` 4
|
|
logSize testXFTPStatsBackupFile `shouldReturn` 14
|
|
|
|
threadDelay 100000
|
|
|
|
withXFTPServerStoreLogOn $ \_ -> pure () -- ack is compacted - -1 from log
|
|
logSize testXFTPLogFile `shouldReturn` 3
|
|
|
|
threadDelay 100000
|
|
|
|
withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do
|
|
sId <- liftIO $ readTVarIO sIdVar
|
|
rId1 <- liftIO $ readTVarIO rIdVar1
|
|
rId2 <- liftIO $ readTVarIO rIdVar2
|
|
-- recipient 1 can't download due to previous acknowledgement
|
|
download g c rpKey1 rId1 digest bytes
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|
|
-- recipient 2 can download
|
|
download g c rpKey2 rId2 digest bytes
|
|
-- sender can delete - +1 to log
|
|
deleteXFTPChunk c spKey sId
|
|
logSize testXFTPLogFile `shouldReturn` 4
|
|
logSize testXFTPStatsBackupFile `shouldReturn` 14
|
|
|
|
threadDelay 100000
|
|
|
|
withXFTPServerStoreLogOn $ \_ -> pure () -- compacts on start
|
|
logSize testXFTPLogFile `shouldReturn` 0
|
|
logSize testXFTPStatsBackupFile `shouldReturn` 14
|
|
|
|
threadDelay 100000
|
|
|
|
removeFile testXFTPLogFile
|
|
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
|
|
|
|
testFileBasicAuth :: Bool -> Maybe BasicAuth -> Maybe BasicAuth -> Bool -> IO ()
|
|
testFileBasicAuth allowNewFiles newFileBasicAuth clntAuth success =
|
|
withXFTPServerCfg testXFTPServerConfig {allowNewFiles, newFileBasicAuth} $
|
|
\_ -> testXFTPClient $ \c -> do
|
|
g <- C.newRandom
|
|
(sndKey, spKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
(rcvKey, rpKey) <- atomically $ C.generateAuthKeyPair C.SEd25519 g
|
|
bytes <- createTestChunk testChunkPath
|
|
digest <- LC.sha256Hash <$> LB.readFile testChunkPath
|
|
let file = FileInfo {sndKey, size = chSize, digest}
|
|
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
|
runRight_ $
|
|
if success
|
|
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
|
|
else do
|
|
void (createXFTPChunk c spKey file [rcvKey] clntAuth)
|
|
`catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH))
|