concurrent and padded hellos in the server

src/Simplex/FileTransfer/Agent.hs

@@ -47,7 +47,7 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, mapMaybe)
 import qualified Data.Set as S
-import Data.Text (Text)
+import Data.Text (Text, pack)
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Simplex.FileTransfer.Chunks (toKB)
@@ -433,7 +433,7 @@ runXFTPSndPrepareWorker c Worker {doWork} = do
         encryptFileForUpload :: SndFile -> FilePath -> AM (FileDigest, [(XFTPChunkSpec, FileDigest)])
         encryptFileForUpload SndFile {key, nonce, srcFile, redirect} fsEncPath = do
           let CryptoFile {filePath} = srcFile
-              fileName = takeFileName filePath
+              fileName = pack $ takeFileName filePath
           fileSize <- liftIO $ fromInteger <$> CF.getFileContentsSize srcFile
           when (fileSize > maxFileSizeHard) $ throwE $ FILE FT.SIZE
           let fileHdr = smpEncode FileHeader {fileName, fileExtra = Nothing}

src/Simplex/FileTransfer/Client/Main.hs

@@ -41,6 +41,7 @@ import qualified Data.List.NonEmpty as L
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Word (Word32)
 import GHC.Records (HasField (getField))
@@ -242,7 +243,8 @@ cliSendFile opts = cliSendFileOpts opts True $ printProgress "Uploaded"
 
 cliSendFileOpts :: SendOptions -> Bool -> (Int64 -> Int64 -> IO ()) -> ExceptT CLIError IO ()
 cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, retryCount, tempPath, verbose} printInfo notifyProgress = do
-  let (_, fileName) = splitFileName filePath
+  let (_, fileNameStr) = splitFileName filePath
+      fileName = T.pack fileNameStr
   liftIO $ when printInfo $ printNoNewLine "Encrypting file..."
   g <- liftIO C.newRandom
   (encPath, fdRcv, fdSnd, chunkSpecs, encSize) <- encryptFileForUpload g fileName
@@ -254,14 +256,14 @@ cliSendFileOpts SendOptions {filePath, outputDir, numRecipients, xftpServers, re
   liftIO $ do
     let fdRcvs = createRcvFileDescriptions fdRcv sentChunks
         fdSnd' = createSndFileDescription fdSnd sentChunks
-    (fdRcvPaths, fdSndPath) <- writeFileDescriptions fileName fdRcvs fdSnd'
+    (fdRcvPaths, fdSndPath) <- writeFileDescriptions fileNameStr fdRcvs fdSnd'
     when printInfo $ do
       printNoNewLine "File uploaded!"
       putStrLn $ "\nSender file description: " <> fdSndPath
       putStrLn "Pass file descriptions to the recipient(s):"
     forM_ fdRcvPaths putStrLn
   where
-    encryptFileForUpload :: TVar ChaChaDRG -> String -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
+    encryptFileForUpload :: TVar ChaChaDRG -> Text -> ExceptT CLIError IO (FilePath, FileDescription 'FRecipient, FileDescription 'FSender, [XFTPChunkSpec], Int64)
     encryptFileForUpload g fileName = do
       fileSize <- fromInteger <$> getFileSize filePath
       when (fileSize > maxFileSize) $ throwE $ CLIError $ "Files bigger than " <> maxFileSizeStr <> " are not supported"
@@ -430,13 +432,14 @@ cliReceiveFile ReceiveOptions {fileDescription, filePath, retryCount, tempPath,
         when verbose $ putStrLn ""
       pure (chunkNo, chunkPath)
     downloadFileChunk _ _ _ _ _ _ = throwE $ 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) (throwE "File already exists") (pure path)
-        _ -> (`uniqueCombine` name) . (</> "Downloads") =<< getHomeDirectory
+    getFilePath :: Text -> ExceptT String IO FilePath
+    getFilePath name = case filePath of
+      Just path ->
+        ifM (doesDirectoryExist path) (uniqueCombine path name') $
+          ifM (doesFileExist path) (throwE "File already exists") (pure path)
+      _ -> (`uniqueCombine` name') . (</> "Downloads") =<< getHomeDirectory
+      where
+        name' = T.unpack name
     acknowledgeFileChunk :: XFTPClientAgent -> FileChunk -> ExceptT CLIError IO ()
     acknowledgeFileChunk a FileChunk {replicas = replica : _} = do
       let FileChunkReplica {server, replicaId, replicaKey} = replica

src/Simplex/FileTransfer/Crypto.hs

@@ -16,6 +16,7 @@ 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 Data.Text (Text)
 import Simplex.FileTransfer.Types (FileHeader (..), authTagSize)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.File (CryptoFile (..), FTCryptoError (..))
@@ -54,7 +55,7 @@ encryptFile srcFile fileHdr key nonce fileSize' encSize encFile = do
           liftIO $ B.hPut w ch'
           encryptChunks_ get w (sb', len - chSize)
 
-decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> ExceptT String IO CryptoFile) -> ExceptT FTCryptoError IO CryptoFile
+decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (Text -> ExceptT String IO CryptoFile) -> ExceptT FTCryptoError IO CryptoFile
 decryptChunks _ [] _ _ _ = throwE $ FTCEInvalidHeader "empty"
 decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse chPaths of
   [] -> do

src/Simplex/FileTransfer/Server.hs

@@ -167,26 +167,32 @@ xftpServer cfg@XFTPServerConfig {xftpPort, transportConfig, inactiveClientExpira
       s <- atomically $ TM.lookup sessionId sessions
       r <- runExceptT $ case s of
         Nothing -> processHello Nothing
-        Just (HandshakeSent pk) -> processClientHandshake pk
+        Just (HandshakeSent pk)
+          | webHello -> processHello (Just pk)
+          | otherwise -> processClientHandshake pk
         Just (HandshakeAccepted thParams)
           | webHello -> processHello (serverPrivKey <$> thAuth thParams)
+          | webHandshake, Just auth <- thAuth thParams -> processClientHandshake (serverPrivKey auth)
           | otherwise -> pure $ Just thParams
       either sendError pure r
       where
         webHello = sniUsed && any (\(t, _) -> tokenKey t == "xftp-web-hello") (fst $ H.requestHeaders request)
+        webHandshake = sniUsed && any (\(t, _) -> tokenKey t == "xftp-handshake") (fst $ H.requestHeaders request)
         processHello pk_ = do
           challenge_ <-
             if
               | B.null bodyHead -> pure Nothing
               | sniUsed -> do
-                  XFTPClientHello {webChallenge} <- liftHS $ smpDecode bodyHead
+                  body <- liftHS $ C.unPad bodyHead
+                  XFTPClientHello {webChallenge} <- liftHS $ smpDecode body
                   pure webChallenge
               | otherwise -> throwE HANDSHAKE
-          (k, pk) <- maybe
-            (atomically . C.generateKeyPair =<< asks random)
-            (\pk -> pure (C.publicKey pk, pk))
-            pk_
-          atomically $ TM.insert sessionId (HandshakeSent pk) sessions
+          rng <- asks random
+          k <- atomically $ TM.lookup sessionId sessions >>= \case
+            Just (HandshakeSent pk') -> pure $ C.publicKey pk'
+            _ -> do
+              kp <- maybe (C.generateKeyPair rng) (\p -> pure (C.publicKey p, p)) pk_
+              fst kp <$ TM.insert sessionId (HandshakeSent $ snd kp) sessions
           let authPubKey = CertChainPubKey chain (C.signX509 serverSignKey $ C.publicToX509 k)
               webIdentityProof = C.sign serverSignKey . (<> sessionId) <$> challenge_
           let hs = XFTPServerHandshake {xftpVersionRange = xftpServerVRange, sessionId, authPubKey, webIdentityProof}

src/Simplex/FileTransfer/Types.hs

@@ -10,6 +10,7 @@ import qualified Data.Aeson.TH as J
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Word (Word32)
@@ -33,8 +34,8 @@ authTagSize = fromIntegral C.authTagSize
 
 -- fileExtra is added to allow header extension in future versions
 data FileHeader = FileHeader
-  { fileName :: String,
-    fileExtra :: Maybe String
+  { fileName :: Text,
+    fileExtra :: Maybe Text
   }
   deriving (Eq, Show)
 

src/Simplex/Messaging/Encoding.hs

@@ -24,6 +24,8 @@ import Data.Bits (shiftL, shiftR, (.|.))
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import Data.ByteString.Internal (c2w, w2c)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
 import Data.Int (Int64)
 import qualified Data.List.NonEmpty as L
 import Data.Time.Clock.System (SystemTime (..))
@@ -156,6 +158,12 @@ smpEncodeList xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs
 smpListP :: Encoding a => Parser [a]
 smpListP = (`A.count` smpP) =<< lenP
 
+instance Encoding Text where
+  smpEncode = smpEncode . encodeUtf8
+  {-# INLINE smpEncode #-}
+  smpP = either (fail . show) pure . decodeUtf8' =<< smpP
+  {-# INLINE smpP #-}
+
 instance Encoding String where
   smpEncode = smpEncode . B.pack
   {-# INLINE smpEncode #-}