From edffa37841946faf2cb2c971a9c08db02e36a77d Mon Sep 17 00:00:00 2001
From: Alexander Bondarenko <486682+dpwiz@users.noreply.github.com>
Date: Tue, 4 Jun 2024 19:41:57 +0300
Subject: [PATCH] bench tweetnacl bindings

---
 benchmarks/Bench.hs             |  2 +
 benchmarks/Bench/Crypto.hs      | 75 +++++++++++++++++++++++++++++++++
 simplexmq.cabal                 |  3 +-
 src/Simplex/Messaging/Crypto.hs |  1 +
 4 files changed, 80 insertions(+), 1 deletion(-)
 create mode 100644 benchmarks/Bench/Crypto.hs

diff --git a/benchmarks/Bench.hs b/benchmarks/Bench.hs
index 4a3c375b2..22b99e9c0 100644
--- a/benchmarks/Bench.hs
+++ b/benchmarks/Bench.hs
@@ -11,6 +11,7 @@ module Main where
 import Bench.Base64
 import Bench.BsConcat
 import Bench.Compression
+import Bench.Crypto
 import Bench.SNTRUP761
 import Bench.TRcvQueues
 import Test.Tasty.Bench
@@ -20,6 +21,7 @@ main =
   defaultMain
     [ bgroup "TRcvQueues" benchTRcvQueues,
       bgroup "SNTRUP761" benchSNTRUP761,
+      bgroup "Crypto" benchCrypto,
       bgroup "Compression" benchCompression,
       bgroup "BsConcat" benchBsConcat,
       bgroup "Base64" benchBase64
diff --git a/benchmarks/Bench/Crypto.hs b/benchmarks/Bench/Crypto.hs
new file mode 100644
index 000000000..77491957a
--- /dev/null
+++ b/benchmarks/Bench/Crypto.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use camelCase" #-}
+
+module Bench.Crypto where
+
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.NaCl.Bindings
+import Test.Tasty.Bench
+
+import Control.Concurrent.STM (TVar)
+import Control.Monad.STM (atomically)
+import qualified Crypto.Cipher.XSalsa as XSalsa
+import qualified Crypto.MAC.Poly1305 as Poly1305
+import Crypto.Random (ChaChaDRG)
+import qualified Data.ByteArray as BA
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+-- import Test.Tasty (withResource)
+
+benchCrypto :: [Benchmark]
+benchCrypto =
+  [ bgroup
+      "cryptoBox"
+      [ env randomChunk $ bench "crypton" . nf cryptoBoxRef,
+        env randomChunk $ bcompare "crypton" . bench "tweetnacl" . nf cryptoBoxNaCl
+      ]
+  ]
+
+randomChunk :: IO (ByteString, ByteString, ByteString)
+randomChunk = do
+  g <- C.newRandom
+  (aPub :: C.PublicKeyX25519, _aPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+  (_bPub :: C.PublicKeyX25519, bPriv :: C.PrivateKeyX25519) <- atomically $ C.generateKeyPair g
+  let C.DhSecretX25519 sk = C.dh' aPub bPriv
+  -- let baShared = C.dh' bPub aPriv
+  C.CbNonce n <- atomically $ C.randomCbNonce g
+  msg <- atomically $ C.randomBytes 12345 g
+  pure (BA.convert sk, n, msg)
+
+cryptoBoxRef :: (ByteString, ByteString, ByteString) -> ByteString
+cryptoBoxRef (k, nonce', msg) = ref_cryptoBox k nonce' msg
+
+cryptoBoxNaCl :: (ByteString, ByteString, ByteString) -> ByteString
+cryptoBoxNaCl (k, nonce', msg) = C.cryptoBox k nonce' msg
+
+ref_cryptoBox :: BA.ByteArrayAccess key => key -> ByteString -> ByteString -> ByteString
+ref_cryptoBox secret nonce s = BA.convert tag <> c
+  where
+    (rs, c) = ref_xSalsa20 secret nonce s
+    tag = Poly1305.auth rs c
+
+-- | NaCl @crypto_box@ decrypt with a shared DH secret and 192-bit nonce (without unpadding).
+ref_sbDecryptNoPad_ :: BA.ByteArrayAccess key => key -> C.CbNonce -> ByteString -> Either C.CryptoError ByteString
+ref_sbDecryptNoPad_ secret (C.CbNonce nonce) packet
+  | B.length packet < 16 = Left C.CBDecryptError
+  | BA.constEq tag' tag = Right msg
+  | otherwise = Left C.CBDecryptError
+  where
+    (tag', c) = B.splitAt 16 packet
+    (rs, msg) = ref_xSalsa20 secret nonce c
+    tag = Poly1305.auth rs c
+
+ref_xSalsa20 :: BA.ByteArrayAccess key => key -> ByteString -> ByteString -> (ByteString, ByteString)
+ref_xSalsa20 secret nonce msg = (rs, msg')
+  where
+    zero = B.replicate 16 $ toEnum 0
+    (iv0, iv1) = B.splitAt 8 nonce
+    state0 = XSalsa.initialize 20 secret (zero `B.append` iv0)
+    state1 = XSalsa.derive state0 iv1
+    (rs, state2) = XSalsa.generate state1 32
+    (msg', _) = XSalsa.combine state2 msg
diff --git a/simplexmq.cabal b/simplexmq.cabal
index fd40a4f04..656fa7bfc 100644
--- a/simplexmq.cabal
+++ b/simplexmq.cabal
@@ -792,6 +792,7 @@ benchmark simplexmq-bench
       Bench.Base64
       Bench.BsConcat
       Bench.Compression
+      Bench.Crypto
       Bench.SNTRUP761
       Bench.TRcvQueues
       Paths_simplexmq
@@ -799,7 +800,7 @@ benchmark simplexmq-bench
       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
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=incomplete-uni-patterns -Werror=missing-methods -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -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
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index c7fc139b0..339661704 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -186,6 +186,7 @@ module Simplex.Messaging.Crypto
     unsafeMaxLenBS,
     appendMaxLenBS,
     hsalsa20,
+    cryptoBox,
     secretBox,
     secretBoxOpen,
   )