diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs new file mode 100644 index 0000000000..4a3c375b2d --- /dev/null +++ b/benchmarks/Bench.hs @@ -0,0 +1,26 @@ +{- 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.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 + ] diff --git a/benchmarks/Bench/Base64.hs b/benchmarks/Bench/Base64.hs new file mode 100644 index 0000000000..2b3ff20f24 --- /dev/null +++ b/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" diff --git a/benchmarks/Bench/BsConcat.hs b/benchmarks/Bench/BsConcat.hs new file mode 100644 index 0000000000..c0f9ba1668 --- /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/benchmarks/Bench/Compression.hs b/benchmarks/Bench/Compression.hs new file mode 100644 index 0000000000..6597736d3e --- /dev/null +++ b/benchmarks/Bench/Compression.hs @@ -0,0 +1,30 @@ +{-# 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.Bench + +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 + ] + ] + +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/SNTRUP761.hs b/benchmarks/Bench/SNTRUP761.hs new file mode 100644 index 0000000000..6b02e0bf5c --- /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/benchmarks/Bench/TRcvQueues.hs b/benchmarks/Bench/TRcvQueues.hs new file mode 100644 index 0000000000..ffea415b14 --- /dev/null +++ b/benchmarks/Bench/TRcvQueues.hs @@ -0,0 +1,138 @@ +{-# 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 = "", + sndSecure = False, + 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) diff --git a/cabal.project b/cabal.project index 43afe30eae..557b458f21 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 d787d8f8a8..d301ffd933 100644 --- a/package.yaml +++ b/package.yaml @@ -44,6 +44,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.* @@ -162,7 +163,6 @@ tests: main: Test.hs dependencies: - simplexmq - - deepseq == 1.4.* - generic-random == 1.5.* - hspec == 2.11.* - hspec-core == 2.11.* @@ -177,6 +177,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 - -Weverything diff --git a/simplexmq.cabal b/simplexmq.cabal index 489b77eb55..696d3aee56 100644 --- a/simplexmq.cabal +++ b/simplexmq.cabal @@ -233,6 +233,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.* @@ -307,6 +308,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.* @@ -385,6 +387,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.* , file-embed @@ -464,6 +467,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.* @@ -539,6 +543,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.* @@ -701,3 +706,92 @@ 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.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 diff --git a/src/Simplex/Messaging/Agent/TRcvQueues.hs b/src/Simplex/Messaging/Agent/TRcvQueues.hs index 9ffe325b21..25256a5f5c 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 63e3e4d98d..4e7d34d5fd 100644 --- a/src/Simplex/Messaging/Protocol.hs +++ b/src/Simplex/Messaging/Protocol.hs @@ -181,6 +181,7 @@ module Simplex.Messaging.Protocol where import Control.Applicative (optional, (<|>)) +import Control.DeepSeq (NFData (..)) import Control.Exception (Exception) import Control.Monad import Control.Monad.Except @@ -898,6 +899,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 @@ -982,6 +985,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