ForgetMock wrapper for KES

cardano-crypto-class/cardano-crypto-class.cabal

@@ -43,6 +43,7 @@ library
 
                        Cardano.Crypto.KES.Class
                        Cardano.Crypto.KES.Mock
+                       Cardano.Crypto.KES.ForgetMock
                        Cardano.Crypto.KES.NeverUsed
                        Cardano.Crypto.KES.Simple
                        Cardano.Crypto.KES.Single
@@ -84,6 +85,7 @@ library
                      , memory
                      , nothunks
                      , primitive
+                     , stm
                      , text
                      , transformers
                      , vector

cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs

@@ -47,7 +47,7 @@ import GHC.Generics (Generic)
 import GHC.Stack
 import GHC.TypeLits (Nat, KnownNat, natVal)
 import NoThunks.Class (NoThunks)
->>>>>>> Cardano.Crypto.KES using libsodium bindings
+import Data.Functor.Identity (Identity)
 
 import Cardano.Binary (Decoder, decodeBytes, Encoding, encodeBytes, Size, withWordSize)
 
@@ -66,6 +66,8 @@ class ( Typeable v
       , NoThunks (SignKeyKES v)
       , NoThunks (VerKeyKES v)
       , KnownNat (SeedSizeKES v)
+      , Monad (ForgetKES v)
+      , Monad (GenerateKES v)
       )
       => KESAlgorithm v where
 
@@ -79,6 +81,13 @@ class ( Typeable v
   data SignKeyKES v :: Type
   data SigKES     v :: Type
 
+  -- | The monad in which keys can be generated or updated.
+  type GenerateKES v :: Type -> Type
+  type GenerateKES v = Identity
+
+  -- | The monad in which keys can be forgotten.
+  type ForgetKES v :: Type -> Type
+  type ForgetKES v = IO
 
   --
   -- Metadata and basic key operations
@@ -143,7 +152,7 @@ class ( Typeable v
     => ContextKES v
     -> SignKeyKES v
     -> Period  -- ^ The /current/ period for the key, not the target period.
-    -> Maybe (SignKeyKES v)
+    -> GenerateKES v (Maybe (SignKeyKES v))
 
   -- | Return the total number of KES periods supported by this algorithm. The
   -- KES algorithm is assumed to support a fixed maximum number of periods, not
@@ -161,7 +170,9 @@ class ( Typeable v
   -- Key generation
   --
 
-  genKeyKES :: NaCl.MLockedSizedBytes (SeedSizeKES v) -> SignKeyKES v
+  genKeyKES
+    :: NaCl.MLockedSizedBytes (SeedSizeKES v)
+    -> GenerateKES v (SignKeyKES v)
 
   -- | The upper bound on the 'Seed' size needed by 'genKeyKES'
   seedSizeKES :: proxy v -> Word
@@ -177,8 +188,11 @@ class ( Typeable v
   --
   -- The precondition is that this key value will not be used again.
   --
-  forgetSignKeyKES :: SignKeyKES v -> IO ()
-  forgetSignKeyKES = const $ return ()
+  forgetSignKeyKES
+    :: SignKeyKES v
+    -> ForgetKES v ()
+  forgetSignKeyKES =
+    const $ return ()
 
   --
   -- Serialisation/(de)serialisation in fixed-size raw format

cardano-crypto-class/src/Cardano/Crypto/KES/ForgetMock.hs

@@ -0,0 +1,125 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | Mock key evolving signatures.
+module Cardano.Crypto.KES.ForgetMock
+  ( ForgetMockKES
+  , VerKeyKES (..)
+  , SignKeyKES (..)
+  , SigKES (..)
+  )
+where
+
+import Data.Proxy (Proxy(..))
+import GHC.Generics (Generic)
+
+import Cardano.Prelude (lift, MonadIO, liftIO, ReaderT (..), ask)
+
+import Cardano.Crypto.KES.Class
+import Debug.Trace (traceEvent)
+import NoThunks.Class (NoThunks)
+import System.IO.Unsafe
+
+-- | A wrapper for a KES implementation that adds logging functionality, for
+-- the purpose of verifying that invocations of 'genKeyKES' and
+-- 'forgetSignKeyKES' pair up properly in a given host application.
+--
+-- The wrapped KES behaves exactly like its unwrapped payload, except that
+-- invocations of 'genKeyKES', 'updateKES' and 'forgetSignKeyKES' are logged
+-- to the eventlog (via 'traceEvent'), prefixed with @"PRE: "@, @"UPD: "@,
+-- or @"DEL: "@, respectively.
+data ForgetMockKES k
+
+type Logger = String -> IO ()
+
+instance
+  ( KESAlgorithm k
+  , MonadIO (ForgetKES k)
+  )
+  => KESAlgorithm (ForgetMockKES k) where
+    type SeedSizeKES (ForgetMockKES k) = SeedSizeKES k
+    type Signable (ForgetMockKES k) = Signable k
+
+    newtype VerKeyKES (ForgetMockKES k) = VerKeyForgetMockKES (VerKeyKES k)
+      deriving (Generic)
+    newtype SignKeyKES (ForgetMockKES k) = SignKeyForgetMockKES (SignKeyKES k)
+      deriving (Generic)
+    newtype SigKES (ForgetMockKES k) = SigForgetMockKES (SigKES k)
+      deriving (Generic)
+
+    type ContextKES (ForgetMockKES k) = ContextKES k
+
+    type GenerateKES (ForgetMockKES k) = ReaderT Logger (GenerateKES k)
+    type ForgetKES (ForgetMockKES k) = ReaderT Logger (ForgetKES k)
+
+    genKeyKES seed = do
+      sk <- lift $ genKeyKES seed
+      (writeLog :: Logger) <- ask
+      let a = unsafePerformIO $ writeLog ("GEN: " ++ show sk)
+      a `seq` return (SignKeyForgetMockKES sk)
+
+    forgetSignKeyKES (SignKeyForgetMockKES sk) = do
+      writeLog <- ask
+      liftIO $ writeLog ("DEL: " ++ show sk)
+      return ()
+
+    algorithmNameKES _ = algorithmNameKES (Proxy @k)
+
+    deriveVerKeyKES (SignKeyForgetMockKES k) = VerKeyForgetMockKES $ deriveVerKeyKES k
+
+    signKES ctx p msg (SignKeyForgetMockKES sk) =
+        SigForgetMockKES $ signKES ctx p msg sk
+
+    verifyKES ctx (VerKeyForgetMockKES vk) p msg (SigForgetMockKES sig) =
+        verifyKES ctx vk p msg sig
+
+    updateKES ctx (SignKeyForgetMockKES sk) p = do
+      writeLog <- ask
+      lift (updateKES ctx sk p) >>= \case
+        Just sk' -> do
+          let a = unsafePerformIO $ writeLog ("UPD: " ++ show sk')
+          a `seq` (return $ Just $ SignKeyForgetMockKES sk')
+        Nothing -> do
+          let a = unsafePerformIO $ writeLog ("UPD: ---")
+          a `seq` return Nothing
+
+    totalPeriodsKES _ = totalPeriodsKES (Proxy @k)
+
+    sizeVerKeyKES _ = sizeVerKeyKES (Proxy @k)
+    sizeSignKeyKES _ = sizeSignKeyKES (Proxy @k)
+    sizeSigKES _ = sizeSigKES (Proxy @k)
+
+    rawSerialiseVerKeyKES (VerKeyForgetMockKES k) = rawSerialiseVerKeyKES k
+    rawSerialiseSignKeyKES (SignKeyForgetMockKES k) = rawSerialiseSignKeyKES k
+    rawSerialiseSigKES (SigForgetMockKES k) = rawSerialiseSigKES k
+
+    rawDeserialiseVerKeyKES = fmap VerKeyForgetMockKES . rawDeserialiseVerKeyKES
+    rawDeserialiseSignKeyKES = fmap SignKeyForgetMockKES . rawDeserialiseSignKeyKES
+    rawDeserialiseSigKES = fmap SigForgetMockKES . rawDeserialiseSigKES
+
+
+
+deriving instance Show (VerKeyKES k) => Show (VerKeyKES (ForgetMockKES k))
+deriving instance Eq (VerKeyKES k) => Eq (VerKeyKES (ForgetMockKES k))
+deriving instance Ord (VerKeyKES k) => Ord (VerKeyKES (ForgetMockKES k))
+deriving instance NoThunks (VerKeyKES k) => NoThunks (VerKeyKES (ForgetMockKES k))
+
+deriving instance Show (SignKeyKES k) => Show (SignKeyKES (ForgetMockKES k))
+deriving instance Eq (SignKeyKES k) => Eq (SignKeyKES (ForgetMockKES k))
+deriving instance Ord (SignKeyKES k) => Ord (SignKeyKES (ForgetMockKES k))
+deriving instance NoThunks (SignKeyKES k) => NoThunks (SignKeyKES (ForgetMockKES k))
+
+deriving instance Show (SigKES k) => Show (SigKES (ForgetMockKES k))
+deriving instance Eq (SigKES k) => Eq (SigKES (ForgetMockKES k))
+deriving instance Ord (SigKES k) => Ord (SigKES (ForgetMockKES k))
+deriving instance NoThunks (SigKES k) => NoThunks (SigKES (ForgetMockKES k))

cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs

@@ -89,8 +89,8 @@ instance KnownNat t => KESAlgorithm (MockKES t) where
     updateKES () (SignKeyMockKES vk t') t =
         assert (t == t') $
          if t+1 < totalPeriodsKES (Proxy @ (MockKES t))
-           then Just (SignKeyMockKES vk (t+1))
-           else Nothing
+           then return $ Just (SignKeyMockKES vk (t+1))
+           else return Nothing
 
     -- | Produce valid signature only with correct key, i.e., same iteration and
     -- allowed KES period.
@@ -115,9 +115,9 @@ instance KnownNat t => KESAlgorithm (MockKES t) where
     -- Key generation
     --
 
-    genKeyKES seed =
+    genKeyKES seed = do
         let vk = VerKeyMockKES (runMonadRandomWithSeed (mkSeedFromBytes $ mlsbToByteString seed) getRandomWord64)
-         in SignKeyMockKES vk 0
+        return $ SignKeyMockKES vk 0
 
 
     --

cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs

@@ -45,7 +45,7 @@ instance KESAlgorithm NeverKES where
 
   totalPeriodsKES _ = 0
 
-  genKeyKES       _ = NeverUsedSignKeyKES
+  genKeyKES       _ = return NeverUsedSignKeyKES
 
   sizeVerKeyKES  _ = 0
   sizeSignKeyKES _ = 0

cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs

@@ -114,8 +114,8 @@ instance (DSIGNAlgorithm d, Typeable d, KnownNat t, KnownNat (SeedSizeDSIGN d *
           Just vk -> verifyDSIGN ctxt vk a sig
 
     updateKES _ sk t
-      | t+1 < fromIntegral (natVal (Proxy @ t)) = Just sk
-      | otherwise                               = Nothing
+      | t+1 < fromIntegral (natVal (Proxy @ t)) = return $ Just sk
+      | otherwise                               = return Nothing
 
     totalPeriodsKES  _ = fromIntegral (natVal (Proxy @ t))
 
@@ -137,7 +137,7 @@ instance (DSIGNAlgorithm d, Typeable d, KnownNat t, KnownNat (SeedSizeDSIGN d *
                      . map mkSeedFromBytes
                      $ unfoldr (getBytesFromSeed seedSize) seed
             sks      = map genKeyDSIGN seeds
-         in SignKeySimpleKES (Vec.fromList sks)
+         in return $ SignKeySimpleKES (Vec.fromList sks)
 
 
     --

cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs

@@ -104,15 +104,16 @@ instance ( NaCl.SodiumDSIGNAlgorithm d -- needed for secure forgetting
         assert (t == 0) $
         NaCl.naclVerifyDSIGN (Proxy @d) vk a sig
 
-    updateKES _ctx (SignKeySingleKES _sk) _to = Nothing
+    updateKES _ctx (SignKeySingleKES _sk) _to = return Nothing
 
     totalPeriodsKES  _ = 1
 
     --
     -- Key generation
     --
 
-    genKeyKES seed = SignKeySingleKES (NaCl.naclGenKeyDSIGN (Proxy @d) seed)
+    genKeyKES seed =
+      return $ SignKeySingleKES (NaCl.naclGenKeyDSIGN (Proxy @d) seed)
 
     --
     -- forgetting