mirror of
https://github.com/simplex-chat/simplexmq.git
synced 2026-03-30 16:26:02 +00:00
xftp: sender file description (#647)
* xftp: sender file description * tests * check, info, tests * test * refactor * refactor, rename sender file --------- Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
This commit is contained in:
spaced4ndy
@@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@@ -28,7 +30,7 @@ import Options.Applicative
|
||||
import Simplex.FileTransfer.Client
|
||||
import Simplex.FileTransfer.Client.Agent
|
||||
import Simplex.FileTransfer.Description
|
||||
import Simplex.FileTransfer.Protocol (FileInfo (..))
|
||||
import Simplex.FileTransfer.Protocol
|
||||
import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import qualified Simplex.Messaging.Crypto.Lazy as LC
|
||||
@@ -175,8 +177,8 @@ data SentRecipientReplica = SentRecipientReplica
|
||||
{ chunkNo :: Int,
|
||||
server :: XFTPServer,
|
||||
rcvNo :: Int,
|
||||
rcvId :: ChunkReplicaId,
|
||||
rcvKey :: C.APrivateSignKey,
|
||||
replicaId :: ChunkReplicaId,
|
||||
replicaKey :: C.APrivateSignKey,
|
||||
digest :: FileDigest,
|
||||
chunkSize :: FileSize Word32
|
||||
}
|
||||
@@ -213,16 +215,20 @@ instance Encoding FileHeader where
|
||||
cliSendFile :: SendOptions -> ExceptT CLIError IO ()
|
||||
cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath} = do
|
||||
let (_, fileName) = splitFileName filePath
|
||||
(encPath, fd, chunkSpecs) <- encryptFile fileName
|
||||
(encPath, fdRcv, fdSnd, chunkSpecs) <- encryptFile fileName
|
||||
sentChunks <- uploadFile chunkSpecs
|
||||
whenM (doesFileExist encPath) $ removeFile encPath
|
||||
-- TODO if only small chunks, use different default size
|
||||
liftIO $ do
|
||||
fds <- writeFileDescriptions fileName $ createFileDescriptions fd sentChunks
|
||||
let fdRcvs = createRcvFileDescriptions fdRcv sentChunks
|
||||
fdSnd' = createSndFileDescription fdSnd sentChunks
|
||||
(fdRcvPaths, fdSndPath) <- writeFileDescriptions fileName fdRcvs fdSnd'
|
||||
putStrLn "File uploaded!\nPass file descriptions to the recipient(s):"
|
||||
forM_ fds putStrLn
|
||||
forM_ fdRcvPaths putStrLn
|
||||
putStrLn "Sender file description:"
|
||||
putStrLn fdSndPath
|
||||
where
|
||||
encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription, [XFTPChunkSpec])
|
||||
encryptFile :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FPRecipient, FileDescription 'FPSender, [XFTPChunkSpec])
|
||||
encryptFile fileName = do
|
||||
encPath <- getEncPath tempPath "xftp"
|
||||
key <- liftIO C.randomSbKey
|
||||
@@ -235,8 +241,9 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
|
||||
encrypt fileHdr key nonce fileSize' encSize encPath
|
||||
digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath
|
||||
let chunkSpecs = prepareChunkSpecs encPath chunkSizes
|
||||
fd = FileDescription {size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
|
||||
pure (encPath, fd, chunkSpecs)
|
||||
fdRcv = FileDescription {party = SRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
|
||||
fdSnd = FileDescription {party = SSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defaultChunkSize, chunks = []}
|
||||
pure (encPath, fdRcv, fdSnd, chunkSpecs)
|
||||
where
|
||||
encrypt :: ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT CLIError IO ()
|
||||
encrypt fileHdr key nonce fileSize' encSize encFile = do
|
||||
@@ -285,8 +292,8 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
|
||||
-- M chunks, R replicas, N recipients
|
||||
-- rcvReplicas: M[SentFileChunk] -> M * R * N [SentRecipientReplica]
|
||||
-- rcvChunks: M * R * N [SentRecipientReplica] -> N[ M[FileChunk] ]
|
||||
createFileDescriptions :: FileDescription -> [SentFileChunk] -> [FileDescription]
|
||||
createFileDescriptions fd sentChunks = map (\chunks -> (fd :: FileDescription) {chunks}) rcvChunks
|
||||
createRcvFileDescriptions :: FileDescription 'FPRecipient -> [SentFileChunk] -> [FileDescription 'FPRecipient]
|
||||
createRcvFileDescriptions fd sentChunks = map (\chunks -> (fd :: (FileDescription 'FPRecipient)) {chunks}) rcvChunks
|
||||
where
|
||||
rcvReplicas :: [SentRecipientReplica]
|
||||
rcvReplicas =
|
||||
@@ -294,7 +301,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
|
||||
( \SentFileChunk {chunkNo, digest, chunkSize, replicas} ->
|
||||
concatMap
|
||||
( \SentFileChunkReplica {server, recipients} ->
|
||||
zipWith (\rcvNo (rcvId, rcvKey) -> SentRecipientReplica {chunkNo, server, rcvNo, rcvId, rcvKey, digest, chunkSize}) [1 ..] recipients
|
||||
zipWith (\rcvNo (replicaId, replicaKey) -> SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize}) [1 ..] recipients
|
||||
)
|
||||
replicas
|
||||
)
|
||||
@@ -305,7 +312,7 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
|
||||
sortChunks = map reverseReplicas . sortOn (chunkNo :: FileChunk -> Int)
|
||||
reverseReplicas ch@FileChunk {replicas} = (ch :: FileChunk) {replicas = reverse replicas}
|
||||
addRcvChunk :: Map Int (Map Int FileChunk) -> SentRecipientReplica -> Map Int (Map Int FileChunk)
|
||||
addRcvChunk m SentRecipientReplica {chunkNo, server, rcvNo, rcvId, rcvKey, digest, chunkSize} =
|
||||
addRcvChunk m SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize} =
|
||||
M.alter (Just . addOrChangeRecipient) rcvNo m
|
||||
where
|
||||
addOrChangeRecipient :: Maybe (Map Int FileChunk) -> Map Int FileChunk
|
||||
@@ -316,38 +323,58 @@ cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryC
|
||||
addOrChangeChunk = \case
|
||||
Just ch@FileChunk {replicas} -> ch {replicas = replica : replicas}
|
||||
_ -> FileChunk {chunkNo, digest, chunkSize, replicas = [replica]}
|
||||
replica = FileChunkReplica {server, rcvId, rcvKey}
|
||||
writeFileDescriptions :: String -> [FileDescription] -> IO [FilePath]
|
||||
writeFileDescriptions fileName fds = do
|
||||
replica = FileChunkReplica {server, replicaId, replicaKey}
|
||||
createSndFileDescription :: FileDescription 'FPSender -> [SentFileChunk] -> FileDescription 'FPSender
|
||||
createSndFileDescription fd sentChunks = fd {chunks = sndChunks}
|
||||
where
|
||||
sndChunks :: [FileChunk]
|
||||
sndChunks =
|
||||
map
|
||||
( \SentFileChunk {chunkNo, sndId, sndPrivateKey, chunkSize, digest, replicas} ->
|
||||
FileChunk {chunkNo, digest, chunkSize, replicas = sndReplicas replicas (ChunkReplicaId sndId) sndPrivateKey}
|
||||
)
|
||||
sentChunks
|
||||
-- SentFileChunk having sndId and sndPrivateKey represents the current implementation's limitation
|
||||
-- that sender uploads each chunk only to one server, so we can use the first replica's server for FileChunkReplica
|
||||
sndReplicas :: [SentFileChunkReplica] -> ChunkReplicaId -> C.APrivateSignKey -> [FileChunkReplica]
|
||||
sndReplicas [] _ _ = []
|
||||
sndReplicas (SentFileChunkReplica {server} : _) replicaId replicaKey = [FileChunkReplica {server, replicaId, replicaKey}]
|
||||
writeFileDescriptions :: String -> [FileDescription 'FPRecipient] -> FileDescription 'FPSender -> IO ([FilePath], FilePath)
|
||||
writeFileDescriptions fileName fdRcvs fdSnd = do
|
||||
outDir <- uniqueCombine (fromMaybe "." outputDir) (fileName <> ".xftp")
|
||||
createDirectoryIfMissing True outDir
|
||||
forM (zip [1 ..] fds) $ \(i :: Int, fd) -> do
|
||||
fdRcvPaths <- forM (zip [1 ..] fdRcvs) $ \(i :: Int, fd) -> do
|
||||
let fdPath = outDir </> ("rcv" <> show i <> ".xftp")
|
||||
B.writeFile fdPath $ strEncode fd
|
||||
pure fdPath
|
||||
let fdSndPath = outDir </> "snd.xftp.private"
|
||||
B.writeFile fdSndPath $ strEncode fdSnd
|
||||
pure (fdRcvPaths, fdSndPath)
|
||||
|
||||
cliReceiveFile :: ReceiveOptions -> ExceptT CLIError IO ()
|
||||
cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} = do
|
||||
ValidFileDescription FileDescription {size, digest, key, nonce, chunks} <- getFileDescription fileDescription
|
||||
encPath <- getEncPath tempPath "xftp"
|
||||
createDirectory encPath
|
||||
a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
|
||||
chunkPaths <- forM chunks $ downloadFileChunk a encPath
|
||||
encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
|
||||
when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
|
||||
path <- decryptFile chunkPaths key nonce
|
||||
whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
|
||||
liftIO $ putStrLn $ "File received: " <> path
|
||||
cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath} =
|
||||
getFileDescription' fileDescription >>= receiveFile
|
||||
where
|
||||
receiveFile :: ValidFileDescription 'FPRecipient -> ExceptT CLIError IO ()
|
||||
receiveFile (ValidFileDescription FileDescription {digest, key, nonce, chunks}) = do
|
||||
encPath <- getEncPath tempPath "xftp"
|
||||
createDirectory encPath
|
||||
a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig
|
||||
chunkPaths <- forM chunks $ downloadFileChunk a encPath
|
||||
encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths
|
||||
when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch"
|
||||
path <- decryptFile chunkPaths key nonce
|
||||
whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath
|
||||
liftIO $ putStrLn $ "File received: " <> path
|
||||
retries :: Show e => ExceptT e IO a -> ExceptT CLIError IO a
|
||||
retries = withRetry retryCount . withExceptT (CLIError . show)
|
||||
downloadFileChunk :: XFTPClientAgent -> FilePath -> FileChunk -> ExceptT CLIError IO FilePath
|
||||
downloadFileChunk a encPath FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do
|
||||
let FileChunkReplica {server, rcvId, rcvKey} = replica
|
||||
let FileChunkReplica {server, replicaId, replicaKey} = replica
|
||||
chunkPath <- uniqueCombine encPath $ show chunkNo
|
||||
c <- retries $ getXFTPServerClient a server
|
||||
let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest)
|
||||
retries $ downloadXFTPChunk c rcvKey (unChunkReplicaId rcvId) chunkSpec
|
||||
retries $ downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec
|
||||
pure chunkPath
|
||||
downloadFileChunk _ _ _ = throwError $ CLIError "chunk has no replicas"
|
||||
decryptFile :: [FilePath] -> C.SbKey -> C.CbNonce -> ExceptT CLIError IO FilePath
|
||||
@@ -376,24 +403,36 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath}
|
||||
|
||||
cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO ()
|
||||
cliFileDescrInfo InfoOptions {fileDescription} = do
|
||||
ValidFileDescription FileDescription {size, chunkSize, chunks} <- getFileDescription fileDescription
|
||||
let replicas = groupReplicasByServer chunkSize chunks
|
||||
liftIO $ do
|
||||
putStrLn $ "File download size: " <> strEnc size
|
||||
putStrLn "File server(s):"
|
||||
forM_ replicas $ \srvReplicas -> do
|
||||
let srv = replicaServer $ head srvReplicas
|
||||
chSizes = map (\FileServerReplica {chunkSize = chSize_} -> unFileSize $ fromMaybe chunkSize chSize_) srvReplicas
|
||||
putStrLn $ strEnc srv <> ": " <> strEnc (FileSize $ sum chSizes)
|
||||
getFileDescription fileDescription >>= \case
|
||||
AVFD (ValidFileDescription FileDescription {party, size, chunkSize, chunks}) -> do
|
||||
let replicas = groupReplicasByServer chunkSize chunks
|
||||
liftIO $ do
|
||||
printParty
|
||||
putStrLn $ "File download size: " <> strEnc size
|
||||
putStrLn "File server(s):"
|
||||
forM_ replicas $ \srvReplicas -> do
|
||||
let srv = replicaServer $ head srvReplicas
|
||||
chSizes = map (\FileServerReplica {chunkSize = chSize_} -> unFileSize $ fromMaybe chunkSize chSize_) srvReplicas
|
||||
putStrLn $ strEnc srv <> ": " <> strEnc (FileSize $ sum chSizes)
|
||||
where
|
||||
printParty :: IO ()
|
||||
printParty = case party of
|
||||
SRecipient -> putStrLn "Recipient file description"
|
||||
SSender -> putStrLn "Sender file description"
|
||||
|
||||
strEnc :: StrEncoding a => a -> String
|
||||
strEnc = B.unpack . strEncode
|
||||
|
||||
getFileDescription :: FilePath -> ExceptT CLIError IO ValidFileDescription
|
||||
getFileDescription :: FilePath -> ExceptT CLIError IO AValidFileDescription
|
||||
getFileDescription path = do
|
||||
fd <- ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path
|
||||
liftEither . first CLIError $ validateFileDescription fd
|
||||
|
||||
getFileDescription' :: FilePartyI p => FilePath -> ExceptT CLIError IO (ValidFileDescription p)
|
||||
getFileDescription' path =
|
||||
getFileDescription path >>= \case
|
||||
AVFD fd -> either (throwError . CLIError) pure $ checkParty fd
|
||||
|
||||
prepareChunkSizes :: Int64 -> [Word32]
|
||||
prepareChunkSizes 0 = []
|
||||
prepareChunkSizes size
|
||||
|
||||
@@ -2,15 +2,21 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Simplex.FileTransfer.Description
|
||||
( FileDescription (..),
|
||||
ValidFileDescription,
|
||||
AFileDescription (..),
|
||||
ValidFileDescription, -- constructor is not exported, use pattern
|
||||
pattern ValidFileDescription,
|
||||
AValidFileDescription (..),
|
||||
FileDigest (..),
|
||||
FileChunk (..),
|
||||
FileChunkReplica (..),
|
||||
@@ -43,14 +49,16 @@ import Data.Maybe (fromMaybe)
|
||||
import Data.Word (Word32)
|
||||
import qualified Data.Yaml as Y
|
||||
import GHC.Generics (Generic)
|
||||
import Simplex.FileTransfer.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Protocol (XFTPServer)
|
||||
import Simplex.Messaging.Util (bshow, (<$?>))
|
||||
|
||||
data FileDescription = FileDescription
|
||||
{ size :: FileSize Int64,
|
||||
data FileDescription (p :: FileParty) = FileDescription
|
||||
{ party :: SFileParty p,
|
||||
size :: FileSize Int64,
|
||||
digest :: FileDigest,
|
||||
key :: C.SbKey,
|
||||
nonce :: C.CbNonce,
|
||||
@@ -59,11 +67,17 @@ data FileDescription = FileDescription
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype ValidFileDescription = ValidFD FileDescription
|
||||
data AFileDescription = forall p. FilePartyI p => AFD (FileDescription p)
|
||||
|
||||
pattern ValidFileDescription :: FileDescription -> ValidFileDescription
|
||||
newtype ValidFileDescription p = ValidFD (FileDescription p)
|
||||
|
||||
pattern ValidFileDescription :: FileDescription p -> ValidFileDescription p
|
||||
pattern ValidFileDescription fd = ValidFD fd
|
||||
|
||||
{-# COMPLETE ValidFileDescription #-}
|
||||
|
||||
data AValidFileDescription = forall p. FilePartyI p => AVFD (ValidFileDescription p)
|
||||
|
||||
newtype FileDigest = FileDigest {unFileDigest :: ByteString}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -89,8 +103,8 @@ data FileChunk = FileChunk
|
||||
|
||||
data FileChunkReplica = FileChunkReplica
|
||||
{ server :: XFTPServer,
|
||||
rcvId :: ChunkReplicaId,
|
||||
rcvKey :: C.APrivateSignKey
|
||||
replicaId :: ChunkReplicaId,
|
||||
replicaKey :: C.APrivateSignKey
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -109,7 +123,8 @@ instance ToJSON ChunkReplicaId where
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data YAMLFileDescription = YAMLFileDescription
|
||||
{ size :: String,
|
||||
{ party :: FileParty,
|
||||
size :: String,
|
||||
digest :: FileDigest,
|
||||
key :: C.SbKey,
|
||||
nonce :: C.CbNonce,
|
||||
@@ -135,31 +150,38 @@ instance ToJSON YAMLServerReplicas where
|
||||
data FileServerReplica = FileServerReplica
|
||||
{ chunkNo :: Int,
|
||||
server :: XFTPServer,
|
||||
rcvId :: ChunkReplicaId,
|
||||
rcvKey :: C.APrivateSignKey,
|
||||
replicaId :: ChunkReplicaId,
|
||||
replicaKey :: C.APrivateSignKey,
|
||||
digest :: Maybe FileDigest,
|
||||
chunkSize :: Maybe (FileSize Word32)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance StrEncoding FileDescription where
|
||||
instance FilePartyI p => StrEncoding (FileDescription p) where
|
||||
strEncode = Y.encode . encodeFileDescription
|
||||
strDecode s = strDecode s >>= (\(AFD fd) -> checkParty fd)
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
|
||||
instance StrEncoding AFileDescription where
|
||||
strEncode (AFD fd) = strEncode fd
|
||||
strDecode = decodeFileDescription <=< first show . Y.decodeEither'
|
||||
strP = strDecode <$?> A.takeByteString
|
||||
|
||||
validateFileDescription :: FileDescription -> Either String ValidFileDescription
|
||||
validateFileDescription fd@FileDescription {size, chunks}
|
||||
| chunkNos /= [1 .. length chunks] = Left "chunk numbers are not sequential"
|
||||
| chunksSize chunks /= unFileSize size = Left "chunks total size is different than file size"
|
||||
| otherwise = Right $ ValidFD fd
|
||||
where
|
||||
chunkNos = map (chunkNo :: FileChunk -> Int) chunks
|
||||
chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
|
||||
validateFileDescription :: AFileDescription -> Either String AValidFileDescription
|
||||
validateFileDescription = \case
|
||||
AFD fd@FileDescription {size, chunks}
|
||||
| chunkNos /= [1 .. length chunks] -> Left "chunk numbers are not sequential"
|
||||
| chunksSize chunks /= unFileSize size -> Left "chunks total size is different than file size"
|
||||
| otherwise -> Right $ AVFD (ValidFD fd)
|
||||
where
|
||||
chunkNos = map (chunkNo :: FileChunk -> Int) chunks
|
||||
chunksSize = fromIntegral . foldl' (\s FileChunk {chunkSize} -> s + unFileSize chunkSize) 0
|
||||
|
||||
encodeFileDescription :: FileDescription -> YAMLFileDescription
|
||||
encodeFileDescription FileDescription {size, digest, key, nonce, chunkSize, chunks} =
|
||||
encodeFileDescription :: FileDescription p -> YAMLFileDescription
|
||||
encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSize, chunks} =
|
||||
YAMLFileDescription
|
||||
{ size = B.unpack $ strEncode size,
|
||||
{ party = toFileParty party,
|
||||
size = B.unpack $ strEncode size,
|
||||
digest,
|
||||
key,
|
||||
nonce,
|
||||
@@ -209,41 +231,42 @@ replicaServer :: FileServerReplica -> XFTPServer
|
||||
replicaServer = server
|
||||
|
||||
encodeServerReplica :: FileServerReplica -> ByteString
|
||||
encodeServerReplica FileServerReplica {chunkNo, rcvId, rcvKey, digest, chunkSize} =
|
||||
encodeServerReplica FileServerReplica {chunkNo, replicaId, replicaKey, digest, chunkSize} =
|
||||
bshow chunkNo
|
||||
<> ":"
|
||||
<> strEncode rcvId
|
||||
<> strEncode replicaId
|
||||
<> ":"
|
||||
<> strEncode rcvKey
|
||||
<> strEncode replicaKey
|
||||
<> maybe "" ((":" <>) . strEncode) digest
|
||||
<> maybe "" ((":" <>) . strEncode) chunkSize
|
||||
|
||||
serverReplicaP :: XFTPServer -> Parser FileServerReplica
|
||||
serverReplicaP server = do
|
||||
chunkNo <- A.decimal
|
||||
rcvId <- A.char ':' *> strP
|
||||
rcvKey <- A.char ':' *> strP
|
||||
replicaId <- A.char ':' *> strP
|
||||
replicaKey <- A.char ':' *> strP
|
||||
digest <- optional (A.char ':' *> strP)
|
||||
chunkSize <- optional (A.char ':' *> strP)
|
||||
pure FileServerReplica {chunkNo, server, rcvId, rcvKey, digest, chunkSize}
|
||||
pure FileServerReplica {chunkNo, server, replicaId, replicaKey, digest, chunkSize}
|
||||
|
||||
unfoldChunksToReplicas :: FileSize Word32 -> [FileChunk] -> [FileServerReplica]
|
||||
unfoldChunksToReplicas defChunkSize = concatMap chunkReplicas
|
||||
where
|
||||
chunkReplicas c@FileChunk {replicas} = zipWith (replicaToServerReplica c) [1 ..] replicas
|
||||
replicaToServerReplica :: FileChunk -> Int -> FileChunkReplica -> FileServerReplica
|
||||
replicaToServerReplica FileChunk {chunkNo, digest, chunkSize} replicaNo FileChunkReplica {server, rcvId, rcvKey} =
|
||||
replicaToServerReplica FileChunk {chunkNo, digest, chunkSize} replicaNo FileChunkReplica {server, replicaId, replicaKey} =
|
||||
let chunkSize' = if chunkSize /= defChunkSize && replicaNo == 1 then Just chunkSize else Nothing
|
||||
digest' = if replicaNo == 1 then Just digest else Nothing
|
||||
in FileServerReplica {chunkNo, server, rcvId, rcvKey, digest = digest', chunkSize = chunkSize'}
|
||||
in FileServerReplica {chunkNo, server, replicaId, replicaKey, digest = digest', chunkSize = chunkSize'}
|
||||
|
||||
decodeFileDescription :: YAMLFileDescription -> Either String FileDescription
|
||||
decodeFileDescription YAMLFileDescription {size, digest, key, nonce, chunkSize, replicas} = do
|
||||
decodeFileDescription :: YAMLFileDescription -> Either String AFileDescription
|
||||
decodeFileDescription YAMLFileDescription {party, size, digest, key, nonce, chunkSize, replicas} = do
|
||||
size' <- strDecode $ B.pack size
|
||||
chunkSize' <- strDecode $ B.pack chunkSize
|
||||
replicas' <- decodeFileParts replicas
|
||||
chunks <- foldReplicasToChunks chunkSize' replicas'
|
||||
pure FileDescription {size = size', digest, key, nonce, chunkSize = chunkSize', chunks}
|
||||
pure $ case aFileParty party of
|
||||
AFP party' -> AFD FileDescription {party = party', size = size', digest, key, nonce, chunkSize = chunkSize', chunks}
|
||||
where
|
||||
decodeFileParts = fmap concat . mapM decodeYAMLServerReplicas
|
||||
|
||||
@@ -275,15 +298,15 @@ foldReplicasToChunks defChunkSize fs = do
|
||||
foldChunks sd = foldl' (addReplica sd) (Right M.empty)
|
||||
addReplica :: (Map Int (FileSize Word32), Map Int FileDigest) -> Either String (Map Int FileChunk) -> FileServerReplica -> Either String (Map Int FileChunk)
|
||||
addReplica _ (Left e) _ = Left e
|
||||
addReplica (ms, md) (Right cs) FileServerReplica {chunkNo, server, rcvId, rcvKey} = do
|
||||
addReplica (ms, md) (Right cs) FileServerReplica {chunkNo, server, replicaId, replicaKey} = do
|
||||
case M.lookup chunkNo cs of
|
||||
Just chunk@FileChunk {replicas} ->
|
||||
let replica = FileChunkReplica {server, rcvId, rcvKey}
|
||||
let replica = FileChunkReplica {server, replicaId, replicaKey}
|
||||
in Right $ M.insert chunkNo ((chunk :: FileChunk) {replicas = replica : replicas}) cs
|
||||
_ -> do
|
||||
case M.lookup chunkNo md of
|
||||
Just digest' ->
|
||||
let replica = FileChunkReplica {server, rcvId, rcvKey}
|
||||
let replica = FileChunkReplica {server, replicaId, replicaKey}
|
||||
chunkSize' = fromMaybe defChunkSize $ M.lookup chunkNo ms
|
||||
chunk = FileChunk {chunkNo, digest = digest', chunkSize = chunkSize', replicas = [replica]}
|
||||
in Right $ M.insert chunkNo chunk cs
|
||||
|
||||
@@ -13,6 +13,8 @@
|
||||
|
||||
module Simplex.FileTransfer.Protocol where
|
||||
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
@@ -27,6 +29,7 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Transport (ntfClientHandshake)
|
||||
import Simplex.Messaging.Parsers
|
||||
import Simplex.Messaging.Protocol
|
||||
( CommandError (..),
|
||||
Protocol (..),
|
||||
@@ -61,34 +64,55 @@ xftpBlockSize :: Int
|
||||
xftpBlockSize = 16384
|
||||
|
||||
-- | File protocol clients
|
||||
data FileParty = Recipient | Sender
|
||||
deriving (Show)
|
||||
data FileParty = FPRecipient | FPSender
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromJSON FileParty where
|
||||
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "FP"
|
||||
|
||||
instance ToJSON FileParty where
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "FP"
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "FP"
|
||||
|
||||
data SFileParty :: FileParty -> Type where
|
||||
SRecipient :: SFileParty Recipient
|
||||
SSender :: SFileParty Sender
|
||||
SRecipient :: SFileParty FPRecipient
|
||||
SSender :: SFileParty FPSender
|
||||
|
||||
instance TestEquality SFileParty where
|
||||
testEquality SRecipient SRecipient = Just Refl
|
||||
testEquality SSender SSender = Just Refl
|
||||
testEquality _ _ = Nothing
|
||||
|
||||
deriving instance Eq (SFileParty p)
|
||||
|
||||
deriving instance Show (SFileParty p)
|
||||
|
||||
data AFileParty = forall p. FilePartyI p => AFP (SFileParty p)
|
||||
|
||||
toFileParty :: SFileParty p -> FileParty
|
||||
toFileParty = \case
|
||||
SRecipient -> FPRecipient
|
||||
SSender -> FPSender
|
||||
|
||||
aFileParty :: FileParty -> AFileParty
|
||||
aFileParty = \case
|
||||
FPRecipient -> AFP SRecipient
|
||||
FPSender -> AFP SSender
|
||||
|
||||
class FilePartyI (p :: FileParty) where sFileParty :: SFileParty p
|
||||
|
||||
instance FilePartyI Recipient where sFileParty = SRecipient
|
||||
instance FilePartyI FPRecipient where sFileParty = SRecipient
|
||||
|
||||
instance FilePartyI Sender where sFileParty = SSender
|
||||
instance FilePartyI FPSender where sFileParty = SSender
|
||||
|
||||
data FileCommandTag (p :: FileParty) where
|
||||
FNEW_ :: FileCommandTag Sender
|
||||
FADD_ :: FileCommandTag Sender
|
||||
FPUT_ :: FileCommandTag Sender
|
||||
FDEL_ :: FileCommandTag Sender
|
||||
FGET_ :: FileCommandTag Recipient
|
||||
FACK_ :: FileCommandTag Recipient
|
||||
PING_ :: FileCommandTag Recipient
|
||||
FNEW_ :: FileCommandTag FPSender
|
||||
FADD_ :: FileCommandTag FPSender
|
||||
FPUT_ :: FileCommandTag FPSender
|
||||
FDEL_ :: FileCommandTag FPSender
|
||||
FGET_ :: FileCommandTag FPRecipient
|
||||
FACK_ :: FileCommandTag FPRecipient
|
||||
PING_ :: FileCommandTag FPRecipient
|
||||
|
||||
deriving instance Show (FileCommandTag p)
|
||||
|
||||
@@ -133,13 +157,13 @@ instance Protocol XFTPErrorType FileResponse where
|
||||
_ -> Nothing
|
||||
|
||||
data FileCommand (p :: FileParty) where
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand Sender
|
||||
FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender
|
||||
FPUT :: FileCommand Sender
|
||||
FDEL :: FileCommand Sender
|
||||
FGET :: RcvPublicDhKey -> FileCommand Recipient
|
||||
FACK :: FileCommand Recipient
|
||||
PING :: FileCommand Recipient
|
||||
FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
|
||||
FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FPSender
|
||||
FPUT :: FileCommand FPSender
|
||||
FDEL :: FileCommand FPSender
|
||||
FGET :: RcvPublicDhKey -> FileCommand FPRecipient
|
||||
FACK :: FileCommand FPRecipient
|
||||
PING :: FileCommand FPRecipient
|
||||
|
||||
deriving instance Show (FileCommand p)
|
||||
|
||||
@@ -357,7 +381,7 @@ instance Encoding XFTPErrorType where
|
||||
checkParty :: forall t p p'. (FilePartyI p, FilePartyI p') => t p' -> Either String (t p)
|
||||
checkParty c = case testEquality (sFileParty @p) (sFileParty @p') of
|
||||
Just Refl -> Right c
|
||||
Nothing -> Left "bad command party"
|
||||
Nothing -> Left "incorrect XFTP party"
|
||||
|
||||
checkParty' :: forall t p p'. (FilePartyI p, FilePartyI p') => t p' -> Maybe (t p)
|
||||
checkParty' c = case testEquality (sFileParty @p) (sFileParty @p') of
|
||||
|
||||
@@ -167,7 +167,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, (<$?>))
|
||||
import Simplex.Messaging.Util (bshow, (<$?>), eitherToMaybe)
|
||||
import Simplex.Messaging.Version
|
||||
import Test.QuickCheck (Arbitrary (..))
|
||||
|
||||
@@ -1153,9 +1153,7 @@ checkParty c = case testEquality (sParty @p) (sParty @p') of
|
||||
Nothing -> Left "bad command party"
|
||||
|
||||
checkParty' :: forall t p p'. (PartyI p, PartyI p') => t p' -> Maybe (t p)
|
||||
checkParty' c = case testEquality (sParty @p) (sParty @p') of
|
||||
Just Refl -> Just c
|
||||
_ -> Nothing
|
||||
checkParty' = eitherToMaybe . checkParty
|
||||
|
||||
instance Encoding ErrorType where
|
||||
smpEncode = \case
|
||||
|
||||
@@ -10,6 +10,7 @@ import Control.Exception (bracket_)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.Yaml as Y
|
||||
import Simplex.FileTransfer.Description
|
||||
import Simplex.FileTransfer.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String (StrEncoding (..))
|
||||
import System.Directory (removeFile)
|
||||
@@ -38,10 +39,11 @@ testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTF
|
||||
testCbNonce :: C.CbNonce
|
||||
testCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu"
|
||||
|
||||
fileDesc :: FileDescription
|
||||
fileDesc :: FileDescription 'FPRecipient
|
||||
fileDesc =
|
||||
FileDescription
|
||||
{ size = FileSize $ 26 * mb,
|
||||
{ party = SRecipient,
|
||||
size = FileSize $ 26 * mb,
|
||||
digest = FileDigest "abc",
|
||||
key = testSbKey,
|
||||
nonce = testCbNonce,
|
||||
@@ -52,8 +54,8 @@ fileDesc =
|
||||
digest = chunkDigest,
|
||||
chunkSize = defaultChunkSize,
|
||||
replicas =
|
||||
[ FileChunkReplica {server = "xftp://abc=@example1.com", rcvId, rcvKey},
|
||||
FileChunkReplica {server = "xftp://abc=@example3.com", rcvId, rcvKey}
|
||||
[ FileChunkReplica {server = "xftp://abc=@example1.com", replicaId, replicaKey},
|
||||
FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey}
|
||||
]
|
||||
},
|
||||
FileChunk
|
||||
@@ -61,8 +63,8 @@ fileDesc =
|
||||
digest = chunkDigest,
|
||||
chunkSize = defaultChunkSize,
|
||||
replicas =
|
||||
[ FileChunkReplica {server = "xftp://abc=@example2.com", rcvId, rcvKey},
|
||||
FileChunkReplica {server = "xftp://abc=@example4.com", rcvId, rcvKey}
|
||||
[ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey},
|
||||
FileChunkReplica {server = "xftp://abc=@example4.com", replicaId, replicaKey}
|
||||
]
|
||||
},
|
||||
FileChunk
|
||||
@@ -70,8 +72,8 @@ fileDesc =
|
||||
digest = chunkDigest,
|
||||
chunkSize = defaultChunkSize,
|
||||
replicas =
|
||||
[ FileChunkReplica {server = "xftp://abc=@example1.com", rcvId, rcvKey},
|
||||
FileChunkReplica {server = "xftp://abc=@example4.com", rcvId, rcvKey}
|
||||
[ FileChunkReplica {server = "xftp://abc=@example1.com", replicaId, replicaKey},
|
||||
FileChunkReplica {server = "xftp://abc=@example4.com", replicaId, replicaKey}
|
||||
]
|
||||
},
|
||||
FileChunk
|
||||
@@ -79,22 +81,23 @@ fileDesc =
|
||||
digest = chunkDigest,
|
||||
chunkSize = FileSize $ 2 * mb,
|
||||
replicas =
|
||||
[ FileChunkReplica {server = "xftp://abc=@example2.com", rcvId, rcvKey},
|
||||
FileChunkReplica {server = "xftp://abc=@example3.com", rcvId, rcvKey}
|
||||
[ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey},
|
||||
FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey}
|
||||
]
|
||||
}
|
||||
]
|
||||
}
|
||||
where
|
||||
defaultChunkSize = FileSize $ 8 * mb
|
||||
rcvId = ChunkReplicaId "abc"
|
||||
rcvKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
|
||||
replicaId = ChunkReplicaId "abc"
|
||||
replicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe"
|
||||
chunkDigest = FileDigest "ghi"
|
||||
|
||||
yamlFileDesc :: YAMLFileDescription
|
||||
yamlFileDesc =
|
||||
YAMLFileDescription
|
||||
{ size = "26mb",
|
||||
{ party = FPRecipient,
|
||||
size = "26mb",
|
||||
chunkSize = "8mb",
|
||||
digest = FileDigest "abc",
|
||||
key = testSbKey,
|
||||
|
||||
@@ -39,17 +39,28 @@ testXFTPCLISendReceive = withXFTPServer $ do
|
||||
xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
|
||||
file <- LB.readFile filePath
|
||||
getFileSize filePath `shouldReturn` 19 * mb
|
||||
let fd1 = filePath <> ".xftp" </> "rcv1.xftp"
|
||||
fd2 = filePath <> ".xftp" </> "rcv2.xftp"
|
||||
let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
|
||||
fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
|
||||
fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
|
||||
xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"]
|
||||
`shouldReturn` ["File uploaded!", "Pass file descriptions to the recipient(s):", fd1, fd2]
|
||||
testReceiveFile fd1 "testfile" file
|
||||
testReceiveFile fd2 "testfile_1" file
|
||||
`shouldReturn` [ "File uploaded!",
|
||||
"Pass file descriptions to the recipient(s):",
|
||||
fdRcv1,
|
||||
fdRcv2,
|
||||
"Sender file description:",
|
||||
fdSnd
|
||||
]
|
||||
testInfoFile fdRcv1 "Recipient"
|
||||
testReceiveFile fdRcv1 "testfile" file
|
||||
testInfoFile fdRcv2 "Recipient"
|
||||
testReceiveFile fdRcv2 "testfile_1" file
|
||||
testInfoFile fdSnd "Sender"
|
||||
where
|
||||
xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
|
||||
testReceiveFile fd fileName file = do
|
||||
testInfoFile fd party = do
|
||||
xftp ["info", fd]
|
||||
`shouldReturn` ["File download size: 20mb", "File server(s):", testXFTPServerStr <> ": 20mb"]
|
||||
`shouldReturn` [party <> " file description", "File download size: 20mb", "File server(s):", testXFTPServerStr <> ": 20mb"]
|
||||
testReceiveFile fd fileName file = do
|
||||
xftp ["recv", fd, recipientFiles, "--tmp=tests/tmp"]
|
||||
`shouldReturn` ["File received: " <> recipientFiles </> fileName]
|
||||
LB.readFile (recipientFiles </> fileName) `shouldReturn` file
|
||||
@@ -60,16 +71,24 @@ testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do
|
||||
xftp ["rand", filePath, "19mb"] `shouldReturn` ["File created: " <> filePath]
|
||||
file <- LB.readFile filePath
|
||||
getFileSize filePath `shouldReturn` 19 * mb
|
||||
let fd1 = filePath <> ".xftp" </> "rcv1.xftp"
|
||||
fd2 = filePath <> ".xftp" </> "rcv2.xftp"
|
||||
let fdRcv1 = filePath <> ".xftp" </> "rcv1.xftp"
|
||||
fdRcv2 = filePath <> ".xftp" </> "rcv2.xftp"
|
||||
fdSnd = filePath <> ".xftp" </> "snd.xftp.private"
|
||||
xftp ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"]
|
||||
`shouldReturn` ["File uploaded!", "Pass file descriptions to the recipient(s):", fd1, fd2]
|
||||
testReceiveFile fd1 "testfile" file
|
||||
testReceiveFile fd2 "testfile_1" file
|
||||
`shouldReturn` [ "File uploaded!",
|
||||
"Pass file descriptions to the recipient(s):",
|
||||
fdRcv1,
|
||||
fdRcv2,
|
||||
"Sender file description:",
|
||||
fdSnd
|
||||
]
|
||||
testReceiveFile fdRcv1 "testfile" file
|
||||
testReceiveFile fdRcv2 "testfile_1" file
|
||||
where
|
||||
xftp params = lines <$> capture_ (withArgs params xftpClientCLI)
|
||||
testReceiveFile fd fileName file = do
|
||||
sizeStr : srvStr : srvs <- xftp ["info", fd]
|
||||
partyStr : sizeStr : srvStr : srvs <- xftp ["info", fd]
|
||||
partyStr `shouldContain` "Recipient file description"
|
||||
sizeStr `shouldBe` "File download size: 20mb"
|
||||
srvStr `shouldBe` "File server(s):"
|
||||
case srvs of
|
||||
|
||||
1
tests/fixtures/file_description.yaml
vendored
1
tests/fixtures/file_description.yaml
vendored
@@ -2,6 +2,7 @@ chunkSize: 8mb
|
||||
digest: YWJj
|
||||
key: 00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY=
|
||||
nonce: dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu
|
||||
party: recipient
|
||||
replicas:
|
||||
- chunks:
|
||||
- 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp
|
||||
|
||||
Reference in New Issue
Block a user