mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-05-25 03:45:23 +00:00
xftp: add basic auth (#653)
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
202922bceb
commit
8c8a984c1c
@@ -33,7 +33,8 @@ import Simplex.Messaging.Client
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Protocol
|
||||
( Protocol (..),
|
||||
( BasicAuth,
|
||||
Protocol (..),
|
||||
ProtocolServer (..),
|
||||
RecipientId,
|
||||
SenderId,
|
||||
@@ -128,9 +129,10 @@ createXFTPChunk ::
|
||||
C.APrivateSignKey ->
|
||||
FileInfo ->
|
||||
NonEmpty C.APublicVerifyKey ->
|
||||
Maybe BasicAuth ->
|
||||
ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId)
|
||||
createXFTPChunk c spKey file rsps =
|
||||
sendXFTPCommand c spKey "" (FNEW file rsps) Nothing >>= \case
|
||||
createXFTPChunk c spKey file rsps auth_ =
|
||||
sendXFTPCommand c spKey "" (FNEW file rsps auth_) Nothing >>= \case
|
||||
(FRSndIds sId rIds, body) -> noFile body (sId, rIds)
|
||||
(r, _) -> throwError . PCEUnexpectedResponse $ bshow r
|
||||
|
||||
|
||||
@@ -37,7 +37,7 @@ import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Protocol (SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer)
|
||||
import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer, XFTPServerWithAuth)
|
||||
import Simplex.Messaging.Server.CLI (getCliCommand')
|
||||
import Simplex.Messaging.Util (ifM, whenM)
|
||||
import System.Exit (exitFailure)
|
||||
@@ -79,7 +79,7 @@ data SendOptions = SendOptions
|
||||
{ filePath :: FilePath,
|
||||
outputDir :: Maybe FilePath,
|
||||
numRecipients :: Int,
|
||||
xftpServers :: [XFTPServer],
|
||||
xftpServers :: [XFTPServerWithAuth],
|
||||
retryCount :: Int,
|
||||
tempPath :: Maybe FilePath
|
||||
}
|
||||
@@ -113,7 +113,7 @@ data RandomFileOptions = RandomFileOptions
|
||||
defaultRetryCount :: Int
|
||||
defaultRetryCount = 3
|
||||
|
||||
defaultXFTPServers :: NonEmpty XFTPServer
|
||||
defaultXFTPServers :: NonEmpty XFTPServerWithAuth
|
||||
defaultXFTPServers = L.fromList ["xftp://vr0bXzm4iKkLvleRMxLznTS-lHjXEyXunxn_7VJckk4=@localhost:443"]
|
||||
|
||||
cliCommandP :: Parser CliCommand
|
||||
@@ -275,14 +275,14 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
|
||||
-- TODO unshuffle chunks
|
||||
pure $ map snd sentChunks
|
||||
where
|
||||
uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServer -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
|
||||
uploadFileChunk :: XFTPClientAgent -> TVar StdGen -> NonEmpty XFTPServerWithAuth -> (Int, XFTPChunkSpec) -> ExceptT CLIError IO (Int, SentFileChunk)
|
||||
uploadFileChunk a gen srvs (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}) = do
|
||||
(sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
|
||||
rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519)
|
||||
chInfo@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec
|
||||
xftpServer <- liftIO $ getXFTPServer gen srvs
|
||||
ProtoServerWithAuth xftpServer auth <- liftIO $ getXFTPServer gen srvs
|
||||
c <- withRetry retryCount $ getXFTPServerClient a xftpServer
|
||||
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo $ L.map fst rKeys
|
||||
(sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey chInfo (L.map fst rKeys) auth
|
||||
withRetry retryCount $ uploadXFTPChunk c spKey sndId chunkSpec
|
||||
let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys
|
||||
replicas = [SentFileChunkReplica {server = xftpServer, recipients}]
|
||||
@@ -293,7 +293,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
|
||||
hSeek h AbsoluteSeek $ fromIntegral chunkOffset
|
||||
digest <- LC.sha512Hash <$> LB.hGet h (fromIntegral chunkSize)
|
||||
pure FileInfo {sndKey, size = fromIntegral chunkSize, digest}
|
||||
getXFTPServer :: TVar StdGen -> NonEmpty XFTPServer -> IO XFTPServer
|
||||
getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth
|
||||
getXFTPServer gen = \case
|
||||
srv :| [] -> pure srv
|
||||
servers -> do
|
||||
|
||||
@@ -31,7 +31,8 @@ import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol
|
||||
( CommandError (..),
|
||||
( BasicAuth,
|
||||
CommandError (..),
|
||||
Protocol (..),
|
||||
ProtocolEncoding (..),
|
||||
ProtocolErrorType (..),
|
||||
@@ -157,7 +158,7 @@ instance Protocol XFTPErrorType FileResponse where
|
||||
_ -> Nothing
|
||||
|
||||
data FileCommand (p :: FileParty) where
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FPSender
|
||||
FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
|
||||
FPUT :: FileCommand FPSender
|
||||
FDEL :: FileCommand FPSender
|
||||
@@ -183,7 +184,7 @@ type XFTPFileId = ByteString
|
||||
instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where
|
||||
type Tag (FileCommand p) = FileCommandTag p
|
||||
encodeProtocol _v = \case
|
||||
FNEW file rKeys -> e (FNEW_, ' ', file, rKeys)
|
||||
FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_)
|
||||
FADD rKeys -> e (FADD_, ' ', rKeys)
|
||||
FPUT -> e FPUT_
|
||||
FDEL -> e FDEL_
|
||||
@@ -220,7 +221,7 @@ instance ProtocolEncoding XFTPErrorType FileCmd where
|
||||
protocolP _v = \case
|
||||
FCT SSender tag ->
|
||||
FileCmd SSender <$> case tag of
|
||||
FNEW_ -> FNEW <$> _smpP <*> smpP
|
||||
FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP
|
||||
FADD_ -> FADD <$> _smpP
|
||||
FPUT_ -> pure FPUT
|
||||
FDEL_ -> pure FDEL
|
||||
|
||||
@@ -24,6 +24,7 @@ import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.List (intercalate)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
@@ -42,7 +43,7 @@ import Simplex.FileTransfer.Transport
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RecipientId)
|
||||
import Simplex.Messaging.Protocol (CorrId, RcvPublicDhKey, RcvPublicVerifyKey, RecipientId)
|
||||
import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature)
|
||||
import Simplex.Messaging.Server.Expiration
|
||||
import Simplex.Messaging.Server.Stats
|
||||
@@ -196,7 +197,7 @@ data VerificationResult = VRVerified XFTPRequest | VRFailed
|
||||
verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult
|
||||
verifyXFTPTransmission sig_ signed fId cmd =
|
||||
case cmd of
|
||||
FileCmd SSender (FNEW file rcps) -> pure $ XFTPReqNew file rcps `verifyWith` sndKey file
|
||||
FileCmd SSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file
|
||||
FileCmd SRecipient PING -> pure $ VRVerified XFTPReqPing
|
||||
FileCmd party _ -> verifyCmd party
|
||||
where
|
||||
@@ -212,34 +213,45 @@ verifyXFTPTransmission sig_ signed fId cmd =
|
||||
|
||||
processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile)
|
||||
processXFTPRequest HTTP2Body {bodyPart} = \case
|
||||
XFTPReqNew file rcps -> do
|
||||
st <- asks store
|
||||
-- TODO validate body empty
|
||||
-- TODO retry on duplicate IDs?
|
||||
sId <- getFileId
|
||||
rIds <- mapM (const getFileId) rcps
|
||||
let rIdsKeys = L.zipWith FileRecipient rIds rcps
|
||||
ts <- liftIO getSystemTime
|
||||
withFileLog $ \sl -> do
|
||||
logAddFile sl sId file ts
|
||||
logAddRecipients sl sId rIdsKeys
|
||||
r <- runExceptT $ do
|
||||
ExceptT $ atomically $ addFile st sId file ts
|
||||
forM rIdsKeys $ \rcp ->
|
||||
ExceptT $ atomically $ addRecipient st sId rcp
|
||||
noFile $ either FRErr (const $ FRSndIds sId rIds) r
|
||||
XFTPReqNew file rcps auth ->
|
||||
noFile
|
||||
=<< ifM
|
||||
allowNew
|
||||
(createFile file rcps)
|
||||
(pure $ FRErr AUTH)
|
||||
where
|
||||
allowNew = do
|
||||
XFTPServerConfig {allowNewFiles, newFileBasicAuth} <- asks config
|
||||
pure $ allowNewFiles && maybe True ((== auth) . Just) newFileBasicAuth
|
||||
XFTPReqCmd fId fr (FileCmd _ cmd) -> case cmd of
|
||||
FADD _rcps -> noFile FROk
|
||||
FPUT -> (,Nothing) <$> receiveServerFile fr
|
||||
FDEL -> (,Nothing) <$> deleteServerFile fr
|
||||
FPUT -> noFile =<< receiveServerFile fr
|
||||
FDEL -> noFile =<< deleteServerFile fr
|
||||
FGET rDhKey -> sendServerFile fr rDhKey
|
||||
FACK -> (,Nothing) <$> ackFileReception fId fr
|
||||
-- it should never get to the options below, they are passed in other constructors of XFTPRequest
|
||||
FNEW _ _ -> noFile $ FRErr INTERNAL
|
||||
FACK -> noFile =<< ackFileReception fId fr
|
||||
-- it should never get to the commands below, they are passed in other constructors of XFTPRequest
|
||||
FNEW {} -> noFile $ FRErr INTERNAL
|
||||
PING -> noFile FRPong
|
||||
XFTPReqPing -> noFile FRPong
|
||||
where
|
||||
noFile resp = pure (resp, Nothing)
|
||||
createFile :: FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse
|
||||
createFile file rcps = do
|
||||
st <- asks store
|
||||
-- TODO validate body empty
|
||||
-- TODO retry on duplicate IDs?
|
||||
sId <- getFileId
|
||||
rIds <- mapM (const getFileId) rcps
|
||||
let rIdsKeys = L.zipWith FileRecipient rIds rcps
|
||||
ts <- liftIO getSystemTime
|
||||
withFileLog $ \sl -> do
|
||||
logAddFile sl sId file ts
|
||||
logAddRecipients sl sId rIdsKeys
|
||||
r <- runExceptT $ do
|
||||
ExceptT $ atomically $ addFile st sId file ts
|
||||
forM rIdsKeys $ \rcp ->
|
||||
ExceptT $ atomically $ addRecipient st sId rcp
|
||||
pure $ either FRErr (const $ FRSndIds sId rIds) r
|
||||
receiveServerFile :: FileRec -> M FileResponse
|
||||
receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of
|
||||
-- TODO do not allow repeated file upload
|
||||
|
||||
@@ -87,6 +87,6 @@ newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertifi
|
||||
pure XFTPEnv {config, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats}
|
||||
|
||||
data XFTPRequest
|
||||
= XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey)
|
||||
= XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth)
|
||||
| XFTPReqCmd XFTPFileId FileRec FileCmd
|
||||
| XFTPReqPing
|
||||
|
||||
@@ -76,6 +76,7 @@ module Simplex.Messaging.Protocol
|
||||
pattern NtfServer,
|
||||
XFTPServer,
|
||||
pattern XFTPServer,
|
||||
XFTPServerWithAuth,
|
||||
ProtoServerWithAuth (..),
|
||||
BasicAuth (..),
|
||||
SrvLoc (..),
|
||||
@@ -167,7 +168,7 @@ import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Transport
|
||||
import Simplex.Messaging.Transport.Client (TransportHost, TransportHosts (..))
|
||||
import Simplex.Messaging.Util (bshow, (<$?>), eitherToMaybe)
|
||||
import Simplex.Messaging.Util (bshow, eitherToMaybe, (<$?>))
|
||||
import Simplex.Messaging.Version
|
||||
import Test.QuickCheck (Arbitrary (..))
|
||||
|
||||
@@ -632,6 +633,8 @@ pattern XFTPServer host port keyHash = ProtocolServer SPXFTP host port keyHash
|
||||
|
||||
{-# COMPLETE XFTPServer #-}
|
||||
|
||||
type XFTPServerWithAuth = ProtoServerWithAuth 'PXFTP
|
||||
|
||||
sameSrvAddr' :: ProtoServerWithAuth p -> ProtoServerWithAuth p -> Bool
|
||||
sameSrvAddr' (ProtoServerWithAuth srv _) (ProtoServerWithAuth srv' _) = sameSrvAddr srv srv'
|
||||
{-# INLINE sameSrvAddr' #-}
|
||||
|
||||
+37
-10
@@ -25,7 +25,7 @@ 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 (SenderId)
|
||||
import Simplex.Messaging.Protocol (BasicAuth, SenderId)
|
||||
import Simplex.Messaging.Server.Expiration (ExpirationConfig (..))
|
||||
import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile)
|
||||
import System.FilePath ((</>))
|
||||
@@ -47,6 +47,13 @@ xftpServerTests =
|
||||
it "should expire chunks after set interval" testFileChunkExpiration
|
||||
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 :: Num n => n
|
||||
chSize = 128 * 1024
|
||||
@@ -77,9 +84,9 @@ runTestFileChunkDelivery s r = do
|
||||
digest <- liftIO $ LC.sha512Hash <$> 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]
|
||||
(sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk s spKey sId chunkSpec
|
||||
(sId', _) <- createXFTPChunk s spKey file {digest = digest <> "_wrong"} [rcvKey]
|
||||
(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
|
||||
@@ -102,7 +109,7 @@ runTestFileChunkDelete s r = do
|
||||
digest <- liftIO $ LC.sha512Hash <$> 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]
|
||||
(sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk s spKey sId chunkSpec
|
||||
|
||||
downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
@@ -130,7 +137,7 @@ runTestFileChunkAck s r = do
|
||||
digest <- liftIO $ LC.sha512Hash <$> 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]
|
||||
(sId, [rId]) <- createXFTPChunk s spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk s spKey sId chunkSpec
|
||||
|
||||
downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
@@ -151,7 +158,7 @@ testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration
|
||||
digest <- liftIO $ LC.sha512Hash <$> 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]
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId chunkSpec
|
||||
|
||||
downloadXFTPChunk c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest
|
||||
@@ -177,14 +184,14 @@ testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = J
|
||||
download rId = do
|
||||
downloadXFTPChunk 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]
|
||||
(sId1, [rId1]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId1 chunkSpec
|
||||
download rId1
|
||||
(sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey]
|
||||
(sId2, [rId2]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId2 chunkSpec
|
||||
download rId2
|
||||
|
||||
(sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey]
|
||||
(sId3, [rId3]) <- createXFTPChunk c spKey file [rcvKey] Nothing
|
||||
uploadXFTPChunk c spKey sId3 chunkSpec
|
||||
`catchError` (liftIO . (`shouldBe` PCEProtocolError QUOTA))
|
||||
|
||||
@@ -207,7 +214,7 @@ testFileLog = 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]
|
||||
(sId, [rId1, rId2]) <- createXFTPChunk c spKey file [rcvKey1, rcvKey2] Nothing
|
||||
liftIO $
|
||||
atomically $ do
|
||||
writeTVar sIdVar sId
|
||||
@@ -255,3 +262,23 @@ testFileLog = do
|
||||
download c rpKey rId digest bytes = do
|
||||
downloadXFTPChunk 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 -> runRight_ $ do
|
||||
(sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
|
||||
(rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519
|
||||
bytes <- liftIO $ createTestChunk testChunkPath
|
||||
digest <- liftIO $ LC.sha512Hash <$> LB.readFile testChunkPath
|
||||
let file = FileInfo {sndKey, size = chSize, digest}
|
||||
chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize}
|
||||
if success
|
||||
then do
|
||||
(sId, [rId]) <- createXFTPChunk c spKey file [rcvKey] clntAuth
|
||||
uploadXFTPChunk c spKey sId chunkSpec
|
||||
downloadXFTPChunk 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))
|
||||
|
||||
Reference in New Issue
Block a user