package: add benchmark target

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
+  ]

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)

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

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

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