Securely forget the signing key

Fixes #2367.

As the `forgetSignKeyKES` method lives in IO but we live in `IOLike m`, we
can't call it directly. We add it as a method to `IOLike`.

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/Crypto/HotKey.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 -- | Hot key
@@ -13,7 +15,7 @@ module Ouroboros.Consensus.Shelley.Protocol.Crypto.HotKey (
 
 import           GHC.Generics (Generic)
 
-import           Cardano.Crypto.KES.Class
+import           Cardano.Crypto.KES.Class (SignKeyKES, updateKES)
 import qualified Cardano.Crypto.KES.Class as Relative (Period)
 import           Cardano.Prelude (NoUnexpectedThunks (..))
 
@@ -78,37 +80,41 @@ toPeriod HotKey { hkStart = Absolute.KESPeriod lo, hkEvolution } =
 --
 -- When the given KES period is outside the bounds of the 'HotKey', we return
 -- 'Nothing'.
+--
+-- The old 'HotKey' (and an intermediary ones produced while evolving) is
+-- securely erased from memory.
 evolve ::
      forall c m. (IOLike m, Crypto c)
   => Absolute.KESPeriod
   -> HotKey c
   -> m (Maybe (HotKey c))
-evolve targetPeriod hk = do
-    let mNewHotKey = do
-           targetEvolution <- toEvolution hk targetPeriod
-           key' <- go targetEvolution (hkEvolution hk) (hkKey hk)
-           return HotKey {
-               hkStart     = hkStart hk
-             , hkEnd       = hkEnd   hk
-             , hkEvolution = targetEvolution
-             , hkKey       = key'
-             }
-    -- Any stateful code (for instance, running finalizers to clear the
-    -- memory associated with the old key) would happen here or in (a
-    -- monadic) 'go'.
-    return mNewHotKey
+evolve targetPeriod hk
+  | Just targetEvolution <- toEvolution hk targetPeriod
+  = go targetEvolution (hkEvolution hk) (hkKey hk) >>= \case
+      Nothing   -> return Nothing
+      Just key' -> return $ Just HotKey {
+          hkStart     = hkStart hk
+        , hkEnd       = hkEnd   hk
+        , hkEvolution = targetEvolution
+        , hkKey       = key'
+        }
+  | otherwise
+  = return Nothing
   where
     go :: KESEvolution
        -> KESEvolution
        -> SignKeyKES (KES c)
-       -> Maybe (SignKeyKES (KES c))
+       -> m (Maybe (SignKeyKES (KES c)))
     go targetEvolution curEvolution key
       | targetEvolution == curEvolution
-      = Just key
+      = return $ Just key
       | targetEvolution < curEvolution
-      = Nothing
+      = forgetSignKeyKES key >> return Nothing
       | otherwise
       = case updateKES () key curEvolution of
           -- This cannot happen
-          Nothing   -> error "Could not update KES key"
-          Just key' -> go targetEvolution (curEvolution + 1) key'
+          Nothing    -> error "Could not update KES key"
+          Just !key' -> do
+            -- Clear the memory associated with the old key
+            forgetSignKeyKES key
+            go targetEvolution (curEvolution + 1) key'

ouroboros-consensus/ouroboros-consensus-test-infra/src/Test/Util/Orphans/IOLike.hs

@@ -10,4 +10,5 @@ import           Test.Util.Orphans.NoUnexpectedThunks ()
 instance MonadSTMTxExtended (SimSTM s) where
   lengthTBQueue = lengthTBQueueDefault
 
-instance IOLike (SimM s)
+instance IOLike (SimM s) where
+  forgetSignKeyKES = const $ return ()

ouroboros-consensus/src/Ouroboros/Consensus/Util/EarlyExit.hs

@@ -37,7 +37,7 @@ import           Control.Monad.Class.MonadThrow
 import           Control.Monad.Class.MonadTimer
 
 import           Ouroboros.Consensus.Util ((.:))
-import           Ouroboros.Consensus.Util.IOLike (IOLike,
+import           Ouroboros.Consensus.Util.IOLike (IOLike (..),
                      MonadMonotonicTime (..), MonadSTMTxExtended (..),
                      StrictMVar, StrictTVar)
 
@@ -232,4 +232,5 @@ instance ( IOLike m
            -- @MonadCatch (STM m)@ intsead of @MonadThrow (STM m)@.
            -- <https://github.com/input-output-hk/ouroboros-network/issues/1461>
          , MonadCatch (STM m)
-         ) => IOLike (WithEarlyExit m)
+         ) => IOLike (WithEarlyExit m) where
+  forgetSignKeyKES = lift . forgetSignKeyKES

ouroboros-consensus/src/Ouroboros/Consensus/Util/IOLike.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE QuantifiedConstraints #-}
 
 module Ouroboros.Consensus.Util.IOLike (
-    IOLike
+    IOLike(..)
     -- * Re-exports
     -- *** MonadThrow
   , MonadThrow(..)
@@ -42,6 +42,8 @@ module Ouroboros.Consensus.Util.IOLike (
 
 import qualified Control.Concurrent.STM as IO
 
+import           Cardano.Crypto.KES (KESAlgorithm, SignKeyKES)
+import qualified Cardano.Crypto.KES as KES
 import           Cardano.Prelude (Natural, NoUnexpectedThunks (..))
 
 import           Control.Monad.Class.MonadAsync
@@ -89,5 +91,10 @@ class ( MonadAsync              m
       , forall a. NoUnexpectedThunks a => NoUnexpectedThunks (StrictTVar m a)
       , forall a. NoUnexpectedThunks a => NoUnexpectedThunks (StrictMVar m a)
       ) => IOLike m where
+  -- | Securely forget a KES signing key.
+  --
+  -- No-op for the IOSim, but 'KES.forgetSignKeyKES' for IO.
+  forgetSignKeyKES :: KESAlgorithm v => SignKeyKES v -> m ()
 
-instance IOLike IO
+instance IOLike IO where
+  forgetSignKeyKES = KES.forgetSignKeyKES

ouroboros-consensus/test-consensus/Test/Consensus/BlockchainTime/Simple.hs

@@ -340,7 +340,8 @@ instance MonadDelay (OverrideDelay (SimM s)) where
 instance MonadDelay (OverrideDelay IO) where
   threadDelay d = OverrideDelay $ ReaderT $ \_schedule -> threadDelay d
 
-instance (IOLike m, MonadDelay (OverrideDelay m)) => IOLike (OverrideDelay m)
+instance (IOLike m, MonadDelay (OverrideDelay m)) => IOLike (OverrideDelay m) where
+  forgetSignKeyKES = OverrideDelay . lift . forgetSignKeyKES
 
 overrideDelay :: UTCTime
               -> Schedule