use updated version

benchmarks/Bench.hs

@@ -0,0 +1,28 @@
+{- Benchmark harness
+
+Run with: cabal bench -O2 simplexmq-bench
+
+List cases: cabal bench -O2 simplexmq-bench --benchmark-options "-l"
+Pick one or group: cabal bench -O2 simplexmq-bench --benchmark-options "-p TRcvQueues.getDelSessQueues"
+-}
+
+module Main where
+
+import Bench.Base64
+import Bench.BsConcat
+import Bench.Compression
+import Bench.Crypto.Lazy
+import Bench.SNTRUP761
+import Bench.TRcvQueues
+import Test.Tasty.Bench
+
+main :: IO ()
+main =
+  defaultMain
+    [ bgroup "TRcvQueues" benchTRcvQueues,
+      bgroup "SNTRUP761" benchSNTRUP761,
+      bgroup "Compression" benchCompression,
+      bgroup "BsConcat" benchBsConcat,
+      bgroup "Base64" benchBase64,
+      bgroup "CryptoLazy" benchCryptoLazy
+    ]

benchmarks/Bench/Base64.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Bench.Base64 where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Char (isAlphaNum)
+import Test.Tasty.Bench
+import qualified "base64" Data.Base64.Types as New
+import qualified "base64" Data.ByteString.Base64 as New
+import qualified "base64" Data.ByteString.Base64.URL as NewUrl
+import qualified "base64-bytestring" Data.ByteString.Base64 as Old
+import qualified "base64-bytestring" Data.ByteString.Base64.URL as OldUrl
+
+benchBase64 :: [Benchmark]
+benchBase64 =
+  [ bgroup
+      "encode"
+      [ bench "e-old" $ nf Old.encode decoded,
+        bcompare "e-old" . bench "e-new" $ nf New.encodeBase64' decoded
+      ],
+    bgroup
+      "decode"
+      [ bench "d-old" $ nf Old.decode encoded,
+        bcompare "d-old" . bench "d-new" $ nf New.decodeBase64Untyped encoded,
+        bcompare "d-old" . bench "d-typed" $ nf (New.decodeBase64 . New.assertBase64 @New.StdPadded) encoded
+      ],
+    bgroup
+      "encode url"
+      [ bench "eu-old" $ nf OldUrl.encode decoded,
+        bcompare "eu-old" . bench "eu-new" $ nf NewUrl.encodeBase64' decoded
+      ],
+    bgroup
+      "decode url"
+      [ bench "du-old" $ nf OldUrl.decode encodedUrl,
+        bcompare "du-old" . bench "du-new" $ nf NewUrl.decodeBase64Untyped encodedUrl,
+        bcompare "du-old" . bench "du-typed" $ nf (NewUrl.decodeBase64 . New.assertBase64 @New.UrlPadded) encodedUrl
+      ],
+    bgroup
+      "parsing"
+      [ bench "predicates" $ nf parsePredicates encoded,
+        bcompare "predicates" . bench "alphabet" $ nf parseAlphabet encoded
+      ]
+  ]
+
+parsePredicates :: ByteString -> Either String ByteString
+parsePredicates = A.parseOnly $ do
+  str <- A.takeWhile1 (\c -> isAlphaNum c || c == '+' || c == '/')
+  pad <- A.takeWhile (== '=')
+  either fail pure $ Old.decode (str <> pad)
+
+parseAlphabet :: ByteString -> Either String ByteString
+parseAlphabet = A.parseOnly $ do
+  str <- A.takeWhile1 (`B.elem` base64Alphabet)
+  pad <- A.takeWhile (== '=')
+  either fail pure $ Old.decode (str <> pad)
+  where
+    base64Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+
+encoded :: ByteString
+encoded = "e8JK+8V3fq6kOLqco/SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON+qbvQ9ecJAA=="
+
+encodedUrl :: ByteString
+encodedUrl = "e8JK-8V3fq6kOLqco_SaKlpNaQ7i1gfOrXoqekEl42u4mF8Bgu14T5j0189CGcUhJHw2RwCMvON-qbvQ9ecJAA=="
+
+decoded :: ByteString
+decoded = "{\194J\251\197w~\174\164\&8\186\156\163\244\154*ZMi\SO\226\214\a\206\173z*zA%\227k\184\152_\SOH\130\237xO\152\244\215\207B\EM\197!$|6G\NUL\140\188\227~\169\187\208\245\231\t\NUL"

benchmarks/Bench/BsConcat.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bench.BsConcat where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Test.Tasty.Bench
+
+benchBsConcat :: [Benchmark]
+benchBsConcat =
+  [ bgroup "3 elements"
+      [ bench "(3-tuple baseline)" $ nf (\(a, s, b) -> a `seq` s `seq` b `seq` "" :: ByteString) ("aaa" :: ByteString, " " :: ByteString, "bbb" :: ByteString),
+        bench "a <> s <> b" $ nf (\(a, s, b) -> a <> s <> b :: ByteString) ("aaa", " ", "bbb"),
+        bench "concat [a, s, b]" $ nf (\(a, s, b) -> B.concat [a, s, b] :: ByteString) ("aaa", " ", "bbb"),
+        bench "unwords [a, b]" $ nf (\(a, b) -> B.unwords [a, b] :: ByteString) ("aaa", "bbb")
+      ],
+    bgroup "5 elements"
+      [ bench "a <> s <> b <> s <> c" $ nf (\(a, s1, b, s2, c) -> a <> s1 <> b <> s2 <> c :: ByteString) ("aaa", " ", "bbb", " ", "ccc"),
+        bench "(a <> s <> b) <> (s <> c)" $ nf (\(a, s1, b, s2, c) -> (a <> s1 <> b) <> (s2 <> c) :: ByteString) ("aaa", " ", "bbb", " ", "ccc"),
+        bench "concat [a, s, b, s c]" $ nf (\(a, s1, b, s2, c) -> B.concat [a, s1, b, s2, c] :: ByteString) ("aaa", " ", "bbb", " ", "ccc"),
+        bench "unwords [a, b, c]" $ nf (\(a, b, c) -> B.unwords [a, b, c] :: ByteString) ("aaa", "bbb", "ccc")
+      ]
+  ]

benchmarks/Bench/Compression.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bench.Compression where
+
+import qualified Codec.Compression.Zstd as Z
+import Data.Aeson
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as LB
+import Simplex.Messaging.Compression
+import Test.Tasty
+import Test.Tasty.Bench
+import Simplex.Messaging.Encoding (smpEncode)
+import Control.Monad (replicateM)
+-- import qualified Codec.Compression.Zstd.FFI as Z
+
+benchCompression :: [Benchmark]
+benchCompression =
+  [ bgroup
+      "stateless"
+      [ bench "1" $ nf (Z.compress 1) testJson,
+        bench "3" $ nf (Z.compress 3) testJson,
+        bench "5" $ nf (Z.compress 5) testJson,
+        bench "9" $ nf (Z.compress 9) testJson,
+        bench "15" $ nf (Z.compress 19) testJson
+      ],
+    bgroup
+      "context"
+        [ withCtxRes $ bench "batch-1" . nfAppIO (>>= replicateM 1 . fmap smpEncode . flip compress testJson),
+          withCtxRes $ bench "batch-1-pass" . nfAppIO (>>= replicateM 1 . fmap smpEncode . flip compress shortJson),
+          withCtxRes $ bench "batch-10" . nfAppIO (>>= replicateM 10 . fmap smpEncode . flip compress testJson),
+          withCtxRes $ bcompare "batch-10" . bench "native-10" . nfAppIO (const . replicateM 10 $ pure $! smpEncode $ Z.compress 3 testJson)
+        ]
+  ]
+
+withCtxRes :: (IO CompressCtx -> TestTree) -> TestTree
+withCtxRes = withResource (createCompressCtx 16384) freeCompressCtx
+
+shortJson :: B.ByteString
+shortJson = B.take maxLengthPassthrough testJson
+
+testJson :: B.ByteString
+testJson = LB.toStrict . encode $ object ["some stuff" .= [obj, obj, obj, obj]]
+  where
+    obj = object ["test" .= [True, False, True], "arr" .= [0 :: Int .. 50], "loooooooooong key" .= String "is loooooooooooooooooooooooong-ish"]

benchmarks/Bench/Crypto/Lazy.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Bench.Crypto.Lazy where
+
+-- import qualified Simplex.Messaging.Crypto.Lazy as CL
+import Test.Tasty.Bench
+
+import Control.Concurrent.STM (atomically)
+import Control.Monad.Except (runExceptT, throwError)
+import qualified Data.ByteString.Lazy.Char8 as LB
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.File (CryptoFile (..))
+import qualified Simplex.Messaging.Crypto.File as CF
+import System.Directory (removeFile)
+import Test.Tasty (TestTree, withResource)
+import System.IO (IOMode(..))
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad
+import UnliftIO.Directory (getFileSize)
+import qualified Data.ByteString as B
+import Control.Monad.Trans.Except (ExceptT)
+
+benchCryptoLazy :: [Benchmark]
+benchCryptoLazy =
+  [ bgroup
+      "File"
+      [ withSomeFile $ bench "cf-passthrough" . nfAppIO (>>= benchPassthrough),
+        withSomeFile $ bench "cf-double-streaming" . nfAppIO (>>= benchDoubleStreaming),
+        withSomeFile $ bench "cf-streamFromFile" . nfAppIO (>>= benchStreamFromFile),
+        withSomeFile $ bench "cf-readFile" . nfAppIO (>>= benchReadFile)
+      ]
+  ]
+
+benchReadFile :: (CryptoFile, CryptoFile) -> IO ()
+benchReadFile (cfIn, cfOut) = fmap (either (error . show) id) . runExceptT $ CF.readFile cfIn >>= CF.writeFile cfOut
+
+benchStreamFromFile :: (CryptoFile, CryptoFile) -> IO ()
+benchStreamFromFile (cfIn, cfOut) = fmap (either (error . show) id) . runExceptT $
+  -- CF.streamFromFile cfIn $ \_ -> pure ()
+  CF.withFile cfOut WriteMode $ \cbh -> do
+    CF.streamFromFile cfIn $ liftIO . CF.hPut cbh
+    liftIO $ CF.hPutTag cbh
+
+benchPassthrough :: (CryptoFile, CryptoFile) -> IO ()
+benchPassthrough (CryptoFile pathIn _, CryptoFile pathOut _) = LB.readFile pathIn >>= LB.writeFile pathOut
+
+benchDoubleStreaming :: (CryptoFile, CryptoFile) -> IO ()
+benchDoubleStreaming (src, dst) = fmap (either (error . show) id) . runExceptT $ copyCryptoFile src dst
+  where
+    copyCryptoFile :: CryptoFile -> CryptoFile -> ExceptT CF.FTCryptoError IO ()
+    copyCryptoFile fromCF@CryptoFile {filePath = fsFromPath, cryptoArgs = fromArgs} toCF@CryptoFile {cryptoArgs = toArgs} = do
+      fromSizeFull <- getFileSize fsFromPath
+      let fromSize = fromSizeFull - maybe 0 (const $ toInteger C.authTagSize) fromArgs
+      CF.withFile fromCF ReadMode $ \fromH ->
+        CF.withFile toCF WriteMode $ \toH -> do
+          copyChunks fromH toH fromSize
+          forM_ fromArgs $ \_ -> CF.hGetTag fromH
+          forM_ toArgs $ \_ -> liftIO $ CF.hPutTag toH
+      where
+        copyChunks :: CF.CryptoFileHandle -> CF.CryptoFileHandle -> Integer -> ExceptT CF.FTCryptoError IO ()
+        copyChunks r w size = do
+          let chSize = min size 0xFFFF
+              chSize' = fromIntegral chSize
+              size' = size - chSize
+          ch <- liftIO $ CF.hGet r chSize'
+          when (B.length ch /= chSize') $ throwError $ CF.FTCEFileIOError "encrypting file: unexpected EOF"
+          liftIO . CF.hPut w $ LB.fromStrict ch
+          when (size' > 0) $ copyChunks r w size'
+
+withSomeFile :: (IO (CryptoFile, CryptoFile) -> TestTree) -> TestTree
+withSomeFile = withResource createCF deleteCF
+  where
+    createCF = do
+      g <- C.newRandom
+      -- encrypt input file
+      let pathIn = "./some-file.in"
+      -- let cfIn  = CryptoFile pathIn Nothing
+      -- LB.writeFile pathIn $ LB.replicate (256 * 1024 * 1024) '#'
+      cfIn <- atomically $ CryptoFile pathIn . Just <$> CF.randomArgs g
+      -- Right () <- runExceptT $ CF.withFile cfIn WriteMode $ \cbh -> liftIO $ do
+      --   replicateM_ 256 $ CF.hPut cbh dummyChunk
+      --   CF.hPutTag cbh
+      Right () <- runExceptT $ CF.writeFile cfIn $ LB.replicate (256 * 1024 * 1024) '#'
+      -- gen out args
+      cfOut <- atomically $ CryptoFile "./some-file.out" . Just <$> CF.randomArgs g
+      -- let cfOut  = CryptoFile "./some-file.out" Nothing
+      pure (cfIn, cfOut)
+    deleteCF (CryptoFile pathIn _, CryptoFile pathOut _) = do
+      removeFile pathIn
+      removeFile pathOut
+
+dummyChunk :: LB.ByteString
+dummyChunk = LB.replicate (1024 * 1024) '#'

benchmarks/Bench/SNTRUP761.hs

@@ -0,0 +1,15 @@
+module Bench.SNTRUP761 where
+
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.SNTRUP761.Bindings
+import Test.Tasty.Bench
+
+import Test.Tasty (withResource)
+
+benchSNTRUP761 :: [Benchmark]
+benchSNTRUP761 =
+  [ bgroup
+      "sntrup761Keypair"
+      [ withResource C.newRandom (\_ -> pure ()) $ bench "current" . whnfAppIO (>>= sntrup761Keypair)
+      ]
+  ]

benchmarks/Bench/TRcvQueues.hs

@@ -0,0 +1,137 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Bench.TRcvQueues where
+
+import Control.Monad (replicateM, unless)
+import Crypto.Random
+import Data.Bifunctor (bimap)
+import Data.ByteString (ByteString)
+import Data.Hashable (hash)
+import Simplex.Messaging.Agent.Protocol (ConnId, QueueStatus (..), UserId)
+import Simplex.Messaging.Agent.Store (DBQueueId (..), RcvQueue, StoredRcvQueue (..))
+import qualified Simplex.Messaging.Agent.TRcvQueues as Current
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Protocol (ProtocolServer (..), SMPServer, SProtocolType (..), currentSMPClientVersion)
+import Simplex.Messaging.Transport.Client (TransportHost (..))
+import Test.Tasty.Bench
+import qualified Data.Map.Strict as M
+import UnliftIO
+
+-- For quick equivalence tests
+-- import GHC.IO (unsafePerformIO)
+-- import Test.Hspec
+-- import Test.Tasty.Hspec (testSpec)
+
+
+benchTRcvQueues :: [Benchmark]
+benchTRcvQueues =
+  [ bgroup
+      "addQueue"
+      [ bench "aq-current" $ nfIO prepareCurrent,
+        bcompare "aq-current" . bench "aq-batch" $ nfIO prepareCurrentBatch
+      ],
+    bgroup "getDelSessQueues" benchGDS,
+    bgroup "resubscribe" benchResubscribe
+  ]
+
+benchGDS :: [Benchmark]
+benchGDS =
+  [ env prepareCurrent $ bench "gds-current" . nfAppIO (fmap (bimap length length) . benchGDSCurrent)
+  -- unsafePerformIO $ testSpec "gds-equiv" testGDSequivalent
+  ]
+  where
+    benchGDSCurrent (tSess, qs) = atomically $ Current.getDelSessQueues tSess qs
+
+-- testGDSequivalent = it "same" $ do
+--   m@(mKey, _) <- prepareMaster
+--   c@(cKey, _) <- prepareCurrent
+--   mKey `shouldBe` cKey
+--   qsMaster <- benchGDSMaster m
+--   (qsCurrent, _connIds) <- benchGDSCurrent c
+--   length qsMaster `shouldNotBe` 0
+--   length qsMaster `shouldBe` length qsCurrent
+--   qsMaster `shouldBe` qsCurrent
+
+benchResubscribe :: [Benchmark]
+benchResubscribe =
+  [ env (prepareCurrent >>= pickActiveCurrent 1.0) $ bench "resub-current-full" . nfAppIO benchResubCurrent,
+    env (prepareCurrent >>= pickActiveCurrent 0.5) $ bench "resub-current-half" . nfAppIO benchResubCurrent,
+    env (prepareCurrent >>= pickActiveCurrent 0.0) $ bench "resub-current-none" . nfAppIO benchResubCurrent
+  ]
+  where
+    pickActiveCurrent rOk (_tsess, activeSubs) = do
+      ok <- readTVarIO $ Current.getConnections activeSubs
+      let num = fromIntegral (M.size ok) * rOk :: Float
+      let ok' = take (round num) $ M.keys ok
+      pure (ok', activeSubs)
+    benchResubCurrent (okConns, activeSubs) = do
+      cs <- readTVarIO $ Current.getConnections activeSubs
+      let conns = filter (`M.notMember` cs) okConns
+      unless (null conns) $ pure ()
+
+type TSessKey = (UserId, SMPServer, Maybe ConnId)
+
+prepareCurrent :: IO (TSessKey, Current.TRcvQueues)
+prepareCurrent = prepareWith Current.empty Current.addQueue
+
+prepareCurrentBatch :: IO (TSessKey, Current.TRcvQueues)
+prepareCurrentBatch = prepareQueues Current.empty Current.batchAddQueues
+
+prepareWith :: STM qs -> (RcvQueue -> qs -> STM ()) -> IO (TSessKey, qs)
+prepareWith initQS addQueue = prepareQueues initQS (\trqs qs -> mapM_ (`addQueue` trqs) qs)
+
+prepareQueues :: STM qs -> (qs -> [RcvQueue] -> STM ()) -> IO (TSessKey, qs)
+prepareQueues initQS addQueues = do
+  let (servers, gen1) = genServers gen0 nServers
+  let (qs, _gen2) = genQueues gen1 servers nUsers nQueues
+  atomically $ do
+    trqs <- initQS
+    addQueues trqs qs
+    pure (fmap (const Nothing) . Current.qKey $ head qs, trqs)
+  where
+    nUsers = 4
+    nServers = 10
+    nQueues = 10000
+
+genServers :: ChaChaDRG -> Int -> ([SMPServer], ChaChaDRG)
+genServers random nServers =
+  withDRG random . replicateM nServers $ do
+    host <- THOnionHost <$> getRandomBytes 32
+    keyHash <- C.KeyHash <$> getRandomBytes 64
+    pure ProtocolServer {scheme = SPSMP, host = pure host, port = "12345", keyHash}
+
+genQueues :: ChaChaDRG -> [SMPServer] -> Int -> Int -> ([RcvQueue], ChaChaDRG)
+genQueues random servers nUsers nQueues =
+  withDRG random . replicateM nQueues $ do
+    userRandom <- hash @ByteString <$> getRandomBytes 8
+    let userId = fromIntegral $ userRandom `mod` nUsers
+    connId <- getRandomBytes 10
+    serverRandom <- hash @ByteString <$> getRandomBytes 8
+    let server = servers !! (serverRandom `mod` nServers)
+    pure
+      RcvQueue
+        { userId,
+          connId,
+          server,
+          rcvId = "",
+          rcvPrivateKey = C.APrivateAuthKey C.SEd25519 "MC4CAQAwBQYDK2VwBCIEIDfEfevydXXfKajz3sRkcQ7RPvfWUPoq6pu1TYHV1DEe",
+          rcvDhSecret = "01234567890123456789012345678901",
+          e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk",
+          e2eDhSecret = Nothing,
+          sndId = "",
+          status = New,
+          dbQueueId = DBQueueId 0,
+          primary = True,
+          dbReplaceQueueId = Nothing,
+          rcvSwchStatus = Nothing,
+          smpClientVersion = currentSMPClientVersion,
+          clientNtfCreds = Nothing,
+          deleteErrors = 0
+        }
+  where
+    nServers = length servers
+
+gen0 :: ChaChaDRG
+gen0 = drgNewSeed (seedFromInteger 100500)

cabal.project

@@ -28,3 +28,8 @@ source-repository-package
     type: git
     location: https://github.com/simplex-chat/sqlcipher-simple.git
     tag: a46bd361a19376c5211f1058908fc0ae6bf42446
+
+source-repository-package
+    type: git
+    location: https://github.com/emilypi/base64.git
+    tag: e67505b35084040c91c833bae6a9e6592863fd04

package.yaml

@@ -42,6 +42,7 @@ dependencies:
   - crypton-x509-validation == 1.6.*
   - cryptostore == 0.3.*
   - data-default == 0.7.*
+  - deepseq == 1.4.*
   - direct-sqlcipher == 2.3.*
   - directory == 1.3.*
   - filepath == 1.4.*
@@ -160,7 +161,6 @@ tests:
     main: Test.hs
     dependencies:
       - simplexmq
-      - deepseq == 1.4.*
       - generic-random == 1.5.*
       - hspec == 2.11.*
       - hspec-core == 2.11.*
@@ -175,6 +175,31 @@ tests:
       - -with-rtsopts=-A64M
       - -with-rtsopts=-N1
 
+benchmarks:
+  simplexmq-bench:
+    source-dirs: benchmarks
+    main: Bench.hs
+    dependencies:
+      - base64 >= 1.0
+      - base64-bytestring
+      - containers
+      - hashable == 1.4.*
+      - hspec
+      - simplexmq
+      - tasty
+      - tasty-bench
+      - tasty-hspec
+      - unliftio
+      - unordered-containers
+      - zstd
+    ghc-options:
+      - -fproc-alignment=64
+      - -rtsopts
+      - -threaded
+      - -with-rtsopts=-A64m
+      - -with-rtsopts=-N1
+      - -with-rtsopts=-T
+
 ghc-options:
   # - -haddock
   - -Wall

simplexmq.cabal

@@ -200,6 +200,7 @@ library
     , crypton-x509-validation ==1.6.*
     , cryptostore ==0.3.*
     , data-default ==0.7.*
+    , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
@@ -274,6 +275,7 @@ executable ntf-server
     , crypton-x509-validation ==1.6.*
     , cryptostore ==0.3.*
     , data-default ==0.7.*
+    , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
@@ -349,6 +351,7 @@ executable smp-agent
     , crypton-x509-validation ==1.6.*
     , cryptostore ==0.3.*
     , data-default ==0.7.*
+    , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
@@ -424,6 +427,7 @@ executable smp-server
     , crypton-x509-validation ==1.6.*
     , cryptostore ==0.3.*
     , data-default ==0.7.*
+    , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
@@ -499,6 +503,7 @@ executable xftp
     , crypton-x509-validation ==1.6.*
     , cryptostore ==0.3.*
     , data-default ==0.7.*
+    , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
@@ -574,6 +579,7 @@ executable xftp-server
     , crypton-x509-validation ==1.6.*
     , cryptostore ==0.3.*
     , data-default ==0.7.*
+    , deepseq ==1.4.*
     , direct-sqlcipher ==2.3.*
     , directory ==1.3.*
     , filepath ==1.4.*
@@ -736,3 +742,93 @@ test-suite simplexmq-test
         bytestring ==0.10.*
       , template-haskell ==2.16.*
       , text >=1.2.3.0 && <1.3
+
+benchmark simplexmq-bench
+  type: exitcode-stdio-1.0
+  main-is: Bench.hs
+  other-modules:
+      Bench.Base64
+      Bench.BsConcat
+      Bench.Compression
+      Bench.Crypto.Lazy
+      Bench.SNTRUP761
+      Bench.TRcvQueues
+      Paths_simplexmq
+  hs-source-dirs:
+      benchmarks
+  default-extensions:
+      StrictData
+  ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -O2 -fproc-alignment=64 -rtsopts -threaded -with-rtsopts=-A64m -with-rtsopts=-N1 -with-rtsopts=-T
+  build-depends:
+      aeson ==2.2.*
+    , 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 >=1.0
+    , base64-bytestring
+    , case-insensitive ==1.2.*
+    , composition ==1.0.*
+    , constraints >=0.12 && <0.14
+    , containers
+    , crypton ==0.34.*
+    , crypton-x509 ==1.7.*
+    , crypton-x509-store ==1.6.*
+    , crypton-x509-validation ==1.6.*
+    , cryptostore ==0.3.*
+    , data-default ==0.7.*
+    , deepseq ==1.4.*
+    , direct-sqlcipher ==2.3.*
+    , directory ==1.3.*
+    , filepath ==1.4.*
+    , hashable ==1.4.*
+    , hourglass ==0.2.*
+    , hspec
+    , http-types ==0.12.*
+    , http2 >=4.2.2 && <4.3
+    , ini ==0.4.1
+    , iproute ==1.7.*
+    , iso8601-time ==0.1.*
+    , memory ==0.18.*
+    , mtl >=2.3.1 && <3.0
+    , network >=3.1.2.7 && <3.2
+    , network-info ==0.2.*
+    , network-transport ==0.5.6
+    , network-udp ==0.0.*
+    , 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.*
+    , tasty
+    , tasty-bench
+    , tasty-hspec
+    , temporary ==1.3.*
+    , time ==1.12.*
+    , time-manager ==0.0.*
+    , tls >=1.7.0 && <1.8
+    , transformers ==0.6.*
+    , unliftio
+    , unliftio-core ==0.2.*
+    , unordered-containers
+    , websockets ==0.12.*
+    , yaml ==0.11.*
+    , zstd
+  default-language: Haskell2010
+  if flag(swift)
+    cpp-options: -DswiftJSON
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , template-haskell ==2.20.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , template-haskell ==2.16.*
+      , text >=1.2.3.0 && <1.3

src/Simplex/FileTransfer/Crypto.hs

@@ -57,9 +57,9 @@ decryptChunks :: Int64 -> [FilePath] -> C.SbKey -> C.CbNonce -> (String -> Excep
 decryptChunks _ [] _ _ _ = throwError $ FTCEInvalidHeader "empty"
 decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse chPaths of
   [] -> do
-    (!authOk, !f) <- liftEither . first FTCECryptoError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (LB.readFile chPath)
+    (!authOk, f) <- liftEither . first FTCECryptoError . LC.sbDecryptTailTag key nonce (encSize - authTagSize) =<< liftIO (LB.readFile chPath)
     unless authOk $ throwError FTCEInvalidAuthTag
-    (FileHeader {fileName}, !f') <- parseFileHeader f
+    (FileHeader {fileName}, f') <- parseFileHeader f
     destFile <- withExceptT FTCEFileIOError $ getDestFile fileName
     CF.writeFile destFile f'
     pure destFile
@@ -79,24 +79,33 @@ decryptChunks encSize (chPath : chPaths) key nonce getDestFile = case reverse ch
       decryptFirstChunk = do
         sb <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
         ch <- liftIO $ LB.readFile chPath
-        let (ch1, !sb') = LC.sbDecryptChunkLazy sb ch
+        -- let (ch1, !sb') = LC.sbDecryptChunkLazy sb ch
+        sbFin <- newEmptyMVar
+        ch1 <- LC.secretBoxLazyM (\st -> pure . LC.sbDecryptChunk st) (putMVar sbFin) sb ch
         (!expectedLen, ch2) <- liftEitherWith FTCECryptoError $ LC.splitLen ch1
         let len1 = LB.length ch2
+        sb' <- takeMVar sbFin
         pure ((sb', len1), expectedLen, ch2)
       decryptChunk h (!sb, !len) chPth = do
         ch <- LB.readFile chPth
+        sbFin <- newEmptyMVar
+        ch' <- LC.secretBoxLazyM (\st -> pure . LC.sbDecryptChunk st) (putMVar sbFin) sb ch
         let len' = len + LB.length ch
-            (ch', sb') = LC.sbDecryptChunkLazy sb ch
+            -- (ch', sb') = LC.sbDecryptChunkLazy sb ch
         CF.hPut h ch'
+        sb' <- takeMVar sbFin
         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
+            -- (ch2, sb') = LC.sbDecryptChunkLazy sb ch1
+        sbFin <- newEmptyMVar
+        ch2 <- LC.secretBoxLazyM (\st -> pure . LC.sbDecryptChunk st) (putMVar sbFin) sb ch1
+        let len' = len + LB.length ch2
             ch3 = LB.take (LB.length ch2 - len' + expectedLen) ch2
-            tag :: ByteString = BA.convert (LC.sbAuth sb')
+        sb' <- takeMVar sbFin
+        let tag :: ByteString = BA.convert (LC.sbAuth sb')
         CF.hPut h ch3
         CF.hPutTag h
         pure $ B.length tag'' == 16 && BA.constEq tag'' tag

src/Simplex/Messaging/Agent/TRcvQueues.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE StrictData #-}
 
 module Simplex.Messaging.Agent.TRcvQueues
   ( TRcvQueues (getRcvQueues, getConnections),
@@ -16,6 +17,7 @@ module Simplex.Messaging.Agent.TRcvQueues
 where
 
 import Control.Concurrent.STM
+import Control.DeepSeq (NFData (..))
 import Data.Foldable (foldl')
 import Data.List.NonEmpty (NonEmpty (..), (<|))
 import qualified Data.List.NonEmpty as L
@@ -33,6 +35,8 @@ data TRcvQueues = TRcvQueues
     getConnections :: TMap ConnId (NonEmpty (UserId, SMPServer, RecipientId))
   }
 
+instance NFData TRcvQueues where rnf TRcvQueues {} = ()
+
 empty :: STM TRcvQueues
 empty = TRcvQueues <$> TM.empty <*> TM.empty
 

src/Simplex/Messaging/Compression.hs

@@ -51,10 +51,18 @@ compress1 bs
 type CompressCtx = (Ptr Z.CCtx, Ptr CChar, CSize)
 
 withCompressCtx :: CSize -> (CompressCtx -> IO a) -> IO a
-withCompressCtx scratchSize action =
-  bracket Z.createCCtx Z.freeCCtx $ \cctx ->
-    allocaBytes (fromIntegral scratchSize) $ \scratchPtr ->
-      action (cctx, scratchPtr, scratchSize)
+withCompressCtx scratchSize = bracket (createCompressCtx scratchSize) freeCompressCtx
+
+createCompressCtx :: CSize -> IO CompressCtx
+createCompressCtx scratchSize = do
+  ctx <- Z.createCCtx
+  scratch <- mallocBytes (fromIntegral scratchSize)
+  pure (ctx, scratch, scratchSize)
+
+freeCompressCtx :: CompressCtx -> IO ()
+freeCompressCtx (ctx, scratch, _) = do
+  free scratch
+  Z.freeCCtx ctx
 
 -- | Compress bytes, falling back to Passthrough in case of some internal error.
 compress :: CompressCtx -> ByteString -> IO Compressed

src/Simplex/Messaging/Crypto/File.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BangPatterns #-}
 
 module Simplex.Messaging.Crypto.File
   ( CryptoFile (..),
@@ -8,6 +9,7 @@ module Simplex.Messaging.Crypto.File
     CryptoFileHandle (..),
     FTCryptoError (..),
     Simplex.Messaging.Crypto.File.readFile,
+    streamFromFile,
     Simplex.Messaging.Crypto.File.writeFile,
     withFile,
     hPut,
@@ -29,7 +31,6 @@ import qualified Data.ByteArray as BA
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
-import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe (isJust)
 import Simplex.Messaging.Client.Agent ()
 import qualified Simplex.Messaging.Crypto as C
@@ -41,6 +42,8 @@ import System.Directory (getFileSize)
 import UnliftIO (Handle, IOMode (..), liftIO)
 import qualified UnliftIO as IO
 import UnliftIO.STM
+import GHC.IO (unsafeInterleaveIO)
+import Data.ByteString.Builder.Extra (defaultChunkSize)
 
 -- Possibly encrypted local file
 data CryptoFile = CryptoFile {filePath :: FilePath, cryptoArgs :: Maybe CryptoFileArgs}
@@ -53,22 +56,71 @@ data CryptoFileHandle = CFHandle Handle (Maybe (TVar LC.SbState))
 
 readFile :: CryptoFile -> ExceptT FTCryptoError IO LazyByteString
 readFile (CryptoFile path cfArgs) = do
+  fileLen <- liftIO $ getFileSize path
   s <- liftIO $ LB.readFile path
   case cfArgs of
-    Just (CFArgs (C.SbKey key) (C.CbNonce nonce)) -> do
-      let len = LB.length s - fromIntegral C.authTagSize
+    Just (CFArgs key nonce) -> do
+      let len = fromInteger fileLen - fromIntegral C.authTagSize
       when (len < 0) $ throwError FTCEInvalidFileSize
       let (s', tag') = LB.splitAt len s
-      (tag :| cs) <- liftEitherWith FTCECryptoError $ LC.secretBox LC.sbDecryptChunk key nonce s'
+      st0 <- liftEitherWith FTCECryptoError $ LC.sbInit key nonce
+      tagVar <- IO.newEmptyMVar
+      cs <- LC.secretBoxLazyM (\st -> pure . LC.sbDecryptChunk st) (IO.putMVar tagVar . LC.sbAuth) st0 s'
+      tag <- IO.takeMVar tagVar
       unless (BA.constEq (LB.toStrict tag') tag) $ throwError FTCEInvalidAuthTag
-      pure $ LB.fromChunks cs
+      pure cs
     Nothing -> pure s
 
+streamFromFile :: CryptoFile -> (LazyByteString -> IO ()) -> ExceptT FTCryptoError IO ()
+streamFromFile (CryptoFile path cfArgs) stepF = do
+  case cfArgs of
+    Nothing -> liftIO (LB.readFile path) >>= liftIO . stepF
+    Just (CFArgs key nonce) -> do
+      fileLen <- liftIO $ getFileSize path
+      let len = fileLen - fromIntegral C.authTagSize
+      when (len < 0) $ throwError FTCEInvalidFileSize
+      ---
+      tag' <- liftIO . IO.withFile path IO.ReadMode $ \h -> do
+        IO.hSeek h IO.AbsoluteSeek len
+        B.hGet h $ fromIntegral C.authTagSize
+      ---
+      sv <- IO.newIORef =<< liftEitherWith FTCECryptoError (LC.sbInit key nonce)
+      tag <- liftIO . IO.withFile path IO.ReadMode $ \h ->
+        hGetN defaultChunkSize h (fromInteger len) (step' sv) (LC.sbAuth <$> IO.readIORef sv)
+        -- unsafeInterleaveIO (LB.hGet h (fromInteger len)) >>= LB.foldrChunks (step sv) (LC.sbAuth <$> IO.readIORef sv)
+      ---
+      -- liftIO $ print (tag', BA.convert tag :: ByteString)
+      unless (BA.constEq tag' tag) $ throwError FTCEInvalidAuthTag
+  where
+    step' :: IO.IORef LC.SbState -> ByteString -> IO ()
+    step' sv chunk = do
+      st <- IO.readIORef sv
+      let (dc, !st') = LC.sbDecryptChunk st chunk
+      IO.writeIORef sv st'
+      stepF (LB.fromStrict dc)
+    -- step :: IO.IORef LC.SbState -> ByteString -> IO a -> IO a
+    -- step sv chunk next = do
+    --   st <- IO.readIORef sv
+    --   let (dc, st') = LC.sbDecryptChunk st chunk
+    --   st' `seq` IO.writeIORef sv st'
+    --   stepF (LB.fromStrict dc)
+    --   next
+    -- hGetN :: Int -> Handle -> Int -> IO ByteString
+    hGetN k h n step done | n > 0 = foldChunks n
+      where
+        foldChunks !i = do
+            c <- B.hGet h (min k i)
+            case B.length c of
+              0 -> done
+              m -> step c >> foldChunks (i - m)
+    hGetN _ _ 0 _ done = done
+    hGetN _ _ _ _ _ = error "hGetN: illegal buffer size"
+
 writeFile :: CryptoFile -> LazyByteString -> ExceptT FTCryptoError IO ()
 writeFile (CryptoFile path cfArgs) s = do
   s' <- case cfArgs of
     Just (CFArgs (C.SbKey key) (C.CbNonce nonce)) ->
-      liftEitherWith FTCECryptoError $ LB.fromChunks <$> LC.secretBoxTailTag LC.sbEncryptChunk key nonce s
+      liftEitherWith FTCECryptoError $ LC.secretBoxTailTag LC.sbEncryptChunk key nonce s
     Nothing -> pure s
   liftIO $ LB.writeFile path s'
 
@@ -79,9 +131,23 @@ withFile (CryptoFile path cfArgs) mode action = do
   ExceptT . IO.withFile path mode $ \h -> runExceptT $ action $ CFHandle h sb
 
 hPut :: CryptoFileHandle -> LazyByteString -> IO ()
-hPut (CFHandle h sb_) s = LB.hPut h =<< maybe (pure s) encrypt sb_
+hPut (CFHandle h sb_) s = maybe (LB.hPut h s) encrypt sb_ -- XXX: not thread-safe unless state is TMVar
   where
-    encrypt sb = atomically $ stateTVar sb (`LC.sbEncryptChunkLazy` s)
+    encrypt :: TVar LC.SbState -> IO ()
+    encrypt var = do
+      st <- readTVarIO var
+      void $ LC.secretBoxLazyM step (atomically . writeTVar var) st s
+      where
+        step st chunk = do
+          let (chunk', st') = LC.sbEncryptChunk st chunk
+          B.hPut h chunk'
+          pure (chunk', st')
+
+-- hPut :: CryptoFileHandle -> LazyByteString -> IO ()
+-- hPut (CFHandle h sb_) s = LB.hPut h =<< maybe (pure s) encrypt sb_
+--   where
+--     encrypt :: TVar LC.SbState -> IO LazyByteString
+--     encrypt sb = atomically $ stateTVar sb (`LC.sbEncryptChunkLazy` s)
 
 hPutTag :: CryptoFileHandle -> IO ()
 hPutTag (CFHandle h sb_) = forM_ sb_ $ B.hPut h . BA.convert . LC.sbAuth <=< readTVarIO

src/Simplex/Messaging/Crypto/Lazy.hs

@@ -11,23 +11,25 @@ module Simplex.Messaging.Crypto.Lazy
     pad,
     unPad,
     splitLen,
-    sbEncrypt,
-    sbDecrypt,
+    -- sbEncrypt,
+    -- sbDecrypt,
     sbEncryptTailTag,
     kcbEncryptTailTag,
     sbDecryptTailTag,
     kcbDecryptTailTag,
     fastReplicate,
-    secretBox,
+    -- secretBox,
     secretBoxTailTag,
+    secretBoxLazy_,
+    secretBoxLazyM,
     SbState,
     cbInit,
     sbInit,
     kcbInit,
     sbEncryptChunk,
     sbDecryptChunk,
-    sbEncryptChunkLazy,
-    sbDecryptChunkLazy,
+    -- sbEncryptChunkLazy,
+    -- sbDecryptChunkLazy,
     sbAuth,
     LazyByteString,
   )
@@ -38,20 +40,18 @@ import qualified Crypto.Error as CE
 import Crypto.Hash (Digest, hashlazy)
 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 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 (..), DhSecret (..), DhSecretX25519, SbKey, pattern CbNonce, pattern SbKey)
 import Simplex.Messaging.Crypto.SNTRUP761 (KEMHybridSecret (..))
 import Simplex.Messaging.Encoding
+import GHC.Stack (HasCallStack)
 
 type LazyByteString = LB.ByteString
 
@@ -100,33 +100,34 @@ splitLen padded
   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) (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@ 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) (CbNonce nonce) msg len paddedLen =
+--   prependTag <$> (secretBox sbEncryptChunk key nonce =<< pad msg len paddedLen)
+--   where
+--     prependTag (tag, cs) = LB.Chunk tag 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) (CbNonce nonce) packet
-  | LB.length tag' < 16 = Left CBDecryptError
-  | 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
+-- -- | 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) (CbNonce nonce) packet
+--   | LB.length tag' < 16 = Left CBDecryptError
+--   | otherwise = case secretBox sbDecryptChunk key nonce c of
+--       Right (tag, cs)
+--         | BA.constEq (LB.toStrict tag') tag -> unPad cs
+--         | otherwise -> Left CBDecryptError
+--       Left e -> Left e
+--   where
+--     (tag', c) = LB.splitAt 16 packet
 
-secretBox :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (NonEmpty ByteString)
+secretBox :: (ByteArrayAccess key, HasCallStack) => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError (ByteString, LazyByteString)
 secretBox sbProcess secret nonce msg = run <$> sbInit_ secret nonce
   where
-    run state =
-      let (!cs, !state') = secretBoxLazy_ sbProcess state msg
-       in BA.convert (sbAuth state') :| reverse cs
+    run state = undefined
+
+-- let (!cs, !state') = secretBoxLazy_ sbProcess state msg
+--  in BA.convert (sbAuth state') :| reverse cs
 
 -- | 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
@@ -140,7 +141,7 @@ kcbEncryptTailTag (KEMHybridSecret key) = sbEncryptTailTag_ key
 
 sbEncryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> LazyByteString -> Int64 -> Int64 -> Either CryptoError LazyByteString
 sbEncryptTailTag_ key (CbNonce nonce) msg len paddedLen =
-  LB.fromChunks <$> (secretBoxTailTag sbEncryptChunk key nonce =<< pad msg len paddedLen)
+  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.
@@ -158,25 +159,35 @@ kcbDecryptTailTag (KEMHybridSecret key) = sbDecryptTailTag_ key
 sbDecryptTailTag_ :: ByteArrayAccess key => key -> CbNonce -> Int64 -> LazyByteString -> Either CryptoError (Bool, LazyByteString)
 sbDecryptTailTag_ key (CbNonce nonce) paddedLen packet =
   case secretBox sbDecryptChunk key nonce c of
-    Right (tag :| cs) ->
+    Right (tag, cs) ->
       let valid = LB.length tag' == 16 && BA.constEq (LB.toStrict tag') tag
-       in (valid,) <$> unPad (LB.fromChunks cs)
+       in (valid,) <$> unPad cs
     Left e -> Left e
   where
     (c, tag') = LB.splitAt paddedLen packet
 
-secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError [ByteString]
-secretBoxTailTag sbProcess secret nonce msg = run <$> sbInit_ secret nonce
+secretBoxTailTag :: ByteArrayAccess key => (SbState -> ByteString -> (ByteString, SbState)) -> key -> ByteString -> LazyByteString -> Either CryptoError LazyByteString
+secretBoxTailTag sbProcess secret nonce msg = (\st -> secretBoxLazy_ sbProcess sbFinish st msg) <$> sbInit_ secret nonce
   where
-    run state =
-      let (cs, state') = secretBoxLazy_ sbProcess state msg
-       in reverse $ BA.convert (sbAuth state') : cs
+    sbFinish = LB.fromStrict . BA.convert . sbAuth
 
--- 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 = LB.foldlChunks update ([], state)
+secretBoxLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> (SbState -> LazyByteString) -> SbState -> LazyByteString -> LazyByteString
+secretBoxLazy_ sbProcess sbFinish = go
   where
-    update (cs, st) chunk = let (!c, !st') = sbProcess st chunk in (c : cs, st')
+    go st = \case
+      LB.Empty -> sbFinish st
+      LB.Chunk chunk next ->
+        let (chunk', st') = sbProcess st chunk
+         in LB.chunk chunk' (go st' next)
+
+secretBoxLazyM :: Monad m => (SbState -> ByteString -> m (ByteString, SbState)) -> (SbState -> m ()) -> SbState -> LB.ByteString -> m LB.ByteString
+secretBoxLazyM sbProcess sbFinish = go
+  where
+    go st = \case
+      LB.Empty -> LB.Empty <$ sbFinish st
+      LB.Chunk chunk next -> do
+        (chunk', st') <- sbProcess st chunk
+        LB.chunk chunk' <$> go st' next
 
 type SbState = (XSalsa.State, Poly1305.State)
 
@@ -201,15 +212,15 @@ sbInit_ secret nonce = (state2,) <$> cryptoPassed (Poly1305.initialize rs)
     state1 = XSalsa.derive state0 iv1
     (rs :: ByteString, state2) = XSalsa.generate state1 32
 
-sbEncryptChunkLazy :: SbState -> LazyByteString -> (LazyByteString, SbState)
-sbEncryptChunkLazy = sbProcessChunkLazy_ sbEncryptChunk
+-- sbEncryptChunkLazy :: HasCallStack => SbState -> LazyByteString -> (LazyByteString, SbState)
+-- sbEncryptChunkLazy = undefined -- secretBoxLazy_ sbEncryptChunk sbFinish
 
-sbDecryptChunkLazy :: SbState -> LazyByteString -> (LazyByteString, SbState)
-sbDecryptChunkLazy = sbProcessChunkLazy_ sbDecryptChunk
+-- sbDecryptChunkLazy :: HasCallStack => SbState -> LazyByteString -> (LazyByteString, SbState)
+-- sbDecryptChunkLazy = undefined -- secretBoxLazy_ sbDecryptChunk sbFinish
 
-sbProcessChunkLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> (LazyByteString, SbState)
-sbProcessChunkLazy_ = first (LB.fromChunks . reverse) .:. secretBoxLazy_
-{-# INLINE sbProcessChunkLazy_ #-}
+-- sbProcessChunkLazy_ :: (SbState -> ByteString -> (ByteString, SbState)) -> SbState -> LazyByteString -> (LazyByteString, SbState)
+-- sbProcessChunkLazy_ = first LB.fromChunks .:. secretBoxLazy_
+-- {-# INLINE sbProcessChunkLazy_ #-}
 
 sbEncryptChunk :: SbState -> ByteString -> (ByteString, SbState)
 sbEncryptChunk (st, authSt) chunk =

src/Simplex/Messaging/Protocol.hs

@@ -123,6 +123,7 @@ module Simplex.Messaging.Protocol
     NMsgMeta (..),
     MsgFlags (..),
     initialSMPClientVersion,
+    currentSMPClientVersion,
     userProtocol,
     rcvMessageMeta,
     noMsgFlags,
@@ -167,6 +168,7 @@ module Simplex.Messaging.Protocol
 where
 
 import Control.Applicative (optional, (<|>))
+import Control.DeepSeq (NFData (..))
 import Control.Monad
 import Control.Monad.Except
 import Data.Aeson (FromJSON (..), ToJSON (..))
@@ -764,6 +766,8 @@ deriving instance Ord (SProtocolType p)
 
 deriving instance Show (SProtocolType p)
 
+instance NFData (SProtocolType p) where rnf spt = spt `seq` ()
+
 data AProtocolType = forall p. ProtocolTypeI p => AProtocolType (SProtocolType p)
 
 instance Eq AProtocolType where
@@ -848,6 +852,8 @@ data ProtocolServer p = ProtocolServer
 
 data AProtocolServer = forall p. ProtocolTypeI p => AProtocolServer (SProtocolType p) (ProtocolServer p)
 
+instance NFData (ProtocolServer p) where rnf ProtocolServer {} = ()
+
 instance ProtocolTypeI p => IsString (ProtocolServer p) where
   fromString = parseString strDecode
 

tests/CoreTests/CryptoFileTests.hs

@@ -16,7 +16,7 @@ import System.Directory (getFileSize)
 import Test.Hspec
 
 cryptoFileTests :: Spec
-cryptoFileTests = do
+cryptoFileTests = focus $ do
   it "should write/read file" testWriteReadFile
   it "should put/get file" testPutGetFile
   it "should write/get file" testWriteGetFile

tests/CoreTests/CryptoTests.hs

@@ -154,33 +154,33 @@ testSecretBox = it "should encrypt / decrypt string with a random symmetric key"
         plain = C.sbDecrypt k nonce =<< cipher
      in isRight cipher && cipher /= plain && Right b == plain
 
-testLazySecretBox :: Spec
-testLazySecretBox = it "should lazily encrypt / decrypt string with a random symmetric key" . ioProperty $ do
-  g <- C.newRandom
-  k <- atomically $ C.randomSbKey g
-  nonce <- atomically $ C.randomCbNonce g
-  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.sbEncrypt k nonce b len paddedLen
-        plain = LC.sbDecrypt k nonce =<< cipher
-     in isRight cipher && cipher /= plain && Right b == plain
+-- testLazySecretBox :: Spec
+-- testLazySecretBox = it "should lazily encrypt / decrypt string with a random symmetric key" . ioProperty $ do
+--   g <- C.newRandom
+--   k <- atomically $ C.randomSbKey g
+--   nonce <- atomically $ C.randomCbNonce g
+--   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.sbEncrypt k nonce b len paddedLen
+--         plain = LC.sbDecrypt k nonce =<< cipher
+--      in isRight cipher && cipher /= plain && Right b == plain
 
-testLazySecretBoxFile :: Spec
-testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random symmetric key" $ do
-  g <- C.newRandom
-  k <- atomically $ C.randomSbKey g
-  nonce <- atomically $ C.randomCbNonce g
-  let f = "tests/tmp/testsecretbox"
-      paddedLen = 4 * 1024 * 1024
-      len = 4 * 1000 * 1000 :: Int64
-      s = LC.fastReplicate len 'a'
-  Right s' <- pure $ LC.sbEncrypt k nonce s len paddedLen
-  LB.writeFile (f <> ".encrypted") s'
-  Right s'' <- LC.sbDecrypt k nonce <$> LB.readFile (f <> ".encrypted")
-  s'' `shouldBe` s
+-- testLazySecretBoxFile :: Spec
+-- testLazySecretBoxFile = it "should lazily encrypt / decrypt file with a random symmetric key" $ do
+--   g <- C.newRandom
+--   k <- atomically $ C.randomSbKey g
+--   nonce <- atomically $ C.randomCbNonce g
+--   let f = "tests/tmp/testsecretbox"
+--       paddedLen = 4 * 1024 * 1024
+--       len = 4 * 1000 * 1000 :: Int64
+--       s = LC.fastReplicate len 'a'
+--   Right s' <- pure $ LC.sbEncrypt k nonce s len paddedLen
+--   LB.writeFile (f <> ".encrypted") 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