diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 536d67b85..740fbd58e 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -53,6 +53,8 @@ jobs: run: | mv $(cabal list-bin smp-server) smp-server-ubuntu-20_04-x86-64 mv $(cabal list-bin ntf-server) ntf-server-ubuntu-20_04-x86-64 + mv $(cabal list-bin xftp-server) xftp-server-ubuntu-20_04-x86-64 + mv $(cabal list-bin xftp) xftp-ubuntu-20_04-x86-64 - name: Build changelog if: startsWith(github.ref, 'refs/tags/v') && matrix.os == 'ubuntu-20.04' @@ -80,6 +82,8 @@ jobs: LICENSE smp-server-ubuntu-20_04-x86-64 ntf-server-ubuntu-20_04-x86-64 + xftp-server-ubuntu-20_04-x86-64 + xftp-ubuntu-20_04-x86-64 fail_on_unmatched_files: true env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} diff --git a/apps/smp-agent/Main.hs b/apps/smp-agent/Main.hs index 0c51b5619..ce73ccbea 100644 --- a/apps/smp-agent/Main.hs +++ b/apps/smp-agent/Main.hs @@ -21,6 +21,7 @@ servers = InitialAgentServers { smp = M.fromList [(1, L.fromList ["smp://bU0K-bRg24xWW__lS0umO1Zdw_SXqpJNtm1_RrPLViE=@localhost:5223"])], ntf = [], + xftp = M.fromList [], netCfg = defaultNetworkConfig } diff --git a/apps/xftp-server/Main.hs b/apps/xftp-server/Main.hs new file mode 100644 index 000000000..ca3528872 --- /dev/null +++ b/apps/xftp-server/Main.hs @@ -0,0 +1,18 @@ +module Main where + +import Control.Logger.Simple +import Simplex.FileTransfer.Server.Main + +cfgPath :: FilePath +cfgPath = "/etc/opt/simplex-xftp" + +logPath :: FilePath +logPath = "/var/opt/simplex-xftp" + +logCfg :: LogConfig +logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} + +main :: IO () +main = do + setLogLevel LogDebug -- change to LogError in production + withGlobalLogging logCfg $ xftpServerCLI cfgPath logPath diff --git a/apps/xftp/Main.hs b/apps/xftp/Main.hs new file mode 100644 index 000000000..c96a664c9 --- /dev/null +++ b/apps/xftp/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Simplex.FileTransfer.Client.Main + +main :: IO () +main = xftpClientCLI diff --git a/cabal.project b/cabal.project index 020cc61f7..5c6895cdd 100644 --- a/cabal.project +++ b/cabal.project @@ -12,6 +12,11 @@ source-repository-package location: https://github.com/simplex-chat/hs-socks.git tag: a30cc7a79a08d8108316094f8f2f82a0c5e1ac51 +source-repository-package + type: git + location: https://github.com/kazu-yamamoto/http2.git + tag: 78e18f52295a7f89e828539a03fbcb24931461a3 + source-repository-package type: git location: https://github.com/simplex-chat/direct-sqlcipher.git diff --git a/package.yaml b/package.yaml index 56b2748b2..eb10dac51 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: simplexmq -version: 4.4.1 +version: 5.0.0 synopsis: SimpleXMQ message broker description: | This package includes <./docs/Simplex-Messaging-Server.html server>, @@ -42,7 +42,7 @@ dependencies: - directory == 1.3.* - filepath == 1.4.* - http-types == 0.12.* - - http2 == 3.0.* + - http2 == 4.1.* - generic-random >= 1.3 && < 1.5 - ini == 0.4.1 - iso8601-time == 0.1.* @@ -59,6 +59,7 @@ dependencies: - sqlcipher-simple == 0.4.* - stm == 2.5.* - template-haskell == 2.16.* + - temporary == 1.3.* - text == 1.2.* - time == 1.9.* - time-compat == 1.9.* @@ -71,6 +72,7 @@ dependencies: - x509 == 1.7.* - x509-store == 1.6.* - x509-validation == 1.6.* + - yaml == 0.11.* flags: swift: @@ -103,6 +105,14 @@ executables: ghc-options: - -threaded + xftp-server: + source-dirs: apps/xftp-server + main: Main.hs + dependencies: + - simplexmq + ghc-options: + - -threaded + smp-agent: source-dirs: apps/smp-agent main: Main.hs @@ -111,12 +121,21 @@ executables: ghc-options: - -threaded + xftp: + source-dirs: apps/xftp + main: Main.hs + dependencies: + - simplexmq + ghc-options: + - -threaded + tests: simplexmq-test: source-dirs: tests main: Test.hs dependencies: - simplexmq + - deepseq == 1.4.* - hspec == 2.7.* - hspec-core == 2.7.* - HUnit == 1.6.* diff --git a/rfcs/2022-12-26-simplex-file-transfer.md b/rfcs/2022-12-26-simplex-file-transfer.md index a607726fb..9ca7a99d9 100644 --- a/rfcs/2022-12-26-simplex-file-transfer.md +++ b/rfcs/2022-12-26-simplex-file-transfer.md @@ -132,16 +132,15 @@ File description format (yml): ``` name: file.ext size: 33200000 -chunk: 8Mb +chunk: 8mb hash: abc= key: abc= iv: abc= -part_hashes: [def=, def=, def=, def=] parts: - server: xftp://abc=@example1.com chunks: [1:abc=:def=:ghi=, 3:abc=:def=:ghi=] - server: xftp://abc=@example2.com - chunks: [2:abc=:def=:ghi=, 4:abc=:def=:ghi=] + chunks: [2:abc=:def=:ghi=, 4:abc=:def=:ghi=:2mb] - server: xftp://abc=@example3.com chunks: [1:abc=:def=, 4:abc=:def=] - server: xftp://abc=@example4.com diff --git a/simplexmq.cabal b/simplexmq.cabal index 7b9894a36..9140410be 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: simplexmq -version: 4.4.1 +version: 5.0.0 synopsis: SimpleXMQ message broker description: This package includes <./docs/Simplex-Messaging-Server.html server>, <./docs/Simplex-Messaging-Client.html client> and @@ -34,6 +34,24 @@ flag swift library exposed-modules: + Simplex.FileTransfer + Simplex.FileTransfer.Agent + Simplex.FileTransfer.Client + Simplex.FileTransfer.Client.Agent + Simplex.FileTransfer.Client.Main + Simplex.FileTransfer.Client.Presets + Simplex.FileTransfer.Crypto + Simplex.FileTransfer.Description + Simplex.FileTransfer.Protocol + Simplex.FileTransfer.Server + Simplex.FileTransfer.Server.Env + Simplex.FileTransfer.Server.Main + Simplex.FileTransfer.Server.Stats + Simplex.FileTransfer.Server.Store + Simplex.FileTransfer.Server.StoreLog + Simplex.FileTransfer.Transport + Simplex.FileTransfer.Types + Simplex.FileTransfer.Util Simplex.Messaging.Agent Simplex.Messaging.Agent.Client Simplex.Messaging.Agent.Env.SQLite @@ -59,6 +77,8 @@ library Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files + Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files Simplex.Messaging.Agent.TAsyncs Simplex.Messaging.Agent.TRcvQueues Simplex.Messaging.Client @@ -132,7 +152,7 @@ library , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* - , http2 ==3.0.* + , http2 ==4.1.* , ini ==0.4.1 , iso8601-time ==0.1.* , memory ==0.15.* @@ -147,6 +167,7 @@ library , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* + , temporary ==1.3.* , text ==1.2.* , time ==1.9.* , time-compat ==1.9.* @@ -159,6 +180,7 @@ library , x509 ==1.7.* , x509-store ==1.6.* , x509-validation ==1.6.* + , yaml ==0.11.* default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -193,7 +215,7 @@ executable ntf-server , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* - , http2 ==3.0.* + , http2 ==4.1.* , ini ==0.4.1 , iso8601-time ==0.1.* , memory ==0.15.* @@ -209,6 +231,7 @@ executable ntf-server , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* + , temporary ==1.3.* , text ==1.2.* , time ==1.9.* , time-compat ==1.9.* @@ -221,6 +244,7 @@ executable ntf-server , x509 ==1.7.* , x509-store ==1.6.* , x509-validation ==1.6.* + , yaml ==0.11.* default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -255,7 +279,7 @@ executable smp-agent , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* - , http2 ==3.0.* + , http2 ==4.1.* , ini ==0.4.1 , iso8601-time ==0.1.* , memory ==0.15.* @@ -271,6 +295,7 @@ executable smp-agent , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* + , temporary ==1.3.* , text ==1.2.* , time ==1.9.* , time-compat ==1.9.* @@ -283,6 +308,7 @@ executable smp-agent , x509 ==1.7.* , x509-store ==1.6.* , x509-validation ==1.6.* + , yaml ==0.11.* default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -317,7 +343,7 @@ executable smp-server , filepath ==1.4.* , generic-random >=1.3 && <1.5 , http-types ==0.12.* - , http2 ==3.0.* + , http2 ==4.1.* , ini ==0.4.1 , iso8601-time ==0.1.* , memory ==0.15.* @@ -333,6 +359,7 @@ executable smp-server , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* + , temporary ==1.3.* , text ==1.2.* , time ==1.9.* , time-compat ==1.9.* @@ -345,6 +372,135 @@ executable smp-server , x509 ==1.7.* , x509-store ==1.6.* , x509-validation ==1.6.* + , yaml ==0.11.* + default-language: Haskell2010 + if flag(swift) + cpp-options: -DswiftJSON + +executable xftp + main-is: Main.hs + other-modules: + Paths_simplexmq + hs-source-dirs: + apps/xftp + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + QuickCheck ==2.14.* + , aeson ==2.0.* + , ansi-terminal >=0.10 && <0.12 + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.14.* + , base >=4.14 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , case-insensitive ==1.2.* + , composition ==1.0.* + , constraints >=0.12 && <0.14 + , containers ==0.6.* + , cryptonite >=0.27 && <0.30 + , cryptostore ==0.2.* + , data-default ==0.7.* + , direct-sqlcipher ==2.3.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random >=1.3 && <1.5 + , http-types ==0.12.* + , http2 ==4.1.* + , ini ==0.4.1 + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network >=3.1.2.7 && <3.2 + , network-transport ==0.5.4 + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , random >=1.1 && <1.3 + , simple-logger ==0.1.* + , simplexmq + , socks ==0.6.* + , sqlcipher-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.16.* + , temporary ==1.3.* + , text ==1.2.* + , time ==1.9.* + , time-compat ==1.9.* + , time-manager ==0.0.* + , tls >=1.6.0 && <1.7 + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.2.* + , websockets ==0.12.* + , x509 ==1.7.* + , x509-store ==1.6.* + , x509-validation ==1.6.* + , yaml ==0.11.* + default-language: Haskell2010 + if flag(swift) + cpp-options: -DswiftJSON + +executable xftp-server + main-is: Main.hs + other-modules: + Paths_simplexmq + hs-source-dirs: + apps/xftp-server + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -threaded + build-depends: + QuickCheck ==2.14.* + , aeson ==2.0.* + , ansi-terminal >=0.10 && <0.12 + , asn1-encoding ==0.9.* + , asn1-types ==0.3.* + , async ==2.2.* + , attoparsec ==0.14.* + , base >=4.14 && <5 + , base64-bytestring >=1.0 && <1.3 + , bytestring ==0.10.* + , case-insensitive ==1.2.* + , composition ==1.0.* + , constraints >=0.12 && <0.14 + , containers ==0.6.* + , cryptonite >=0.27 && <0.30 + , cryptostore ==0.2.* + , data-default ==0.7.* + , direct-sqlcipher ==2.3.* + , directory ==1.3.* + , filepath ==1.4.* + , generic-random >=1.3 && <1.5 + , http-types ==0.12.* + , http2 ==4.1.* + , ini ==0.4.1 + , iso8601-time ==0.1.* + , memory ==0.15.* + , mtl ==2.2.* + , network >=3.1.2.7 && <3.2 + , network-transport ==0.5.4 + , optparse-applicative >=0.15 && <0.17 + , process ==1.6.* + , random >=1.1 && <1.3 + , simple-logger ==0.1.* + , simplexmq + , socks ==0.6.* + , sqlcipher-simple ==0.4.* + , stm ==2.5.* + , template-haskell ==2.16.* + , temporary ==1.3.* + , text ==1.2.* + , time ==1.9.* + , time-compat ==1.9.* + , time-manager ==0.0.* + , tls >=1.6.0 && <1.7 + , transformers ==0.5.* + , unliftio ==0.2.* + , unliftio-core ==0.2.* + , websockets ==0.12.* + , x509 ==1.7.* + , x509-store ==1.6.* + , x509-validation ==1.6.* + , yaml ==0.11.* default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON @@ -366,11 +522,16 @@ test-suite simplexmq-test CoreTests.ProtocolErrorTests CoreTests.RetryIntervalTests CoreTests.VersionRangeTests + FileDescriptionTests NtfClient NtfServerTests ServerTests SMPAgentClient SMPClient + XFTPAgent + XFTPCLI + XFTPClient + XFTPServerTests Paths_simplexmq hs-source-dirs: tests @@ -394,6 +555,7 @@ test-suite simplexmq-test , cryptonite >=0.27 && <0.30 , cryptostore ==0.2.* , data-default ==0.7.* + , deepseq ==1.4.* , direct-sqlcipher ==2.3.* , directory ==1.3.* , filepath ==1.4.* @@ -401,7 +563,7 @@ test-suite simplexmq-test , hspec ==2.7.* , hspec-core ==2.7.* , http-types ==0.12.* - , http2 ==3.0.* + , http2 ==4.1.* , ini ==0.4.1 , iso8601-time ==0.1.* , main-tester ==0.2.* @@ -419,6 +581,7 @@ test-suite simplexmq-test , sqlcipher-simple ==0.4.* , stm ==2.5.* , template-haskell ==2.16.* + , temporary ==1.3.* , text ==1.2.* , time ==1.9.* , time-compat ==1.9.* @@ -432,6 +595,7 @@ test-suite simplexmq-test , x509 ==1.7.* , x509-store ==1.6.* , x509-validation ==1.6.* + , yaml ==0.11.* default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON diff --git a/src/Simplex/FileTransfer.hs b/src/Simplex/FileTransfer.hs new file mode 100644 index 000000000..9f648d7ff --- /dev/null +++ b/src/Simplex/FileTransfer.hs @@ -0,0 +1,14 @@ +module Simplex.FileTransfer where + +-- TODO +-- Protocol +-- Store (in memory storage) +-- StoreLog (append only log) +-- FileDescription +-- Server +-- Client +-- Server/Main (server CLI) +-- Client/Main (client CLI) +-- +-- Transport for HTTP2 ? +-- streaming Crypto diff --git a/src/Simplex/FileTransfer/Agent.hs b/src/Simplex/FileTransfer/Agent.hs new file mode 100644 index 000000000..12ac35548 --- /dev/null +++ b/src/Simplex/FileTransfer/Agent.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Simplex.FileTransfer.Agent + ( -- Receiving files + receiveFile, + addXFTPWorker, + deleteRcvFile, + -- Sending files + sendFileExperimental, + _sendFile, + ) +where + +import Control.Concurrent.STM (stateTVar) +import Control.Logger.Simple (logError) +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Crypto.Random (ChaChaDRG, randomBytesGenerate) +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64.URL as U +import qualified Data.ByteString.Char8 as B +import Data.List (isSuffixOf, partition) +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as L +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Simplex.FileTransfer.Client.Main (CLIError, SendOptions (..), cliSendFile) +import Simplex.FileTransfer.Crypto +import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI) +import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) +import Simplex.FileTransfer.Types +import Simplex.FileTransfer.Util (removePath, uniqueCombine) +import Simplex.Messaging.Agent.Client +import Simplex.Messaging.Agent.Env.SQLite +import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Agent.Store.SQLite +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (XFTPServer, XFTPServerWithAuth) +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (liftError, liftIOEither, tshow) +import System.FilePath (takeFileName, ()) +import UnliftIO +import UnliftIO.Concurrent +import UnliftIO.Directory +import qualified UnliftIO.Exception as E + +receiveFile :: AgentMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> m RcvFileId +receiveFile c userId (ValidFileDescription fd@FileDescription {chunks}) xftpWorkPath = do + g <- asks idsDrg + workPath <- maybe getTemporaryDirectory pure xftpWorkPath + ts <- liftIO getCurrentTime + let isoTime = formatTime defaultTimeLocale "%Y%m%d_%H%M%S_%6q" ts + prefixPath <- uniqueCombine workPath (isoTime <> "_rcv.xftp") + createDirectory prefixPath + let tmpPath = prefixPath "xftp.encrypted" + createDirectory tmpPath + let savePath = prefixPath "xftp.decrypted" + createEmptyFile savePath + fId <- withStore c $ \db -> createRcvFile db g userId fd prefixPath tmpPath savePath + forM_ chunks downloadChunk + pure fId + where + downloadChunk :: AgentMonad m => FileChunk -> m () + downloadChunk FileChunk {replicas = (FileChunkReplica {server} : _)} = do + addXFTPWorker c (Just server) + downloadChunk _ = throwError $ INTERNAL "no replicas" + +createEmptyFile :: AgentMonad m => FilePath -> m () +createEmptyFile fPath = do + h <- openFile fPath AppendMode + liftIO $ B.hPut h "" >> hFlush h + +addXFTPWorker :: AgentMonad m => AgentClient -> Maybe XFTPServer -> m () +addXFTPWorker c srv_ = do + ws <- asks $ xftpWorkers . xftpAgent + atomically (TM.lookup srv_ ws) >>= \case + Nothing -> do + doWork <- newTMVarIO () + let runWorker = case srv_ of + Just srv -> runXFTPWorker c srv doWork + Nothing -> runXFTPLocalWorker c doWork + worker <- async $ runWorker `E.finally` atomically (TM.delete srv_ ws) + atomically $ TM.insert srv_ (doWork, worker) ws + Just (doWork, _) -> + void . atomically $ tryPutTMVar doWork () + +runXFTPWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m () +runXFTPWorker c srv doWork = do + forever $ do + void . atomically $ readTMVar doWork + agentOperationBracket c AORcvNetwork throwWhenInactive runXftpOperation + where + noWorkToDo = void . atomically $ tryTakeTMVar doWork + runXftpOperation :: m () + runXftpOperation = do + nextChunk <- withStore' c (`getNextRcvChunkToDownload` srv) + case nextChunk of + Nothing -> noWorkToDo + Just RcvFileChunk {rcvFileId, rcvFileEntityId, fileTmpPath, replicas = []} -> workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) "chunk has no replicas" + Just fc@RcvFileChunk {userId, rcvFileId, rcvFileEntityId, fileTmpPath, replicas = replica@RcvFileChunkReplica {rcvChunkReplicaId, delay} : _} -> do + ri <- asks $ reconnectInterval . config + let ri' = maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) delay + withRetryInterval ri' $ \delay' loop -> + downloadFileChunk fc replica + `catchError` retryOnError delay' loop (workerInternalError c rcvFileId rcvFileEntityId (Just fileTmpPath) . show) + where + retryOnError :: Int -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m () + retryOnError replicaDelay loop done e = do + logError $ "XFTP worker error: " <> tshow e + if temporaryAgentError e + then retryLoop + else done e + where + retryLoop = do + closeXFTPServerClient c userId replica + withStore' c $ \db -> updateRcvChunkReplicaDelay db rcvChunkReplicaId replicaDelay + atomically $ endAgentOperation c AORcvNetwork + atomically $ throwWhenInactive c + atomically $ beginAgentOperation c AORcvNetwork + loop + downloadFileChunk :: RcvFileChunk -> RcvFileChunkReplica -> m () + downloadFileChunk RcvFileChunk {userId, rcvFileId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath} replica = do + chunkPath <- uniqueCombine fileTmpPath $ show chunkNo + let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) + agentXFTPDownloadChunk c userId replica chunkSpec + fileReceived <- withStore c $ \db -> runExceptT $ do + -- both actions can be done in a single store method + f <- ExceptT $ updateRcvFileChunkReceived db (rcvChunkReplicaId replica) rcvChunkId rcvFileId chunkPath + let fileReceived = allChunksReceived f + when fileReceived $ + liftIO $ updateRcvFileStatus db rcvFileId RFSReceived + pure fileReceived + when fileReceived $ addXFTPWorker c Nothing + where + allChunksReceived :: RcvFile -> Bool + allChunksReceived RcvFile {chunks} = + all (\RcvFileChunk {replicas} -> any received replicas) chunks + +workerInternalError :: AgentMonad m => AgentClient -> DBRcvFileId -> RcvFileId -> Maybe FilePath -> String -> m () +workerInternalError c rcvFileId rcvFileEntityId tmpPath internalErrStr = do + forM_ tmpPath removePath + withStore' c $ \db -> updateRcvFileError db rcvFileId internalErrStr + notifyInternalError c rcvFileEntityId internalErrStr + +notifyInternalError :: (MonadUnliftIO m) => AgentClient -> RcvFileId -> String -> m () +notifyInternalError AgentClient {subQ} rcvFileEntityId internalErrStr = atomically $ writeTBQueue subQ ("", rcvFileEntityId, APC SAERcvFile $ RFERR $ INTERNAL internalErrStr) + +runXFTPLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m () +runXFTPLocalWorker c@AgentClient {subQ} doWork = do + forever $ do + void . atomically $ readTMVar doWork + runXftpOperation + where + runXftpOperation :: m () + runXftpOperation = do + nextFile <- withStore' c getNextRcvFileToDecrypt + case nextFile of + Nothing -> noWorkToDo + Just f@RcvFile {rcvFileId, rcvFileEntityId, tmpPath} -> + decryptFile f `catchError` (workerInternalError c rcvFileId rcvFileEntityId tmpPath . show) + noWorkToDo = void . atomically $ tryTakeTMVar doWork + decryptFile :: RcvFile -> m () + decryptFile RcvFile {rcvFileId, rcvFileEntityId, key, nonce, tmpPath, savePath, chunks} = do + -- TODO test; recreate file if it's in status RFSDecrypting + -- when (status == RFSDecrypting) $ + -- whenM (doesFileExist savePath) (removeFile savePath >> createEmptyFile savePath) + withStore' c $ \db -> updateRcvFileStatus db rcvFileId RFSDecrypting + chunkPaths <- getChunkPaths chunks + encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths + void $ liftError (INTERNAL . show) $ decryptChunks encSize chunkPaths key nonce $ \_ -> pure savePath + forM_ tmpPath removePath + withStore' c (`updateRcvFileComplete` rcvFileId) + notify $ RFDONE savePath + where + notify :: forall e. AEntityI e => ACommand 'Agent e -> m () + notify cmd = atomically $ writeTBQueue subQ ("", rcvFileEntityId, APC (sAEntity @e) cmd) + getChunkPaths :: [RcvFileChunk] -> m [FilePath] + getChunkPaths [] = pure [] + getChunkPaths (RcvFileChunk {chunkTmpPath = Just path} : cs) = do + ps <- getChunkPaths cs + pure $ path : ps + getChunkPaths (RcvFileChunk {chunkTmpPath = Nothing} : _cs) = + throwError $ INTERNAL "no chunk path" + +deleteRcvFile :: AgentMonad m => AgentClient -> UserId -> RcvFileId -> m () +deleteRcvFile c userId rcvFileEntityId = do + RcvFile {rcvFileId, prefixPath, status} <- withStore c $ \db -> getRcvFileByEntityId db userId rcvFileEntityId + if status == RFSComplete || status == RFSError + then do + removePath prefixPath + withStore' c (`deleteRcvFile'` rcvFileId) + else withStore' c (`updateRcvFileDeleted` rcvFileId) + +sendFileExperimental :: forall m. AgentMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId +sendFileExperimental AgentClient {subQ, xftpServers} userId filePath numRecipients xftpWorkPath = do + g <- asks idsDrg + sndFileId <- liftIO $ randomId g 12 + xftpSrvs <- atomically $ TM.lookup userId xftpServers + void $ forkIO $ sendCLI sndFileId $ maybe [] L.toList xftpSrvs + pure sndFileId + where + randomId :: TVar ChaChaDRG -> Int -> IO ByteString + randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n) + sendCLI :: SndFileId -> [XFTPServerWithAuth] -> m () + sendCLI sndFileId xftpSrvs = do + let fileName = takeFileName filePath + workPath <- maybe getTemporaryDirectory pure xftpWorkPath + outputDir <- uniqueCombine workPath $ fileName <> ".descr" + createDirectory outputDir + let tempPath = workPath "snd" + createDirectoryIfMissing False tempPath + let sendOptions = + SendOptions + { filePath, + outputDir = Just outputDir, + numRecipients, + xftpServers = xftpSrvs, + retryCount = 3, + tempPath = Just tempPath, + verbose = False + } + liftCLI $ cliSendFile sendOptions + (sndDescr, rcvDescrs) <- readDescrs outputDir fileName + notify sndFileId $ SFDONE sndDescr rcvDescrs + liftCLI :: ExceptT CLIError IO () -> m () + liftCLI = either (throwError . INTERNAL . show) pure <=< liftIO . runExceptT + readDescrs :: FilePath -> FilePath -> m (ValidFileDescription 'FSender, [ValidFileDescription 'FRecipient]) + readDescrs outDir fileName = do + let descrDir = outDir (fileName <> ".xftp") + files <- listDirectory descrDir + let (sdFiles, rdFiles) = partition ("snd.xftp.private" `isSuffixOf`) files + sdFile = maybe "" (\l -> descrDir L.head l) (nonEmpty sdFiles) + rdFiles' = map (descrDir ) rdFiles + (,) <$> readDescr sdFile <*> mapM readDescr rdFiles' + readDescr :: FilePartyI p => FilePath -> m (ValidFileDescription p) + readDescr f = liftIOEither $ first INTERNAL . strDecode <$> B.readFile f + notify :: forall e. AEntityI e => SndFileId -> ACommand 'Agent e -> m () + notify sndFileId cmd = atomically $ writeTBQueue subQ ("", sndFileId, APC (sAEntity @e) cmd) + +-- _sendFile :: AgentMonad m => AgentClient -> UserId -> Int -> FilePath -> FilePath -> m SndFileId +_sendFile :: AgentClient -> UserId -> Int -> FilePath -> FilePath -> m SndFileId +_sendFile _c _userId _numRecipients _xftpPath _filePath = do + -- db: create file in status New without chunks + -- add local snd worker for encryption + -- return file id to client + undefined + +_runXFTPSndLocalWorker :: forall m. AgentMonad m => AgentClient -> TMVar () -> m () +_runXFTPSndLocalWorker _c doWork = do + forever $ do + void . atomically $ readTMVar doWork + runXftpOperation + where + runXftpOperation :: m () + runXftpOperation = do + -- db: get next snd file to encrypt (in status New) + -- ? (or Encrypted to retry create? - see below) + -- with fixed retries (?) encryptFile + undefined + _encryptFile :: SndFile -> m () + _encryptFile _sndFile = do + -- if enc path exists, remove it + -- if enc path doesn't exist: + -- - choose enc path + -- - touch file, db: update enc path (?) + -- calculate chunk sizes, encrypt file to enc path + -- calculate digest + -- prepare chunk specs + -- db: + -- - update file status to Encrypted + -- - create chunks according to chunk specs + -- ? since which servers are online is unknown, + -- ? we can't blindly assign servers to replicas. + -- ? should we XFTP create chunks on servers here, + -- ? with retrying for different servers, + -- ? keeping a list of servers that were tried? + -- ? then we can add replicas to chunks in db + -- ? and update file status to Uploading, + -- ? probably in same transaction as creating chunks, + -- ? and add XFTP snd workers for uploading chunks. + undefined + +_runXFTPSndWorker :: forall m. AgentMonad m => AgentClient -> XFTPServer -> TMVar () -> m () +_runXFTPSndWorker c _srv doWork = do + forever $ do + void . atomically $ readTMVar doWork + agentOperationBracket c AOSndNetwork throwWhenInactive runXftpOperation + where + runXftpOperation :: m () + runXftpOperation = do + -- db: get next snd chunk to upload (replica is not uploaded) + -- with retry interval uploadChunk + -- - with fixed retries, repeat N times: + -- check if other files are in upload, delay (see xftpSndFiles in XFTPAgent) + undefined + _uploadFileChunk :: SndFileChunk -> m () + _uploadFileChunk _sndFileChunk = do + -- add file id to xftpSndFiles + -- XFTP upload chunk + -- db: update replica status to Uploaded, return SndFile + -- if all SndFile's replicas are uploaded: + -- - serialize file descriptions and notify client + -- - remove file id from xftpSndFiles + undefined diff --git a/src/Simplex/FileTransfer/Client.hs b/src/Simplex/FileTransfer/Client.hs new file mode 100644 index 000000000..a98248c03 --- /dev/null +++ b/src/Simplex/FileTransfer/Client.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Simplex.FileTransfer.Client where + +import Control.Monad.Except +import Data.Bifunctor (first) +import Data.ByteString.Builder (Builder, byteString) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Time (UTCTime) +import Data.Word (Word32) +import qualified Network.HTTP.Types as N +import qualified Network.HTTP2.Client as H +import Simplex.FileTransfer.Description (mb) +import Simplex.FileTransfer.Protocol +import Simplex.FileTransfer.Transport +import Simplex.Messaging.Client + ( NetworkConfig (..), + ProtocolClientError (..), + TransportSession, + chooseTransportHost, + defaultNetworkConfig, + proxyUsername, + transportClientConfig, + ) +import Simplex.Messaging.Client.Agent () +import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol + ( BasicAuth, + Protocol (..), + ProtocolServer (..), + RecipientId, + SenderId, + ) +import Simplex.Messaging.Transport (supportedParameters) +import Simplex.Messaging.Transport.Client (TransportClientConfig, TransportHost) +import Simplex.Messaging.Transport.HTTP2 +import Simplex.Messaging.Transport.HTTP2.Client +import Simplex.Messaging.Util (bshow, liftEitherError, whenM) +import UnliftIO +import UnliftIO.Directory + +data XFTPClient = XFTPClient + { http2Client :: HTTP2Client, + transportSession :: TransportSession FileResponse, + config :: XFTPClientConfig + } + +data XFTPClientConfig = XFTPClientConfig + { xftpNetworkConfig :: NetworkConfig, + uploadTimeoutPerMb :: Int + } + +data XFTPChunkBody = XFTPChunkBody + { chunkSize :: Int, + chunkPart :: Int -> IO ByteString, + http2Body :: HTTP2Body + } + +data XFTPChunkSpec = XFTPChunkSpec + { filePath :: FilePath, + chunkOffset :: Int64, + chunkSize :: Word32 + } + deriving (Eq, Show) + +type XFTPClientError = ProtocolClientError XFTPErrorType + +defaultXFTPClientConfig :: XFTPClientConfig +defaultXFTPClientConfig = + XFTPClientConfig + { xftpNetworkConfig = defaultNetworkConfig, + uploadTimeoutPerMb = 10000000 -- 10 seconds + } + +getXFTPClient :: TransportSession FileResponse -> XFTPClientConfig -> (XFTPClient -> IO ()) -> IO (Either XFTPClientError XFTPClient) +getXFTPClient transportSession@(_, srv, _) config@XFTPClientConfig {xftpNetworkConfig} disconnected = runExceptT $ do + let tcConfig = transportClientConfig xftpNetworkConfig + http2Config = xftpHTTP2Config tcConfig config + username = proxyUsername transportSession + ProtocolServer _ host port keyHash = srv + useHost <- liftEither $ chooseTransportHost xftpNetworkConfig host + clientVar <- newTVarIO Nothing + let usePort = if null port then "443" else port + clientDisconnected = readTVarIO clientVar >>= mapM_ disconnected + http2Client <- liftEitherError xftpClientError $ getVerifiedHTTP2Client (Just username) useHost usePort (Just keyHash) Nothing http2Config clientDisconnected + let c = XFTPClient {http2Client, transportSession, config} + atomically $ writeTVar clientVar $ Just c + pure c + +closeXFTPClient :: XFTPClient -> IO () +closeXFTPClient XFTPClient {http2Client} = closeHTTP2Client http2Client + +xftpClientServer :: XFTPClient -> String +xftpClientServer = B.unpack . strEncode . snd3 . transportSession + where + snd3 (_, s, _) = s + +xftpTransportHost :: XFTPClient -> TransportHost +xftpTransportHost = (host :: HClient -> TransportHost) . client_ . http2Client + +xftpSessionTs :: XFTPClient -> UTCTime +xftpSessionTs = sessionTs . http2Client + +xftpHTTP2Config :: TransportClientConfig -> XFTPClientConfig -> HTTP2ClientConfig +xftpHTTP2Config transportConfig XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = + defaultHTTP2ClientConfig + { bodyHeadSize = xftpBlockSize, + suportedTLSParams = supportedParameters, + connTimeout = tcpConnectTimeout, + transportConfig + } + +xftpClientError :: HTTP2ClientError -> XFTPClientError +xftpClientError = \case + HCResponseTimeout -> PCEResponseTimeout + HCNetworkError -> PCENetworkError + HCIOError e -> PCEIOError e + +sendXFTPCommand :: forall p. FilePartyI p => XFTPClient -> C.APrivateSignKey -> XFTPFileId -> FileCommand p -> Maybe XFTPChunkSpec -> ExceptT XFTPClientError IO (FileResponse, HTTP2Body) +sendXFTPCommand XFTPClient {config, http2Client = http2@HTTP2Client {sessionId}} pKey fId cmd chunkSpec_ = do + t <- + liftEither . first PCETransportError $ + xftpEncodeTransmission sessionId (Just pKey) ("", fId, FileCmd (sFileParty @p) cmd) + let req = H.requestStreaming N.methodPost "/" [] $ streamBody t + reqTimeout = (\XFTPChunkSpec {chunkSize} -> (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1) <$> chunkSpec_ + HTTP2Response {respBody = body@HTTP2Body {bodyHead}} <- liftEitherError xftpClientError $ sendRequest http2 req reqTimeout + when (B.length bodyHead /= xftpBlockSize) $ throwError $ PCEResponseError BLOCK + -- TODO validate that the file ID is the same as in the request? + (_, _, (_, _fId, respOrErr)) <- liftEither . first PCEResponseError $ xftpDecodeTransmission sessionId bodyHead + case respOrErr of + Right r -> case protocolError r of + Just e -> throwError $ PCEProtocolError e + _ -> pure (r, body) + Left e -> throwError $ PCEResponseError e + where + streamBody :: ByteString -> (Builder -> IO ()) -> IO () -> IO () + streamBody t send done = do + send $ byteString t + forM_ chunkSpec_ $ \XFTPChunkSpec {filePath, chunkOffset, chunkSize} -> + withFile filePath ReadMode $ \h -> do + hSeek h AbsoluteSeek $ fromIntegral chunkOffset + sendFile h send $ fromIntegral chunkSize + done + +createXFTPChunk :: + XFTPClient -> + C.APrivateSignKey -> + FileInfo -> + NonEmpty C.APublicVerifyKey -> + Maybe BasicAuth -> + ExceptT XFTPClientError IO (SenderId, NonEmpty RecipientId) +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 + +uploadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPChunkSpec -> ExceptT XFTPClientError IO () +uploadXFTPChunk c spKey fId chunkSpec = + sendXFTPCommand c spKey fId FPUT (Just chunkSpec) >>= okResponse + +downloadXFTPChunk :: XFTPClient -> C.APrivateSignKey -> XFTPFileId -> XFTPRcvChunkSpec -> ExceptT XFTPClientError IO () +downloadXFTPChunk c@XFTPClient {config} rpKey fId chunkSpec@XFTPRcvChunkSpec {filePath, chunkSize} = do + (rDhKey, rpDhKey) <- liftIO C.generateKeyPair' + sendXFTPCommand c rpKey fId (FGET rDhKey) Nothing >>= \case + (FRFile sDhKey cbNonce, HTTP2Body {bodyHead = _bg, bodySize = _bs, bodyPart}) -> case bodyPart of + -- TODO atm bodySize is set to 0, so chunkSize will be incorrect - validate once set + Just chunkPart -> do + let dhSecret = C.dh' sDhKey rpDhKey + cbState <- liftEither . first PCECryptoError $ LC.cbInit dhSecret cbNonce + let t = (fromIntegral chunkSize * uploadTimeoutPerMb config) `div` mb 1 + t `timeout` download cbState >>= maybe (throwError PCEResponseTimeout) pure + where + download cbState = + withExceptT PCEResponseError $ + receiveEncFile chunkPart cbState chunkSpec `catchError` \e -> + whenM (doesFileExist filePath) (removeFile filePath) >> throwError e + _ -> throwError $ PCEResponseError NO_FILE + (r, _) -> throwError . PCEUnexpectedResponse $ bshow r + +deleteXFTPChunk :: XFTPClient -> C.APrivateSignKey -> SenderId -> ExceptT XFTPClientError IO () +deleteXFTPChunk c spKey sId = sendXFTPCommand c spKey sId FDEL Nothing >>= okResponse + +ackXFTPChunk :: XFTPClient -> C.APrivateSignKey -> RecipientId -> ExceptT XFTPClientError IO () +ackXFTPChunk c rpKey rId = sendXFTPCommand c rpKey rId FACK Nothing >>= okResponse + +okResponse :: (FileResponse, HTTP2Body) -> ExceptT XFTPClientError IO () +okResponse = \case + (FROk, body) -> noFile body () + (r, _) -> throwError . PCEUnexpectedResponse $ bshow r + +-- TODO this currently does not check anything because response size is not set and bodyPart is always Just +noFile :: HTTP2Body -> a -> ExceptT XFTPClientError IO a +noFile HTTP2Body {bodyPart} a = case bodyPart of + Just _ -> pure a -- throwError $ PCEResponseError HAS_FILE + _ -> pure a + +-- FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand Sender +-- FDEL :: FileCommand Sender +-- FACK :: FileCommand Recipient +-- PING :: FileCommand Recipient diff --git a/src/Simplex/FileTransfer/Client/Agent.hs b/src/Simplex/FileTransfer/Client/Agent.hs new file mode 100644 index 000000000..00ee89404 --- /dev/null +++ b/src/Simplex/FileTransfer/Client/Agent.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.FileTransfer.Client.Agent where + +import Control.Logger.Simple (logInfo) +import Control.Monad.Except +import Data.Bifunctor (first) +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Simplex.FileTransfer.Client +import Simplex.Messaging.Agent.RetryInterval +import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientError (..), temporaryClientError) +import Simplex.Messaging.Client.Agent () +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (ProtocolServer (..), XFTPServer) +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (catchAll_, tryError) +import UnliftIO + +type XFTPClientVar = TMVar (Either XFTPClientAgentError XFTPClient) + +data XFTPClientAgent = XFTPClientAgent + { xftpClients :: TMap XFTPServer XFTPClientVar, + config :: XFTPClientAgentConfig + } + +data XFTPClientAgentConfig = XFTPClientAgentConfig + { xftpConfig :: XFTPClientConfig, + reconnectInterval :: RetryInterval + } + +defaultXFTPClientAgentConfig :: XFTPClientAgentConfig +defaultXFTPClientAgentConfig = + XFTPClientAgentConfig + { xftpConfig = defaultXFTPClientConfig, + reconnectInterval = + RetryInterval + { initialInterval = 5_000000, + increaseAfter = 10_000000, + maxInterval = 60_000000 + } + } + +data XFTPClientAgentError = XFTPClientAgentError XFTPServer XFTPClientError + deriving (Show, Exception) + +newXFTPAgent :: XFTPClientAgentConfig -> STM XFTPClientAgent +newXFTPAgent config = do + xftpClients <- TM.empty + pure XFTPClientAgent {xftpClients, config} + +type ME a = ExceptT XFTPClientAgentError IO a + +getXFTPServerClient :: XFTPClientAgent -> XFTPServer -> ME XFTPClient +getXFTPServerClient XFTPClientAgent {xftpClients, config} srv = do + atomically getClientVar >>= either newXFTPClient waitForXFTPClient + where + connectClient :: ME XFTPClient + connectClient = + ExceptT $ + first (XFTPClientAgentError srv) + <$> getXFTPClient (1, srv, Nothing) (xftpConfig config) clientDisconnected + + clientDisconnected :: XFTPClient -> IO () + clientDisconnected _ = do + atomically $ TM.delete srv xftpClients + logInfo $ "disconnected from " <> showServer srv + + getClientVar :: STM (Either XFTPClientVar XFTPClientVar) + getClientVar = maybe (Left <$> newClientVar) (pure . Right) =<< TM.lookup srv xftpClients + where + newClientVar :: STM XFTPClientVar + newClientVar = do + var <- newEmptyTMVar + TM.insert srv var xftpClients + pure var + + waitForXFTPClient :: XFTPClientVar -> ME XFTPClient + waitForXFTPClient clientVar = do + let XFTPClientConfig {xftpNetworkConfig = NetworkConfig {tcpConnectTimeout}} = xftpConfig config + client_ <- tcpConnectTimeout `timeout` atomically (readTMVar clientVar) + liftEither $ case client_ of + Just (Right c) -> Right c + Just (Left e) -> Left e + Nothing -> Left $ XFTPClientAgentError srv PCEResponseTimeout + + newXFTPClient :: XFTPClientVar -> ME XFTPClient + newXFTPClient clientVar = tryConnectClient tryConnectAsync + where + tryConnectClient :: ME () -> ME XFTPClient + tryConnectClient retryAction = + tryError connectClient >>= \r -> case r of + Right client -> do + logInfo $ "connected to " <> showServer srv + atomically $ putTMVar clientVar r + pure client + Left e@(XFTPClientAgentError _ e') -> do + if temporaryClientError e' + then retryAction + else atomically $ do + putTMVar clientVar r + TM.delete srv xftpClients + throwError e + tryConnectAsync :: ME () + tryConnectAsync = void . async $ do + withRetryInterval (reconnectInterval config) $ \_ loop -> void $ tryConnectClient loop + +showServer :: XFTPServer -> Text +showServer ProtocolServer {host, port} = + decodeUtf8 $ strEncode host <> B.pack (if null port then "" else ':' : port) + +closeXFTPServerClient :: XFTPClientAgent -> XFTPServer -> IO () +closeXFTPServerClient XFTPClientAgent {xftpClients, config} srv = + atomically (TM.lookupDelete srv xftpClients) >>= mapM_ closeClient + where + closeClient cVar = do + let NetworkConfig {tcpConnectTimeout} = xftpNetworkConfig $ xftpConfig config + tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case + Just (Right client) -> closeXFTPClient client `catchAll_` pure () + _ -> pure () diff --git a/src/Simplex/FileTransfer/Client/Main.hs b/src/Simplex/FileTransfer/Client/Main.hs new file mode 100644 index 000000000..5ed5d5eba --- /dev/null +++ b/src/Simplex/FileTransfer/Client/Main.hs @@ -0,0 +1,587 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Simplex.FileTransfer.Client.Main + ( SendOptions (..), + CLIError (..), + xftpClientCLI, + cliSendFile, + prepareChunkSizes, + ) +where + +import Control.Concurrent.STM (stateTVar) +import Control.Logger.Simple +import Control.Monad +import Control.Monad.Except +import Crypto.Random (getRandomBytes) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Char (toLower) +import Data.Function (on) +import Data.Int (Int64) +import Data.List (foldl', groupBy, sortOn) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import qualified Data.List.NonEmpty as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Word (Word32) +import GHC.Records (HasField (getField)) +import Options.Applicative +import Simplex.FileTransfer.Client +import Simplex.FileTransfer.Client.Agent +import Simplex.FileTransfer.Client.Presets +import Simplex.FileTransfer.Crypto +import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol +import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec (..)) +import Simplex.FileTransfer.Types +import Simplex.FileTransfer.Util (uniqueCombine) +import qualified Simplex.Messaging.Crypto as C +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 (ProtoServerWithAuth (..), SenderId, SndPrivateSignKey, SndPublicVerifyKey, XFTPServer, XFTPServerWithAuth) +import Simplex.Messaging.Server.CLI (getCliCommand') +import Simplex.Messaging.Util (ifM, tshow, whenM) +import System.Exit (exitFailure) +import System.FilePath (splitFileName, ()) +import System.IO.Temp (getCanonicalTemporaryDirectory) +import System.Random (StdGen, newStdGen, randomR) +import UnliftIO +import UnliftIO.Directory + +xftpClientVersion :: String +xftpClientVersion = "0.1.0" + +chunkSize1 :: Word32 +chunkSize1 = kb 256 + +chunkSize2 :: Word32 +chunkSize2 = mb 1 + +chunkSize3 :: Word32 +chunkSize3 = mb 4 + +maxFileSize :: Int64 +maxFileSize = gb 1 + +maxFileSizeStr :: String +maxFileSizeStr = B.unpack . strEncode $ FileSize maxFileSize + +fileSizeLen :: Int64 +fileSizeLen = 8 + +newtype CLIError = CLIError String + deriving (Eq, Show, Exception) + +cliCryptoError :: FTCryptoError -> CLIError +cliCryptoError = \case + FTCECryptoError e -> CLIError $ "Error decrypting file: " <> show e + FTCEInvalidHeader e -> CLIError $ "Invalid file header: " <> e + FTCEInvalidAuthTag -> CLIError "Error decrypting file: incorrect auth tag" + FTCEFileIOError e -> CLIError $ "File IO error: " <> show e + +data CliCommand + = SendFile SendOptions + | ReceiveFile ReceiveOptions + | DeleteFile DeleteOptions + | RandomFile RandomFileOptions + | FileDescrInfo InfoOptions + +data SendOptions = SendOptions + { filePath :: FilePath, + outputDir :: Maybe FilePath, + numRecipients :: Int, + xftpServers :: [XFTPServerWithAuth], + retryCount :: Int, + tempPath :: Maybe FilePath, + verbose :: Bool + } + deriving (Show) + +data ReceiveOptions = ReceiveOptions + { fileDescription :: FilePath, + filePath :: Maybe FilePath, + retryCount :: Int, + tempPath :: Maybe FilePath, + verbose :: Bool, + yes :: Bool + } + deriving (Show) + +data DeleteOptions = DeleteOptions + { fileDescription :: FilePath, + retryCount :: Int, + verbose :: Bool, + yes :: Bool + } + deriving (Show) + +newtype InfoOptions = InfoOptions + { fileDescription :: FilePath + } + deriving (Show) + +data RandomFileOptions = RandomFileOptions + { filePath :: FilePath, + fileSize :: FileSize Int + } + deriving (Show) + +defaultRetryCount :: Int +defaultRetryCount = 3 + +cliCommandP :: Parser CliCommand +cliCommandP = + hsubparser + ( command "send" (info (SendFile <$> sendP) (progDesc "Send file")) + <> command "recv" (info (ReceiveFile <$> receiveP) (progDesc "Receive file")) + <> command "del" (info (DeleteFile <$> deleteP) (progDesc "Delete file from server(s)")) + <> command "info" (info (FileDescrInfo <$> infoP) (progDesc "Show file description")) + ) + <|> hsubparser (command "rand" (info (RandomFile <$> randomP) (progDesc "Generate a random file of a given size")) <> internal) + where + sendP :: Parser SendOptions + sendP = + SendOptions + <$> argument str (metavar "FILE" <> help "File to send") + <*> optional (argument str $ metavar "DIR" <> help "Directory to save file descriptions (default: current directory)") + <*> option auto (short 'n' <> metavar "COUNT" <> help "Number of recipients" <> value 1 <> showDefault) + <*> xftpServers + <*> retryCountP + <*> temp + <*> verboseP + receiveP :: Parser ReceiveOptions + receiveP = + ReceiveOptions + <$> fileDescrArg + <*> optional (argument str $ metavar "DIR" <> help "Directory to save file (default: system Downloads directory)") + <*> retryCountP + <*> temp + <*> verboseP + <*> yesP + deleteP :: Parser DeleteOptions + deleteP = + DeleteOptions + <$> fileDescrArg + <*> retryCountP + <*> verboseP + <*> yesP + infoP :: Parser InfoOptions + infoP = InfoOptions <$> fileDescrArg + randomP :: Parser RandomFileOptions + randomP = + RandomFileOptions + <$> argument str (metavar "FILE" <> help "Path to save file") + <*> argument str (metavar "SIZE" <> help "File size (bytes/kb/mb/gb)") + fileDescrArg = argument str (metavar "FILE" <> help "File description file") + retryCountP = option auto (long "retry" <> short 'r' <> metavar "RETRY" <> help "Number of network retries" <> value defaultRetryCount <> showDefault) + temp = optional (strOption $ long "tmp" <> metavar "TMP" <> help "Directory for temporary encrypted file (default: system temp directory)") + verboseP = switch (long "verbose" <> short 'v' <> help "Verbose output") + yesP = switch (long "yes" <> short 'y' <> help "Yes to questions") + xftpServers = + option + parseXFTPServers + ( long "servers" + <> short 's' + <> metavar "SERVER" + <> help "Semicolon-separated list of XFTP server(s) to use (each server can have more than one hostname)" + <> value [] + ) + parseXFTPServers = eitherReader $ parseAll xftpServersP . B.pack + xftpServersP = strP `A.sepBy1` A.char ';' + +data SentFileChunk = SentFileChunk + { chunkNo :: Int, + sndId :: SenderId, + sndPrivateKey :: SndPrivateSignKey, + chunkSize :: FileSize Word32, + digest :: FileDigest, + replicas :: [SentFileChunkReplica] + } + deriving (Eq, Show) + +data SentFileChunkReplica = SentFileChunkReplica + { server :: XFTPServer, + recipients :: [(ChunkReplicaId, C.APrivateSignKey)] + } + deriving (Eq, Show) + +data SentRecipientReplica = SentRecipientReplica + { chunkNo :: Int, + server :: XFTPServer, + rcvNo :: Int, + replicaId :: ChunkReplicaId, + replicaKey :: C.APrivateSignKey, + digest :: FileDigest, + chunkSize :: FileSize Word32 + } + +logCfg :: LogConfig +logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} + +xftpClientCLI :: IO () +xftpClientCLI = + getCliCommand' cliCommandP clientVersion >>= \case + SendFile opts -> runLogE opts $ cliSendFile opts + ReceiveFile opts -> runLogE opts $ cliReceiveFile opts + DeleteFile opts -> runLogE opts $ cliDeleteFile opts + FileDescrInfo opts -> runE $ cliFileDescrInfo opts + RandomFile opts -> cliRandomFile opts + where + clientVersion = "SimpleX XFTP client v" <> xftpClientVersion + +runLogE :: HasField "verbose" a Bool => a -> ExceptT CLIError IO () -> IO () +runLogE opts a + | getField @"verbose" opts = setLogLevel LogDebug >> withGlobalLogging logCfg (runE a) + | otherwise = runE a + +runE :: ExceptT CLIError IO () -> IO () +runE a = + runExceptT a >>= \case + Left (CLIError e) -> putStrLn e >> exitFailure + _ -> pure () + +cliSendFile :: SendOptions -> ExceptT CLIError IO () +cliSendFile SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath, verbose} = do + let (_, fileName) = splitFileName filePath + liftIO $ printNoNewLine "Encrypting file..." + (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload fileName + liftIO $ printNoNewLine "Uploading file..." + uploadedChunks <- newTVarIO [] + sentChunks <- uploadFile chunkSpecs uploadedChunks encSize + whenM (doesFileExist encPath) $ removeFile encPath + -- TODO if only small chunks, use different default size + liftIO $ do + let fdRcvs = createRcvFileDescriptions fdRcv sentChunks + fdSnd' = createSndFileDescription fdSnd sentChunks + (fdRcvPaths, fdSndPath) <- writeFileDescriptions fileName fdRcvs fdSnd' + printNoNewLine "File uploaded!" + putStrLn $ "\nSender file description: " <> fdSndPath + putStrLn "Pass file descriptions to the recipient(s):" + forM_ fdRcvPaths putStrLn + where + encryptFileForUpload :: String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64) + encryptFileForUpload fileName = do + fileSize <- fromInteger <$> getFileSize filePath + when (fileSize > maxFileSize) $ throwError $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported" + encPath <- getEncPath tempPath "xftp" + key <- liftIO C.randomSbKey + nonce <- liftIO C.randomCbNonce + let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing} + fileSize' = fromIntegral (B.length fileHdr) + fileSize + chunkSizes = prepareChunkSizes $ fileSize' + fileSizeLen + authTagSize + defChunkSize = head chunkSizes + chunkSizes' = map fromIntegral chunkSizes + encSize = sum chunkSizes' + withExceptT (CLIError . show) $ encryptFile filePath fileHdr key nonce fileSize' encSize encPath + digest <- liftIO $ LC.sha512Hash <$> LB.readFile encPath + let chunkSpecs = prepareChunkSpecs encPath chunkSizes + fdRcv = FileDescription {party = SFRecipient, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []} + fdSnd = FileDescription {party = SFSender, size = FileSize encSize, digest = FileDigest digest, key, nonce, chunkSize = FileSize defChunkSize, chunks = []} + logInfo $ "encrypted file to " <> tshow encPath + pure (encPath, fdRcv, fdSnd, chunkSpecs, encSize) + uploadFile :: [XFTPChunkSpec] -> TVar [Int64] -> Int64 -> ExceptT CLIError IO [SentFileChunk] + uploadFile chunks uploadedChunks encSize = do + a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig + gen <- newTVarIO =<< liftIO newStdGen + let xftpSrvs = fromMaybe defaultXFTPServers (nonEmpty xftpServers) + srvs <- liftIO $ replicateM (length chunks) $ getXFTPServer gen xftpSrvs + let thd3 (_, _, x) = x + chunks' = groupBy ((==) `on` thd3) $ sortOn thd3 $ zip3 [1 ..] chunks srvs + -- TODO shuffle/unshuffle chunks + -- the reason we don't do pooled downloads here within one server is that http2 library doesn't handle cleint concurrency, even though + -- upload doesn't allow other requests within the same client until complete (but download does allow). + logInfo $ "uploading " <> tshow (length chunks) <> " chunks..." + map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 chunks' (mapM $ uploadFileChunk a) + where + uploadFileChunk :: XFTPClientAgent -> (Int, XFTPChunkSpec, XFTPServerWithAuth) -> ExceptT CLIError IO (Int, SentFileChunk) + uploadFileChunk a (chunkNo, chunkSpec@XFTPChunkSpec {chunkSize}, ProtoServerWithAuth xftpServer auth) = do + logInfo $ "uploading chunk " <> tshow chunkNo <> " to " <> showServer xftpServer <> "..." + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + rKeys <- liftIO $ L.fromList <$> replicateM numRecipients (C.generateSignatureKeyPair C.SEd25519) + ch@FileInfo {digest} <- liftIO $ getChunkInfo sndKey chunkSpec + c <- withRetry retryCount $ getXFTPServerClient a xftpServer + (sndId, rIds) <- withRetry retryCount $ createXFTPChunk c spKey ch (L.map fst rKeys) auth + withReconnect a xftpServer retryCount $ \c' -> uploadXFTPChunk c' spKey sndId chunkSpec + logInfo $ "uploaded chunk " <> tshow chunkNo + uploaded <- atomically . stateTVar uploadedChunks $ \cs -> + let cs' = fromIntegral chunkSize : cs in (sum cs', cs') + liftIO $ do + printProgress "Uploaded" uploaded encSize + when verbose $ putStrLn "" + let recipients = L.toList $ L.map ChunkReplicaId rIds `L.zip` L.map snd rKeys + replicas = [SentFileChunkReplica {server = xftpServer, recipients}] + pure (chunkNo, SentFileChunk {chunkNo, sndId, sndPrivateKey = spKey, chunkSize = FileSize $ fromIntegral chunkSize, digest = FileDigest digest, replicas}) + getChunkInfo :: SndPublicVerifyKey -> XFTPChunkSpec -> IO FileInfo + getChunkInfo sndKey XFTPChunkSpec {filePath = chunkPath, chunkOffset, chunkSize} = + withFile chunkPath ReadMode $ \h -> do + hSeek h AbsoluteSeek $ fromIntegral chunkOffset + digest <- LC.sha256Hash <$> LB.hGet h (fromIntegral chunkSize) + pure FileInfo {sndKey, size = fromIntegral chunkSize, digest} + getXFTPServer :: TVar StdGen -> NonEmpty XFTPServerWithAuth -> IO XFTPServerWithAuth + getXFTPServer gen = \case + srv :| [] -> pure srv + servers -> do + atomically $ (servers L.!!) <$> stateTVar gen (randomR (0, L.length servers - 1)) + + -- M chunks, R replicas, N recipients + -- rcvReplicas: M[SentFileChunk] -> M * R * N [SentRecipientReplica] + -- rcvChunks: M * R * N [SentRecipientReplica] -> N[ M[FileChunk] ] + createRcvFileDescriptions :: FileDescription 'FRecipient -> [SentFileChunk] -> [FileDescription 'FRecipient] + createRcvFileDescriptions fd sentChunks = map (\chunks -> (fd :: (FileDescription 'FRecipient)) {chunks}) rcvChunks + where + rcvReplicas :: [SentRecipientReplica] + rcvReplicas = + concatMap + ( \SentFileChunk {chunkNo, digest, chunkSize, replicas} -> + concatMap + ( \SentFileChunkReplica {server, recipients} -> + zipWith (\rcvNo (replicaId, replicaKey) -> SentRecipientReplica {chunkNo, server, rcvNo, replicaId, replicaKey, digest, chunkSize}) [1 ..] recipients + ) + replicas + ) + sentChunks + rcvChunks :: [[FileChunk]] + rcvChunks = map (sortChunks . M.elems) $ M.elems $ foldl' addRcvChunk M.empty rcvReplicas + sortChunks :: [FileChunk] -> [FileChunk] + 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, replicaId, replicaKey, digest, chunkSize} = + M.alter (Just . addOrChangeRecipient) rcvNo m + where + addOrChangeRecipient :: Maybe (Map Int FileChunk) -> Map Int FileChunk + addOrChangeRecipient = \case + Just m' -> M.alter (Just . addOrChangeChunk) chunkNo m' + _ -> M.singleton chunkNo $ FileChunk {chunkNo, digest, chunkSize, replicas = [replica]} + addOrChangeChunk :: Maybe FileChunk -> FileChunk + addOrChangeChunk = \case + Just ch@FileChunk {replicas} -> ch {replicas = replica : replicas} + _ -> FileChunk {chunkNo, digest, chunkSize, replicas = [replica]} + replica = FileChunkReplica {server, replicaId, replicaKey} + createSndFileDescription :: FileDescription 'FSender -> [SentFileChunk] -> FileDescription 'FSender + 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 'FRecipient] -> FileDescription 'FSender -> IO ([FilePath], FilePath) + writeFileDescriptions fileName fdRcvs fdSnd = do + outDir <- uniqueCombine (fromMaybe "." outputDir) (fileName <> ".xftp") + createDirectoryIfMissing True outDir + 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, verbose, yes} = + getFileDescription' fileDescription >>= receiveFile + where + receiveFile :: ValidFileDescription 'FRecipient -> ExceptT CLIError IO () + receiveFile (ValidFileDescription FileDescription {size, digest, key, nonce, chunks}) = do + encPath <- getEncPath tempPath "xftp" + createDirectory encPath + a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig + liftIO $ printNoNewLine "Downloading file..." + downloadedChunks <- newTVarIO [] + let srv FileChunk {replicas} = server (head replicas :: FileChunkReplica) + srvChunks = groupBy ((==) `on` srv) $ sortOn srv chunks + chunkPaths <- map snd . sortOn fst . concat <$> pooledForConcurrentlyN 16 srvChunks (mapM $ downloadFileChunk a encPath size downloadedChunks) + encDigest <- liftIO $ LC.sha512Hash <$> readChunks chunkPaths + when (encDigest /= unFileDigest digest) $ throwError $ CLIError "File digest mismatch" + encSize <- liftIO $ foldM (\s path -> (s +) . fromIntegral <$> getFileSize path) 0 chunkPaths + when (FileSize encSize /= size) $ throwError $ CLIError "File size mismatch" + liftIO $ printNoNewLine "Decrypting file..." + path <- withExceptT cliCryptoError $ decryptChunks encSize chunkPaths key nonce getFilePath + forM_ chunks $ acknowledgeFileChunk a + whenM (doesPathExist encPath) $ removeDirectoryRecursive encPath + liftIO $ do + printNoNewLine $ "File downloaded: " <> path + removeFD yes fileDescription + downloadFileChunk :: XFTPClientAgent -> FilePath -> FileSize Int64 -> TVar [Int64] -> FileChunk -> ExceptT CLIError IO (Int, FilePath) + downloadFileChunk a encPath (FileSize encSize) downloadedChunks FileChunk {chunkNo, chunkSize, digest, replicas = replica : _} = do + let FileChunkReplica {server, replicaId, replicaKey} = replica + logInfo $ "downloading chunk " <> tshow chunkNo <> " from " <> showServer server <> "..." + chunkPath <- uniqueCombine encPath $ show chunkNo + let chunkSpec = XFTPRcvChunkSpec chunkPath (unFileSize chunkSize) (unFileDigest digest) + withReconnect a server retryCount $ \c -> downloadXFTPChunk c replicaKey (unChunkReplicaId replicaId) chunkSpec + logInfo $ "downloaded chunk " <> tshow chunkNo <> " to " <> T.pack chunkPath + downloaded <- atomically . stateTVar downloadedChunks $ \cs -> + let cs' = fromIntegral (unFileSize chunkSize) : cs in (sum cs', cs') + liftIO $ do + printProgress "Downloaded" downloaded encSize + when verbose $ putStrLn "" + pure (chunkNo, chunkPath) + downloadFileChunk _ _ _ _ _ = throwError $ CLIError "chunk has no replicas" + getFilePath :: String -> ExceptT String IO FilePath + getFilePath name = + case filePath of + Just path -> + ifM (doesDirectoryExist path) (uniqueCombine path name) $ + ifM (doesFileExist path) (throwError "File already exists") (pure path) + _ -> (`uniqueCombine` name) . ( "Downloads") =<< getHomeDirectory + acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO () + acknowledgeFileChunk a FileChunk {replicas = replica : _} = do + let FileChunkReplica {server, replicaId, replicaKey} = replica + c <- withRetry retryCount $ getXFTPServerClient a server + withRetry retryCount $ ackXFTPChunk c replicaKey (unChunkReplicaId replicaId) + acknowledgeFileChunk _ _ = throwError $ CLIError "chunk has no replicas" + +printProgress :: String -> Int64 -> Int64 -> IO () +printProgress s part total = printNoNewLine $ s <> " " <> show ((part * 100) `div` total) <> "%" + +printNoNewLine :: String -> IO () +printNoNewLine s = do + putStr $ s <> replicate (max 0 $ 25 - length s) ' ' <> "\r" + hFlush stdout + +cliDeleteFile :: DeleteOptions -> ExceptT CLIError IO () +cliDeleteFile DeleteOptions {fileDescription, retryCount, yes} = do + getFileDescription' fileDescription >>= deleteFile + where + deleteFile :: ValidFileDescription 'FSender -> ExceptT CLIError IO () + deleteFile (ValidFileDescription FileDescription {chunks}) = do + a <- atomically $ newXFTPAgent defaultXFTPClientAgentConfig + forM_ chunks $ deleteFileChunk a + liftIO $ do + printNoNewLine "File deleted!" + removeFD yes fileDescription + deleteFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO () + deleteFileChunk a FileChunk {chunkNo, replicas = replica : _} = do + let FileChunkReplica {server, replicaId, replicaKey} = replica + withReconnect a server retryCount $ \c -> deleteXFTPChunk c replicaKey (unChunkReplicaId replicaId) + logInfo $ "deleted chunk " <> tshow chunkNo <> " from " <> showServer server + deleteFileChunk _ _ = throwError $ CLIError "chunk has no replicas" + +cliFileDescrInfo :: InfoOptions -> ExceptT CLIError IO () +cliFileDescrInfo InfoOptions {fileDescription} = do + 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 + SFRecipient -> putStrLn "Recipient file description" + SFSender -> putStrLn "Sender file description" + +strEnc :: StrEncoding a => a -> String +strEnc = B.unpack . strEncode + +getFileDescription :: FilePath -> ExceptT CLIError IO AValidFileDescription +getFileDescription path = + ExceptT $ first (CLIError . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path + +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 size' = prepareSizes size' + where + (smallSize, bigSize) = if size' > size34 chunkSize3 then (chunkSize2, chunkSize3) else (chunkSize1, chunkSize2) + size34 sz = (fromIntegral sz * 3) `div` 4 + prepareSizes 0 = [] + prepareSizes size + | size >= fromIntegral bigSize = replicate (fromIntegral n1) bigSize <> prepareSizes remSz + | size > size34 bigSize = [bigSize] + | otherwise = replicate (fromIntegral n2') smallSize + where + (n1, remSz) = size `divMod` fromIntegral bigSize + n2' = let (n2, remSz2) = (size `divMod` fromIntegral smallSize) in if remSz2 == 0 then n2 else n2 + 1 + +prepareChunkSpecs :: FilePath -> [Word32] -> [XFTPChunkSpec] +prepareChunkSpecs filePath chunkSizes = reverse . snd $ foldl' addSpec (0, []) chunkSizes + where + addSpec :: (Int64, [XFTPChunkSpec]) -> Word32 -> (Int64, [XFTPChunkSpec]) + addSpec (chunkOffset, specs) sz = + let spec = XFTPChunkSpec {filePath, chunkOffset, chunkSize = fromIntegral sz} + in (chunkOffset + fromIntegral sz, spec : specs) + +getEncPath :: MonadIO m => Maybe FilePath -> String -> m FilePath +getEncPath path name = (`uniqueCombine` (name <> ".encrypted")) =<< maybe (liftIO getCanonicalTemporaryDirectory) pure path + +withReconnect :: Show e => XFTPClientAgent -> XFTPServer -> Int -> (XFTPClient -> ExceptT e IO a) -> ExceptT CLIError IO a +withReconnect a srv n run = withRetry n $ do + c <- withRetry n $ getXFTPServerClient a srv + withExceptT (CLIError . show) (run c) `catchError` \e -> do + liftIO $ closeXFTPServerClient a srv + throwError e + +withRetry :: Show e => Int -> ExceptT e IO a -> ExceptT CLIError IO a +withRetry retryCount = withRetry' retryCount . withExceptT (CLIError . show) + where + withRetry' :: Int -> ExceptT CLIError IO a -> ExceptT CLIError IO a + withRetry' 0 _ = throwError $ CLIError "internal: no retry attempts" + withRetry' 1 a = a + withRetry' n a = + a `catchError` \e -> do + logWarn ("retrying: " <> tshow e) + withRetry' (n - 1) a + +removeFD :: Bool -> FilePath -> IO () +removeFD yes fd + | yes = do + removeFile fd + putStrLn $ "\nFile description " <> fd <> " is deleted." + | otherwise = do + y <- liftIO . getConfirmation $ "\nFile description " <> fd <> " can't be used again. Delete it" + when y $ removeFile fd + +getConfirmation :: String -> IO Bool +getConfirmation prompt = do + putStr $ prompt <> " (Y/n): " + hFlush stdout + s <- getLine + case map toLower s of + "y" -> pure True + "" -> pure True + "n" -> pure False + _ -> getConfirmation prompt + +cliRandomFile :: RandomFileOptions -> IO () +cliRandomFile RandomFileOptions {filePath, fileSize = FileSize size} = do + withFile filePath WriteMode (`saveRandomFile` size) + putStrLn $ "File created: " <> filePath + where + saveRandomFile h sz = do + bytes <- getRandomBytes $ min mb' sz + B.hPut h bytes + when (sz > mb') $ saveRandomFile h (sz - mb') + mb' = mb 1 diff --git a/src/Simplex/FileTransfer/Client/Presets.hs b/src/Simplex/FileTransfer/Client/Presets.hs new file mode 100644 index 000000000..daf7b7be3 --- /dev/null +++ b/src/Simplex/FileTransfer/Client/Presets.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.FileTransfer.Client.Presets where + +import Data.List.NonEmpty (NonEmpty) +import Simplex.Messaging.Protocol (XFTPServerWithAuth) + +defaultXFTPServers :: NonEmpty XFTPServerWithAuth +defaultXFTPServers = + [ "xftp://da1aH3nOT-9G8lV7bWamhxpDYdJ1xmW7j3JpGaDR5Ug=@xftp1.simplex.im", + "xftp://5vog2Imy1ExJB_7zDZrkV1KDWi96jYFyy9CL6fndBVw=@xftp2.simplex.im", + "xftp://PYa32DdYNFWi0uZZOprWQoQpIk5qyjRJ3EF7bVpbsn8=@xftp3.simplex.im", + "xftp://k_GgQl40UZVV0Y4BX9ZTyMVqX5ZewcLW0waQIl7AYDE=@xftp4.simplex.im", + "xftp://-bIo6o8wuVc4wpZkZD3tH-rCeYaeER_0lz1ffQcSJDs=@xftp5.simplex.im", + "xftp://6nSvtY9pJn6PXWTAIMNl95E1Kk1vD7FM2TeOA64CFLg=@xftp6.simplex.im" + ] diff --git a/src/Simplex/FileTransfer/Crypto.hs b/src/Simplex/FileTransfer/Crypto.hs new file mode 100644 index 000000000..71f5dec96 --- /dev/null +++ b/src/Simplex/FileTransfer/Crypto.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.FileTransfer.Crypto where + +import Control.Monad.Except +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) +import qualified Data.ByteArray as BA +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Int (Int64) +import Simplex.FileTransfer.Types (FileHeader (..), authTagSize) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Lazy (LazyByteString) +import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Encoding +import Simplex.Messaging.Util (liftEitherWith) +import UnliftIO +import UnliftIO.Directory (removeFile) + +encryptFile :: FilePath -> ByteString -> C.SbKey -> C.CbNonce -> Int64 -> Int64 -> FilePath -> ExceptT FTCryptoError IO () +encryptFile filePath fileHdr key nonce fileSize' encSize encFile = do + sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce + withFile filePath ReadMode $ \r -> withFile encFile WriteMode $ \w -> do + let lenStr = smpEncode fileSize' + (hdr, !sb') = LC.sbEncryptChunk sb $ lenStr <> fileHdr + padLen = encSize - authTagSize - fileSize' - 8 + liftIO $ B.hPut w hdr + sb2 <- encryptChunks r w (sb', fileSize' - fromIntegral (B.length fileHdr)) + sb3 <- encryptPad w (sb2, padLen) + let tag = BA.convert $ LC.sbAuth sb3 + liftIO $ B.hPut w tag + where + encryptChunks r = encryptChunks_ $ liftIO . B.hGet r . fromIntegral + encryptPad = encryptChunks_ $ \sz -> pure $ B.replicate (fromIntegral sz) '#' + encryptChunks_ :: (Int64 -> IO ByteString) -> Handle -> (LC.SbState, Int64) -> ExceptT FTCryptoError IO LC.SbState + encryptChunks_ get w (!sb, !len) + | len == 0 = pure sb + | otherwise = do + let chSize = min len 65536 + ch <- liftIO $ get chSize + when (B.length ch /= fromIntegral chSize) $ throwError $ FTCEFileIOError "encrypting file: unexpected EOF" + let (ch', sb') = LC.sbEncryptChunk sb ch + liftIO $ B.hPut w ch' + encryptChunks_ get w (sb', len - chSize) + +decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO String) -> ExceptT FTCryptoError IO FilePath +decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty" +decryptChunks encSize (chPath : chPaths) key nonce getFilePath = case reverse chPaths of + [] -> do + (!authOk, !f) <- liftEither . first FTCECryptoError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (LB.readFile chPath) + unless authOk $ throwError FTCEInvalidAuthTag + (FileHeader {fileName}, !f') <- parseFileHeader f + path <- withExceptT FTCEFileIOError $ getFilePath fileName + liftIO $ LB.writeFile path f' + pure path + lastPath : chPaths' -> do + (state, expectedLen, ch) <- decryptFirstChunk + (FileHeader {fileName}, ch') <- parseFileHeader ch + path <- withExceptT FTCEFileIOError $ getFilePath fileName + authOk <- liftIO . withFile path WriteMode $ \h -> do + liftIO $ LB.hPut h ch' + state' <- foldM (decryptChunk h) state $ reverse chPaths' + decryptLastChunk h state' expectedLen + unless authOk $ do + removeFile path + throwError FTCEInvalidAuthTag + pure path + where + decryptFirstChunk = do + sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce + ch <- liftIO $ LB.readFile chPath + let (ch1, !sb') = LC.sbDecryptChunkLazy sb ch + (!expectedLen, ch2) <- liftEitherWith FTCECryptoError $ LC.splitLen ch1 + let len1 = LB.length ch2 + pure ((sb', len1), expectedLen, ch2) + decryptChunk h (!sb, !len) chPth = do + ch <- LB.readFile chPth + let len' = len + LB.length ch + (ch', sb') = LC.sbDecryptChunkLazy sb ch + LB.hPut h ch' + pure (sb', len') + decryptLastChunk h (!sb, !len) expectedLen = do + ch <- LB.readFile lastPath + let (ch1, tag') = LB.splitAt (LB.length ch - authTagSize) ch + tag'' = LB.toStrict tag' + (ch2, sb') = LC.sbDecryptChunkLazy sb ch1 + len' = len + LB.length ch2 + ch3 = LB.take (LB.length ch2 - len' + expectedLen) ch2 + tag :: ByteString = BA.convert (LC.sbAuth sb') + LB.hPut h ch3 + pure $ B.length tag'' == 16 && BA.constEq tag'' tag + where + parseFileHeader :: LazyByteString -> ExceptT FTCryptoError IO (FileHeader, LazyByteString) + parseFileHeader s = do + let (hdrStr, s') = LB.splitAt 1024 s + case A.parse smpP $ LB.toStrict hdrStr of + A.Fail _ _ e -> throwError $ FTCEInvalidHeader e + A.Partial _ -> throwError $ FTCEInvalidHeader "incomplete" + A.Done rest hdr -> pure (hdr, LB.fromStrict rest <> s') + +readChunks :: [FilePath] -> IO LB.ByteString +readChunks = foldM (\s path -> (s <>) <$> LB.readFile path) "" + +data FTCryptoError + = FTCECryptoError C.CryptoError + | FTCEInvalidHeader String + | FTCEInvalidAuthTag + | FTCEFileIOError String + deriving (Show, Eq, Exception) diff --git a/src/Simplex/FileTransfer/Description.hs b/src/Simplex/FileTransfer/Description.hs new file mode 100644 index 000000000..c995f0dcd --- /dev/null +++ b/src/Simplex/FileTransfer/Description.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.FileTransfer.Description + ( FileDescription (..), + AFileDescription (..), + ValidFileDescription, -- constructor is not exported, use pattern + pattern ValidFileDescription, + AValidFileDescription (..), + FileDigest (..), + FileChunk (..), + FileChunkReplica (..), + FileServerReplica (..), + FileSize (..), + ChunkReplicaId (..), + YAMLFileDescription (..), -- for tests + YAMLServerReplicas (..), -- for tests + validateFileDescription, + groupReplicasByServer, + replicaServer, + fdSeparator, + kb, + mb, + gb, + ) +where + +import Control.Applicative (optional) +import Control.Monad ((<=<)) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as J +import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Bifunctor (first) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Function (on) +import Data.Int (Int64) +import Data.List (foldl', groupBy, sortOn) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import Data.String +import Data.Word (Word32) +import qualified Data.Yaml as Y +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +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 (p :: FileParty) = FileDescription + { party :: SFileParty p, + size :: FileSize Int64, + digest :: FileDigest, + key :: C.SbKey, + nonce :: C.CbNonce, + chunkSize :: FileSize Word32, + chunks :: [FileChunk] + } + deriving (Eq, Show) + +data AFileDescription = forall p. FilePartyI p => AFD (FileDescription p) + +newtype ValidFileDescription p = ValidFD (FileDescription p) + deriving (Eq, Show) + +pattern ValidFileDescription :: FileDescription p -> ValidFileDescription p +pattern ValidFileDescription fd = ValidFD fd + +{-# COMPLETE ValidFileDescription #-} + +data AValidFileDescription = forall p. FilePartyI p => AVFD (ValidFileDescription p) + +fdSeparator :: IsString s => s +fdSeparator = "################################\n" + +newtype FileDigest = FileDigest {unFileDigest :: ByteString} + deriving (Eq, Show) + +instance StrEncoding FileDigest where + strEncode (FileDigest fd) = strEncode fd + strDecode s = FileDigest <$> strDecode s + strP = FileDigest <$> strP + +instance FromJSON FileDigest where + parseJSON = strParseJSON "FileDigest" + +instance ToJSON FileDigest where + toJSON = strToJSON + toEncoding = strToJEncoding + +instance FromField FileDigest where fromField f = FileDigest <$> fromField f + +instance ToField FileDigest where toField (FileDigest s) = toField s + +data FileChunk = FileChunk + { chunkNo :: Int, + chunkSize :: FileSize Word32, + digest :: FileDigest, + replicas :: [FileChunkReplica] + } + deriving (Eq, Show) + +data FileChunkReplica = FileChunkReplica + { server :: XFTPServer, + replicaId :: ChunkReplicaId, + replicaKey :: C.APrivateSignKey + } + deriving (Eq, Show) + +newtype ChunkReplicaId = ChunkReplicaId {unChunkReplicaId :: ByteString} + deriving (Eq, Show) + +instance StrEncoding ChunkReplicaId where + strEncode (ChunkReplicaId fid) = strEncode fid + strP = ChunkReplicaId <$> strP + +instance FromJSON ChunkReplicaId where + parseJSON = strParseJSON "ChunkReplicaId" + +instance ToJSON ChunkReplicaId where + toJSON = strToJSON + toEncoding = strToJEncoding + +instance FromField ChunkReplicaId where fromField f = ChunkReplicaId <$> fromField f + +instance ToField ChunkReplicaId where toField (ChunkReplicaId s) = toField s + +data YAMLFileDescription = YAMLFileDescription + { party :: FileParty, + size :: String, + digest :: FileDigest, + key :: C.SbKey, + nonce :: C.CbNonce, + chunkSize :: String, + replicas :: [YAMLServerReplicas] + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON YAMLFileDescription where + toJSON = J.genericToJSON J.defaultOptions + toEncoding = J.genericToEncoding J.defaultOptions + +data YAMLServerReplicas = YAMLServerReplicas + { server :: XFTPServer, + chunks :: [String] + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON YAMLServerReplicas where + toJSON = J.genericToJSON J.defaultOptions + toEncoding = J.genericToEncoding J.defaultOptions + +data FileServerReplica = FileServerReplica + { chunkNo :: Int, + server :: XFTPServer, + replicaId :: ChunkReplicaId, + replicaKey :: C.APrivateSignKey, + digest :: Maybe FileDigest, + chunkSize :: Maybe (FileSize Word32) + } + deriving (Show) + +instance FilePartyI p => StrEncoding (ValidFileDescription p) where + strEncode (ValidFD fd) = strEncode fd + strDecode s = strDecode s >>= (\(AVFD fd) -> checkParty fd) + strP = strDecode <$?> A.takeByteString + +instance StrEncoding AValidFileDescription where + strEncode (AVFD fd) = strEncode fd + strDecode = validateFileDescription <=< strDecode + strP = strDecode <$?> A.takeByteString + +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 :: 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 p -> YAMLFileDescription +encodeFileDescription FileDescription {party, size, digest, key, nonce, chunkSize, chunks} = + YAMLFileDescription + { party = toFileParty party, + size = B.unpack $ strEncode size, + digest, + key, + nonce, + chunkSize = B.unpack $ strEncode chunkSize, + replicas = encodeFileReplicas chunkSize chunks + } + +newtype FileSize a = FileSize {unFileSize :: a} + deriving (Eq, Show) + +instance (Integral a, Show a) => StrEncoding (FileSize a) where + strEncode (FileSize b) + | b' /= 0 = bshow b + | ks' /= 0 = bshow ks <> "kb" + | ms' /= 0 = bshow ms <> "mb" + | otherwise = bshow gs <> "gb" + where + (ks, b') = b `divMod` 1024 + (ms, ks') = ks `divMod` 1024 + (gs, ms') = ms `divMod` 1024 + strP = + FileSize + <$> A.choice + [ gb <$> A.decimal <* "gb", + mb <$> A.decimal <* "mb", + kb <$> A.decimal <* "kb", + A.decimal + ] + +kb :: Integral a => a -> a +kb n = 1024 * n +{-# INLINE kb #-} + +mb :: Integral a => a -> a +mb n = 1024 * kb n +{-# INLINE mb #-} + +gb :: Integral a => a -> a +gb n = 1024 * mb n +{-# INLINE gb #-} + +instance (Integral a, Show a) => IsString (FileSize a) where + fromString = either error id . strDecode . B.pack + +instance (FromField a) => FromField (FileSize a) where fromField f = FileSize <$> fromField f + +instance (ToField a) => ToField (FileSize a) where toField (FileSize s) = toField s + +groupReplicasByServer :: FileSize Word32 -> [FileChunk] -> [[FileServerReplica]] +groupReplicasByServer defChunkSize = + groupBy ((==) `on` replicaServer) + . sortOn replicaServer + . unfoldChunksToReplicas defChunkSize + +encodeFileReplicas :: FileSize Word32 -> [FileChunk] -> [YAMLServerReplicas] +encodeFileReplicas defChunkSize = + map encodeServerReplicas . groupReplicasByServer defChunkSize + where + encodeServerReplicas fs = + YAMLServerReplicas + { server = replicaServer $ head fs, -- groupBy guarantees that fs is not empty + chunks = map (B.unpack . encodeServerReplica) fs + } + +replicaServer :: FileServerReplica -> XFTPServer +replicaServer = server + +encodeServerReplica :: FileServerReplica -> ByteString +encodeServerReplica FileServerReplica {chunkNo, replicaId, replicaKey, digest, chunkSize} = + bshow chunkNo + <> ":" + <> strEncode replicaId + <> ":" + <> strEncode replicaKey + <> maybe "" ((":" <>) . strEncode) digest + <> maybe "" ((":" <>) . strEncode) chunkSize + +serverReplicaP :: XFTPServer -> Parser FileServerReplica +serverReplicaP server = do + chunkNo <- A.decimal + replicaId <- A.char ':' *> strP + replicaKey <- A.char ':' *> strP + digest <- optional (A.char ':' *> strP) + chunkSize <- optional (A.char ':' *> strP) + 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, 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, replicaId, replicaKey, digest = digest', chunkSize = chunkSize'} + +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 $ case aFileParty party of + AFP party' -> AFD FileDescription {party = party', size = size', digest, key, nonce, chunkSize = chunkSize', chunks} + where + decodeFileParts = fmap concat . mapM decodeYAMLServerReplicas + +decodeYAMLServerReplicas :: YAMLServerReplicas -> Either String [FileServerReplica] +decodeYAMLServerReplicas YAMLServerReplicas {server, chunks} = + mapM (parseAll (serverReplicaP server) . B.pack) chunks + +-- this function should fail if: +-- 1. no replica has digest or two replicas have different digests +-- 2. two replicas have different chunk sizes +foldReplicasToChunks :: FileSize Word32 -> [FileServerReplica] -> Either String [FileChunk] +foldReplicasToChunks defChunkSize fs = do + sd <- foldSizesDigests fs + -- TODO validate (check that chunks match) or in separate function + sortOn (chunkNo :: FileChunk -> Int) . map reverseReplicas . M.elems <$> foldChunks sd fs + where + foldSizesDigests :: [FileServerReplica] -> Either String (Map Int (FileSize Word32), Map Int FileDigest) + foldSizesDigests = foldl' addSizeDigest $ Right (M.empty, M.empty) + addSizeDigest :: Either String (Map Int (FileSize Word32), Map Int FileDigest) -> FileServerReplica -> Either String (Map Int (FileSize Word32), Map Int FileDigest) + addSizeDigest (Left e) _ = Left e + addSizeDigest (Right (ms, md)) FileServerReplica {chunkNo, chunkSize, digest} = + (,) <$> combineChunk ms chunkNo chunkSize <*> combineChunk md chunkNo digest + combineChunk :: Eq a => Map Int a -> Int -> Maybe a -> Either String (Map Int a) + combineChunk m _ Nothing = Right m + combineChunk m chunkNo (Just value) = case M.lookup chunkNo m of + Nothing -> Right $ M.insert chunkNo value m + Just v -> if v == value then Right m else Left "different size or digest in chunk replicas" + foldChunks :: (Map Int (FileSize Word32), Map Int FileDigest) -> [FileServerReplica] -> Either String (Map Int FileChunk) + 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, replicaId, replicaKey} = do + case M.lookup chunkNo cs of + Just chunk@FileChunk {replicas} -> + 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, 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 + _ -> Left "no digest for chunk" + reverseReplicas c@FileChunk {replicas} = (c :: FileChunk) {replicas = reverse replicas} diff --git a/src/Simplex/FileTransfer/Protocol.hs b/src/Simplex/FileTransfer/Protocol.hs new file mode 100644 index 000000000..a10917a61 --- /dev/null +++ b/src/Simplex/FileTransfer/Protocol.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} + +module Simplex.FileTransfer.Protocol where + +import Control.Applicative ((<|>)) +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) +import qualified Data.ByteString.Char8 as B +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (isNothing) +import Data.Type.Equality +import Data.Word (Word32) +import GHC.Generics (Generic) +import Generic.Random (genericArbitraryU) +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 + ( BasicAuth, + CommandError (..), + Protocol (..), + ProtocolEncoding (..), + ProtocolErrorType (..), + ProtocolMsgTag (..), + ProtocolType (..), + RcvPublicDhKey, + RcvPublicVerifyKey, + RecipientId, + SenderId, + SentRawTransmission, + SignedTransmission, + SndPublicVerifyKey, + Transmission, + encodeTransmission, + messageTagP, + tDecodeParseValidate, + tEncode, + tEncodeBatch, + tParse, + _smpP, + ) +import Simplex.Messaging.Transport (SessionId, TransportError (..)) +import Simplex.Messaging.Util (bshow, (<$?>)) +import Simplex.Messaging.Version +import Test.QuickCheck (Arbitrary (..)) + +currentXFTPVersion :: Version +currentXFTPVersion = 1 + +xftpBlockSize :: Int +xftpBlockSize = 16384 + +-- | File protocol clients +data FileParty = FRecipient | FSender + deriving (Eq, Show, Generic) + +instance FromJSON FileParty where + parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "F" + +instance ToJSON FileParty where + toJSON = J.genericToJSON . enumJSON $ dropPrefix "F" + toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "F" + +data SFileParty :: FileParty -> Type where + SFRecipient :: SFileParty FRecipient + SFSender :: SFileParty FSender + +instance TestEquality SFileParty where + testEquality SFRecipient SFRecipient = Just Refl + testEquality SFSender SFSender = 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 + SFRecipient -> FRecipient + SFSender -> FSender + +aFileParty :: FileParty -> AFileParty +aFileParty = \case + FRecipient -> AFP SFRecipient + FSender -> AFP SFSender + +class FilePartyI (p :: FileParty) where sFileParty :: SFileParty p + +instance FilePartyI FRecipient where sFileParty = SFRecipient + +instance FilePartyI FSender where sFileParty = SFSender + +data FileCommandTag (p :: FileParty) where + FNEW_ :: FileCommandTag FSender + FADD_ :: FileCommandTag FSender + FPUT_ :: FileCommandTag FSender + FDEL_ :: FileCommandTag FSender + FGET_ :: FileCommandTag FRecipient + FACK_ :: FileCommandTag FRecipient + PING_ :: FileCommandTag FRecipient + +deriving instance Show (FileCommandTag p) + +data FileCmdTag = forall p. FilePartyI p => FCT (SFileParty p) (FileCommandTag p) + +instance FilePartyI p => Encoding (FileCommandTag p) where + smpEncode = \case + FNEW_ -> "FNEW" + FADD_ -> "FADD" + FPUT_ -> "FPUT" + FDEL_ -> "FDEL" + FGET_ -> "FGET" + FACK_ -> "FACK" + PING_ -> "PING" + smpP = messageTagP + +instance Encoding FileCmdTag where + smpEncode (FCT _ t) = smpEncode t + smpP = messageTagP + +instance ProtocolMsgTag FileCmdTag where + decodeTag = \case + "FNEW" -> Just $ FCT SFSender FNEW_ + "FADD" -> Just $ FCT SFSender FADD_ + "FPUT" -> Just $ FCT SFSender FPUT_ + "FDEL" -> Just $ FCT SFSender FDEL_ + "FGET" -> Just $ FCT SFRecipient FGET_ + "FACK" -> Just $ FCT SFRecipient FACK_ + "PING" -> Just $ FCT SFRecipient PING_ + _ -> Nothing + +instance FilePartyI p => ProtocolMsgTag (FileCommandTag p) where + decodeTag s = decodeTag s >>= (\(FCT _ t) -> checkParty' t) + +instance Protocol XFTPErrorType FileResponse where + type ProtoCommand FileResponse = FileCmd + type ProtoType FileResponse = 'PXFTP + protocolClientHandshake = ntfClientHandshake + protocolPing = FileCmd SFRecipient PING + protocolError = \case + FRErr e -> Just e + _ -> Nothing + +data FileCommand (p :: FileParty) where + FNEW :: FileInfo -> NonEmpty RcvPublicVerifyKey -> Maybe BasicAuth -> FileCommand FSender + FADD :: NonEmpty RcvPublicVerifyKey -> FileCommand FSender + FPUT :: FileCommand FSender + FDEL :: FileCommand FSender + FGET :: RcvPublicDhKey -> FileCommand FRecipient + FACK :: FileCommand FRecipient + PING :: FileCommand FRecipient + +deriving instance Show (FileCommand p) + +data FileCmd = forall p. FilePartyI p => FileCmd (SFileParty p) (FileCommand p) + +deriving instance Show FileCmd + +data FileInfo = FileInfo + { sndKey :: SndPublicVerifyKey, + size :: Word32, + digest :: ByteString + } + deriving (Eq, Show) + +type XFTPFileId = ByteString + +instance FilePartyI p => ProtocolEncoding XFTPErrorType (FileCommand p) where + type Tag (FileCommand p) = FileCommandTag p + encodeProtocol _v = \case + FNEW file rKeys auth_ -> e (FNEW_, ' ', file, rKeys, auth_) + FADD rKeys -> e (FADD_, ' ', rKeys) + FPUT -> e FPUT_ + FDEL -> e FDEL_ + FGET rKey -> e (FGET_, ' ', rKey) + FACK -> e FACK_ + PING -> e PING_ + where + e :: Encoding a => a -> ByteString + e = smpEncode + + protocolP v tag = (\(FileCmd _ c) -> checkParty c) <$?> protocolP v (FCT (sFileParty @p) tag) + + fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse + {-# INLINE fromProtocolError #-} + + checkCredentials (sig, _, fileId, _) cmd = case cmd of + -- FNEW must not have signature and chunk ID + FNEW {} + | isNothing sig -> Left $ CMD NO_AUTH + | not (B.null fileId) -> Left $ CMD HAS_AUTH + | otherwise -> Right cmd + PING + | isNothing sig && B.null fileId -> Right cmd + | otherwise -> Left $ CMD HAS_AUTH + -- other client commands must have both signature and queue ID + _ + | isNothing sig || B.null fileId -> Left $ CMD NO_AUTH + | otherwise -> Right cmd + +instance ProtocolEncoding XFTPErrorType FileCmd where + type Tag FileCmd = FileCmdTag + encodeProtocol _v (FileCmd _ c) = encodeProtocol _v c + + protocolP _v = \case + FCT SFSender tag -> + FileCmd SFSender <$> case tag of + FNEW_ -> FNEW <$> _smpP <*> smpP <*> smpP + FADD_ -> FADD <$> _smpP + FPUT_ -> pure FPUT + FDEL_ -> pure FDEL + FCT SFRecipient tag -> + FileCmd SFRecipient <$> case tag of + FGET_ -> FGET <$> _smpP + FACK_ -> pure FACK + PING_ -> pure PING + + fromProtocolError = fromProtocolError @XFTPErrorType @FileResponse + {-# INLINE fromProtocolError #-} + + checkCredentials t (FileCmd p c) = FileCmd p <$> checkCredentials t c + +instance Encoding FileInfo where + smpEncode FileInfo {sndKey, size, digest} = smpEncode (sndKey, size, digest) + smpP = FileInfo <$> smpP <*> smpP <*> smpP + +instance StrEncoding FileInfo where + strEncode FileInfo {sndKey, size, digest} = strEncode (sndKey, size, digest) + strP = FileInfo <$> strP_ <*> strP_ <*> strP + +data FileResponseTag + = FRSndIds_ + | FRRcvIds_ + | FRFile_ + | FROk_ + | FRErr_ + | FRPong_ + deriving (Show) + +instance Encoding FileResponseTag where + smpEncode = \case + FRSndIds_ -> "SIDS" + FRRcvIds_ -> "RIDS" + FRFile_ -> "FILE" + FROk_ -> "OK" + FRErr_ -> "ERR" + FRPong_ -> "PONG" + smpP = messageTagP + +instance ProtocolMsgTag FileResponseTag where + decodeTag = \case + "SIDS" -> Just FRSndIds_ + "RIDS" -> Just FRRcvIds_ + "FILE" -> Just FRFile_ + "OK" -> Just FROk_ + "ERR" -> Just FRErr_ + "PONG" -> Just FRPong_ + _ -> Nothing + +data FileResponse + = FRSndIds SenderId (NonEmpty RecipientId) + | FRRcvIds (NonEmpty RecipientId) + | FRFile RcvPublicDhKey C.CbNonce + | FROk + | FRErr XFTPErrorType + | FRPong + deriving (Show) + +instance ProtocolEncoding XFTPErrorType FileResponse where + type Tag FileResponse = FileResponseTag + encodeProtocol _v = \case + FRSndIds fId rIds -> e (FRSndIds_, ' ', fId, rIds) + FRRcvIds rIds -> e (FRRcvIds_, ' ', rIds) + FRFile rDhKey nonce -> e (FRFile_, ' ', rDhKey, nonce) + FROk -> e FROk_ + FRErr err -> e (FRErr_, ' ', err) + FRPong -> e FRPong_ + where + e :: Encoding a => a -> ByteString + e = smpEncode + + protocolP _v = \case + FRSndIds_ -> FRSndIds <$> _smpP <*> smpP + FRRcvIds_ -> FRRcvIds <$> _smpP + FRFile_ -> FRFile <$> _smpP <*> smpP + FROk_ -> pure FROk + FRErr_ -> FRErr <$> _smpP + FRPong_ -> pure FRPong + + fromProtocolError = \case + PECmdSyntax -> CMD SYNTAX + PECmdUnknown -> CMD UNKNOWN + PESession -> SESSION + PEBlock -> BLOCK + {-# INLINE fromProtocolError #-} + + checkCredentials (_, _, entId, _) cmd = case cmd of + FRSndIds {} -> noEntity + -- ERR response does not always have entity ID + FRErr _ -> Right cmd + -- PONG response must not have queue ID + FRPong -> noEntity + -- other server responses must have entity ID + _ + | B.null entId -> Left $ CMD NO_ENTITY + | otherwise -> Right cmd + where + noEntity + | B.null entId = Right cmd + | otherwise = Left $ CMD HAS_AUTH + +data XFTPErrorType + = -- | incorrect block format, encoding or signature size + BLOCK + | -- | incorrect SMP session ID (TLS Finished message / tls-unique binding RFC5929) + SESSION + | -- | SMP command is unknown or has invalid syntax + CMD {cmdErr :: CommandError} + | -- | command authorization error - bad signature or non-existing SMP queue + AUTH + | -- | incorrent file size + SIZE + | -- | storage quota exceeded + QUOTA + | -- | incorrent file digest + DIGEST + | -- | file encryption/decryption failed + CRYPTO + | -- | no expected file body in request/response or no file on the server + NO_FILE + | -- | unexpected file body + HAS_FILE + | -- | file IO error + FILE_IO + | -- | internal server error + INTERNAL + | -- | used internally, never returned by the server (to be removed) + DUPLICATE_ -- not part of SMP protocol, used internally + deriving (Eq, Generic, Read, Show) + +instance ToJSON XFTPErrorType where + toJSON = J.genericToJSON $ sumTypeJSON id + toEncoding = J.genericToEncoding $ sumTypeJSON id + +instance StrEncoding XFTPErrorType where + strEncode = \case + CMD e -> "CMD " <> bshow e + e -> bshow e + strP = "CMD " *> (CMD <$> parseRead1) <|> parseRead1 + +instance Arbitrary XFTPErrorType where arbitrary = genericArbitraryU + +instance Encoding XFTPErrorType where + smpEncode = \case + BLOCK -> "BLOCK" + SESSION -> "SESSION" + CMD err -> "CMD " <> smpEncode err + AUTH -> "AUTH" + SIZE -> "SIZE" + QUOTA -> "QUOTA" + DIGEST -> "DIGEST" + CRYPTO -> "CRYPTO" + NO_FILE -> "NO_FILE" + HAS_FILE -> "HAS_FILE" + FILE_IO -> "FILE_IO" + INTERNAL -> "INTERNAL" + DUPLICATE_ -> "DUPLICATE_" + + smpP = + A.takeTill (== ' ') >>= \case + "BLOCK" -> pure BLOCK + "SESSION" -> pure SESSION + "CMD" -> CMD <$> _smpP + "AUTH" -> pure AUTH + "SIZE" -> pure SIZE + "QUOTA" -> pure QUOTA + "DIGEST" -> pure DIGEST + "CRYPTO" -> pure CRYPTO + "NO_FILE" -> pure NO_FILE + "HAS_FILE" -> pure HAS_FILE + "FILE_IO" -> pure FILE_IO + "INTERNAL" -> pure INTERNAL + "DUPLICATE_" -> pure DUPLICATE_ + _ -> fail "bad error type" + +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 "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 + Just Refl -> Just c + _ -> Nothing + +xftpEncodeTransmission :: ProtocolEncoding e c => SessionId -> Maybe C.APrivateSignKey -> Transmission c -> Either TransportError ByteString +xftpEncodeTransmission sessionId pKey (corrId, fId, msg) = do + let t = encodeTransmission currentXFTPVersion sessionId (corrId, fId, msg) + xftpEncodeBatch1 $ signTransmission t + where + signTransmission :: ByteString -> SentRawTransmission + signTransmission t = ((`C.sign` t) <$> pKey, t) + +-- this function uses batch syntax but puts only one transmission in the batch +xftpEncodeBatch1 :: (Maybe C.ASignature, ByteString) -> Either TransportError ByteString +xftpEncodeBatch1 (sig, t) = + let t' = tEncodeBatch 1 . smpEncode . Large $ tEncode (sig, t) + in first (const TELargeMsg) $ C.pad t' xftpBlockSize + +xftpDecodeTransmission :: ProtocolEncoding e c => SessionId -> ByteString -> Either XFTPErrorType (SignedTransmission e c) +xftpDecodeTransmission sessionId t = do + t' <- first (const BLOCK) $ C.unPad t + case tParse True t' of + t'' :| [] -> Right $ tDecodeParseValidate sessionId currentXFTPVersion t'' + _ -> Left BLOCK diff --git a/src/Simplex/FileTransfer/Server.hs b/src/Simplex/FileTransfer/Server.hs new file mode 100644 index 000000000..8e9c8a1e6 --- /dev/null +++ b/src/Simplex/FileTransfer/Server.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.FileTransfer.Server where + +import Control.Logger.Simple +import Control.Monad.Except +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Reader +import Crypto.Random (getRandomBytes) +import Data.Bifunctor (first) +import qualified Data.ByteString.Base64.URL as B64 +import Data.ByteString.Builder (byteString) +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 +import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, getCurrentTime) +import Data.Time.Clock.System (SystemTime (..), getSystemTime) +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.Word (Word32) +import qualified Network.HTTP.Types as N +import qualified Network.HTTP2.Server as H +import Simplex.FileTransfer.Protocol +import Simplex.FileTransfer.Server.Env +import Simplex.FileTransfer.Server.Stats +import Simplex.FileTransfer.Server.Store +import Simplex.FileTransfer.Server.StoreLog +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, RcvPublicVerifyKey, RecipientId) +import Simplex.Messaging.Server (dummyVerifyCmd, verifyCmdSignature) +import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Server.Stats +import Simplex.Messaging.Transport.HTTP2 +import Simplex.Messaging.Transport.HTTP2.Server +import Simplex.Messaging.Util +import System.Exit (exitFailure) +import System.FilePath (()) +import System.IO (BufferMode (..), hPutStrLn, hSetBuffering) +import UnliftIO (IOMode (..), withFile) +import UnliftIO.Concurrent (threadDelay) +import UnliftIO.Directory (doesFileExist, removeFile, renameFile) +import UnliftIO.Exception +import UnliftIO.STM + +type M a = ReaderT XFTPEnv IO a + +runXFTPServer :: XFTPServerConfig -> IO () +runXFTPServer cfg = do + started <- newEmptyTMVarIO + runXFTPServerBlocking started cfg + +runXFTPServerBlocking :: TMVar Bool -> XFTPServerConfig -> IO () +runXFTPServerBlocking started cfg = newXFTPServerEnv cfg >>= runReaderT (xftpServer cfg started) + +xftpServer :: XFTPServerConfig -> TMVar Bool -> M () +xftpServer cfg@XFTPServerConfig {xftpPort, logTLSErrors} started = do + restoreServerStats + raceAny_ (runServer : expireFilesThread_ cfg <> serverStatsThread_ cfg) `finally` stopServer + where + runServer :: M () + runServer = do + serverParams <- asks tlsServerParams + env <- ask + liftIO $ + runHTTP2Server started xftpPort defaultHTTP2BufferSize serverParams logTLSErrors $ \sessionId r sendResponse -> do + reqBody <- getHTTP2Body r xftpBlockSize + processRequest HTTP2Request {sessionId, request = r, reqBody, sendResponse} `runReaderT` env + + stopServer :: M () + stopServer = do + withFileLog closeStoreLog + saveServerStats + + expireFilesThread_ :: XFTPServerConfig -> [M ()] + expireFilesThread_ XFTPServerConfig {fileExpiration = Just fileExp} = [expireFiles fileExp] + expireFilesThread_ _ = [] + + expireFiles :: ExpirationConfig -> M () + expireFiles expCfg = do + st <- asks store + let interval = checkInterval expCfg * 1000000 + forever $ do + threadDelay interval + old <- liftIO $ expireBeforeEpoch expCfg + sIds <- M.keysSet <$> readTVarIO (files st) + forM_ sIds $ \sId -> do + threadDelay 100000 + atomically (expiredFilePath st sId old) + >>= mapM_ (remove $ delete st sId) + where + remove del filePath = + ifM + (doesFileExist filePath) + (removeFile filePath >> del `catch` \(e :: SomeException) -> logError $ "failed to remove expired file " <> tshow filePath <> ": " <> tshow e) + del + delete st sId = do + withFileLog (`logDeleteFile` sId) + void $ atomically $ deleteFile st sId + + serverStatsThread_ :: XFTPServerConfig -> [M ()] + serverStatsThread_ XFTPServerConfig {logStatsInterval = Just interval, logStatsStartTime, serverStatsLogFile} = + [logServerStats logStatsStartTime interval serverStatsLogFile] + serverStatsThread_ _ = [] + + logServerStats :: Int -> Int -> FilePath -> M () + logServerStats startAt logInterval statsFilePath = do + initialDelay <- (startAt -) . fromIntegral . (`div` 1000000_000000) . diffTimeToPicoseconds . utctDayTime <$> liftIO getCurrentTime + liftIO $ putStrLn $ "server stats log enabled: " <> statsFilePath + threadDelay $ 1_000_000 * (initialDelay + if initialDelay < 0 then 86_400 else 0) + FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} <- asks serverStats + let interval = 1_000_000 * logInterval + forever $ do + withFile statsFilePath AppendMode $ \h -> liftIO $ do + hSetBuffering h LineBuffering + ts <- getCurrentTime + fromTime' <- atomically $ swapTVar fromTime ts + filesCreated' <- atomically $ swapTVar filesCreated 0 + fileRecipients' <- atomically $ swapTVar fileRecipients 0 + filesUploaded' <- atomically $ swapTVar filesUploaded 0 + filesDeleted' <- atomically $ swapTVar filesDeleted 0 + files <- atomically $ periodStatCounts filesDownloaded ts + fileDownloads' <- atomically $ swapTVar fileDownloads 0 + fileDownloadAcks' <- atomically $ swapTVar fileDownloadAcks 0 + filesCount' <- atomically $ swapTVar filesCount 0 + filesSize' <- atomically $ swapTVar filesSize 0 + hPutStrLn h $ + intercalate + "," + [ iso8601Show $ utctDay fromTime', + show filesCreated', + show fileRecipients', + show filesUploaded', + show filesDeleted', + dayCount files, + weekCount files, + monthCount files, + show fileDownloads', + show fileDownloadAcks', + show filesCount', + show filesSize' + ] + threadDelay interval + +data ServerFile = ServerFile + { filePath :: FilePath, + fileSize :: Word32, + sbState :: LC.SbState + } + +processRequest :: HTTP2Request -> M () +processRequest HTTP2Request {sessionId, reqBody = body@HTTP2Body {bodyHead}, sendResponse} + | B.length bodyHead /= xftpBlockSize = sendXFTPResponse ("", "", FRErr BLOCK) Nothing + | otherwise = do + case xftpDecodeTransmission sessionId bodyHead of + Right (sig_, signed, (corrId, fId, cmdOrErr)) -> do + case cmdOrErr of + Right cmd -> do + verifyXFTPTransmission sig_ signed fId cmd >>= \case + VRVerified req -> uncurry send =<< processXFTPRequest body req + VRFailed -> send (FRErr AUTH) Nothing + Left e -> send (FRErr e) Nothing + where + send resp = sendXFTPResponse (corrId, fId, resp) + Left e -> sendXFTPResponse ("", "", FRErr e) Nothing + where + sendXFTPResponse :: (CorrId, XFTPFileId, FileResponse) -> Maybe ServerFile -> M () + sendXFTPResponse (corrId, fId, resp) serverFile_ = do + let t_ = xftpEncodeTransmission sessionId Nothing (corrId, fId, resp) + liftIO $ sendResponse $ H.responseStreaming N.ok200 [] $ streamBody t_ + where + streamBody t_ send done = do + case t_ of + Left _ -> do + send "padding error" -- TODO respond with BLOCK error? + done + Right t -> do + send $ byteString t + -- timeout sending file in the same way as receiving + forM_ serverFile_ $ \ServerFile {filePath, fileSize, sbState} -> do + withFile filePath ReadMode $ \h -> sendEncFile h send sbState (fromIntegral fileSize) + done + +data VerificationResult = VRVerified XFTPRequest | VRFailed + +verifyXFTPTransmission :: Maybe C.ASignature -> ByteString -> XFTPFileId -> FileCmd -> M VerificationResult +verifyXFTPTransmission sig_ signed fId cmd = + case cmd of + FileCmd SFSender (FNEW file rcps auth) -> pure $ XFTPReqNew file rcps auth `verifyWith` sndKey file + FileCmd SFRecipient PING -> pure $ VRVerified XFTPReqPing + FileCmd party _ -> verifyCmd party + where + verifyCmd :: SFileParty p -> M VerificationResult + verifyCmd party = do + st <- asks store + atomically $ verify <$> getFile st party fId + where + verify = \case + Right (fr, k) -> XFTPReqCmd fId fr cmd `verifyWith` k + _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed + req `verifyWith` k = if verifyCmdSignature sig_ signed k then VRVerified req else VRFailed + +processXFTPRequest :: HTTP2Body -> XFTPRequest -> M (FileResponse, Maybe ServerFile) +processXFTPRequest HTTP2Body {bodyPart} = \case + XFTPReqNew file rks auth -> do + st <- asks store + noFile + =<< ifM + allowNew + (createFile st file rks) + (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 -> noFile =<< receiveServerFile fr + FDEL -> noFile =<< deleteServerFile fr + FGET rDhKey -> sendServerFile fr rDhKey + 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 :: FileStore -> FileInfo -> NonEmpty RcvPublicVerifyKey -> M FileResponse + createFile st file rks = do + r <- runExceptT $ do + sizes <- asks $ allowedChunkSizes . config + unless (size file `elem` sizes) $ throwError SIZE + ts <- liftIO getSystemTime + -- TODO validate body empty + sId <- ExceptT $ addFileRetry 3 ts + rcps <- mapM (ExceptT . addRecipientRetry 3 sId) rks + withFileLog $ \sl -> do + logAddFile sl sId file ts + logAddRecipients sl sId rcps + stats <- asks serverStats + atomically $ modifyTVar' (filesCreated stats) (+ 1) + atomically $ modifyTVar' (fileRecipients stats) (+ length rks) + let rIds = L.map (\(FileRecipient rId _) -> rId) rcps + pure $ FRSndIds sId rIds + pure $ either FRErr id r + where + addFileRetry :: Int -> SystemTime -> M (Either XFTPErrorType XFTPFileId) + addFileRetry n ts = + retryAdd n $ \sId -> runExceptT $ do + ExceptT $ addFile st sId file ts + pure sId + addRecipientRetry :: Int -> XFTPFileId -> RcvPublicVerifyKey -> M (Either XFTPErrorType FileRecipient) + addRecipientRetry n sId rpk = + retryAdd n $ \rId -> runExceptT $ do + let rcp = FileRecipient rId rpk + ExceptT $ addRecipient st sId rcp + pure rcp + retryAdd :: Int -> (XFTPFileId -> STM (Either XFTPErrorType a)) -> M (Either XFTPErrorType a) + retryAdd 0 _ = pure $ Left INTERNAL + retryAdd n add = do + fId <- getFileId + atomically (add fId) >>= \case + Left DUPLICATE_ -> retryAdd (n - 1) add + r -> pure r + receiveServerFile :: FileRec -> M FileResponse + receiveServerFile fr@FileRec {senderId, fileInfo} = case bodyPart of + -- TODO do not allow repeated file upload + Nothing -> pure $ FRErr SIZE + Just getBody -> do + -- TODO validate body size before downloading, once it's populated + path <- asks $ filesPath . config + let fPath = path B.unpack (B64.encode senderId) + FileInfo {size, digest} = fileInfo + withFileLog $ \sl -> logPutFile sl senderId fPath + st <- asks store + quota_ <- asks $ fileSizeQuota . config + -- TODO timeout file upload, remove partially uploaded files + stats <- asks serverStats + liftIO $ + runExceptT (receiveFile getBody (XFTPRcvChunkSpec fPath size digest)) >>= \case + Right () -> do + used <- readTVarIO $ usedStorage st + if maybe False (used + fromIntegral size >) quota_ + then remove fPath $> FRErr QUOTA + else do + atomically (setFilePath' st fr fPath) + atomically $ modifyTVar' (filesUploaded stats) (+ 1) + atomically $ modifyTVar' (filesCount stats) (+ 1) + atomically $ modifyTVar' (filesSize stats) (+ fromIntegral size) + pure FROk + Left e -> remove fPath $> FRErr e + where + remove fPath = whenM (doesFileExist fPath) (removeFile fPath) `catch` logFileError + + sendServerFile :: FileRec -> RcvPublicDhKey -> M (FileResponse, Maybe ServerFile) + sendServerFile FileRec {senderId, filePath, fileInfo = FileInfo {size}} rDhKey = do + readTVarIO filePath >>= \case + Just path -> do + (sDhKey, spDhKey) <- liftIO C.generateKeyPair' + let dhSecret = C.dh' rDhKey spDhKey + cbNonce <- liftIO C.randomCbNonce + case LC.cbInit dhSecret cbNonce of + Right sbState -> do + stats <- asks serverStats + atomically $ modifyTVar' (fileDownloads stats) (+ 1) + atomically $ updatePeriodStats (filesDownloaded stats) senderId + pure (FRFile sDhKey cbNonce, Just ServerFile {filePath = path, fileSize = size, sbState}) + _ -> pure (FRErr INTERNAL, Nothing) + _ -> pure (FRErr NO_FILE, Nothing) + + deleteServerFile :: FileRec -> M FileResponse + deleteServerFile FileRec {senderId, fileInfo, filePath} = do + withFileLog (`logDeleteFile` senderId) + r <- runExceptT $ do + path <- readTVarIO filePath + stats <- asks serverStats + ExceptT $ first (\(_ :: SomeException) -> FILE_IO) <$> try (forM_ path $ \p -> whenM (doesFileExist p) (removeFile p >> deletedStats stats)) + st <- asks store + void $ atomically $ deleteFile st senderId + atomically $ modifyTVar' (filesDeleted stats) (+ 1) + pure FROk + either (pure . FRErr) pure r + where + deletedStats stats = do + atomically $ modifyTVar' (filesCount stats) (subtract 1) + atomically $ modifyTVar' (filesSize stats) (subtract $ fromIntegral $ size fileInfo) + + logFileError :: SomeException -> IO () + logFileError e = logError $ "Error deleting file: " <> tshow e + + ackFileReception :: RecipientId -> FileRec -> M FileResponse + ackFileReception rId fr = do + withFileLog (`logAckFile` rId) + st <- asks store + atomically $ deleteRecipient st rId fr + stats <- asks serverStats + atomically $ modifyTVar' (fileDownloadAcks stats) (+ 1) + pure FROk + +randomId :: (MonadUnliftIO m, MonadReader XFTPEnv m) => Int -> m ByteString +randomId n = do + gVar <- asks idsDrg + atomically (C.pseudoRandomBytes n gVar) + +getFileId :: M XFTPFileId +getFileId = liftIO . getRandomBytes =<< asks (fileIdSize . config) + +withFileLog :: (MonadIO m, MonadReader XFTPEnv m) => (StoreLog 'WriteMode -> IO a) -> m () +withFileLog action = liftIO . mapM_ action =<< asks storeLog + +incFileStat :: (FileServerStats -> TVar Int) -> M () +incFileStat statSel = do + stats <- asks serverStats + atomically $ modifyTVar (statSel stats) (+ 1) + +saveServerStats :: M () +saveServerStats = + asks (serverStatsBackupFile . config) + >>= mapM_ (\f -> asks serverStats >>= atomically . getFileServerStatsData >>= liftIO . saveStats f) + where + saveStats f stats = do + logInfo $ "saving server stats to file " <> T.pack f + B.writeFile f $ strEncode stats + logInfo "server stats saved" + +restoreServerStats :: M () +restoreServerStats = asks (serverStatsBackupFile . config) >>= mapM_ restoreStats + where + restoreStats f = whenM (doesFileExist f) $ do + logInfo $ "restoring server stats from file " <> T.pack f + liftIO (strDecode <$> B.readFile f) >>= \case + Right d -> do + s <- asks serverStats + fs <- readTVarIO . files =<< asks store + let _filesCount = length $ M.keys fs + _filesSize = M.foldl' (\n -> (n +) . fromIntegral . size . fileInfo) 0 fs + atomically $ setFileServerStats s d {_filesCount, _filesSize} + renameFile f $ f <> ".bak" + logInfo "server stats restored" + Left e -> do + logInfo $ "error restoring server stats: " <> T.pack e + liftIO exitFailure diff --git a/src/Simplex/FileTransfer/Server/Env.hs b/src/Simplex/FileTransfer/Server/Env.hs new file mode 100644 index 000000000..08ddf9ade --- /dev/null +++ b/src/Simplex/FileTransfer/Server/Env.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} + +module Simplex.FileTransfer.Server.Env where + +import Control.Logger.Simple (logInfo) +import Control.Monad +import Control.Monad.IO.Unlift +import Crypto.Random +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) +import Data.Time.Clock (getCurrentTime) +import Data.Word (Word32) +import Data.X509.Validation (Fingerprint (..)) +import Network.Socket +import qualified Network.TLS as T +import Simplex.FileTransfer.Protocol (FileCmd, FileInfo, XFTPFileId) +import Simplex.FileTransfer.Server.Stats +import Simplex.FileTransfer.Server.Store +import Simplex.FileTransfer.Server.StoreLog +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Protocol (BasicAuth, RcvPublicVerifyKey) +import Simplex.Messaging.Server.Expiration +import Simplex.Messaging.Transport.Server (loadFingerprint, loadTLSServerParams) +import Simplex.Messaging.Util (tshow) +import System.IO (IOMode (..)) +import UnliftIO.STM + +data XFTPServerConfig = XFTPServerConfig + { xftpPort :: ServiceName, + fileIdSize :: Int, + storeLogFile :: Maybe FilePath, + filesPath :: FilePath, + -- | server storage quota + fileSizeQuota :: Maybe Int64, + -- | allowed file chunk sizes + allowedChunkSizes :: [Word32], + -- | set to False to prohibit creating new files + allowNewFiles :: Bool, + -- | simple password that the clients need to pass in handshake to be able to create new files + newFileBasicAuth :: Maybe BasicAuth, + -- | time after which the files can be removed and check interval, seconds + fileExpiration :: Maybe ExpirationConfig, + -- CA certificate private key is not needed for initialization + caCertificateFile :: FilePath, + privateKeyFile :: FilePath, + certificateFile :: FilePath, + -- stats config - see SMP server config + logStatsInterval :: Maybe Int, + logStatsStartTime :: Int, + serverStatsLogFile :: FilePath, + serverStatsBackupFile :: Maybe FilePath, + logTLSErrors :: Bool + } + +data XFTPEnv = XFTPEnv + { config :: XFTPServerConfig, + store :: FileStore, + storeLog :: Maybe (StoreLog 'WriteMode), + idsDrg :: TVar ChaChaDRG, + serverIdentity :: C.KeyHash, + tlsServerParams :: T.ServerParams, + serverStats :: FileServerStats + } + +defaultFileExpiration :: ExpirationConfig +defaultFileExpiration = + ExpirationConfig + { ttl = 48 * 3600, -- seconds, 48 hours + checkInterval = 2 * 3600 -- seconds, 2 hours + } + +newXFTPServerEnv :: (MonadUnliftIO m, MonadRandom m) => XFTPServerConfig -> m XFTPEnv +newXFTPServerEnv config@XFTPServerConfig {storeLogFile, fileSizeQuota, caCertificateFile, certificateFile, privateKeyFile} = do + idsDrg <- drgNew >>= newTVarIO + store <- atomically newFileStore + storeLog <- liftIO $ mapM (`readWriteFileStore` store) storeLogFile + used <- readTVarIO (usedStorage store) + forM_ fileSizeQuota $ \quota -> do + logInfo $ "Total / available storage: " <> tshow quota <> " / " <> tshow (quota - used) + when (quota < used) $ logInfo "WARNING: storage quota is less than used storage, no files can be uploaded!" + tlsServerParams <- liftIO $ loadTLSServerParams caCertificateFile certificateFile privateKeyFile + Fingerprint fp <- liftIO $ loadFingerprint caCertificateFile + serverStats <- atomically . newFileServerStats =<< liftIO getCurrentTime + pure XFTPEnv {config, store, storeLog, idsDrg, tlsServerParams, serverIdentity = C.KeyHash fp, serverStats} + +data XFTPRequest + = XFTPReqNew FileInfo (NonEmpty RcvPublicVerifyKey) (Maybe BasicAuth) + | XFTPReqCmd XFTPFileId FileRec FileCmd + | XFTPReqPing diff --git a/src/Simplex/FileTransfer/Server/Main.hs b/src/Simplex/FileTransfer/Server/Main.hs new file mode 100644 index 000000000..4c3d6e1fb --- /dev/null +++ b/src/Simplex/FileTransfer/Server/Main.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} + +module Simplex.FileTransfer.Server.Main where + +import qualified Data.ByteString.Char8 as B +import Data.Either (fromRight) +import Data.Functor (($>)) +import Data.Ini (lookupValue, readIniFile) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Network.Socket (HostName) +import Options.Applicative +import Simplex.FileTransfer.Description (FileSize (..), kb, mb) +import Simplex.FileTransfer.Server (runXFTPServer) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), pattern XFTPServer) +import Simplex.Messaging.Server.CLI +import Simplex.Messaging.Transport.Client (TransportHost (..)) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (combine) +import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) +import Text.Read (readMaybe) + +xftpServerVersion :: String +xftpServerVersion = "0.1.0" + +xftpServerCLI :: FilePath -> FilePath -> IO () +xftpServerCLI cfgPath logPath = do + getCliCommand' (cliCommandP cfgPath logPath iniFile) serverVersion >>= \case + Init opts -> + doesFileExist iniFile >>= \case + True -> exitError $ "Error: server is already initialized (" <> iniFile <> " exists).\nRun `" <> executableName <> " start`." + _ -> initializeServer opts + Start -> + doesFileExist iniFile >>= \case + True -> readIniFile iniFile >>= either exitError runServer + _ -> exitError $ "Error: server is not initialized (" <> iniFile <> " does not exist).\nRun `" <> executableName <> " init`." + Delete -> do + confirmOrExit "WARNING: deleting the server will make all queues inaccessible, because the server identity (certificate fingerprint) will change.\nTHIS CANNOT BE UNDONE!" + deleteDirIfExists cfgPath + deleteDirIfExists logPath + putStrLn "Deleted configuration and log files" + where + iniFile = combine cfgPath "file-server.ini" + serverVersion = "SimpleX XFTP server v" <> xftpServerVersion + defaultServerPort = "443" + executableName = "file-server" + storeLogFilePath = combine logPath "file-server-store.log" + initializeServer InitOptions {enableStoreLog, signAlgorithm, ip, fqdn, filesPath, fileSizeQuota} = do + clearDirIfExists cfgPath + clearDirIfExists logPath + createDirectoryIfMissing True cfgPath + createDirectoryIfMissing True logPath + let x509cfg = defaultX509Config {commonName = fromMaybe ip fqdn, signAlgorithm} + fp <- createServerX509 cfgPath x509cfg + let host = fromMaybe (if ip == "127.0.0.1" then "" else ip) fqdn + srv = ProtoServerWithAuth (XFTPServer [THDomainName host] "" (C.KeyHash fp)) Nothing + writeFile iniFile $ iniFileContent host + putStrLn $ "Server initialized, you can modify configuration in " <> iniFile <> ".\nRun `" <> executableName <> " start` to start server." + warnCAPrivateKeyFile cfgPath x509cfg + printServiceInfo serverVersion srv + where + iniFileContent host = + "[STORE_LOG]\n\ + \# The server uses STM memory for persistence,\n\ + \# that will be lost on restart (e.g., as with redis).\n\ + \# This option enables saving memory to append only log,\n\ + \# and restoring it when the server is started.\n\ + \# Log is compacted on start (deleted objects are removed).\n" + <> ("enable: " <> onOff enableStoreLog <> "\n\n") + <> "log_stats: off\n\ + \\n\ + \[AUTH]\n\ + \# Set new_files option to off to completely prohibit uploading new files.\n\ + \# This can be useful when you want to decommission the server, but still allow downloading the existing files.\n\ + \new_files: on\n\ + \\n\ + \# Use create_password option to enable basic auth to upload new files.\n\ + \# The password should be used as part of server address in client configuration:\n\ + \# xftp://fingerprint:password@host1,host2\n\ + \# The password will not be shared with file recipients, you must share it only\n\ + \# with the users who you want to allow uploading files to your server.\n\ + \# create_password: password to upload files (any printable ASCII characters without whitespace, '@', ':' and '/')\n\ + \\n\ + \[TRANSPORT]\n\ + \# host is only used to print server address on start\n" + <> ("host: " <> host <> "\n") + <> ("port: " <> defaultServerPort <> "\n") + <> "log_tls_errors: off\n\ + \\n\ + \[FILES]\n" + <> ("path: " <> filesPath <> "\n") + <> ("storage_quota: " <> B.unpack (strEncode fileSizeQuota) <> "\n") + runServer ini = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + fp <- checkSavedFingerprint cfgPath defaultX509Config + let host = fromRight "" $ T.unpack <$> lookupValue "TRANSPORT" "host" ini + port = T.unpack $ strictIni "TRANSPORT" "port" ini + srv = ProtoServerWithAuth (XFTPServer [THDomainName host] (if port == "443" then "" else port) (C.KeyHash fp)) Nothing + printServiceInfo serverVersion srv + printXFTPConfig serverConfig + runXFTPServer serverConfig + where + enableStoreLog = settingIsOn "STORE_LOG" "enable" ini + logStats = settingIsOn "STORE_LOG" "log_stats" ini + c = combine cfgPath . ($ defaultX509Config) + printXFTPConfig XFTPServerConfig {allowNewFiles, newFileBasicAuth, xftpPort, storeLogFile} = do + putStrLn $ case storeLogFile of + Just f -> "Store log: " <> f + _ -> "Store log disabled." + putStrLn $ + "Uploading new files " + <> if allowNewFiles + then maybe "allowed." (const "requires password.") newFileBasicAuth + else "NOT allowed." + putStrLn $ "Listening on port " <> xftpPort <> "..." + + serverConfig = + XFTPServerConfig + { xftpPort = T.unpack $ strictIni "TRANSPORT" "port" ini, + fileIdSize = 16, + storeLogFile = enableStoreLog $> storeLogFilePath, + filesPath = T.unpack $ strictIni "FILES" "path" ini, + fileSizeQuota = either error unFileSize <$> strDecodeIni "FILES" "storage_quota" ini, + allowedChunkSizes = [kb 256, mb 1, mb 4], + allowNewFiles = fromMaybe True $ iniOnOff "AUTH" "new_files" ini, + newFileBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini, + fileExpiration = Just defaultFileExpiration, + caCertificateFile = c caCrtFile, + privateKeyFile = c serverKeyFile, + certificateFile = c serverCrtFile, + logStatsInterval = logStats $> 86400, -- seconds + logStatsStartTime = 0, -- seconds from 00:00 UTC + serverStatsLogFile = combine logPath "file-server-stats.daily.log", + serverStatsBackupFile = logStats $> combine logPath "file-server-stats.log", + logTLSErrors = fromMaybe False $ iniOnOff "TRANSPORT" "log_tls_errors" ini + } + +data CliCommand + = Init InitOptions + | Start + | Delete + +data InitOptions = InitOptions + { enableStoreLog :: Bool, + signAlgorithm :: SignAlgorithm, + ip :: HostName, + fqdn :: Maybe HostName, + filesPath :: FilePath, + fileSizeQuota :: FileSize Int64 + } + deriving (Show) + +cliCommandP :: FilePath -> FilePath -> FilePath -> Parser CliCommand +cliCommandP cfgPath logPath iniFile = + hsubparser + ( command "init" (info (Init <$> initP) (progDesc $ "Initialize server - creates " <> cfgPath <> " and " <> logPath <> " directories and configuration files")) + <> command "start" (info (pure Start) (progDesc $ "Start server (configuration: " <> iniFile <> ")")) + <> command "delete" (info (pure Delete) (progDesc "Delete configuration and log files")) + ) + where + initP :: Parser InitOptions + initP = + InitOptions + <$> switch + ( long "store-log" + <> short 'l' + <> help "Enable store log for persistence" + ) + <*> option + (maybeReader readMaybe) + ( long "sign-algorithm" + <> short 'a' + <> help "Signature algorithm used for TLS certificates: ED25519, ED448" + <> value ED448 + <> showDefault + <> metavar "ALG" + ) + <*> strOption + ( long "ip" + <> help + "Server IP address, used as Common Name for TLS online certificate if FQDN is not supplied" + <> value "127.0.0.1" + <> showDefault + <> metavar "IP" + ) + <*> (optional . strOption) + ( long "fqdn" + <> short 'n' + <> help "Server FQDN used as Common Name for TLS online certificate" + <> showDefault + <> metavar "FQDN" + ) + <*> strOption + ( long "path" + <> short 'p' + <> help "Path to the directory to store files" + <> metavar "PATH" + ) + <*> strOption + ( long "quota" + <> short 'q' + <> help "File storage quota (e.g. 100gb)" + <> metavar "QUOTA" + ) diff --git a/src/Simplex/FileTransfer/Server/Stats.hs b/src/Simplex/FileTransfer/Server/Stats.hs new file mode 100644 index 000000000..f6e092cdf --- /dev/null +++ b/src/Simplex/FileTransfer/Server/Stats.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.FileTransfer.Server.Stats where + +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Char8 as B +import Data.Int (Int64) +import Data.Time.Clock (UTCTime) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (SenderId) +import Simplex.Messaging.Server.Stats (PeriodStats, PeriodStatsData, getPeriodStatsData, newPeriodStats, setPeriodStats) +import UnliftIO.STM + +data FileServerStats = FileServerStats + { fromTime :: TVar UTCTime, + filesCreated :: TVar Int, + fileRecipients :: TVar Int, + filesUploaded :: TVar Int, + filesDeleted :: TVar Int, + filesDownloaded :: PeriodStats SenderId, + fileDownloads :: TVar Int, + fileDownloadAcks :: TVar Int, + filesCount :: TVar Int, + filesSize :: TVar Int64 + } + +data FileServerStatsData = FileServerStatsData + { _fromTime :: UTCTime, + _filesCreated :: Int, + _fileRecipients :: Int, + _filesUploaded :: Int, + _filesDeleted :: Int, + _filesDownloaded :: PeriodStatsData SenderId, + _fileDownloads :: Int, + _fileDownloadAcks :: Int, + _filesCount :: Int, + _filesSize :: Int64 + } + deriving (Show) + +newFileServerStats :: UTCTime -> STM FileServerStats +newFileServerStats ts = do + fromTime <- newTVar ts + filesCreated <- newTVar 0 + fileRecipients <- newTVar 0 + filesUploaded <- newTVar 0 + filesDeleted <- newTVar 0 + filesDownloaded <- newPeriodStats + fileDownloads <- newTVar 0 + fileDownloadAcks <- newTVar 0 + filesCount <- newTVar 0 + filesSize <- newTVar 0 + pure FileServerStats {fromTime, filesCreated, fileRecipients, filesUploaded, filesDeleted, filesDownloaded, fileDownloads, fileDownloadAcks, filesCount, filesSize} + +getFileServerStatsData :: FileServerStats -> STM FileServerStatsData +getFileServerStatsData s = do + _fromTime <- readTVar $ fromTime (s :: FileServerStats) + _filesCreated <- readTVar $ filesCreated s + _fileRecipients <- readTVar $ fileRecipients s + _filesUploaded <- readTVar $ filesUploaded s + _filesDeleted <- readTVar $ filesDeleted s + _filesDownloaded <- getPeriodStatsData $ filesDownloaded s + _fileDownloads <- readTVar $ fileDownloads s + _fileDownloadAcks <- readTVar $ fileDownloadAcks s + _filesCount <- readTVar $ filesCount s + _filesSize <- readTVar $ filesSize s + pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount, _filesSize} + +setFileServerStats :: FileServerStats -> FileServerStatsData -> STM () +setFileServerStats s d = do + writeTVar (fromTime (s :: FileServerStats)) $! _fromTime (d :: FileServerStatsData) + writeTVar (filesCreated s) $! _filesCreated d + writeTVar (fileRecipients s) $! _fileRecipients d + writeTVar (filesUploaded s) $! _filesUploaded d + writeTVar (filesDeleted s) $! _filesDeleted d + setPeriodStats (filesDownloaded s) $! _filesDownloaded d + writeTVar (fileDownloads s) $! _fileDownloads d + writeTVar (fileDownloadAcks s) $! _fileDownloadAcks d + writeTVar (filesCount s) $! _filesCount d + writeTVar (filesSize s) $! _filesSize d + +instance StrEncoding FileServerStatsData where + strEncode FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks} = + B.unlines + [ "fromTime=" <> strEncode _fromTime, + "filesCreated=" <> strEncode _filesCreated, + "fileRecipients=" <> strEncode _fileRecipients, + "filesUploaded=" <> strEncode _filesUploaded, + "filesDeleted=" <> strEncode _filesDeleted, + "filesDownloaded:", + strEncode _filesDownloaded, + "fileDownloads=" <> strEncode _fileDownloads, + "fileDownloadAcks=" <> strEncode _fileDownloadAcks + ] + strP = do + _fromTime <- "fromTime=" *> strP <* A.endOfLine + _filesCreated <- "filesCreated=" *> strP <* A.endOfLine + _fileRecipients <- "fileRecipients=" *> strP <* A.endOfLine + _filesUploaded <- "filesUploaded=" *> strP <* A.endOfLine + _filesDeleted <- "filesDeleted=" *> strP <* A.endOfLine + _filesDownloaded <- "filesDownloaded:" *> A.endOfLine *> strP <* A.endOfLine + _fileDownloads <- "fileDownloads=" *> strP <* A.endOfLine + _fileDownloadAcks <- "fileDownloadAcks=" *> strP <* A.endOfLine + pure FileServerStatsData {_fromTime, _filesCreated, _fileRecipients, _filesUploaded, _filesDeleted, _filesDownloaded, _fileDownloads, _fileDownloadAcks, _filesCount = 0, _filesSize = 0} diff --git a/src/Simplex/FileTransfer/Server/Store.hs b/src/Simplex/FileTransfer/Server/Store.hs new file mode 100644 index 000000000..ce399cea6 --- /dev/null +++ b/src/Simplex/FileTransfer/Server/Store.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Simplex.FileTransfer.Server.Store + ( FileStore (..), + FileRec (..), + FileRecipient (..), + newFileStore, + addFile, + setFilePath, + setFilePath', + addRecipient, + deleteFile, + deleteRecipient, + expiredFilePath, + getFile, + ackFile, + ) +where + +import Control.Concurrent.STM +import qualified Data.Attoparsec.ByteString.Char8 as A +import Data.Functor (($>)) +import Data.Int (Int64) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Time.Clock.System (SystemTime (..)) +import Simplex.FileTransfer.Protocol (FileInfo (..), SFileParty (..), XFTPErrorType (..), XFTPFileId) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId) +import Simplex.Messaging.TMap (TMap) +import qualified Simplex.Messaging.TMap as TM +import Simplex.Messaging.Util (ifM, ($>>=)) + +data FileStore = FileStore + { files :: TMap SenderId FileRec, + recipients :: TMap RecipientId (SenderId, RcvPublicVerifyKey), + usedStorage :: TVar Int64 + } + +data FileRec = FileRec + { senderId :: SenderId, + fileInfo :: FileInfo, + filePath :: TVar (Maybe FilePath), + recipientIds :: TVar (Set RecipientId), + createdAt :: SystemTime + } + deriving (Eq) + +data FileRecipient = FileRecipient RecipientId RcvPublicVerifyKey + +instance StrEncoding FileRecipient where + strEncode (FileRecipient rId rKey) = strEncode rId <> ":" <> strEncode rKey + strP = FileRecipient <$> strP <* A.char ':' <*> strP + +newFileStore :: STM FileStore +newFileStore = do + files <- TM.empty + recipients <- TM.empty + usedStorage <- newTVar 0 + pure FileStore {files, recipients, usedStorage} + +addFile :: FileStore -> SenderId -> FileInfo -> SystemTime -> STM (Either XFTPErrorType ()) +addFile FileStore {files} sId fileInfo createdAt = + ifM (TM.member sId files) (pure $ Left DUPLICATE_) $ do + f <- newFileRec sId fileInfo createdAt + TM.insert sId f files + pure $ Right () + +newFileRec :: SenderId -> FileInfo -> SystemTime -> STM FileRec +newFileRec senderId fileInfo createdAt = do + recipientIds <- newTVar S.empty + filePath <- newTVar Nothing + pure FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} + +setFilePath :: FileStore -> SenderId -> FilePath -> STM (Either XFTPErrorType ()) +setFilePath st sId fPath = + withFile st sId $ \fr -> setFilePath' st fr fPath $> Right () + +setFilePath' :: FileStore -> FileRec -> FilePath -> STM () +setFilePath' st FileRec {fileInfo, filePath} fPath = do + writeTVar filePath (Just fPath) + modifyTVar' (usedStorage st) (+ fromIntegral (size fileInfo)) + +addRecipient :: FileStore -> SenderId -> FileRecipient -> STM (Either XFTPErrorType ()) +addRecipient st@FileStore {recipients} senderId (FileRecipient rId rKey) = + withFile st senderId $ \FileRec {recipientIds} -> do + rIds <- readTVar recipientIds + mem <- TM.member rId recipients + if rId `S.member` rIds || mem + then pure $ Left DUPLICATE_ + else do + writeTVar recipientIds $! S.insert rId rIds + TM.insert rId (senderId, rKey) recipients + pure $ Right () + +-- this function must be called after the file is deleted from the file system +deleteFile :: FileStore -> SenderId -> STM (Either XFTPErrorType ()) +deleteFile FileStore {files, recipients, usedStorage} senderId = do + TM.lookupDelete senderId files >>= \case + Just FileRec {fileInfo, recipientIds} -> do + readTVar recipientIds >>= mapM_ (`TM.delete` recipients) + modifyTVar' usedStorage $ subtract (fromIntegral $ size fileInfo) + pure $ Right () + _ -> pure $ Left AUTH + +deleteRecipient :: FileStore -> RecipientId -> FileRec -> STM () +deleteRecipient FileStore {recipients} rId FileRec {recipientIds} = do + TM.delete rId recipients + modifyTVar' recipientIds $ S.delete rId + +getFile :: FileStore -> SFileParty p -> XFTPFileId -> STM (Either XFTPErrorType (FileRec, C.APublicVerifyKey)) +getFile st party fId = case party of + SFSender -> withFile st fId $ pure . Right . (\f -> (f, sndKey $ fileInfo f)) + SFRecipient -> + TM.lookup fId (recipients st) >>= \case + Just (sId, rKey) -> withFile st sId $ pure . Right . (,rKey) + _ -> pure $ Left AUTH + +expiredFilePath :: FileStore -> XFTPFileId -> Int64 -> STM (Maybe FilePath) +expiredFilePath FileStore {files} sId old = + TM.lookup sId files + $>>= \FileRec {filePath, createdAt} -> + if systemSeconds createdAt < old + then readTVar filePath + else pure Nothing + +ackFile :: FileStore -> RecipientId -> STM (Either XFTPErrorType ()) +ackFile st@FileStore {recipients} recipientId = do + TM.lookupDelete recipientId recipients >>= \case + Just (sId, _) -> + withFile st sId $ \FileRec {recipientIds} -> do + modifyTVar' recipientIds $ S.delete recipientId + pure $ Right () + _ -> pure $ Left AUTH + +withFile :: FileStore -> SenderId -> (FileRec -> STM (Either XFTPErrorType a)) -> STM (Either XFTPErrorType a) +withFile FileStore {files} sId a = + TM.lookup sId files >>= \case + Just f -> a f + _ -> pure $ Left AUTH diff --git a/src/Simplex/FileTransfer/Server/StoreLog.hs b/src/Simplex/FileTransfer/Server/StoreLog.hs new file mode 100644 index 000000000..dcfbb757e --- /dev/null +++ b/src/Simplex/FileTransfer/Server/StoreLog.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.FileTransfer.Server.StoreLog + ( StoreLog, + FileStoreLogRecord (..), + closeStoreLog, + readWriteFileStore, + logAddFile, + logPutFile, + logAddRecipients, + logDeleteFile, + logAckFile, + ) +where + +import Control.Concurrent.STM +import Control.Monad.Except +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString.Char8 as B +import Data.Composition ((.:), (.:.)) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as L +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Time.Clock.System (SystemTime) +import Simplex.FileTransfer.Protocol (FileInfo (..)) +import Simplex.FileTransfer.Server.Store +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Protocol (RcvPublicVerifyKey, RecipientId, SenderId) +import Simplex.Messaging.Server.StoreLog +import Simplex.Messaging.Util (bshow, whenM) +import System.Directory (doesFileExist, renameFile) +import System.IO + +data FileStoreLogRecord + = AddFile SenderId FileInfo SystemTime + | PutFile SenderId FilePath + | AddRecipients SenderId (NonEmpty FileRecipient) + | DeleteFile SenderId + | AckFile RecipientId + +instance StrEncoding FileStoreLogRecord where + strEncode = \case + AddFile sId file createdAt -> strEncode (Str "FNEW", sId, file, createdAt) + PutFile sId path -> strEncode (Str "FPUT", sId, path) + AddRecipients sId rcps -> strEncode (Str "FADD", sId, rcps) + DeleteFile sId -> strEncode (Str "FDEL", sId) + AckFile rId -> strEncode (Str "FACK", rId) + strP = + A.choice + [ "FNEW " *> (AddFile <$> strP_ <*> strP_ <*> strP), + "FPUT " *> (PutFile <$> strP_ <*> strP), + "FADD " *> (AddRecipients <$> strP_ <*> strP), + "FDEL " *> (DeleteFile <$> strP), + "FACK " *> (AckFile <$> strP) + ] + +logFileStoreRecord :: StoreLog 'WriteMode -> FileStoreLogRecord -> IO () +logFileStoreRecord = writeStoreLogRecord + +logAddFile :: StoreLog 'WriteMode -> SenderId -> FileInfo -> SystemTime -> IO () +logAddFile s = logFileStoreRecord s .:. AddFile + +logPutFile :: StoreLog 'WriteMode -> SenderId -> FilePath -> IO () +logPutFile s = logFileStoreRecord s .: PutFile + +logAddRecipients :: StoreLog 'WriteMode -> SenderId -> NonEmpty FileRecipient -> IO () +logAddRecipients s = logFileStoreRecord s .: AddRecipients + +logDeleteFile :: StoreLog 'WriteMode -> SenderId -> IO () +logDeleteFile s = logFileStoreRecord s . DeleteFile + +logAckFile :: StoreLog 'WriteMode -> RecipientId -> IO () +logAckFile s = logFileStoreRecord s . AckFile + +readWriteFileStore :: FilePath -> FileStore -> IO (StoreLog 'WriteMode) +readWriteFileStore f st = do + whenM (doesFileExist f) $ do + readFileStore f st + renameFile f $ f <> ".bak" + s <- openWriteStoreLog f + writeFileStore s st + pure s + +readFileStore :: FilePath -> FileStore -> IO () +readFileStore f st = mapM_ addFileLogRecord . B.lines =<< B.readFile f + where + addFileLogRecord s = case strDecode s of + Left e -> B.putStrLn $ "Log parsing error (" <> B.pack e <> "): " <> B.take 100 s + Right lr -> + atomically (addToStore lr) >>= \case + Left e -> B.putStrLn $ "Log processing error (" <> bshow e <> "): " <> B.take 100 s + _ -> pure () + addToStore = \case + AddFile sId file createdAt -> addFile st sId file createdAt + PutFile qId path -> setFilePath st qId path + AddRecipients sId rcps -> runExceptT $ addRecipients sId rcps + DeleteFile sId -> deleteFile st sId + AckFile rId -> ackFile st rId + addRecipients sId rcps = mapM_ (ExceptT . addRecipient st sId) rcps + +writeFileStore :: StoreLog 'WriteMode -> FileStore -> IO () +writeFileStore s FileStore {files, recipients} = do + allRcps <- readTVarIO recipients + readTVarIO files >>= mapM_ (logFile allRcps) + where + logFile :: Map RecipientId (SenderId, RcvPublicVerifyKey) -> FileRec -> IO () + logFile allRcps FileRec {senderId, fileInfo, filePath, recipientIds, createdAt} = do + logAddFile s senderId fileInfo createdAt + (rcpErrs, rcps) <- M.mapEither getRcp . M.fromSet id <$> readTVarIO recipientIds + mapM_ (logAddRecipients s senderId) $ L.nonEmpty $ M.elems rcps + mapM_ (B.putStrLn . ("Error storing log: " <>)) rcpErrs + readTVarIO filePath >>= mapM_ (logPutFile s senderId) + where + getRcp rId = case M.lookup rId allRcps of + Just (sndId, rKey) + | sndId == senderId -> Right $ FileRecipient rId rKey + | otherwise -> Left $ "sender ID for recipient ID " <> bshow rId <> " does not match FileRec" + Nothing -> Left $ "recipient ID " <> bshow rId <> " not found" diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs new file mode 100644 index 000000000..01a5757b6 --- /dev/null +++ b/src/Simplex/FileTransfer/Transport.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Simplex.FileTransfer.Transport + ( supportedFileServerVRange, + XFTPRcvChunkSpec (..), + sendFile, + receiveFile, + sendEncFile, + receiveEncFile, + ) +where + +import qualified Control.Exception as E +import Control.Monad.Except +import qualified Data.ByteArray as BA +import Data.ByteString.Builder (Builder, byteString) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Data.Word (Word32) +import GHC.IO.Handle.Internals (ioe_EOF) +import Simplex.FileTransfer.Protocol (XFTPErrorType (..)) +import qualified Simplex.Messaging.Crypto as C +import qualified Simplex.Messaging.Crypto.Lazy as LC +import Simplex.Messaging.Version +import System.IO (Handle, IOMode (..), withFile) + +data XFTPRcvChunkSpec = XFTPRcvChunkSpec + { filePath :: FilePath, + chunkSize :: Word32, + chunkDigest :: ByteString + } + deriving (Show) + +supportedFileServerVRange :: VersionRange +supportedFileServerVRange = mkVersionRange 1 1 + +fileBlockSize :: Int +fileBlockSize = 16 * 1024 + +sendFile :: Handle -> (Builder -> IO ()) -> Word32 -> IO () +sendFile h send = go + where + go 0 = pure () + go sz = + getFileChunk h sz >>= \ch -> do + send $ byteString ch + go $ sz - fromIntegral (B.length ch) + +sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO () +sendEncFile h send = go + where + go sbState 0 = do + let authTag = BA.convert (LC.sbAuth sbState) + send $ byteString authTag + go sbState sz = + getFileChunk h sz >>= \ch -> do + let (encCh, sbState') = LC.sbEncryptChunk sbState ch + send (byteString encCh) `E.catch` \(e :: E.SomeException) -> print e >> E.throwIO e + go sbState' $ sz - fromIntegral (B.length ch) + +getFileChunk :: Handle -> Word32 -> IO ByteString +getFileChunk h sz = + B.hGet h fileBlockSize >>= \case + "" -> ioe_EOF + ch -> pure $ B.take (fromIntegral sz) ch -- sz >= xftpBlockSize + +receiveFile :: (Int -> IO ByteString) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () +receiveFile getBody = receiveFile_ receive + where + receive h sz = do + ch <- getBody fileBlockSize + let chSize = fromIntegral $ B.length ch + if + | chSize > sz -> pure $ Left SIZE + | chSize > 0 -> B.hPut h ch >> receive h (sz - chSize) + | sz == 0 -> pure $ Right () + | otherwise -> pure $ Left SIZE + +receiveEncFile :: (Int -> IO ByteString) -> LC.SbState -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () +receiveEncFile getBody = receiveFile_ . receive + where + receive sbState h sz = do + ch <- getBody fileBlockSize + let chSize = fromIntegral $ B.length ch + if + | chSize > sz + authSz -> pure $ Left SIZE + | chSize > 0 -> do + let (ch', rest) = B.splitAt (fromIntegral sz) ch + (decCh, sbState') = LC.sbDecryptChunk sbState ch' + sz' = sz - fromIntegral (B.length ch') + B.hPut h decCh + if sz' > 0 + then receive sbState' h sz' + else do + let tag' = B.take C.authTagSize rest + tagSz = B.length tag' + tag = LC.sbAuth sbState' + tag'' <- if tagSz == C.authTagSize then pure tag' else (tag' <>) <$> getBody (C.authTagSize - tagSz) + pure $ if BA.constEq tag'' tag then Right () else Left CRYPTO + | otherwise -> pure $ Left SIZE + authSz = fromIntegral C.authTagSize + +receiveFile_ :: (Handle -> Word32 -> IO (Either XFTPErrorType ())) -> XFTPRcvChunkSpec -> ExceptT XFTPErrorType IO () +receiveFile_ receive XFTPRcvChunkSpec {filePath, chunkSize, chunkDigest} = do + ExceptT $ withFile filePath WriteMode (`receive` chunkSize) + digest' <- liftIO $ LC.sha256Hash <$> LB.readFile filePath + when (digest' /= chunkDigest) $ throwError DIGEST diff --git a/src/Simplex/FileTransfer/Types.hs b/src/Simplex/FileTransfer/Types.hs new file mode 100644 index 000000000..578d98ac6 --- /dev/null +++ b/src/Simplex/FileTransfer/Types.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Simplex.FileTransfer.Types where + +import Data.Int (Int64) +import Data.Word (Word32) +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) +import Simplex.FileTransfer.Client (XFTPChunkSpec (..)) +import Simplex.FileTransfer.Description +import Simplex.Messaging.Agent.Protocol (RcvFileId) +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Parsers (fromTextField_) +import Simplex.Messaging.Protocol + +authTagSize :: Int64 +authTagSize = fromIntegral C.authTagSize + +-- fileExtra is added to allow header extension in future versions +data FileHeader = FileHeader + { fileName :: String, + fileExtra :: Maybe String + } + deriving (Eq, Show) + +instance Encoding FileHeader where + smpEncode FileHeader {fileName, fileExtra} = smpEncode (fileName, fileExtra) + smpP = do + (fileName, fileExtra) <- smpP + pure FileHeader {fileName, fileExtra} + +type DBRcvFileId = Int64 + +data RcvFile = RcvFile + { rcvFileId :: DBRcvFileId, + rcvFileEntityId :: RcvFileId, + userId :: Int64, + size :: FileSize Int64, + digest :: FileDigest, + key :: C.SbKey, + nonce :: C.CbNonce, + chunkSize :: FileSize Word32, + chunks :: [RcvFileChunk], + prefixPath :: FilePath, + tmpPath :: Maybe FilePath, + savePath :: FilePath, + status :: RcvFileStatus, + deleted :: Bool + } + deriving (Eq, Show) + +data RcvFileStatus + = RFSReceiving + | RFSReceived + | RFSDecrypting + | RFSComplete + | RFSError + deriving (Eq, Show) + +instance FromField RcvFileStatus where fromField = fromTextField_ textDecode + +instance ToField RcvFileStatus where toField = toField . textEncode + +instance TextEncoding RcvFileStatus where + textDecode = \case + "receiving" -> Just RFSReceiving + "received" -> Just RFSReceived + "decrypting" -> Just RFSDecrypting + "complete" -> Just RFSComplete + "error" -> Just RFSError + _ -> Nothing + textEncode = \case + RFSReceiving -> "receiving" + RFSReceived -> "received" + RFSDecrypting -> "decrypting" + RFSComplete -> "complete" + RFSError -> "error" + +data RcvFileChunk = RcvFileChunk + { rcvFileId :: DBRcvFileId, + rcvFileEntityId :: RcvFileId, + userId :: Int64, + rcvChunkId :: Int64, + chunkNo :: Int, + chunkSize :: FileSize Word32, + digest :: FileDigest, + replicas :: [RcvFileChunkReplica], + fileTmpPath :: FilePath, + chunkTmpPath :: Maybe FilePath + } + deriving (Eq, Show) + +data RcvFileChunkReplica = RcvFileChunkReplica + { rcvChunkReplicaId :: Int64, + server :: XFTPServer, + replicaId :: ChunkReplicaId, + replicaKey :: C.APrivateSignKey, + received :: Bool, + delay :: Maybe Int, + retries :: Int + } + deriving (Eq, Show) + +-- Sending files + +type DBSndFileId = Int64 + +data SndFile = SndFile + { userId :: Int64, + sndFileId :: DBSndFileId, + size :: FileSize Int64, + digest :: FileDigest, + key :: C.SbKey, + nonce :: C.CbNonce, + chunkSize :: FileSize Word32, + chunks :: [RcvFileChunk], + path :: FilePath, + encPath :: Maybe FilePath, + status :: SndFileStatus + } + deriving (Eq, Show) + +data SndFileStatus + = SFSNew + | SFSEncrypting + | SFSEncrypted + | SFSUploading + | SFSComplete + deriving (Eq, Show) + +instance FromField SndFileStatus where fromField = fromTextField_ textDecode + +instance ToField SndFileStatus where toField = toField . textEncode + +instance TextEncoding SndFileStatus where + textDecode = \case + "new" -> Just SFSNew + "encrypting" -> Just SFSEncrypting + "encrypted" -> Just SFSEncrypted + "uploading" -> Just SFSUploading + "complete" -> Just SFSComplete + _ -> Nothing + textEncode = \case + SFSNew -> "new" + SFSEncrypting -> "encrypting" + SFSEncrypted -> "encrypted" + SFSUploading -> "uploading" + SFSComplete -> "complete" + +data SndFileChunk = SndFileChunk + { userId :: Int64, + sndFileId :: DBSndFileId, + sndChunkId :: Int64, + chunkNo :: Int, + chunkSpec :: XFTPChunkSpec, + digest :: FileDigest, + replicas :: [SndFileChunkReplica], + delay :: Maybe Int + } + deriving (Eq, Show) + +data SndFileChunkReplica = SndFileChunkReplica + { sndChunkReplicaId :: Int64, + server :: XFTPServer, + replicaId :: ChunkReplicaId, + replicaKey :: C.APrivateSignKey, + rcvIdsKeys :: [(ChunkReplicaId, C.APrivateSignKey)], + -- created :: Bool, + uploaded :: Bool, + retries :: Int + } + deriving (Eq, Show) + +-- to be used in reply to client +data SndFileDescription = SndFileDescription + { description :: String, + sender :: Bool + } + deriving (Eq, Show) diff --git a/src/Simplex/FileTransfer/Util.hs b/src/Simplex/FileTransfer/Util.hs new file mode 100644 index 000000000..fad920747 --- /dev/null +++ b/src/Simplex/FileTransfer/Util.hs @@ -0,0 +1,24 @@ +module Simplex.FileTransfer.Util + ( uniqueCombine, + removePath, + ) +where + +import Simplex.Messaging.Util (ifM, whenM) +import System.FilePath (splitExtensions, ()) +import UnliftIO +import UnliftIO.Directory + +uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath +uniqueCombine filePath fileName = tryCombine (0 :: Int) + where + tryCombine n = + let (name, ext) = splitExtensions fileName + suffix = if n == 0 then "" else "_" <> show n + f = filePath (name <> suffix <> ext) + in ifM (doesPathExist f) (tryCombine $ n + 1) (pure f) + +removePath :: MonadIO m => FilePath -> m () +removePath p = do + ifM (doesDirectoryExist p) (removeDirectoryRecursive p) $ + whenM (doesFileExist p) (removeFile p) diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index 8ae5e5306..8d037c185 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/src/Simplex/Messaging/Agent.hs @@ -80,6 +80,9 @@ module Simplex.Messaging.Agent getNtfToken, getNtfTokenData, toggleConnectionNtfs, + xftpReceiveFile, + xftpDeleteRcvFile, + xftpSendFile, activateAgent, suspendAgent, execAgentStoreSQL, @@ -113,6 +116,10 @@ import qualified Data.Text as T import Data.Time.Clock import Data.Time.Clock.System (systemToUTCTime) import qualified Database.SQLite.Simple as DB +import Simplex.FileTransfer.Agent (addXFTPWorker, deleteRcvFile, receiveFile, sendFileExperimental) +import Simplex.FileTransfer.Description (ValidFileDescription) +import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.FileTransfer.Util (removePath) import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Lock (withLock) @@ -130,7 +137,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken, NtfRegCode (NtfReg import Simplex.Messaging.Notifications.Server.Push.APNS (PNMessageData (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (parse) -import Simplex.Messaging.Protocol (BrokerMsg, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr') +import Simplex.Messaging.Protocol (BrokerMsg, EntityId, ErrorType (AUTH), MsgBody, MsgFlags, NtfServer, SMPMsgMeta, SndPublicVerifyKey, protoServer, sameSrvAddr') import qualified Simplex.Messaging.Protocol as SMP import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util @@ -150,7 +157,17 @@ getSMPAgentClient cfg initServers = newSMPAgentEnv cfg >>= runReaderT runAgent runAgent = do c <- getAgentClient initServers void $ raceAny_ [subscriber c, runNtfSupervisor c, cleanupManager c] `forkFinally` const (disconnectAgentClient c) + runExceptT (startFiles c) >>= \case + Left e -> liftIO $ print e + Right _ -> pure () pure c + startFiles c = do + pendingRcvServers <- withStore' c getPendingRcvFilesServers + forM_ pendingRcvServers $ \s -> addXFTPWorker c (Just s) + -- start local worker for files pending decryption, + -- no need to make an extra query for the check + -- as the worker will check the store anyway + addXFTPWorker c Nothing disconnectAgentClient :: MonadUnliftIO m => AgentClient -> m () disconnectAgentClient c@AgentClient {agentEnv = Env {ntfSupervisor = ns}} = do @@ -276,18 +293,18 @@ getConnectionRatchetAdHash :: AgentErrorMonad m => AgentClient -> ConnId -> m By getConnectionRatchetAdHash c = withAgentEnv c . getConnectionRatchetAdHash' c -- | Change servers to be used for creating new queues -setSMPServers :: AgentErrorMonad m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m () +setSMPServers :: MonadUnliftIO m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m () setSMPServers c = withAgentEnv c .: setSMPServers' c -- | Test SMP server testSMPServerConnection :: AgentErrorMonad m => AgentClient -> UserId -> SMPServerWithAuth -> m (Maybe SMPTestFailure) testSMPServerConnection c = withAgentEnv c .: runSMPServerTest c -setNtfServers :: AgentErrorMonad m => AgentClient -> [NtfServer] -> m () +setNtfServers :: MonadUnliftIO m => AgentClient -> [NtfServer] -> m () setNtfServers c = withAgentEnv c . setNtfServers' c -- | set SOCKS5 proxy on/off and optionally set TCP timeout -setNetworkConfig :: AgentErrorMonad m => AgentClient -> NetworkConfig -> m () +setNetworkConfig :: MonadUnliftIO m => AgentClient -> NetworkConfig -> m () setNetworkConfig c cfg' = do cfg <- atomically $ do swapTVar (useNetworkConfig c) cfg' @@ -322,31 +339,43 @@ getNtfTokenData c = withAgentEnv c $ getNtfTokenData' c toggleConnectionNtfs :: AgentErrorMonad m => AgentClient -> ConnId -> Bool -> m () toggleConnectionNtfs c = withAgentEnv c .: toggleConnectionNtfs' c +-- | Receive XFTP file +xftpReceiveFile :: AgentErrorMonad m => AgentClient -> UserId -> ValidFileDescription 'FRecipient -> Maybe FilePath -> m RcvFileId +xftpReceiveFile c = withAgentEnv c .:. receiveFile c + +-- | Delete XFTP rcv file (deletes work files from file system and db records) +xftpDeleteRcvFile :: AgentErrorMonad m => AgentClient -> UserId -> RcvFileId -> m () +xftpDeleteRcvFile c = withAgentEnv c .: deleteRcvFile c + +-- | Send XFTP file +xftpSendFile :: AgentErrorMonad m => AgentClient -> UserId -> FilePath -> Int -> Maybe FilePath -> m SndFileId +xftpSendFile c = withAgentEnv c .:: sendFileExperimental c + -- | Activate operations -activateAgent :: AgentErrorMonad m => AgentClient -> m () +activateAgent :: MonadUnliftIO m => AgentClient -> m () activateAgent c = withAgentEnv c $ activateAgent' c -- | Suspend operations with max delay to deliver pending messages -suspendAgent :: AgentErrorMonad m => AgentClient -> Int -> m () +suspendAgent :: MonadUnliftIO m => AgentClient -> Int -> m () suspendAgent c = withAgentEnv c . suspendAgent' c execAgentStoreSQL :: AgentErrorMonad m => AgentClient -> Text -> m [Text] execAgentStoreSQL c = withAgentEnv c . execAgentStoreSQL' c -debugAgentLocks :: AgentErrorMonad m => AgentClient -> m AgentLocks +debugAgentLocks :: MonadUnliftIO m => AgentClient -> m AgentLocks debugAgentLocks c = withAgentEnv c $ debugAgentLocks' c -getAgentStats :: AgentErrorMonad m => AgentClient -> m [(AgentStatsKey, Int)] +getAgentStats :: MonadIO m => AgentClient -> m [(AgentStatsKey, Int)] getAgentStats c = readTVarIO (agentStats c) >>= mapM (\(k, cnt) -> (k,) <$> readTVarIO cnt) . M.assocs -resetAgentStats :: AgentErrorMonad m => AgentClient -> m () +resetAgentStats :: MonadIO m => AgentClient -> m () resetAgentStats = atomically . TM.clear . agentStats withAgentEnv :: AgentClient -> ReaderT Env m a -> m a withAgentEnv c = (`runReaderT` agentEnv c) -- | Creates an SMP agent client instance that receives commands and sends responses via 'TBQueue's. -getAgentClient :: (MonadUnliftIO m, MonadReader Env m) => InitialAgentServers -> m AgentClient +getAgentClient :: AgentMonad' m => InitialAgentServers -> m AgentClient getAgentClient initServers = ask >>= atomically . newAgentClient initServers logConnection :: MonadUnliftIO m => AgentClient -> Bool -> m () @@ -355,34 +384,36 @@ logConnection c connected = in logInfo $ T.unwords ["client", showText (clientId c), event, "Agent"] -- | Runs an SMP agent instance that receives commands and sends responses via 'TBQueue's. -runAgentClient :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () +runAgentClient :: AgentMonad' m => AgentClient -> m () runAgentClient c = race_ (subscriber c) (client c) -client :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () +client :: forall m. AgentMonad' m => AgentClient -> m () client c@AgentClient {rcvQ, subQ} = forever $ do - (corrId, connId, cmd) <- atomically $ readTBQueue rcvQ - runExceptT (processCommand c (connId, cmd)) + (corrId, entId, cmd) <- atomically $ readTBQueue rcvQ + runExceptT (processCommand c (entId, cmd)) >>= atomically . writeTBQueue subQ . \case - Left e -> (corrId, connId, ERR e) - Right (connId', resp) -> (corrId, connId', resp) + Left e -> (corrId, entId, APC SAEConn $ ERR e) + Right (entId', resp) -> (corrId, entId', resp) -- | execute any SMP agent command -processCommand :: forall m. AgentMonad m => AgentClient -> (ConnId, ACommand 'Client) -> m (ConnId, ACommand 'Agent) -processCommand c (connId, cmd) = case cmd of - NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing - JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo - LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK) - ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo - RJCT invId -> rejectContact' c connId invId $> (connId, OK) - SUB -> subscribeConnection' c connId $> (connId, OK) - SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody - ACK msgId -> ackMessage' c connId msgId $> (connId, OK) - SWCH -> switchConnection' c connId $> (connId, OK) - OFF -> suspendConnection' c connId $> (connId, OK) - DEL -> deleteConnection' c connId $> (connId, OK) - CHK -> (connId,) . STAT <$> getConnectionServers' c connId +processCommand :: forall m. AgentMonad m => AgentClient -> (EntityId, APartyCmd 'Client) -> m (EntityId, APartyCmd 'Agent) +processCommand c (connId, APC e cmd) = + second (APC e) <$> case cmd of + NEW enableNtfs (ACM cMode) -> second (INV . ACR cMode) <$> newConn c userId connId enableNtfs cMode Nothing + JOIN enableNtfs (ACR _ cReq) connInfo -> (,OK) <$> joinConn c userId connId False enableNtfs cReq connInfo + LET confId ownCInfo -> allowConnection' c connId confId ownCInfo $> (connId, OK) + ACPT invId ownCInfo -> (,OK) <$> acceptContact' c connId True invId ownCInfo + RJCT invId -> rejectContact' c connId invId $> (connId, OK) + SUB -> subscribeConnection' c connId $> (connId, OK) + SEND msgFlags msgBody -> (connId,) . MID <$> sendMessage' c connId msgFlags msgBody + ACK msgId -> ackMessage' c connId msgId $> (connId, OK) + SWCH -> switchConnection' c connId $> (connId, OK) + OFF -> suspendConnection' c connId $> (connId, OK) + DEL -> deleteConnection' c connId $> (connId, OK) + CHK -> (connId,) . STAT <$> getConnectionServers' c connId where -- command interface does not support different users + userId :: UserId userId = 1 createUser' :: AgentMonad m => AgentClient -> NonEmpty SMPServerWithAuth -> m UserId @@ -400,12 +431,12 @@ deleteUser' c userId delSMPQueues = do where delUser = whenM (withStore' c (`deleteUserWithoutConns` userId)) $ - atomically $ writeTBQueue (subQ c) ("", "", DEL_USER userId) + atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId) newConnAsync :: forall m c. (AgentMonad m, ConnectionModeI c) => AgentClient -> UserId -> ACorrId -> Bool -> SConnectionMode c -> m ConnId newConnAsync c userId corrId enableNtfs cMode = do connId <- newConnNoQueues c userId "" enableNtfs cMode - enqueueCommand c corrId connId Nothing $ AClientCommand $ NEW enableNtfs (ACM cMode) + enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ NEW enableNtfs (ACM cMode) pure connId newConnNoQueues :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> m ConnId @@ -424,7 +455,7 @@ joinConnAsync c userId corrId enableNtfs cReqUri@(CRInvitationUri ConnReqUriData let duplexHS = connAgentVersion /= 1 cData = ConnData {userId, connId = "", connAgentVersion, enableNtfs, duplexHandshake = Just duplexHS, deleted = False} connId <- withStore c $ \db -> createNewConn db g cData SCMInvitation - enqueueCommand c corrId connId Nothing $ AClientCommand $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo + enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn $ JOIN enableNtfs (ACR sConnectionMode cReqUri) cInfo pure connId _ -> throwError $ AGENT A_VERSION joinConnAsync _c _userId _corrId _enableNtfs (CRContactUri _) _cInfo = @@ -434,7 +465,7 @@ allowConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> Con allowConnectionAsync' c corrId connId confId ownConnInfo = withStore c (`getConn` connId) >>= \case SomeConn _ (RcvConnection _ RcvQueue {server}) -> - enqueueCommand c corrId connId (Just server) $ AClientCommand $ LET confId ownConnInfo + enqueueCommand c corrId connId (Just server) $ AClientCommand $ APC SAEConn $ LET confId ownConnInfo _ -> throwError $ CMD PROHIBITED acceptContactAsync' :: AgentMonad m => AgentClient -> ACorrId -> Bool -> InvitationId -> ConnInfo -> m ConnId @@ -461,7 +492,7 @@ ackMessageAsync' c corrId connId msgId = do enqueueAck :: m () enqueueAck = do (RcvQueue {server}, _) <- withStore c $ \db -> setMsgUserAck db connId $ InternalId msgId - enqueueCommand c corrId connId (Just server) . AClientCommand $ ACK msgId + enqueueCommand c corrId connId (Just server) . AClientCommand $ APC SAEConn $ ACK msgId deleteConnectionAsync' :: forall m. AgentMonad m => AgentClient -> ConnId -> m () deleteConnectionAsync' c connId = deleteConnectionsAsync' c [connId] @@ -483,7 +514,7 @@ deleteConnectionsAsync_ onSuccess c connIds = case connIds of switchConnectionAsync' :: AgentMonad m => AgentClient -> ACorrId -> ConnId -> m () switchConnectionAsync' c corrId connId = withStore c (`getConn` connId) >>= \case - SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand SWCH + SomeConn _ DuplexConnection {} -> enqueueCommand c corrId connId Nothing $ AClientCommand $ APC SAEConn SWCH _ -> throwError $ CMD PROHIBITED newConn :: AgentMonad m => AgentClient -> UserId -> ConnId -> Bool -> SConnectionMode c -> Maybe CRClientData -> m (ConnId, ConnectionRequestUri c) @@ -689,7 +720,7 @@ subscribeConnections' c connIds = do let actual = M.size rs expected = length connIds when (actual /= expected) . atomically $ - writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected) + writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "subscribeConnections result size: " <> show actual <> ", expected " <> show expected) resubscribeConnection' :: AgentMonad m => AgentClient -> ConnId -> m () resubscribeConnection' c connId = toConnResult connId =<< resubscribeConnections' c [connId] @@ -777,10 +808,10 @@ resumeConnCmds c connId = queuePendingCommands c srv cmdIds connQueued = atomically $ isJust <$> TM.lookupInsert connId True (connCmdsQueued c) -cmdProcessExists :: AgentMonad m => AgentClient -> Maybe SMPServer -> m Bool +cmdProcessExists :: AgentMonad' m => AgentClient -> Maybe SMPServer -> m Bool cmdProcessExists c srv = atomically $ TM.member srv (asyncCmdProcesses c) -queuePendingCommands :: AgentMonad m => AgentClient -> Maybe SMPServer -> [AsyncCmdId] -> m () +queuePendingCommands :: AgentMonad' m => AgentClient -> Maybe SMPServer -> [AsyncCmdId] -> m () queuePendingCommands c server cmdIds = atomically $ do q <- getPendingCommandQ c server mapM_ (writeTQueue q) cmdIds @@ -804,12 +835,12 @@ runCommandProcessing c@AgentClient {subQ} server_ = do cmdId <- atomically $ readTQueue cq atomically $ beginAgentOperation c AOSndNetwork E.try (withStore c $ \db -> getPendingCommand db cmdId) >>= \case - Left (e :: E.SomeException) -> atomically $ writeTBQueue subQ ("", "", ERR . INTERNAL $ show e) + Left (e :: E.SomeException) -> atomically $ writeTBQueue subQ ("", "", APC SAEConn $ ERR $ INTERNAL $ show e) Right cmd -> processCmd (riFast ri) cmdId cmd where processCmd :: RetryInterval -> AsyncCmdId -> PendingCommand -> m () processCmd ri cmdId PendingCommand {corrId, userId, connId, command} = case command of - AClientCommand cmd -> case cmd of + AClientCommand (APC _ cmd) -> case cmd of NEW enableNtfs (ACM cMode) -> noServer $ do usedSrvs <- newTVarIO ([] :: [SMPServer]) tryCommand . withNextSrv usedSrvs [] $ \srv -> do @@ -896,7 +927,8 @@ runCommandProcessing c@AgentClient {subQ} server_ = do tryWithLock name = tryCommand . withConnLock c connId name internalErr s = cmdError $ INTERNAL $ s <> ": " <> show (agentCommandTag command) cmdError e = notify (ERR e) >> withStore' c (`deleteCommand` cmdId) - notify cmd = atomically $ writeTBQueue subQ (corrId, connId, cmd) + notify :: forall e. AEntityI e => ACommand 'Agent e -> m () + notify cmd = atomically $ writeTBQueue subQ (corrId, connId, APC (sAEntity @e) cmd) withNextSrv :: TVar [SMPServer] -> [SMPServer] -> (SMPServerWithAuth -> m ()) -> m () withNextSrv usedSrvs initUsed action = do used <- readTVarIO usedSrvs @@ -959,7 +991,7 @@ resumeMsgDelivery c cData@ConnData {connId} sq@SndQueue {server, sndId} = do queueDelivering qKey = atomically $ TM.member qKey (smpQueueMsgDeliveries c) msgsQueued = atomically $ isJust <$> TM.lookupInsert (server, sndId) True (pendingMsgsQueued c) -queuePendingMsgs :: AgentMonad m => AgentClient -> SndQueue -> [InternalId] -> m () +queuePendingMsgs :: AgentMonad' m => AgentClient -> SndQueue -> [InternalId] -> m () queuePendingMsgs c sq msgIds = atomically $ do modifyTVar' (msgDeliveryOp c) $ \s -> s {opsInProgress = opsInProgress s + length msgIds} -- s <- readTVar (msgDeliveryOp c) @@ -1105,9 +1137,9 @@ runSmpQueueMsgDelivery c@AgentClient {subQ} cData@ConnData {userId, connId, dupl where delMsg :: InternalId -> m () delMsg msgId = withStore' c $ \db -> deleteSndMsgDelivery db connId sq msgId - notify :: ACommand 'Agent -> m () - notify cmd = atomically $ writeTBQueue subQ ("", connId, cmd) - notifyDel :: InternalId -> ACommand 'Agent -> m () + notify :: forall e. AEntityI e => ACommand 'Agent e -> m () + notify cmd = atomically $ writeTBQueue subQ ("", connId, APC (sAEntity @e) cmd) + notifyDel :: AEntityI e => InternalId -> ACommand 'Agent e -> m () notifyDel msgId cmd = notify cmd >> delMsg msgId connError msgId = notifyDel msgId . ERR . CONN qError msgId = notifyDel msgId . ERR . AGENT . A_QUEUE @@ -1226,7 +1258,7 @@ deleteConnQueues :: forall m. AgentMonad m => AgentClient -> Bool -> [RcvQueue] deleteConnQueues c ntf rqs = do rs <- connResults <$> (deleteQueueRecs =<< deleteQueues c rqs) forM_ (M.assocs rs) $ \case - (connId, Right _) -> withStore' c (`deleteConn` connId) >> notify ("", connId, DEL_CONN) + (connId, Right _) -> withStore' c (`deleteConn` connId) >> notify ("", connId, APC SAEConn DEL_CONN) _ -> pure () pure rs where @@ -1240,7 +1272,7 @@ deleteConnQueues c ntf rqs = do | temporaryOrHostError e && deleteErrors rq + 1 < maxErrs -> withStore' c (`incRcvDeleteErrors` rq) $> r | otherwise -> withStore' c (`deleteConnRcvQueue` rq) >> notifyRQ rq (Just e) $> Right () pure (rq, r') - notifyRQ rq e_ = notify ("", qConnId rq, DEL_RCVQ (qServer rq) (queueId rq) e_) + notifyRQ rq e_ = notify ("", qConnId rq, APC SAEConn $ DEL_RCVQ (qServer rq) (queueId rq) e_) notify = when ntf . atomically . writeTBQueue (subQ c) connResults :: [(RcvQueue, Either AgentErrorType ())] -> Map ConnId (Either AgentErrorType ()) connResults = M.map snd . foldl' addResult M.empty @@ -1278,7 +1310,7 @@ deleteConnections_ getConnections ntf c connIds = do let actual = M.size rs expected = length connIds when (actual /= expected) . atomically $ - writeTBQueue (subQ c) ("", "", ERR . INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected) + writeTBQueue (subQ c) ("", "", APC SAEConn $ ERR $ INTERNAL $ "deleteConnections result size: " <> show actual <> ", expected " <> show expected) getConnectionServers' :: AgentMonad m => AgentClient -> ConnId -> m ConnectionStats getConnectionServers' c connId = do @@ -1299,7 +1331,7 @@ connectionStats = \case NewConnection _ -> ConnectionStats {rcvServers = [], sndServers = []} -- | Change servers to be used for creating new queues, in Reader monad -setSMPServers' :: AgentMonad m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m () +setSMPServers' :: AgentMonad' m => AgentClient -> UserId -> NonEmpty SMPServerWithAuth -> m () setSMPServers' c userId srvs = atomically $ TM.insert userId srvs $ smpServers c registerNtfToken' :: forall m. AgentMonad m => AgentClient -> DeviceToken -> NotificationsMode -> m NtfTknStatus @@ -1494,19 +1526,19 @@ sendNtfConnCommands c cmd = do Just (ConnData {enableNtfs}, _) -> when enableNtfs . atomically $ writeTBQueue (ntfSubQ ns) (connId, cmd) _ -> - atomically $ writeTBQueue (subQ c) ("", connId, ERR $ INTERNAL "no connection data") + atomically $ writeTBQueue (subQ c) ("", connId, APC SAEConn $ ERR $ INTERNAL "no connection data") -setNtfServers' :: AgentMonad m => AgentClient -> [NtfServer] -> m () +setNtfServers' :: AgentMonad' m => AgentClient -> [NtfServer] -> m () setNtfServers' c = atomically . writeTVar (ntfServers c) -activateAgent' :: AgentMonad m => AgentClient -> m () +activateAgent' :: AgentMonad' m => AgentClient -> m () activateAgent' c = do atomically $ writeTVar (agentState c) ASActive mapM_ activate $ reverse agentOperations where activate opSel = atomically $ modifyTVar' (opSel c) $ \s -> s {opSuspended = False} -suspendAgent' :: AgentMonad m => AgentClient -> Int -> m () +suspendAgent' :: AgentMonad' m => AgentClient -> Int -> m () suspendAgent' c 0 = do atomically $ writeTVar (agentState c) ASSuspended mapM_ suspend agentOperations @@ -1531,7 +1563,7 @@ suspendAgent' c@AgentClient {agentState = as} maxDelay = do execAgentStoreSQL' :: AgentMonad m => AgentClient -> Text -> m [Text] execAgentStoreSQL' c sql = withStore' c (`execSQL` sql) -debugAgentLocks' :: AgentMonad m => AgentClient -> m AgentLocks +debugAgentLocks' :: AgentMonad' m => AgentClient -> m AgentLocks debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs, deleteLock = d} = do connLocks <- getLocks cs srvLocks <- getLocks rs @@ -1543,7 +1575,7 @@ debugAgentLocks' AgentClient {connLocks = cs, reconnectLocks = rs, deleteLock = getSMPServer :: AgentMonad m => AgentClient -> UserId -> m SMPServerWithAuth getSMPServer c userId = withUserServers c userId pickServer -pickServer :: AgentMonad m => NonEmpty SMPServerWithAuth -> m SMPServerWithAuth +pickServer :: AgentMonad' m => NonEmpty SMPServerWithAuth -> m SMPServerWithAuth pickServer = \case srv :| [] -> pure srv servers -> do @@ -1562,7 +1594,7 @@ withUserServers c userId action = Just srvs -> action srvs _ -> throwError $ INTERNAL "unknown userId - no SMP servers" -subscriber :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () +subscriber :: AgentMonad' m => AgentClient -> m () subscriber c@AgentClient {msgQ} = forever $ do t <- atomically $ readTBQueue msgQ agentOperationBracket c AORcvNetwork waitUntilActive $ @@ -1570,18 +1602,32 @@ subscriber c@AgentClient {msgQ} = forever $ do Left e -> liftIO $ print e Right _ -> return () -cleanupManager :: (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () +cleanupManager :: AgentMonad' m => AgentClient -> m () cleanupManager c = do threadDelay =<< asks (initialCleanupDelay . config) int <- asks (cleanupInterval . config) forever $ do - void . runExceptT $ + void . runExceptT $ do + deleteConns + deleteFiles + threadDelay int + where + deleteConns = withLock (deleteLock c) "cleanupManager" $ do void $ withStore' c getDeletedConnIds >>= deleteDeletedConns c withStore' c deleteUsersWithoutConns >>= mapM_ notifyUserDeleted - threadDelay int - where - notifyUserDeleted userId = atomically $ writeTBQueue (subQ c) ("", "", DEL_USER userId) + notifyUserDeleted userId = atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ DEL_USER userId) + deleteFiles = do + -- cleanup rcv files marked for deletion + rcvDeleted <- withStore' c getCleanupRcvFilesDeleted + forM_ rcvDeleted $ \(fId, p) -> do + removePath p + withStore' c (`deleteRcvFile'` fId) + -- cleanup rcv tmp paths + rcvTmpPaths <- withStore' c getCleanupRcvFilesTmpPaths + forM_ rcvTmpPaths $ \(fId, p) -> do + removePath p + withStore' c (`updateRcvFileNoTmpPath` fId) processSMPTransmission :: forall m. AgentMonad m => AgentClient -> ServerTransmission BrokerMsg -> m () processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, sessId, rId, cmd) = do @@ -1695,7 +1741,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s Just (Right clnt) | sessId == sessionId clnt -> do removeSubscription c connId - writeTBQueue subQ ("", connId, END) + notify' END pure "END" | otherwise -> ignored _ -> ignored @@ -1704,8 +1750,11 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s logServer "<--" c srv rId $ "unexpected: " <> bshow cmd notify . ERR $ BROKER (B.unpack $ strEncode srv) UNEXPECTED where - notify :: ACommand 'Agent -> m () - notify msg = atomically $ writeTBQueue subQ ("", connId, msg) + notify :: forall e. AEntityI e => ACommand 'Agent e -> m () + notify = atomically . notify' + + notify' :: forall e. AEntityI e => ACommand 'Agent e -> STM () + notify' msg = writeTBQueue subQ ("", connId, APC (sAEntity @e) msg) prohibited :: m () prohibited = notify . ERR $ AGENT A_PROHIBITED @@ -1786,7 +1835,7 @@ processSMPTransmission c@AgentClient {smpClients, subQ} (tSess@(_, srv, _), v, s -- this branch is executed by the accepting party in duplexHandshake mode (v2) -- and by the initiating party in v1 -- Also see comment where HELLO is sent. - | sndStatus == Active -> atomically $ writeTBQueue subQ ("", connId, CON) + | sndStatus == Active -> notify CON | duplexHandshake == Just True -> enqueueDuplexHello sq | otherwise -> pure () _ -> pure () diff --git a/src/Simplex/Messaging/Agent/Client.hs b/src/Simplex/Messaging/Agent/Client.hs index d6be964db..245c17d09 100644 --- a/src/Simplex/Messaging/Agent/Client.hs +++ b/src/Simplex/Messaging/Agent/Client.hs @@ -15,6 +15,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} module Simplex.Messaging.Agent.Client ( AgentClient (..), @@ -24,6 +25,7 @@ module Simplex.Messaging.Agent.Client withConnLock, closeAgentClient, closeProtocolServerClients, + closeXFTPServerClient, runSMPServerTest, newRcvQueue, subscribeQueues, @@ -48,6 +50,7 @@ module Simplex.Messaging.Agent.Client agentNtfCreateSubscription, agentNtfCheckSubscription, agentNtfDeleteSubscription, + agentXFTPDownloadChunk, agentCbEncrypt, agentCbDecrypt, cryptoError, @@ -108,10 +111,17 @@ import Data.Maybe (isJust, listToMaybe) import Data.Set (Set) import qualified Data.Set as S import Data.Text.Encoding +import Data.Time (UTCTime) import Data.Word (Word16) import qualified Database.SQLite.Simple as DB import GHC.Generics (Generic) import Network.Socket (HostName) +import Simplex.FileTransfer.Client (XFTPClient, XFTPClientConfig (..)) +import qualified Simplex.FileTransfer.Client as X +import Simplex.FileTransfer.Description (ChunkReplicaId (..)) +import Simplex.FileTransfer.Protocol (FileResponse, XFTPErrorType) +import Simplex.FileTransfer.Transport (XFTPRcvChunkSpec) +import Simplex.FileTransfer.Types (RcvFileChunkReplica (..)) import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Protocol @@ -151,6 +161,7 @@ import Simplex.Messaging.Protocol RcvNtfPublicDhKey, SMPMsgMeta (..), SndPublicVerifyKey, + XFTPServerWithAuth, ) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.TMap (TMap) @@ -163,16 +174,20 @@ import UnliftIO (mapConcurrently) import qualified UnliftIO.Exception as E import UnliftIO.STM -type ClientVar err msg = TMVar (Either AgentErrorType (ProtocolClient err msg)) +type ClientVar msg = TMVar (Either AgentErrorType (Client msg)) -type SMPClientVar = TMVar (Either AgentErrorType SMPClient) +type SMPClientVar = ClientVar SMP.BrokerMsg -type NtfClientVar = TMVar (Either AgentErrorType NtfClient) +type NtfClientVar = ClientVar NtfResponse + +type XFTPClientVar = TMVar (Either AgentErrorType XFTPClient) type SMPTransportSession = TransportSession SMP.BrokerMsg type NtfTransportSession = TransportSession NtfResponse +type XFTPTransportSession = TransportSession FileResponse + data AgentClient = AgentClient { active :: TVar Bool, rcvQ :: TBQueue (ATransmission 'Client), @@ -182,6 +197,8 @@ data AgentClient = AgentClient smpClients :: TMap SMPTransportSession SMPClientVar, ntfServers :: TVar [NtfServer], ntfClients :: TMap NtfTransportSession NtfClientVar, + xftpServers :: TMap UserId (NonEmpty XFTPServerWithAuth), + xftpClients :: TMap XFTPTransportSession XFTPClientVar, useNetworkConfig :: TVar NetworkConfig, subscrConns :: TVar (Set ConnId), activeSubs :: TRcvQueues, @@ -246,7 +263,7 @@ data AgentStatsKey = AgentStatsKey deriving (Eq, Ord, Show) newAgentClient :: InitialAgentServers -> Env -> STM AgentClient -newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do +newAgentClient InitialAgentServers {smp, ntf, xftp, netCfg} agentEnv = do let qSize = tbqSize $ config agentEnv active <- newTVar True rcvQ <- newTBQueue qSize @@ -256,6 +273,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do smpClients <- TM.empty ntfServers <- newTVar ntf ntfClients <- TM.empty + xftpServers <- newTVar xftp + xftpClients <- TM.empty useNetworkConfig <- newTVar netCfg subscrConns <- newTVar S.empty activeSubs <- RQ.empty @@ -290,6 +309,8 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do smpClients, ntfServers, ntfClients, + xftpServers, + xftpClients, useNetworkConfig, subscrConns, activeSubs, @@ -320,17 +341,41 @@ newAgentClient InitialAgentServers {smp, ntf, netCfg} agentEnv = do agentClientStore :: AgentClient -> SQLiteStore agentClientStore AgentClient {agentEnv = Env {store}} = store -class ProtocolServerClient err msg | msg -> err where - getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (ProtocolClient err msg) +class (Encoding err, Show err) => ProtocolServerClient err msg | msg -> err where + type Client msg = c | c -> msg + getProtocolServerClient :: AgentMonad m => AgentClient -> TransportSession msg -> m (Client msg) clientProtocolError :: err -> AgentErrorType + closeProtocolServerClient :: Client msg -> IO () + clientServer :: Client msg -> String + clientTransportHost :: Client msg -> TransportHost + clientSessionTs :: Client msg -> UTCTime instance ProtocolServerClient ErrorType BrokerMsg where + type Client BrokerMsg = ProtocolClient ErrorType BrokerMsg getProtocolServerClient = getSMPServerClient clientProtocolError = SMP + closeProtocolServerClient = closeProtocolClient + clientServer = protocolClientServer + clientTransportHost = transportHost' + clientSessionTs = sessionTs instance ProtocolServerClient ErrorType NtfResponse where + type Client NtfResponse = ProtocolClient ErrorType NtfResponse getProtocolServerClient = getNtfServerClient clientProtocolError = NTF + closeProtocolServerClient = closeProtocolClient + clientServer = protocolClientServer + clientTransportHost = transportHost' + clientSessionTs = sessionTs + +instance ProtocolServerClient XFTPErrorType FileResponse where + type Client FileResponse = XFTPClient + getProtocolServerClient = getXFTPServerClient + clientProtocolError = XFTP + closeProtocolServerClient = X.closeXFTPClient + clientServer = X.xftpClientServer + clientTransportHost = X.xftpTransportHost + clientSessionTs = X.xftpSessionTs getSMPServerClient :: forall m. AgentMonad m => AgentClient -> SMPTransportSession -> m SMPClient getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, _) = do @@ -369,8 +414,8 @@ getSMPServerClient c@AgentClient {active, smpClients, msgQ} tSess@(userId, srv, atomically $ mapM_ (releaseGetLock c) qs unliftIO u $ reconnectServer c tSess - notifySub :: ConnId -> ACommand 'Agent -> IO () - notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd) + notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO () + notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd) reconnectServer :: AgentMonad m => AgentClient -> SMPTransportSession -> m () reconnectServer c tSess = newAsyncAction tryReconnectSMPClient $ reconnections c @@ -397,8 +442,8 @@ reconnectSMPClient c tSess@(_, srv, _) = let (tempErrs, finalErrs) = partition (temporaryAgentError . snd) errs liftIO $ mapM_ (\(connId, e) -> notifySub connId $ ERR e) finalErrs mapM_ (throwError . snd) $ listToMaybe tempErrs - notifySub :: ConnId -> ACommand 'Agent -> IO () - notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, cmd) + notifySub :: forall e. AEntityI e => ConnId -> ACommand 'Agent e -> IO () + notifySub connId cmd = atomically $ writeTBQueue (subQ c) ("", connId, APC (sAEntity @e) cmd) getNtfServerClient :: forall m. AgentMonad m => AgentClient -> NtfTransportSession -> m NtfClient getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = do @@ -417,7 +462,28 @@ getNtfServerClient c@AgentClient {active, ntfClients} tSess@(userId, srv, _) = d clientDisconnected client = do atomically $ TM.delete tSess ntfClients incClientStat c userId client "DISCONNECT" "" - atomically $ writeTBQueue (subQ c) ("", "", hostEvent DISCONNECT client) + atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client) + logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv + +getXFTPServerClient :: forall m. AgentMonad m => AgentClient -> XFTPTransportSession -> m XFTPClient +getXFTPServerClient c@AgentClient {active, xftpClients, useNetworkConfig} tSess@(userId, srv, _) = do + unlessM (readTVarIO active) . throwError $ INTERNAL "agent is stopped" + atomically (getClientVar tSess xftpClients) + >>= either + (newProtocolClient c tSess xftpClients connectClient $ \_ _ -> pure ()) + (waitForProtocolClient c tSess) + where + connectClient :: m XFTPClient + connectClient = do + cfg <- asks $ xftpCfg . config + xftpNetworkConfig <- readTVarIO useNetworkConfig + liftEitherError (protocolClientError XFTP $ B.unpack $ strEncode srv) (X.getXFTPClient tSess cfg {xftpNetworkConfig} clientDisconnected) + + clientDisconnected :: XFTPClient -> IO () + clientDisconnected client = do + atomically $ TM.delete tSess xftpClients + incClientStat c userId client "DISCONNECT" "" + atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent DISCONNECT client) logInfo . decodeUtf8 $ "Agent disconnected from " <> showServer srv getClientVar :: forall a s. TransportSession s -> TMap (TransportSession s) (TMVar a) -> STM (Either (TMVar a) (TMVar a)) @@ -429,7 +495,7 @@ getClientVar tSess clients = maybe (Left <$> newClientVar) (pure . Right) =<< TM TM.insert tSess var clients pure var -waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar err msg -> m (ProtocolClient err msg) +waitForProtocolClient :: (AgentMonad m, ProtocolTypeI (ProtoType msg)) => AgentClient -> TransportSession msg -> ClientVar msg -> m (Client msg) waitForProtocolClient c (_, srv, _) clientVar = do NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c client_ <- liftIO $ tcpConnectTimeout `timeout` atomically (readTMVar clientVar) @@ -440,24 +506,24 @@ waitForProtocolClient c (_, srv, _) clientVar = do newProtocolClient :: forall err msg m. - (AgentMonad m, ProtocolTypeI (ProtoType msg)) => + (AgentMonad m, ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> - TMap (TransportSession msg) (ClientVar err msg) -> - m (ProtocolClient err msg) -> + TMap (TransportSession msg) (ClientVar msg) -> + m (Client msg) -> (AgentClient -> TransportSession msg -> m ()) -> - ClientVar err msg -> - m (ProtocolClient err msg) + ClientVar msg -> + m (Client msg) newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconnectClient clientVar = tryConnectClient pure tryConnectAsync where - tryConnectClient :: (ProtocolClient err msg -> m a) -> m () -> m a + tryConnectClient :: (Client msg -> m a) -> m () -> m a tryConnectClient successAction retryAction = tryError connectClient >>= \r -> case r of Right client -> do logInfo . decodeUtf8 $ "Agent connected to " <> showServer srv <> " (user " <> bshow userId <> maybe "" (" for entity " <>) entityId_ <> ")" atomically $ putTMVar clientVar r liftIO $ incClientStat c userId client "CLIENT" "OK" - atomically $ writeTBQueue (subQ c) ("", "", hostEvent CONNECT client) + atomically $ writeTBQueue (subQ c) ("", "", APC SAENone $ hostEvent CONNECT client) successAction client Left e -> do liftIO $ incServerStat c userId srv "CLIENT" $ strEncode e @@ -475,10 +541,10 @@ newProtocolClient c tSess@(userId, srv, entityId_) clients connectClient reconne withRetryInterval ri $ \_ loop -> void $ tryConnectClient (const $ reconnectClient c tSess) loop atomically . removeAsyncAction aId $ asyncClients c -hostEvent :: forall err msg. ProtocolTypeI (ProtoType msg) => (AProtocolType -> TransportHost -> ACommand 'Agent) -> ProtocolClient err msg -> ACommand 'Agent -hostEvent event client = event (AProtocolType $ protocolTypeI @(ProtoType msg)) $ transportHost' client +hostEvent :: forall err msg. (ProtocolTypeI (ProtoType msg), ProtocolServerClient err msg) => (AProtocolType -> TransportHost -> ACommand 'Agent 'AENone) -> Client msg -> ACommand 'Agent 'AENone +hostEvent event = event (AProtocolType $ protocolTypeI @(ProtoType msg)) . clientTransportHost -getClientConfig :: AgentMonad m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig +getClientConfig :: AgentMonad' m => AgentClient -> (AgentConfig -> ProtocolClientConfig) -> m ProtocolClientConfig getClientConfig AgentClient {useNetworkConfig} cfgSel = do cfg <- asks $ cfgSel . config networkConfig <- readTVarIO useNetworkConfig @@ -489,6 +555,7 @@ closeAgentClient c = liftIO $ do atomically $ writeTVar (active c) False closeProtocolServerClients c smpClients closeProtocolServerClients c ntfClients + closeProtocolServerClients c xftpClients cancelActions . actions $ reconnections c cancelActions . actions $ asyncClients c cancelActions $ smpQueueMsgDeliveries c @@ -519,16 +586,24 @@ throwWhenNoDelivery c SndQueue {server, sndId} = where k = (server, sndId) -closeProtocolServerClients :: AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar err msg)) -> IO () +closeProtocolServerClients :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> IO () closeProtocolServerClients c clientsSel = - atomically (swapTVar cs M.empty) >>= mapM_ (forkIO . closeClient) - where - cs = clientsSel c - closeClient cVar = do - NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c - tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case - Just (Right client) -> closeProtocolClient client `catchAll_` pure () - _ -> pure () + atomically (clientsSel c `swapTVar` M.empty) >>= mapM_ (forkIO . closeClient_ c) + +closeClient :: ProtocolServerClient err msg => AgentClient -> (AgentClient -> TMap (TransportSession msg) (ClientVar msg)) -> TransportSession msg -> IO () +closeClient c clientSel tSess = + atomically (TM.lookupDelete tSess $ clientSel c) >>= mapM_ (closeClient_ c) + +closeClient_ :: ProtocolServerClient err msg => AgentClient -> ClientVar msg -> IO () +closeClient_ c cVar = do + NetworkConfig {tcpConnectTimeout} <- readTVarIO $ useNetworkConfig c + tcpConnectTimeout `timeout` atomically (readTMVar cVar) >>= \case + Just (Right client) -> closeProtocolServerClient client `catchAll_` pure () + _ -> pure () + +closeXFTPServerClient :: AgentMonad' m => AgentClient -> UserId -> RcvFileChunkReplica -> m () +closeXFTPServerClient c userId RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId} = + mkTransportSession c userId server fId >>= liftIO . closeClient c xftpClients cancelActions :: (Foldable f, Monoid (f (Async ()))) => TVar (f (Async ())) -> IO () cancelActions as = atomically (swapTVar as mempty) >>= mapM_ (forkIO . uninterruptibleCancel) @@ -542,29 +617,29 @@ withLockMap_ locks key = withGetLock $ TM.lookup key locks >>= maybe newLock pur where newLock = createLock >>= \l -> TM.insert key l locks $> l -withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient err msg -> m a) -> m a +withClient_ :: forall a m err msg. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> m a) -> m a withClient_ c tSess@(userId, srv, _) statCmd action = do cl <- getProtocolServerClient c tSess (action cl <* stat cl "OK") `catchError` logServerError cl where stat cl = liftIO . incClientStat c userId cl statCmd - logServerError :: ProtocolClient err msg -> AgentErrorType -> m a + logServerError :: Client msg -> AgentErrorType -> m a logServerError cl e = do logServer "<--" c srv "" $ strEncode e stat cl $ strEncode e throwError e -withLogClient_ :: (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient err msg -> m a) -> m a +withLogClient_ :: (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> m a) -> m a withLogClient_ c tSess@(_, srv, _) entId cmdStr action = do logServer "-->" c srv entId cmdStr res <- withClient_ c tSess cmdStr action logServer "<--" c srv entId "OK" return res -withClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg, ProtocolTypeI (ProtoType msg), Encoding err, Show err) => AgentClient -> TransportSession msg -> ByteString -> (ProtocolClient err msg -> ExceptT (ProtocolClientError err) IO a) -> m a +withClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a withClient c tSess statKey action = withClient_ c tSess statKey $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client -withLogClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg, ProtocolTypeI (ProtoType msg), Encoding err, Show err) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (ProtocolClient err msg -> ExceptT (ProtocolClientError err) IO a) -> m a +withLogClient :: forall m err msg a. (AgentMonad m, ProtocolServerClient err msg) => AgentClient -> TransportSession msg -> EntityId -> ByteString -> (Client msg -> ExceptT (ProtocolClientError err) IO a) -> m a withLogClient c tSess entId cmdStr action = withLogClient_ c tSess entId cmdStr $ \client -> liftClient (clientProtocolError @err @msg) (clientServer client) $ action client withSMPClient :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> ByteString -> (SMPClient -> ExceptT SMPClientError IO a) -> m a @@ -580,6 +655,17 @@ withSMPClient_ c q cmdStr action = do withNtfClient :: forall m a. AgentMonad m => AgentClient -> NtfServer -> EntityId -> ByteString -> (NtfClient -> ExceptT NtfClientError IO a) -> m a withNtfClient c srv = withLogClient c (0, srv, Nothing) +withXFTPClient :: + (AgentMonad m, ProtocolServerClient err msg) => + AgentClient -> + (UserId, ProtoServer msg, EntityId) -> + ByteString -> + (Client msg -> ExceptT (ProtocolClientError err) IO b) -> + m b +withXFTPClient c (userId, srv, fId) cmdStr action = do + tSess <- mkTransportSession c userId srv fId + withLogClient c tSess (strEncode fId) cmdStr action + liftClient :: (AgentMonad m, Show err, Encoding err) => (err -> AgentErrorType) -> HostName -> ExceptT (ProtocolClientError err) IO a -> m a liftClient protocolError_ = liftError . protocolClientError protocolError_ @@ -592,7 +678,7 @@ protocolClientError protocolError_ host = \case PCENetworkError -> BROKER host NETWORK PCEIncompatibleHost -> BROKER host HOST PCETransportError e -> BROKER host $ TRANSPORT e - e@PCESignatureError {} -> INTERNAL $ show e + e@PCECryptoError {} -> INTERNAL $ show e PCEIOError {} -> BROKER host NETWORK data SMPTestStep = TSConnect | TSCreateQueue | TSSecureQueue | TSDeleteQueue | TSDisconnect @@ -636,19 +722,19 @@ runSMPServerTest c userId (ProtoServerWithAuth srv auth) = do testErr :: SMPTestStep -> SMPClientError -> SMPTestFailure testErr step = SMPTestFailure step . protocolClientError SMP addr -mkTransportSession :: AgentMonad m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg) +mkTransportSession :: AgentMonad' m => AgentClient -> UserId -> ProtoServer msg -> EntityId -> m (TransportSession msg) mkTransportSession c userId srv entityId = mkTSession userId srv entityId <$> getSessionMode c mkTSession :: UserId -> ProtoServer msg -> EntityId -> TransportSessionMode -> TransportSession msg mkTSession userId srv entityId mode = (userId, srv, if mode == TSMEntity then Just entityId else Nothing) -mkSMPTransportSession :: (AgentMonad m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession +mkSMPTransportSession :: (AgentMonad' m, SMPQueueRec q) => AgentClient -> q -> m SMPTransportSession mkSMPTransportSession c q = mkSMPTSession q <$> getSessionMode c mkSMPTSession :: SMPQueueRec q => q -> TransportSessionMode -> SMPTransportSession mkSMPTSession q = mkTSession (qUserId q) (qServer q) (qConnId q) -getSessionMode :: AgentMonad m => AgentClient -> m TransportSessionMode +getSessionMode :: AgentMonad' m => AgentClient -> m TransportSessionMode getSessionMode = fmap sessionMode . readTVarIO . useNetworkConfig newRcvQueue :: AgentMonad m => AgentClient -> UserId -> ConnId -> SMPServerWithAuth -> VersionRange -> m (RcvQueue, SMPQueueUri) @@ -692,13 +778,6 @@ processSubResult c rq r = do _ -> addSubscription c rq pure r -temporaryClientError :: ProtocolClientError err -> Bool -temporaryClientError = \case - PCENetworkError -> True - PCEResponseTimeout -> True - PCEIOError _ -> True - _ -> False - temporaryAgentError :: AgentErrorType -> Bool temporaryAgentError = \case BROKER _ NETWORK -> True @@ -919,6 +998,10 @@ agentNtfDeleteSubscription :: AgentMonad m => AgentClient -> NtfSubscriptionId - agentNtfDeleteSubscription c subId NtfToken {ntfServer, ntfPrivKey} = withNtfClient c ntfServer subId "SDEL" $ \ntf -> ntfDeleteSubscription ntf ntfPrivKey subId +agentXFTPDownloadChunk :: AgentMonad m => AgentClient -> UserId -> RcvFileChunkReplica -> XFTPRcvChunkSpec -> m () +agentXFTPDownloadChunk c userId RcvFileChunkReplica {server, replicaId = ChunkReplicaId fId, replicaKey} chunkSpec = + withXFTPClient c (userId, server, fId) "FGET" $ \xftp -> X.downloadXFTPChunk xftp replicaKey fId chunkSpec + agentCbEncrypt :: AgentMonad m => SndQueue -> Maybe C.PublicKeyX25519 -> ByteString -> m ByteString agentCbEncrypt SndQueue {e2eDhSecret, smpClientVersion} e2ePubKey msg = do cmNonce <- liftIO C.randomCbNonce @@ -986,7 +1069,7 @@ suspendOperation c op endedAction = do notifySuspended :: AgentClient -> STM () notifySuspended c = do -- unsafeIOToSTM $ putStrLn "notifySuspended" - writeTBQueue (subQ c) ("", "", SUSPENDED) + writeTBQueue (subQ c) ("", "", APC SAENone SUSPENDED) writeTVar (agentState c) ASSuspended endOperation :: AgentClient -> AgentOperation -> STM () -> STM () @@ -1048,7 +1131,7 @@ incStat AgentClient {agentStats} n k = do Just v -> modifyTVar' v (+ n) _ -> newTVar n >>= \v -> TM.insert k v agentStats -incClientStat :: AgentClient -> UserId -> ProtocolClient err msg -> ByteString -> ByteString -> IO () +incClientStat :: ProtocolServerClient err msg => AgentClient -> UserId -> Client msg -> ByteString -> ByteString -> IO () incClientStat c userId pc = incClientStatN c userId pc 1 incServerStat :: AgentClient -> UserId -> ProtocolServer p -> ByteString -> ByteString -> IO () @@ -1058,8 +1141,8 @@ incServerStat c userId ProtocolServer {host} cmd res = do where statsKey = AgentStatsKey {userId, host = strEncode $ L.head host, clientTs = "", cmd, res} -incClientStatN :: AgentClient -> UserId -> ProtocolClient err msg -> Int -> ByteString -> ByteString -> IO () +incClientStatN :: ProtocolServerClient err msg => AgentClient -> UserId -> Client msg -> Int -> ByteString -> ByteString -> IO () incClientStatN c userId pc n cmd res = do atomically $ incStat c n statsKey where - statsKey = AgentStatsKey {userId, host = strEncode $ transportHost' pc, clientTs = strEncode $ sessionTs pc, cmd, res} + statsKey = AgentStatsKey {userId, host = strEncode $ clientTransportHost pc, clientTs = strEncode $ clientSessionTs pc, cmd, res} diff --git a/src/Simplex/Messaging/Agent/Env/SQLite.hs b/src/Simplex/Messaging/Agent/Env/SQLite.hs index 0bba24180..5deb6ed67 100644 --- a/src/Simplex/Messaging/Agent/Env/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Env/SQLite.hs @@ -12,6 +12,7 @@ module Simplex.Messaging.Agent.Env.SQLite ( AgentMonad, + AgentMonad', AgentConfig (..), AgentDatabase (..), databaseFile, @@ -24,6 +25,7 @@ module Simplex.Messaging.Agent.Env.SQLite createAgentStore, NtfSupervisor (..), NtfSupervisorCommand (..), + XFTPAgent (..), ) where @@ -33,13 +35,16 @@ import Control.Monad.Reader import Crypto.Random import Data.List.NonEmpty (NonEmpty) import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Set as S import Data.Time.Clock (NominalDiffTime, nominalDay) import Data.Word (Word16) import Network.Socket import Numeric.Natural +import Simplex.FileTransfer.Client (XFTPClientConfig (..), defaultXFTPClientConfig) +import Simplex.FileTransfer.Types (DBSndFileId) import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval -import Simplex.Messaging.Agent.Store (UserId) import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations import Simplex.Messaging.Client @@ -47,7 +52,7 @@ import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (supportedE2EEncryptVRange) import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Protocol (NtfServer, supportedSMPClientVRange) +import Simplex.Messaging.Protocol (NtfServer, XFTPServer, XFTPServerWithAuth, supportedSMPClientVRange) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Transport (TLS, Transport (..)) @@ -57,12 +62,14 @@ import System.Random (StdGen, newStdGen) import UnliftIO (Async) import UnliftIO.STM --- | Agent monad with MonadReader Env and MonadError AgentErrorType -type AgentMonad m = (MonadUnliftIO m, MonadReader Env m, MonadError AgentErrorType m) +type AgentMonad' m = (MonadUnliftIO m, MonadReader Env m) + +type AgentMonad m = (AgentMonad' m, MonadError AgentErrorType m) data InitialAgentServers = InitialAgentServers { smp :: Map UserId (NonEmpty SMPServerWithAuth), ntf :: [NtfServer], + xftp :: Map UserId (NonEmpty XFTPServerWithAuth), netCfg :: NetworkConfig } @@ -84,6 +91,7 @@ data AgentConfig = AgentConfig yesToMigrations :: Bool, smpCfg :: ProtocolClientConfig, ntfCfg :: ProtocolClientConfig, + xftpCfg :: XFTPClientConfig, reconnectInterval :: RetryInterval, messageRetryInterval :: RetryInterval2, messageTimeout :: NominalDiffTime, @@ -144,6 +152,7 @@ defaultAgentConfig = yesToMigrations = False, smpCfg = defaultClientConfig {defaultTransport = (show defaultSMPPort, transport @TLS)}, ntfCfg = defaultClientConfig {defaultTransport = ("443", transport @TLS)}, + xftpCfg = defaultXFTPClientConfig, reconnectInterval = defaultReconnectInterval, messageRetryInterval = defaultMessageRetryInterval, messageTimeout = 2 * nominalDay, @@ -173,7 +182,8 @@ data Env = Env idsDrg :: TVar ChaChaDRG, clientCounter :: TVar Int, randomServer :: TVar StdGen, - ntfSupervisor :: NtfSupervisor + ntfSupervisor :: NtfSupervisor, + xftpAgent :: XFTPAgent } newSMPAgentEnv :: (MonadUnliftIO m, MonadRandom m) => AgentConfig -> m Env @@ -185,7 +195,8 @@ newSMPAgentEnv config@AgentConfig {database, yesToMigrations, initialClientId} = clientCounter <- newTVarIO initialClientId randomServer <- newTVarIO =<< liftIO newStdGen ntfSupervisor <- atomically . newNtfSubSupervisor $ tbqSize config - return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor} + xftpAgent <- atomically newXFTPAgent + return Env {config, store, idsDrg, clientCounter, randomServer, ntfSupervisor, xftpAgent} createAgentStore :: FilePath -> String -> Bool -> IO SQLiteStore createAgentStore dbFilePath dbKey = createSQLiteStore dbFilePath dbKey Migrations.app @@ -207,3 +218,20 @@ newNtfSubSupervisor qSize = do ntfWorkers <- TM.empty ntfSMPWorkers <- TM.empty pure NtfSupervisor {ntfTkn, ntfSubQ, ntfWorkers, ntfSMPWorkers} + +data XFTPAgent = XFTPAgent + { xftpWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()), + -- separate send workers for unhindered concurrency between download and upload, + -- clients can also be separate by passing direction to withXFTPClient, and differentiating by it + xftpSndWorkers :: TMap (Maybe XFTPServer) (TMVar (), Async ()), + -- files currently in upload - to throttle upload of other files' chunks, + -- this optimization can be dropped for the MVP + xftpSndFiles :: TVar (Set DBSndFileId) + } + +newXFTPAgent :: STM XFTPAgent +newXFTPAgent = do + xftpWorkers <- TM.empty + xftpSndWorkers <- TM.empty + xftpSndFiles <- newTVar S.empty + pure XFTPAgent {xftpWorkers, xftpSndWorkers, xftpSndFiles} diff --git a/src/Simplex/Messaging/Agent/Lock.hs b/src/Simplex/Messaging/Agent/Lock.hs index 06b8a9efd..e0dd22713 100644 --- a/src/Simplex/Messaging/Agent/Lock.hs +++ b/src/Simplex/Messaging/Agent/Lock.hs @@ -14,7 +14,7 @@ createLock :: STM Lock createLock = newEmptyTMVar {-# INLINE createLock #-} -withLock :: MonadUnliftIO m => TMVar String -> String -> m a -> m a +withLock :: MonadUnliftIO m => Lock -> String -> m a -> m a withLock lock name = E.bracket_ (atomically $ putTMVar lock name) diff --git a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs index 1a96fff16..ebd4a9937 100644 --- a/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs +++ b/src/Simplex/Messaging/Agent/NtfSubSupervisor.hs @@ -31,8 +31,7 @@ import Data.Text (Text) import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) import Simplex.Messaging.Agent.Client import Simplex.Messaging.Agent.Env.SQLite -import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..)) -import qualified Simplex.Messaging.Agent.Protocol as AP +import Simplex.Messaging.Agent.Protocol (ACommand (..), APartyCmd (..), AgentErrorType (..), BrokerErrorType (..), ConnId, NotificationsMode (..), SAEntity (..)) import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite @@ -40,7 +39,7 @@ import Simplex.Messaging.Client.Agent () import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol (NtfSubStatus (..), NtfTknStatus (..), SMPQueueNtf (..)) import Simplex.Messaging.Notifications.Types -import Simplex.Messaging.Protocol +import Simplex.Messaging.Protocol (NtfServer, ProtocolServer, SMPServer, sameSrvAddr) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (tshow, unlessM) @@ -50,7 +49,7 @@ import UnliftIO.Concurrent (forkIO, threadDelay) import qualified UnliftIO.Exception as E import UnliftIO.STM -runNtfSupervisor :: forall m. (MonadUnliftIO m, MonadReader Env m) => AgentClient -> m () +runNtfSupervisor :: forall m. AgentMonad' m => AgentClient -> m () runNtfSupervisor c = do ns <- asks ntfSupervisor forever $ do @@ -156,7 +155,7 @@ processNtfSub c (connId, cmd) = do Just (doWork, _) -> void . atomically $ tryPutTMVar doWork () -withNtfServer :: AgentMonad m => AgentClient -> (NtfServer -> m ()) -> m () +withNtfServer :: AgentMonad' m => AgentClient -> (NtfServer -> m ()) -> m () withNtfServer c action = getNtfServer c >>= mapM_ action runNtfWorker :: forall m. AgentMonad m => AgentClient -> NtfServer -> TMVar () -> m () @@ -290,7 +289,7 @@ runNtfSMPWorker c srv doWork = do mapM_ (disableQueueNotifications c) rq_ withStore' c $ \db -> deleteNtfSubscription db connId -rescheduleAction :: AgentMonad m => TMVar () -> UTCTime -> UTCTime -> m Bool +rescheduleAction :: AgentMonad' m => TMVar () -> UTCTime -> UTCTime -> m Bool rescheduleAction doWork ts actionTs | actionTs <= ts = pure False | otherwise = do @@ -306,7 +305,7 @@ fromPico (MkFixed i) = i diffInMicros :: UTCTime -> UTCTime -> Int diffInMicros a b = (`div` 1000000) . fromInteger . fromPico . nominalDiffTimeToSeconds $ diffUTCTime a b -retryOnError :: AgentMonad m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m () +retryOnError :: AgentMonad' m => AgentClient -> Text -> m () -> (AgentErrorType -> m ()) -> AgentErrorType -> m () retryOnError c name loop done e = do logError $ name <> " error: " <> tshow e case e of @@ -325,10 +324,11 @@ workerInternalError c connId internalErrStr = do withStore' c $ \db -> setNullNtfSubscriptionAction db connId notifyInternalError c connId internalErrStr -notifyInternalError :: (MonadUnliftIO m) => AgentClient -> ConnId -> String -> m () -notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, AP.ERR $ AP.INTERNAL internalErrStr) +-- TODO change error +notifyInternalError :: MonadUnliftIO m => AgentClient -> ConnId -> String -> m () +notifyInternalError AgentClient {subQ} connId internalErrStr = atomically $ writeTBQueue subQ ("", connId, APC SAEConn $ ERR $ INTERNAL internalErrStr) -getNtfToken :: AgentMonad m => m (Maybe NtfToken) +getNtfToken :: AgentMonad' m => m (Maybe NtfToken) getNtfToken = do tkn <- asks $ ntfTkn . ntfSupervisor readTVarIO tkn @@ -359,7 +359,7 @@ cancelNtfWorkers_ wsVar = do ws <- atomically $ stateTVar wsVar (,M.empty) mapM_ (uninterruptibleCancel . snd) ws -getNtfServer :: AgentMonad m => AgentClient -> m (Maybe NtfServer) +getNtfServer :: AgentMonad' m => AgentClient -> m (Maybe NtfServer) getNtfServer c = do ntfServers <- readTVarIO $ ntfServers c case ntfServers of diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index c08f86fd7..7d7d1180b 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -40,13 +40,19 @@ module Simplex.Messaging.Agent.Protocol -- * SMP agent protocol types ConnInfo, ACommand (..), + APartyCmd (..), ACommandTag (..), aCommandTag, + aPartyCmdTag, ACmd (..), + APartyCmdTag (..), ACmdTag (..), AParty (..), + AEntity (..), SAParty (..), + SAEntity (..), APartyI (..), + AEntityI (..), MsgHash, MsgMeta (..), ConnectionStats (..), @@ -91,11 +97,14 @@ module Simplex.Messaging.Agent.Protocol ATransmissionOrError, ARawTransmission, ConnId, + RcvFileId, + SndFileId, ConfirmationId, InvitationId, MsgIntegrity (..), MsgErrorType (..), QueueStatus (..), + UserId, ACorrId, AgentMsgId, NotificationsMode (..), @@ -125,6 +134,8 @@ module Simplex.Messaging.Agent.Protocol where import Control.Applicative (optional, (<|>)) +import Control.Monad (unless) +import Control.Monad.Except (runExceptT, throwError) import Control.Monad.IO.Class import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J @@ -153,6 +164,8 @@ import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField import GHC.Generics (Generic) import Generic.Random (genericArbitraryU) +import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (FileParty (..), XFTPErrorType) import Simplex.Messaging.Agent.QueryString import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Ratchet (E2ERatchetParams, E2ERatchetParamsUri) @@ -161,6 +174,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers import Simplex.Messaging.Protocol ( AProtocolType, + EntityId, ErrorType, MsgBody, MsgFlags, @@ -207,10 +221,12 @@ e2eEncUserMsgLength = 15856 type ARawTransmission = (ByteString, ByteString, ByteString) -- | Parsed SMP agent protocol transmission. -type ATransmission p = (ACorrId, ConnId, ACommand p) +type ATransmission p = (ACorrId, EntityId, APartyCmd p) -- | SMP agent protocol transmission or transmission error. -type ATransmissionOrError p = (ACorrId, ConnId, Either AgentErrorType (ACommand p)) +type ATransmissionOrError p = (ACorrId, EntityId, Either AgentErrorType (APartyCmd p)) + +type UserId = Int64 type ACorrId = ByteString @@ -238,96 +254,159 @@ instance APartyI Agent where sAParty = SAgent instance APartyI Client where sAParty = SClient -data ACmd = forall p. APartyI p => ACmd (SAParty p) (ACommand p) +data AEntity = AEConn | AERcvFile | AESndFile | AENone + deriving (Eq, Show) + +data SAEntity :: AEntity -> Type where + SAEConn :: SAEntity AEConn + SAERcvFile :: SAEntity AERcvFile + SAESndFile :: SAEntity AESndFile + SAENone :: SAEntity AENone + +deriving instance Show (SAEntity e) + +deriving instance Eq (SAEntity e) + +instance TestEquality SAEntity where + testEquality SAEConn SAEConn = Just Refl + testEquality SAERcvFile SAERcvFile = Just Refl + testEquality SAESndFile SAESndFile = Just Refl + testEquality SAENone SAENone = Just Refl + testEquality _ _ = Nothing + +class AEntityI (e :: AEntity) where sAEntity :: SAEntity e + +instance AEntityI AEConn where sAEntity = SAEConn + +instance AEntityI AERcvFile where sAEntity = SAERcvFile + +instance AEntityI AESndFile where sAEntity = SAESndFile + +instance AEntityI AENone where sAEntity = SAENone + +data ACmd = forall p e. (APartyI p, AEntityI e) => ACmd (SAParty p) (SAEntity e) (ACommand p e) deriving instance Show ACmd +data APartyCmd p = forall e. AEntityI e => APC (SAEntity e) (ACommand p e) + +instance Eq (APartyCmd p) where + APC e cmd == APC e' cmd' = case testEquality e e' of + Just Refl -> cmd == cmd' + Nothing -> False + +deriving instance Show (APartyCmd p) + type ConnInfo = ByteString -- | Parameterized type for SMP agent protocol commands and responses from all participants. -data ACommand (p :: AParty) where - NEW :: Bool -> AConnectionMode -> ACommand Client -- response INV - INV :: AConnectionRequestUri -> ACommand Agent - JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client -- response OK - CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake - LET :: ConfirmationId -> ConnInfo -> ACommand Client -- ConnInfo is from client - REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent -- ConnInfo is from sender - ACPT :: InvitationId -> ConnInfo -> ACommand Client -- ConnInfo is from client - RJCT :: InvitationId -> ACommand Client - INFO :: ConnInfo -> ACommand Agent - CON :: ACommand Agent -- notification that connection is established - SUB :: ACommand Client - END :: ACommand Agent - CONNECT :: AProtocolType -> TransportHost -> ACommand Agent - DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent - DOWN :: SMPServer -> [ConnId] -> ACommand Agent - UP :: SMPServer -> [ConnId] -> ACommand Agent - SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent - SEND :: MsgFlags -> MsgBody -> ACommand Client - MID :: AgentMsgId -> ACommand Agent - SENT :: AgentMsgId -> ACommand Agent - MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent - MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent - ACK :: AgentMsgId -> ACommand Client - SWCH :: ACommand Client - OFF :: ACommand Client - DEL :: ACommand Client - DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent - DEL_CONN :: ACommand Agent - DEL_USER :: Int64 -> ACommand Agent - CHK :: ACommand Client - STAT :: ConnectionStats -> ACommand Agent - OK :: ACommand Agent - ERR :: AgentErrorType -> ACommand Agent - SUSPENDED :: ACommand Agent +data ACommand (p :: AParty) (e :: AEntity) where + NEW :: Bool -> AConnectionMode -> ACommand Client AEConn -- response INV + INV :: AConnectionRequestUri -> ACommand Agent AEConn + JOIN :: Bool -> AConnectionRequestUri -> ConnInfo -> ACommand Client AEConn -- response OK + CONF :: ConfirmationId -> [SMPServer] -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender, [SMPServer] will be empty only in v1 handshake + LET :: ConfirmationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client + REQ :: InvitationId -> L.NonEmpty SMPServer -> ConnInfo -> ACommand Agent AEConn -- ConnInfo is from sender + ACPT :: InvitationId -> ConnInfo -> ACommand Client AEConn -- ConnInfo is from client + RJCT :: InvitationId -> ACommand Client AEConn + INFO :: ConnInfo -> ACommand Agent AEConn + CON :: ACommand Agent AEConn -- notification that connection is established + SUB :: ACommand Client AEConn + END :: ACommand Agent AEConn + CONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone + DISCONNECT :: AProtocolType -> TransportHost -> ACommand Agent AENone + DOWN :: SMPServer -> [ConnId] -> ACommand Agent AENone + UP :: SMPServer -> [ConnId] -> ACommand Agent AENone + SWITCH :: QueueDirection -> SwitchPhase -> ConnectionStats -> ACommand Agent AEConn + SEND :: MsgFlags -> MsgBody -> ACommand Client AEConn + MID :: AgentMsgId -> ACommand Agent AEConn + SENT :: AgentMsgId -> ACommand Agent AEConn + MERR :: AgentMsgId -> AgentErrorType -> ACommand Agent AEConn + MSG :: MsgMeta -> MsgFlags -> MsgBody -> ACommand Agent AEConn + ACK :: AgentMsgId -> ACommand Client AEConn + SWCH :: ACommand Client AEConn + OFF :: ACommand Client AEConn + DEL :: ACommand Client AEConn + DEL_RCVQ :: SMPServer -> SMP.RecipientId -> Maybe AgentErrorType -> ACommand Agent AEConn + DEL_CONN :: ACommand Agent AEConn + DEL_USER :: Int64 -> ACommand Agent AENone + CHK :: ACommand Client AEConn + STAT :: ConnectionStats -> ACommand Agent AEConn + OK :: ACommand Agent AEConn + ERR :: AgentErrorType -> ACommand Agent AEConn + SUSPENDED :: ACommand Agent AENone + -- XFTP commands and responses + RFPROG :: Int -> Int -> ACommand Agent AERcvFile + RFDONE :: FilePath -> ACommand Agent AERcvFile + RFERR :: AgentErrorType -> ACommand Agent AERcvFile + SFPROG :: Int -> Int -> ACommand Agent AESndFile + SFDONE :: ValidFileDescription 'FSender -> [ValidFileDescription 'FRecipient] -> ACommand Agent AESndFile -deriving instance Eq (ACommand p) +deriving instance Eq (ACommand p e) -deriving instance Show (ACommand p) +deriving instance Show (ACommand p e) -data ACmdTag = forall p. APartyI p => ACmdTag (SAParty p) (ACommandTag p) +data ACmdTag = forall p e. (APartyI p, AEntityI e) => ACmdTag (SAParty p) (SAEntity e) (ACommandTag p e) -data ACommandTag (p :: AParty) where - NEW_ :: ACommandTag Client - INV_ :: ACommandTag Agent - JOIN_ :: ACommandTag Client - CONF_ :: ACommandTag Agent - LET_ :: ACommandTag Client - REQ_ :: ACommandTag Agent - ACPT_ :: ACommandTag Client - RJCT_ :: ACommandTag Client - INFO_ :: ACommandTag Agent - CON_ :: ACommandTag Agent - SUB_ :: ACommandTag Client - END_ :: ACommandTag Agent - CONNECT_ :: ACommandTag Agent - DISCONNECT_ :: ACommandTag Agent - DOWN_ :: ACommandTag Agent - UP_ :: ACommandTag Agent - SWITCH_ :: ACommandTag Agent - SEND_ :: ACommandTag Client - MID_ :: ACommandTag Agent - SENT_ :: ACommandTag Agent - MERR_ :: ACommandTag Agent - MSG_ :: ACommandTag Agent - ACK_ :: ACommandTag Client - SWCH_ :: ACommandTag Client - OFF_ :: ACommandTag Client - DEL_ :: ACommandTag Client - DEL_RCVQ_ :: ACommandTag Agent - DEL_CONN_ :: ACommandTag Agent - DEL_USER_ :: ACommandTag Agent - CHK_ :: ACommandTag Client - STAT_ :: ACommandTag Agent - OK_ :: ACommandTag Agent - ERR_ :: ACommandTag Agent - SUSPENDED_ :: ACommandTag Agent +data APartyCmdTag p = forall e. AEntityI e => APCT (SAEntity e) (ACommandTag p e) -deriving instance Eq (ACommandTag p) +instance Eq (APartyCmdTag p) where + APCT e cmd == APCT e' cmd' = case testEquality e e' of + Just Refl -> cmd == cmd' + Nothing -> False -deriving instance Show (ACommandTag p) +deriving instance Show (APartyCmdTag p) -aCommandTag :: ACommand p -> ACommandTag p +data ACommandTag (p :: AParty) (e :: AEntity) where + NEW_ :: ACommandTag Client AEConn + INV_ :: ACommandTag Agent AEConn + JOIN_ :: ACommandTag Client AEConn + CONF_ :: ACommandTag Agent AEConn + LET_ :: ACommandTag Client AEConn + REQ_ :: ACommandTag Agent AEConn + ACPT_ :: ACommandTag Client AEConn + RJCT_ :: ACommandTag Client AEConn + INFO_ :: ACommandTag Agent AEConn + CON_ :: ACommandTag Agent AEConn + SUB_ :: ACommandTag Client AEConn + END_ :: ACommandTag Agent AEConn + CONNECT_ :: ACommandTag Agent AENone + DISCONNECT_ :: ACommandTag Agent AENone + DOWN_ :: ACommandTag Agent AENone + UP_ :: ACommandTag Agent AENone + SWITCH_ :: ACommandTag Agent AEConn + SEND_ :: ACommandTag Client AEConn + MID_ :: ACommandTag Agent AEConn + SENT_ :: ACommandTag Agent AEConn + MERR_ :: ACommandTag Agent AEConn + MSG_ :: ACommandTag Agent AEConn + ACK_ :: ACommandTag Client AEConn + SWCH_ :: ACommandTag Client AEConn + OFF_ :: ACommandTag Client AEConn + DEL_ :: ACommandTag Client AEConn + DEL_RCVQ_ :: ACommandTag Agent AEConn + DEL_CONN_ :: ACommandTag Agent AEConn + DEL_USER_ :: ACommandTag Agent AENone + CHK_ :: ACommandTag Client AEConn + STAT_ :: ACommandTag Agent AEConn + OK_ :: ACommandTag Agent AEConn + ERR_ :: ACommandTag Agent AEConn + SUSPENDED_ :: ACommandTag Agent AENone + -- XFTP commands and responses + RFDONE_ :: ACommandTag Agent AERcvFile + RFPROG_ :: ACommandTag Agent AERcvFile + RFERR_ :: ACommandTag Agent AERcvFile + SFPROG_ :: ACommandTag Agent AESndFile + SFDONE_ :: ACommandTag Agent AESndFile + +deriving instance Eq (ACommandTag p e) + +deriving instance Show (ACommandTag p e) + +aPartyCmdTag :: APartyCmd p -> APartyCmdTag p +aPartyCmdTag (APC e cmd) = APCT e $ aCommandTag cmd + +aCommandTag :: ACommand p e -> ACommandTag p e aCommandTag = \case NEW {} -> NEW_ INV _ -> INV_ @@ -363,6 +442,11 @@ aCommandTag = \case OK -> OK_ ERR _ -> ERR_ SUSPENDED -> SUSPENDED_ + RFPROG {} -> RFPROG_ + RFDONE {} -> RFDONE_ + RFERR {} -> RFERR_ + SFPROG {} -> SFPROG_ + SFDONE {} -> SFDONE_ data QueueDirection = QDRcv | QDSnd deriving (Eq, Show) @@ -811,6 +895,10 @@ connModeT = \case -- | SMP agent connection ID. type ConnId = ByteString +type RcvFileId = ByteString + +type SndFileId = ByteString + type ConfirmationId = ByteString type InvitationId = ByteString @@ -1070,6 +1158,8 @@ data AgentErrorType SMP {smpErr :: ErrorType} | -- | NTF protocol errors forwarded to agent clients NTF {ntfErr :: ErrorType} + | -- | XFTP protocol errors forwarded to agent clients + XFTP {xftpErr :: XFTPErrorType} | -- | SMP server errors BROKER {brokerAddress :: String, brokerErr :: BrokerErrorType} | -- | errors of other agents @@ -1164,6 +1254,7 @@ instance StrEncoding AgentErrorType where <|> "CONN " *> (CONN <$> parseRead1) <|> "SMP " *> (SMP <$> strP) <|> "NTF " *> (NTF <$> strP) + <|> "XFTP " *> (XFTP <$> strP) <|> "BROKER " *> (BROKER <$> textP <* " RESPONSE " <*> (RESPONSE <$> textP)) <|> "BROKER " *> (BROKER <$> textP <* " TRANSPORT " <*> (TRANSPORT <$> transportErrorP)) <|> "BROKER " *> (BROKER <$> textP <* A.space <*> parseRead1) @@ -1177,6 +1268,7 @@ instance StrEncoding AgentErrorType where CONN e -> "CONN " <> bshow e SMP e -> "SMP " <> strEncode e NTF e -> "NTF " <> strEncode e + XFTP e -> "XFTP " <> strEncode e BROKER srv (RESPONSE e) -> "BROKER " <> text srv <> " RESPONSE " <> text e BROKER srv (TRANSPORT e) -> "BROKER " <> text srv <> " TRANSPORT " <> serializeTransportError e BROKER srv e -> "BROKER " <> text srv <> " " <> bshow e @@ -1205,46 +1297,60 @@ dbCommandP :: Parser ACmd dbCommandP = commandP $ A.take =<< (A.decimal <* "\n") instance StrEncoding ACmdTag where - strEncode (ACmdTag _ cmd) = strEncode cmd + strEncode (ACmdTag _ _ cmd) = strEncode cmd strP = A.takeTill (== ' ') >>= \case - "NEW" -> pure $ ACmdTag SClient NEW_ - "INV" -> pure $ ACmdTag SAgent INV_ - "JOIN" -> pure $ ACmdTag SClient JOIN_ - "CONF" -> pure $ ACmdTag SAgent CONF_ - "LET" -> pure $ ACmdTag SClient LET_ - "REQ" -> pure $ ACmdTag SAgent REQ_ - "ACPT" -> pure $ ACmdTag SClient ACPT_ - "RJCT" -> pure $ ACmdTag SClient RJCT_ - "INFO" -> pure $ ACmdTag SAgent INFO_ - "CON" -> pure $ ACmdTag SAgent CON_ - "SUB" -> pure $ ACmdTag SClient SUB_ - "END" -> pure $ ACmdTag SAgent END_ - "CONNECT" -> pure $ ACmdTag SAgent CONNECT_ - "DISCONNECT" -> pure $ ACmdTag SAgent DISCONNECT_ - "DOWN" -> pure $ ACmdTag SAgent DOWN_ - "UP" -> pure $ ACmdTag SAgent UP_ - "SWITCH" -> pure $ ACmdTag SAgent SWITCH_ - "SEND" -> pure $ ACmdTag SClient SEND_ - "MID" -> pure $ ACmdTag SAgent MID_ - "SENT" -> pure $ ACmdTag SAgent SENT_ - "MERR" -> pure $ ACmdTag SAgent MERR_ - "MSG" -> pure $ ACmdTag SAgent MSG_ - "ACK" -> pure $ ACmdTag SClient ACK_ - "SWCH" -> pure $ ACmdTag SClient SWCH_ - "OFF" -> pure $ ACmdTag SClient OFF_ - "DEL" -> pure $ ACmdTag SClient DEL_ - "DEL_RCVQ" -> pure $ ACmdTag SAgent DEL_RCVQ_ - "DEL_CONN" -> pure $ ACmdTag SAgent DEL_CONN_ - "DEL_USER" -> pure $ ACmdTag SAgent DEL_USER_ - "CHK" -> pure $ ACmdTag SClient CHK_ - "STAT" -> pure $ ACmdTag SAgent STAT_ - "OK" -> pure $ ACmdTag SAgent OK_ - "ERR" -> pure $ ACmdTag SAgent ERR_ - "SUSPENDED" -> pure $ ACmdTag SAgent SUSPENDED_ + "NEW" -> t NEW_ + "INV" -> ct INV_ + "JOIN" -> t JOIN_ + "CONF" -> ct CONF_ + "LET" -> t LET_ + "REQ" -> ct REQ_ + "ACPT" -> t ACPT_ + "RJCT" -> t RJCT_ + "INFO" -> ct INFO_ + "CON" -> ct CON_ + "SUB" -> t SUB_ + "END" -> ct END_ + "CONNECT" -> nt CONNECT_ + "DISCONNECT" -> nt DISCONNECT_ + "DOWN" -> nt DOWN_ + "UP" -> nt UP_ + "SWITCH" -> ct SWITCH_ + "SEND" -> t SEND_ + "MID" -> ct MID_ + "SENT" -> ct SENT_ + "MERR" -> ct MERR_ + "MSG" -> ct MSG_ + "ACK" -> t ACK_ + "SWCH" -> t SWCH_ + "OFF" -> t OFF_ + "DEL" -> t DEL_ + "DEL_RCVQ" -> ct DEL_RCVQ_ + "DEL_CONN" -> ct DEL_CONN_ + "DEL_USER" -> nt DEL_USER_ + "CHK" -> t CHK_ + "STAT" -> ct STAT_ + "OK" -> ct OK_ + "ERR" -> ct ERR_ + "SUSPENDED" -> nt SUSPENDED_ + "RFPROG" -> at SAERcvFile RFPROG_ + "RFDONE" -> at SAERcvFile RFDONE_ + "RFERR" -> at SAERcvFile RFERR_ + "SFPROG" -> at SAESndFile SFPROG_ + "SFDONE" -> at SAESndFile SFDONE_ _ -> fail "bad ACmdTag" + where + t = pure . ACmdTag SClient SAEConn + at e = pure . ACmdTag SAgent e + ct = at SAEConn + nt = at SAENone -instance APartyI p => StrEncoding (ACommandTag p) where +instance APartyI p => StrEncoding (APartyCmdTag p) where + strEncode (APCT _ cmd) = strEncode cmd + strP = (\(ACmdTag _ e t) -> checkParty $ APCT e t) <$?> strP + +instance (APartyI p, AEntityI e) => StrEncoding (ACommandTag p e) where strEncode = \case NEW_ -> "NEW" INV_ -> "INV" @@ -1280,20 +1386,30 @@ instance APartyI p => StrEncoding (ACommandTag p) where OK_ -> "OK" ERR_ -> "ERR" SUSPENDED_ -> "SUSPENDED" - strP = (\(ACmdTag _ t) -> checkParty t) <$?> strP + RFPROG_ -> "RFPROG" + RFDONE_ -> "RFDONE" + RFERR_ -> "RFERR" + SFPROG_ -> "SFPROG" + SFDONE_ -> "SFDONE" + strP = (\(APCT _ t) -> checkEntity t) <$?> strP checkParty :: forall t p p'. (APartyI p, APartyI p') => t p' -> Either String (t p) checkParty x = case testEquality (sAParty @p) (sAParty @p') of Just Refl -> Right x Nothing -> Left "bad party" +checkEntity :: forall t e e'. (AEntityI e, AEntityI e') => t e' -> Either String (t e) +checkEntity x = case testEquality (sAEntity @e) (sAEntity @e') of + Just Refl -> Right x + Nothing -> Left "bad entity" + -- | SMP agent command and response parser commandP :: Parser ByteString -> Parser ACmd commandP binaryP = strP >>= \case - ACmdTag SClient cmd -> - ACmd SClient <$> case cmd of + ACmdTag SClient e cmd -> + ACmd SClient e <$> case cmd of NEW_ -> s (NEW <$> strP_ <*> strP) JOIN_ -> s (JOIN <$> strP_ <*> strP_ <*> binaryP) LET_ -> s (LET <$> A.takeTill (== ' ') <* A.space <*> binaryP) @@ -1306,8 +1422,8 @@ commandP binaryP = OFF_ -> pure OFF DEL_ -> pure DEL CHK_ -> pure CHK - ACmdTag SAgent cmd -> - ACmd SAgent <$> case cmd of + ACmdTag SAgent e cmd -> + ACmd SAgent e <$> case cmd of INV_ -> s (INV <$> strP) CONF_ -> s (CONF <$> A.takeTill (== ' ') <* A.space <*> strListP <* A.space <*> binaryP) REQ_ -> s (REQ <$> A.takeTill (== ' ') <* A.space <*> strP_ <*> binaryP) @@ -1330,11 +1446,22 @@ commandP binaryP = OK_ -> pure OK ERR_ -> s (ERR <$> strP) SUSPENDED_ -> pure SUSPENDED + RFPROG_ -> s (RFPROG <$> A.decimal <* A.space <*> A.decimal) + RFDONE_ -> s (RFDONE <$> strP) + RFERR_ -> s (RFERR <$> strP) + SFPROG_ -> s (SFPROG <$> A.decimal <* A.space <*> A.decimal) + SFDONE_ -> s (sfDone . safeDecodeUtf8 <$?> binaryP) where s :: Parser a -> Parser a s p = A.space *> p connections :: Parser [ConnId] connections = strP `A.sepBy'` A.char ',' + sfDone :: Text -> Either String (ACommand 'Agent 'AESndFile) + sfDone t = + let ds = T.splitOn fdSeparator t + in case ds of + [] -> Left "no sender file description" + sd : rds -> SFDONE <$> strDecode (encodeUtf8 sd) <*> mapM (strDecode . encodeUtf8) rds msgMetaP = do integrity <- strP recipient <- " R=" *> partyMeta A.decimal @@ -1347,7 +1474,7 @@ parseCommand :: ByteString -> Either AgentErrorType ACmd parseCommand = parse (commandP A.takeByteString) $ CMD SYNTAX -- | Serialize SMP agent command. -serializeCommand :: ACommand p -> ByteString +serializeCommand :: ACommand p e -> ByteString serializeCommand = \case NEW ntfs cMode -> s (NEW_, ntfs, cMode) INV cReq -> s (INV_, cReq) @@ -1383,6 +1510,11 @@ serializeCommand = \case ERR e -> s (ERR_, e) OK -> s OK_ SUSPENDED -> s SUSPENDED_ + RFPROG rcvd total -> s (RFPROG_, rcvd, total) + RFDONE fPath -> s (RFDONE_, fPath) + RFERR e -> s (RFERR_, e) + SFPROG sent total -> s (SFPROG_, sent, total) + SFDONE sd rds -> B.unwords [s SFDONE_, serializeBinary (sfDone sd rds)] where s :: StrEncoding a => a -> ByteString s = strEncode @@ -1390,6 +1522,7 @@ serializeCommand = \case showTs = B.pack . formatISO8601Millis connections :: [ConnId] -> ByteString connections = B.intercalate "," . map strEncode + sfDone sd rds = B.intercalate fdSeparator $ strEncode sd : map strEncode rds serializeMsgMeta :: MsgMeta -> ByteString serializeMsgMeta MsgMeta {integrity, recipient = (rmId, rTs), broker = (bmId, bTs), sndMsgId} = B.unwords @@ -1415,60 +1548,65 @@ tGetRaw h = (,,) <$> getLn h <*> getLn h <*> getLn h -- | Send SMP agent protocol command (or response) to TCP connection. tPut :: (Transport c, MonadIO m) => c -> ATransmission p -> m () -tPut h (corrId, connId, command) = - liftIO $ tPutRaw h (corrId, connId, serializeCommand command) +tPut h (corrId, connId, APC _ cmd) = + liftIO $ tPutRaw h (corrId, connId, serializeCommand cmd) -- | Receive client and agent transmissions from TCP connection. tGet :: forall c m p. (Transport c, MonadIO m) => SAParty p -> c -> m (ATransmissionOrError p) tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody where tParseLoadBody :: ARawTransmission -> m (ATransmissionOrError p) - tParseLoadBody t@(corrId, connId, command) = do + tParseLoadBody t@(corrId, entId, command) = do let cmd = parseCommand command >>= fromParty >>= tConnId t fullCmd <- either (return . Left) cmdWithMsgBody cmd - return (corrId, connId, fullCmd) + return (corrId, entId, fullCmd) - fromParty :: ACmd -> Either AgentErrorType (ACommand p) - fromParty (ACmd (p :: p1) cmd) = case testEquality party p of - Just Refl -> Right cmd + fromParty :: ACmd -> Either AgentErrorType (APartyCmd p) + fromParty (ACmd (p :: p1) e cmd) = case testEquality party p of + Just Refl -> Right $ APC e cmd _ -> Left $ CMD PROHIBITED - tConnId :: ARawTransmission -> ACommand p -> Either AgentErrorType (ACommand p) - tConnId (_, connId, _) cmd = case cmd of - -- NEW, JOIN and ACPT have optional connId - NEW {} -> Right cmd - JOIN {} -> Right cmd - ACPT {} -> Right cmd - -- ERROR response does not always have connId - ERR _ -> Right cmd - CONNECT {} -> Right cmd - DISCONNECT {} -> Right cmd - DOWN {} -> Right cmd - UP {} -> Right cmd - -- other responses must have connId - _ - | B.null connId -> Left $ CMD NO_CONN - | otherwise -> Right cmd + tConnId :: ARawTransmission -> APartyCmd p -> Either AgentErrorType (APartyCmd p) + tConnId (_, entId, _) (APC e cmd) = + APC e <$> case cmd of + -- NEW, JOIN and ACPT have optional connection ID + NEW {} -> Right cmd + JOIN {} -> Right cmd + ACPT {} -> Right cmd + -- ERROR response does not always have connection ID + ERR _ -> Right cmd + CONNECT {} -> Right cmd + DISCONNECT {} -> Right cmd + DOWN {} -> Right cmd + UP {} -> Right cmd + SUSPENDED {} -> Right cmd + -- other responses must have connection ID + _ + | B.null entId -> Left $ CMD NO_CONN + | otherwise -> Right cmd - cmdWithMsgBody :: ACommand p -> m (Either AgentErrorType (ACommand p)) - cmdWithMsgBody = \case - SEND msgFlags body -> SEND msgFlags <$$> getBody body - MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body - JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo - CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo - LET confId cInfo -> LET confId <$$> getBody cInfo - REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo - ACPT invId cInfo -> ACPT invId <$$> getBody cInfo - INFO cInfo -> INFO <$$> getBody cInfo - cmd -> pure $ Right cmd + cmdWithMsgBody :: APartyCmd p -> m (Either AgentErrorType (APartyCmd p)) + cmdWithMsgBody (APC e cmd) = + APC e <$$> case cmd of + SEND msgFlags body -> SEND msgFlags <$$> getBody body + MSG msgMeta msgFlags body -> MSG msgMeta msgFlags <$$> getBody body + JOIN ntfs qUri cInfo -> JOIN ntfs qUri <$$> getBody cInfo + CONF confId srvs cInfo -> CONF confId srvs <$$> getBody cInfo + LET confId cInfo -> LET confId <$$> getBody cInfo + REQ invId srvs cInfo -> REQ invId srvs <$$> getBody cInfo + ACPT invId cInfo -> ACPT invId <$$> getBody cInfo + INFO cInfo -> INFO <$$> getBody cInfo + _ -> pure $ Right cmd getBody :: ByteString -> m (Either AgentErrorType ByteString) getBody binary = case B.unpack binary of ':' : body -> return . Right $ B.pack body str -> case readMaybe str :: Maybe Int of - Just size -> liftIO $ do - body <- cGet h size - s <- getLn h - return $ if B.null s then Right body else Left $ CMD SIZE + Just size -> runExceptT $ do + body <- liftIO $ cGet h size + unless (B.length body == size) $ throwError $ CMD SIZE + s <- liftIO $ getLn h + unless (B.null s) $ throwError $ CMD SIZE + pure body Nothing -> return . Left $ CMD SYNTAX diff --git a/src/Simplex/Messaging/Agent/Server.hs b/src/Simplex/Messaging/Agent/Server.hs index 45b6be121..6ef9701f8 100644 --- a/src/Simplex/Messaging/Agent/Server.hs +++ b/src/Simplex/Messaging/Agent/Server.hs @@ -60,10 +60,10 @@ connectClient h c = race_ (send h c) (receive h c) receive :: forall c m. (Transport c, MonadUnliftIO m) => c -> AgentClient -> m () receive h c@AgentClient {rcvQ, subQ} = forever $ do - (corrId, connId, cmdOrErr) <- tGet SClient h + (corrId, entId, cmdOrErr) <- tGet SClient h case cmdOrErr of - Right cmd -> write rcvQ (corrId, connId, cmd) - Left e -> write subQ (corrId, connId, ERR e) + Right cmd -> write rcvQ (corrId, entId, cmd) + Left e -> write subQ (corrId, entId, APC SAEConn $ ERR e) where write :: TBQueue (ATransmission p) -> ATransmission p -> m () write q t = do @@ -77,5 +77,5 @@ send h c@AgentClient {subQ} = forever $ do logClient c "<--" t logClient :: MonadUnliftIO m => AgentClient -> ByteString -> ATransmission a -> m () -logClient AgentClient {clientId} dir (corrId, connId, cmd) = do +logClient AgentClient {clientId} dir (corrId, connId, APC _ cmd) = do logInfo . decodeUtf8 $ B.unwords [bshow clientId, dir, "A :", corrId, connId, B.takeWhile (/= ' ') $ serializeCommand cmd] diff --git a/src/Simplex/Messaging/Agent/Store.hs b/src/Simplex/Messaging/Agent/Store.hs index adcf70224..cf139c96b 100644 --- a/src/Simplex/Messaging/Agent/Store.hs +++ b/src/Simplex/Messaging/Agent/Store.hs @@ -264,8 +264,6 @@ data PendingCommand = PendingCommand data AgentCmdType = ACClient | ACInternal -type UserId = Int64 - instance StrEncoding AgentCmdType where strEncode = \case ACClient -> "CLIENT" @@ -277,20 +275,20 @@ instance StrEncoding AgentCmdType where _ -> fail "bad AgentCmdType" data AgentCommand - = AClientCommand (ACommand 'Client) + = AClientCommand (APartyCmd 'Client) | AInternalCommand InternalCommand instance StrEncoding AgentCommand where strEncode = \case - AClientCommand cmd -> strEncode (ACClient, Str $ serializeCommand cmd) + AClientCommand (APC _ cmd) -> strEncode (ACClient, Str $ serializeCommand cmd) AInternalCommand cmd -> strEncode (ACInternal, cmd) strP = strP_ >>= \case - ACClient -> AClientCommand <$> ((\(ACmd _ cmd) -> checkParty cmd) <$?> dbCommandP) + ACClient -> AClientCommand <$> ((\(ACmd _ e cmd) -> checkParty $ APC e cmd) <$?> dbCommandP) ACInternal -> AInternalCommand <$> strP data AgentCommandTag - = AClientCommandTag (ACommandTag 'Client) + = AClientCommandTag (APartyCmdTag 'Client) | AInternalCommandTag InternalCommandTag deriving (Show) @@ -363,7 +361,7 @@ instance StrEncoding InternalCommandTag where agentCommandTag :: AgentCommand -> AgentCommandTag agentCommandTag = \case - AClientCommand cmd -> AClientCommandTag $ aCommandTag cmd + AClientCommand cmd -> AClientCommandTag $ aPartyCmdTag cmd AInternalCommand cmd -> AInternalCommandTag $ internalCmdTag cmd internalCmdTag :: InternalCommand -> InternalCommandTag @@ -535,4 +533,8 @@ data StoreError SEX3dhKeysNotFound | -- | Used to wrap agent errors inside store operations to avoid race conditions SEAgentError AgentErrorType + | -- | XFTP Server not found. + SEXFTPServerNotFound + | -- | XFTP File not found. + SEFileNotFound deriving (Eq, Show, Exception) diff --git a/src/Simplex/Messaging/Agent/Store/SQLite.hs b/src/Simplex/Messaging/Agent/Store/SQLite.hs index 85b5d3fc7..2ad2015dd 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite.hs @@ -123,6 +123,23 @@ module Simplex.Messaging.Agent.Store.SQLite getActiveNtfToken, getNtfRcvQueue, setConnectionNtfs, + -- File transfer + createRcvFile, + getRcvFile, + getRcvFileByEntityId, + updateRcvChunkReplicaDelay, + updateRcvFileChunkReceived, + updateRcvFileStatus, + updateRcvFileError, + updateRcvFileComplete, + updateRcvFileNoTmpPath, + updateRcvFileDeleted, + deleteRcvFile', + getNextRcvChunkToDownload, + getNextRcvFileToDecrypt, + getPendingRcvFilesServers, + getCleanupRcvFilesTmpPaths, + getCleanupRcvFilesDeleted, -- * utilities withConnection, @@ -155,6 +172,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Word (Word32) import Database.SQLite.Simple (FromRow, NamedParam (..), Only (..), Query (..), SQLError, ToRow, field, (:.) (..)) import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.FromField @@ -162,6 +180,9 @@ import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.ToField (ToField (..)) import qualified Database.SQLite3 as SQLite3 import Network.Socket (ServiceName) +import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.FileTransfer.Types import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.Store import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration) @@ -173,7 +194,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfSubscriptionId, NtfTknStatus (..), NtfTokenId, SMPQueueNtf (..)) import Simplex.Messaging.Notifications.Types import Simplex.Messaging.Parsers (blobFieldParser, fromTextField_) -import Simplex.Messaging.Protocol (MsgBody, MsgFlags, NtfServer, ProtocolServer (..), RcvNtfDhSecret, SndPublicVerifyKey, pattern NtfServer) +import Simplex.Messaging.Protocol import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost) import Simplex.Messaging.Util (bshow, eitherToMaybe, ($>>=), (<$$>)) @@ -1703,3 +1724,257 @@ randomId gVar n = U.encode <$> (atomically . stateTVar gVar $ randomBytesGenerat ntfSubAndSMPAction :: NtfSubAction -> (Maybe NtfSubNTFAction, Maybe NtfSubSMPAction) ntfSubAndSMPAction (NtfSubNTFAction action) = (Just action, Nothing) ntfSubAndSMPAction (NtfSubSMPAction action) = (Nothing, Just action) + +createXFTPServer_ :: DB.Connection -> XFTPServer -> IO Int64 +createXFTPServer_ db newSrv@ProtocolServer {host, port, keyHash} = + getXFTPServerId_ db newSrv >>= \case + Right srvId -> pure srvId + Left _ -> insertNewServer_ + where + insertNewServer_ = do + DB.execute db "INSERT INTO xftp_servers (xftp_host, xftp_port, xftp_key_hash) VALUES (?,?,?)" (host, port, keyHash) + insertedRowId db + +getXFTPServerId_ :: DB.Connection -> XFTPServer -> IO (Either StoreError Int64) +getXFTPServerId_ db ProtocolServer {host, port, keyHash} = do + firstRow fromOnly SEXFTPServerNotFound $ + DB.query db "SELECT xftp_server_id FROM xftp_servers WHERE xftp_host = ? AND xftp_port = ? AND xftp_key_hash = ?" (host, port, keyHash) + +createRcvFile :: DB.Connection -> TVar ChaChaDRG -> UserId -> FileDescription 'FRecipient -> FilePath -> FilePath -> FilePath -> IO (Either StoreError RcvFileId) +createRcvFile db gVar userId fd@FileDescription {chunks} prefixPath tmpPath savePath = runExceptT $ do + (rcvFileEntityId, rcvFileId) <- ExceptT $ insertRcvFile fd + liftIO $ + forM_ chunks $ \fc@FileChunk {replicas} -> do + chunkId <- insertChunk fc rcvFileId + forM_ (zip [1 ..] replicas) $ \(rno, replica) -> insertReplica rno replica chunkId + pure rcvFileEntityId + where + insertRcvFile :: FileDescription 'FRecipient -> IO (Either StoreError (RcvFileId, DBRcvFileId)) + insertRcvFile FileDescription {size, digest, key, nonce, chunkSize} = runExceptT $ do + rcvFileEntityId <- ExceptT $ + createWithRandomId gVar $ \rcvFileEntityId -> + DB.execute + db + "INSERT INTO rcv_files (rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, status) VALUES (?,?,?,?,?,?,?,?,?,?,?)" + ((rcvFileEntityId, userId, size, digest, key, nonce, chunkSize) :. (prefixPath, tmpPath, savePath, RFSReceiving)) + rcvFileId <- liftIO $ insertedRowId db + pure (rcvFileEntityId, rcvFileId) + insertChunk :: FileChunk -> DBRcvFileId -> IO Int64 + insertChunk FileChunk {chunkNo, chunkSize, digest} rcvFileId = do + DB.execute + db + "INSERT INTO rcv_file_chunks (rcv_file_id, chunk_no, chunk_size, digest) VALUES (?,?,?,?)" + (rcvFileId, chunkNo, chunkSize, digest) + insertedRowId db + insertReplica :: Int -> FileChunkReplica -> Int64 -> IO () + insertReplica replicaNo FileChunkReplica {server, replicaId, replicaKey} chunkId = do + srvId <- createXFTPServer_ db server + DB.execute + db + "INSERT INTO rcv_file_chunk_replicas (replica_number, rcv_file_chunk_id, xftp_server_id, replica_id, replica_key) VALUES (?,?,?,?,?)" + (replicaNo, chunkId, srvId, replicaId, replicaKey) + +getRcvFileByEntityId :: DB.Connection -> UserId -> RcvFileId -> IO (Either StoreError RcvFile) +getRcvFileByEntityId db userId rcvFileEntityId = runExceptT $ do + rcvFileId <- ExceptT $ getRcvFileIdByEntityId_ db userId rcvFileEntityId + ExceptT $ getRcvFile db rcvFileId + +getRcvFileIdByEntityId_ :: DB.Connection -> UserId -> RcvFileId -> IO (Either StoreError DBRcvFileId) +getRcvFileIdByEntityId_ db userId rcvFileEntityId = + firstRow fromOnly SEFileNotFound $ + DB.query db "SELECT rcv_file_id FROM rcv_files WHERE user_id = ? AND rcv_file_entity_id = ?" (userId, rcvFileEntityId) + +getRcvFile :: DB.Connection -> DBRcvFileId -> IO (Either StoreError RcvFile) +getRcvFile db rcvFileId = runExceptT $ do + fd@RcvFile {rcvFileEntityId, userId, tmpPath} <- ExceptT getFile + chunks <- maybe (pure []) (liftIO . getChunks rcvFileEntityId userId) tmpPath + pure (fd {chunks} :: RcvFile) + where + getFile :: IO (Either StoreError RcvFile) + getFile = do + firstRow toFile SEFileNotFound $ + DB.query + db + [sql| + SELECT rcv_file_entity_id, user_id, size, digest, key, nonce, chunk_size, prefix_path, tmp_path, save_path, status, deleted + FROM rcv_files + WHERE rcv_file_id = ? + |] + (Only rcvFileId) + where + toFile :: (RcvFileId, UserId, FileSize Int64, FileDigest, C.SbKey, C.CbNonce, FileSize Word32, FilePath, Maybe FilePath, FilePath, RcvFileStatus, Bool) -> RcvFile + toFile (rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath, savePath, status, deleted) = + RcvFile {rcvFileId, rcvFileEntityId, userId, size, digest, key, nonce, chunkSize, prefixPath, tmpPath, savePath, status, deleted, chunks = []} + getChunks :: RcvFileId -> UserId -> FilePath -> IO [RcvFileChunk] + getChunks rcvFileEntityId userId fileTmpPath = do + chunks <- + map toChunk + <$> DB.query + db + [sql| + SELECT rcv_file_chunk_id, chunk_no, chunk_size, digest, tmp_path + FROM rcv_file_chunks + WHERE rcv_file_id = ? + |] + (Only rcvFileId) + forM chunks $ \chunk@RcvFileChunk {rcvChunkId} -> do + replicas' <- getChunkReplicas rcvChunkId + pure (chunk {replicas = replicas'} :: RcvFileChunk) + where + toChunk :: (Int64, Int, FileSize Word32, FileDigest, Maybe FilePath) -> RcvFileChunk + toChunk (rcvChunkId, chunkNo, chunkSize, digest, chunkTmpPath) = + RcvFileChunk {rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath, replicas = []} + getChunkReplicas :: Int64 -> IO [RcvFileChunkReplica] + getChunkReplicas chunkId = do + map toReplica + <$> DB.query + db + [sql| + SELECT + r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries, + s.xftp_host, s.xftp_port, s.xftp_key_hash + FROM rcv_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + WHERE r.rcv_file_chunk_id = ? + |] + (Only chunkId) + where + toReplica :: (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int, Int, NonEmpty TransportHost, ServiceName, C.KeyHash) -> RcvFileChunkReplica + toReplica (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries, host, port, keyHash) = + let server = XFTPServer host port keyHash + in RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries} + +updateRcvChunkReplicaDelay :: DB.Connection -> Int64 -> Int -> IO () +updateRcvChunkReplicaDelay db replicaId delay = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (delay, updatedAt, replicaId) + +updateRcvFileChunkReceived :: DB.Connection -> Int64 -> Int64 -> DBRcvFileId -> FilePath -> IO (Either StoreError RcvFile) +updateRcvFileChunkReceived db rId cId fId chunkTmpPath = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_file_chunk_replicas SET received = 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?" (updatedAt, rId) + DB.execute db "UPDATE rcv_file_chunks SET tmp_path = ?, updated_at = ? WHERE rcv_file_chunk_id = ?" (chunkTmpPath, updatedAt, cId) + getRcvFile db fId + +updateRcvFileStatus :: DB.Connection -> DBRcvFileId -> RcvFileStatus -> IO () +updateRcvFileStatus db rcvFileId status = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET status = ?, updated_at = ? WHERE rcv_file_id = ?" (status, updatedAt, rcvFileId) + +updateRcvFileError :: DB.Connection -> DBRcvFileId -> String -> IO () +updateRcvFileError db rcvFileId errStr = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET tmp_path = NULL, error = ?, status = ?, updated_at = ? WHERE rcv_file_id = ?" (errStr, RFSError, updatedAt, rcvFileId) + +updateRcvFileComplete :: DB.Connection -> DBRcvFileId -> IO () +updateRcvFileComplete db rcvFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET tmp_path = NULL, status = ?, updated_at = ? WHERE rcv_file_id = ?" (RFSComplete, updatedAt, rcvFileId) + +updateRcvFileNoTmpPath :: DB.Connection -> DBRcvFileId -> IO () +updateRcvFileNoTmpPath db rcvFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET tmp_path = NULL, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId) + +updateRcvFileDeleted :: DB.Connection -> DBRcvFileId -> IO () +updateRcvFileDeleted db rcvFileId = do + updatedAt <- getCurrentTime + DB.execute db "UPDATE rcv_files SET deleted = 1, updated_at = ? WHERE rcv_file_id = ?" (updatedAt, rcvFileId) + +deleteRcvFile' :: DB.Connection -> DBRcvFileId -> IO () +deleteRcvFile' db rcvFileId = + DB.execute db "DELETE FROM rcv_files WHERE rcv_file_id = ?" (Only rcvFileId) + +getNextRcvChunkToDownload :: DB.Connection -> XFTPServer -> IO (Maybe RcvFileChunk) +getNextRcvChunkToDownload db server@ProtocolServer {host, port, keyHash} = do + maybeFirstRow toChunk $ + DB.query + db + [sql| + SELECT + f.rcv_file_id, f.rcv_file_entity_id, f.user_id, c.rcv_file_chunk_id, c.chunk_no, c.chunk_size, c.digest, f.tmp_path, c.tmp_path, + r.rcv_file_chunk_replica_id, r.replica_id, r.replica_key, r.received, r.delay, r.retries + FROM rcv_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id + JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id + WHERE s.xftp_host = ? AND s.xftp_port = ? AND s.xftp_key_hash = ? + AND r.received = 0 AND r.replica_number = 1 + AND f.status = ? AND f.deleted = 0 + ORDER BY r.created_at ASC + LIMIT 1 + |] + (host, port, keyHash, RFSReceiving) + where + toChunk :: ((DBRcvFileId, RcvFileId, UserId, Int64, Int, FileSize Word32, FileDigest, FilePath, Maybe FilePath) :. (Int64, ChunkReplicaId, C.APrivateSignKey, Bool, Maybe Int, Int)) -> RcvFileChunk + toChunk ((rcvFileId, rcvFileEntityId, userId, rcvChunkId, chunkNo, chunkSize, digest, fileTmpPath, chunkTmpPath) :. (rcvChunkReplicaId, replicaId, replicaKey, received, delay, retries)) = + RcvFileChunk + { rcvFileId, + rcvFileEntityId, + userId, + rcvChunkId, + chunkNo, + chunkSize, + digest, + fileTmpPath, + chunkTmpPath, + replicas = [RcvFileChunkReplica {rcvChunkReplicaId, server, replicaId, replicaKey, received, delay, retries}] + } + +getNextRcvFileToDecrypt :: DB.Connection -> IO (Maybe RcvFile) +getNextRcvFileToDecrypt db = do + fileId_ :: Maybe DBRcvFileId <- + maybeFirstRow fromOnly $ + DB.query + db + [sql| + SELECT rcv_file_id + FROM rcv_files + WHERE status IN (?,?) AND deleted = 0 + ORDER BY created_at ASC LIMIT 1 + |] + (RFSReceived, RFSDecrypting) + case fileId_ of + Nothing -> pure Nothing + Just fileId -> eitherToMaybe <$> getRcvFile db fileId + +getPendingRcvFilesServers :: DB.Connection -> IO [XFTPServer] +getPendingRcvFilesServers db = do + map toServer + <$> DB.query + db + [sql| + SELECT DISTINCT + s.xftp_host, s.xftp_port, s.xftp_key_hash + FROM rcv_file_chunk_replicas r + JOIN xftp_servers s ON s.xftp_server_id = r.xftp_server_id + JOIN rcv_file_chunks c ON c.rcv_file_chunk_id = r.rcv_file_chunk_id + JOIN rcv_files f ON f.rcv_file_id = c.rcv_file_id + WHERE r.received = 0 AND r.replica_number = 1 + AND f.status = ? AND f.deleted = 0 + |] + (Only RFSReceiving) + where + toServer :: (NonEmpty TransportHost, ServiceName, C.KeyHash) -> XFTPServer + toServer (host, port, keyHash) = XFTPServer host port keyHash + +getCleanupRcvFilesTmpPaths :: DB.Connection -> IO [(DBRcvFileId, FilePath)] +getCleanupRcvFilesTmpPaths db = + DB.query + db + [sql| + SELECT rcv_file_id, tmp_path + FROM rcv_files + WHERE status IN (?,?) AND tmp_path IS NOT NULL + |] + (RFSComplete, RFSError) + +getCleanupRcvFilesDeleted :: DB.Connection -> IO [(DBRcvFileId, FilePath)] +getCleanupRcvFilesDeleted db = + DB.query_ + db + [sql| + SELECT rcv_file_id, prefix_path + FROM rcv_files + WHERE deleted = 1 + |] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs index d896da044..7cdc153a4 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations.hs @@ -41,6 +41,7 @@ import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230110_users import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230117_fkey_indexes import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230120_delete_errors import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230217_server_key_hash +import Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files import Simplex.Messaging.Encoding.String import Simplex.Messaging.Transport.Client (TransportHost) @@ -61,7 +62,8 @@ schemaMigrations = ("m20230110_users", m20230110_users), ("m20230117_fkey_indexes", m20230117_fkey_indexes), ("m20230120_delete_errors", m20230120_delete_errors), - ("m20230217_server_key_hash", m20230217_server_key_hash) + ("m20230217_server_key_hash", m20230217_server_key_hash), + ("m20230223_files", m20230223_files) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs new file mode 100644 index 000000000..1bae366a7 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230223_files.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230223_files where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20230223_files :: Query +m20230223_files = + [sql| +CREATE TABLE xftp_servers ( + xftp_server_id INTEGER PRIMARY KEY, + xftp_host TEXT NOT NULL, + xftp_port TEXT NOT NULL, + xftp_key_hash BLOB NOT NULL, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')), + UNIQUE(xftp_host, xftp_port, xftp_key_hash) +); + +CREATE TABLE rcv_files ( + rcv_file_id INTEGER PRIMARY KEY, + rcv_file_entity_id BLOB NOT NULL, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + size INTEGER NOT NULL, + digest BLOB NOT NULL, + key BLOB NOT NULL, + nonce BLOB NOT NULL, + chunk_size INTEGER NOT NULL, + prefix_path TEXT NOT NULL, + tmp_path TEXT, + save_path TEXT NOT NULL, + status TEXT NOT NULL, + deleted INTEGER NOT NULL DEFAULT 0, + error TEXT, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')), + UNIQUE(rcv_file_entity_id) +); + +CREATE INDEX idx_rcv_files_user_id ON rcv_files(user_id); + +CREATE TABLE rcv_file_chunks ( + rcv_file_chunk_id INTEGER PRIMARY KEY, + rcv_file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE, + chunk_no INTEGER NOT NULL, + chunk_size INTEGER NOT NULL, + digest BLOB NOT NULL, + tmp_path TEXT, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_rcv_file_chunks_rcv_file_id ON rcv_file_chunks(rcv_file_id); + +CREATE TABLE rcv_file_chunk_replicas ( + rcv_file_chunk_replica_id INTEGER PRIMARY KEY, + rcv_file_chunk_id INTEGER NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE, + replica_number INTEGER NOT NULL, + xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + replica_id BLOB NOT NULL, + replica_key BLOB NOT NULL, + received INTEGER NOT NULL DEFAULT 0, + delay INTEGER, + retries INTEGER NOT NULL DEFAULT 0, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_rcv_file_chunk_replicas_rcv_file_chunk_id ON rcv_file_chunk_replicas(rcv_file_chunk_id); +CREATE INDEX idx_rcv_file_chunk_replicas_xftp_server_id ON rcv_file_chunk_replicas(xftp_server_id); +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230401_snd_files.hs b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230401_snd_files.hs new file mode 100644 index 000000000..df5754fb2 --- /dev/null +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/M20230401_snd_files.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Messaging.Agent.Store.SQLite.Migrations.M20230401_snd_files where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +-- this migration is a draft - it is not included in the list of migrations +m20230401_snd_files :: Query +m20230401_snd_files = + [sql| +CREATE TABLE snd_files ( + snd_file_id INTEGER PRIMARY KEY AUTOINCREMENT, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + size INTEGER NOT NULL, + digest BLOB NOT NULL, + key BLOB NOT NULL, + nonce BLOB NOT NULL, + chunk_size INTEGER NOT NULL, + path TEXT NOT NULL, + enc_path TEXT, + status TEXT NOT NULL, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_snd_files_user_id ON snd_files(user_id); + +CREATE TABLE snd_file_chunks ( + snd_file_chunk_id INTEGER PRIMARY KEY, + snd_file_id INTEGER NOT NULL REFERENCES snd_files ON DELETE CASCADE, + chunk_no INTEGER NOT NULL, + chunk_offset INTEGER NOT NULL, + chunk_size INTEGER NOT NULL, + digest BLOB NOT NULL, + delay INTEGER, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_snd_file_chunks_snd_file_id ON snd_file_chunks(snd_file_id); + +-- ? add fk to snd_file_descriptions? +-- ? probably it's not necessary since these entities are +-- ? required at different stages of sending files - +-- ? replicas on upload, description on notifying client +CREATE TABLE snd_file_chunk_replicas ( + snd_file_chunk_replica_id INTEGER PRIMARY KEY, + snd_file_chunk_id INTEGER NOT NULL REFERENCES snd_file_chunks ON DELETE CASCADE, + replica_number INTEGER NOT NULL, + xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + replica_id BLOB NOT NULL, + replica_key BLOB NOT NULL, + -- created INTEGER NOT NULL DEFAULT 0, -- as in XFTP create - registered on server + uploaded INTEGER NOT NULL DEFAULT 0, + retries INTEGER NOT NULL DEFAULT 0, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_snd_file_chunk_replicas_snd_file_chunk_id ON snd_file_chunk_replicas(snd_file_chunk_id); +CREATE INDEX idx_snd_file_chunk_replicas_xftp_server_id ON snd_file_chunk_replicas(xftp_server_id); + +CREATE TABLE snd_file_chunk_replica_recipients ( + snd_file_chunk_replica_recipient_id INTEGER PRIMARY KEY, + snd_file_chunk_replica_id INTEGER NOT NULL REFERENCES snd_file_chunk_replicas ON DELETE CASCADE, + rcv_replica_id BLOB NOT NULL, + rcv_replica_key BLOB NOT NULL, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_snd_file_chunk_replica_recipients_snd_file_chunk_replica_id ON snd_file_chunk_replica_recipients(snd_file_chunk_replica_id); + +CREATE TABLE snd_file_descriptions ( + snd_file_description_id INTEGER PRIMARY KEY, + snd_file_id INTEGER NOT NULL REFERENCES snd_files ON DELETE CASCADE, + sender INTEGER NOT NULL, -- 1 for sender file description + descr_text TEXT NOT NULL, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + updated_at TEXT NOT NULL DEFAULT (datetime('now')) +); + +CREATE INDEX idx_snd_file_descriptions_snd_file_id ON snd_file_descriptions(snd_file_id); +|] diff --git a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql index 540329a57..29de284f9 100644 --- a/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql +++ b/src/Simplex/Messaging/Agent/Store/SQLite/Migrations/agent_schema.sql @@ -283,3 +283,62 @@ CREATE INDEX idx_snd_messages_conn_id_internal_id ON snd_messages( internal_id ); CREATE INDEX idx_snd_queues_host_port ON snd_queues(host, port); +CREATE TABLE xftp_servers( + xftp_server_id INTEGER PRIMARY KEY, + xftp_host TEXT NOT NULL, + xftp_port TEXT NOT NULL, + xftp_key_hash BLOB NOT NULL, + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')), + UNIQUE(xftp_host, xftp_port, xftp_key_hash) +); +CREATE TABLE rcv_files( + rcv_file_id INTEGER PRIMARY KEY, + rcv_file_entity_id BLOB NOT NULL, + user_id INTEGER NOT NULL REFERENCES users ON DELETE CASCADE, + size INTEGER NOT NULL, + digest BLOB NOT NULL, + key BLOB NOT NULL, + nonce BLOB NOT NULL, + chunk_size INTEGER NOT NULL, + prefix_path TEXT NOT NULL, + tmp_path TEXT, + save_path TEXT NOT NULL, + status TEXT NOT NULL, + deleted INTEGER NOT NULL DEFAULT 0, + error TEXT, + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')), + UNIQUE(rcv_file_entity_id) +); +CREATE INDEX idx_rcv_files_user_id ON rcv_files(user_id); +CREATE TABLE rcv_file_chunks( + rcv_file_chunk_id INTEGER PRIMARY KEY, + rcv_file_id INTEGER NOT NULL REFERENCES rcv_files ON DELETE CASCADE, + chunk_no INTEGER NOT NULL, + chunk_size INTEGER NOT NULL, + digest BLOB NOT NULL, + tmp_path TEXT, + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')) +); +CREATE INDEX idx_rcv_file_chunks_rcv_file_id ON rcv_file_chunks(rcv_file_id); +CREATE TABLE rcv_file_chunk_replicas( + rcv_file_chunk_replica_id INTEGER PRIMARY KEY, + rcv_file_chunk_id INTEGER NOT NULL REFERENCES rcv_file_chunks ON DELETE CASCADE, + replica_number INTEGER NOT NULL, + xftp_server_id INTEGER NOT NULL REFERENCES xftp_servers ON DELETE CASCADE, + replica_id BLOB NOT NULL, + replica_key BLOB NOT NULL, + received INTEGER NOT NULL DEFAULT 0, + delay INTEGER, + retries INTEGER NOT NULL DEFAULT 0, + created_at TEXT NOT NULL DEFAULT(datetime('now')), + updated_at TEXT NOT NULL DEFAULT(datetime('now')) +); +CREATE INDEX idx_rcv_file_chunk_replicas_rcv_file_chunk_id ON rcv_file_chunk_replicas( + rcv_file_chunk_id +); +CREATE INDEX idx_rcv_file_chunk_replicas_xftp_server_id ON rcv_file_chunk_replicas( + xftp_server_id +); diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs index aad0f16e6..bc116c2e3 100644 --- a/src/Simplex/Messaging/Agent/TRcvQueues.hs +++ b/src/Simplex/Messaging/Agent/TRcvQueues.hs @@ -16,8 +16,8 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as M import Data.Set (Set) import qualified Data.Set as S -import Simplex.Messaging.Agent.Protocol (ConnId) -import Simplex.Messaging.Agent.Store (RcvQueue (..), UserId) +import Simplex.Messaging.Agent.Protocol (ConnId, UserId) +import Simplex.Messaging.Agent.Store (RcvQueue (..)) import Simplex.Messaging.Protocol (RecipientId, SMPServer) import Simplex.Messaging.TMap (TMap) import qualified Simplex.Messaging.TMap as TM diff --git a/src/Simplex/Messaging/Client.hs b/src/Simplex/Messaging/Client.hs index b0f13a35f..7df7cf97d 100644 --- a/src/Simplex/Messaging/Client.hs +++ b/src/Simplex/Messaging/Client.hs @@ -31,7 +31,7 @@ module Simplex.Messaging.Client SMPClient, getProtocolClient, closeProtocolClient, - clientServer, + protocolClientServer, transportHost', transportSession', @@ -64,6 +64,7 @@ module Simplex.Messaging.Client transportClientConfig, chooseTransportHost, proxyUsername, + temporaryClientError, ServerTransmission, ClientCommand, ) @@ -253,8 +254,8 @@ chooseTransportHost NetworkConfig {socksProxy, hostMode, requiredHostMode} hosts onionHost = find isOnionHost hosts publicHost = find (not . isOnionHost) hosts -clientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String -clientServer = B.unpack . strEncode . snd3 . transportSession . client_ +protocolClientServer :: ProtocolTypeI (ProtoType msg) => ProtocolClient err msg -> String +protocolClientServer = B.unpack . strEncode . snd3 . transportSession . client_ where snd3 (_, s, _) = s @@ -413,14 +414,21 @@ data ProtocolClientError err | -- | TCP transport handshake or some other transport error. -- Forwarded to the agent client as `ERR BROKER TRANSPORT e`. PCETransportError TransportError - | -- | Error when cryptographically "signing" the command. - PCESignatureError C.CryptoError + | -- | Error when cryptographically "signing" the command or when initializing crypto_box. + PCECryptoError C.CryptoError | -- | IO Error PCEIOError IOException deriving (Eq, Show, Exception) type SMPClientError = ProtocolClientError ErrorType +temporaryClientError :: ProtocolClientError err -> Bool +temporaryClientError = \case + PCENetworkError -> True + PCEResponseTimeout -> True + PCEIOError _ -> True + _ -> False + -- | Create a new SMP queue. -- -- https://github.com/simplex-chat/simplexmq/blob/master/protocol/simplex-messaging.md#create-queue-command diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs index f756d7ce6..1d66a3824 100644 --- a/src/Simplex/Messaging/Crypto.hs +++ b/src/Simplex/Messaging/Crypto.hs @@ -121,6 +121,7 @@ module Simplex.Messaging.Crypto sbEncrypt, sbDecrypt, sbKey, + unsafeSbKey, randomSbKey, -- * pseudo-random bytes @@ -758,11 +759,19 @@ instance FromJSON Key where -- | IV bytes newtype. newtype IV = IV {unIV :: ByteString} + deriving (Eq, Show) instance Encoding IV where smpEncode = unIV smpP = IV <$> A.take (ivSize @AES256) +instance ToJSON IV where + toJSON = strToJSON . unIV + toEncoding = strToJEncoding . unIV + +instance FromJSON IV where + parseJSON = fmap IV . strParseJSON "IV" + -- | GCMIV bytes newtype. newtype GCMIV = GCMIV {unGCMIV :: ByteString} @@ -1025,6 +1034,13 @@ instance ToJSON CbNonce where toJSON = strToJSON toEncoding = strToJEncoding +instance FromJSON CbNonce where + parseJSON = strParseJSON "CbNonce" + +instance FromField CbNonce where fromField f = CryptoBoxNonce <$> fromField f + +instance ToField CbNonce where toField (CryptoBoxNonce s) = toField s + cbNonce :: ByteString -> CbNonce cbNonce s | len == 24 = CryptoBoxNonce s @@ -1056,19 +1072,26 @@ pattern SbKey s <- SecretBoxKey s instance StrEncoding SbKey where strEncode (SbKey s) = strEncode s - strP = sbKey <$> strP + strP = sbKey <$?> strP instance ToJSON SbKey where toJSON = strToJSON toEncoding = strToJEncoding -sbKey :: ByteString -> SbKey +instance FromJSON SbKey where + parseJSON = strParseJSON "SbKey" + +instance FromField SbKey where fromField f = SecretBoxKey <$> fromField f + +instance ToField SbKey where toField (SecretBoxKey s) = toField s + +sbKey :: ByteString -> Either String SbKey sbKey s - | len == 32 = SecretBoxKey s - | len > 32 = SecretBoxKey . fst $ B.splitAt 32 s - | otherwise = SecretBoxKey $ s <> B.replicate (32 - len) (toEnum 0) - where - len = B.length s + | B.length s == 32 = Right $ SecretBoxKey s + | otherwise = Left "SbKey: invalid length" + +unsafeSbKey :: ByteString -> SbKey +unsafeSbKey s = either error id $ sbKey s randomSbKey :: IO SbKey randomSbKey = SecretBoxKey <$> getRandomBytes 32 diff --git a/src/Simplex/Messaging/Crypto/Lazy.hs b/src/Simplex/Messaging/Crypto/Lazy.hs index 667c9a7c4..ab972c8da 100644 --- a/src/Simplex/Messaging/Crypto/Lazy.hs +++ b/src/Simplex/Messaging/Crypto/Lazy.hs @@ -1,33 +1,60 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module Simplex.Messaging.Crypto.Lazy - ( sha512Hash, + ( sha256Hash, + sha512Hash, pad, unPad, + splitLen, sbEncrypt, sbDecrypt, + sbEncryptTailTag, + sbDecryptTailTag, fastReplicate, + SbState, + cbInit, + sbInit, + sbEncryptChunk, + sbDecryptChunk, + sbEncryptChunkLazy, + sbDecryptChunkLazy, + sbAuth, + LazyByteString, ) where import qualified Crypto.Cipher.XSalsa as XSalsa import qualified Crypto.Error as CE import Crypto.Hash (Digest, hashlazy) -import Crypto.Hash.Algorithms (SHA512) +import Crypto.Hash.Algorithms (SHA256, SHA512) import qualified Crypto.MAC.Poly1305 as Poly1305 +import Data.Bifunctor (first) import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as BA +import qualified Data.ByteString as S import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import qualified Data.ByteString.Lazy.Internal as LB +import Data.Composition ((.:.)) import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty (..)) import Foreign (sizeOf) -import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), SbKey, pattern CbNonce, pattern SbKey) +import Simplex.Messaging.Crypto (CbNonce, CryptoError (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey) import Simplex.Messaging.Encoding type LazyByteString = LB.ByteString +-- | SHA512 digest of a lazy bytestring. +sha256Hash :: LazyByteString -> ByteString +sha256Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA256) + -- | SHA512 digest of a lazy bytestring. sha512Hash :: LazyByteString -> ByteString sha512Hash = BA.convert . (hashlazy :: LazyByteString -> Digest SHA512) @@ -56,63 +83,129 @@ fastReplicate n c -- this function does not validate the length of the message to avoid consuming all chunks, -- so it can return a shorter string than expected unPad :: LazyByteString -> Either CryptoError LazyByteString -unPad padded +unPad = fmap snd . splitLen + +splitLen :: LazyByteString -> Either CryptoError (Int64, LazyByteString) +splitLen padded | LB.length lenStr == 8 = case smpDecode $ LB.toStrict lenStr of Right len | len < 0 -> Left CryptoInvalidMsgError - | otherwise -> Right $ LB.take len rest + | otherwise -> Right (len, LB.take len rest) Left _ -> Left CryptoInvalidMsgError | otherwise = Left CryptoInvalidMsgError where (lenStr, rest) = LB.splitAt 8 padded -- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce. +-- The resulting string will be bigger than paddedLen by the size of the auth tag (16 bytes). sbEncrypt :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString -sbEncrypt (SbKey key) = sbEncrypt_ key - -sbEncrypt_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString -sbEncrypt_ secret (CbNonce nonce) msg len paddedLen = cryptoBox secret nonce =<< pad msg len paddedLen +sbEncrypt (SbKey key) (CbNonce nonce) msg len paddedLen = + prependTag <$> (secretBox sbEncryptChunk key nonce =<< pad msg len paddedLen) + where + prependTag (tag :| cs) = LB.Chunk tag $ LB.fromChunks cs -- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce. +-- The resulting string will be smaller than packet size by the size of the auth tag (16 bytes). sbDecrypt :: SbKey -> CbNonce -> LazyByteString -> Either CryptoError LazyByteString -sbDecrypt (SbKey key) = sbDecrypt_ key - --- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce. -sbDecrypt_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Either CryptoError LazyByteString -sbDecrypt_ secret (CbNonce nonce) packet +sbDecrypt (SbKey key) (CbNonce nonce) packet | LB.length tag' < 16 = Left CBDecryptError - | otherwise = case poly1305auth rs c of - Right tag - | BA.constEq (LB.toStrict tag') tag -> unPad msg + | otherwise = case secretBox sbDecryptChunk key nonce c of + Right (tag :| cs) + | BA.constEq (LB.toStrict tag') tag -> unPad $ LB.fromChunks cs | otherwise -> Left CBDecryptError Left e -> Left e where (tag', c) = LB.splitAt 16 packet - (rs, msg) = xSalsa20 secret nonce c -cryptoBox :: ByteArrayAccess key => key -> ByteString -> LazyByteString -> Either CryptoError LazyByteString -cryptoBox secret nonce s = (<> c) . LB.fromStrict . BA.convert <$> tag +secretBox :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (NonEmpty ByteString) +secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce where - (rs, c) = xSalsa20 secret nonce s - tag = poly1305auth rs c + run state = + let (!cs, !state') = secretBoxLazy_ sbProcess state msg + in BA.convert (sbAuth state') :| reverse cs -poly1305auth :: ByteString -> LazyByteString -> Either CryptoError Poly1305.Auth -poly1305auth rs c = authTag <$> cryptoPassed (Poly1305.initialize rs) +-- | NaCl @secret_box@ lazy encrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files). +sbEncryptTailTag :: SbKey -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString +sbEncryptTailTag (SbKey key) (CbNonce nonce) msg len paddedLen = + LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen) + +-- | NaCl @secret_box@ decrypt with a symmetric 256-bit key and 192-bit nonce with appended auth tag (more efficient with large files). +-- paddedLen should NOT include the tag length, it should be the same number that is passed to sbEncrypt / sbEncryptTailTag. +sbDecryptTailTag :: SbKey -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString) +sbDecryptTailTag (SbKey key) (CbNonce nonce) paddedLen packet = + case secretBox sbDecryptChunk key nonce c of + Right (tag :| cs) -> + let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag + in (valid,) <$> unPad (LB.fromChunks cs) + Left e -> Left e where - authTag state = Poly1305.finalize $ Poly1305.updates state $ LB.toChunks c - cryptoPassed = \case - CE.CryptoPassed a -> Right a - CE.CryptoFailed e -> Left $ CryptoPoly1305Error e + (c, tag') = LB.splitAt paddedLen packet -xSalsa20 :: ByteArrayAccess key => key -> ByteString -> LazyByteString -> (ByteString, LazyByteString) -xSalsa20 secret nonce msg = (rs, msg') +secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString] +secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce + where + run state = + let (cs, state') = secretBoxLazy_ sbProcess state msg + in reverse $ BA.convert (sbAuth state') : cs + +-- passes lazy bytestring via initialized secret box returning the reversed list of chunks +secretBoxLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> ([ByteString], SbState) +secretBoxLazy_ sbProcess state = foldlChunks update ([], state) + where + update (cs, st) chunk = let (!c, !st') = sbProcess st chunk in (c : cs, st') + +type SbState = (XSalsa.State, Poly1305.State) + +cbInit :: DhSecretX25519 -> CbNonce -> Either CryptoError SbState +cbInit (DhSecretX25519 secret) (CbNonce nonce) = sbInit_ secret nonce +{-# INLINE cbInit #-} + +sbInit :: SbKey -> CbNonce -> Either CryptoError SbState +sbInit (SbKey secret) (CbNonce nonce) = sbInit_ secret nonce +{-# INLINE sbInit #-} + +sbInit_ :: ByteArrayAccess key => key -> ByteString -> Either CryptoError SbState +sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs) where zero = B.replicate 16 $ toEnum 0 (iv0, iv1) = B.splitAt 8 nonce state0 = XSalsa.initialize 20 secret (zero `B.append` iv0) state1 = XSalsa.derive state0 iv1 - (rs, state2) = XSalsa.generate state1 32 - (msg', _) = foldl update (LB.empty, state2) $ LB.toChunks msg - update (acc, state) chunk = - let (c, state') = XSalsa.combine state chunk - in (acc `LB.append` LB.fromStrict c, state') + (rs :: ByteString, state2) = XSalsa.generate state1 32 + +sbEncryptChunkLazy :: SbState -> LazyByteString -> (LazyByteString, SbState) +sbEncryptChunkLazy = sbProcessChunkLazy_ sbEncryptChunk + +sbDecryptChunkLazy :: SbState -> LazyByteString -> (LazyByteString, SbState) +sbDecryptChunkLazy = sbProcessChunkLazy_ sbDecryptChunk + +sbProcessChunkLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> (LazyByteString, SbState) +sbProcessChunkLazy_ = first (LB.fromChunks . reverse) .:. secretBoxLazy_ +{-# INLINE sbProcessChunkLazy_ #-} + +sbEncryptChunk :: SbState -> ByteString -> (ByteString, SbState) +sbEncryptChunk (st, authSt) chunk = + let (!c, !st') = XSalsa.combine st chunk + !authSt' = Poly1305.update authSt c + in (c, (st', authSt')) + +sbDecryptChunk :: SbState -> ByteString -> (ByteString, SbState) +sbDecryptChunk (st, authSt) chunk = + let (!s, !st') = XSalsa.combine st chunk + !authSt' = Poly1305.update authSt chunk + in (s, (st', authSt')) + +sbAuth :: SbState -> Poly1305.Auth +sbAuth = Poly1305.finalize . snd + +cryptoPassed :: CE.CryptoFailable b -> Either CryptoError b +cryptoPassed = \case + CE.CryptoPassed a -> Right a + CE.CryptoFailed e -> Left $ CryptoPoly1305Error e + +foldlChunks :: (a -> S.ByteString -> a) -> a -> LazyByteString -> a +foldlChunks f = go + where + go !a LB.Empty = a + go !a (LB.Chunk c cs) = go (f a c) cs +{-# INLINE foldlChunks #-} diff --git a/src/Simplex/Messaging/Encoding/String.hs b/src/Simplex/Messaging/Encoding/String.hs index 769d591b9..e81b0da89 100644 --- a/src/Simplex/Messaging/Encoding/String.hs +++ b/src/Simplex/Messaging/Encoding/String.hs @@ -36,7 +36,7 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Time.Clock.System (SystemTime (..)) import Data.Time.Format.ISO8601 -import Data.Word (Word16) +import Data.Word (Word16, Word32) import Simplex.Messaging.Encoding import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Util ((<$?>)) @@ -75,6 +75,10 @@ instance StrEncoding Str where strEncode = unStr strP = Str <$> A.takeTill (== ' ') <* optional A.space +instance StrEncoding String where + strEncode = strEncode . B.pack + strP = B.unpack <$> strP + instance ToJSON Str where toJSON (Str s) = strToJSON s toEncoding (Str s) = strToJEncoding s @@ -94,6 +98,12 @@ instance StrEncoding Word16 where strP = A.decimal {-# INLINE strP #-} +instance StrEncoding Word32 where + strEncode = B.pack . show + {-# INLINE strEncode #-} + strP = A.decimal + {-# INLINE strP #-} + instance StrEncoding Char where strEncode = smpEncode {-# INLINE strEncode #-} diff --git a/src/Simplex/Messaging/Notifications/Server.hs b/src/Simplex/Messaging/Notifications/Server.hs index bbc7e3d43..1f230883b 100644 --- a/src/Simplex/Messaging/Notifications/Server.hs +++ b/src/Simplex/Messaging/Notifications/Server.hs @@ -235,7 +235,7 @@ ntfSubscriber NtfSubscriber {smpSubscribers, newSubQ, smpAgent = ca@SMPClientAge PCEResponseError e -> updateErr "ResponseError " e PCEUnexpectedResponse r -> updateErr "UnexpectedResponse " r PCETransportError e -> updateErr "TransportError " e - PCESignatureError e -> updateErr "SignatureError " e + PCECryptoError e -> updateErr "CryptoError " e PCEIncompatibleHost -> updateSubStatus smpQueue $ NSErr "IncompatibleHost" PCEResponseTimeout -> pure () PCENetworkError -> pure () diff --git a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs index 5eee63447..0b4b0f572 100644 --- a/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs +++ b/src/Simplex/Messaging/Notifications/Server/Push/APNS.hs @@ -343,7 +343,8 @@ apnsPushProviderClient c@APNSPushClient {nonceDrg, apnsCfg} tkn@NtfTknData {toke nonce <- atomically $ C.pseudoRandomCbNonce nonceDrg apnsNtf <- liftEither $ first PPCryptoError $ apnsNotification tkn nonce (paddedNtfLength apnsCfg) pn req <- liftIO $ apnsRequest c tknStr apnsNtf - HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req + -- TODO when HTTP2 client is thread-safe, we can use sendRequestDirect + HTTP2Response {response, respBody = HTTP2Body {bodyHead}} <- liftHTTPS2 $ sendRequest http2 req Nothing let status = H.responseStatus response reason' = maybe "" reason $ J.decodeStrict' bodyHead logDebug $ "APNS response: " <> T.pack (show status) <> " " <> reason' diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 238fc971a..20e35aae5 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -65,6 +65,7 @@ module Simplex.Messaging.Protocol PrivHeader (..), Protocol (..), ProtocolType (..), + SProtocolType (..), AProtocolType (..), ProtocolTypeI (..), ProtocolServer (..), @@ -74,7 +75,11 @@ module Simplex.Messaging.Protocol SMPServerWithAuth, NtfServer, pattern NtfServer, + XFTPServer, + pattern XFTPServer, + XFTPServerWithAuth, ProtoServerWithAuth (..), + AProtoServerWithAuth (..), BasicAuth (..), SrvLoc (..), CorrId (..), @@ -165,7 +170,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 (..)) @@ -623,6 +628,15 @@ pattern NtfServer host port keyHash = ProtocolServer SPNTF host port keyHash {-# COMPLETE NtfServer #-} +type XFTPServer = ProtocolServer 'PXFTP + +pattern XFTPServer :: NonEmpty TransportHost -> ServiceName -> C.KeyHash -> ProtocolServer 'PXFTP +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' #-} @@ -631,22 +645,25 @@ sameSrvAddr :: ProtocolServer p -> ProtocolServer p -> Bool sameSrvAddr ProtocolServer {host, port} ProtocolServer {host = h', port = p'} = host == h' && port == p' {-# INLINE sameSrvAddr #-} -data ProtocolType = PSMP | PNTF +data ProtocolType = PSMP | PNTF | PXFTP deriving (Eq, Ord, Show) instance StrEncoding ProtocolType where strEncode = \case PSMP -> "smp" PNTF -> "ntf" + PXFTP -> "xftp" strP = A.takeTill (\c -> c == ':' || c == ' ') >>= \case "smp" -> pure PSMP "ntf" -> pure PNTF + "xftp" -> pure PXFTP _ -> fail "bad ProtocolType" data SProtocolType (p :: ProtocolType) where SPSMP :: SProtocolType 'PSMP SPNTF :: SProtocolType 'PNTF + SPXFTP :: SProtocolType 'PXFTP deriving instance Eq (SProtocolType p) @@ -664,17 +681,20 @@ instance Eq AProtocolType where instance TestEquality SProtocolType where testEquality SPSMP SPSMP = Just Refl testEquality SPNTF SPNTF = Just Refl + testEquality SPXFTP SPXFTP = Just Refl testEquality _ _ = Nothing protocolType :: SProtocolType p -> ProtocolType protocolType = \case SPSMP -> PSMP SPNTF -> PNTF + SPXFTP -> PXFTP aProtocolType :: ProtocolType -> AProtocolType aProtocolType = \case PSMP -> AProtocolType SPSMP PNTF -> AProtocolType SPNTF + PXFTP -> AProtocolType SPXFTP instance ProtocolTypeI p => StrEncoding (SProtocolType p) where strEncode = strEncode . protocolType @@ -700,6 +720,8 @@ instance ProtocolTypeI 'PSMP where protocolTypeI = SPSMP instance ProtocolTypeI 'PNTF where protocolTypeI = SPNTF +instance ProtocolTypeI 'PXFTP where protocolTypeI = SPXFTP + -- | server location and transport key digest (hash). data ProtocolServer p = ProtocolServer { scheme :: SProtocolType p, @@ -709,6 +731,8 @@ data ProtocolServer p = ProtocolServer } deriving (Eq, Ord, Show) +data AProtocolServer = forall p. ProtocolTypeI p => AProtocolServer (SProtocolType p) (ProtocolServer p) + instance ProtocolTypeI p => IsString (ProtocolServer p) where fromString = parseString strDecode @@ -724,15 +748,18 @@ instance ProtocolTypeI p => StrEncoding (ProtocolServer p) where strEncodeServer scheme (strEncode host) port keyHash Nothing strP = serverStrP >>= \case - (srv, Nothing) -> pure srv + (AProtocolServer _ srv, Nothing) -> either fail pure $ checkProtocolType srv _ -> fail "ProtocolServer with basic auth not allowed" instance ProtocolTypeI p => ToJSON (ProtocolServer p) where toJSON = strToJSON toEncoding = strToJEncoding +instance ProtocolTypeI p => FromJSON (ProtocolServer p) where + parseJSON = strParseJSON "ProtocolServer" + newtype BasicAuth = BasicAuth {unBasicAuth :: ByteString} - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance IsString BasicAuth where fromString = BasicAuth . B.pack @@ -752,15 +779,25 @@ basicAuth s valid c = isPrint c && not (isSpace c) && c /= '@' && c /= ':' && c /= '/' data ProtoServerWithAuth p = ProtoServerWithAuth {protoServer :: ProtocolServer p, serverBasicAuth :: Maybe BasicAuth} - deriving (Show) + deriving (Eq, Ord, Show) instance ProtocolTypeI p => IsString (ProtoServerWithAuth p) where fromString = parseString strDecode +data AProtoServerWithAuth = forall p. ProtocolTypeI p => AProtoServerWithAuth (SProtocolType p) (ProtoServerWithAuth p) + +deriving instance Show AProtoServerWithAuth + instance ProtocolTypeI p => StrEncoding (ProtoServerWithAuth p) where strEncode (ProtoServerWithAuth ProtocolServer {scheme, host, port, keyHash} auth_) = strEncodeServer scheme (strEncode host) port keyHash auth_ - strP = uncurry ProtoServerWithAuth <$> serverStrP + strP = (\(AProtoServerWithAuth _ srv) -> checkProtocolType srv) <$?> strP + +instance StrEncoding AProtoServerWithAuth where + strEncode (AProtoServerWithAuth _ srv) = strEncode srv + strP = + serverStrP >>= \(AProtocolServer p srv, auth) -> + pure $ AProtoServerWithAuth p (ProtoServerWithAuth srv auth) instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where toJSON = strToJSON @@ -769,6 +806,13 @@ instance ProtocolTypeI p => ToJSON (ProtoServerWithAuth p) where instance ProtocolTypeI p => FromJSON (ProtoServerWithAuth p) where parseJSON = strParseJSON "ProtoServerWithAuth" +instance ToJSON AProtoServerWithAuth where + toJSON = strToJSON + toEncoding = strToJEncoding + +instance FromJSON AProtoServerWithAuth where + parseJSON = strParseJSON "AProtoServerWithAuth" + noAuthSrv :: ProtocolServer p -> ProtoServerWithAuth p noAuthSrv srv = ProtoServerWithAuth srv Nothing @@ -791,14 +835,15 @@ strEncodeServer scheme host port keyHash auth_ = where portStr = B.pack $ if null port then "" else ':' : port -serverStrP :: ProtocolTypeI p => Parser (ProtocolServer p, Maybe BasicAuth) +serverStrP :: Parser (AProtocolServer, Maybe BasicAuth) serverStrP = do scheme <- strP <* "://" keyHash <- strP auth_ <- optional $ A.char ':' *> strP TransportHosts host <- A.char '@' *> strP port <- portP <|> pure "" - pure (ProtocolServer {scheme, host, port, keyHash}, auth_) + pure $ case scheme of + AProtocolType s -> (AProtocolServer s $ ProtocolServer {scheme = s, host, port, keyHash}, auth_) where portP = show <$> (A.char ':' *> (A.decimal :: Parser Int)) @@ -1133,9 +1178,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 @@ -1214,7 +1257,7 @@ tPut th trs Just ts' -> encodeBatch n' s' ts' _ -> (n', s', Nothing) -tEncode :: C.CryptoSignature s => (s, ByteString) -> ByteString +tEncode :: (Maybe C.ASignature, ByteString) -> ByteString tEncode (sig, t) = smpEncode (C.signatureBytes sig) <> t tEncodeBatch :: Int -> ByteString -> ByteString diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index bd8c5330c..b9f03ff9b 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/src/Simplex/Messaging/Server.hs @@ -300,7 +300,7 @@ disconnectTransport THandle {connection} c activeAt expCfg = do data VerificationResult = VRVerified (Maybe QueueRec) | VRFailed verifyTransmission :: Maybe C.ASignature -> ByteString -> QueueId -> Cmd -> M VerificationResult -verifyTransmission sig_ signed queueId cmd = do +verifyTransmission sig_ signed queueId cmd = case cmd of Cmd SRecipient (NEW k _ _) -> pure $ Nothing `verified` verifyCmdSignature sig_ signed k Cmd SRecipient _ -> verifyCmd SRecipient $ verifyCmdSignature sig_ signed . recipientKey @@ -311,7 +311,7 @@ verifyTransmission sig_ signed queueId cmd = do verifyCmd :: SParty p -> (QueueRec -> Bool) -> M VerificationResult verifyCmd party f = do st <- asks queueStore - q_ <- atomically (getQueue st party queueId) + q_ <- atomically $ getQueue st party queueId pure $ case q_ of Right q -> Just q `verified` f q _ -> maybe False (dummyVerifyCmd signed) sig_ `seq` VRFailed diff --git a/src/Simplex/Messaging/Server/CLI.hs b/src/Simplex/Messaging/Server/CLI.hs index 462274b47..6f393a018 100644 --- a/src/Simplex/Messaging/Server/CLI.hs +++ b/src/Simplex/Messaging/Server/CLI.hs @@ -16,6 +16,7 @@ import Data.Either (fromRight) import Data.Ini (Ini, lookupValue) import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import Data.X509.Validation (Fingerprint (..)) import Network.Socket (HostName, ServiceName) import Options.Applicative @@ -24,7 +25,7 @@ import Simplex.Messaging.Protocol (ProtoServerWithAuth (..), ProtocolServer (..) import Simplex.Messaging.Transport (ATransport (..), TLS, Transport (..)) import Simplex.Messaging.Transport.Server (loadFingerprint) import Simplex.Messaging.Transport.WebSockets (WS) -import Simplex.Messaging.Util (whenM) +import Simplex.Messaging.Util (eitherToMaybe, whenM) import System.Directory (doesDirectoryExist, listDirectory, removeDirectoryRecursive, removePathForcibly) import System.Exit (exitFailure) import System.FilePath (combine) @@ -170,6 +171,9 @@ iniOnOff section name ini = case lookupValue section name ini of Right s -> error . T.unpack $ "invalid INI setting " <> name <> ": " <> s _ -> Nothing +strDecodeIni :: StrEncoding a => Text -> Text -> Ini -> Maybe (Either String a) +strDecodeIni section name ini = strDecode . encodeUtf8 <$> eitherToMaybe (lookupValue section name ini) + withPrompt :: String -> IO a -> IO a withPrompt s a = putStr s >> hFlush stdout >> a diff --git a/src/Simplex/Messaging/Server/Main.hs b/src/Simplex/Messaging/Server/Main.hs index b66ed5ba4..49a24a0bc 100644 --- a/src/Simplex/Messaging/Server/Main.hs +++ b/src/Simplex/Messaging/Server/Main.hs @@ -178,9 +178,7 @@ smpServerCLI cfgPath logPath = _ -> enableStoreLog $> messagesPath, -- allow creating new queues by default allowNewQueues = fromMaybe True $ iniOnOff "AUTH" "new_queues" ini, - newQueueBasicAuth = case lookupValue "AUTH" "create_password" ini of - Right auth -> either error Just . strDecode $ encodeUtf8 auth - _ -> Nothing, + newQueueBasicAuth = either error id <$> strDecodeIni "AUTH" "create_password" ini, messageExpiration = Just defaultMessageExpiration, inactiveClientExpiration = settingIsOn "INACTIVE_CLIENTS" "disconnect" ini diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index 2042e530e..3344a8197 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/src/Simplex/Messaging/Transport.hs @@ -204,11 +204,10 @@ instance Transport TLS where tlsUnique = tlsUniq closeConnection tls = closeTLS $ tlsContext tls + -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData + -- this function may return less than requested number of bytes cGet :: TLS -> Int -> IO ByteString - cGet TLS {tlsContext, tlsBuffer} n = do - s <- getBuffered tlsBuffer n (T.recvData tlsContext) - -- https://hackage.haskell.org/package/tls-1.6.0/docs/Network-TLS.html#v:recvData - if B.length s == n then pure s else ioe_EOF + cGet TLS {tlsContext, tlsBuffer} n = getBuffered tlsBuffer n (T.recvData tlsContext) cPut :: TLS -> ByteString -> IO () cPut tls = T.sendData (tlsContext tls) . BL.fromStrict @@ -303,7 +302,7 @@ transportErrorP = "BLOCK" $> TEBadBlock <|> "LARGE_MSG" $> TELargeMsg <|> "SESSION" $> TEBadSession - <|> TEHandshake <$> parseRead1 + <|> "HANDSHAKE " *> (TEHandshake <$> parseRead1) -- | Serialize SMP encrypted transport error. serializeTransportError :: TransportError -> ByteString @@ -311,7 +310,7 @@ serializeTransportError = \case TEBadBlock -> "BLOCK" TELargeMsg -> "LARGE_MSG" TEBadSession -> "SESSION" - TEHandshake e -> bshow e + TEHandshake e -> "HANDSHAKE " <> bshow e -- | Pad and send block to SMP transport. tPutBlock :: Transport c => THandle c -> ByteString -> IO (Either TransportError ()) @@ -321,10 +320,11 @@ tPutBlock THandle {connection = c, blockSize} block = -- | Receive block from SMP transport. tGetBlock :: Transport c => THandle c -> IO (Either TransportError ByteString) -tGetBlock THandle {connection = c, blockSize} = - cGet c blockSize >>= \case - "" -> ioe_EOF - msg -> pure . first (const TELargeMsg) $ C.unPad msg +tGetBlock THandle {connection = c, blockSize} = do + msg <- cGet c blockSize + if B.length msg == blockSize + then pure . first (const TELargeMsg) $ C.unPad msg + else ioe_EOF -- | Server SMP transport handshake. -- diff --git a/src/Simplex/Messaging/Transport/Buffer.hs b/src/Simplex/Messaging/Transport/Buffer.hs index e789eeaac..7d09d6819 100644 --- a/src/Simplex/Messaging/Transport/Buffer.hs +++ b/src/Simplex/Messaging/Transport/Buffer.hs @@ -31,6 +31,8 @@ getBuffered tb@TBuffer {buffer} n getChunk = withBufferLock tb $ do b <- readChunks =<< readTVarIO buffer let (s, b') = B.splitAt n b atomically $ writeTVar buffer $! b' + -- This would prevent the need to pad auth tag in HTTP2 + -- threadDelay 150 pure s where readChunks :: ByteString -> IO ByteString diff --git a/src/Simplex/Messaging/Transport/HTTP2.hs b/src/Simplex/Messaging/Transport/HTTP2.hs index dc023f920..f258f9dc9 100644 --- a/src/Simplex/Messaging/Transport/HTTP2.hs +++ b/src/Simplex/Messaging/Transport/HTTP2.hs @@ -22,7 +22,7 @@ import qualified System.TimeManager as TI defaultHTTP2BufferSize :: BufferSize defaultHTTP2BufferSize = 32768 -withHTTP2 :: BufferSize -> (Config -> SessionId -> IO ()) -> TLS -> IO () +withHTTP2 :: BufferSize -> (Config -> SessionId -> IO a) -> TLS -> IO a withHTTP2 sz run c = E.bracket (allocHTTP2Config c sz) freeSimpleConfig (`run` tlsUniq c) allocHTTP2Config :: TLS -> BufferSize -> IO Config @@ -56,25 +56,26 @@ data HTTP2Body = HTTP2Body class HTTP2BodyChunk a where getBodyChunk :: a -> IO ByteString - getBodeSize :: a -> Maybe Int + getBodySize :: a -> Maybe Int instance HTTP2BodyChunk HC.Response where getBodyChunk = HC.getResponseBodyChunk {-# INLINE getBodyChunk #-} - getBodeSize = HC.responseBodySize - {-# INLINE getBodeSize #-} + getBodySize = HC.responseBodySize + {-# INLINE getBodySize #-} instance HTTP2BodyChunk HS.Request where getBodyChunk = HS.getRequestBodyChunk {-# INLINE getBodyChunk #-} - getBodeSize = HS.requestBodySize - {-# INLINE getBodeSize #-} + getBodySize = HS.requestBodySize + {-# INLINE getBodySize #-} getHTTP2Body :: HTTP2BodyChunk a => a -> Int -> IO HTTP2Body getHTTP2Body r n = do bodyBuffer <- atomically newTBuffer let getPart n' = getBuffered bodyBuffer n' $ getBodyChunk r bodyHead <- getPart n - let bodySize = fromMaybe 0 $ getBodeSize r - bodyPart = if bodySize > n && B.length bodyHead == n then Just getPart else Nothing + let bodySize = fromMaybe 0 $ getBodySize r + -- TODO check bodySize once it is set + bodyPart = if B.length bodyHead == n then Just getPart else Nothing pure HTTP2Body {bodyHead, bodySize, bodyPart, bodyBuffer} diff --git a/src/Simplex/Messaging/Transport/HTTP2/Client.hs b/src/Simplex/Messaging/Transport/HTTP2/Client.hs index c8d74dbc5..66d88f6c9 100644 --- a/src/Simplex/Messaging/Transport/HTTP2/Client.hs +++ b/src/Simplex/Messaging/Transport/HTTP2/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -6,10 +7,11 @@ module Simplex.Messaging.Transport.HTTP2.Client where import Control.Concurrent.Async -import Control.Exception (IOException) +import Control.Exception (IOException, try) import qualified Control.Exception as E import Control.Monad.Except import Data.ByteString.Char8 (ByteString) +import Data.Functor (($>)) import Data.Time (UTCTime, getCurrentTime) import qualified Data.X509.CertificateStore as XS import Network.HPACK (BufferSize) @@ -27,14 +29,16 @@ import UnliftIO.STM import UnliftIO.Timeout data HTTP2Client = HTTP2Client - { action :: Maybe (Async ()), + { action :: Maybe (Async HTTP2Response), sessionId :: SessionId, sessionTs :: UTCTime, + sendReq :: Request -> (Response -> IO HTTP2Response) -> IO HTTP2Response, client_ :: HClient } data HClient = HClient { connected :: TVar Bool, + disconnected :: IO (), host :: TransportHost, port :: ServiceName, config :: HTTP2ClientConfig, @@ -82,7 +86,7 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config@HTTP2Clien mkHTTPS2Client = do connected <- newTVar False reqQ <- newTBQueue $ qSize config - pure HClient {connected, host, port, config, reqQ} + pure HClient {connected, disconnected, host, port, config, reqQ} runClient :: HClient -> IO (Either HTTP2ClientError HTTP2Client) runClient c = do @@ -97,34 +101,54 @@ getVerifiedHTTP2Client proxyUsername host port keyHash caStore config@HTTP2Clien Just (Left e) -> Left e Nothing -> Left HCNetworkError - client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> SessionId -> H.Client () + client :: HClient -> TMVar (Either HTTP2ClientError HTTP2Client) -> SessionId -> H.Client HTTP2Response client c cVar sessionId sendReq = do sessionTs <- getCurrentTime - let c' = HTTP2Client {action = Nothing, client_ = c, sessionId, sessionTs} + let c' = HTTP2Client {action = Nothing, client_ = c, sendReq, sessionId, sessionTs} atomically $ do writeTVar (connected c) True putTMVar cVar (Right c') process c' sendReq `E.finally` disconnected - process :: HTTP2Client -> H.Client () + process :: HTTP2Client -> H.Client HTTP2Response process HTTP2Client {client_ = HClient {reqQ}} sendReq = forever $ do (req, respVar) <- atomically $ readTBQueue reqQ sendReq req $ \r -> do respBody <- getHTTP2Body r bodyHeadSize - atomically $ putTMVar respVar HTTP2Response {response = r, respBody} + let resp = HTTP2Response {response = r, respBody} + atomically $ putTMVar respVar resp + pure resp -- | Disconnects client from the server and terminates client threads. closeHTTP2Client :: HTTP2Client -> IO () closeHTTP2Client = mapM_ uninterruptibleCancel . action -sendRequest :: HTTP2Client -> Request -> IO (Either HTTP2ClientError HTTP2Response) -sendRequest HTTP2Client {client_ = HClient {config, reqQ}} req = do +sendRequest :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response) +sendRequest HTTP2Client {client_ = HClient {config, reqQ}} req reqTimeout_ = do resp <- newEmptyTMVarIO atomically $ writeTBQueue reqQ (req, resp) - maybe (Left HCResponseTimeout) Right <$> (connTimeout config `timeout` atomically (takeTMVar resp)) + let reqTimeout = http2RequestTimeout config reqTimeout_ + maybe (Left HCResponseTimeout) Right <$> (reqTimeout `timeout` atomically (takeTMVar resp)) -runHTTP2Client :: T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (SessionId -> H.Client ()) -> IO () +-- | this function should not be used until HTTP2 is thread safe, use sendRequest +sendRequestDirect :: HTTP2Client -> Request -> Maybe Int -> IO (Either HTTP2ClientError HTTP2Response) +sendRequestDirect HTTP2Client {client_ = HClient {config, disconnected}, sendReq} req reqTimeout_ = do + let reqTimeout = http2RequestTimeout config reqTimeout_ + reqTimeout `timeout` try (sendReq req process) >>= \case + Just (Right r) -> pure $ Right r + Just (Left e) -> disconnected $> Left (HCIOError e) + Nothing -> pure $ Left HCNetworkError + where + process r = do + respBody <- getHTTP2Body r $ bodyHeadSize config + pure HTTP2Response {response = r, respBody} + +http2RequestTimeout :: HTTP2ClientConfig -> Maybe Int -> Int +http2RequestTimeout HTTP2ClientConfig {connTimeout} = maybe connTimeout (connTimeout +) + +runHTTP2Client :: forall a. T.Supported -> Maybe XS.CertificateStore -> TransportClientConfig -> BufferSize -> Maybe ByteString -> TransportHost -> ServiceName -> Maybe C.KeyHash -> (SessionId -> H.Client a) -> IO a runHTTP2Client tlsParams caStore tcConfig bufferSize proxyUsername host port keyHash client = runTLSTransportClient tlsParams caStore tcConfig proxyUsername host port keyHash $ withHTTP2 bufferSize run where + run :: H.Config -> SessionId -> IO a run cfg = H.run (ClientConfig "https" (strEncode host) 20) cfg . client diff --git a/src/Simplex/Messaging/Util.hs b/src/Simplex/Messaging/Util.hs index 6e1b5ef11..a98175ff0 100644 --- a/src/Simplex/Messaging/Util.hs +++ b/src/Simplex/Messaging/Util.hs @@ -55,6 +55,10 @@ liftEitherError :: (MonadIO m, MonadError e' m) => (e -> e') -> IO (Either e a) liftEitherError f a = liftIOEither (first f <$> a) {-# INLINE liftEitherError #-} +liftEitherWith :: (MonadError e' m) => (e -> e') -> Either e a -> m a +liftEitherWith f = liftEither . first f +{-# INLINE liftEitherWith #-} + tryError :: MonadError e m => m a -> m (Either e a) tryError action = (Right <$> action) `catchError` (pure . Left) {-# INLINE tryError #-} diff --git a/stack.yaml b/stack.yaml index 0cc68455c..1835dec0e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -48,6 +48,8 @@ extra-deps: - time-compat-1.9.6.1@sha256:42d8f2e08e965e1718917d54ad69e1d06bd4b87d66c41dc7410f59313dba4ed1,5033 - github: simplex-chat/aeson commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7 + - github: kazu-yamamoto/http2 + commit: 78e18f52295a7f89e828539a03fbcb24931461a3 # - ../direct-sqlcipher - github: simplex-chat/direct-sqlcipher commit: 34309410eb2069b029b8fc1872deb1e0db123294 diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index 705bf4550..6023ae398 100644 --- a/tests/AgentTests.hs +++ b/tests/AgentTests.hs @@ -5,6 +5,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PostfixOperators #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module AgentTests (agentTests) where @@ -19,6 +20,7 @@ import Control.Concurrent import Control.Monad (forM_) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B +import Data.Type.Equality import Network.HTTP.Types (urlEncode) import SMPAgentClient import SMPClient (testKeyHash, testPort, testPort2, testStoreLogFile, withSmpServer, withSmpServerStoreLogOn) @@ -81,45 +83,73 @@ agentTests (ATransport t) = do it "should resume delivering messages after exceeding quota once all messages are received" $ smpAgentTest2_2_1 $ testResumeDeliveryQuotaExceeded t -tGetAgent :: Transport c => c -> IO (ATransmissionOrError 'Agent) -tGetAgent h = do - t@(_, _, cmd) <- tGet SAgent h - case cmd of - Right CONNECT {} -> tGetAgent h - Right DISCONNECT {} -> tGetAgent h - _ -> pure t +type AEntityTransmission p e = (ACorrId, ConnId, ACommand p e) + +type AEntityTransmissionOrError p e = (ACorrId, ConnId, Either AgentErrorType (ACommand p e)) + +tGetAgent :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn) +tGetAgent = tGetAgent' + +tGetAgent' :: forall c e. (Transport c, AEntityI e) => c -> IO (AEntityTransmissionOrError 'Agent e) +tGetAgent' h = do + (corrId, connId, cmdOrErr) <- pGetAgent h + case cmdOrErr of + Right (APC e cmd) -> case testEquality e (sAEntity @e) of + Just Refl -> pure (corrId, connId, Right cmd) + _ -> error $ "unexpected command " <> show cmd + Left err -> pure (corrId, connId, Left err) + +pGetAgent :: forall c. Transport c => c -> IO (ATransmissionOrError 'Agent) +pGetAgent h = do + (corrId, connId, cmdOrErr) <- tGet SAgent h + case cmdOrErr of + Right (APC _ CONNECT {}) -> pGetAgent h + Right (APC _ DISCONNECT {}) -> pGetAgent h + cmd -> pure (corrId, connId, cmd) -- | receive message to handle `h` -(<#:) :: Transport c => c -> IO (ATransmissionOrError 'Agent) +(<#:) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AEConn) (<#:) = tGetAgent +(<#:?) :: Transport c => c -> IO (ATransmissionOrError 'Agent) +(<#:?) = pGetAgent + +(<#:.) :: Transport c => c -> IO (AEntityTransmissionOrError 'Agent 'AENone) +(<#:.) = tGetAgent' + -- | send transmission `t` to handle `h` and get response -(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (ATransmissionOrError 'Agent) +(#:) :: Transport c => c -> (ByteString, ByteString, ByteString) -> IO (AEntityTransmissionOrError 'Agent 'AEConn) h #: t = tPutRaw h t >> (<#:) h -- | action and expected response -- `h #:t #> r` is the test that sends `t` to `h` and validates that the response is `r` -(#>) :: IO (ATransmissionOrError 'Agent) -> ATransmission 'Agent -> Expectation +(#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> AEntityTransmission 'Agent 'AEConn -> Expectation action #> (corrId, connId, cmd) = action `shouldReturn` (corrId, connId, Right cmd) -- | action and predicate for the response -- `h #:t =#> p` is the test that sends `t` to `h` and validates the response using `p` -(=#>) :: IO (ATransmissionOrError 'Agent) -> (ATransmission 'Agent -> Bool) -> Expectation +(=#>) :: IO (AEntityTransmissionOrError 'Agent 'AEConn) -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation action =#> p = action >>= (`shouldSatisfy` p . correctTransmission) -correctTransmission :: ATransmissionOrError a -> ATransmission a +correctTransmission :: (ACorrId, ConnId, Either AgentErrorType cmd) -> (ACorrId, ConnId, cmd) correctTransmission (corrId, connId, cmdOrErr) = case cmdOrErr of Right cmd -> (corrId, connId, cmd) Left e -> error $ show e -- | receive message to handle `h` and validate that it is the expected one -(<#) :: Transport c => c -> ATransmission 'Agent -> Expectation +(<#) :: Transport c => c -> AEntityTransmission 'Agent 'AEConn -> Expectation h <# (corrId, connId, cmd) = (h <#:) `shouldReturn` (corrId, connId, Right cmd) +(<#.) :: Transport c => c -> AEntityTransmission 'Agent 'AENone -> Expectation +h <#. (corrId, connId, cmd) = (h <#:.) `shouldReturn` (corrId, connId, Right cmd) + -- | receive message to handle `h` and validate it using predicate `p` -(<#=) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation +(<#=) :: Transport c => c -> (AEntityTransmission 'Agent 'AEConn -> Bool) -> Expectation h <#= p = (h <#:) >>= (`shouldSatisfy` p . correctTransmission) +(<#=?) :: Transport c => c -> (ATransmission 'Agent -> Bool) -> Expectation +h <#=? p = (h <#:?) >>= (`shouldSatisfy` p . correctTransmission) + -- | test that nothing is delivered to handle `h` during 10ms (#:#) :: Transport c => c -> String -> Expectation h #:# err = tryGet `shouldReturn` () @@ -129,7 +159,7 @@ h #:# err = tryGet `shouldReturn` () Just _ -> error err _ -> return () -pattern Msg :: MsgBody -> ACommand 'Agent +pattern Msg :: MsgBody -> ACommand 'Agent e pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody testDuplexConnection :: Transport c => TProxy c -> c -> c -> IO () @@ -288,7 +318,7 @@ testSubscrNotification t (server, _) client = do client #: ("1", "conn1", "NEW T INV") =#> \case ("1", "conn1", INV {}) -> True; _ -> False client #:# "nothing should be delivered to client before the server is killed" killThread server - client <# ("", "", DOWN testSMPServer ["conn1"]) + client <#. ("", "", DOWN testSMPServer ["conn1"]) withSmpServer (ATransport t) $ client <# ("", "conn1", ERR (SMP AUTH)) -- this new server does not have the queue @@ -302,15 +332,15 @@ testMsgDeliveryServerRestart t alice bob = do alice #: ("11", "bob", "ACK 4") #> ("11", "bob", OK) alice #:# "nothing else delivered before the server is killed" - let server = (SMPServer "localhost" testPort2 testKeyHash) - alice <# ("", "", DOWN server ["bob"]) + let server = SMPServer "localhost" testPort2 testKeyHash + alice <#. ("", "", DOWN server ["bob"]) bob #: ("2", "alice", "SEND F 11\nhello again") #> ("2", "alice", MID 5) bob #:# "nothing else delivered before the server is restarted" alice #:# "nothing else delivered before the server is restarted" withServer $ do bob <# ("", "alice", SENT 5) - alice <# ("", "", UP server ["bob"]) + alice <#. ("", "", UP server ["bob"]) alice <#= \case ("", "bob", Msg "hello again") -> True; _ -> False alice #: ("12", "bob", "ACK 5") #> ("12", "bob", OK) @@ -325,8 +355,8 @@ testServerConnectionAfterError t _ = do withServer $ do connect (bob, "bob") (alice, "alice") - bob <# ("", "", DOWN server ["alice"]) - alice <# ("", "", DOWN server ["bob"]) + bob <#. ("", "", DOWN server ["alice"]) + alice <#. ("", "", DOWN server ["bob"]) alice #: ("1", "bob", "SEND F 5\nhello") #> ("1", "bob", MID 4) alice #:# "nothing else delivered before the server is restarted" bob #:# "nothing else delivered before the server is restarted" @@ -336,10 +366,10 @@ testServerConnectionAfterError t _ = do bob #: ("1", "alice", "SUB") =#> \("1", "alice", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT alice #: ("1", "bob", "SUB") =#> \("1", "bob", ERR (BROKER _ e)) -> e == NETWORK || e == TIMEOUT withServer $ do - alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False - alice <#= \case ("", "bob", SENT 4) -> True; ("", "", UP s ["bob"]) -> s == server; _ -> False - bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False - bob <#= \case ("", "alice", Msg "hello") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False + alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False + alice <#=? \case ("", "bob", APC _ (SENT 4)) -> True; ("", "", APC _ (UP s ["bob"])) -> s == server; _ -> False + bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False + bob <#=? \case ("", "alice", APC _ (Msg "hello")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False bob #: ("2", "alice", "ACK 4") #> ("2", "alice", OK) alice #: ("1", "bob", "SEND F 11\nhello again") #> ("1", "bob", MID 5) alice <# ("", "bob", SENT 5) @@ -368,7 +398,7 @@ testMsgDeliveryAgentRestart t bob = do bob #: ("11", "alice", "ACK 4") #> ("11", "alice", OK) bob #:# "nothing else delivered before the server is down" - bob <# ("", "", DOWN server ["alice"]) + bob <#. ("", "", DOWN server ["alice"]) alice #: ("2", "bob", "SEND F 11\nhello again") #> ("2", "bob", MID 5) alice #:# "nothing else delivered before the server is restarted" bob #:# "nothing else delivered before the server is restarted" @@ -381,8 +411,8 @@ testMsgDeliveryAgentRestart t bob = do (corrId == "3" && cmd == OK) || (corrId == "" && cmd == SENT 5) _ -> False - bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False - bob <#= \case ("", "alice", Msg "hello again") -> True; ("", "", UP s ["alice"]) -> s == server; _ -> False + bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False + bob <#=? \case ("", "alice", APC _ (Msg "hello again")) -> True; ("", "", APC _ (UP s ["alice"])) -> s == server; _ -> False bob #: ("12", "alice", "ACK 5") #> ("12", "alice", OK) removeFile testStoreLogFile @@ -499,10 +529,8 @@ syntaxTests t = do it "unknown command" $ ("1", "5678", "HELLO") >#> ("1", "5678", "ERR CMD SYNTAX") describe "NEW" $ do describe "valid" $ do - -- TODO: add tests with defined connection id it "with correct parameter" $ ("211", "", "NEW T INV") >#>= \case ("211", _, "INV" : _) -> True; _ -> False describe "invalid" $ do - -- TODO: add tests with defined connection id it "with incorrect parameter" $ ("222", "", "NEW T hi") >#> ("222", "", "ERR CMD SYNTAX") describe "JOIN" $ do diff --git a/tests/AgentTests/FunctionalAPITests.hs b/tests/AgentTests/FunctionalAPITests.hs index 34204d0ec..8ef94eced 100644 --- a/tests/AgentTests/FunctionalAPITests.hs +++ b/tests/AgentTests/FunctionalAPITests.hs @@ -8,6 +8,7 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module AgentTests.FunctionalAPITests @@ -19,6 +20,10 @@ module AgentTests.FunctionalAPITests runRight, runRight_, get, + get', + rfGet, + sfGet, + nGet, (##>), (=##>), pattern Msg, @@ -38,13 +43,13 @@ import qualified Data.Map as M import Data.Maybe (isNothing) import qualified Data.Set as S import Data.Time.Clock.System (SystemTime (..), getSystemTime) +import Data.Type.Equality import SMPAgentClient import SMPClient (cfg, testPort, testPort2, testStoreLogFile2, withSmpServer, withSmpServerConfigOn, withSmpServerOn, withSmpServerStoreLogOn, withSmpServerStoreMsgLogOn) import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Client (SMPTestFailure (..), SMPTestStep (..)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), InitialAgentServers (..)) import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Agent.Store (UserId) import Simplex.Messaging.Client (NetworkConfig (..), ProtocolClientConfig (..), TransportSessionMode (TSMEntity, TSMUser), defaultClientConfig) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String @@ -58,21 +63,42 @@ import Simplex.Messaging.Version import Test.Hspec import UnliftIO -(##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> ATransmission 'Agent -> m () +type AEntityTransmission e = (ACorrId, ConnId, ACommand 'Agent e) + +(##>) :: (HasCallStack, MonadIO m) => m (AEntityTransmission e) -> AEntityTransmission e -> m () a ##> t = a >>= \t' -> liftIO (t' `shouldBe` t) -(=##>) :: (HasCallStack, MonadIO m) => m (ATransmission 'Agent) -> (ATransmission 'Agent -> Bool) -> m () +(=##>) :: (Show a, HasCallStack, MonadIO m) => m a -> (a -> Bool) -> m () a =##> p = a >>= \t -> liftIO (t `shouldSatisfy` p) -get :: MonadIO m => AgentClient -> m (ATransmission 'Agent) -get c = do - t@(_, _, cmd) <- atomically (readTBQueue $ subQ c) +get :: MonadIO m => AgentClient -> m (AEntityTransmission 'AEConn) +get = get' @'AEConn + +rfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AERcvFile) +rfGet = get' @'AERcvFile + +sfGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AESndFile) +sfGet = get' @'AESndFile + +nGet :: MonadIO m => AgentClient -> m (AEntityTransmission 'AENone) +nGet = get' @'AENone + +get' :: forall e m. (MonadIO m, AEntityI e) => AgentClient -> m (AEntityTransmission e) +get' c = do + (corrId, connId, APC e cmd) <- pGet c + case testEquality e (sAEntity @e) of + Just Refl -> pure (corrId, connId, cmd) + _ -> error $ "unexpected command " <> show cmd + +pGet :: forall m. MonadIO m => AgentClient -> m (ATransmission 'Agent) +pGet c = do + t@(_, _, APC _ cmd) <- atomically (readTBQueue $ subQ c) case cmd of - CONNECT {} -> get c - DISCONNECT {} -> get c + CONNECT {} -> pGet c + DISCONNECT {} -> pGet c _ -> pure t -pattern Msg :: MsgBody -> ACommand 'Agent +pattern Msg :: MsgBody -> ACommand 'Agent e pattern Msg msgBody <- MSG MsgMeta {integrity = MsgOk} _ msgBody smpCfgV1 :: ProtocolClientConfig @@ -87,7 +113,7 @@ agentCfgRatchetV1 = agentCfg {e2eEncryptVRange = vr11} vr11 :: VersionRange vr11 = mkVersionRange 1 1 -runRight_ :: HasCallStack => ExceptT AgentErrorType IO () -> Expectation +runRight_ :: (Eq e, Show e, HasCallStack) => ExceptT e IO () -> Expectation runRight_ action = runExceptT action `shouldReturn` Right () runRight :: HasCallStack => ExceptT AgentErrorType IO a -> IO a @@ -387,12 +413,12 @@ testAsyncServerOffline t = do runRight $ createConnection alice 1 True SCMInvitation Nothing -- connection fails Left (BROKER _ NETWORK) <- runExceptT $ joinConnection bob 1 True cReq "bob's connInfo" - ("", "", DOWN srv conns) <- get alice + ("", "", DOWN srv conns) <- nGet alice srv `shouldBe` testSMPServer conns `shouldBe` [bobId] -- connection succeeds after server start withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - ("", "", UP srv1 conns1) <- get alice + ("", "", UP srv1 conns1) <- nGet alice liftIO $ do srv1 `shouldBe` testSMPServer conns1 `shouldBe` [bobId] @@ -439,8 +465,8 @@ testDuplicateMessage t = do pure (aliceId, bobId, bob1) - get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False - get bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False + nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False + nGet bob1 =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False -- commenting two lines below and uncommenting further two lines would also runRight_, -- it is the scenario tested above, when the message was not acknowledged by the user threadDelay 200000 @@ -484,7 +510,7 @@ testInactiveClientDisconnected t = do alice <- getSMPAgentClient agentCfg initAgentServers runRight_ $ do (connId, _cReq) <- createConnection alice 1 True SCMInvitation Nothing - get alice ##> ("", "", DOWN testSMPServer [connId]) + nGet alice ##> ("", "", DOWN testSMPServer [connId]) testActiveClientNotDisconnected :: ATransport -> IO () testActiveClientNotDisconnected t = do @@ -510,7 +536,7 @@ testActiveClientNotDisconnected t = do Nothing <- 800000 `timeout` get alice liftIO $ threadDelay 1200000 -- and after 2 sec of inactivity DOWN is sent - get alice ##> ("", "", DOWN testSMPServer [connId]) + nGet alice ##> ("", "", DOWN testSMPServer [connId]) milliseconds ts = systemSeconds ts * 1000 + fromIntegral (systemNanoseconds ts `div` 1000000) testSuspendingAgent :: IO () @@ -524,7 +550,7 @@ testSuspendingAgent = do get b =##> \case ("", c, Msg "hello") -> c == aId; _ -> False ackMessage b aId 4 suspendAgent b 1000000 - get b ##> ("", "", SUSPENDED) + get' b ##> ("", "", SUSPENDED) 5 <- sendMessage a bId SMP.noMsgFlags "hello 2" get a ##> ("", bId, SENT 5) Nothing <- 100000 `timeout` get b @@ -544,21 +570,21 @@ testSuspendingAgentCompleteSending t = do pure (aId, bId) runRight_ $ do - ("", "", DOWN {}) <- get a - ("", "", DOWN {}) <- get b + ("", "", DOWN {}) <- nGet a + ("", "", DOWN {}) <- nGet b 5 <- sendMessage b aId SMP.noMsgFlags "hello too" 6 <- sendMessage b aId SMP.noMsgFlags "how are you?" liftIO $ threadDelay 100000 suspendAgent b 5000000 - withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False - get b =##> \case ("", c, SENT 5) -> c == aId; ("", "", UP {}) -> True; _ -> False - get b =##> \case ("", c, SENT 6) -> c == aId; ("", "", UP {}) -> True; _ -> False - ("", "", SUSPENDED) <- get b + withSmpServerStoreLogOn t testPort $ \_ -> runRight_ @AgentErrorType $ do + pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, APC _ (SENT 5)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False + pGet b =##> \case ("", c, APC _ (SENT 6)) -> c == aId; ("", "", APC _ UP {}) -> True; _ -> False + ("", "", SUSPENDED) <- nGet b - get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False - get a =##> \case ("", c, Msg "hello too") -> c == bId; ("", "", UP {}) -> True; _ -> False + pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False + pGet a =##> \case ("", c, APC _ (Msg "hello too")) -> c == bId; ("", "", APC _ UP {}) -> True; _ -> False ackMessage a bId 5 get a =##> \case ("", c, Msg "how are you?") -> c == bId; _ -> False ackMessage a bId 6 @@ -576,12 +602,12 @@ testSuspendingAgentTimeout t = do pure (aId, bId) runRight_ $ do - ("", "", DOWN {}) <- get a - ("", "", DOWN {}) <- get b + ("", "", DOWN {}) <- nGet a + ("", "", DOWN {}) <- nGet b 5 <- sendMessage b aId SMP.noMsgFlags "hello too" 6 <- sendMessage b aId SMP.noMsgFlags "how are you?" suspendAgent b 100000 - ("", "", SUSPENDED) <- get b + ("", "", SUSPENDED) <- nGet b pure () testBatchedSubscriptions :: ATransport -> IO () @@ -596,15 +622,15 @@ testBatchedSubscriptions t = do delete b aIds' liftIO $ threadDelay 1000000 pure conns - ("", "", DOWN {}) <- get a - ("", "", DOWN {}) <- get a - ("", "", DOWN {}) <- get b - ("", "", DOWN {}) <- get b + ("", "", DOWN {}) <- nGet a + ("", "", DOWN {}) <- nGet a + ("", "", DOWN {}) <- nGet b + ("", "", DOWN {}) <- nGet b runServers $ do - ("", "", UP {}) <- get a - ("", "", UP {}) <- get a - ("", "", UP {}) <- get b - ("", "", UP {}) <- get b + ("", "", UP {}) <- nGet a + ("", "", UP {}) <- nGet a + ("", "", UP {}) <- nGet b + ("", "", UP {}) <- nGet b liftIO $ threadDelay 1000000 let (aIds, bIds) = unzip conns conns' = drop 10 conns @@ -777,7 +803,7 @@ testUsers = do deleteUser a auId True get a =##> \case ("", c, DEL_RCVQ _ _ Nothing) -> c == bId'; _ -> False get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False - get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False + nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False exchangeGreetingsMsgId 6 a bId b aId liftIO $ noMessages a "nothing else should be delivered to alice" @@ -806,18 +832,18 @@ testUsersNoServer t = do (aId', bId') <- makeConnectionForUsers a auId b 1 exchangeGreetingsMsgId 4 a bId' b aId' pure (aId, bId, auId, aId', bId') - get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False - get a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False - get b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False + nGet a =##> \case ("", "", DOWN _ [c]) -> c == bId || c == bId'; _ -> False + nGet b =##> \case ("", "", DOWN _ cs) -> length cs == 2; _ -> False runRight_ $ do deleteUser a auId True get a =##> \case ("", c, DEL_RCVQ _ _ (Just (BROKER _ e))) -> c == bId' && (e == TIMEOUT || e == NETWORK); _ -> False get a =##> \case ("", c, DEL_CONN) -> c == bId'; _ -> False - get a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False + nGet a =##> \case ("", "", DEL_USER u) -> u == auId; _ -> False liftIO $ noMessages a "nothing else should be delivered to alice" withSmpServerStoreLogOn t testPort $ \_ -> runRight_ $ do - get a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False - get b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False + nGet a =##> \case ("", "", UP _ [c]) -> c == bId; _ -> False + nGet b =##> \case ("", "", UP _ cs) -> length cs == 2; _ -> False exchangeGreetingsMsgId 6 a bId b aId testSwitchConnection :: InitialAgentServers -> IO () @@ -961,8 +987,8 @@ testTwoUsers = do b `hasClients` 1 setNetworkConfig a nc {sessionMode = TSMEntity} liftIO $ threadDelay 250000 - ("", "", DOWN _ _) <- get a - ("", "", UP _ _) <- get a + ("", "", DOWN _ _) <- nGet a + ("", "", UP _ _) <- nGet a a `hasClients` 2 exchangeGreetingsMsgId 6 a bId1 b aId1 @@ -970,10 +996,10 @@ testTwoUsers = do liftIO $ threadDelay 250000 setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 - ("", "", DOWN _ _) <- get a - ("", "", DOWN _ _) <- get a - ("", "", UP _ _) <- get a - ("", "", UP _ _) <- get a + ("", "", DOWN _ _) <- nGet a + ("", "", DOWN _ _) <- nGet a + ("", "", UP _ _) <- nGet a + ("", "", UP _ _) <- nGet a a `hasClients` 1 aUserId2 <- createUser a [noAuthSrv testSMPServer] @@ -985,10 +1011,10 @@ testTwoUsers = do b `hasClients` 1 setNetworkConfig a nc {sessionMode = TSMEntity} liftIO $ threadDelay 250000 - ("", "", DOWN _ _) <- get a - ("", "", DOWN _ _) <- get a - ("", "", UP _ _) <- get a - ("", "", UP _ _) <- get a + ("", "", DOWN _ _) <- nGet a + ("", "", DOWN _ _) <- nGet a + ("", "", UP _ _) <- nGet a + ("", "", UP _ _) <- nGet a a `hasClients` 4 exchangeGreetingsMsgId 8 a bId1 b aId1 exchangeGreetingsMsgId 8 a bId1' b aId1' @@ -997,14 +1023,14 @@ testTwoUsers = do liftIO $ threadDelay 250000 setNetworkConfig a nc {sessionMode = TSMUser} liftIO $ threadDelay 250000 - ("", "", DOWN _ _) <- get a - ("", "", DOWN _ _) <- get a - ("", "", DOWN _ _) <- get a - ("", "", DOWN _ _) <- get a - ("", "", UP _ _) <- get a - ("", "", UP _ _) <- get a - ("", "", UP _ _) <- get a - ("", "", UP _ _) <- get a + ("", "", DOWN _ _) <- nGet a + ("", "", DOWN _ _) <- nGet a + ("", "", DOWN _ _) <- nGet a + ("", "", DOWN _ _) <- nGet a + ("", "", UP _ _) <- nGet a + ("", "", UP _ _) <- nGet a + ("", "", UP _ _) <- nGet a + ("", "", UP _ _) <- nGet a a `hasClients` 2 exchangeGreetingsMsgId 10 a bId1 b aId1 exchangeGreetingsMsgId 10 a bId1' b aId1' diff --git a/tests/AgentTests/NotificationTests.hs b/tests/AgentTests/NotificationTests.hs index 6f4fbb65d..490873b9e 100644 --- a/tests/AgentTests/NotificationTests.hs +++ b/tests/AgentTests/NotificationTests.hs @@ -3,12 +3,13 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module AgentTests.NotificationTests where -- import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) -import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg) +import AgentTests.FunctionalAPITests (exchangeGreetingsMsgId, get, makeConnection, nGet, runRight, runRight_, switchComplete, testServerMatrix2, (##>), (=##>), pattern Msg) import Control.Concurrent (killThread, threadDelay) import Control.Monad.Except import qualified Data.Aeson as J @@ -464,13 +465,13 @@ testNotificationsSMPRestart t APNSMockServer {apnsQ} = do liftIO $ killThread threadId pure (aliceId, bobId) - runRight_ $ do - get alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False - get bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False + runRight_ @AgentErrorType $ do + nGet alice =##> \case ("", "", DOWN _ [c]) -> c == bobId; _ -> False + nGet bob =##> \case ("", "", DOWN _ [c]) -> c == aliceId; _ -> False withSmpServerStoreLogOn t testPort $ \threadId -> runRight_ $ do - get alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False - get bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False + nGet alice =##> \case ("", "", UP _ [c]) -> c == bobId; _ -> False + nGet bob =##> \case ("", "", UP _ [c]) -> c == aliceId; _ -> False liftIO $ threadDelay 1000000 5 <- sendMessage bob aliceId (SMP.MsgFlags True) "hello again" get bob ##> ("", aliceId, SENT 5) diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index a43196148..6c3d6c80b 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/tests/AgentTests/SQLiteTests.hs @@ -62,7 +62,6 @@ removeStore db = do close :: SQLiteStore -> IO () close st = mapM_ DB.close =<< atomically (tryTakeTMVar $ dbConnection st) --- TODO add null port tests storeTests :: Spec storeTests = do withStore2 $ do @@ -279,7 +278,6 @@ testDeleteRcvConn = `shouldReturn` Right (SomeConn SCRcv (RcvConnection cData1 rcvQueue1)) deleteConn db "conn1" `shouldReturn` () - -- TODO check queues are deleted as well getConn db "conn1" `shouldReturn` Left SEConnNotFound @@ -292,7 +290,6 @@ testDeleteSndConn = `shouldReturn` Right (SomeConn SCSnd (SndConnection cData1 sndQueue1)) deleteConn db "conn1" `shouldReturn` () - -- TODO check queues are deleted as well getConn db "conn1" `shouldReturn` Left SEConnNotFound @@ -306,7 +303,6 @@ testDeleteDuplexConn = `shouldReturn` Right (SomeConn SCDuplex (DuplexConnection cData1 [rcvQueue1] [sndQueue1])) deleteConn db "conn1" `shouldReturn` () - -- TODO check queues are deleted as well getConn db "conn1" `shouldReturn` Left SEConnNotFound diff --git a/tests/AgentTests/SchemaDump.hs b/tests/AgentTests/SchemaDump.hs index 43c67a332..54ceb48ad 100644 --- a/tests/AgentTests/SchemaDump.hs +++ b/tests/AgentTests/SchemaDump.hs @@ -2,6 +2,7 @@ module AgentTests.SchemaDump where +import Control.DeepSeq import Control.Monad (void) import Simplex.Messaging.Agent.Store.SQLite import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations @@ -23,7 +24,7 @@ testVerifySchemaDump = do void $ createSQLiteStore testDB "" Migrations.app False void $ readCreateProcess (shell $ "touch " <> schema) "" savedSchema <- readFile schema - savedSchema `seq` pure () + savedSchema `deepseq` pure () void $ readCreateProcess (shell $ "sqlite3 " <> testDB <> " '.schema --indent' > " <> schema) "" currentSchema <- readFile schema savedSchema `shouldBe` currentSchema diff --git a/tests/CLITests.hs b/tests/CLITests.hs index e18cf1963..40915515b 100644 --- a/tests/CLITests.hs +++ b/tests/CLITests.hs @@ -4,6 +4,7 @@ module CLITests where import Data.Ini (lookupValue, readIniFile) import Data.List (isPrefixOf) +import Simplex.FileTransfer.Server.Main (xftpServerCLI, xftpServerVersion) import Simplex.Messaging.Notifications.Server.Main import Simplex.Messaging.Server.Main import Simplex.Messaging.Transport (simplexMQVersion) @@ -27,6 +28,12 @@ ntfCfgPath = "tests/tmp/cli/etc/opt/simplex-notifications" ntfLogPath :: FilePath ntfLogPath = "tests/tmp/cli/etc/var/simplex-notifications" +fileCfgPath :: FilePath +fileCfgPath = "tests/tmp/cli/etc/opt/simplex-files" + +fileLogPath :: FilePath +fileLogPath = "tests/tmp/cli/etc/var/simplex-files" + cliTests :: Spec cliTests = do describe "SMP server CLI" $ do @@ -38,6 +45,9 @@ cliTests = do describe "Ntf server CLI" $ do it "should initialize, start and delete the server (no store log)" $ ntfServerTest False it "should initialize, start and delete the server (with store log)" $ ntfServerTest True + describe "XFTP server CLI" $ do + it "should initialize, start and delete the server (no store log)" $ xftpServerTest False + it "should initialize, start and delete the server (with store log)" $ xftpServerTest True smpServerTest :: Bool -> Bool -> IO () smpServerTest storeLog basicAuth = do @@ -78,3 +88,20 @@ ntfServerTest storeLog = do capture_ (withStdin "Y" . withArgs ["delete"] $ ntfServerCLI ntfCfgPath ntfLogPath) >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`)) doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False + +xftpServerTest :: Bool -> IO () +xftpServerTest storeLog = do + capture_ (withArgs (["init", "-p", "tests/tmp", "-q", "10gb"] <> ["-l" | storeLog]) $ xftpServerCLI fileCfgPath fileLogPath) + >>= (`shouldSatisfy` (("Server initialized, you can modify configuration in " <> fileCfgPath <> "/file-server.ini") `isPrefixOf`)) + Right ini <- readIniFile $ fileCfgPath <> "/file-server.ini" + lookupValue "STORE_LOG" "enable" ini `shouldBe` Right (if storeLog then "on" else "off") + lookupValue "STORE_LOG" "log_stats" ini `shouldBe` Right "off" + lookupValue "TRANSPORT" "port" ini `shouldBe` Right "443" + doesFileExist (fileCfgPath <> "/ca.key") `shouldReturn` True + r <- lines <$> capture_ (withArgs ["start"] $ (100000 `timeout` xftpServerCLI fileCfgPath fileLogPath) `catchAll_` pure (Just ())) + r `shouldContain` ["SimpleX XFTP server v" <> xftpServerVersion] + r `shouldContain` (if storeLog then ["Store log: " <> fileLogPath <> "/file-server-store.log"] else ["Store log disabled."]) + r `shouldContain` ["Listening on port 443..."] + capture_ (withStdin "Y" . withArgs ["delete"] $ xftpServerCLI fileCfgPath fileLogPath) + >>= (`shouldSatisfy` ("WARNING: deleting the server will make all queues inaccessible" `isPrefixOf`)) + doesFileExist (cfgPath <> "/ca.key") `shouldReturn` False diff --git a/tests/CoreTests/CryptoTests.hs b/tests/CoreTests/CryptoTests.hs index d9c6a8fae..4ff670ba5 100644 --- a/tests/CoreTests/CryptoTests.hs +++ b/tests/CoreTests/CryptoTests.hs @@ -78,6 +78,8 @@ cryptoTests = do describe "lazy secretbox" $ do testLazySecretBox testLazySecretBoxFile + testLazySecretBoxTailTag + testLazySecretBoxFileTailTag describe "AES GCM" $ do testAESGCM describe "X509 key encoding" $ do @@ -152,6 +154,33 @@ testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random s Right s'' <- LC.sbDecrypt k nonce <$> LB.readFile (f <> ".encrypted") s'' `shouldBe` s +testLazySecretBoxTailTag :: Spec +testLazySecretBoxTailTag = it "should lazily encrypt / decrypt string with a random symmetric key (tail tag)" . ioProperty $ do + k <- C.randomSbKey + nonce <- C.randomCbNonce + pure $ \(s, pad) -> + let b = LE.encodeUtf8 $ LT.pack s + len = LB.length b + pad' = min (abs pad) 100000 + paddedLen = len + pad' + 8 + cipher = LC.sbEncryptTailTag k nonce b len paddedLen + plain = LC.sbDecryptTailTag k nonce paddedLen =<< cipher + in isRight cipher && cipher /= (snd <$> plain) && Right (True, b) == plain + +testLazySecretBoxFileTailTag :: Spec +testLazySecretBoxFileTailTag = it "should lazily encrypt / decrypt file with a random symmetric key (tail tag)" $ do + k <- C.randomSbKey + nonce <- C.randomCbNonce + let f = "tests/tmp/testsecretbox" + paddedLen = 4 * 1024 * 1024 + len = 4 * 1000 * 1000 :: Int64 + s = LC.fastReplicate len 'a' + Right s' <- pure $ LC.sbEncryptTailTag k nonce s len paddedLen + LB.writeFile (f <> ".encrypted") s' + Right (auth, s'') <- LC.sbDecryptTailTag k nonce paddedLen <$> LB.readFile (f <> ".encrypted") + s'' `shouldBe` s + auth `shouldBe` True + testAESGCM :: Spec testAESGCM = it "should encrypt / decrypt string with a random symmetric key" $ do k <- C.randomAesKey diff --git a/tests/FileDescriptionTests.hs b/tests/FileDescriptionTests.hs new file mode 100644 index 000000000..676882bcd --- /dev/null +++ b/tests/FileDescriptionTests.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module FileDescriptionTests where + +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) +import Test.Hspec + +fileDescriptionTests :: Spec +fileDescriptionTests = + describe "file description parsing / serializing" $ do + it "parse YAML file description" testParseYAMLFileDescription + it "serialize YAML file description" testSerializeYAMLFileDescription + it "parse file description" testParseFileDescription + it "serialize file description" testSerializeFileDescription + +fileDescPath :: FilePath +fileDescPath = "tests/fixtures/file_description.yaml" + +tmpFileDescPath :: FilePath +tmpFileDescPath = "tests/tmp/file_description.yaml" + +testSbKey :: C.SbKey +testSbKey = either error id $ strDecode "00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY=" + +testCbNonce :: C.CbNonce +testCbNonce = either error id $ strDecode "dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu" + +fileDesc :: FileDescription 'FRecipient +fileDesc = + FileDescription + { party = SFRecipient, + size = FileSize $ mb 26, + digest = FileDigest "abc", + key = testSbKey, + nonce = testCbNonce, + chunkSize = defaultChunkSize, + chunks = + [ FileChunk + { chunkNo = 1, + digest = chunkDigest, + chunkSize = defaultChunkSize, + replicas = + [ FileChunkReplica {server = "xftp://abc=@example1.com", replicaId, replicaKey}, + FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey} + ] + }, + FileChunk + { chunkNo = 2, + digest = chunkDigest, + chunkSize = defaultChunkSize, + replicas = + [ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey}, + FileChunkReplica {server = "xftp://abc=@example4.com", replicaId, replicaKey} + ] + }, + FileChunk + { chunkNo = 3, + digest = chunkDigest, + chunkSize = defaultChunkSize, + replicas = + [ FileChunkReplica {server = "xftp://abc=@example1.com", replicaId, replicaKey}, + FileChunkReplica {server = "xftp://abc=@example4.com", replicaId, replicaKey} + ] + }, + FileChunk + { chunkNo = 4, + digest = chunkDigest, + chunkSize = FileSize $ mb 2, + replicas = + [ FileChunkReplica {server = "xftp://abc=@example2.com", replicaId, replicaKey}, + FileChunkReplica {server = "xftp://abc=@example3.com", replicaId, replicaKey} + ] + } + ] + } + where + defaultChunkSize = FileSize $ mb 8 + replicaId = ChunkReplicaId "abc" + replicaKey = C.APrivateSignKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" + chunkDigest = FileDigest "ghi" + +yamlFileDesc :: YAMLFileDescription +yamlFileDesc = + YAMLFileDescription + { party = FRecipient, + size = "26mb", + chunkSize = "8mb", + digest = FileDigest "abc", + key = testSbKey, + nonce = testCbNonce, + replicas = + [ YAMLServerReplicas + { server = "xftp://abc=@example1.com", + chunks = + [ "1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp", + "3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp" + ] + }, + YAMLServerReplicas + { server = "xftp://abc=@example2.com", + chunks = + [ "2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp", + "4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp:2mb" + ] + }, + YAMLServerReplicas + { server = "xftp://abc=@example3.com", + chunks = + [ "1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe", + "4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" + ] + }, + YAMLServerReplicas + { server = "xftp://abc=@example4.com", + chunks = + [ "2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe", + "3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe" + ] + } + ] + } + +testParseYAMLFileDescription :: IO () +testParseYAMLFileDescription = do + yfd <- Y.decodeFileThrow fileDescPath + yfd `shouldBe` yamlFileDesc + +testSerializeYAMLFileDescription :: IO () +testSerializeYAMLFileDescription = withRemoveTmpFile $ do + Y.encodeFile tmpFileDescPath yamlFileDesc + fdSer <- B.readFile tmpFileDescPath + fdExp <- B.readFile fileDescPath + fdSer `shouldBe` fdExp + +testParseFileDescription :: IO () +testParseFileDescription = do + r <- strDecode <$> B.readFile fileDescPath + case r of + Left e -> expectationFailure $ show e + Right fd -> fd `shouldBe` fileDesc + +testSerializeFileDescription :: IO () +testSerializeFileDescription = withRemoveTmpFile $ do + B.writeFile tmpFileDescPath $ strEncode fileDesc + fdSer <- B.readFile tmpFileDescPath + fdExp <- B.readFile fileDescPath + fdSer `shouldBe` fdExp + +withRemoveTmpFile :: IO () -> IO () +withRemoveTmpFile = + bracket_ + (pure ()) + (removeFile tmpFileDescPath) diff --git a/tests/NtfClient.hs b/tests/NtfClient.hs index d3c10c80e..f0a9a1d47 100644 --- a/tests/NtfClient.hs +++ b/tests/NtfClient.hs @@ -30,6 +30,7 @@ import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as N import qualified Network.HTTP2.Server as H import Network.Socket +import SMPClient (serverBracket) import Simplex.Messaging.Client (chooseTransportHost, defaultNetworkConfig) import Simplex.Messaging.Client.Agent (defaultSMPClientAgentConfig) import qualified Simplex.Messaging.Crypto as C @@ -48,7 +49,6 @@ import UnliftIO.Async import UnliftIO.Concurrent import qualified UnliftIO.Exception as E import UnliftIO.STM -import UnliftIO.Timeout (timeout) testHost :: NonEmpty TransportHost testHost = "localhost" @@ -115,19 +115,6 @@ withNtfServerCfg t cfg = (\started -> runNtfServerBlocking started cfg {transports = [(ntfTestPort, t)]}) (pure ()) -serverBracket :: MonadUnliftIO m => (TMVar Bool -> m ()) -> m () -> (ThreadId -> m a) -> m a -serverBracket process afterProcess f = do - started <- newEmptyTMVarIO - E.bracket - (forkIOWithUnmask ($ process started)) - (\t -> killThread t >> afterProcess >> waitFor started "stop") - (\t -> waitFor started "start" >> f t) - where - waitFor started s = - 5_000_000 `timeout` atomically (takeTMVar started) >>= \case - Nothing -> error $ "server did not " <> s - _ -> pure () - withNtfServerOn :: ATransport -> ServiceName -> IO a -> IO a withNtfServerOn t port' = withNtfServerThreadOn t port' . const diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index b21554891..bcb9d080a 100644 --- a/tests/SMPAgentClient.hs +++ b/tests/SMPAgentClient.hs @@ -29,14 +29,15 @@ import Simplex.Messaging.Agent.Env.SQLite import Simplex.Messaging.Agent.Protocol import Simplex.Messaging.Agent.RetryInterval import Simplex.Messaging.Agent.Server (runSMPAgentBlocking) -import Simplex.Messaging.Agent.Store (UserId) import Simplex.Messaging.Client (ProtocolClientConfig (..), chooseTransportHost, defaultClientConfig, defaultNetworkConfig) import Simplex.Messaging.Parsers (parseAll) +import Simplex.Messaging.Protocol (ProtoServerWithAuth) import Simplex.Messaging.Transport import Simplex.Messaging.Transport.Client import Test.Hspec import UnliftIO.Concurrent import UnliftIO.Directory +import XFTPClient (testXFTPServer) agentTestHost :: NonEmpty TransportHost agentTestHost = "localhost" @@ -65,8 +66,8 @@ smpAgentTest _ cmd = runSmpAgentTest $ \(h :: c) -> tPutRaw h cmd >> get h get h = do t@(_, _, cmdStr) <- tGetRaw h case parseAll networkCommandP cmdStr of - Right (ACmd SAgent CONNECT {}) -> get h - Right (ACmd SAgent DISCONNECT {}) -> get h + Right (ACmd SAgent _ CONNECT {}) -> get h + Right (ACmd SAgent _ DISCONNECT {}) -> get h _ -> pure t runSmpAgentTest :: forall c a. Transport c => (c -> IO a) -> IO a @@ -178,6 +179,7 @@ initAgentServers = InitialAgentServers { smp = userServers [noAuthSrv testSMPServer], ntf = ["ntf://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:6001"], + xftp = userServers [noAuthSrv testXFTPServer], netCfg = defaultNetworkConfig {tcpTimeout = 500_000, tcpConnectTimeout = 500_000} } @@ -208,7 +210,7 @@ withSmpAgentThreadOn_ t (port', smpPort', db') afterProcess = (\started -> runSMPAgentBlocking t started cfg' initServers') afterProcess -userServers :: NonEmpty SMPServerWithAuth -> Map UserId (NonEmpty SMPServerWithAuth) +userServers :: NonEmpty (ProtoServerWithAuth p) -> Map UserId (NonEmpty (ProtoServerWithAuth p)) userServers srvs = M.fromList [(1, srvs)] withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => ATransport -> (ServiceName, ServiceName, AgentDatabase) -> (ThreadId -> m a) -> m a diff --git a/tests/Test.hs b/tests/Test.hs index 287d5b50b..d76357be4 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -8,6 +8,7 @@ import CoreTests.EncodingTests import CoreTests.ProtocolErrorTests import CoreTests.RetryIntervalTests import CoreTests.VersionRangeTests +import FileDescriptionTests (fileDescriptionTests) import NtfServerTests (ntfServerTests) import ServerTests import Simplex.Messaging.Transport (TLS, Transport (..)) @@ -15,6 +16,9 @@ import Simplex.Messaging.Transport.WebSockets (WS) import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive) import System.Environment (setEnv) import Test.Hspec +import XFTPAgent +import XFTPCLI +import XFTPServerTests (xftpServerTests) logCfg :: LogConfig logCfg = LogConfig {lc_file = Nothing, lc_stderr = True} @@ -39,4 +43,9 @@ main = do describe "SMP server via WebSockets" $ serverTests (transport @WS) describe "Notifications server" $ ntfServerTests (transport @TLS) describe "SMP client agent" $ agentTests (transport @TLS) + describe "XFTP" $ do + describe "XFTP server" xftpServerTests + describe "XFTP file description" fileDescriptionTests + describe "XFTP CLI" xftpCLITests + describe "XFTP agent" xftpAgentTests describe "Server CLIs" cliTests diff --git a/tests/XFTPAgent.hs b/tests/XFTPAgent.hs new file mode 100644 index 000000000..ba87160da --- /dev/null +++ b/tests/XFTPAgent.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module XFTPAgent where + +import AgentTests.FunctionalAPITests (get, rfGet, runRight, runRight_, sfGet) +import Control.Logger.Simple +import Control.Monad.Except +import Data.Bifunctor (first) +import qualified Data.ByteString.Char8 as B +import SMPAgentClient (agentCfg, initAgentServers) +import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Protocol (FileParty (..)) +import Simplex.Messaging.Agent (disconnectAgentClient, getSMPAgentClient, xftpDeleteRcvFile, xftpReceiveFile, xftpSendFile) +import Simplex.Messaging.Agent.Protocol (ACommand (..), AgentErrorType (..)) +import Simplex.Messaging.Encoding.String (StrEncoding (..)) +import System.Directory (doesDirectoryExist, getFileSize, listDirectory) +import System.FilePath (()) +import System.Timeout (timeout) +import Test.Hspec +import XFTPCLI +import XFTPClient + +xftpAgentTests :: Spec +xftpAgentTests = around_ testBracket . describe "Functional API" $ do + it "should receive file" testXFTPAgentReceive + it "should resume receiving file after restart" testXFTPAgentReceiveRestore + it "should cleanup tmp path after permanent error" testXFTPAgentReceiveCleanup + it "should send file using experimental api" testXFTPAgentSendExperimental + +testXFTPAgentReceive :: IO () +testXFTPAgentReceive = withXFTPServer $ do + -- send file using CLI + let filePath = senderFiles "testfile" + xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] + file <- B.readFile filePath + getFileSize filePath `shouldReturn` mb 17 + let fdRcv = filePath <> ".xftp" "rcv1.xftp" + fdSnd = filePath <> ".xftp" "snd.xftp.private" + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-s", testXFTPServerStr, "--tmp=tests/tmp"] + progress `shouldSatisfy` uploadProgress + sendResult + `shouldBe` [ "Sender file description: " <> fdSnd, + "Pass file descriptions to the recipient(s):", + fdRcv + ] + -- receive file using agent + rcp <- getSMPAgentClient agentCfg initAgentServers + runRight_ $ do + fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv + fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) + ("", fId', RFDONE path) <- rfGet rcp + liftIO $ do + fId' `shouldBe` fId + B.readFile path `shouldReturn` file + + -- delete file + xftpDeleteRcvFile rcp 1 fId + +getFileDescription :: FilePath -> ExceptT AgentErrorType IO (ValidFileDescription 'FRecipient) +getFileDescription path = + ExceptT $ first (INTERNAL . ("Failed to parse file description: " <>)) . strDecode <$> B.readFile path + +logCfgNoLogs :: LogConfig +logCfgNoLogs = LogConfig {lc_file = Nothing, lc_stderr = False} + +testXFTPAgentReceiveRestore :: IO () +testXFTPAgentReceiveRestore = withGlobalLogging logCfgNoLogs $ do + let filePath = senderFiles "testfile" + fdRcv = filePath <> ".xftp" "rcv1.xftp" + fdSnd = filePath <> ".xftp" "snd.xftp.private" + + withXFTPServerStoreLogOn $ \_ -> do + -- send file using CLI + xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] + getFileSize filePath `shouldReturn` mb 17 + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-s", testXFTPServerStr, "--tmp=tests/tmp"] + progress `shouldSatisfy` uploadProgress + sendResult + `shouldBe` [ "Sender file description: " <> fdSnd, + "Pass file descriptions to the recipient(s):", + fdRcv + ] + + -- receive file using agent - should not succeed due to server being down + rcp <- getSMPAgentClient agentCfg initAgentServers + fId <- runRight $ do + fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv + fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) + liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt + pure fId + disconnectAgentClient rcp + + [prefixDir] <- listDirectory recipientFiles + let tmpPath = recipientFiles prefixDir "xftp.encrypted" + doesDirectoryExist tmpPath `shouldReturn` True + + rcp' <- getSMPAgentClient agentCfg initAgentServers + withXFTPServerStoreLogOn $ \_ -> do + -- receive file using agent - should succeed with server up + ("", fId', RFDONE path) <- rfGet rcp' + liftIO $ do + fId' `shouldBe` fId + file <- B.readFile filePath + B.readFile path `shouldReturn` file + + -- tmp path should be removed after receiving file + doesDirectoryExist tmpPath `shouldReturn` False + +testXFTPAgentReceiveCleanup :: IO () +testXFTPAgentReceiveCleanup = withGlobalLogging logCfgNoLogs $ do + let filePath = senderFiles "testfile" + fdRcv = filePath <> ".xftp" "rcv1.xftp" + fdSnd = filePath <> ".xftp" "snd.xftp.private" + + withXFTPServerStoreLogOn $ \_ -> do + -- send file using CLI + xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] + getFileSize filePath `shouldReturn` mb 17 + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-s", testXFTPServerStr, "--tmp=tests/tmp"] + progress `shouldSatisfy` uploadProgress + sendResult + `shouldBe` [ "Sender file description: " <> fdSnd, + "Pass file descriptions to the recipient(s):", + fdRcv + ] + + -- receive file using agent - should not succeed due to server being down + rcp <- getSMPAgentClient agentCfg initAgentServers + fId <- runRight $ do + fd :: ValidFileDescription 'FRecipient <- getFileDescription fdRcv + fId <- xftpReceiveFile rcp 1 fd (Just recipientFiles) + liftIO $ timeout 300000 (get rcp) `shouldReturn` Nothing -- wait for worker attempt + pure fId + disconnectAgentClient rcp + + [prefixDir] <- listDirectory recipientFiles + let tmpPath = recipientFiles prefixDir "xftp.encrypted" + doesDirectoryExist tmpPath `shouldReturn` True + + -- receive file using agent - should fail with AUTH error + rcp' <- getSMPAgentClient agentCfg initAgentServers + withXFTPServerThreadOn $ \_ -> do + ("", fId', RFERR (INTERNAL "XFTP {xftpErr = AUTH}")) <- rfGet rcp' + fId' `shouldBe` fId + + -- tmp path should be removed after permanent error + doesDirectoryExist tmpPath `shouldReturn` False + +testXFTPAgentSendExperimental :: IO () +testXFTPAgentSendExperimental = withXFTPServer $ do + -- create random file using cli + let filePath = senderFiles "testfile" + xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] + file <- B.readFile filePath + getFileSize filePath `shouldReturn` mb 17 + + -- send file using experimental agent API + sndr <- getSMPAgentClient agentCfg initAgentServers + rfd <- runRight $ do + sfId <- xftpSendFile sndr 1 filePath 2 $ Just senderFiles + ("", sfId', SFDONE sndDescr rcvDescrs) <- sfGet sndr + liftIO $ do + sfId' `shouldBe` sfId + strDecode <$> B.readFile (senderFiles "testfile.descr/testfile.xftp/snd.xftp.private") `shouldReturn` Right sndDescr + Right rfd1 <- strDecode <$> B.readFile (senderFiles "testfile.descr/testfile.xftp/rcv1.xftp") + Right rfd2 <- strDecode <$> B.readFile (senderFiles "testfile.descr/testfile.xftp/rcv2.xftp") + rcvDescrs `shouldMatchList` [rfd1, rfd2] + pure rfd1 + + -- receive file using agent + rcp <- getSMPAgentClient agentCfg initAgentServers + runRight_ $ do + rfId <- xftpReceiveFile rcp 1 rfd (Just recipientFiles) + ("", rfId', RFDONE path) <- rfGet rcp + liftIO $ do + rfId' `shouldBe` rfId + B.readFile path `shouldReturn` file diff --git a/tests/XFTPCLI.hs b/tests/XFTPCLI.hs new file mode 100644 index 000000000..14c62aea5 --- /dev/null +++ b/tests/XFTPCLI.hs @@ -0,0 +1,169 @@ +module XFTPCLI where + +import Control.Exception (bracket_) +import qualified Data.ByteString as LB +import Data.List (isInfixOf, isPrefixOf, isSuffixOf) +import Simplex.FileTransfer.Client.Main (prepareChunkSizes, xftpClientCLI) +import Simplex.FileTransfer.Description (kb, mb) +import System.Directory (createDirectoryIfMissing, getFileSize, listDirectory, removeDirectoryRecursive) +import System.Environment (withArgs) +import System.FilePath (()) +import System.IO.Silently (capture_) +import Test.Hspec +import XFTPClient (testXFTPServerStr, testXFTPServerStr2, withXFTPServer, withXFTPServer2, xftpServerFiles, xftpServerFiles2) + +xftpCLITests :: Spec +xftpCLITests = around_ testBracket . describe "XFTP CLI" $ do + it "should send and receive file" testXFTPCLISendReceive + it "should send and receive file with 2 servers" testXFTPCLISendReceive2servers + it "should delete file from 2 servers" testXFTPCLIDelete + it "prepareChunkSizes should use 2 chunk sizes" testPrepareChunkSizes + +testBracket :: IO () -> IO () +testBracket = + bracket_ + (mapM_ (createDirectoryIfMissing False) testDirs) + (mapM_ removeDirectoryRecursive testDirs) + where + testDirs = [xftpServerFiles, xftpServerFiles2, senderFiles, recipientFiles] + +senderFiles :: FilePath +senderFiles = "tests/tmp/xftp-sender-files" + +recipientFiles :: FilePath +recipientFiles = "tests/tmp/xftp-recipient-files" + +xftpCLI :: [String] -> IO [String] +xftpCLI params = lines <$> capture_ (withArgs params xftpClientCLI) + +testXFTPCLISendReceive :: IO () +testXFTPCLISendReceive = withXFTPServer $ do + let filePath = senderFiles "testfile" + xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] + file <- LB.readFile filePath + getFileSize filePath `shouldReturn` mb 17 + let fdRcv1 = filePath <> ".xftp" "rcv1.xftp" + fdRcv2 = filePath <> ".xftp" "rcv2.xftp" + fdSnd = filePath <> ".xftp" "snd.xftp.private" + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr, "--tmp=tests/tmp"] + progress `shouldSatisfy` uploadProgress + sendResult + `shouldBe` [ "Sender file description: " <> fdSnd, + "Pass file descriptions to the recipient(s):", + fdRcv1, + fdRcv2 + ] + testInfoFile fdRcv1 "Recipient" + testReceiveFile fdRcv1 "testfile" file + testInfoFile fdRcv2 "Recipient" + testReceiveFile fdRcv2 "testfile_1" file + testInfoFile fdSnd "Sender" + xftpCLI ["recv", fdSnd, recipientFiles, "--tmp=tests/tmp"] + `shouldThrow` anyException + where + testInfoFile fd party = do + xftpCLI ["info", fd] + `shouldReturn` [party <> " file description", "File download size: 18mb", "File server(s):", testXFTPServerStr <> ": 18mb"] + testReceiveFile fd fileName file = do + progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"] + progress `shouldSatisfy` downloadProgress fileName + recvResult `shouldBe` ["File description " <> fd <> " is deleted."] + LB.readFile (recipientFiles fileName) `shouldReturn` file + +testXFTPCLISendReceive2servers :: IO () +testXFTPCLISendReceive2servers = withXFTPServer . withXFTPServer2 $ do + let filePath = senderFiles "testfile" + xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] + file <- LB.readFile filePath + getFileSize filePath `shouldReturn` mb 17 + let fdRcv1 = filePath <> ".xftp" "rcv1.xftp" + fdRcv2 = filePath <> ".xftp" "rcv2.xftp" + fdSnd = filePath <> ".xftp" "snd.xftp.private" + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"] + progress `shouldSatisfy` uploadProgress + sendResult + `shouldBe` [ "Sender file description: " <> fdSnd, + "Pass file descriptions to the recipient(s):", + fdRcv1, + fdRcv2 + ] + testReceiveFile fdRcv1 "testfile" file + testReceiveFile fdRcv2 "testfile_1" file + where + testReceiveFile fd fileName file = do + partyStr : sizeStr : srvStr : srvs <- xftpCLI ["info", fd] + partyStr `shouldContain` "Recipient file description" + sizeStr `shouldBe` "File download size: 18mb" + srvStr `shouldBe` "File server(s):" + case srvs of + [srv1] -> any (`isInfixOf` srv1) [testXFTPServerStr, testXFTPServerStr2] `shouldBe` True + [srv1, srv2] -> do + srv1 `shouldContain` testXFTPServerStr + srv2 `shouldContain` testXFTPServerStr2 + _ -> print srvs >> error "more than 2 servers returned" + progress : recvResult <- xftpCLI ["recv", fd, recipientFiles, "--tmp=tests/tmp", "-y"] + progress `shouldSatisfy` downloadProgress fileName + recvResult `shouldBe` ["File description " <> fd <> " is deleted."] + LB.readFile (recipientFiles fileName) `shouldReturn` file + +testXFTPCLIDelete :: IO () +testXFTPCLIDelete = withXFTPServer . withXFTPServer2 $ do + let filePath = senderFiles "testfile" + xftpCLI ["rand", filePath, "17mb"] `shouldReturn` ["File created: " <> filePath] + file <- LB.readFile filePath + getFileSize filePath `shouldReturn` mb 17 + let fdRcv1 = filePath <> ".xftp" "rcv1.xftp" + fdRcv2 = filePath <> ".xftp" "rcv2.xftp" + fdSnd = filePath <> ".xftp" "snd.xftp.private" + progress : sendResult <- xftpCLI ["send", filePath, senderFiles, "-n", "2", "-s", testXFTPServerStr <> ";" <> testXFTPServerStr2, "--tmp=tests/tmp"] + progress `shouldSatisfy` uploadProgress + sendResult + `shouldBe` [ "Sender file description: " <> fdSnd, + "Pass file descriptions to the recipient(s):", + fdRcv1, + fdRcv2 + ] + xftpCLI ["del", fdRcv1] + `shouldThrow` anyException + progress1 : recvResult <- xftpCLI ["recv", fdRcv1, recipientFiles, "--tmp=tests/tmp", "-y"] + progress1 `shouldSatisfy` downloadProgress "testfile" + recvResult `shouldBe` ["File description " <> fdRcv1 <> " is deleted."] + LB.readFile (recipientFiles "testfile") `shouldReturn` file + fs1 <- listDirectory xftpServerFiles + fs2 <- listDirectory xftpServerFiles2 + length fs1 + length fs2 `shouldBe` 6 + xftpCLI ["del", fdSnd, "-y"] + `shouldReturn` ["File deleted! \r", "File description " <> fdSnd <> " is deleted."] + listDirectory xftpServerFiles >>= (`shouldBe` []) + listDirectory xftpServerFiles2 >>= (`shouldBe` []) + xftpCLI ["recv", fdRcv2, recipientFiles, "--tmp=tests/tmp"] + `shouldThrow` anyException + +testPrepareChunkSizes :: IO () +testPrepareChunkSizes = do + prepareChunkSizes (mb 9 + kb 256) `shouldBe` [mb 4, mb 4, mb 1, mb 1] + prepareChunkSizes (mb 9) `shouldBe` [mb 4, mb 4, mb 1] + prepareChunkSizes (mb 7 + 1) `shouldBe` [mb 4, mb 4] + prepareChunkSizes (mb 7) `shouldBe` [mb 4] <> r3 (mb 1) + prepareChunkSizes (mb 3 + 1) `shouldBe` [mb 4] + prepareChunkSizes (mb 3) `shouldBe` r3 (mb 1) + prepareChunkSizes (mb 2 + 3 * kb 256 + 1) `shouldBe` r3 (mb 1) + prepareChunkSizes (mb 2 + 3 * kb 256) `shouldBe` [mb 1, mb 1] <> r3 (kb 256) + prepareChunkSizes (mb 2 + 1) `shouldBe` [mb 1, mb 1, kb 256] + prepareChunkSizes (3 * kb 256 + 1) `shouldBe` [mb 1] + prepareChunkSizes (3 * kb 256) `shouldBe` r3 (kb 256) + prepareChunkSizes 1 `shouldBe` [kb 256] + where + r3 = replicate 3 + +uploadProgress :: String -> Bool +uploadProgress s = + "Encrypting file..." `isPrefixOf` s + && "Uploading file..." `isInfixOf` s + && "File uploaded!" `isInfixOf` s + +downloadProgress :: FilePath -> String -> Bool +downloadProgress fileName s = + "Downloading file..." `isPrefixOf` s + && "Decrypting file..." `isInfixOf` s + && ("File downloaded: " <> recipientFiles fileName <> "\r") `isSuffixOf` s diff --git a/tests/XFTPClient.hs b/tests/XFTPClient.hs new file mode 100644 index 000000000..5bfcadf47 --- /dev/null +++ b/tests/XFTPClient.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module XFTPClient where + +import Control.Concurrent (ThreadId) +import Data.String (fromString) +import Network.Socket (ServiceName) +import SMPClient (serverBracket) +import Simplex.FileTransfer.Client +import Simplex.FileTransfer.Description +import Simplex.FileTransfer.Server (runXFTPServerBlocking) +import Simplex.FileTransfer.Server.Env (XFTPServerConfig (..), defaultFileExpiration) +import Simplex.Messaging.Protocol (XFTPServer) +import Test.Hspec + +xftpTest :: HasCallStack => (HasCallStack => XFTPClient -> IO ()) -> Expectation +xftpTest test = runXFTPTest test `shouldReturn` () + +xftpTestN :: HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO ()) -> Expectation +xftpTestN n test = runXFTPTestN n test `shouldReturn` () + +xftpTest2 :: HasCallStack => (HasCallStack => XFTPClient -> XFTPClient -> IO ()) -> Expectation +xftpTest2 test = xftpTestN 2 _test + where + _test [h1, h2] = test h1 h2 + _test _ = error "expected 2 handles" + +runXFTPTest :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a +runXFTPTest test = withXFTPServer $ testXFTPClient test + +runXFTPTestN :: forall a. HasCallStack => Int -> (HasCallStack => [XFTPClient] -> IO a) -> IO a +runXFTPTestN nClients test = withXFTPServer $ run nClients [] + where + run :: Int -> [XFTPClient] -> IO a + run 0 hs = test hs + run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs) + +withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile} + +withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerCfg cfg = + serverBracket + (`runXFTPServerBlocking` cfg) + (pure ()) + +withXFTPServerThreadOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a +withXFTPServerThreadOn = withXFTPServerCfg testXFTPServerConfig + +withXFTPServer :: IO a -> IO a +withXFTPServer = withXFTPServerCfg testXFTPServerConfig . const + +withXFTPServer2 :: IO a -> IO a +withXFTPServer2 = withXFTPServerCfg testXFTPServerConfig {xftpPort = xftpTestPort2, filesPath = xftpServerFiles2} . const + +xftpTestPort :: ServiceName +xftpTestPort = "7000" + +xftpTestPort2 :: ServiceName +xftpTestPort2 = "7001" + +testXFTPServer :: XFTPServer +testXFTPServer = fromString testXFTPServerStr + +testXFTPServerStr :: String +testXFTPServerStr = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7000" + +testXFTPServerStr2 :: String +testXFTPServerStr2 = "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:7001" + +xftpServerFiles :: FilePath +xftpServerFiles = "tests/tmp/xftp-server-files" + +xftpServerFiles2 :: FilePath +xftpServerFiles2 = "tests/tmp/xftp-server-files2" + +testXFTPLogFile :: FilePath +testXFTPLogFile = "tests/tmp/xftp-server-store.log" + +testXFTPStatsBackupFile :: FilePath +testXFTPStatsBackupFile = "tests/tmp/xftp-server-stats.log" + +testXFTPServerConfig :: XFTPServerConfig +testXFTPServerConfig = + XFTPServerConfig + { xftpPort = xftpTestPort, + fileIdSize = 16, + storeLogFile = Nothing, + filesPath = xftpServerFiles, + fileSizeQuota = Nothing, + allowedChunkSizes = [kb 128, kb 256, mb 1, mb 4], + allowNewFiles = True, + newFileBasicAuth = Nothing, + fileExpiration = Just defaultFileExpiration, + caCertificateFile = "tests/fixtures/ca.crt", + privateKeyFile = "tests/fixtures/server.key", + certificateFile = "tests/fixtures/server.crt", + logStatsInterval = Nothing, + logStatsStartTime = 0, + serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", + serverStatsBackupFile = Nothing, + logTLSErrors = True + } + +testXFTPClientConfig :: XFTPClientConfig +testXFTPClientConfig = defaultXFTPClientConfig + +testXFTPClient :: HasCallStack => (HasCallStack => XFTPClient -> IO a) -> IO a +testXFTPClient client = + getXFTPClient (1, testXFTPServer, Nothing) testXFTPClientConfig (\_ -> pure ()) >>= \case + Right c -> client c + Left e -> error $ show e diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs new file mode 100644 index 000000000..9da40ef8f --- /dev/null +++ b/tests/XFTPServerTests.hs @@ -0,0 +1,309 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module XFTPServerTests where + +import AgentTests.FunctionalAPITests (runRight_) +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Exception (SomeException) +import Control.Monad.Except +import Crypto.Random (getRandomBytes) +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 System.Directory (createDirectoryIfMissing, removeDirectoryRecursive, removeFile) +import System.FilePath (()) +import Test.Hspec +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 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 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 + bytes <- getRandomBytes chSize + 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 + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + 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 r rpKey rId (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize (digest <> "_wrong")) + `catchError` (liftIO . (`shouldBe` PCEResponseError DIGEST)) + downloadXFTPChunk r rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + +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 + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + 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 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) -> "openBinaryFile: does not exist" `isInfixOf` show e + downloadXFTPChunk 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 + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey, rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + 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 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 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 -> runRight_ $ do + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey, _rpKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + liftIO $ B.writeFile testChunkPath =<< getRandomBytes (kb 96) + digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath + let file = FileInfo {sndKey, size = kb 96, digest} + void (createXFTPChunk c spKey file [rcvKey] Nothing) + `catchError` (liftIO . (`shouldBe` PCEProtocolError SIZE)) + +testFileChunkExpiration :: Expectation +testFileChunkExpiration = withXFTPServerCfg testXFTPServerConfig {fileExpiration} $ + \_ -> 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.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 c rpKey rId $ XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest + liftIO $ B.readFile "tests/tmp/received_chunk1" `shouldReturn` bytes + + liftIO $ threadDelay 1000000 + downloadXFTPChunk 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} + +testFileStorageQuota :: Expectation +testFileStorageQuota = withXFTPServerCfg testXFTPServerConfig {fileSizeQuota = Just $ chSize * 2} $ + \_ -> 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.sha256Hash <$> LB.readFile testChunkPath + let file = FileInfo {sndKey, size = chSize, digest} + chunkSpec = XFTPChunkSpec {filePath = testChunkPath, chunkOffset = 0, chunkSize = chSize} + 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] 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 + bytes <- liftIO $ createTestChunk testChunkPath + (sndKey, spKey) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey1, rpKey1) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + (rcvKey2, rpKey2) <- liftIO $ C.generateSignatureKeyPair C.SEd25519 + digest <- liftIO $ LC.sha256Hash <$> LB.readFile testChunkPath + sIdVar <- newTVarIO "" + rIdVar1 <- newTVarIO "" + rIdVar2 <- newTVarIO "" + + 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 c rpKey1 rId1 digest bytes + download c rpKey2 rId2 digest bytes + logSize testXFTPLogFile `shouldReturn` 3 + logSize testXFTPStatsBackupFile `shouldReturn` 11 + + 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 c rpKey1 rId1 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + downloadXFTPChunk c rpKey2 rId2 (XFTPRcvChunkSpec "tests/tmp/received_chunk1" chSize digest) + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + deleteXFTPChunk c spKey sId + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + + withXFTPServerStoreLogOn $ \_ -> testXFTPClient $ \c -> runRight_ $ do + rId1 <- liftIO $ readTVarIO rIdVar1 + rId2 <- liftIO $ readTVarIO rIdVar2 + -- recipient 1 can download, acknowledges - +1 to log + download c rpKey1 rId1 digest bytes + ackXFTPChunk c rpKey1 rId1 + -- recipient 2 can download + download c rpKey2 rId2 digest bytes + logSize testXFTPLogFile `shouldReturn` 4 + logSize testXFTPStatsBackupFile `shouldReturn` 11 + + withXFTPServerStoreLogOn $ \_ -> pure () -- ack is compacted - -1 from log + logSize testXFTPLogFile `shouldReturn` 3 + + 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 c rpKey1 rId1 digest bytes + `catchError` (liftIO . (`shouldBe` PCEProtocolError AUTH)) + -- recipient 2 can download + download c rpKey2 rId2 digest bytes + -- sender can delete - +1 to log + deleteXFTPChunk c spKey sId + logSize testXFTPLogFile `shouldReturn` 4 + logSize testXFTPStatsBackupFile `shouldReturn` 11 + + withXFTPServerStoreLogOn $ \_ -> pure () -- compacts on start + logSize testXFTPLogFile `shouldReturn` 0 + logSize testXFTPStatsBackupFile `shouldReturn` 11 + + removeFile testXFTPLogFile + removeFile testXFTPStatsBackupFile + where + 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.sha256Hash <$> 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)) diff --git a/tests/fixtures/file_description.yaml b/tests/fixtures/file_description.yaml new file mode 100644 index 000000000..6ba8a0a6e --- /dev/null +++ b/tests/fixtures/file_description.yaml @@ -0,0 +1,23 @@ +chunkSize: 8mb +digest: YWJj +key: 00n8p1tJq5E-SGnHcYTOrS4A9I07gTA_WFD6MTFFFOY= +nonce: dPSF-wrQpDiK_K6sYv0BDBZ9S4dg-jmu +party: recipient +replicas: +- chunks: + - 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp + - 3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp + server: xftp://abc=@example1.com +- chunks: + - 2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp + - 4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe:Z2hp:2mb + server: xftp://abc=@example2.com +- chunks: + - 1:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe + - 4:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe + server: xftp://abc=@example3.com +- chunks: + - 2:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe + - 3:YWJj:MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe + server: xftp://abc=@example4.com +size: 26mb