diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs index 4e74a5659..20e5bd7f9 100644 --- a/src/Simplex/FileTransfer/Client/Main.hs +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs index c4cdc5d6e..289d716c3 100644 --- a/src/Simplex/FileTransfer/Description.hs +++ b/src/Simplex/FileTransfer/Description.hs @@ -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 diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs index 56fd9be32..bc1cdb17b 100644 --- a/src/Simplex/FileTransfer/Protocol.hs +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 4bba022ad..998c1c66a 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -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 diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs index b8fa62da9..f8425ce44 100644 --- a/tests/FileDescriptionTests.hs +++ b/tests/FileDescriptionTests.hs @@ -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, diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs index 5897c4b0b..0a53aa9cd 100644 --- a/tests/XFTPCLI.hs +++ b/tests/XFTPCLI.hs @@ -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 diff --git a/tests/fixtures/file_description.yaml b/tests/fixtures/file_description.yaml index a96e9a4f3..6ba8a0a6e 100644 --- a/tests/fixtures/file_description.yaml +++ b/tests/fixtures/file_description.yaml @@ -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