{-# 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 #-}

-- | Hot key
--
-- Intended for qualified import
module Ouroboros.Consensus.Protocol.Ledger.HotKey
  ( -- * KES Info
    KESEvolution
  , KESInfo (..)
  , kesAbsolutePeriod

    -- * KES Status
  , KESStatus (..)
  , kesStatus

    -- * Hot Key
  , 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

{-------------------------------------------------------------------------------
  KES Info
-------------------------------------------------------------------------------}

-- | We call the relative periods that a KES key is valid its evolution, to
-- avoid confusion with absolute periods.
type KESEvolution = Relative.Period

data KESInfo = KESInfo
  { KESInfo -> KESPeriod
kesStartPeriod :: !Absolute.KESPeriod
  , KESInfo -> KESPeriod
kesEndPeriod :: !Absolute.KESPeriod
  -- ^ Currently derived from 'TPraosParams':
  -- > kesEndPeriod = kesStartPeriod + tpraosMaxKESEvo
  , KESInfo -> Word
kesEvolution :: !KESEvolution
  -- ^ Current evolution or /relative period/.
  --
  -- Invariant:
  -- > kesStartPeriod + kesEvolution in [kesStartPeriod, kesEndPeriod)
  }
  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)

-- | Return the absolute KES period
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

{-------------------------------------------------------------------------------
  KES Status
-------------------------------------------------------------------------------}

data KESStatus
  = -- | The given period is before the start period of the KES key.
    BeforeKESStart
      -- | Given period
      Absolute.KESPeriod
      -- | Start period of the KES key
      Absolute.KESPeriod
  | -- | The given period is in the range of the KES key.
    InKESRange
      -- | Relative period or evolution corresponding to the
      -- given absolute period
      KESEvolution
  | -- | The given period is after the end period of the KES key.
    AfterKESEnd
      -- | Given period
      Absolute.KESPeriod
      -- | End period of the KES key
      Absolute.KESPeriod

-- | Return the evolution of the given KES period, /when/ it falls within the
-- range of the 'HotKey' (@[hkStart, hkEnd)@).
--
-- Note that the upper bound is exclusive, the spec says:
-- > c0 <= kesPeriod s < c0 + MaxKESEvo
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)

{-------------------------------------------------------------------------------
  Hot Key
-------------------------------------------------------------------------------}

-- | Failed to evolve the KES key.
data KESEvolutionError
  = -- | The KES key could not be evolved to the target period.
    KESCouldNotEvolve
      KESInfo
      -- | Target period outside the range of the current KES key. Typically
      -- the current KES period according to the wallclock slot.
      Absolute.KESPeriod
  | -- | The KES key was already poisoned.
    KESKeyAlreadyPoisoned
      KESInfo
      -- | Target period outside the range of the current KES key. Typically
      -- the current KES period according to the wallclock slot.
      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

-- | Result of evolving the KES key.
type KESEvolutionInfo = UpdateInfo KESInfo KESEvolutionError

-- | API to interact with the key.
data HotKey c m = HotKey
  { forall c (m :: * -> *).
HotKey c m -> KESPeriod -> m KESEvolutionInfo
evolve :: Absolute.KESPeriod -> m KESEvolutionInfo
  -- ^ Evolve the KES signing key to the given absolute KES period.
  --
  -- When the key cannot evolve anymore, we poison it.
  , forall c (m :: * -> *). HotKey c m -> m KESInfo
getInfo :: m KESInfo
  -- ^ Return 'KESInfo' of the signing key.
  , forall c (m :: * -> *). HotKey c m -> m (Maybe (OCert c))
getOCertMaybe :: m (Maybe (OCert.OCert c))
  -- ^ Return the 'OCert' corresponding to the KES signing key, if any.
  , forall c (m :: * -> *). HotKey c m -> m Bool
isPoisoned :: m Bool
  -- ^ Check whether a valid KES signing key exists. "Poisoned" means no
  -- key exists; reasons for this could be:
  -- - no signing key has been set yet
  -- - the signing key has been explicitly erased ('forget')
  -- - the signing key has been evolved past the end of the available
  --   evolutions
  , 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)
  -- ^ Sign the given @toSign@ with the current signing key.
  --
  -- PRECONDITION: the key is not poisoned.
  --
  -- POSTCONDITION: the signature is in normal form.
  , forall c (m :: * -> *). HotKey c m -> m ()
finalize :: m ()
  -- ^ Release any resources held by the 'HotKey', including the signing key
  -- itself. This should be called exactly once per 'HotKey' instance.
  }

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_

-- | The actual KES key, unless it expired, in which case it is replaced by
-- \"poison\".
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)

-- Create a new 'HotKey' and initialize it to the given initial KES key. The
-- initial key must be at evolution 0 (i.e., freshly generated and never
-- evolved).
mkHotKey ::
  forall m c.
  (Crypto c, IOLike m) =>
  OCert.OCert c ->
  KES.SignKeyKES (KES c) ->
  -- | Start period
  Absolute.KESPeriod ->
  -- | Max KES evolutions
  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

-- Create a new 'HotKey' and initialize it to the given initial KES key. The
-- initial key should be at the given evolution.
mkHotKeyAtEvolution ::
  forall m c.
  (Crypto c, IOLike m) =>
  Word ->
  OCert.OCert c ->
  KES.SignKeyKES (KES c) ->
  -- | Start period
  Absolute.KESPeriod ->
  -- | Max KES evolutions
  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

-- | Create a new 'HotKey' and initialize it to a poisoned state (containing no
-- valid KES sign key).
mkEmptyHotKey ::
  forall m c.
  (Crypto c, IOLike m) =>
  -- | Max KES evolutions
  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 =
  -- | Callback that will be invoked when a new key has been received
  (OCert.OCert c -> KES.SignKeyKES (KES c) -> Word -> Absolute.KESPeriod -> m ()) ->
  -- | Callback that will be invoked when a key deletion has been received
  m () ->
  m ()

-- | Create a new 'HotKey' that runs a key-producer action on a separate thread.
-- The key producer action will receive a callback that can be used to pass
-- keys into the HotKey; the HotKey will dynamically update its internal state
-- to reflect new keys as they arrive.
mkDynamicHotKey ::
  forall m c.
  (Crypto c, IOLike m) =>
  -- | Max KES evolutions
  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

-- | The most general function for creating a new 'HotKey', accepting an initial
-- set of credentials, a key producer action, and a custom finalizer.
mkHotKeyWith ::
  forall m c.
  (Crypto c, IOLike m) =>
  Maybe (OCert.OCert c, KES.SignKeyKES (KES c), Word, Absolute.KESPeriod) ->
  -- | Max KES evolutions
  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

      -- 'cancel' cannot throw exceptions, so we don't need to use 'finally'
      -- here
      pure (cancel keyThreadAsync >> unset)
    Maybe (KeyProducer c m)
Nothing ->
      -- we don't need to do anything here, since we haven't spawned any other
      -- threads to communicate with the KES agent
      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
      -- already poisoned
      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}

-- | Evolve the 'HotKey' so that its evolution matches the given KES period.
--
-- When the given KES period is after the end period of the 'HotKey', we
-- poison the key and return 'UpdateFailed'.
--
-- When the given KES period is before the start period of the 'HotKey' or
-- when the given period is before the key's period, we don't evolve the key
-- and return 'Updated'.
--
-- When the given KES period is within the range of the 'HotKey' and the given
-- period is after the key's period, we evolve the key and return 'Updated'.
--
-- When the key is poisoned, we always return 'UpdateFailed'.
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
  -- We mask the evolution process because if we got interrupted after
  -- calling 'forgetSignKeyKES', which destructively updates the current
  -- signing key, we would leave an erased key in the state, which might
  -- cause a segfault when used afterwards.
  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
      -- When the absolute period is before the start period, we can't
      -- update the key. 'checkCanForge' will say we can't forge because the
      -- key is not valid yet.
      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)
      -- When the absolute period is after the end period, we can't evolve
      -- anymore and poison the expired key.
      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
        -- No evolving needed
        | 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)
        -- Evolving needed
        | 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
  -- \| PRECONDITION:
  --
  -- > targetEvolution >= curEvolution
  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 ->
              -- This cannot happen
              String -> m (KESState c)
forall a. HasCallStack => String -> a
error String
"Could not update KES key"
            Just !SignKeyKES (KES c)
key' -> do
              -- Clear the memory associated with the old key
              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