{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoStarIsType #-}

-- | A key evolving signatures implementation.
--
-- It is a naive recursive implementation of the sum composition from
-- section 3.1 of the \"MMM\" paper:
--
-- /Composition and Efficiency Tradeoffs for Forward-Secure Digital Signatures/
-- By Tal Malkin, Daniele Micciancio and Sara Miner
-- <https://eprint.iacr.org/2001/034>
--
-- Specfically we do the binary sum composition directly as in the paper, and
-- then use that in a nested\/recursive fashion to construct a 7-level deep
-- binary tree version.
--
-- This relies on "Cardano.Crypto.KES.CompactSingle" for the base case.
--
-- Compared to the implementation in 'Cardano.Crypto.KES.Sum', this flavor
-- stores only one VerKey in the branch node.
--
-- Consider the following Merkle tree:
--
-- @
--       (A)
--      /   \
--   (B)     (C)
--   / \     / \
-- (D) (E) (F) (G)
--      ^
--  0   1   2   3
-- @
--
-- The caret points at leaf node E, indicating that the current period is 1.
-- The signatures for leaf nodes D through G all contain their respective
-- DSIGN keys; the signature for branch node B however only holds the signature
-- for node E, and the VerKey for node D. It can reconstruct its own VerKey
-- from these two. The signature for branch node A (the root node), then, only
-- contains the VerKey for node C, and the signature for node B. In other
-- words, the number of individual hashes to be stored equals the depth of the
-- Merkle tree. Compare that to the older, naive 'SumKES', where each branch
-- node stores two VerKeys: here, the number of keys to store is the depth of
-- the tree times two.
--
-- Note that when we verify such a signature, we need to also compare the
-- ultimate VerKey at the root against the one passed in externally, because
-- all VerKeys until that point have been derived from the (user-supplied, so
-- untrusted) signature. But we only need to do this once, at the tree root,
-- so we split up the verification into two parts: verifying a signature
-- against its embedded VerKey, and comparing that VerKey against the
-- externally supplied target key.
--
-- NOTE - some functions in this module have been deliberately marked NOINLINE;
-- this is necessary to avoid an edge case in GHC that causes the simplifier to
-- go haywire, leading to a @Simplifier ticks exhausted@ error and very long
-- compilation times. Worse yet, this error will only appear when compiling
-- code that depends on this module, not when compiling the module itself.
module Cardano.Crypto.KES.CompactSum (
  CompactSumKES,
  VerKeyKES (..),
  SignKeyKES (..),
  SigKES (..),

  -- * Type aliases for powers of binary sums
  CompactSum0KES,
  CompactSum1KES,
  CompactSum2KES,
  CompactSum3KES,
  CompactSum4KES,
  CompactSum5KES,
  CompactSum6KES,
  CompactSum7KES,
) where

import Control.Monad (guard, (<$!>))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))

import Cardano.Binary (FromCBOR (..), ToCBOR (..))

import Cardano.Crypto.DirectSerialise
import Cardano.Crypto.Hash.Class
import Cardano.Crypto.KES.Class
import Cardano.Crypto.KES.CompactSingle (CompactSingleKES)
import Cardano.Crypto.Libsodium
import Cardano.Crypto.Libsodium.MLockedSeed
import Cardano.Crypto.Libsodium.Memory
import Cardano.Crypto.Seed
import Cardano.Crypto.Util

import Control.DeepSeq (NFData (..))
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Foreign.Ptr (castPtr)
import GHC.TypeLits (KnownNat, type (*), type (+))

-- | A 2^0 period KES
type CompactSum0KES d = CompactSingleKES d

-- | A 2^1 period KES
type CompactSum1KES d h = CompactSumKES h (CompactSum0KES d)

-- | A 2^2 period KES
type CompactSum2KES d h = CompactSumKES h (CompactSum1KES d h)

-- | A 2^3 period KES
type CompactSum3KES d h = CompactSumKES h (CompactSum2KES d h)

-- | A 2^4 period KES
type CompactSum4KES d h = CompactSumKES h (CompactSum3KES d h)

-- | A 2^5 period KES
type CompactSum5KES d h = CompactSumKES h (CompactSum4KES d h)

-- | A 2^6 period KES
type CompactSum6KES d h = CompactSumKES h (CompactSum5KES d h)

-- | A 2^7 period KES
type CompactSum7KES d h = CompactSumKES h (CompactSum6KES d h)

-- | A composition of two KES schemes to give a KES scheme with the sum of
-- the time periods.
--
-- While we could do this with two independent KES schemes (i.e. two types)
-- we only need it for two instances of the same scheme, and we save
-- substantially on the size of the type and runtime dictionaries if we do it
-- this way, especially when we start applying it recursively.
data CompactSumKES h d

instance
  (NFData (SigKES d), NFData (VerKeyKES d)) =>
  NFData (SigKES (CompactSumKES h d))

instance
  (NFData (SignKeyKES d), NFData (VerKeyKES d)) =>
  NFData (SignKeyKES (CompactSumKES h d))
  where
  rnf :: SignKeyKES (CompactSumKES h d) -> ()
rnf (SignKeyCompactSumKES SignKeyKES d
sk MLockedSeed (SeedSizeKES d)
r VerKeyKES d
vk1 VerKeyKES d
vk2) =
    forall a. NFData a => a -> ()
rnf (SignKeyKES d
sk, MLockedSeed (SeedSizeKES d)
r, VerKeyKES d
vk1, VerKeyKES d
vk2)

instance
  ( OptimizedKESAlgorithm d
  , SodiumHashAlgorithm h -- needed for secure forgetting
  , SizeHash h ~ SeedSizeKES d -- can be relaxed
  , NoThunks (VerKeyKES (CompactSumKES h d))
  , KnownNat (SizeVerKeyKES (CompactSumKES h d))
  , KnownNat (SizeSignKeyKES (CompactSumKES h d))
  , KnownNat (SizeSigKES (CompactSumKES h d))
  ) =>
  KESAlgorithm (CompactSumKES h d)
  where
  type SeedSizeKES (CompactSumKES h d) = SeedSizeKES d

  --
  -- Key and signature types
  --

  -- \| From Section 3,1:
  --
  -- The verification key @vk@ for the sum scheme is the hash of the
  -- verification keys @vk_0, vk_1@ of the two constituent schemes.
  newtype VerKeyKES (CompactSumKES h d)
    = VerKeyCompactSumKES (Hash h (VerKeyKES d, VerKeyKES d))
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall h d x.
Rep (VerKeyKES (CompactSumKES h d)) x
-> VerKeyKES (CompactSumKES h d)
forall h d x.
VerKeyKES (CompactSumKES h d)
-> Rep (VerKeyKES (CompactSumKES h d)) x
$cto :: forall h d x.
Rep (VerKeyKES (CompactSumKES h d)) x
-> VerKeyKES (CompactSumKES h d)
$cfrom :: forall h d x.
VerKeyKES (CompactSumKES h d)
-> Rep (VerKeyKES (CompactSumKES h d)) x
Generic)
    deriving newtype (VerKeyKES (CompactSumKES h d) -> ()
forall a. (a -> ()) -> NFData a
forall h d. VerKeyKES (CompactSumKES h d) -> ()
rnf :: VerKeyKES (CompactSumKES h d) -> ()
$crnf :: forall h d. VerKeyKES (CompactSumKES h d) -> ()
NFData)

  -- \| Figure 3 gives: @(sigma, vk_0, vk_1)@ - however, we store only the
  -- \"off-side\" VK in the branch, and calculate the \"on-side\" one from
  -- the leaf VK (stored in the leaf node, see 'CompactSingleKES') and the
  -- \"off-side\" VK's along the Merkle path.
  data SigKES (CompactSumKES h d)
    = SigCompactSumKES
        !(SigKES d) -- includes VerKeys for the Merkle subpath
        !(VerKeyKES d)
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall h d x.
Rep (SigKES (CompactSumKES h d)) x -> SigKES (CompactSumKES h d)
forall h d x.
SigKES (CompactSumKES h d) -> Rep (SigKES (CompactSumKES h d)) x
$cto :: forall h d x.
Rep (SigKES (CompactSumKES h d)) x -> SigKES (CompactSumKES h d)
$cfrom :: forall h d x.
SigKES (CompactSumKES h d) -> Rep (SigKES (CompactSumKES h d)) x
Generic)

  -- \| From Figure 3: @(sk_0, r_1, vk_0, vk_1)@
  data SignKeyKES (CompactSumKES h d)
    = SignKeyCompactSumKES
        !(SignKeyKES d)
        !(MLockedSeed (SeedSizeKES d))
        !(VerKeyKES d)
        !(VerKeyKES d)

  --
  -- Metadata and basic key operations
  --

  algorithmNameKES :: forall (proxy :: Type -> Type). proxy (CompactSumKES h d) -> String
algorithmNameKES proxy (CompactSumKES h d)
_ = String -> String
mungeName (forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> String
algorithmNameKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d))

  -- The verification key in this scheme is actually a hash already
  -- however the type of hashVerKeyKES says the caller gets to choose
  -- the hash, not the implementation. So that's why we have to hash
  -- the hash here. We could alternatively provide a "key identifier"
  -- function and let the implementation choose what that is.
  hashVerKeyKES :: forall h.
HashAlgorithm h =>
VerKeyKES (CompactSumKES h d)
-> Hash h (VerKeyKES (CompactSumKES h d))
hashVerKeyKES (VerKeyCompactSumKES Hash h (VerKeyKES d, VerKeyKES d)
vk) = forall h a b. Hash h a -> Hash h b
castHash (forall h a. HashAlgorithm h => (a -> ByteString) -> a -> Hash h a
hashWith forall h a. Hash h a -> ByteString
hashToBytes Hash h (VerKeyKES d, VerKeyKES d)
vk)

  --
  -- Core algorithm operations
  --

  type Signable (CompactSumKES h d) = Signable d
  type ContextKES (CompactSumKES h d) = ContextKES d

  verifyKES :: forall a.
(Signable (CompactSumKES h d) a, HasCallStack) =>
ContextKES (CompactSumKES h d)
-> VerKeyKES (CompactSumKES h d)
-> Period
-> a
-> SigKES (CompactSumKES h d)
-> Either String ()
verifyKES = forall v a.
(OptimizedKESAlgorithm v, Signable v a, HasCallStack) =>
ContextKES v
-> VerKeyKES v -> Period -> a -> SigKES v -> Either String ()
verifyOptimizedKES

  totalPeriodsKES :: forall (proxy :: Type -> Type). proxy (CompactSumKES h d) -> Period
totalPeriodsKES proxy (CompactSumKES h d)
_ = Period
2 forall a. Num a => a -> a -> a
* forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)

  --
  -- raw serialise/deserialise
  --

  type SizeVerKeyKES (CompactSumKES h d) = SizeHash h
  type
    SizeSignKeyKES (CompactSumKES h d) =
      SizeSignKeyKES d
        + SeedSizeKES d
        + SizeVerKeyKES d * 2
  type
    SizeSigKES (CompactSumKES h d) =
      SizeSigKES d
        + SizeVerKeyKES d

  rawSerialiseVerKeyKES :: VerKeyKES (CompactSumKES h d) -> ByteString
rawSerialiseVerKeyKES (VerKeyCompactSumKES Hash h (VerKeyKES d, VerKeyKES d)
vk) = forall h a. Hash h a -> ByteString
hashToBytes Hash h (VerKeyKES d, VerKeyKES d)
vk

  rawSerialiseSigKES :: SigKES (CompactSumKES h d) -> ByteString
rawSerialiseSigKES (SigCompactSumKES SigKES d
sigma VerKeyKES d
vk_other) =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall v. KESAlgorithm v => SigKES v -> ByteString
rawSerialiseSigKES SigKES d
sigma
      , forall v. KESAlgorithm v => VerKeyKES v -> ByteString
rawSerialiseVerKeyKES VerKeyKES d
vk_other
      ]

  rawDeserialiseVerKeyKES :: ByteString -> Maybe (VerKeyKES (CompactSumKES h d))
rawDeserialiseVerKeyKES = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall h d.
Hash h (VerKeyKES d, VerKeyKES d) -> VerKeyKES (CompactSumKES h d)
VerKeyCompactSumKES forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes

  rawDeserialiseSigKES :: ByteString -> Maybe (SigKES (CompactSumKES h d))
rawDeserialiseSigKES ByteString
b = do
    forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
b forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral Period
size_total)
    SigKES d
sigma <- forall v. KESAlgorithm v => ByteString -> Maybe (SigKES v)
rawDeserialiseSigKES ByteString
b_sig
    VerKeyKES d
vk <- forall v. KESAlgorithm v => ByteString -> Maybe (VerKeyKES v)
rawDeserialiseVerKeyKES ByteString
b_vk
    forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall h d. SigKES d -> VerKeyKES d -> SigKES (CompactSumKES h d)
SigCompactSumKES SigKES d
sigma VerKeyKES d
vk)
    where
      b_sig :: ByteString
b_sig = Period -> Period -> ByteString -> ByteString
slice Period
off_sig Period
size_sig ByteString
b
      b_vk :: ByteString
b_vk = Period -> Period -> ByteString -> ByteString
slice Period
off_vk Period
size_vk ByteString
b

      size_sig :: Period
size_sig = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeSigKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      size_vk :: Period
size_vk = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeVerKeyKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      size_total :: Period
size_total = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeSigKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy (CompactSumKES h d))

      off_sig :: Period
off_sig = Period
0 :: Word
      off_vk :: Period
off_vk = Period
size_sig

  deriveVerKeyKES :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
SignKeyKES (CompactSumKES h d) -> m (VerKeyKES (CompactSumKES h d))
deriveVerKeyKES (SignKeyCompactSumKES SignKeyKES d
_ MLockedSeed (SeedSizeKES d)
_ VerKeyKES d
vk_0 VerKeyKES d
vk_1) =
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
Hash h (VerKeyKES d, VerKeyKES d) -> VerKeyKES (CompactSumKES h d)
VerKeyCompactSumKES (forall d h.
(KESAlgorithm d, HashAlgorithm h) =>
(VerKeyKES d, VerKeyKES d) -> Hash h (VerKeyKES d, VerKeyKES d)
hashPairOfVKeys (VerKeyKES d
vk_0, VerKeyKES d
vk_1))

  {-# NOINLINE signKES #-}
  signKES :: forall a (m :: Type -> Type).
(Signable (CompactSumKES h d) a, MonadST m, MonadThrow m) =>
ContextKES (CompactSumKES h d)
-> Period
-> a
-> SignKeyKES (CompactSumKES h d)
-> m (SigKES (CompactSumKES h d))
signKES ContextKES (CompactSumKES h d)
ctxt Period
t a
a (SignKeyCompactSumKES SignKeyKES d
sk MLockedSeed (SeedSizeKES d)
_r_1 VerKeyKES d
vk_0 VerKeyKES d
vk_1) = do
    SigKES d
sigma <- m (SigKES d)
getSigma
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d. SigKES d -> VerKeyKES d -> SigKES (CompactSumKES h d)
SigCompactSumKES SigKES d
sigma VerKeyKES d
vk_other
    where
      (m (SigKES d)
getSigma, VerKeyKES d
vk_other)
        | Period
t forall a. Ord a => a -> a -> Bool
< Period
_T = (forall v a (m :: Type -> Type).
(KESAlgorithm v, Signable v a, MonadST m, MonadThrow m) =>
ContextKES v -> Period -> a -> SignKeyKES v -> m (SigKES v)
signKES ContextKES (CompactSumKES h d)
ctxt Period
t a
a SignKeyKES d
sk, VerKeyKES d
vk_1)
        | Bool
otherwise = (forall v a (m :: Type -> Type).
(KESAlgorithm v, Signable v a, MonadST m, MonadThrow m) =>
ContextKES v -> Period -> a -> SignKeyKES v -> m (SigKES v)
signKES ContextKES (CompactSumKES h d)
ctxt (Period
t forall a. Num a => a -> a -> a
- Period
_T) a
a SignKeyKES d
sk, VerKeyKES d
vk_0)

      _T :: Period
_T = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)

  {-# NOINLINE updateKESWith #-}
  updateKESWith :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m
-> ContextKES (CompactSumKES h d)
-> SignKeyKES (CompactSumKES h d)
-> Period
-> m (Maybe (SignKeyKES (CompactSumKES h d)))
updateKESWith MLockedAllocator m
allocator ContextKES (CompactSumKES h d)
ctx (SignKeyCompactSumKES SignKeyKES d
sk MLockedSeed (SeedSizeKES d)
r_1 VerKeyKES d
vk_0 VerKeyKES d
vk_1) Period
t
    | Period
t forall a. Num a => a -> a -> a
+ Period
1 forall a. Ord a => a -> a -> Bool
< Period
_T =
        forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$!
          do
            SignKeyKES d
sk' <- forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$! forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m
-> ContextKES v
-> SignKeyKES v
-> Period
-> m (Maybe (SignKeyKES v))
updateKESWith MLockedAllocator m
allocator ContextKES (CompactSumKES h d)
ctx SignKeyKES d
sk Period
t
            MLockedSeed (SeedSizeKES d)
r_1' <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$! forall (n :: Nat) (m :: Type -> Type).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> MLockedSeed n -> m (MLockedSeed n)
mlockedSeedCopyWith MLockedAllocator m
allocator MLockedSeed (SeedSizeKES d)
r_1
            forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
SignKeyKES d
-> MLockedSeed (SeedSizeKES d)
-> VerKeyKES d
-> VerKeyKES d
-> SignKeyKES (CompactSumKES h d)
SignKeyCompactSumKES SignKeyKES d
sk' MLockedSeed (SeedSizeKES d)
r_1' VerKeyKES d
vk_0 VerKeyKES d
vk_1
    | Period
t forall a. Num a => a -> a -> a
+ Period
1 forall a. Eq a => a -> a -> Bool
== Period
_T = do
        SignKeyKES d
sk' <- forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m
-> MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v)
genKeyKESWith MLockedAllocator m
allocator MLockedSeed (SeedSizeKES d)
r_1
        MLockedSeed (SeedSizeKES d)
zero <- forall (n :: Nat) (m :: Type -> Type).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> m (MLockedSeed n)
mlockedSeedNewZeroWith MLockedAllocator m
allocator
        forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall h d.
SignKeyKES d
-> MLockedSeed (SeedSizeKES d)
-> VerKeyKES d
-> VerKeyKES d
-> SignKeyKES (CompactSumKES h d)
SignKeyCompactSumKES SignKeyKES d
sk' MLockedSeed (SeedSizeKES d)
zero VerKeyKES d
vk_0 VerKeyKES d
vk_1
    | Bool
otherwise =
        forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$!
          do
            SignKeyKES d
sk' <- forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$! forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m
-> ContextKES v
-> SignKeyKES v
-> Period
-> m (Maybe (SignKeyKES v))
updateKESWith MLockedAllocator m
allocator ContextKES (CompactSumKES h d)
ctx SignKeyKES d
sk (Period
t forall a. Num a => a -> a -> a
- Period
_T)
            MLockedSeed (SeedSizeKES d)
r_1' <- forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$! forall (n :: Nat) (m :: Type -> Type).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> MLockedSeed n -> m (MLockedSeed n)
mlockedSeedCopyWith MLockedAllocator m
allocator MLockedSeed (SeedSizeKES d)
r_1
            forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
SignKeyKES d
-> MLockedSeed (SeedSizeKES d)
-> VerKeyKES d
-> VerKeyKES d
-> SignKeyKES (CompactSumKES h d)
SignKeyCompactSumKES SignKeyKES d
sk' MLockedSeed (SeedSizeKES d)
r_1' VerKeyKES d
vk_0 VerKeyKES d
vk_1
    where
      _T :: Period
_T = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)

  --
  -- Key generation
  --

  {-# NOINLINE genKeyKESWith #-}
  genKeyKESWith :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m
-> MLockedSeed (SeedSizeKES (CompactSumKES h d))
-> m (SignKeyKES (CompactSumKES h d))
genKeyKESWith MLockedAllocator m
allocator MLockedSeed (SeedSizeKES (CompactSumKES h d))
r = do
    (MLockedSizedBytes (SeedSizeKES d)
r0raw, MLockedSizedBytes (SeedSizeKES d)
r1raw) <- forall h (m :: Type -> Type) (proxy :: Type -> Type).
(SodiumHashAlgorithm h, MonadST m, MonadThrow m) =>
MLockedAllocator m
-> proxy h
-> MLockedSizedBytes (SizeHash h)
-> m (MLockedSizedBytes (SizeHash h),
      MLockedSizedBytes (SizeHash h))
expandHashWith MLockedAllocator m
allocator (forall {k} (t :: k). Proxy t
Proxy :: Proxy h) (forall (n :: Nat). MLockedSeed n -> MLockedSizedBytes n
mlockedSeedMLSB MLockedSeed (SeedSizeKES (CompactSumKES h d))
r)
    let r0 :: MLockedSeed (SeedSizeKES d)
r0 = forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed MLockedSizedBytes (SeedSizeKES d)
r0raw
        r1 :: MLockedSeed (SeedSizeKES d)
r1 = forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed MLockedSizedBytes (SeedSizeKES d)
r1raw
    SignKeyKES d
sk_0 <- forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m
-> MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v)
genKeyKESWith MLockedAllocator m
allocator MLockedSeed (SeedSizeKES d)
r0
    VerKeyKES d
vk_0 <- forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m (VerKeyKES v)
deriveVerKeyKES SignKeyKES d
sk_0
    SignKeyKES d
sk_1 <- forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m
-> MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v)
genKeyKESWith MLockedAllocator m
allocator MLockedSeed (SeedSizeKES d)
r1
    VerKeyKES d
vk_1 <- forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m (VerKeyKES v)
deriveVerKeyKES SignKeyKES d
sk_1
    forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES d
sk_1
    forall (m :: Type -> Type) (n :: Nat).
MonadST m =>
MLockedSeed n -> m ()
mlockedSeedFinalize MLockedSeed (SeedSizeKES d)
r0
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
SignKeyKES d
-> MLockedSeed (SeedSizeKES d)
-> VerKeyKES d
-> VerKeyKES d
-> SignKeyKES (CompactSumKES h d)
SignKeyCompactSumKES SignKeyKES d
sk_0 MLockedSeed (SeedSizeKES d)
r1 VerKeyKES d
vk_0 VerKeyKES d
vk_1

  --
  -- forgetting
  --
  forgetSignKeyKESWith :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m -> SignKeyKES (CompactSumKES h d) -> m ()
forgetSignKeyKESWith MLockedAllocator m
allocator (SignKeyCompactSumKES SignKeyKES d
sk_0 MLockedSeed (SeedSizeKES d)
r1 VerKeyKES d
_ VerKeyKES d
_) = do
    forall v (m :: Type -> Type).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m -> SignKeyKES v -> m ()
forgetSignKeyKESWith MLockedAllocator m
allocator SignKeyKES d
sk_0
    forall (m :: Type -> Type) (n :: Nat).
MonadST m =>
MLockedSeed n -> m ()
mlockedSeedFinalize MLockedSeed (SeedSizeKES d)
r1

instance
  ( KESAlgorithm (CompactSumKES h d)
  , UnsoundKESAlgorithm d
  ) =>
  UnsoundKESAlgorithm (CompactSumKES h d)
  where
  --
  -- Raw serialise/deserialise - dangerous, do not use in production code.
  --

  {-# NOINLINE rawSerialiseSignKeyKES #-}
  rawSerialiseSignKeyKES :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
SignKeyKES (CompactSumKES h d) -> m ByteString
rawSerialiseSignKeyKES (SignKeyCompactSumKES SignKeyKES d
sk MLockedSeed (SeedSizeKES d)
r_1 VerKeyKES d
vk_0 VerKeyKES d
vk_1) = do
    ByteString
ssk <- forall v (m :: Type -> Type).
(UnsoundKESAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyKES v -> m ByteString
rawSerialiseSignKeyKES SignKeyKES d
sk
    ByteString
sr1 <- forall (n :: Nat) (m :: Type -> Type).
(KnownNat n, MonadST m) =>
MLockedSizedBytes n -> m ByteString
mlsbToByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat). MLockedSeed n -> MLockedSizedBytes n
mlockedSeedMLSB forall a b. (a -> b) -> a -> b
$ MLockedSeed (SeedSizeKES d)
r_1
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      forall a. Monoid a => [a] -> a
mconcat
        [ ByteString
ssk
        , ByteString
sr1
        , forall v. KESAlgorithm v => VerKeyKES v -> ByteString
rawSerialiseVerKeyKES VerKeyKES d
vk_0
        , forall v. KESAlgorithm v => VerKeyKES v -> ByteString
rawSerialiseVerKeyKES VerKeyKES d
vk_1
        ]

  {-# NOINLINE rawDeserialiseSignKeyKESWith #-}
  rawDeserialiseSignKeyKESWith :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m
-> ByteString -> m (Maybe (SignKeyKES (CompactSumKES h d)))
rawDeserialiseSignKeyKESWith MLockedAllocator m
allocator ByteString
b = forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
b forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral Period
size_total)
    SignKeyKES d
sk <- forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall v (m :: Type -> Type).
(UnsoundKESAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m -> ByteString -> m (Maybe (SignKeyKES v))
rawDeserialiseSignKeyKESWith MLockedAllocator m
allocator ByteString
b_sk
    MLockedSizedBytes (SeedSizeKES d)
r <- forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (n :: Nat) (m :: Type -> Type).
(KnownNat n, MonadST m) =>
MLockedAllocator m -> ByteString -> m (Maybe (MLockedSizedBytes n))
mlsbFromByteStringCheckWith MLockedAllocator m
allocator ByteString
b_r
    VerKeyKES d
vk_0 <- forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall v. KESAlgorithm v => ByteString -> Maybe (VerKeyKES v)
rawDeserialiseVerKeyKES ByteString
b_vk0
    VerKeyKES d
vk_1 <- forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall v. KESAlgorithm v => ByteString -> Maybe (VerKeyKES v)
rawDeserialiseVerKeyKES ByteString
b_vk1
    forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall h d.
SignKeyKES d
-> MLockedSeed (SeedSizeKES d)
-> VerKeyKES d
-> VerKeyKES d
-> SignKeyKES (CompactSumKES h d)
SignKeyCompactSumKES SignKeyKES d
sk (forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed MLockedSizedBytes (SeedSizeKES d)
r) VerKeyKES d
vk_0 VerKeyKES d
vk_1)
    where
      b_sk :: ByteString
b_sk = Period -> Period -> ByteString -> ByteString
slice Period
off_sk Period
size_sk ByteString
b
      b_r :: ByteString
b_r = Period -> Period -> ByteString -> ByteString
slice Period
off_r Period
size_r ByteString
b
      b_vk0 :: ByteString
b_vk0 = Period -> Period -> ByteString -> ByteString
slice Period
off_vk0 Period
size_vk ByteString
b
      b_vk1 :: ByteString
b_vk1 = Period -> Period -> ByteString -> ByteString
slice Period
off_vk1 Period
size_vk ByteString
b

      size_sk :: Period
size_sk = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeSignKeyKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      size_r :: Period
size_r = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
seedSizeKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      size_vk :: Period
size_vk = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeVerKeyKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      size_total :: Period
size_total = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeSignKeyKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy (CompactSumKES h d))

      off_sk :: Period
off_sk = Period
0 :: Word
      off_r :: Period
off_r = Period
size_sk
      off_vk0 :: Period
off_vk0 = Period
off_r forall a. Num a => a -> a -> a
+ Period
size_r
      off_vk1 :: Period
off_vk1 = Period
off_vk0 forall a. Num a => a -> a -> a
+ Period
size_vk

instance
  (KESAlgorithm (CompactSumKES h d), OptimizedKESAlgorithm d, HashAlgorithm h) =>
  OptimizedKESAlgorithm (CompactSumKES h d)
  where
  verifySigKES :: forall a.
(Signable (CompactSumKES h d) a, HasCallStack) =>
ContextKES (CompactSumKES h d)
-> Period -> a -> SigKES (CompactSumKES h d) -> Either String ()
verifySigKES ContextKES (CompactSumKES h d)
ctxt Period
t a
a (SigCompactSumKES SigKES d
sigma VerKeyKES d
_) =
    forall v a.
(OptimizedKESAlgorithm v, Signable v a, HasCallStack) =>
ContextKES v -> Period -> a -> SigKES v -> Either String ()
verifySigKES ContextKES (CompactSumKES h d)
ctxt Period
t' a
a SigKES d
sigma
    where
      _T :: Period
_T = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      t' :: Period
t'
        | Period
t forall a. Ord a => a -> a -> Bool
< Period
_T = Period
t
        | Bool
otherwise = Period
t forall a. Num a => a -> a -> a
- Period
_T

  verKeyFromSigKES :: ContextKES (CompactSumKES h d)
-> Period
-> SigKES (CompactSumKES h d)
-> VerKeyKES (CompactSumKES h d)
verKeyFromSigKES ContextKES (CompactSumKES h d)
ctxt Period
t (SigCompactSumKES SigKES d
sigma VerKeyKES d
vk_other) =
    forall h d.
Hash h (VerKeyKES d, VerKeyKES d) -> VerKeyKES (CompactSumKES h d)
VerKeyCompactSumKES forall a b. (a -> b) -> a -> b
$ forall d h.
(KESAlgorithm d, HashAlgorithm h) =>
(VerKeyKES d, VerKeyKES d) -> Hash h (VerKeyKES d, VerKeyKES d)
hashPairOfVKeys (VerKeyKES d
vk_0, VerKeyKES d
vk_1)
    where
      _T :: Period
_T = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      t' :: Period
t'
        | Period
t forall a. Ord a => a -> a -> Bool
< Period
_T = Period
t
        | Bool
otherwise = Period
t forall a. Num a => a -> a -> a
- Period
_T
      (VerKeyKES d
vk_0, VerKeyKES d
vk_1)
        | Period
t forall a. Ord a => a -> a -> Bool
< Period
_T = (forall v.
OptimizedKESAlgorithm v =>
ContextKES v -> Period -> SigKES v -> VerKeyKES v
verKeyFromSigKES ContextKES (CompactSumKES h d)
ctxt Period
t' SigKES d
sigma, VerKeyKES d
vk_other)
        | Bool
otherwise = (VerKeyKES d
vk_other, forall v.
OptimizedKESAlgorithm v =>
ContextKES v -> Period -> SigKES v -> VerKeyKES v
verKeyFromSigKES ContextKES (CompactSumKES h d)
ctxt Period
t' SigKES d
sigma)

--
-- VerKey instances
--

deriving instance HashAlgorithm h => Show (VerKeyKES (CompactSumKES h d))
deriving instance Eq (VerKeyKES (CompactSumKES h d))

deriving via
  OnlyCheckWhnfNamed "SignKeyKES (CompactSumKES h d)" (SignKeyKES (CompactSumKES h d))
  instance
    NoThunks (SignKeyKES (CompactSumKES h d))

instance KESAlgorithm d => NoThunks (VerKeyKES (CompactSumKES h d))

instance
  ( OptimizedKESAlgorithm d
  , SodiumHashAlgorithm h
  , SizeHash h ~ SeedSizeKES d
  , NoThunks (VerKeyKES (CompactSumKES h d))
  , KnownNat (SizeVerKeyKES (CompactSumKES h d))
  , KnownNat (SizeSignKeyKES (CompactSumKES h d))
  , KnownNat (SizeSigKES (CompactSumKES h d))
  ) =>
  ToCBOR (VerKeyKES (CompactSumKES h d))
  where
  toCBOR :: VerKeyKES (CompactSumKES h d) -> Encoding
toCBOR = forall v. KESAlgorithm v => VerKeyKES v -> Encoding
encodeVerKeyKES
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (VerKeyKES (CompactSumKES h d)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
_size = forall v. KESAlgorithm v => Proxy (VerKeyKES v) -> Size
encodedVerKeyKESSizeExpr

instance
  ( OptimizedKESAlgorithm d
  , SodiumHashAlgorithm h
  , SizeHash h ~ SeedSizeKES d
  , NoThunks (VerKeyKES (CompactSumKES h d))
  , KnownNat (SizeVerKeyKES (CompactSumKES h d))
  , KnownNat (SizeSignKeyKES (CompactSumKES h d))
  , KnownNat (SizeSigKES (CompactSumKES h d))
  ) =>
  FromCBOR (VerKeyKES (CompactSumKES h d))
  where
  fromCBOR :: forall s. Decoder s (VerKeyKES (CompactSumKES h d))
fromCBOR = forall v s. KESAlgorithm v => Decoder s (VerKeyKES v)
decodeVerKeyKES

--
-- SignKey instances
--

-- These instances would violate mlocking protections, bleeding secret keys
-- onto the GHC heap.
--
-- deriving instance KESAlgorithm d => Show (SignKeyKES (CompactSumKES h d))
--
-- instance (OptimizedKESAlgorithm d) => NoThunks (VerKeyKES  (CompactSumKES h d))
--
-- instance (OptimizedKESAlgorithm d, HashAlgorithm h, SizeHash h ~ SeedSizeKES d)
--       => ToCBOR (SignKeyKES (CompactSumKES h d)) where
--   toCBOR = encodeSignKeyKES
--   encodedSizeExpr _size = encodedSignKeyKESSizeExpr
--
-- instance (OptimizedKESAlgorithm d, HashAlgorithm h, SizeHash h ~ SeedSizeKES d)
--       => FromCBOR (SignKeyKES (CompactSumKES h d)) where
--   fromCBOR = decodeSignKeyKES

--
-- Sig instances
--

deriving instance KESAlgorithm d => Show (SigKES (CompactSumKES h d))
deriving instance KESAlgorithm d => Eq (SigKES (CompactSumKES h d))

instance KESAlgorithm d => NoThunks (SigKES (CompactSumKES h d))

instance
  ( OptimizedKESAlgorithm d
  , SodiumHashAlgorithm h
  , SizeHash h ~ SeedSizeKES d
  , NoThunks (VerKeyKES (CompactSumKES h d))
  , KnownNat (SizeVerKeyKES (CompactSumKES h d))
  , KnownNat (SizeSignKeyKES (CompactSumKES h d))
  , KnownNat (SizeSigKES (CompactSumKES h d))
  ) =>
  ToCBOR (SigKES (CompactSumKES h d))
  where
  toCBOR :: SigKES (CompactSumKES h d) -> Encoding
toCBOR = forall v. KESAlgorithm v => SigKES v -> Encoding
encodeSigKES
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (SigKES (CompactSumKES h d)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
_size = forall v. KESAlgorithm v => Proxy (SigKES v) -> Size
encodedSigKESSizeExpr

instance
  ( OptimizedKESAlgorithm d
  , SodiumHashAlgorithm h
  , SizeHash h ~ SeedSizeKES d
  , NoThunks (VerKeyKES (CompactSumKES h d))
  , KnownNat (SizeVerKeyKES (CompactSumKES h d))
  , KnownNat (SizeSignKeyKES (CompactSumKES h d))
  , KnownNat (SizeSigKES (CompactSumKES h d))
  ) =>
  FromCBOR (SigKES (CompactSumKES h d))
  where
  fromCBOR :: forall s. Decoder s (SigKES (CompactSumKES h d))
fromCBOR = forall v s. KESAlgorithm v => Decoder s (SigKES v)
decodeSigKES

--
-- Unsound pure KES API
--
instance
  ( KESAlgorithm (CompactSumKES h d)
  , HashAlgorithm h
  , UnsoundPureKESAlgorithm d
  ) =>
  UnsoundPureKESAlgorithm (CompactSumKES h d)
  where
  data UnsoundPureSignKeyKES (CompactSumKES h d)
    = UnsoundPureSignKeyCompactSumKES
        !(UnsoundPureSignKeyKES d)
        !Seed
        !(VerKeyKES d)
        !(VerKeyKES d)
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall h d x.
Rep (UnsoundPureSignKeyKES (CompactSumKES h d)) x
-> UnsoundPureSignKeyKES (CompactSumKES h d)
forall h d x.
UnsoundPureSignKeyKES (CompactSumKES h d)
-> Rep (UnsoundPureSignKeyKES (CompactSumKES h d)) x
$cto :: forall h d x.
Rep (UnsoundPureSignKeyKES (CompactSumKES h d)) x
-> UnsoundPureSignKeyKES (CompactSumKES h d)
$cfrom :: forall h d x.
UnsoundPureSignKeyKES (CompactSumKES h d)
-> Rep (UnsoundPureSignKeyKES (CompactSumKES h d)) x
Generic)

  unsoundPureSignKES :: forall a.
Signable (CompactSumKES h d) a =>
ContextKES (CompactSumKES h d)
-> Period
-> a
-> UnsoundPureSignKeyKES (CompactSumKES h d)
-> SigKES (CompactSumKES h d)
unsoundPureSignKES ContextKES (CompactSumKES h d)
ctxt Period
t a
a (UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk Seed
_r_1 VerKeyKES d
vk_0 VerKeyKES d
vk_1) =
    forall h d. SigKES d -> VerKeyKES d -> SigKES (CompactSumKES h d)
SigCompactSumKES SigKES d
sigma VerKeyKES d
vk_other
    where
      (SigKES d
sigma, VerKeyKES d
vk_other)
        | Period
t forall a. Ord a => a -> a -> Bool
< Period
_T = (forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v -> Period -> a -> UnsoundPureSignKeyKES v -> SigKES v
unsoundPureSignKES ContextKES (CompactSumKES h d)
ctxt Period
t a
a UnsoundPureSignKeyKES d
sk, VerKeyKES d
vk_1)
        | Bool
otherwise = (forall v a.
(UnsoundPureKESAlgorithm v, Signable v a) =>
ContextKES v -> Period -> a -> UnsoundPureSignKeyKES v -> SigKES v
unsoundPureSignKES ContextKES (CompactSumKES h d)
ctxt (Period
t forall a. Num a => a -> a -> a
- Period
_T) a
a UnsoundPureSignKeyKES d
sk, VerKeyKES d
vk_0)

      _T :: Period
_T = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)

  unsoundPureUpdateKES :: ContextKES (CompactSumKES h d)
-> UnsoundPureSignKeyKES (CompactSumKES h d)
-> Period
-> Maybe (UnsoundPureSignKeyKES (CompactSumKES h d))
unsoundPureUpdateKES ContextKES (CompactSumKES h d)
ctx (UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk Seed
r_1 VerKeyKES d
vk_0 VerKeyKES d
vk_1) Period
t
    | Period
t forall a. Num a => a -> a -> a
+ Period
1 forall a. Ord a => a -> a -> Bool
< Period
_T = do
        UnsoundPureSignKeyKES d
sk' <- forall v.
UnsoundPureKESAlgorithm v =>
ContextKES v
-> UnsoundPureSignKeyKES v
-> Period
-> Maybe (UnsoundPureSignKeyKES v)
unsoundPureUpdateKES ContextKES (CompactSumKES h d)
ctx UnsoundPureSignKeyKES d
sk Period
t
        let r_1' :: Seed
r_1' = Seed
r_1
        forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
UnsoundPureSignKeyKES d
-> Seed
-> VerKeyKES d
-> VerKeyKES d
-> UnsoundPureSignKeyKES (CompactSumKES h d)
UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk' Seed
r_1' VerKeyKES d
vk_0 VerKeyKES d
vk_1
    | Period
t forall a. Num a => a -> a -> a
+ Period
1 forall a. Eq a => a -> a -> Bool
== Period
_T = do
        let sk' :: UnsoundPureSignKeyKES d
sk' = forall v.
UnsoundPureKESAlgorithm v =>
Seed -> UnsoundPureSignKeyKES v
unsoundPureGenKeyKES Seed
r_1
        let r_1' :: Seed
r_1' = ByteString -> Seed
mkSeedFromBytes (Int -> Word8 -> ByteString
BS.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
seedSizeKES (forall {k} (t :: k). Proxy t
Proxy @d))) Word8
0)
        forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
UnsoundPureSignKeyKES d
-> Seed
-> VerKeyKES d
-> VerKeyKES d
-> UnsoundPureSignKeyKES (CompactSumKES h d)
UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk' Seed
r_1' VerKeyKES d
vk_0 VerKeyKES d
vk_1
    | Bool
otherwise = do
        UnsoundPureSignKeyKES d
sk' <- forall v.
UnsoundPureKESAlgorithm v =>
ContextKES v
-> UnsoundPureSignKeyKES v
-> Period
-> Maybe (UnsoundPureSignKeyKES v)
unsoundPureUpdateKES ContextKES (CompactSumKES h d)
ctx UnsoundPureSignKeyKES d
sk (Period
t forall a. Num a => a -> a -> a
- Period
_T)
        let r_1' :: Seed
r_1' = Seed
r_1
        forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
UnsoundPureSignKeyKES d
-> Seed
-> VerKeyKES d
-> VerKeyKES d
-> UnsoundPureSignKeyKES (CompactSumKES h d)
UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk' Seed
r_1' VerKeyKES d
vk_0 VerKeyKES d
vk_1
    where
      _T :: Period
_T = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
totalPeriodsKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)

  --
  -- Key generation
  --

  unsoundPureGenKeyKES :: Seed -> UnsoundPureSignKeyKES (CompactSumKES h d)
unsoundPureGenKeyKES Seed
r =
    let r0 :: Seed
r0 = ByteString -> Seed
mkSeedFromBytes forall a b. (a -> b) -> a -> b
$ forall h (proxy :: Type -> Type).
HashAlgorithm h =>
proxy h -> ByteString -> ByteString
digest (forall {k} (t :: k). Proxy t
Proxy @h) (Word8 -> ByteString -> ByteString
BS.cons Word8
1 forall a b. (a -> b) -> a -> b
$ Seed -> ByteString
getSeedBytes Seed
r)
        r1 :: Seed
r1 = ByteString -> Seed
mkSeedFromBytes forall a b. (a -> b) -> a -> b
$ forall h (proxy :: Type -> Type).
HashAlgorithm h =>
proxy h -> ByteString -> ByteString
digest (forall {k} (t :: k). Proxy t
Proxy @h) (Word8 -> ByteString -> ByteString
BS.cons Word8
2 forall a b. (a -> b) -> a -> b
$ Seed -> ByteString
getSeedBytes Seed
r)
        sk_0 :: UnsoundPureSignKeyKES d
sk_0 = forall v.
UnsoundPureKESAlgorithm v =>
Seed -> UnsoundPureSignKeyKES v
unsoundPureGenKeyKES Seed
r0
        vk_0 :: VerKeyKES d
vk_0 = forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> VerKeyKES v
unsoundPureDeriveVerKeyKES UnsoundPureSignKeyKES d
sk_0
        sk_1 :: UnsoundPureSignKeyKES d
sk_1 = forall v.
UnsoundPureKESAlgorithm v =>
Seed -> UnsoundPureSignKeyKES v
unsoundPureGenKeyKES Seed
r1
        vk_1 :: VerKeyKES d
vk_1 = forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> VerKeyKES v
unsoundPureDeriveVerKeyKES UnsoundPureSignKeyKES d
sk_1
     in forall h d.
UnsoundPureSignKeyKES d
-> Seed
-> VerKeyKES d
-> VerKeyKES d
-> UnsoundPureSignKeyKES (CompactSumKES h d)
UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk_0 Seed
r1 VerKeyKES d
vk_0 VerKeyKES d
vk_1

  unsoundPureDeriveVerKeyKES :: UnsoundPureSignKeyKES (CompactSumKES h d)
-> VerKeyKES (CompactSumKES h d)
unsoundPureDeriveVerKeyKES (UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
_ Seed
_ VerKeyKES d
vk_0 VerKeyKES d
vk_1) =
    forall h d.
Hash h (VerKeyKES d, VerKeyKES d) -> VerKeyKES (CompactSumKES h d)
VerKeyCompactSumKES (forall d h.
(KESAlgorithm d, HashAlgorithm h) =>
(VerKeyKES d, VerKeyKES d) -> Hash h (VerKeyKES d, VerKeyKES d)
hashPairOfVKeys (VerKeyKES d
vk_0, VerKeyKES d
vk_1))

  unsoundPureSignKeyKESToSoundSignKeyKES :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
UnsoundPureSignKeyKES (CompactSumKES h d)
-> m (SignKeyKES (CompactSumKES h d))
unsoundPureSignKeyKESToSoundSignKeyKES (UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk Seed
r_1 VerKeyKES d
vk_0 VerKeyKES d
vk_1) =
    forall h d.
SignKeyKES d
-> MLockedSeed (SeedSizeKES d)
-> VerKeyKES d
-> VerKeyKES d
-> SignKeyKES (CompactSumKES h d)
SignKeyCompactSumKES
      forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall v (m :: Type -> Type).
(UnsoundPureKESAlgorithm v, MonadST m, MonadThrow m) =>
UnsoundPureSignKeyKES v -> m (SignKeyKES v)
unsoundPureSignKeyKESToSoundSignKeyKES UnsoundPureSignKeyKES d
sk
      forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Nat) (m :: Type -> Type).
(KnownNat n, MonadST m) =>
ByteString -> m (MLockedSizedBytes n)
mlsbFromByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seed -> ByteString
getSeedBytes forall a b. (a -> b) -> a -> b
$ Seed
r_1)
      forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure VerKeyKES d
vk_0
      forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure VerKeyKES d
vk_1

  rawSerialiseUnsoundPureSignKeyKES :: UnsoundPureSignKeyKES (CompactSumKES h d) -> ByteString
rawSerialiseUnsoundPureSignKeyKES (UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk Seed
r_1 VerKeyKES d
vk_0 VerKeyKES d
vk_1) =
    let ssk :: ByteString
ssk = forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> ByteString
rawSerialiseUnsoundPureSignKeyKES UnsoundPureSignKeyKES d
sk
        sr1 :: ByteString
sr1 = Seed -> ByteString
getSeedBytes Seed
r_1
     in forall a. Monoid a => [a] -> a
mconcat
          [ ByteString
ssk
          , ByteString
sr1
          , forall v. KESAlgorithm v => VerKeyKES v -> ByteString
rawSerialiseVerKeyKES VerKeyKES d
vk_0
          , forall v. KESAlgorithm v => VerKeyKES v -> ByteString
rawSerialiseVerKeyKES VerKeyKES d
vk_1
          ]

  rawDeserialiseUnsoundPureSignKeyKES :: ByteString -> Maybe (UnsoundPureSignKeyKES (CompactSumKES h d))
rawDeserialiseUnsoundPureSignKeyKES ByteString
b = do
    forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
b forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral Period
size_total)
    UnsoundPureSignKeyKES d
sk <- forall v.
UnsoundPureKESAlgorithm v =>
ByteString -> Maybe (UnsoundPureSignKeyKES v)
rawDeserialiseUnsoundPureSignKeyKES ByteString
b_sk
    let r :: Seed
r = ByteString -> Seed
mkSeedFromBytes ByteString
b_r
    VerKeyKES d
vk_0 <- forall v. KESAlgorithm v => ByteString -> Maybe (VerKeyKES v)
rawDeserialiseVerKeyKES ByteString
b_vk0
    VerKeyKES d
vk_1 <- forall v. KESAlgorithm v => ByteString -> Maybe (VerKeyKES v)
rawDeserialiseVerKeyKES ByteString
b_vk1
    forall (m :: Type -> Type) a. Monad m => a -> m a
return (forall h d.
UnsoundPureSignKeyKES d
-> Seed
-> VerKeyKES d
-> VerKeyKES d
-> UnsoundPureSignKeyKES (CompactSumKES h d)
UnsoundPureSignKeyCompactSumKES UnsoundPureSignKeyKES d
sk Seed
r VerKeyKES d
vk_0 VerKeyKES d
vk_1)
    where
      b_sk :: ByteString
b_sk = Period -> Period -> ByteString -> ByteString
slice Period
off_sk Period
size_sk ByteString
b
      b_r :: ByteString
b_r = Period -> Period -> ByteString -> ByteString
slice Period
off_r Period
size_r ByteString
b
      b_vk0 :: ByteString
b_vk0 = Period -> Period -> ByteString -> ByteString
slice Period
off_vk0 Period
size_vk ByteString
b
      b_vk1 :: ByteString
b_vk1 = Period -> Period -> ByteString -> ByteString
slice Period
off_vk1 Period
size_vk ByteString
b

      size_sk :: Period
size_sk = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeSignKeyKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      size_r :: Period
size_r = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
seedSizeKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      size_vk :: Period
size_vk = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeVerKeyKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
      size_total :: Period
size_total = forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
sizeSignKeyKES (forall {k} (t :: k). Proxy t
Proxy :: Proxy (CompactSumKES h d))

      off_sk :: Period
off_sk = Period
0 :: Word
      off_r :: Period
off_r = Period
size_sk
      off_vk0 :: Period
off_vk0 = Period
off_r forall a. Num a => a -> a -> a
+ Period
size_r
      off_vk1 :: Period
off_vk1 = Period
off_vk0 forall a. Num a => a -> a -> a
+ Period
size_vk

--
-- UnsoundPureSignKey instances
--

deriving instance
  (KESAlgorithm d, Show (UnsoundPureSignKeyKES d)) => Show (UnsoundPureSignKeyKES (CompactSumKES h d))
deriving instance
  (KESAlgorithm d, Eq (UnsoundPureSignKeyKES d)) => Eq (UnsoundPureSignKeyKES (CompactSumKES h d))

instance
  ( SizeHash h ~ SeedSizeKES d
  , OptimizedKESAlgorithm d
  , UnsoundPureKESAlgorithm d
  , SodiumHashAlgorithm h
  , KnownNat (SizeVerKeyKES (CompactSumKES h d))
  , KnownNat (SizeSignKeyKES (CompactSumKES h d))
  , KnownNat (SizeSigKES (CompactSumKES h d))
  ) =>
  ToCBOR (UnsoundPureSignKeyKES (CompactSumKES h d))
  where
  toCBOR :: UnsoundPureSignKeyKES (CompactSumKES h d) -> Encoding
toCBOR = forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> Encoding
encodeUnsoundPureSignKeyKES
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (UnsoundPureSignKeyKES (CompactSumKES h d)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
_size Proxy (UnsoundPureSignKeyKES (CompactSumKES h d))
_skProxy = forall v. KESAlgorithm v => Proxy (SignKeyKES v) -> Size
encodedSignKeyKESSizeExpr (forall {k} (t :: k). Proxy t
Proxy :: Proxy (SignKeyKES (CompactSumKES h d)))

instance
  ( SizeHash h ~ SeedSizeKES d
  , OptimizedKESAlgorithm d
  , UnsoundPureKESAlgorithm d
  , SodiumHashAlgorithm h
  , KnownNat (SizeVerKeyKES (CompactSumKES h d))
  , KnownNat (SizeSignKeyKES (CompactSumKES h d))
  , KnownNat (SizeSigKES (CompactSumKES h d))
  ) =>
  FromCBOR (UnsoundPureSignKeyKES (CompactSumKES h d))
  where
  fromCBOR :: forall s. Decoder s (UnsoundPureSignKeyKES (CompactSumKES h d))
fromCBOR = forall v s.
UnsoundPureKESAlgorithm v =>
Decoder s (UnsoundPureSignKeyKES v)
decodeUnsoundPureSignKeyKES

instance
  (NoThunks (UnsoundPureSignKeyKES d), KESAlgorithm d) =>
  NoThunks (UnsoundPureSignKeyKES (CompactSumKES h d))

--
-- Direct ser/deser
--

instance
  ( DirectSerialise (SignKeyKES d)
  , DirectSerialise (VerKeyKES d)
  , KESAlgorithm d
  ) =>
  DirectSerialise (SignKeyKES (CompactSumKES h d))
  where
  directSerialise :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ())
-> SignKeyKES (CompactSumKES h d) -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push (SignKeyCompactSumKES SignKeyKES d
sk MLockedSeed (SeedSizeKES d)
r VerKeyKES d
vk0 VerKeyKES d
vk1) = do
    forall a (m :: Type -> Type).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push SignKeyKES d
sk
    forall a (m :: Type -> Type).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push MLockedSeed (SeedSizeKES d)
r
    forall a (m :: Type -> Type).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push VerKeyKES d
vk0
    forall a (m :: Type -> Type).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push VerKeyKES d
vk1

instance
  ( DirectDeserialise (SignKeyKES d)
  , DirectDeserialise (VerKeyKES d)
  , KESAlgorithm d
  ) =>
  DirectDeserialise (SignKeyKES (CompactSumKES h d))
  where
  directDeserialise :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m (SignKeyKES (CompactSumKES h d))
directDeserialise Ptr CChar -> CSize -> m ()
pull = do
    SignKeyKES d
sk <- forall a (m :: Type -> Type).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
directDeserialise Ptr CChar -> CSize -> m ()
pull
    MLockedSeed (SeedSizeKES d)
r <- forall a (m :: Type -> Type).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
directDeserialise Ptr CChar -> CSize -> m ()
pull
    VerKeyKES d
vk0 <- forall a (m :: Type -> Type).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
directDeserialise Ptr CChar -> CSize -> m ()
pull
    VerKeyKES d
vk1 <- forall a (m :: Type -> Type).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
directDeserialise Ptr CChar -> CSize -> m ()
pull

    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
SignKeyKES d
-> MLockedSeed (SeedSizeKES d)
-> VerKeyKES d
-> VerKeyKES d
-> SignKeyKES (CompactSumKES h d)
SignKeyCompactSumKES SignKeyKES d
sk MLockedSeed (SeedSizeKES d)
r VerKeyKES d
vk0 VerKeyKES d
vk1

instance DirectSerialise (VerKeyKES (CompactSumKES h d)) where
  directSerialise :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ())
-> VerKeyKES (CompactSumKES h d) -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push (VerKeyCompactSumKES Hash h (VerKeyKES d, VerKeyKES d)
h) =
    forall (m :: Type -> Type) a.
(MonadThrow m, MonadST m) =>
ByteString -> (CStringLen -> m a) -> m a
unpackByteStringCStringLen (forall h a. Hash h a -> ByteString
hashToBytes Hash h (VerKeyKES d, VerKeyKES d)
h) forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
len) ->
      Ptr CChar -> CSize -> m ()
push (forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
ptr) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

instance
  HashAlgorithm h =>
  DirectDeserialise (VerKeyKES (CompactSumKES h d))
  where
  directDeserialise :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m (VerKeyKES (CompactSumKES h d))
directDeserialise Ptr CChar -> CSize -> m ()
pull = do
    let len :: Num a => a
        len :: forall a. Num a => a
len = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall h (proxy :: Type -> Type).
HashAlgorithm h =>
proxy h -> Period
sizeHash (forall {k} (t :: k). Proxy t
Proxy @h)
    ForeignPtr m Word8
fptr <- forall (m :: Type -> Type) a.
MonadST m =>
Int -> m (ForeignPtr m a)
mallocForeignPtrBytes forall a. Num a => a
len
    forall (m :: Type -> Type) a b.
MonadST m =>
ForeignPtr m a -> (Ptr a -> m b) -> m b
withForeignPtr ForeignPtr m Word8
fptr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
      Ptr CChar -> CSize -> m ()
pull (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) forall a. Num a => a
len
    let bs :: ByteString
bs = ForeignPtr Word8 -> Int -> Int -> ByteString
BS.fromForeignPtr (forall (m :: Type -> Type) a. ForeignPtr m a -> ForeignPtr a
unsafeRawForeignPtr ForeignPtr m Word8
fptr) Int
0 forall a. Num a => a
len
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"Invalid hash") forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall h d.
Hash h (VerKeyKES d, VerKeyKES d) -> VerKeyKES (CompactSumKES h d)
VerKeyCompactSumKES forall (m :: Type -> Type) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
hashFromBytes ByteString
bs