update cGet to not throw exception if returned string is shorter (trying to fix HTTP2), fix test (#663)

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 =

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

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.
 --

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

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
     }
 

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