From 5baffbb3700c3fc6fb465da9579f892c74a38005 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Mon, 26 Feb 2024 13:02:50 +0200 Subject: [PATCH 1/8] package: add benchmark target --- benchmarks/Bench.hs | 17 +++ benchmarks/Bench/TRcvQueues.hs | 137 ++++++++++++++++++++++ package.yaml | 24 +++- simplexmq.cabal | 87 ++++++++++++++ src/Simplex/Messaging/Agent/TRcvQueues.hs | 4 + src/Simplex/Messaging/Protocol.hs | 5 + 6 files changed, 273 insertions(+), 1 deletion(-) create mode 100644 benchmarks/Bench.hs create mode 100644 benchmarks/Bench/TRcvQueues.hs diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs new file mode 100644 index 000000000..67094ce94 --- /dev/null +++ b/benchmarks/Bench.hs @@ -0,0 +1,17 @@ +{- 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 Test.Tasty.Bench +import Bench.TRcvQueues + +main :: IO () +main = defaultMain + [ bgroup "TRcvQueues" benchTRcvQueues + ] diff --git a/benchmarks/Bench/TRcvQueues.hs b/benchmarks/Bench/TRcvQueues.hs new file mode 100644 index 000000000..bb911b1be --- /dev/null +++ b/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 (..)) +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 = 123, + clientNtfCreds = Nothing, + deleteErrors = 0 + } + where + nServers = length servers + +gen0 :: ChaChaDRG +gen0 = drgNewSeed (seedFromInteger 100500) diff --git a/package.yaml b/package.yaml index 4dbc971a1..0f9d08936 100644 --- a/package.yaml +++ b/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.* @@ -159,7 +160,6 @@ tests: main: Test.hs dependencies: - simplexmq - - deepseq == 1.4.* - generic-random == 1.5.* - hspec == 2.11.* - hspec-core == 2.11.* @@ -169,6 +169,28 @@ tests: - main-tester == 0.2.* - timeit == 2.0.* +benchmarks: + simplexmq-bench: + source-dirs: benchmarks + main: Bench.hs + dependencies: + - containers + - hashable == 1.4.* + - hspec + - simplexmq + - tasty + - tasty-bench + - tasty-hspec + - unliftio + - unordered-containers + ghc-options: + - -fproc-alignment=64 + - -rtsopts + - -threaded + - -with-rtsopts=-A64m + - -with-rtsopts=-N1 + - -with-rtsopts=-T + ghc-options: # - -haddock - -Wall diff --git a/simplexmq.cabal b/simplexmq.cabal index 5a8d91390..e87150a36 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -194,6 +194,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.* @@ -265,6 +266,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.* @@ -337,6 +339,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.* @@ -409,6 +412,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.* @@ -481,6 +485,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.* @@ -553,6 +558,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.* @@ -709,3 +715,84 @@ 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.TRcvQueues + Paths_simplexmq + hs-source-dirs: + benchmarks + ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -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-bytestring >=1.0 && <1.3 + , 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.* + 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 diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs index 9ffe325b2..25256a5f5 100644 --- a/src/Simplex/Messaging/Agent/TRcvQueues.hs +++ b/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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index 315a4e5a3..3a2fa241e 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -160,6 +160,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 (..)) @@ -742,6 +743,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) deriving instance Show AProtocolType @@ -826,6 +829,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 From e7270900205b93af338cabe68f59d8ccfb0ed020 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Thu, 29 Feb 2024 16:23:10 +0200 Subject: [PATCH 2/8] add sntrup761 benchmark --- benchmarks/Bench.hs | 11 +++++++---- benchmarks/Bench/SNTRUP761.hs | 15 +++++++++++++++ simplexmq.cabal | 1 + 3 files changed, 23 insertions(+), 4 deletions(-) create mode 100644 benchmarks/Bench/SNTRUP761.hs diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs index 67094ce94..abfc9da9c 100644 --- a/benchmarks/Bench.hs +++ b/benchmarks/Bench.hs @@ -8,10 +8,13 @@ Pick one or group: cabal bench -O2 simplexmq-bench --benchmark-options "-p TRcvQ module Main where -import Test.Tasty.Bench +import Bench.SNTRUP761 import Bench.TRcvQueues +import Test.Tasty.Bench main :: IO () -main = defaultMain - [ bgroup "TRcvQueues" benchTRcvQueues - ] +main = + defaultMain + [ bgroup "TRcvQueues" benchTRcvQueues, + bgroup "SNTRUP761" benchSNTRUP761 + ] diff --git a/benchmarks/Bench/SNTRUP761.hs b/benchmarks/Bench/SNTRUP761.hs new file mode 100644 index 000000000..6b02e0bf5 --- /dev/null +++ b/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) + ] + ] diff --git a/simplexmq.cabal b/simplexmq.cabal index e87150a36..66b671139 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -720,6 +720,7 @@ benchmark simplexmq-bench type: exitcode-stdio-1.0 main-is: Bench.hs other-modules: + Bench.SNTRUP761 Bench.TRcvQueues Paths_simplexmq hs-source-dirs: From 1208df2344ed011ad1145624788131192eededaf Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Fri, 15 Mar 2024 19:41:47 +0200 Subject: [PATCH 3/8] bench: add compression --- benchmarks/Bench.hs | 4 ++- benchmarks/Bench/Compression.hs | 44 ++++++++++++++++++++++++++++ benchmarks/Bench/TRcvQueues.hs | 4 +-- package.yaml | 1 + simplexmq.cabal | 2 ++ src/Simplex/Messaging/Compression.hs | 18 +++++++++--- src/Simplex/Messaging/Protocol.hs | 1 + 7 files changed, 67 insertions(+), 7 deletions(-) create mode 100644 benchmarks/Bench/Compression.hs diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs index abfc9da9c..898f37080 100644 --- a/benchmarks/Bench.hs +++ b/benchmarks/Bench.hs @@ -8,6 +8,7 @@ Pick one or group: cabal bench -O2 simplexmq-bench --benchmark-options "-p TRcvQ module Main where +import Bench.Compression import Bench.SNTRUP761 import Bench.TRcvQueues import Test.Tasty.Bench @@ -16,5 +17,6 @@ main :: IO () main = defaultMain [ bgroup "TRcvQueues" benchTRcvQueues, - bgroup "SNTRUP761" benchSNTRUP761 + bgroup "SNTRUP761" benchSNTRUP761, + bgroup "Compression" benchCompression ] diff --git a/benchmarks/Bench/Compression.hs b/benchmarks/Bench/Compression.hs new file mode 100644 index 000000000..f1ac941e2 --- /dev/null +++ b/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"] diff --git a/benchmarks/Bench/TRcvQueues.hs b/benchmarks/Bench/TRcvQueues.hs index bb911b1be..ff43e40ae 100644 --- a/benchmarks/Bench/TRcvQueues.hs +++ b/benchmarks/Bench/TRcvQueues.hs @@ -13,7 +13,7 @@ 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 (..)) +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 @@ -126,7 +126,7 @@ genQueues random servers nUsers nQueues = primary = True, dbReplaceQueueId = Nothing, rcvSwchStatus = Nothing, - smpClientVersion = 123, + smpClientVersion = currentSMPClientVersion, clientNtfCreds = Nothing, deleteErrors = 0 } diff --git a/package.yaml b/package.yaml index 85a58d74f..66e3edecf 100644 --- a/package.yaml +++ b/package.yaml @@ -184,6 +184,7 @@ benchmarks: - tasty-hspec - unliftio - unordered-containers + - zstd ghc-options: - -fproc-alignment=64 - -rtsopts diff --git a/simplexmq.cabal b/simplexmq.cabal index 039c4abd0..d1938b27c 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -733,6 +733,7 @@ benchmark simplexmq-bench type: exitcode-stdio-1.0 main-is: Bench.hs other-modules: + Bench.Compression Bench.SNTRUP761 Bench.TRcvQueues Paths_simplexmq @@ -797,6 +798,7 @@ benchmark simplexmq-bench , unordered-containers , websockets ==0.12.* , yaml ==0.11.* + , zstd default-language: Haskell2010 if flag(swift) cpp-options: -DswiftJSON diff --git a/src/Simplex/Messaging/Compression.hs b/src/Simplex/Messaging/Compression.hs index fec9f8151..e73ab3444 100644 --- a/src/Simplex/Messaging/Compression.hs +++ b/src/Simplex/Messaging/Compression.hs @@ -38,13 +38,23 @@ instance Encoding Compressed where '1' -> Compressed <$> smpP x -> fail $ "unknown Compressed tag: " <> show x +-- ** Batch compression context + 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 diff --git a/src/Simplex/Messaging/Protocol.hs b/src/Simplex/Messaging/Protocol.hs index d583c0361..dcf48fa16 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -123,6 +123,7 @@ module Simplex.Messaging.Protocol NMsgMeta (..), MsgFlags (..), initialSMPClientVersion, + currentSMPClientVersion, userProtocol, rcvMessageMeta, noMsgFlags, From 50040231c7654cd654c64c88ad2f2d3a70d6c899 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Wed, 27 Mar 2024 14:24:37 +0200 Subject: [PATCH 4/8] add bs concat --- benchmarks/Bench.hs | 4 +++- benchmarks/Bench/BsConcat.hs | 23 +++++++++++++++++++++++ simplexmq.cabal | 1 + 3 files changed, 27 insertions(+), 1 deletion(-) create mode 100644 benchmarks/Bench/BsConcat.hs diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs index 898f37080..a175cd522 100644 --- a/benchmarks/Bench.hs +++ b/benchmarks/Bench.hs @@ -8,6 +8,7 @@ Pick one or group: cabal bench -O2 simplexmq-bench --benchmark-options "-p TRcvQ module Main where +import Bench.BsConcat import Bench.Compression import Bench.SNTRUP761 import Bench.TRcvQueues @@ -18,5 +19,6 @@ main = defaultMain [ bgroup "TRcvQueues" benchTRcvQueues, bgroup "SNTRUP761" benchSNTRUP761, - bgroup "Compression" benchCompression + bgroup "Compression" benchCompression, + bgroup "BsConcat" benchBsConcat ] diff --git a/benchmarks/Bench/BsConcat.hs b/benchmarks/Bench/BsConcat.hs new file mode 100644 index 000000000..c0f9ba166 --- /dev/null +++ b/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") + ] + ] diff --git a/simplexmq.cabal b/simplexmq.cabal index 79823b25b..240a76aea 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -733,6 +733,7 @@ benchmark simplexmq-bench type: exitcode-stdio-1.0 main-is: Bench.hs other-modules: + Bench.BsConcat Bench.Compression Bench.SNTRUP761 Bench.TRcvQueues From 0dbbf718ea59560b30375e9fff56e68544eee256 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Wed, 3 Apr 2024 12:31:30 +0300 Subject: [PATCH 5/8] add base64 case --- benchmarks/Bench.hs | 4 +++- benchmarks/Bench/Base64.hs | 49 ++++++++++++++++++++++++++++++++++++++ package.yaml | 34 +++++++++++++------------- simplexmq.cabal | 8 +++++-- 4 files changed, 76 insertions(+), 19 deletions(-) create mode 100644 benchmarks/Bench/Base64.hs diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs index a175cd522..4a3c375b2 100644 --- a/benchmarks/Bench.hs +++ b/benchmarks/Bench.hs @@ -8,6 +8,7 @@ Pick one or group: cabal bench -O2 simplexmq-bench --benchmark-options "-p TRcvQ module Main where +import Bench.Base64 import Bench.BsConcat import Bench.Compression import Bench.SNTRUP761 @@ -20,5 +21,6 @@ main = [ bgroup "TRcvQueues" benchTRcvQueues, bgroup "SNTRUP761" benchSNTRUP761, bgroup "Compression" benchCompression, - bgroup "BsConcat" benchBsConcat + bgroup "BsConcat" benchBsConcat, + bgroup "Base64" benchBase64 ] diff --git a/benchmarks/Bench/Base64.hs b/benchmarks/Bench/Base64.hs new file mode 100644 index 000000000..17e460795 --- /dev/null +++ b/benchmarks/Bench/Base64.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + +module Bench.Base64 where + +import Data.ByteString (ByteString) +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 + ] + ] + +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" diff --git a/package.yaml b/package.yaml index 0117bd99c..d6a821fc0 100644 --- a/package.yaml +++ b/package.yaml @@ -175,23 +175,25 @@ benchmarks: source-dirs: benchmarks main: Bench.hs dependencies: - - containers - - hashable == 1.4.* - - hspec - - simplexmq - - tasty - - tasty-bench - - tasty-hspec - - unliftio - - unordered-containers - - zstd + - base64 + - 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 + - -fproc-alignment=64 + - -rtsopts + - -threaded + - -with-rtsopts=-A64m + - -with-rtsopts=-N1 + - -with-rtsopts=-T ghc-options: # - -haddock diff --git a/simplexmq.cabal b/simplexmq.cabal index 13852b54a..99a61cf3f 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -749,6 +749,7 @@ benchmark simplexmq-bench type: exitcode-stdio-1.0 main-is: Bench.hs other-modules: + Bench.Base64 Bench.BsConcat Bench.Compression Bench.SNTRUP761 @@ -756,7 +757,9 @@ benchmark simplexmq-bench Paths_simplexmq hs-source-dirs: benchmarks - ghc-options: -Wall -Wcompat -Werror=incomplete-patterns -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -Wunused-type-patterns -fproc-alignment=64 -rtsopts -threaded -with-rtsopts=-A64m -with-rtsopts=-N1 -with-rtsopts=-T + 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 @@ -765,7 +768,8 @@ benchmark simplexmq-bench , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64-bytestring >=1.0 && <1.3 + , base64 + , base64-bytestring , case-insensitive ==1.2.* , composition ==1.0.* , constraints >=0.12 && <0.14 From 8ba036b594c9daf25122db125baf98dc7f59d9fa Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Wed, 3 Apr 2024 13:19:02 +0300 Subject: [PATCH 6/8] add parser bench --- benchmarks/Bench/Base64.hs | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/benchmarks/Bench/Base64.hs b/benchmarks/Bench/Base64.hs index 17e460795..2b3ff20f2 100644 --- a/benchmarks/Bench/Base64.hs +++ b/benchmarks/Bench/Base64.hs @@ -5,7 +5,10 @@ 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 @@ -36,9 +39,28 @@ benchBase64 = [ 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==" From f843752404a752c190334004ab4ca1557779c2e0 Mon Sep 17 00:00:00 2001 From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com> Date: Thu, 11 Apr 2024 20:17:49 +0300 Subject: [PATCH 7/8] pin base64 dep --- cabal.project | 5 +++++ package.yaml | 2 +- simplexmq.cabal | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/cabal.project b/cabal.project index 43afe30ea..557b458f2 100644 --- a/cabal.project +++ b/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 diff --git a/package.yaml b/package.yaml index 7bdba1b4d..5eac6776d 100644 --- a/package.yaml +++ b/package.yaml @@ -180,7 +180,7 @@ benchmarks: source-dirs: benchmarks main: Bench.hs dependencies: - - base64 + - base64 >= 1.0 - base64-bytestring - containers - hashable == 1.4.* diff --git a/simplexmq.cabal b/simplexmq.cabal index 2b1ee4477..d579f3a43 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -766,7 +766,7 @@ benchmark simplexmq-bench , async ==2.2.* , attoparsec ==0.14.* , base >=4.14 && <5 - , base64 + , base64 >=1.0 , base64-bytestring , case-insensitive ==1.2.* , composition ==1.0.* From 099ff67885e79f6ae96430a1a500b4b620332bfa Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin Date: Sat, 20 Jul 2024 21:06:19 +0100 Subject: [PATCH 8/8] update --- benchmarks/Bench/TRcvQueues.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/benchmarks/Bench/TRcvQueues.hs b/benchmarks/Bench/TRcvQueues.hs index ff43e40ae..ffea415b1 100644 --- a/benchmarks/Bench/TRcvQueues.hs +++ b/benchmarks/Bench/TRcvQueues.hs @@ -121,6 +121,7 @@ genQueues random servers nUsers nQueues = e2ePrivKey = "MC4CAQAwBQYDK2VuBCIEINCzbVFaCiYHoYncxNY8tSIfn0pXcIAhLBfFc0m+gOpk", e2eDhSecret = Nothing, sndId = "", + sndSecure = False, status = New, dbQueueId = DBQueueId 0, primary = True,