diff --git a/src/Simplex/FileTransfer/Transport.hs b/src/Simplex/FileTransfer/Transport.hs index da43c2fc6..d90e54c55 100644 --- a/src/Simplex/FileTransfer/Transport.hs +++ b/src/Simplex/FileTransfer/Transport.hs @@ -57,7 +57,7 @@ sendEncFile :: Handle -> (Builder -> IO ()) -> LC.SbState -> Word32 -> IO () sendEncFile h send = go where go sbState 0 = do - -- TODO remove padding when HTTP2 issue is fixed + -- TODO padding somehow also solves timing issue in HTTP2 (?) let authTag = BA.convert (LC.sbAuth sbState) <> B.replicate (fileBlockSize - C.authTagSize) '#' send $ byteString authTag go sbState sz = diff --git a/src/Simplex/Messaging/Agent/Protocol.hs b/src/Simplex/Messaging/Agent/Protocol.hs index c08f86fd7..1c55a5b42 100644 --- a/src/Simplex/Messaging/Agent/Protocol.hs +++ b/src/Simplex/Messaging/Agent/Protocol.hs @@ -125,6 +125,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 @@ -1467,8 +1469,10 @@ tGet party h = liftIO (tGetRaw h) >>= tParseLoadBody 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/Transport.hs b/src/Simplex/Messaging/Transport.hs index 9df1a127d..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 @@ -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/tests/XFTPClient.hs b/tests/XFTPClient.hs index d6b48f6a2..934ce3629 100644 --- a/tests/XFTPClient.hs +++ b/tests/XFTPClient.hs @@ -39,7 +39,7 @@ runXFTPTestN nClients test = withXFTPServer $ run nClients [] run n hs = testXFTPClient $ \h -> run (n - 1) (h : hs) withXFTPServerStoreLogOn :: HasCallStack => (HasCallStack => ThreadId -> IO a) -> IO a -withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile} +withXFTPServerStoreLogOn = withXFTPServerCfg testXFTPServerConfig {storeLogFile = Just testXFTPLogFile, serverStatsBackupFile = Just testXFTPStatsBackupFile} withXFTPServerCfg :: HasCallStack => XFTPServerConfig -> (HasCallStack => ThreadId -> IO a) -> IO a withXFTPServerCfg cfg = @@ -80,6 +80,9 @@ 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 @@ -98,7 +101,7 @@ testXFTPServerConfig = logStatsInterval = Nothing, logStatsStartTime = 0, serverStatsLogFile = "tests/tmp/xftp-server-stats.daily.log", - serverStatsBackupFile = Just "tests/tmp/xftp-server-stats.log", + serverStatsBackupFile = Nothing, logTLSErrors = True } diff --git a/tests/XFTPServerTests.hs b/tests/XFTPServerTests.hs index 3ec2a33c9..7e3d5ed16 100644 --- a/tests/XFTPServerTests.hs +++ b/tests/XFTPServerTests.hs @@ -235,6 +235,7 @@ testFileLog = do 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 @@ -257,6 +258,7 @@ testFileLog = do -- 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 @@ -273,11 +275,14 @@ testFileLog = do -- 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