{-# 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 $bVerKeySimpleKES :: forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
$mVerKeySimpleKES :: forall {r} {d} {t :: Nat}.
VerKeyKES (SimpleKES d t)
-> (Vector (VerKeyDSIGN d) -> r) -> ((# #) -> r) -> r
VerKeySimpleKES v <- ThunkyVerKeySimpleKES v
  where
    VerKeySimpleKES Vector (VerKeyDSIGN d)
v = forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
ThunkyVerKeySimpleKES (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 $bSignKeySimpleKES :: forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
$mSignKeySimpleKES :: forall {r} {d} {t :: Nat}.
SignKeyKES (SimpleKES d t)
-> (Vector (SignKeyDSIGNM d) -> r) -> ((# #) -> r) -> r
SignKeySimpleKES v <- ThunkySignKeySimpleKES v
  where
    SignKeySimpleKES Vector (SignKeyDSIGNM d)
v = forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
ThunkySignKeySimpleKES (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 $bUnsoundPureSignKeySimpleKES :: forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
$mUnsoundPureSignKeySimpleKES :: forall {r} {d} {t :: Nat}.
UnsoundPureSignKeyKES (SimpleKES d t)
-> (Vector (SignKeyDSIGN d) -> r) -> ((# #) -> r) -> r
UnsoundPureSignKeySimpleKES v <- UnsoundPureThunkySignKeySimpleKES v
  where
    UnsoundPureSignKeySimpleKES Vector (SignKeyDSIGN d)
v = forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureThunkySignKeySimpleKES (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 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
$cto :: forall d (t :: Nat) x.
Rep (VerKeyKES (SimpleKES d t)) x -> VerKeyKES (SimpleKES d t)
$cfrom :: forall d (t :: Nat) x.
VerKeyKES (SimpleKES d t) -> Rep (VerKeyKES (SimpleKES d t)) x
Generic)

  newtype SigKES (SimpleKES d t)
    = SigSimpleKES (SigDSIGN d)
    deriving (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
$cto :: forall d (t :: Nat) x.
Rep (SigKES (SimpleKES d t)) x -> SigKES (SimpleKES d t)
$cfrom :: forall d (t :: Nat) x.
SigKES (SimpleKES d t) -> Rep (SigKES (SimpleKES d t)) x
Generic)

  newtype SignKeyKES (SimpleKES d t)
    = ThunkySignKeySimpleKES (Vector (SignKeyDSIGNM d))
    deriving (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
$cto :: forall d (t :: Nat) x.
Rep (SignKeyKES (SimpleKES d t)) x -> SignKeyKES (SimpleKES d t)
$cfrom :: forall d (t :: Nat) x.
SignKeyKES (SimpleKES d t) -> Rep (SignKeyKES (SimpleKES d t)) x
Generic)

  --
  -- Metadata and basic key operations
  --

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

  totalPeriodsKES :: forall (proxy :: Type -> Type). proxy (SimpleKES d t) -> Period
totalPeriodsKES proxy (SimpleKES d t)
_ = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (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 forall a. Vector a -> Int -> Maybe a
!? forall a b. (Integral a, Num b) => a -> b
fromIntegral Period
j of
      Maybe (VerKeyDSIGN d)
Nothing -> forall a b. a -> Either a b
Left String
"KES verification failed: out of range"
      Just VerKeyDSIGN d
vk -> forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SigDSIGN v -> Either String ()
verifyDSIGN 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 [forall v. DSIGNAlgorithm v => VerKeyDSIGN v -> ByteString
rawSerialiseVerKeyDSIGN VerKeyDSIGN d
vk | VerKeyDSIGN d
vk <- forall a. Vector a -> [a]
Vec.toList Vector (VerKeyDSIGN d)
vks]

  rawSerialiseSigKES :: SigKES (SimpleKES d t) -> ByteString
rawSerialiseSigKES (SigSimpleKES SigDSIGN d
sig) =
    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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
          sizeKey :: Int
sizeKey = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
sizeVerKeyDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d))
    , [ByteString]
vkbs <- [Int] -> ByteString -> [ByteString]
splitsAt (forall a. Int -> a -> [a]
replicate Int
duration Int
sizeKey) ByteString
bs
    , forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ByteString]
vkbs forall a. Eq a => a -> a -> Bool
== Int
duration
    , Just [VerKeyDSIGN d]
vks <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall v. DSIGNAlgorithm v => ByteString -> Maybe (VerKeyDSIGN v)
rawDeserialiseVerKeyDSIGN [ByteString]
vkbs =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
VerKeySimpleKES (forall a. [a] -> Vector a
Vec.fromList [VerKeyDSIGN d]
vks)
    | Bool
otherwise =
        forall a. Maybe a
Nothing

  rawDeserialiseSigKES :: ByteString -> Maybe (SigKES (SimpleKES d t))
rawDeserialiseSigKES = forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap forall d (t :: Nat). SigDSIGN d -> SigKES (SimpleKES d t)
SigSimpleKES forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
    forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
VerKeySimpleKES forall (m :: Type -> Type) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
Vec.mapM forall v (m :: Type -> Type).
(DSIGNMAlgorithm v, MonadThrow m, MonadST m) =>
SignKeyDSIGNM v -> m (VerKeyDSIGN v)
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 forall a. Vector a -> Int -> Maybe a
!? forall a b. (Integral a, Num b) => a -> b
fromIntegral Period
j of
      Maybe (SignKeyDSIGNM d)
Nothing -> forall a. HasCallStack => String -> a
error (String
"SimpleKES.signKES: period out of range " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Period
j)
      Just SignKeyDSIGNM d
sk -> forall d (t :: Nat). SigDSIGN d -> SigKES (SimpleKES d t)
SigSimpleKES forall (m :: Type -> Type) a b. Monad m => (a -> b) -> m a -> m b
<$!> (forall v a (m :: Type -> Type).
(DSIGNMAlgorithm v, Signable v a, MonadST m, MonadThrow m) =>
ContextDSIGN v -> a -> SignKeyDSIGNM v -> m (SigDSIGN v)
signDSIGNM ContextKES (SimpleKES d t)
ctxt a
a 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 forall a. Num a => a -> a -> a
+ Period
1 forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy @t)) = do
        Vector (SignKeyDSIGNM d)
sk' <- forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
Vec.mapM (forall v (m :: Type -> Type).
(DSIGNMAlgorithm v, MonadST m) =>
MLockedAllocator m -> SignKeyDSIGNM v -> m (SignKeyDSIGNM v)
cloneKeyDSIGNMWith MLockedAllocator m
allocator) Vector (SignKeyDSIGNM d)
sk
        forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES Vector (SignKeyDSIGNM d)
sk'
    | Bool
otherwise = forall (m :: Type -> Type) a. Monad m => a -> m a
return 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 = forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
seedSizeDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
        duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy @t))
    Vector (SignKeyDSIGNM d)
sks <- forall (m :: Type -> Type) a.
Monad m =>
Int -> (Int -> m a) -> m (Vector a)
Vec.generateM Int
duration forall a b. (a -> b) -> a -> b
$ \Int
t -> do
      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 (SeedSizeKES (SimpleKES d t))
mlsb (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
t forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Period
seedSize) forall a b. (a -> b) -> a -> b
$ \MLockedSizedBytes (SeedSizeDSIGN d)
mlsb' -> do
        forall v (m :: Type -> Type).
(DSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m
-> MLockedSeed (SeedSizeDSIGN v) -> m (SignKeyDSIGNM v)
genKeyDSIGNMWith MLockedAllocator m
allocator (forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed MLockedSizedBytes (SeedSizeDSIGN d)
mlsb')
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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) =
    forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Vector a -> m ()
Vec.mapM_ (forall v (m :: Type -> Type).
(DSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m -> SignKeyDSIGNM v -> 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 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
$cto :: forall d (t :: Nat) x.
Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
-> UnsoundPureSignKeyKES (SimpleKES d t)
$cfrom :: forall d (t :: Nat) x.
UnsoundPureSignKeyKES (SimpleKES d t)
-> Rep (UnsoundPureSignKeyKES (SimpleKES d t)) x
Generic)

  unsoundPureGenKeyKES :: Seed -> UnsoundPureSignKeyKES (SimpleKES d t)
unsoundPureGenKeyKES Seed
seed =
    let seedSize :: Int
seedSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
seedSizeDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d))
        duration :: Int
duration = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy @t))
        seedChunk :: Int -> Seed
seedChunk Int
t =
          ByteString -> Seed
mkSeedFromBytes (Int -> ByteString -> ByteString
BS.take Int
seedSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (Int
seedSize forall a. Num a => a -> a -> a
* Int
t) forall a b. (a -> b) -> a -> b
$ Seed -> ByteString
getSeedBytes Seed
seed)
     in forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureSignKeySimpleKES forall a b. (a -> b) -> a -> b
$
          forall a. Int -> (Int -> a) -> Vector a
Vec.generate Int
duration (forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN 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 forall a. Vector a -> Int -> Maybe a
!? forall a b. (Integral a, Num b) => a -> b
fromIntegral Period
j of
      Maybe (SignKeyDSIGN d)
Nothing -> forall a. HasCallStack => String -> a
error (String
"SimpleKES.unsoundPureSignKES: period out of range " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Period
j)
      Just SignKeyDSIGN d
sk -> forall d (t :: Nat). SigDSIGN d -> SigKES (SimpleKES d t)
SigSimpleKES forall a b. (a -> b) -> a -> b
$! forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SigDSIGN v
signDSIGN 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 forall a. Num a => a -> a -> a
+ Period
1 forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy @t)) =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureThunkySignKeySimpleKES Vector (SignKeyDSIGN d)
sk
    | Bool
otherwise =
        forall a. Maybe a
Nothing

  unsoundPureDeriveVerKeyKES :: UnsoundPureSignKeyKES (SimpleKES d t) -> VerKeyKES (SimpleKES d t)
unsoundPureDeriveVerKeyKES (UnsoundPureSignKeySimpleKES Vector (SignKeyDSIGN d)
sks) =
    forall d (t :: Nat).
Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t)
VerKeySimpleKES forall a b. (a -> b) -> a -> b
$! forall a b. (a -> b) -> Vector a -> Vector b
Vec.map 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
    forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SignKeyDSIGN d -> m (SignKeyDSIGNM d)
convertSK Vector (SignKeyDSIGN d)
sks
    where
      convertSK :: SignKeyDSIGN d -> m (SignKeyDSIGNM d)
convertSK =
        forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"unsoundPureSignKeyKESToSoundSignKeyKES: deserialisation failed"))
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (m :: Type -> Type).
(UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
ByteString -> m (Maybe (SignKeyDSIGNM v))
rawDeserialiseSignKeyDSIGNM
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> ByteString
rawSerialiseSignKeyDSIGN

  rawSerialiseUnsoundPureSignKeyKES :: UnsoundPureSignKeyKES (SimpleKES d t) -> ByteString
rawSerialiseUnsoundPureSignKeyKES (UnsoundPureSignKeySimpleKES Vector (SignKeyDSIGN d)
sks) =
    forall (t :: Type -> Type) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
          sizeKey :: Int
sizeKey = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
sizeSignKeyDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d))
          skbs :: [ByteString]
skbs = [Int] -> ByteString -> [ByteString]
splitsAt (forall a. Int -> a -> [a]
replicate Int
duration Int
sizeKey) ByteString
bs
    , forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ByteString]
skbs forall a. Eq a => a -> a -> Bool
== Int
duration =
        do
          [SignKeyDSIGN d]
sks <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall v. DSIGNAlgorithm v => ByteString -> Maybe (SignKeyDSIGN v)
rawDeserialiseSignKeyDSIGN [ByteString]
skbs
          forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall d (t :: Nat).
Vector (SignKeyDSIGN d) -> UnsoundPureSignKeyKES (SimpleKES d t)
UnsoundPureSignKeySimpleKES (forall a. [a] -> Vector a
Vec.fromList [SignKeyDSIGN d]
sks)
    | Bool
otherwise =
        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 forall (m :: Type -> Type) a b. Monad m => (a -> b) -> m a -> m b
<$!> forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall v (m :: Type -> Type).
(UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
SignKeyDSIGNM v -> m ByteString
rawSerialiseSignKeyDSIGNM (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 (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
          sizeKey :: Int
sizeKey = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall v (proxy :: Type -> Type).
DSIGNAlgorithm v =>
proxy v -> Period
sizeSignKeyDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d))
    , [ByteString]
skbs <- [Int] -> ByteString -> [ByteString]
splitsAt (forall a. Int -> a -> [a]
replicate Int
duration Int
sizeKey) ByteString
bs
    , forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [ByteString]
skbs forall a. Eq a => a -> a -> Bool
== Int
duration =
        forall (m :: Type -> Type) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
          [SignKeyDSIGNM d]
sks <- forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: Type -> Type) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v (m :: Type -> Type).
(UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) =>
MLockedAllocator m -> ByteString -> m (Maybe (SignKeyDSIGNM v))
rawDeserialiseSignKeyDSIGNMWith MLockedAllocator m
allocator) [ByteString]
skbs
          forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES (forall a. [a] -> Vector a
Vec.fromList [SignKeyDSIGNM d]
sks)
    | Bool
otherwise =
        forall (m :: Type -> Type) a. Monad m => a -> m a
return 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 = 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 = 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 = 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 = 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 = 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 = 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) =
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a (m :: Type -> Type).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> 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 (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
    Vector (VerKeyDSIGN d)
vks <- forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vec.replicateM Int
duration (forall a (m :: Type -> Type).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
directDeserialise Ptr CChar -> CSize -> m ()
pull)
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall 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) =
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a (m :: Type -> Type).
(DirectSerialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> a -> 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 (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Nat
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy t))
    Vector (SignKeyDSIGNM d)
sks <- forall (m :: Type -> Type) a. Monad m => Int -> m a -> m (Vector a)
Vec.replicateM Int
duration (forall a (m :: Type -> Type).
(DirectDeserialise a, MonadST m, MonadThrow m) =>
(Ptr CChar -> CSize -> m ()) -> m a
directDeserialise Ptr CChar -> CSize -> m ()
pull)
    forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall d (t :: Nat).
Vector (SignKeyDSIGNM d) -> SignKeyKES (SimpleKES d t)
SignKeySimpleKES Vector (SignKeyDSIGNM d)
sks