{-# 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 = forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ 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) 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) 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) 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) 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" forall a b. (a -> b) -> a -> b
$
        forall a. NFData a => IO a -> Benchmarkable
nfIO forall a b. (a -> b) -> a -> b
$
          forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v)
genKeyKES @v forall (n :: Nat). KnownNat n => MLockedSeed n
testSeedML 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" forall a b. (a -> b) -> a -> b
$
        forall a. NFData a => IO a -> Benchmarkable
nfIO 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; forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES v
sk; forall (m :: * -> *) a. Monad m => a -> m a
return SigKES v
sig)
            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 forall (n :: Nat). KnownNat n => MLockedSeed n
testSeedML
    , String -> Benchmarkable -> Benchmark
bench String
"verifyKES" forall a b. (a -> b) -> a -> b
$
        forall a. NFData a => IO a -> Benchmarkable
nfIO 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 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 <- forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m (VerKeyKES v)
deriveVerKeyKES SignKeyKES v
signKey
          forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES v
signKey
          forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> Either a b -> b
fromRight 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" forall a b. (a -> b) -> a -> b
$
        forall a. NFData a => IO a -> Benchmarkable
nfIO 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 forall (n :: Nat). KnownNat n => MLockedSeed n
testSeedML
          SignKeyKES v
sk' <- forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
ContextKES v -> SignKeyKES v -> Period -> m (Maybe (SignKeyKES v))
updateKES () SignKeyKES v
signKey Period
0
          forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES v
signKey
          forall (m :: * -> *) a. Monad m => a -> m a
return SignKeyKES v
sk'
    ]