{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Bench.Crypto.KES (
  benchmarks,
) where

import Data.Maybe (fromJust)
import Data.Proxy

import Control.DeepSeq

import Cardano.Crypto.DSIGN.Ed25519
import Cardano.Crypto.Hash.Blake2b
import Cardano.Crypto.KES.Class
import Cardano.Crypto.KES.CompactSum
import Cardano.Crypto.KES.Sum

import Cardano.Crypto.Libsodium as NaCl
import Cardano.Crypto.Libsodium.MLockedSeed
import Criterion
import qualified Data.ByteString as BS (ByteString)
import Data.Either (fromRight)
import Data.Kind (Type)
import GHC.TypeLits (KnownNat)
import System.IO.Unsafe (unsafePerformIO)

import Bench.Crypto.BenchData

{- HLINT ignore "Use camelCase" -}

{-# NOINLINE testSeedML #-}
testSeedML :: forall n. KnownNat n => MLockedSeed n
testSeedML :: forall (n :: Nat). KnownNat n => MLockedSeed n
testSeedML = MLockedSizedBytes n -> MLockedSeed n
forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed (MLockedSizedBytes n -> MLockedSeed n)
-> (IO (MLockedSizedBytes n) -> MLockedSizedBytes n)
-> IO (MLockedSizedBytes n)
-> MLockedSeed n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (MLockedSizedBytes n) -> MLockedSizedBytes n
forall a. IO a -> a
unsafePerformIO (IO (MLockedSizedBytes n) -> MLockedSeed n)
-> IO (MLockedSizedBytes n) -> MLockedSeed n
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (MLockedSizedBytes n)
forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
ByteString -> m (MLockedSizedBytes n)
NaCl.mlsbFromByteString ByteString
testBytes

benchmarks :: Benchmark
benchmarks :: Benchmark
benchmarks =
  String -> [Benchmark] -> Benchmark
bgroup
    String
"KES"
    [ forall (proxy :: forall k. k -> *) v.
(KESAlgorithm v, ContextKES v ~ (), Signable v ByteString,
 NFData (SignKeyKES v), NFData (SigKES v)) =>
proxy v -> String -> Benchmark
benchKES @Proxy @(Sum6KES Ed25519DSIGN Blake2b_256) Proxy (Sum6KES Ed25519DSIGN Blake2b_256)
forall {k} (t :: k). Proxy t
Proxy String
"Sum6KES"
    , forall (proxy :: forall k. k -> *) v.
(KESAlgorithm v, ContextKES v ~ (), Signable v ByteString,
 NFData (SignKeyKES v), NFData (SigKES v)) =>
proxy v -> String -> Benchmark
benchKES @Proxy @(Sum7KES Ed25519DSIGN Blake2b_256) Proxy (Sum7KES Ed25519DSIGN Blake2b_256)
forall {k} (t :: k). Proxy t
Proxy String
"Sum7KES"
    , forall (proxy :: forall k. k -> *) v.
(KESAlgorithm v, ContextKES v ~ (), Signable v ByteString,
 NFData (SignKeyKES v), NFData (SigKES v)) =>
proxy v -> String -> Benchmark
benchKES @Proxy @(CompactSum6KES Ed25519DSIGN Blake2b_256) Proxy (CompactSum6KES Ed25519DSIGN Blake2b_256)
forall {k} (t :: k). Proxy t
Proxy String
"CompactSum6KES"
    , forall (proxy :: forall k. k -> *) v.
(KESAlgorithm v, ContextKES v ~ (), Signable v ByteString,
 NFData (SignKeyKES v), NFData (SigKES v)) =>
proxy v -> String -> Benchmark
benchKES @Proxy @(CompactSum7KES Ed25519DSIGN Blake2b_256) Proxy (CompactSum7KES Ed25519DSIGN Blake2b_256)
forall {k} (t :: k). Proxy t
Proxy String
"CompactSum7KES"
    ]

{-# NOINLINE benchKES #-}
benchKES ::
  forall (proxy :: forall k. k -> Type) v.
  ( KESAlgorithm v
  , ContextKES v ~ ()
  , Signable v BS.ByteString
  , NFData (SignKeyKES v)
  , NFData (SigKES v)
  ) =>
  proxy v ->
  [Char] ->
  Benchmark
benchKES :: forall (proxy :: forall k. k -> *) v.
(KESAlgorithm v, ContextKES v ~ (), Signable v ByteString,
 NFData (SignKeyKES v), NFData (SigKES v)) =>
proxy v -> String -> Benchmark
benchKES proxy v
_ String
lbl =
  String -> [Benchmark] -> Benchmark
bgroup
    String
lbl
    [ String -> Benchmarkable -> Benchmark
bench String
"genKey" (Benchmarkable -> Benchmark) -> Benchmarkable -> Benchmark
forall a b. (a -> b) -> a -> b
$
        IO () -> Benchmarkable
forall a. NFData a => IO a -> Benchmarkable
nfIO (IO () -> Benchmarkable) -> IO () -> Benchmarkable
forall a b. (a -> b) -> a -> b
$
          forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v)
genKeyKES @v MLockedSeed (SeedSizeKES v)
forall (n :: Nat). KnownNat n => MLockedSeed n
testSeedML IO (SignKeyKES v) -> (SignKeyKES v -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ()
forgetSignKeyKES @v
    , String -> Benchmarkable -> Benchmark
bench String
"signKES" (Benchmarkable -> Benchmark) -> Benchmarkable -> Benchmark
forall a b. (a -> b) -> a -> b
$
        IO (SigKES v) -> Benchmarkable
forall a. NFData a => IO a -> Benchmarkable
nfIO (IO (SigKES v) -> Benchmarkable) -> IO (SigKES v) -> Benchmarkable
forall a b. (a -> b) -> a -> b
$
          (\SignKeyKES v
sk -> do SigKES v
sig <- forall v a (m :: * -> *).
(KESAlgorithm v, Signable v a, MonadST m, MonadThrow m) =>
ContextKES v -> Period -> a -> SignKeyKES v -> m (SigKES v)
signKES @v () Period
0 ByteString
typicalMsg SignKeyKES v
sk; SignKeyKES v -> IO ()
forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES v
sk; SigKES v -> IO (SigKES v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SigKES v
sig)
            (SignKeyKES v -> IO (SigKES v))
-> IO (SignKeyKES v) -> IO (SigKES v)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v)
genKeyKES @v MLockedSeed (SeedSizeKES v)
forall (n :: Nat). KnownNat n => MLockedSeed n
testSeedML
    , String -> Benchmarkable -> Benchmark
bench String
"verifyKES" (Benchmarkable -> Benchmark) -> Benchmarkable -> Benchmark
forall a b. (a -> b) -> a -> b
$
        IO (Either Any (Either String ()) -> Either String ())
-> Benchmarkable
forall a. NFData a => IO a -> Benchmarkable
nfIO (IO (Either Any (Either String ()) -> Either String ())
 -> Benchmarkable)
-> IO (Either Any (Either String ()) -> Either String ())
-> Benchmarkable
forall a b. (a -> b) -> a -> b
$ do
          SignKeyKES v
signKey <- forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v)
genKeyKES @v MLockedSeed (SeedSizeKES v)
forall (n :: Nat). KnownNat n => MLockedSeed n
testSeedML
          SigKES v
sig <- forall v a (m :: * -> *).
(KESAlgorithm v, Signable v a, MonadST m, MonadThrow m) =>
ContextKES v -> Period -> a -> SignKeyKES v -> m (SigKES v)
signKES @v () Period
0 ByteString
typicalMsg SignKeyKES v
signKey
          VerKeyKES v
verKey <- SignKeyKES v -> IO (VerKeyKES v)
forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m (VerKeyKES v)
forall (m :: * -> *).
(MonadST m, MonadThrow m) =>
SignKeyKES v -> m (VerKeyKES v)
deriveVerKeyKES SignKeyKES v
signKey
          SignKeyKES v -> IO ()
forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES v
signKey
          (Either Any (Either String ()) -> Either String ())
-> IO (Either Any (Either String ()) -> Either String ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Either Any (Either String ()) -> Either String ())
 -> IO (Either Any (Either String ()) -> Either String ()))
-> (Either String ()
    -> Either Any (Either String ()) -> Either String ())
-> Either String ()
-> IO (Either Any (Either String ()) -> Either String ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String ()
-> Either Any (Either String ()) -> Either String ()
forall b a. b -> Either a b -> b
fromRight (Either String ()
 -> IO (Either Any (Either String ()) -> Either String ()))
-> Either String ()
-> IO (Either Any (Either String ()) -> Either String ())
forall a b. (a -> b) -> a -> b
$ forall v a.
(KESAlgorithm v, Signable v a, HasCallStack) =>
ContextKES v
-> VerKeyKES v -> Period -> a -> SigKES v -> Either String ()
verifyKES @v () VerKeyKES v
verKey Period
0 ByteString
typicalMsg SigKES v
sig
    , String -> Benchmarkable -> Benchmark
bench String
"updateKES" (Benchmarkable -> Benchmark) -> Benchmarkable -> Benchmark
forall a b. (a -> b) -> a -> b
$
        IO (SignKeyKES v) -> Benchmarkable
forall a. NFData a => IO a -> Benchmarkable
nfIO (IO (SignKeyKES v) -> Benchmarkable)
-> IO (SignKeyKES v) -> Benchmarkable
forall a b. (a -> b) -> a -> b
$ do
          SignKeyKES v
signKey <- forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v)
genKeyKES @v MLockedSeed (SeedSizeKES v)
forall (n :: Nat). KnownNat n => MLockedSeed n
testSeedML
          SignKeyKES v
sk' <- Maybe (SignKeyKES v) -> SignKeyKES v
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (SignKeyKES v) -> SignKeyKES v)
-> IO (Maybe (SignKeyKES v)) -> IO (SignKeyKES v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContextKES v -> SignKeyKES v -> Period -> IO (Maybe (SignKeyKES v))
forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
ContextKES v -> SignKeyKES v -> Period -> m (Maybe (SignKeyKES v))
updateKES () SignKeyKES v
signKey Period
0
          SignKeyKES v -> IO ()
forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES v
signKey
          SignKeyKES v -> IO (SignKeyKES v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SignKeyKES v
sk'
    ]