{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoStarIsType #-}
-- Needed for ghc-9.6 to avoid a redunant constraint warning on the
-- `KESSignAlgorithm m (SimpleKES d t)` instance. Removing the constraint leaves another type
-- error which is rather opaque.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Mock key evolving signatures.
module Cardano.Crypto.KES.Simple (
  SimpleKES,
  SigKES (..),
  SignKeyKES (SignKeySimpleKES, ThunkySignKeySimpleKES),
  UnsoundPureSignKeyKES (UnsoundPureSignKeySimpleKES, UnsoundPureThunkySignKeySimpleKES),
)
where

import Cardano.Binary.FixedSizeCodec (
  FixedSizeCodec (..),
  decodeFixedSized,
  encodeFixedSized,
  guardFixedSized,
 )
import Control.Monad (unless, (<$!>))
import Control.Monad.Trans.Maybe
import qualified Data.ByteString as BS
import Data.Proxy (Proxy (..))
import Data.Vector (Vector, (!?))
import qualified Data.Vector as Vec
import GHC.Generics (Generic)
import GHC.TypeNats (KnownNat, Nat, natVal, type (*))
import NoThunks.Class (NoThunks)

import Cardano.Base.Bytes (splitsAt)
import Cardano.Binary (FromCBOR (..), ToCBOR (..))

import Cardano.Crypto.DSIGN
import qualified Cardano.Crypto.DSIGN.Class as DSIGN
import Cardano.Crypto.DirectSerialise
import Cardano.Crypto.KES.Class
import Cardano.Crypto.Libsodium.MLockedBytes
import Cardano.Crypto.Libsodium.MLockedSeed
import Cardano.Crypto.Seed
import Data.Maybe (fromMaybe)
import Data.Unit.Strict (forceElemsToWHNF)
import GHC.TypeLits (Natural)

data SimpleKES d (t :: Nat)

-- | 'VerKeySimpleKES' uses a boxed 'Vector', which is lazy in its elements.
-- We don't want laziness and the potential space leak, so we use this pattern
-- synonym to force the elements of the vector to WHNF upon construction.
--
-- The alternative is to use an unboxed vector, but that would require an
-- unreasonable 'Unbox' constraint.
pattern VerKeySimpleKES :: Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
pattern $mVerKeySimpleKES :: forall {r} {d} {t :: Nat}.
VerKeyKES (SimpleKES d t)
-> (Vector (VerKeyDSIGN d) -> r) -> ((# #) -> r) -> r
$bVerKeySimpleKES :: forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
VerKeySimpleKES v <- ThunkyVerKeySimpleKES v
  where
    VerKeySimpleKES Vector (VerKeyDSIGN d)
v = Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
ThunkyVerKeySimpleKES (Vector (VerKeyDSIGN d) -> Vector (VerKeyDSIGN d)
forall (t :: Type -> Type) a. Foldable t => t a -> t a
forceElemsToWHNF Vector (VerKeyDSIGN d)
v)

{-# COMPLETE VerKeySimpleKES #-}

-- | See 'VerKeySimpleKES'.
pattern SignKeySimpleKES :: Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
pattern $mSignKeySimpleKES :: forall {r} {d} {t :: Nat}.
SignKeyKES (SimpleKES d t)
-> (Vector (SignKeyDSIGNM d) -> r) -> ((# #) -> r) -> r
$bSignKeySimpleKES :: forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES v <- ThunkySignKeySimpleKES v
  where
    SignKeySimpleKES Vector (SignKeyDSIGNM d)
v = Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
ThunkySignKeySimpleKES (Vector (SignKeyDSIGNM d) -> Vector (SignKeyDSIGNM d)
forall (t :: Type -> Type) a. Foldable t => t a -> t a
forceElemsToWHNF Vector (SignKeyDSIGNM d)
v)

{-# COMPLETE SignKeySimpleKES #-}

-- | See 'VerKeySimpleKES'.
pattern UnsoundPureSignKeySimpleKES ::
  Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
pattern $mUnsoundPureSignKeySimpleKES :: forall {r} {d} {t :: Nat}.
UnsoundPureSignKeyKES (SimpleKES d t)
-> (Vector (SignKeyDSIGN d) -> r) -> ((# #) -> r) -> r
$bUnsoundPureSignKeySimpleKES :: forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureSignKeySimpleKES v <- UnsoundPureThunkySignKeySimpleKES v
  where
    UnsoundPureSignKeySimpleKES Vector (SignKeyDSIGN d)
v = Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureThunkySignKeySimpleKES (Vector (SignKeyDSIGN d) -> Vector (SignKeyDSIGN d)
forall (t :: Type -> Type) a. Foldable t => t a -> t a
forceElemsToWHNF Vector (SignKeyDSIGN d)
v)

{-# COMPLETE UnsoundPureSignKeySimpleKES #-}

instance
  ( DSIGNMAlgorithm d
  , KnownNat t
  , KnownNat (SeedSizeDSIGN d * t)
  , KnownNat (VerKeySizeDSIGN d * t)
  , KnownNat (SignKeySizeDSIGN d * t)
  ) =>
  KESAlgorithm (SimpleKES d t)
  where
  type SeedSizeKES (SimpleKES d t) = SeedSizeDSIGN d * t

  --
  -- Key and signature types
  --

  newtype VerKeyKES (SimpleKES d t)
    = ThunkyVerKeySimpleKES (Vector (VerKeyDSIGN d))
    deriving ((forall x.
 VerKeyKES (SimpleKES d t) -> Rep (VerKeyKES (SimpleKES d t)) x)
-> (forall x.
    Rep (VerKeyKES (SimpleKES d t)) x -> VerKeyKES (SimpleKES d t))
-> Generic (VerKeyKES (SimpleKES d t))
forall x.
Rep (VerKeyKES (SimpleKES d t)) x -> VerKeyKES (SimpleKES d t)
forall x.
VerKeyKES (SimpleKES d t) -> Rep (VerKeyKES (SimpleKES d t)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d (t :: Nat) x.
Rep (VerKeyKES (SimpleKES d t)) x -> VerKeyKES (SimpleKES d t)
forall d (t :: Nat) x.
VerKeyKES (SimpleKES d t) -> Rep (VerKeyKES (SimpleKES d t)) x
$cfrom :: forall d (t :: Nat) x.
VerKeyKES (SimpleKES d t) -> Rep (VerKeyKES (SimpleKES d t)) x
from :: forall x.
VerKeyKES (SimpleKES d t) -> Rep (VerKeyKES (SimpleKES d t)) x
$cto :: forall d (t :: Nat) x.
Rep (VerKeyKES (SimpleKES d t)) x -> VerKeyKES (SimpleKES d t)
to :: forall x.
Rep (VerKeyKES (SimpleKES d t)) x -> VerKeyKES (SimpleKES d t)
Generic)

  newtype SigKES (SimpleKES d t)
    = SigSimpleKES (SigDSIGN d)
    deriving ((forall x.
 SigKES (SimpleKES d t) -> Rep (SigKES (SimpleKES d t)) x)
-> (forall x.
    Rep (SigKES (SimpleKES d t)) x -> SigKES (SimpleKES d t))
-> Generic (SigKES (SimpleKES d t))
forall x. Rep (SigKES (SimpleKES d t)) x -> SigKES (SimpleKES d t)
forall x. SigKES (SimpleKES d t) -> Rep (SigKES (SimpleKES d t)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d (t :: Nat) x.
Rep (SigKES (SimpleKES d t)) x -> SigKES (SimpleKES d t)
forall d (t :: Nat) x.
SigKES (SimpleKES d t) -> Rep (SigKES (SimpleKES d t)) x
$cfrom :: forall d (t :: Nat) x.
SigKES (SimpleKES d t) -> Rep (SigKES (SimpleKES d t)) x
from :: forall x. SigKES (SimpleKES d t) -> Rep (SigKES (SimpleKES d t)) x
$cto :: forall d (t :: Nat) x.
Rep (SigKES (SimpleKES d t)) x -> SigKES (SimpleKES d t)
to :: forall x. Rep (SigKES (SimpleKES d t)) x -> SigKES (SimpleKES d t)
Generic)

  newtype SignKeyKES (SimpleKES d t)
    = ThunkySignKeySimpleKES (Vector (SignKeyDSIGNM d))
    deriving ((forall x.
 SignKeyKES (SimpleKES d t) -> Rep (SignKeyKES (SimpleKES d t)) x)
-> (forall x.
    Rep (SignKeyKES (SimpleKES d t)) x -> SignKeyKES (SimpleKES d t))
-> Generic (SignKeyKES (SimpleKES d t))
forall x.
Rep (SignKeyKES (SimpleKES d t)) x -> SignKeyKES (SimpleKES d t)
forall x.
SignKeyKES (SimpleKES d t) -> Rep (SignKeyKES (SimpleKES d t)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d (t :: Nat) x.
Rep (SignKeyKES (SimpleKES d t)) x -> SignKeyKES (SimpleKES d t)
forall d (t :: Nat) x.
SignKeyKES (SimpleKES d t) -> Rep (SignKeyKES (SimpleKES d t)) x
$cfrom :: forall d (t :: Nat) x.
SignKeyKES (SimpleKES d t) -> Rep (SignKeyKES (SimpleKES d t)) x
from :: forall x.
SignKeyKES (SimpleKES d t) -> Rep (SignKeyKES (SimpleKES d t)) x
$cto :: forall d (t :: Nat) x.
Rep (SignKeyKES (SimpleKES d t)) x -> SignKeyKES (SimpleKES d t)
to :: forall x.
Rep (SignKeyKES (SimpleKES d t)) x -> SignKeyKES (SimpleKES d t)
Generic)

  --
  -- Metadata and basic key operations
  --

  algorithmNameKES :: forall (proxy :: Type -> Type). proxy (SimpleKES d t) -> String
algorithmNameKES proxy (SimpleKES d t)
proxy = String
"simple_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Period -> String
forall a. Show a => a -> String
show (proxy (SimpleKES d t) -> Period
forall v (proxy :: Type -> Type).
KESAlgorithm v =>
proxy v -> Period
forall (proxy :: Type -> Type). proxy (SimpleKES d t) -> Period
totalPeriodsKES proxy (SimpleKES d t)
proxy)

  type TotalPeriodsKES (SimpleKES d t) = t

  --
  -- Core algorithm operations
  --

  type ContextKES (SimpleKES d t) = ContextDSIGN d
  type Signable (SimpleKES d t) = DSIGN.Signable d

  verifyKES :: forall a.
(Signable (SimpleKES d t) a, HasCallStack) =>
ContextKES (SimpleKES d t)
-> VerKeyKES (SimpleKES d t)
-> Period
-> a
-> SigKES (SimpleKES d t)
-> Either String ()
verifyKES ContextKES (SimpleKES d t)
ctxt (VerKeySimpleKES Vector (VerKeyDSIGN d)
vks) Period
j a
a (SigSimpleKES SigDSIGN d
sig) =
    case Vector (VerKeyDSIGN d)
vks Vector (VerKeyDSIGN d) -> Int -> Maybe (VerKeyDSIGN d)
forall a. Vector a -> Int -> Maybe a
!? forall a b. (Integral a, Num b) => a -> b
fromIntegral @Period @Int Period
j of
      Maybe (VerKeyDSIGN d)
Nothing -> String -> Either String ()
forall a b. a -> Either a b
Left String
"KES verification failed: out of range"
      Just VerKeyDSIGN d
vk -> ContextDSIGN d
-> VerKeyDSIGN d -> a -> SigDSIGN d -> Either String ()
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SigDSIGN v -> Either String ()
forall a.
(Signable d a, HasCallStack) =>
ContextDSIGN d
-> VerKeyDSIGN d -> a -> SigDSIGN d -> Either String ()
verifyDSIGN ContextKES (SimpleKES d t)
ContextDSIGN d
ctxt VerKeyDSIGN d
vk a
a SigDSIGN d
sig

  --
  -- raw serialise/deserialise
  --

  type SignKeySizeKES (SimpleKES d t) = SignKeySizeDSIGN d * t

  deriveVerKeyKES :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
SignKeyKES (SimpleKES d t) -> m (VerKeyKES (SimpleKES d t))
deriveVerKeyKES (SignKeySimpleKES Vector (SignKeyDSIGNM d)
sks) =
    Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
VerKeySimpleKES (Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t))
-> m (Vector (VerKeyDSIGN d)) -> m (VerKeyKES (SimpleKES d t))
forall (m :: Type -> Type) a b. Monad m => (a -> b) -> m a -> m b
<$!> (SignKeyDSIGNM d -> m (VerKeyDSIGN d))
-> Vector (SignKeyDSIGNM d) -> m (Vector (VerKeyDSIGN d))
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
Vec.mapM SignKeyDSIGNM d -> m (VerKeyDSIGN d)
forall v (m :: Type -> Type).
(DSIGNMAlgorithm v, MonadThrow m, MonadST m) =>
SignKeyDSIGNM v -> m (VerKeyDSIGN v)
forall (m :: Type -> Type).
(MonadThrow m, MonadST m) =>
SignKeyDSIGNM d -> m (VerKeyDSIGN d)
deriveVerKeyDSIGNM Vector (SignKeyDSIGNM d)
sks

  signKES :: forall a (m :: Type -> Type).
(Signable (SimpleKES d t) a, MonadST m, MonadThrow m) =>
ContextKES (SimpleKES d t)
-> Period
-> a
-> SignKeyKES (SimpleKES d t)
-> m (SigKES (SimpleKES d t))
signKES ContextKES (SimpleKES d t)
ctxt Period
j a
a (SignKeySimpleKES Vector (SignKeyDSIGNM d)
sks) =
    case Vector (SignKeyDSIGNM d)
sks Vector (SignKeyDSIGNM d) -> Int -> Maybe (SignKeyDSIGNM d)
forall a. Vector a -> Int -> Maybe a
!? forall a b. (Integral a, Num b) => a -> b
fromIntegral @Period @Int Period
j of
      Maybe (SignKeyDSIGNM d)
Nothing -> String -> m (SigKES (SimpleKES d t))
forall a. HasCallStack => String -> a
error (String
"SimpleKES.signKES: period out of range " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Period -> String
forall a. Show a => a -> String
show Period
j)
      Just SignKeyDSIGNM d
sk -> SigDSIGN d -> SigKES (SimpleKES d t)
forall d (t :: Nat). SigDSIGN d -> SigKES (SimpleKES d t)
SigSimpleKES (SigDSIGN d -> SigKES (SimpleKES d t))
-> m (SigDSIGN d) -> m (SigKES (SimpleKES d t))
forall (m :: Type -> Type) a b. Monad m => (a -> b) -> m a -> m b
<$!> (ContextDSIGN d -> a -> SignKeyDSIGNM d -> m (SigDSIGN d)
forall v a (m :: Type -> Type).
(DSIGNMAlgorithm v, Signable v a, MonadST m, MonadThrow m) =>
ContextDSIGN v -> a -> SignKeyDSIGNM v -> m (SigDSIGN v)
forall a (m :: Type -> Type).
(Signable d a, MonadST m, MonadThrow m) =>
ContextDSIGN d -> a -> SignKeyDSIGNM d -> m (SigDSIGN d)
signDSIGNM ContextKES (SimpleKES d t)
ContextDSIGN d
ctxt a
a (SignKeyDSIGNM d -> m (SigDSIGN d))
-> SignKeyDSIGNM d -> m (SigDSIGN d)
forall a b. (a -> b) -> a -> b
$! SignKeyDSIGNM d
sk)

  updateKESWith :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m
-> ContextKES (SimpleKES d t)
-> SignKeyKES (SimpleKES d t)
-> Period
-> m (Maybe (SignKeyKES (SimpleKES d t)))
updateKESWith MLockedAllocator m
allocator ContextKES (SimpleKES d t)
_ (ThunkySignKeySimpleKES Vector (SignKeyDSIGNM d)
sk) Period
t
    | Period
t Period -> Period -> Period
forall a. Num a => a -> a -> a
+ Period
1 Period -> Period -> Bool
forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Period (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @t)) = do
        Vector (SignKeyDSIGNM d)
sk' <- (SignKeyDSIGNM d -> m (SignKeyDSIGNM d))
-> Vector (SignKeyDSIGNM d) -> m (Vector (SignKeyDSIGNM d))
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
Vec.mapM (MLockedAllocator m -> SignKeyDSIGNM d -> m (SignKeyDSIGNM d)
forall v (m :: Type -> Type).
(DSIGNMAlgorithm v, MonadST m) =>
MLockedAllocator m -> SignKeyDSIGNM v -> m (SignKeyDSIGNM v)
forall (m :: Type -> Type).
MonadST m =>
MLockedAllocator m -> SignKeyDSIGNM d -> m (SignKeyDSIGNM d)
cloneKeyDSIGNMWith MLockedAllocator m
allocator) Vector (SignKeyDSIGNM d)
sk
        Maybe (SignKeyKES (SimpleKES d t))
-> m (Maybe (SignKeyKES (SimpleKES d t)))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe (SignKeyKES (SimpleKES d t))
 -> m (Maybe (SignKeyKES (SimpleKES d t))))
-> Maybe (SignKeyKES (SimpleKES d t))
-> m (Maybe (SignKeyKES (SimpleKES d t)))
forall a b. (a -> b) -> a -> b
$! SignKeyKES (SimpleKES d t) -> Maybe (SignKeyKES (SimpleKES d t))
forall a. a -> Maybe a
Just (SignKeyKES (SimpleKES d t) -> Maybe (SignKeyKES (SimpleKES d t)))
-> SignKeyKES (SimpleKES d t) -> Maybe (SignKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$! Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES Vector (SignKeyDSIGNM d)
sk'
    | Bool
otherwise = Maybe (SignKeyKES (SimpleKES d t))
-> m (Maybe (SignKeyKES (SimpleKES d t)))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (SignKeyKES (SimpleKES d t))
forall a. Maybe a
Nothing

  --
  -- Key generation
  --

  genKeyKESWith :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m
-> MLockedSeed (SeedSizeKES (SimpleKES d t))
-> m (SignKeyKES (SimpleKES d t))
genKeyKESWith MLockedAllocator m
allocator (MLockedSeed MLockedSizedBytes (SeedSizeKES (SimpleKES d t))
mlsb) = do
    let seedSize :: Period
seedSize = Proxy d -> Period
forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
seedSizeDSIGN (Proxy d
forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
        duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Int (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @t))
    Vector (SignKeyDSIGNM d)
sks <- Int -> (Int -> m (SignKeyDSIGNM d)) -> m (Vector (SignKeyDSIGNM d))
forall (m :: Type -> Type) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
Vec.generateM Int
duration ((Int -> m (SignKeyDSIGNM d)) -> m (Vector (SignKeyDSIGNM d)))
-> (Int -> m (SignKeyDSIGNM d)) -> m (Vector (SignKeyDSIGNM d))
forall a b. (a -> b) -> a -> b
$ \Int
t -> do
      MLockedSizedBytes (SeedSizeDSIGN d * t)
-> Int
-> (MLockedSizedBytes (SeedSizeDSIGN d) -> m (SignKeyDSIGNM d))
-> m (SignKeyDSIGNM d)
forall b (n :: Nat) (n' :: Nat) (m :: Type -> Type).
(MonadST m, KnownNat n, KnownNat n') =>
MLockedSizedBytes n -> Int -> (MLockedSizedBytes n' -> m b) -> m b
withMLSBChunk MLockedSizedBytes (SeedSizeDSIGN d * t)
MLockedSizedBytes (SeedSizeKES (SimpleKES d t))
mlsb (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Period
seedSize) ((MLockedSizedBytes (SeedSizeDSIGN d) -> m (SignKeyDSIGNM d))
 -> m (SignKeyDSIGNM d))
-> (MLockedSizedBytes (SeedSizeDSIGN d) -> m (SignKeyDSIGNM d))
-> m (SignKeyDSIGNM d)
forall a b. (a -> b) -> a -> b
$ \MLockedSizedBytes (SeedSizeDSIGN d)
mlsb' -> do
        MLockedAllocator m
-> MLockedSeed (SeedSizeDSIGN d) -> m (SignKeyDSIGNM d)
forall v (m :: Type -> Type).
(DSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m
-> MLockedSeed (SeedSizeDSIGN v) -> m (SignKeyDSIGNM v)
forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m
-> MLockedSeed (SeedSizeDSIGN d) -> m (SignKeyDSIGNM d)
genKeyDSIGNMWith MLockedAllocator m
allocator (MLockedSizedBytes (SeedSizeDSIGN d)
-> MLockedSeed (SeedSizeDSIGN d)
forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed MLockedSizedBytes (SeedSizeDSIGN d)
mlsb')
    SignKeyKES (SimpleKES d t) -> m (SignKeyKES (SimpleKES d t))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SignKeyKES (SimpleKES d t) -> m (SignKeyKES (SimpleKES d t)))
-> SignKeyKES (SimpleKES d t) -> m (SignKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$! Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES Vector (SignKeyDSIGNM d)
sks

  --
  -- Forgetting
  --

  forgetSignKeyKESWith :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m -> SignKeyKES (SimpleKES d t) -> m ()
forgetSignKeyKESWith MLockedAllocator m
allocator (SignKeySimpleKES Vector (SignKeyDSIGNM d)
sks) =
    (SignKeyDSIGNM d -> m ()) -> Vector (SignKeyDSIGNM d) -> m ()
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Vector a -> m ()
Vec.mapM_ (MLockedAllocator m -> SignKeyDSIGNM d -> m ()
forall v (m :: Type -> Type).
(DSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m -> SignKeyDSIGNM v -> m ()
forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m -> SignKeyDSIGNM d -> m ()
forgetSignKeyDSIGNMWith MLockedAllocator m
allocator) Vector (SignKeyDSIGNM d)
sks

instance
  ( KESAlgorithm (SimpleKES d t)
  , KnownNat t
  , DSIGNAlgorithm d
  , UnsoundDSIGNMAlgorithm d
  ) =>
  UnsoundPureKESAlgorithm (SimpleKES d t)
  where
  newtype UnsoundPureSignKeyKES (SimpleKES d t)
    = UnsoundPureThunkySignKeySimpleKES (Vector (SignKeyDSIGN d))
    deriving ((forall x.
 UnsoundPureSignKeyKES (SimpleKES d t)
 -> Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x)
-> (forall x.
    Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
    -> UnsoundPureSignKeyKES (SimpleKES d t))
-> Generic (UnsoundPureSignKeyKES (SimpleKES d t))
forall x.
Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
-> UnsoundPureSignKeyKES (SimpleKES d t)
forall x.
UnsoundPureSignKeyKES (SimpleKES d t)
-> Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d (t :: Nat) x.
Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
-> UnsoundPureSignKeyKES (SimpleKES d t)
forall d (t :: Nat) x.
UnsoundPureSignKeyKES (SimpleKES d t)
-> Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
$cfrom :: forall d (t :: Nat) x.
UnsoundPureSignKeyKES (SimpleKES d t)
-> Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
from :: forall x.
UnsoundPureSignKeyKES (SimpleKES d t)
-> Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
$cto :: forall d (t :: Nat) x.
Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
-> UnsoundPureSignKeyKES (SimpleKES d t)
to :: forall x.
Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
-> UnsoundPureSignKeyKES (SimpleKES d t)
Generic)

  unsoundPureGenKeyKES :: Seed -> UnsoundPureSignKeyKES (SimpleKES d t)
unsoundPureGenKeyKES Seed
seed =
    let seedSize :: Int
seedSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int (Proxy d -> Period
forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
seedSizeDSIGN (Proxy d
forall {k} (t :: k). Proxy t
Proxy :: Proxy d))
        duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Int (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @t))
        seedChunk :: Int -> Seed
seedChunk Int
t =
          ByteString -> Seed
mkSeedFromBytes (Int -> ByteString -> ByteString
BS.take Int
seedSize (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (Int
seedSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
t) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Seed -> ByteString
getSeedBytes Seed
seed)
     in Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureSignKeySimpleKES (Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t))
-> Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
forall a b. (a -> b) -> a -> b
$
          Int -> (Int -> SignKeyDSIGN d) -> Vector (SignKeyDSIGN d)
forall a. Int -> (Int -> a) -> Vector a
Vec.generate Int
duration (Seed -> SignKeyDSIGN d
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN (Seed -> SignKeyDSIGN d) -> (Int -> Seed) -> Int -> SignKeyDSIGN d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Seed
seedChunk)

  unsoundPureSignKES :: forall a.
Signable (SimpleKES d t) a =>
ContextKES (SimpleKES d t)
-> Period
-> a
-> UnsoundPureSignKeyKES (SimpleKES d t)
-> SigKES (SimpleKES d t)
unsoundPureSignKES ContextKES (SimpleKES d t)
ctxt Period
j a
a (UnsoundPureSignKeySimpleKES Vector (SignKeyDSIGN d)
sks) =
    case Vector (SignKeyDSIGN d)
sks Vector (SignKeyDSIGN d) -> Int -> Maybe (SignKeyDSIGN d)
forall a. Vector a -> Int -> Maybe a
!? forall a b. (Integral a, Num b) => a -> b
fromIntegral @Period @Int Period
j of
      Maybe (SignKeyDSIGN d)
Nothing -> String -> SigKES (SimpleKES d t)
forall a. HasCallStack => String -> a
error (String
"SimpleKES.unsoundPureSignKES: period out of range " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Period -> String
forall a. Show a => a -> String
show Period
j)
      Just SignKeyDSIGN d
sk -> SigDSIGN d -> SigKES (SimpleKES d t)
forall d (t :: Nat). SigDSIGN d -> SigKES (SimpleKES d t)
SigSimpleKES (SigDSIGN d -> SigKES (SimpleKES d t))
-> SigDSIGN d -> SigKES (SimpleKES d t)
forall a b. (a -> b) -> a -> b
$! ContextDSIGN d -> a -> SignKeyDSIGN d -> SigDSIGN d
forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SigDSIGN v
forall a.
(Signable d a, HasCallStack) =>
ContextDSIGN d -> a -> SignKeyDSIGN d -> SigDSIGN d
signDSIGN ContextKES (SimpleKES d t)
ContextDSIGN d
ctxt a
a SignKeyDSIGN d
sk

  unsoundPureUpdateKES :: ContextKES (SimpleKES d t)
-> UnsoundPureSignKeyKES (SimpleKES d t)
-> Period
-> Maybe (UnsoundPureSignKeyKES (SimpleKES d t))
unsoundPureUpdateKES ContextKES (SimpleKES d t)
_ (UnsoundPureThunkySignKeySimpleKES Vector (SignKeyDSIGN d)
sk) Period
t
    | Period
t Period -> Period -> Period
forall a. Num a => a -> a -> a
+ Period
1 Period -> Period -> Bool
forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Period (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @t)) =
        UnsoundPureSignKeyKES (SimpleKES d t)
-> Maybe (UnsoundPureSignKeyKES (SimpleKES d t))
forall a. a -> Maybe a
Just (UnsoundPureSignKeyKES (SimpleKES d t)
 -> Maybe (UnsoundPureSignKeyKES (SimpleKES d t)))
-> UnsoundPureSignKeyKES (SimpleKES d t)
-> Maybe (UnsoundPureSignKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$! Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureThunkySignKeySimpleKES Vector (SignKeyDSIGN d)
sk
    | Bool
otherwise =
        Maybe (UnsoundPureSignKeyKES (SimpleKES d t))
forall a. Maybe a
Nothing

  unsoundPureDeriveVerKeyKES :: UnsoundPureSignKeyKES (SimpleKES d t) -> VerKeyKES (SimpleKES d t)
unsoundPureDeriveVerKeyKES (UnsoundPureSignKeySimpleKES Vector (SignKeyDSIGN d)
sks) =
    Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
VerKeySimpleKES (Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t))
-> Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
forall a b. (a -> b) -> a -> b
$! (SignKeyDSIGN d -> VerKeyDSIGN d)
-> Vector (SignKeyDSIGN d) -> Vector (VerKeyDSIGN d)
forall a b. (a -> b) -> Vector a -> Vector b
Vec.map SignKeyDSIGN d -> VerKeyDSIGN d
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN Vector (SignKeyDSIGN d)
sks

  unsoundPureSignKeyKESToSoundSignKeyKES :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
UnsoundPureSignKeyKES (SimpleKES d t)
-> m (SignKeyKES (SimpleKES d t))
unsoundPureSignKeyKESToSoundSignKeyKES (UnsoundPureThunkySignKeySimpleKES Vector (SignKeyDSIGN d)
sks) = do
    Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES (Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t))
-> m (Vector (SignKeyDSIGNM d)) -> m (SignKeyKES (SimpleKES d t))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (SignKeyDSIGN d -> m (SignKeyDSIGNM d))
-> Vector (SignKeyDSIGN d) -> m (Vector (SignKeyDSIGNM d))
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
mapM SignKeyDSIGN d -> m (SignKeyDSIGNM d)
convertSK Vector (SignKeyDSIGN d)
sks
    where
      convertSK :: SignKeyDSIGN d -> m (SignKeyDSIGNM d)
convertSK =
        (Maybe (SignKeyDSIGNM d) -> SignKeyDSIGNM d)
-> m (Maybe (SignKeyDSIGNM d)) -> m (SignKeyDSIGNM d)
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (SignKeyDSIGNM d -> Maybe (SignKeyDSIGNM d) -> SignKeyDSIGNM d
forall a. a -> Maybe a -> a
fromMaybe (String -> SignKeyDSIGNM d
forall a. HasCallStack => String -> a
error String
"unsoundPureSignKeyKESToSoundSignKeyKES: deserialisation failed"))
          (m (Maybe (SignKeyDSIGNM d)) -> m (SignKeyDSIGNM d))
-> (SignKeyDSIGN d -> m (Maybe (SignKeyDSIGNM d)))
-> SignKeyDSIGN d
-> m (SignKeyDSIGNM d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> m (Maybe (SignKeyDSIGNM d))
forall v (m :: Type -> Type).
(UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
ByteString -> m (Maybe (SignKeyDSIGNM v))
rawDeserialiseSignKeyDSIGNM
          (ByteString -> m (Maybe (SignKeyDSIGNM d)))
-> (SignKeyDSIGN d -> ByteString)
-> SignKeyDSIGN d
-> m (Maybe (SignKeyDSIGNM d))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyDSIGN d -> ByteString
forall a. FixedSizeCodec a => a -> ByteString
rawEncodeFixedSized

instance
  (UnsoundDSIGNMAlgorithm d, KnownNat t, KESAlgorithm (SimpleKES d t)) =>
  UnsoundKESAlgorithm (SimpleKES d t)
  where
  --
  -- raw serialise/deserialise
  --

  rawSerialiseSignKeyKES :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
SignKeyKES (SimpleKES d t) -> m ByteString
rawSerialiseSignKeyKES (SignKeySimpleKES Vector (SignKeyDSIGNM d)
sks) =
    [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> m [ByteString] -> m ByteString
forall (m :: Type -> Type) a b. Monad m => (a -> b) -> m a -> m b
<$!> (SignKeyDSIGNM d -> m ByteString)
-> [SignKeyDSIGNM d] -> m [ByteString]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM SignKeyDSIGNM d -> m ByteString
forall v (m :: Type -> Type).
(UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyDSIGNM v -> m ByteString
forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
SignKeyDSIGNM d -> m ByteString
rawSerialiseSignKeyDSIGNM (Vector (SignKeyDSIGNM d) -> [SignKeyDSIGNM d]
forall a. Vector a -> [a]
Vec.toList Vector (SignKeyDSIGNM d)
sks)

  rawDeserialiseSignKeyKESWith :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m
-> ByteString -> m (Maybe (SignKeyKES (SimpleKES d t)))
rawDeserialiseSignKeyKESWith MLockedAllocator m
allocator ByteString
bs
    | let duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Int (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
          sizeKey :: Int
sizeKey = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int (Proxy (SignKeyDSIGN d) -> Period
forall a (proxy :: Type -> Type).
FixedSizeCodec a =>
proxy a -> Period
fixedSize (Proxy (SignKeyDSIGN d)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (SignKeyDSIGN d)))
    , [ByteString]
skbs <- [Int] -> ByteString -> [ByteString]
splitsAt (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
duration Int
sizeKey) ByteString
bs
    , [ByteString] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ByteString]
skbs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
duration =
        MaybeT m (SignKeyKES (SimpleKES d t))
-> m (Maybe (SignKeyKES (SimpleKES d t)))
forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m (SignKeyKES (SimpleKES d t))
 -> m (Maybe (SignKeyKES (SimpleKES d t))))
-> MaybeT m (SignKeyKES (SimpleKES d t))
-> m (Maybe (SignKeyKES (SimpleKES d t)))
forall a b. (a -> b) -> a -> b
$ do
          [SignKeyDSIGNM d]
sks <- (ByteString -> MaybeT m (SignKeyDSIGNM d))
-> [ByteString] -> MaybeT m [SignKeyDSIGNM d]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (m (Maybe (SignKeyDSIGNM d)) -> MaybeT m (SignKeyDSIGNM d)
forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe (SignKeyDSIGNM d)) -> MaybeT m (SignKeyDSIGNM d))
-> (ByteString -> m (Maybe (SignKeyDSIGNM d)))
-> ByteString
-> MaybeT m (SignKeyDSIGNM d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MLockedAllocator m -> ByteString -> m (Maybe (SignKeyDSIGNM d))
forall v (m :: Type -> Type).
(UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m -> ByteString -> m (Maybe (SignKeyDSIGNM v))
forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
MLockedAllocator m -> ByteString -> m (Maybe (SignKeyDSIGNM d))
rawDeserialiseSignKeyDSIGNMWith MLockedAllocator m
allocator) [ByteString]
skbs
          SignKeyKES (SimpleKES d t) -> MaybeT m (SignKeyKES (SimpleKES d t))
forall a. a -> MaybeT m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SignKeyKES (SimpleKES d t)
 -> MaybeT m (SignKeyKES (SimpleKES d t)))
-> SignKeyKES (SimpleKES d t)
-> MaybeT m (SignKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$! Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES ([SignKeyDSIGNM d] -> Vector (SignKeyDSIGNM d)
forall a. [a] -> Vector a
Vec.fromList [SignKeyDSIGNM d]
sks)
    | Bool
otherwise =
        Maybe (SignKeyKES (SimpleKES d t))
-> m (Maybe (SignKeyKES (SimpleKES d t)))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe (SignKeyKES (SimpleKES d t))
forall a. Maybe a
Nothing

instance
  ( DSIGNAlgorithm d
  , KnownNat t
  , KnownNat (VerKeySizeDSIGN d * t)
  ) =>
  FixedSizeCodec (VerKeyKES (SimpleKES d t))
  where
  type FixedSize (VerKeyKES (SimpleKES d t)) = VerKeySizeDSIGN d * t
  rawEncodeFixedSized :: VerKeyKES (SimpleKES d t) -> ByteString
rawEncodeFixedSized (VerKeySimpleKES Vector (VerKeyDSIGN d)
vks) =
    [ByteString] -> ByteString
BS.concat [VerKeyDSIGN d -> ByteString
forall a. FixedSizeCodec a => a -> ByteString
rawEncodeFixedSized VerKeyDSIGN d
vk | VerKeyDSIGN d
vk <- Vector (VerKeyDSIGN d) -> [VerKeyDSIGN d]
forall a. Vector a -> [a]
Vec.toList Vector (VerKeyDSIGN d)
vks]
  rawDecodeFixedSized :: forall (m :: Type -> Type).
MonadFail m =>
ByteString -> m (VerKeyKES (SimpleKES d t))
rawDecodeFixedSized ByteString
bs = ByteString
-> m (VerKeyKES (SimpleKES d t)) -> m (VerKeyKES (SimpleKES d t))
forall a (m :: Type -> Type).
(FixedSizeCodec a, MonadFail m, Typeable a) =>
ByteString -> m a -> m a
guardFixedSized ByteString
bs (m (VerKeyKES (SimpleKES d t)) -> m (VerKeyKES (SimpleKES d t)))
-> m (VerKeyKES (SimpleKES d t)) -> m (VerKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$ do
    let duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Int (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
        sizeKey :: Int
sizeKey = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int (Proxy (VerKeyDSIGN d) -> Period
forall a (proxy :: Type -> Type).
FixedSizeCodec a =>
proxy a -> Period
fixedSize (Proxy (VerKeyDSIGN d)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (VerKeyDSIGN d)))
        vkbs :: [ByteString]
vkbs = [Int] -> ByteString -> [ByteString]
splitsAt (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
duration Int
sizeKey) ByteString
bs
    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ByteString]
vkbs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
duration) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"VerKeyKES (SimpleKES d t): vkbs length is not equal to duration"
    [VerKeyDSIGN d]
vks <- (ByteString -> m (VerKeyDSIGN d))
-> [ByteString] -> m [VerKeyDSIGN d]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ByteString -> m (VerKeyDSIGN d)
forall a (m :: Type -> Type).
(FixedSizeCodec a, MonadFail m) =>
ByteString -> m a
forall (m :: Type -> Type).
MonadFail m =>
ByteString -> m (VerKeyDSIGN d)
rawDecodeFixedSized [ByteString]
vkbs
    VerKeyKES (SimpleKES d t) -> m (VerKeyKES (SimpleKES d t))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (VerKeyKES (SimpleKES d t) -> m (VerKeyKES (SimpleKES d t)))
-> VerKeyKES (SimpleKES d t) -> m (VerKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$! Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
VerKeySimpleKES ([VerKeyDSIGN d] -> Vector (VerKeyDSIGN d)
forall a. [a] -> Vector a
Vec.fromList [VerKeyDSIGN d]
vks)
  {-# INLINE rawDecodeFixedSized #-}

instance
  (DSIGNAlgorithm d, KnownNat t) =>
  FixedSizeCodec (SigKES (SimpleKES d t))
  where
  type FixedSize (SigKES (SimpleKES d t)) = SigSizeDSIGN d
  rawEncodeFixedSized :: SigKES (SimpleKES d t) -> ByteString
rawEncodeFixedSized (SigSimpleKES SigDSIGN d
sig) = SigDSIGN d -> ByteString
forall a. FixedSizeCodec a => a -> ByteString
rawEncodeFixedSized SigDSIGN d
sig
  rawDecodeFixedSized :: forall (m :: Type -> Type).
MonadFail m =>
ByteString -> m (SigKES (SimpleKES d t))
rawDecodeFixedSized ByteString
bs = SigDSIGN d -> SigKES (SimpleKES d t)
forall d (t :: Nat). SigDSIGN d -> SigKES (SimpleKES d t)
SigSimpleKES (SigDSIGN d -> SigKES (SimpleKES d t))
-> m (SigDSIGN d) -> m (SigKES (SimpleKES d t))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m (SigDSIGN d)
forall a (m :: Type -> Type).
(FixedSizeCodec a, MonadFail m) =>
ByteString -> m a
forall (m :: Type -> Type).
MonadFail m =>
ByteString -> m (SigDSIGN d)
rawDecodeFixedSized ByteString
bs
  {-# INLINE rawDecodeFixedSized #-}

instance
  ( DSIGNAlgorithm d
  , KnownNat t
  , KnownNat (SignKeySizeDSIGN d * t)
  ) =>
  FixedSizeCodec (UnsoundPureSignKeyKES (SimpleKES d t))
  where
  type FixedSize (UnsoundPureSignKeyKES (SimpleKES d t)) = SignKeySizeKES (SimpleKES d t)
  rawEncodeFixedSized :: UnsoundPureSignKeyKES (SimpleKES d t) -> ByteString
rawEncodeFixedSized (UnsoundPureSignKeySimpleKES Vector (SignKeyDSIGN d)
sks) =
    (SignKeyDSIGN d -> ByteString)
-> Vector (SignKeyDSIGN d) -> ByteString
forall m a. Monoid m => (a -> m) -> Vector a -> m
forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SignKeyDSIGN d -> ByteString
forall a. FixedSizeCodec a => a -> ByteString
rawEncodeFixedSized Vector (SignKeyDSIGN d)
sks
  rawDecodeFixedSized :: forall (m :: Type -> Type).
MonadFail m =>
ByteString -> m (UnsoundPureSignKeyKES (SimpleKES d t))
rawDecodeFixedSized ByteString
bs = ByteString
-> m (UnsoundPureSignKeyKES (SimpleKES d t))
-> m (UnsoundPureSignKeyKES (SimpleKES d t))
forall a (m :: Type -> Type).
(FixedSizeCodec a, MonadFail m, Typeable a) =>
ByteString -> m a -> m a
guardFixedSized ByteString
bs (m (UnsoundPureSignKeyKES (SimpleKES d t))
 -> m (UnsoundPureSignKeyKES (SimpleKES d t)))
-> m (UnsoundPureSignKeyKES (SimpleKES d t))
-> m (UnsoundPureSignKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$ do
    let duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Int (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
        sizeKey :: Int
sizeKey = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int (Proxy (SignKeyDSIGN d) -> Period
forall a (proxy :: Type -> Type).
FixedSizeCodec a =>
proxy a -> Period
fixedSize (Proxy (SignKeyDSIGN d)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (SignKeyDSIGN d)))
        skbs :: [ByteString]
skbs = [Int] -> ByteString -> [ByteString]
splitsAt (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
duration Int
sizeKey) ByteString
bs
    Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ByteString]
skbs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
duration) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"UnsoundPureSignKeyKES (SimpleKES d t): vkbs length is not equal to duration"
    [SignKeyDSIGN d]
sks <- (ByteString -> m (SignKeyDSIGN d))
-> [ByteString] -> m [SignKeyDSIGN d]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM ByteString -> m (SignKeyDSIGN d)
forall a (m :: Type -> Type).
(FixedSizeCodec a, MonadFail m) =>
ByteString -> m a
forall (m :: Type -> Type).
MonadFail m =>
ByteString -> m (SignKeyDSIGN d)
rawDecodeFixedSized [ByteString]
skbs
    UnsoundPureSignKeyKES (SimpleKES d t)
-> m (UnsoundPureSignKeyKES (SimpleKES d t))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (UnsoundPureSignKeyKES (SimpleKES d t)
 -> m (UnsoundPureSignKeyKES (SimpleKES d t)))
-> UnsoundPureSignKeyKES (SimpleKES d t)
-> m (UnsoundPureSignKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$! Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureSignKeySimpleKES ([SignKeyDSIGN d] -> Vector (SignKeyDSIGN d)
forall a. [a] -> Vector a
Vec.fromList [SignKeyDSIGN d]
sks)
  {-# INLINE rawDecodeFixedSized #-}

deriving instance DSIGNMAlgorithm d => Show (VerKeyKES (SimpleKES d t))
deriving instance (DSIGNMAlgorithm d, Show (SignKeyDSIGNM d)) => Show (SignKeyKES (SimpleKES d t))
deriving instance
  (DSIGNMAlgorithm d, Show (SignKeyDSIGNM d)) => Show (UnsoundPureSignKeyKES (SimpleKES d t))
deriving instance DSIGNMAlgorithm d => Show (SigKES (SimpleKES d t))

deriving instance DSIGNMAlgorithm d => Eq (VerKeyKES (SimpleKES d t))
deriving instance DSIGNMAlgorithm d => Eq (SigKES (SimpleKES d t))
deriving instance Eq (SignKeyDSIGN d) => Eq (UnsoundPureSignKeyKES (SimpleKES d t))

instance DSIGNMAlgorithm d => NoThunks (SigKES (SimpleKES d t))
instance DSIGNMAlgorithm d => NoThunks (SignKeyKES (SimpleKES d t))
instance DSIGNMAlgorithm d => NoThunks (UnsoundPureSignKeyKES (SimpleKES d t))
instance DSIGNMAlgorithm d => NoThunks (VerKeyKES (SimpleKES d t))

instance
  ( DSIGNMAlgorithm d
  , KnownNat t
  , KnownNat (SeedSizeDSIGN d * t)
  , KnownNat (VerKeySizeDSIGN d * t)
  , KnownNat (SignKeySizeDSIGN d * t)
  ) =>
  ToCBOR (VerKeyKES (SimpleKES d t))
  where
  toCBOR :: VerKeyKES (SimpleKES d t) -> Encoding
toCBOR = VerKeyKES (SimpleKES d t) -> Encoding
forall a. FixedSizeCodec a => a -> Encoding
encodeFixedSized
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (VerKeyKES (SimpleKES d t)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
_size = Proxy (VerKeyKES (SimpleKES d t)) -> Size
forall v. KESAlgorithm v => Proxy (VerKeyKES v) -> Size
encodedVerKeyKESSizeExpr

instance
  ( DSIGNMAlgorithm d
  , KnownNat t
  , KnownNat (SeedSizeDSIGN d * t)
  , KnownNat (VerKeySizeDSIGN d * t)
  , KnownNat (SignKeySizeDSIGN d * t)
  ) =>
  FromCBOR (VerKeyKES (SimpleKES d t))
  where
  fromCBOR :: forall s. Decoder s (VerKeyKES (SimpleKES d t))
fromCBOR = Decoder s (VerKeyKES (SimpleKES d t))
forall a s. FixedSizeCodec a => Decoder s a
decodeFixedSized

instance
  ( DSIGNMAlgorithm d
  , KnownNat t
  , KnownNat (SeedSizeDSIGN d * t)
  , KnownNat (VerKeySizeDSIGN d * t)
  , KnownNat (SignKeySizeDSIGN d * t)
  ) =>
  ToCBOR (SigKES (SimpleKES d t))
  where
  toCBOR :: SigKES (SimpleKES d t) -> Encoding
toCBOR = SigKES (SimpleKES d t) -> Encoding
forall a. FixedSizeCodec a => a -> Encoding
encodeFixedSized
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (SigKES (SimpleKES d t)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
_size = Proxy (SigKES (SimpleKES d t)) -> Size
forall v. KESAlgorithm v => Proxy (SigKES v) -> Size
encodedSigKESSizeExpr

instance
  ( DSIGNMAlgorithm d
  , KnownNat t
  , KnownNat (SeedSizeDSIGN d * t)
  , KnownNat (VerKeySizeDSIGN d * t)
  , KnownNat (SignKeySizeDSIGN d * t)
  ) =>
  FromCBOR (SigKES (SimpleKES d t))
  where
  fromCBOR :: forall s. Decoder s (SigKES (SimpleKES d t))
fromCBOR = Decoder s (SigKES (SimpleKES d t))
forall a s. FixedSizeCodec a => Decoder s a
decodeFixedSized

instance DirectSerialise (VerKeyDSIGN d) => DirectSerialise (VerKeyKES (SimpleKES d t)) where
  directSerialise :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> VerKeyKES (SimpleKES d t) -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push (VerKeySimpleKES Vector (VerKeyDSIGN d)
vks) =
    (VerKeyDSIGN d -> m ()) -> Vector (VerKeyDSIGN d) -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ptr CChar -> CSize -> m ()) -> VerKeyDSIGN d -> m ()
forall a (m :: Type -> Type).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> m ()
forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> VerKeyDSIGN d -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push) Vector (VerKeyDSIGN d)
vks

instance (DirectDeserialise (VerKeyDSIGN d), KnownNat t) => DirectDeserialise (VerKeyKES (SimpleKES d t)) where
  directDeserialise :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m (VerKeyKES (SimpleKES d t))
directDeserialise Ptr CChar -> CSize -> m ()
pull = do
    let duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Int (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
    Vector (VerKeyDSIGN d)
vks <- Int -> m (VerKeyDSIGN d) -> m (Vector (VerKeyDSIGN d))
forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vec.replicateM Int
duration ((Ptr CChar -> CSize -> m ()) -> m (VerKeyDSIGN d)
forall a (m :: Type -> Type).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m (VerKeyDSIGN d)
directDeserialise Ptr CChar -> CSize -> m ()
pull)
    VerKeyKES (SimpleKES d t) -> m (VerKeyKES (SimpleKES d t))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (VerKeyKES (SimpleKES d t) -> m (VerKeyKES (SimpleKES d t)))
-> VerKeyKES (SimpleKES d t) -> m (VerKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$! Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
VerKeySimpleKES Vector (VerKeyDSIGN d)
vks

instance DirectSerialise (SignKeyDSIGNM d) => DirectSerialise (SignKeyKES (SimpleKES d t)) where
  directSerialise :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> SignKeyKES (SimpleKES d t) -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push (SignKeySimpleKES Vector (SignKeyDSIGNM d)
sks) =
    (SignKeyDSIGNM d -> m ()) -> Vector (SignKeyDSIGNM d) -> m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Ptr CChar -> CSize -> m ()) -> SignKeyDSIGNM d -> m ()
forall a (m :: Type -> Type).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> m ()
forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> SignKeyDSIGNM d -> m ()
directSerialise Ptr CChar -> CSize -> m ()
push) Vector (SignKeyDSIGNM d)
sks

instance (DirectDeserialise (SignKeyDSIGNM d), KnownNat t) => DirectDeserialise (SignKeyKES (SimpleKES d t)) where
  directDeserialise :: forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m (SignKeyKES (SimpleKES d t))
directDeserialise Ptr CChar -> CSize -> m ()
pull = do
    let duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural @Int (Proxy t -> Nat
forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
    Vector (SignKeyDSIGNM d)
sks <- Int -> m (SignKeyDSIGNM d) -> m (Vector (SignKeyDSIGNM d))
forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vec.replicateM Int
duration ((Ptr CChar -> CSize -> m ()) -> m (SignKeyDSIGNM d)
forall a (m :: Type -> Type).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
forall (m :: Type -> Type).
(MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m (SignKeyDSIGNM d)
directDeserialise Ptr CChar -> CSize -> m ()
pull)
    SignKeyKES (SimpleKES d t) -> m (SignKeyKES (SimpleKES d t))
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (SignKeyKES (SimpleKES d t) -> m (SignKeyKES (SimpleKES d t)))
-> SignKeyKES (SimpleKES d t) -> m (SignKeyKES (SimpleKES d t))
forall a b. (a -> b) -> a -> b
$! Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES Vector (SignKeyDSIGNM d)
sks