{-# 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 Control.Monad ((<$!>))
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.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 Cardano.Crypto.Util
import Data.Maybe (fromMaybe)
import Data.Unit.Strict (forceElemsToWHNF)

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 (SizeVerKeyDSIGN d * t)
  , KnownNat (SizeSignKeyDSIGN 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)

  totalPeriodsKES :: forall (proxy :: Type -> Type). proxy (SimpleKES d t) -> Period
totalPeriodsKES proxy (SimpleKES d t)
_ = Nat -> Period
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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))

  --
  -- 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
!? Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 ContextDSIGN d
ContextKES (SimpleKES d t)
ctxt VerKeyDSIGN d
vk a
a SigDSIGN d
sig

  --
  -- raw serialise/deserialise
  --

  type SizeVerKeyKES (SimpleKES d t) = SizeVerKeyDSIGN d * t
  type SizeSignKeyKES (SimpleKES d t) = SizeSignKeyDSIGN d * t
  type SizeSigKES (SimpleKES d t) = SizeSigDSIGN d

  rawSerialiseVerKeyKES :: VerKeyKES (SimpleKES d t) -> ByteString
rawSerialiseVerKeyKES (VerKeySimpleKES Vector (VerKeyDSIGN d)
vks) =
    [ByteString] -> ByteString
BS.concat [VerKeyDSIGN d -> ByteString
forall v. DSIGNAlgorithm v => VerKeyDSIGN v -> ByteString
rawSerialiseVerKeyDSIGN VerKeyDSIGN d
vk | VerKeyDSIGN d
vk <- Vector (VerKeyDSIGN d) -> [VerKeyDSIGN d]
forall a. Vector a -> [a]
Vec.toList Vector (VerKeyDSIGN d)
vks]

  rawSerialiseSigKES :: SigKES (SimpleKES d t) -> ByteString
rawSerialiseSigKES (SigSimpleKES SigDSIGN d
sig) =
    SigDSIGN d -> ByteString
forall v. DSIGNAlgorithm v => SigDSIGN v -> ByteString
rawSerialiseSigDSIGN SigDSIGN d
sig

  rawDeserialiseVerKeyKES :: ByteString -> Maybe (VerKeyKES (SimpleKES d t))
rawDeserialiseVerKeyKES ByteString
bs
    | let duration :: Int
duration = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 = Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy d -> Period
forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
sizeVerKeyDSIGN (Proxy d
forall {k} (t :: k). Proxy t
Proxy :: Proxy d))
    , [ByteString]
vkbs <- [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]
vkbs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
duration
    , Just [VerKeyDSIGN d]
vks <- (ByteString -> Maybe (VerKeyDSIGN d))
-> [ByteString] -> Maybe [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 -> Maybe (VerKeyDSIGN d)
forall v. DSIGNAlgorithm v => ByteString -> Maybe (VerKeyDSIGN v)
rawDeserialiseVerKeyDSIGN [ByteString]
vkbs =
        VerKeyKES (SimpleKES d t) -> Maybe (VerKeyKES (SimpleKES d t))
forall a. a -> Maybe a
Just (VerKeyKES (SimpleKES d t) -> Maybe (VerKeyKES (SimpleKES d t)))
-> VerKeyKES (SimpleKES d t) -> Maybe (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)
    | Bool
otherwise =
        Maybe (VerKeyKES (SimpleKES d t))
forall a. Maybe a
Nothing

  rawDeserialiseSigKES :: ByteString -> Maybe (SigKES (SimpleKES d t))
rawDeserialiseSigKES = (SigDSIGN d -> SigKES (SimpleKES d t))
-> Maybe (SigDSIGN d) -> Maybe (SigKES (SimpleKES d t))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap SigDSIGN d -> SigKES (SimpleKES d t)
forall d (t :: Nat). SigDSIGN d -> SigKES (SimpleKES d t)
SigSimpleKES (Maybe (SigDSIGN d) -> Maybe (SigKES (SimpleKES d t)))
-> (ByteString -> Maybe (SigDSIGN d))
-> ByteString
-> Maybe (SigKES (SimpleKES d t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (SigDSIGN d)
forall v. DSIGNAlgorithm v => ByteString -> Maybe (SigDSIGN v)
rawDeserialiseSigDSIGN

  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
!? Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 ContextDSIGN d
ContextKES (SimpleKES d t)
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
< Nat -> Period
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 = Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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
!? Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 ContextDSIGN d
ContextKES (SimpleKES d t)
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
< Nat -> Period
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 v. DSIGNAlgorithm v => SignKeyDSIGN v -> ByteString
rawSerialiseSignKeyDSIGN

  rawSerialiseUnsoundPureSignKeyKES :: UnsoundPureSignKeyKES (SimpleKES d t) -> ByteString
rawSerialiseUnsoundPureSignKeyKES (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 v. DSIGNAlgorithm v => SignKeyDSIGN v -> ByteString
rawSerialiseSignKeyDSIGN Vector (SignKeyDSIGN d)
sks

  rawDeserialiseUnsoundPureSignKeyKES :: ByteString -> Maybe (UnsoundPureSignKeyKES (SimpleKES d t))
rawDeserialiseUnsoundPureSignKeyKES ByteString
bs
    | let duration :: Int
duration = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 = Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy d -> Period
forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
sizeSignKeyDSIGN (Proxy d
forall {k} (t :: k). Proxy t
Proxy :: Proxy d))
          skbs :: [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 =
        do
          [SignKeyDSIGN d]
sks <- (ByteString -> Maybe (SignKeyDSIGN d))
-> [ByteString] -> Maybe [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 -> Maybe (SignKeyDSIGN d)
forall v. DSIGNAlgorithm v => ByteString -> Maybe (SignKeyDSIGN v)
rawDeserialiseSignKeyDSIGN [ByteString]
skbs
          UnsoundPureSignKeyKES (SimpleKES d t)
-> Maybe (UnsoundPureSignKeyKES (SimpleKES d t))
forall a. a -> Maybe a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (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)
UnsoundPureSignKeySimpleKES ([SignKeyDSIGN d] -> Vector (SignKeyDSIGN d)
forall a. [a] -> Vector a
Vec.fromList [SignKeyDSIGN d]
sks)
    | Bool
otherwise =
        Maybe (UnsoundPureSignKeyKES (SimpleKES d t))
forall a. Maybe a
Nothing

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 = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 = Period -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy d -> Period
forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
sizeSignKeyDSIGN (Proxy d
forall {k} (t :: k). Proxy t
Proxy :: Proxy 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

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 (SizeVerKeyDSIGN d * t)
  , KnownNat (SizeSignKeyDSIGN d * t)
  ) =>
  ToCBOR (VerKeyKES (SimpleKES d t))
  where
  toCBOR :: VerKeyKES (SimpleKES d t) -> Encoding
toCBOR = VerKeyKES (SimpleKES d t) -> Encoding
forall v. KESAlgorithm v => VerKeyKES v -> Encoding
encodeVerKeyKES
  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 (SizeVerKeyDSIGN d * t)
  , KnownNat (SizeSignKeyDSIGN 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 v s. KESAlgorithm v => Decoder s (VerKeyKES v)
decodeVerKeyKES

instance
  ( DSIGNMAlgorithm d
  , KnownNat t
  , KnownNat (SeedSizeDSIGN d * t)
  , KnownNat (SizeVerKeyDSIGN d * t)
  , KnownNat (SizeSignKeyDSIGN d * t)
  ) =>
  ToCBOR (SigKES (SimpleKES d t))
  where
  toCBOR :: SigKES (SimpleKES d t) -> Encoding
toCBOR = SigKES (SimpleKES d t) -> Encoding
forall v. KESAlgorithm v => SigKES v -> Encoding
encodeSigKES
  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 (SizeVerKeyDSIGN d * t)
  , KnownNat (SizeSignKeyDSIGN 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 v s. KESAlgorithm v => Decoder s (SigKES v)
decodeSigKES

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 = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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 = Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (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