{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Ouroboros.Consensus.Protocol.Ledger.HotKey
(
KESEvolution
, KESInfo (..)
, kesAbsolutePeriod
, KESStatus (..)
, kesStatus
, HotKey (..)
, KESEvolutionError (..)
, KESEvolutionInfo
, getOCert
, mkDynamicHotKey
, mkEmptyHotKey
, mkHotKey
, mkHotKeyAtEvolution
, sign
) where
import qualified Cardano.Crypto.KES as KES
import qualified Cardano.Crypto.KES as Relative (Period)
import Cardano.Protocol.Crypto (Crypto (..))
import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..))
import qualified Cardano.Protocol.TPraos.OCert as OCert
import Control.Monad (forM_)
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import NoThunks.Class (OnlyCheckWhnfNamed (..))
import Ouroboros.Consensus.Block.Forging (UpdateInfo (..))
import Ouroboros.Consensus.Util.IOLike
type KESEvolution = Relative.Period
data KESInfo = KESInfo
{ KESInfo -> KESPeriod
kesStartPeriod :: !Absolute.KESPeriod
, KESInfo -> KESPeriod
kesEndPeriod :: !Absolute.KESPeriod
, KESInfo -> Word
kesEvolution :: !KESEvolution
}
deriving (Int -> KESInfo -> ShowS
[KESInfo] -> ShowS
KESInfo -> String
(Int -> KESInfo -> ShowS)
-> (KESInfo -> String) -> ([KESInfo] -> ShowS) -> Show KESInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KESInfo -> ShowS
showsPrec :: Int -> KESInfo -> ShowS
$cshow :: KESInfo -> String
show :: KESInfo -> String
$cshowList :: [KESInfo] -> ShowS
showList :: [KESInfo] -> ShowS
Show, (forall x. KESInfo -> Rep KESInfo x)
-> (forall x. Rep KESInfo x -> KESInfo) -> Generic KESInfo
forall x. Rep KESInfo x -> KESInfo
forall x. KESInfo -> Rep KESInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. KESInfo -> Rep KESInfo x
from :: forall x. KESInfo -> Rep KESInfo x
$cto :: forall x. Rep KESInfo x -> KESInfo
to :: forall x. Rep KESInfo x -> KESInfo
Generic, Context -> KESInfo -> IO (Maybe ThunkInfo)
Proxy KESInfo -> String
(Context -> KESInfo -> IO (Maybe ThunkInfo))
-> (Context -> KESInfo -> IO (Maybe ThunkInfo))
-> (Proxy KESInfo -> String)
-> NoThunks KESInfo
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> KESInfo -> IO (Maybe ThunkInfo)
noThunks :: Context -> KESInfo -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> KESInfo -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> KESInfo -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy KESInfo -> String
showTypeOf :: Proxy KESInfo -> String
NoThunks)
kesAbsolutePeriod :: KESInfo -> Absolute.KESPeriod
kesAbsolutePeriod :: KESInfo -> KESPeriod
kesAbsolutePeriod KESInfo{KESPeriod
kesStartPeriod :: KESInfo -> KESPeriod
kesStartPeriod :: KESPeriod
kesStartPeriod, Word
kesEvolution :: KESInfo -> Word
kesEvolution :: Word
kesEvolution} =
Word -> KESPeriod
Absolute.KESPeriod (Word -> KESPeriod) -> Word -> KESPeriod
forall a b. (a -> b) -> a -> b
$ Word
start Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
kesEvolution
where
Absolute.KESPeriod Word
start = KESPeriod
kesStartPeriod
data KESStatus
=
BeforeKESStart
Absolute.KESPeriod
Absolute.KESPeriod
|
InKESRange
KESEvolution
|
AfterKESEnd
Absolute.KESPeriod
Absolute.KESPeriod
kesStatus :: KESInfo -> Absolute.KESPeriod -> KESStatus
kesStatus :: KESInfo -> KESPeriod -> KESStatus
kesStatus
KESInfo
{ kesStartPeriod :: KESInfo -> KESPeriod
kesStartPeriod = lo' :: KESPeriod
lo'@(Absolute.KESPeriod Word
lo)
, kesEndPeriod :: KESInfo -> KESPeriod
kesEndPeriod = hi' :: KESPeriod
hi'@(Absolute.KESPeriod Word
hi)
}
cur' :: KESPeriod
cur'@(Absolute.KESPeriod Word
cur)
| Word
cur Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
< Word
lo = KESPeriod -> KESPeriod -> KESStatus
BeforeKESStart KESPeriod
cur' KESPeriod
lo'
| Word
cur Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
>= Word
hi = KESPeriod -> KESPeriod -> KESStatus
AfterKESEnd KESPeriod
cur' KESPeriod
hi'
| Bool
otherwise = Word -> KESStatus
InKESRange (Word
cur Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
lo)
data KESEvolutionError
=
KESCouldNotEvolve
KESInfo
Absolute.KESPeriod
|
KESKeyAlreadyPoisoned
KESInfo
Absolute.KESPeriod
deriving Int -> KESEvolutionError -> ShowS
[KESEvolutionError] -> ShowS
KESEvolutionError -> String
(Int -> KESEvolutionError -> ShowS)
-> (KESEvolutionError -> String)
-> ([KESEvolutionError] -> ShowS)
-> Show KESEvolutionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KESEvolutionError -> ShowS
showsPrec :: Int -> KESEvolutionError -> ShowS
$cshow :: KESEvolutionError -> String
show :: KESEvolutionError -> String
$cshowList :: [KESEvolutionError] -> ShowS
showList :: [KESEvolutionError] -> ShowS
Show
type KESEvolutionInfo = UpdateInfo KESInfo KESEvolutionError
data HotKey c m = HotKey
{ forall c (m :: * -> *).
HotKey c m -> KESPeriod -> m KESEvolutionInfo
evolve :: Absolute.KESPeriod -> m KESEvolutionInfo
, forall c (m :: * -> *). HotKey c m -> m KESInfo
getInfo :: m KESInfo
, forall c (m :: * -> *). HotKey c m -> m (Maybe (OCert c))
getOCertMaybe :: m (Maybe (OCert.OCert c))
, forall c (m :: * -> *). HotKey c m -> m Bool
isPoisoned :: m Bool
, forall c (m :: * -> *).
HotKey c m
-> forall toSign.
(Signable (KES c) toSign, HasCallStack) =>
toSign -> m (SignedKES (KES c) toSign)
sign_ ::
forall toSign.
(KES.Signable (KES c) toSign, HasCallStack) =>
toSign ->
m (KES.SignedKES (KES c) toSign)
, forall c (m :: * -> *). HotKey c m -> m ()
finalize :: m ()
}
deriving via (OnlyCheckWhnfNamed "HotKey" (HotKey c m)) instance NoThunks (HotKey c m)
getOCert :: Monad m => HotKey c m -> m (OCert.OCert c)
getOCert :: forall (m :: * -> *) c. Monad m => HotKey c m -> m (OCert c)
getOCert HotKey c m
hotKey = do
ocertMay <- HotKey c m -> m (Maybe (OCert c))
forall c (m :: * -> *). HotKey c m -> m (Maybe (OCert c))
getOCertMaybe HotKey c m
hotKey
case ocertMay of
Just OCert c
ocert -> OCert c -> m (OCert c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return OCert c
ocert
Maybe (OCert c)
Nothing -> String -> m (OCert c)
forall a. HasCallStack => String -> a
error String
"trying to read OpCert for poisoned key"
sign ::
(KES.Signable (KES c) toSign, HasCallStack) =>
HotKey c m ->
toSign ->
m (KES.SignedKES (KES c) toSign)
sign :: forall c toSign (m :: * -> *).
(Signable (KES c) toSign, HasCallStack) =>
HotKey c m -> toSign -> m (SignedKES (KES c) toSign)
sign = HotKey c m -> toSign -> m (SignedKES (KES c) toSign)
HotKey c m
-> forall toSign.
(Signable (KES c) toSign, HasCallStack) =>
toSign -> m (SignedKES (KES c) toSign)
forall c (m :: * -> *).
HotKey c m
-> forall toSign.
(Signable (KES c) toSign, HasCallStack) =>
toSign -> m (SignedKES (KES c) toSign)
sign_
data KESKey c
= KESKey !(OCert.OCert c) !(KES.SignKeyKES (KES c))
| KESKeyPoisoned
deriving (forall x. KESKey c -> Rep (KESKey c) x)
-> (forall x. Rep (KESKey c) x -> KESKey c) -> Generic (KESKey c)
forall x. Rep (KESKey c) x -> KESKey c
forall x. KESKey c -> Rep (KESKey c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (KESKey c) x -> KESKey c
forall c x. KESKey c -> Rep (KESKey c) x
$cfrom :: forall c x. KESKey c -> Rep (KESKey c) x
from :: forall x. KESKey c -> Rep (KESKey c) x
$cto :: forall c x. Rep (KESKey c) x -> KESKey c
to :: forall x. Rep (KESKey c) x -> KESKey c
Generic
instance (NoThunks (KES.SignKeyKES (KES c)), Crypto c) => NoThunks (KESKey c)
kesKeyIsPoisoned :: KESKey c -> Bool
kesKeyIsPoisoned :: forall c. KESKey c -> Bool
kesKeyIsPoisoned KESKey c
KESKeyPoisoned = Bool
True
kesKeyIsPoisoned (KESKey OCert c
_ SignKeyKES (KES c)
_) = Bool
False
data KESState c = KESState
{ forall c. KESState c -> KESInfo
kesStateInfo :: !KESInfo
, forall c. KESState c -> KESKey c
kesStateKey :: !(KESKey c)
}
deriving (forall x. KESState c -> Rep (KESState c) x)
-> (forall x. Rep (KESState c) x -> KESState c)
-> Generic (KESState c)
forall x. Rep (KESState c) x -> KESState c
forall x. KESState c -> Rep (KESState c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (KESState c) x -> KESState c
forall c x. KESState c -> Rep (KESState c) x
$cfrom :: forall c x. KESState c -> Rep (KESState c) x
from :: forall x. KESState c -> Rep (KESState c) x
$cto :: forall c x. Rep (KESState c) x -> KESState c
to :: forall x. Rep (KESState c) x -> KESState c
Generic
instance (NoThunks (KES.SignKeyKES (KES c)), Crypto c) => NoThunks (KESState c)
mkHotKey ::
forall m c.
(Crypto c, IOLike m) =>
OCert.OCert c ->
KES.SignKeyKES (KES c) ->
Absolute.KESPeriod ->
Word64 ->
m (HotKey c m)
mkHotKey :: forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
OCert c
-> SignKeyKES (KES c) -> KESPeriod -> Word64 -> m (HotKey c m)
mkHotKey = Word
-> OCert c
-> SignKeyKES (KES c)
-> KESPeriod
-> Word64
-> m (HotKey c m)
forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Word
-> OCert c
-> SignKeyKES (KES c)
-> KESPeriod
-> Word64
-> m (HotKey c m)
mkHotKeyAtEvolution Word
0
mkHotKeyAtEvolution ::
forall m c.
(Crypto c, IOLike m) =>
Word ->
OCert.OCert c ->
KES.SignKeyKES (KES c) ->
Absolute.KESPeriod ->
Word64 ->
m (HotKey c m)
mkHotKeyAtEvolution :: forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Word
-> OCert c
-> SignKeyKES (KES c)
-> KESPeriod
-> Word64
-> m (HotKey c m)
mkHotKeyAtEvolution Word
evolution OCert c
ocert SignKeyKES (KES c)
initKey KESPeriod
startPeriod Word64
maxKESEvolutions =
Maybe (OCert c, SignKeyKES (KES c), Word, KESPeriod)
-> Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Maybe (OCert c, SignKeyKES (KES c), Word, KESPeriod)
-> Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
mkHotKeyWith
((OCert c, SignKeyKES (KES c), Word, KESPeriod)
-> Maybe (OCert c, SignKeyKES (KES c), Word, KESPeriod)
forall a. a -> Maybe a
Just (OCert c
ocert, SignKeyKES (KES c)
initKey, Word
evolution, KESPeriod
startPeriod))
Word64
maxKESEvolutions
Maybe (KeyProducer c m)
forall a. Maybe a
Nothing
mkEmptyHotKey ::
forall m c.
(Crypto c, IOLike m) =>
Word64 ->
m (HotKey c m)
mkEmptyHotKey :: forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Word64 -> m (HotKey c m)
mkEmptyHotKey Word64
maxKESEvolutions =
Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
mkDynamicHotKey Word64
maxKESEvolutions Maybe (KeyProducer c m)
forall a. Maybe a
Nothing
mkKESState ::
Word64 -> OCert.OCert c -> KES.SignKeyKES (KES c) -> Word -> Absolute.KESPeriod -> KESState c
mkKESState :: forall c.
Word64
-> OCert c -> SignKeyKES (KES c) -> Word -> KESPeriod -> KESState c
mkKESState Word64
maxKESEvolutions OCert c
newOCert SignKeyKES (KES c)
newKey Word
evolution startPeriod :: KESPeriod
startPeriod@(Absolute.KESPeriod Word
start) =
KESState
{ kesStateInfo :: KESInfo
kesStateInfo =
KESInfo
{ kesStartPeriod :: KESPeriod
kesStartPeriod = KESPeriod
startPeriod
, kesEndPeriod :: KESPeriod
kesEndPeriod = Word -> KESPeriod
Absolute.KESPeriod (Word
start Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxKESEvolutions)
, kesEvolution :: Word
kesEvolution = Word
evolution
}
, kesStateKey :: KESKey c
kesStateKey = OCert c -> SignKeyKES (KES c) -> KESKey c
forall c. OCert c -> SignKeyKES (KES c) -> KESKey c
KESKey OCert c
newOCert SignKeyKES (KES c)
newKey
}
type KeyProducer c m =
(OCert.OCert c -> KES.SignKeyKES (KES c) -> Word -> Absolute.KESPeriod -> m ()) ->
m () ->
m ()
mkDynamicHotKey ::
forall m c.
(Crypto c, IOLike m) =>
Word64 ->
Maybe (KeyProducer c m) ->
m (HotKey c m)
mkDynamicHotKey :: forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
mkDynamicHotKey = Maybe (OCert c, SignKeyKES (KES c), Word, KESPeriod)
-> Word64
-> Maybe
((OCert c -> SignKeyKES (KES c) -> Word -> KESPeriod -> m ())
-> m () -> m ())
-> m (HotKey c m)
forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Maybe (OCert c, SignKeyKES (KES c), Word, KESPeriod)
-> Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
mkHotKeyWith Maybe (OCert c, SignKeyKES (KES c), Word, KESPeriod)
forall a. Maybe a
Nothing
mkHotKeyWith ::
forall m c.
(Crypto c, IOLike m) =>
Maybe (OCert.OCert c, KES.SignKeyKES (KES c), Word, Absolute.KESPeriod) ->
Word64 ->
Maybe (KeyProducer c m) ->
m (HotKey c m)
mkHotKeyWith :: forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
Maybe (OCert c, SignKeyKES (KES c), Word, KESPeriod)
-> Word64 -> Maybe (KeyProducer c m) -> m (HotKey c m)
mkHotKeyWith Maybe (OCert c, SignKeyKES (KES c), Word, KESPeriod)
initialStateMay Word64
maxKESEvolutions Maybe (KeyProducer c m)
keyThreadMay = do
varKESState <- KESState c -> m (StrictMVar m (KESState c))
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar KESState c
initKESState
let set OCert c
newOCert SignKeyKES (KES c)
newKey Word
evolution KESPeriod
startPeriod =
StrictMVar m (KESState c) -> (KESState c -> m (KESState c)) -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m) =>
StrictMVar m a -> (a -> m a) -> m ()
modifyMVar_ StrictMVar m (KESState c)
varKESState ((KESState c -> m (KESState c)) -> m ())
-> (KESState c -> m (KESState c)) -> m ()
forall a b. (a -> b) -> a -> b
$ \KESState c
oldState -> do
_ <- KESState c -> m (KESState c)
forall (m :: * -> *) c.
(KESAlgorithm (KES c), IOLike m) =>
KESState c -> m (KESState c)
poisonState KESState c
oldState
return $ mkKESState maxKESEvolutions newOCert newKey evolution startPeriod
unset =
StrictMVar m (KESState c) -> (KESState c -> m (KESState c)) -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m) =>
StrictMVar m a -> (a -> m a) -> m ()
modifyMVar_ StrictMVar m (KESState c)
varKESState KESState c -> m (KESState c)
forall (m :: * -> *) c.
(KESAlgorithm (KES c), IOLike m) =>
KESState c -> m (KESState c)
poisonState
forM_ initialStateMay $ \(OCert c
newOCert, SignKeyKES (KES c)
newKey, Word
evolution, KESPeriod
startPeriod) ->
OCert c -> SignKeyKES (KES c) -> Word -> KESPeriod -> m ()
set OCert c
newOCert SignKeyKES (KES c)
newKey Word
evolution KESPeriod
startPeriod
finalizer' <- case keyThreadMay of
Just KeyProducer c m
keyThread -> do
keyThreadAsync <- m () -> m (Async m ())
forall a. m a -> m (Async m a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$ do
String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"HotKey receiver"
KeyProducer c m
keyThread OCert c -> SignKeyKES (KES c) -> Word -> KESPeriod -> m ()
set m ()
unset
pure (cancel keyThreadAsync >> unset)
Maybe (KeyProducer c m)
Nothing ->
m () -> m (m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> m (m ())) -> m () -> m (m ())
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
return
HotKey
{ evolve = evolveKey varKESState
, getInfo = kesStateInfo <$> readMVar varKESState
, getOCertMaybe =
kesStateKey <$> readMVar varKESState >>= \case
KESKey c
KESKeyPoisoned -> Maybe (OCert c) -> m (Maybe (OCert c))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OCert c)
forall a. Maybe a
Nothing
KESKey OCert c
ocert SignKeyKES (KES c)
_ -> Maybe (OCert c) -> m (Maybe (OCert c))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (OCert c -> Maybe (OCert c)
forall a. a -> Maybe a
Just OCert c
ocert)
, isPoisoned = kesKeyIsPoisoned . kesStateKey <$> readMVar varKESState
, sign_ = \toSign
toSign -> do
StrictMVar m (KESState c)
-> (KESState c -> m (SignedKES (KES c) toSign))
-> m (SignedKES (KES c) toSign)
forall (m :: * -> *) a b.
MonadMVar m =>
StrictMVar m a -> (a -> m b) -> m b
withMVar StrictMVar m (KESState c)
varKESState ((KESState c -> m (SignedKES (KES c) toSign))
-> m (SignedKES (KES c) toSign))
-> (KESState c -> m (SignedKES (KES c) toSign))
-> m (SignedKES (KES c) toSign)
forall a b. (a -> b) -> a -> b
$ \KESState{KESInfo
kesStateInfo :: forall c. KESState c -> KESInfo
kesStateInfo :: KESInfo
kesStateInfo, KESKey c
kesStateKey :: forall c. KESState c -> KESKey c
kesStateKey :: KESKey c
kesStateKey} -> do
case KESKey c
kesStateKey of
KESKey c
KESKeyPoisoned ->
String -> m (SignedKES (KES c) toSign)
forall a. HasCallStack => String -> a
error String
"trying to sign with a poisoned key"
KESKey OCert c
_ SignKeyKES (KES c)
key -> do
let evolution :: Word
evolution = KESInfo -> Word
kesEvolution KESInfo
kesStateInfo
ContextKES (KES c)
-> Word
-> toSign
-> SignKeyKES (KES c)
-> m (SignedKES (KES c) toSign)
forall v a (m :: * -> *).
(KESAlgorithm v, Signable v a, MonadST m, MonadThrow m) =>
ContextKES v -> Word -> a -> SignKeyKES v -> m (SignedKES v a)
KES.signedKES () Word
evolution toSign
toSign SignKeyKES (KES c)
key
, finalize = finalizer'
}
where
initKESState :: KESState c
initKESState :: KESState c
initKESState =
KESState
{ kesStateInfo :: KESInfo
kesStateInfo =
KESInfo
{ kesStartPeriod :: KESPeriod
kesStartPeriod = Word -> KESPeriod
Absolute.KESPeriod Word
0
, kesEndPeriod :: KESPeriod
kesEndPeriod = Word -> KESPeriod
Absolute.KESPeriod Word
0
, kesEvolution :: Word
kesEvolution = Word
0
}
, kesStateKey :: KESKey c
kesStateKey = KESKey c
forall c. KESKey c
KESKeyPoisoned
}
poisonState ::
forall m c.
(KES.KESAlgorithm (KES c), IOLike m) =>
KESState c -> m (KESState c)
poisonState :: forall (m :: * -> *) c.
(KESAlgorithm (KES c), IOLike m) =>
KESState c -> m (KESState c)
poisonState KESState c
kesState = do
case KESState c -> KESKey c
forall c. KESState c -> KESKey c
kesStateKey KESState c
kesState of
KESKey c
KESKeyPoisoned -> do
KESState c -> m (KESState c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return KESState c
kesState
KESKey OCert c
_ SignKeyKES (KES c)
sk -> do
SignKeyKES (KES c) -> m ()
forall v. KESAlgorithm v => SignKeyKES v -> m ()
forall (m :: * -> *) v.
(IOLike m, KESAlgorithm v) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES (KES c)
sk
KESState c -> m (KESState c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return KESState c
kesState{kesStateKey = KESKeyPoisoned}
evolveKey ::
forall m c.
(IOLike m, KES.ContextKES (KES c) ~ (), KES.KESAlgorithm (KES c)) =>
StrictMVar m (KESState c) -> Absolute.KESPeriod -> m KESEvolutionInfo
evolveKey :: forall (m :: * -> *) c.
(IOLike m, ContextKES (KES c) ~ (), KESAlgorithm (KES c)) =>
StrictMVar m (KESState c) -> KESPeriod -> m KESEvolutionInfo
evolveKey StrictMVar m (KESState c)
varKESState KESPeriod
targetPeriod = StrictMVar m (KESState c)
-> (KESState c -> m (KESState c, KESEvolutionInfo))
-> m KESEvolutionInfo
forall (m :: * -> *) a b.
(HasCallStack, MonadMVar m) =>
StrictMVar m a -> (a -> m (a, b)) -> m b
modifyMVar StrictMVar m (KESState c)
varKESState ((KESState c -> m (KESState c, KESEvolutionInfo))
-> m KESEvolutionInfo)
-> (KESState c -> m (KESState c, KESEvolutionInfo))
-> m KESEvolutionInfo
forall a b. (a -> b) -> a -> b
$ \KESState c
kesState -> do
let info :: KESInfo
info = KESState c -> KESInfo
forall c. KESState c -> KESInfo
kesStateInfo KESState c
kesState
m (KESState c, KESEvolutionInfo)
-> m (KESState c, KESEvolutionInfo)
forall a. m a -> m a
forall (m :: * -> *) a. MonadMask m => m a -> m a
uninterruptibleMask_ (m (KESState c, KESEvolutionInfo)
-> m (KESState c, KESEvolutionInfo))
-> m (KESState c, KESEvolutionInfo)
-> m (KESState c, KESEvolutionInfo)
forall a b. (a -> b) -> a -> b
$ case KESState c -> KESKey c
forall c. KESState c -> KESKey c
kesStateKey KESState c
kesState of
KESKey c
KESKeyPoisoned ->
let err :: KESEvolutionError
err = KESInfo -> KESPeriod -> KESEvolutionError
KESKeyAlreadyPoisoned KESInfo
info KESPeriod
targetPeriod
in (KESState c, KESEvolutionInfo) -> m (KESState c, KESEvolutionInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (KESState c
kesState, KESEvolutionError -> KESEvolutionInfo
forall updated failed. failed -> UpdateInfo updated failed
UpdateFailed KESEvolutionError
err)
KESKey OCert c
ocert SignKeyKES (KES c)
key -> case KESInfo -> KESPeriod -> KESStatus
kesStatus KESInfo
info KESPeriod
targetPeriod of
BeforeKESStart{} ->
(KESState c, KESEvolutionInfo) -> m (KESState c, KESEvolutionInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (KESState c
kesState, KESInfo -> KESEvolutionInfo
forall updated failed. updated -> UpdateInfo updated failed
Updated KESInfo
info)
AfterKESEnd{} -> do
let err :: KESEvolutionError
err = KESInfo -> KESPeriod -> KESEvolutionError
KESCouldNotEvolve KESInfo
info KESPeriod
targetPeriod
poisonedState <- KESState c -> m (KESState c)
forall (m :: * -> *) c.
(KESAlgorithm (KES c), IOLike m) =>
KESState c -> m (KESState c)
poisonState KESState c
kesState
return (poisonedState, UpdateFailed err)
InKESRange Word
targetEvolution
| Word
targetEvolution Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= KESInfo -> Word
kesEvolution KESInfo
info ->
(KESState c, KESEvolutionInfo) -> m (KESState c, KESEvolutionInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (KESState c
kesState, KESInfo -> KESEvolutionInfo
forall updated failed. updated -> UpdateInfo updated failed
Updated KESInfo
info)
| Bool
otherwise ->
(\KESState c
s' -> (KESState c
s', KESInfo -> KESEvolutionInfo
forall updated failed. updated -> UpdateInfo updated failed
Updated (KESState c -> KESInfo
forall c. KESState c -> KESInfo
kesStateInfo KESState c
s')))
(KESState c -> (KESState c, KESEvolutionInfo))
-> m (KESState c) -> m (KESState c, KESEvolutionInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> KESInfo -> OCert c -> SignKeyKES (KES c) -> m (KESState c)
go Word
targetEvolution KESInfo
info OCert c
ocert SignKeyKES (KES c)
key
where
go :: KESEvolution -> KESInfo -> OCert.OCert c -> KES.SignKeyKES (KES c) -> m (KESState c)
go :: Word -> KESInfo -> OCert c -> SignKeyKES (KES c) -> m (KESState c)
go Word
targetEvolution KESInfo
info OCert c
ocert SignKeyKES (KES c)
key
| Word
targetEvolution Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
curEvolution =
KESState c -> m (KESState c)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (KESState c -> m (KESState c)) -> KESState c -> m (KESState c)
forall a b. (a -> b) -> a -> b
$ KESState{kesStateInfo :: KESInfo
kesStateInfo = KESInfo
info, kesStateKey :: KESKey c
kesStateKey = OCert c -> SignKeyKES (KES c) -> KESKey c
forall c. OCert c -> SignKeyKES (KES c) -> KESKey c
KESKey OCert c
ocert SignKeyKES (KES c)
key}
| Bool
otherwise =
do
maybeKey' <- ContextKES (KES c)
-> SignKeyKES (KES c) -> Word -> m (Maybe (SignKeyKES (KES c)))
forall v (m :: * -> *).
(KESAlgorithm v, MonadST m, MonadThrow m) =>
ContextKES v -> SignKeyKES v -> Word -> m (Maybe (SignKeyKES v))
KES.updateKES () SignKeyKES (KES c)
key Word
curEvolution
case maybeKey' of
Maybe (SignKeyKES (KES c))
Nothing ->
String -> m (KESState c)
forall a. HasCallStack => String -> a
error String
"Could not update KES key"
Just !SignKeyKES (KES c)
key' -> do
SignKeyKES (KES c) -> m ()
forall v. KESAlgorithm v => SignKeyKES v -> m ()
forall (m :: * -> *) v.
(IOLike m, KESAlgorithm v) =>
SignKeyKES v -> m ()
forgetSignKeyKES SignKeyKES (KES c)
key
let info' :: KESInfo
info' = KESInfo
info{kesEvolution = curEvolution + 1}
Word -> KESInfo -> OCert c -> SignKeyKES (KES c) -> m (KESState c)
go Word
targetEvolution KESInfo
info' OCert c
ocert SignKeyKES (KES c)
key'
where
curEvolution :: Word
curEvolution = KESInfo -> Word
kesEvolution KESInfo
info