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