Changes needed for KES Agent

- Direct serialisation from/to raw memory
- SignKeyWithPeriodKES wrapper

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

@@ -54,6 +54,7 @@ library
     Cardano.Crypto.DSIGNM.Class
     Cardano.Crypto.DSIGN.Mock
     Cardano.Crypto.DSIGN.NeverUsed
+    Cardano.Crypto.DirectSerialise
     Cardano.Crypto.Hash
     Cardano.Crypto.Hash.Blake2b
     Cardano.Crypto.Hash.Class

cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs

@@ -29,7 +29,7 @@ import Foreign.Ptr (castPtr, nullPtr)
 import qualified Data.ByteString as BS
 import Data.Proxy
 import Control.Monad ((<$!>))
-import Control.Monad.Class.MonadThrow (MonadThrow (..), throwIO)
+import Control.Monad.Class.MonadThrow (MonadThrow (..), throwIO, bracket)
 import Control.Monad.Class.MonadST (MonadST (..))
 import Control.Monad.ST (ST, stToIO)
 import Control.Monad.ST.Unsafe (unsafeIOToST)
@@ -54,6 +54,7 @@ import Cardano.Crypto.MonadSodium
 import Cardano.Crypto.DSIGNM.Class
 import Cardano.Crypto.MLockedSeed
 import Cardano.Crypto.Util (SignableRepresentation(..))
+import Cardano.Crypto.DirectSerialise
 
 data Ed25519DSIGNM
 
@@ -272,6 +273,51 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => UnsoundDSIGNMAlgorithm m Ed
           mlockedSeedFinalize seed
           return sk
 
+instance DirectSerialise (SignKeyDSIGNM Ed25519DSIGNM) where
+  -- /Note:/ We only serialize the 32-byte seed, not the full 64-byte key. The
+  -- latter contains both the seed and the 32-byte verification key, which is
+  -- convenient, but redundant, since we can always reconstruct it from the
+  -- seed. This is also reflected in the 'SizeSignKeyDSIGNM', which equals
+  -- 'SeedSizeDSIGNM' == 32, rather than reporting the in-memory size of 64.
+  directSerialise push sk = do
+    bracket
+      (getSeedDSIGNM (Proxy @Ed25519DSIGNM) sk)
+      mlockedSeedFinalize
+      (\seed -> mlockedSeedUseAsCPtr seed $ \ptr ->
+          push
+            (castPtr ptr)
+            (fromIntegral $ seedSizeDSIGNM (Proxy @Ed25519DSIGNM)))
+
+instance DirectDeserialise (SignKeyDSIGNM Ed25519DSIGNM) where
+  -- /Note:/ We only serialize the 32-byte seed, not the full 64-byte key. See
+  -- the DirectSerialise instance above.
+  directDeserialise pull = do
+    bracket
+      mlockedSeedNew
+      mlockedSeedFinalize
+      (\seed -> do
+          mlockedSeedUseAsCPtr seed $ \ptr -> do
+            pull
+              (castPtr ptr)
+              (fromIntegral $ seedSizeDSIGNM (Proxy @Ed25519DSIGNM))
+          genKeyDSIGNM seed
+      )
+
+instance DirectSerialise (VerKeyDSIGNM Ed25519DSIGNM) where
+  directSerialise push (VerKeyEd25519DSIGNM psb) = do
+    psbUseAsCPtr psb $ \ptr ->
+      push
+        (castPtr ptr)
+        (fromIntegral $ sizeVerKeyDSIGNM (Proxy @Ed25519DSIGNM))
+
+instance DirectDeserialise (VerKeyDSIGNM Ed25519DSIGNM) where
+  directDeserialise pull = do
+    psb <- psbCreate $ \ptr ->
+      pull
+        (castPtr ptr)
+        (fromIntegral $ sizeVerKeyDSIGNM (Proxy @Ed25519DSIGNM))
+    return $! VerKeyEd25519DSIGNM $! psb
+
 instance ToCBOR (VerKeyDSIGNM Ed25519DSIGNM) where
   toCBOR = encodeVerKeyDSIGNM
   encodedSizeExpr _ = encodedVerKeyDSIGNMSizeExpr

cardano-crypto-class/src/Cardano/Crypto/DirectSerialise.hs

@@ -0,0 +1,39 @@
+-- | Direct (de-)serialisation to / from raw memory.
+--
+-- The purpose of the typeclasses in this module is to abstract over data
+-- structures that can expose the data they store as one or more raw 'Ptr's,
+-- without any additional memory copying or conversion to intermediate data
+-- structures.
+--
+-- This is useful for transmitting data like KES SignKeys over a socket
+-- connection: by accessing the memory directly and copying it into or out of
+-- a file descriptor, without going through an intermediate @ByteString@
+-- representation (or other data structure that resides in the GHC heap), we
+-- can more easily assure that the data is never written to disk, including
+-- swap, which is an important requirement for KES.
+module Cardano.Crypto.DirectSerialise
+where
+
+import Foreign.Ptr
+import Foreign.C.Types
+
+-- | Direct deserialization from raw memory.
+--
+-- @directDeserialise f@ should allocate a new value of type 'a', and
+-- call @f@ with a pointer to the raw memory to be filled. @f@ may be called
+-- multiple times, for data structures that store their data in multiple
+-- non-contiguous blocks of memory.
+--
+-- The order in which memory blocks are visited matters.
+class DirectDeserialise a where
+  directDeserialise :: (Ptr CChar -> CSize -> IO ()) -> IO a
+
+-- | Direct serialization to raw memory.
+--
+-- @directSerialise f x@ should call @f@ to expose the raw memory underyling
+-- @x@. For data types that store their data in multiple non-contiguous blocks
+-- of memory, @f@ may be called multiple times, once for each block.
+--
+-- The order in which memory blocks are visited matters.
+class DirectSerialise a where
+  directSerialise :: (Ptr CChar -> CSize -> IO ()) -> a -> IO ()

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

@@ -21,6 +21,10 @@ module Cardano.Crypto.KES.Class
   , OptimizedKESAlgorithm (..)
   , verifyOptimizedKES
 
+    -- * 'SignKeyWithPeriodKES' wrapper
+  , SignKeyWithPeriodKES (..)
+  , updateKESWithPeriod
+
     -- * 'SignedKES' wrapper
   , SignedKES (..)
   , signedKES
@@ -72,6 +76,7 @@ import GHC.Generics (Generic)
 import GHC.Stack
 import GHC.TypeLits (Nat, KnownNat, natVal, TypeError, ErrorMessage (..))
 import NoThunks.Class (NoThunks)
+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
 
 import Cardano.Binary (Decoder, decodeBytes, Encoding, encodeBytes, Size, withWordSize)
 
@@ -398,6 +403,30 @@ encodeSignedKES (SignedKES s) = encodeSigKES s
 decodeSignedKES :: KESAlgorithm v => Decoder s (SignedKES v a)
 decodeSignedKES = SignedKES <$> decodeSigKES
 
+-- | A sign key bundled with its associated period.
+data SignKeyWithPeriodKES v =
+  SignKeyWithPeriodKES
+    { skWithoutPeriodKES :: !(SignKeyKES v)
+    , periodKES :: !Period
+    }
+    deriving (Generic)
+
+deriving instance (KESAlgorithm v, Eq (SignKeyKES v)) => Eq (SignKeyWithPeriodKES v)
+
+deriving instance (KESAlgorithm v, Show (SignKeyKES v)) => Show (SignKeyWithPeriodKES v)
+
+instance KESAlgorithm v => NoThunks (SignKeyWithPeriodKES v)
+  -- use generic instance
+
+updateKESWithPeriod
+    :: (HasCallStack, KESSignAlgorithm m v)
+    => ContextKES v
+    -> (SignKeyWithPeriodKES v)
+    -> m (Maybe (SignKeyWithPeriodKES v))
+updateKESWithPeriod c (SignKeyWithPeriodKES sk t) = runMaybeT $ do
+  sk' <- MaybeT $ updateKES c sk t
+  return $ SignKeyWithPeriodKES sk' (succ t)
+
 --
 -- 'Size' expressions for 'ToCBOR' instances.
 --

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

@@ -62,6 +62,7 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Crypto.Hash.Class
 import Cardano.Crypto.DSIGNM.Class as DSIGNM
 import Cardano.Crypto.KES.Class
+import Cardano.Crypto.DirectSerialise
 
 
 -- | A standard signature scheme is a forward-secure signature scheme with a
@@ -233,3 +234,19 @@ instance (DSIGNMAlgorithmBase d, KnownNat (SizeSigKES (CompactSingleKES d))) =>
 slice :: Word -> Word -> ByteString -> ByteString
 slice offset size = BS.take (fromIntegral size)
                   . BS.drop (fromIntegral offset)
+
+--
+-- Direct ser/deser
+--
+
+instance (DirectSerialise (SignKeyDSIGNM d)) => DirectSerialise (SignKeyKES (CompactSingleKES d)) where
+  directSerialise push (SignKeyCompactSingleKES sk) = directSerialise push sk
+
+instance (DirectDeserialise (SignKeyDSIGNM d)) => DirectDeserialise (SignKeyKES (CompactSingleKES d)) where
+  directDeserialise pull = SignKeyCompactSingleKES <$> directDeserialise pull
+
+instance (DirectSerialise (VerKeyDSIGNM d)) => DirectSerialise (VerKeyKES (CompactSingleKES d)) where
+  directSerialise push (VerKeyCompactSingleKES sk) = directSerialise push sk
+
+instance (DirectDeserialise (VerKeyDSIGNM d)) => DirectDeserialise (VerKeyKES (CompactSingleKES d)) where
+  directDeserialise pull = VerKeyCompactSingleKES <$> directDeserialise pull

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

@@ -88,8 +88,10 @@ module Cardano.Crypto.KES.CompactSum (
 import           Data.Proxy (Proxy(..))
 import           GHC.Generics (Generic)
 import qualified Data.ByteString as BS
-import           Control.Monad (guard)
+import           Control.Monad (guard, (<$!>))
 import           NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
+import           Foreign.Ptr (castPtr)
+import           Foreign.Marshal.Alloc (allocaBytes)
 
 import           Cardano.Binary (FromCBOR (..), ToCBOR (..))
 
@@ -105,6 +107,7 @@ import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
 import           Control.Monad.Trans (lift)
 import           Control.DeepSeq (NFData (..))
 import           GHC.TypeLits (KnownNat, type (+), type (*))
+import           Cardano.Crypto.DirectSerialise
 
 -- | A 2^0 period KES
 type CompactSum0KES d   = CompactSingleKES d
@@ -479,3 +482,49 @@ instance ( OptimizedKESAlgorithm d
          )
       => FromCBOR (SigKES (CompactSumKES h d)) where
   fromCBOR = decodeSigKES
+
+--
+-- Direct ser/deser
+--
+
+instance ( DirectSerialise (SignKeyKES d)
+         , DirectSerialise (VerKeyKES d)
+         , KESAlgorithm d
+         ) => DirectSerialise (SignKeyKES (CompactSumKES h d)) where
+  directSerialise push (SignKeyCompactSumKES sk r vk0 vk1) = do
+    directSerialise push sk
+    mlockedSeedUseAsCPtr r $ \ptr ->
+      push (castPtr ptr) (fromIntegral $ seedSizeKES (Proxy :: Proxy d))
+    directSerialise push vk0
+    directSerialise push vk1
+
+instance ( DirectDeserialise (SignKeyKES d)
+         , DirectDeserialise (VerKeyKES d)
+         , KESAlgorithm d
+         ) => DirectDeserialise (SignKeyKES (CompactSumKES h d)) where
+  directDeserialise pull = do
+    sk <- directDeserialise pull
+
+    r <- mlockedSeedNew
+    mlockedSeedUseAsCPtr r $ \ptr ->
+      pull (castPtr ptr) (fromIntegral $ seedSizeKES (Proxy :: Proxy d))
+
+    vk0 <- directDeserialise pull
+    vk1 <- directDeserialise pull
+
+    return $! SignKeyCompactSumKES sk r vk0 vk1
+
+
+instance DirectSerialise (VerKeyKES (CompactSumKES h d)) where
+  directSerialise push (VerKeyCompactSumKES h) = do
+    BS.useAsCStringLen (hashToBytes h) $ \(ptr, len) ->
+      push (castPtr ptr) (fromIntegral len)
+
+instance HashAlgorithm h => DirectDeserialise (VerKeyKES (CompactSumKES h d)) where
+  directDeserialise pull = do
+    let len :: Num a => a
+        len = fromIntegral $ sizeHash (Proxy @h)
+    allocaBytes len $ \ptr -> do
+      pull ptr len
+      bs <- BS.packCStringLen (ptr, len)
+      maybe (fail "Invalid hash") return $! VerKeyCompactSumKES <$!> hashFromBytes bs

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

@@ -24,6 +24,8 @@ import Data.Proxy (Proxy(..))
 import GHC.Generics (Generic)
 import GHC.TypeNats (Nat, KnownNat, natVal)
 import NoThunks.Class (NoThunks)
+import qualified Data.ByteString as BS
+import Foreign.Marshal.Alloc (allocaBytes)
 
 import Control.Exception (assert)
 
@@ -35,6 +37,7 @@ import Cardano.Crypto.KES.Class
 import Cardano.Crypto.Util
 import Cardano.Crypto.MLockedSeed
 import Cardano.Crypto.MonadSodium (mlsbAsByteString)
+import Cardano.Crypto.DirectSerialise
 
 data MockKES (t :: Nat)
 
@@ -179,6 +182,34 @@ rawSerialiseSignKeyMockKES (SignKeyMockKES vk t) =
     rawSerialiseVerKeyKES vk
  <> writeBinaryWord64 (fromIntegral t)
 
+instance KnownNat t => DirectSerialise (SignKeyKES (MockKES t)) where
+  directSerialise put sk = do
+    let bs = rawSerialiseSignKeyMockKES sk
+    BS.useAsCStringLen bs $ \(cstr, len) -> put cstr (fromIntegral len)
+
+instance KnownNat t => DirectDeserialise (SignKeyKES (MockKES t)) where
+  directDeserialise pull = do
+    let len = fromIntegral $ sizeSignKeyKES (Proxy @(MockKES t))
+    bs <- allocaBytes len $ \cstr -> do
+        pull cstr (fromIntegral len)
+        BS.packCStringLen (cstr, len)
+    maybe (error "directDeserialise @(SignKeyKES (MockKES t))") return $
+        rawDeserialiseSignKeyMockKES bs
+
+instance KnownNat t => DirectSerialise (VerKeyKES (MockKES t)) where
+  directSerialise put sk = do
+    let bs = rawSerialiseVerKeyKES sk
+    BS.useAsCStringLen bs $ \(cstr, len) -> put cstr (fromIntegral len)
+
+instance KnownNat t => DirectDeserialise (VerKeyKES (MockKES t)) where
+  directDeserialise pull = do
+    let len = fromIntegral $ sizeVerKeyKES (Proxy @(MockKES t))
+    bs <- allocaBytes len $ \cstr -> do
+        pull cstr (fromIntegral len)
+        BS.packCStringLen (cstr, len)
+    maybe (error "directDeserialise @(VerKeyKES (MockKES t))") return $
+        rawDeserialiseVerKeyKES bs
+
 instance KnownNat t => ToCBOR (VerKeyKES (MockKES t)) where
   toCBOR = encodeVerKeyKES
   encodedSizeExpr _size = encodedVerKeyKESSizeExpr

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

@@ -40,6 +40,7 @@ import           Cardano.Crypto.KES.Class
 import           Cardano.Crypto.MLockedSeed
 import           Cardano.Crypto.Libsodium.MLockedBytes
 import           Cardano.Crypto.Util
+import           Cardano.Crypto.DirectSerialise (DirectSerialise (..), DirectDeserialise (..))
 import           Data.Unit.Strict (forceElemsToWHNF)
 import           Cardano.Crypto.MonadSodium (MonadSodium (..), MEq (..))
 
@@ -188,7 +189,6 @@ instance ( KESAlgorithm (SimpleKES d t)
     forgetSignKeyKES (SignKeySimpleKES sks) = Vec.mapM_ forgetSignKeyDSIGNM sks
 
 
-
 instance ( UnsoundDSIGNMAlgorithm m d, KnownNat t, KESSignAlgorithm m (SimpleKES d t))
          => UnsoundKESSignAlgorithm m (SimpleKES d t) where
     --
@@ -211,6 +211,26 @@ instance ( UnsoundDSIGNMAlgorithm m d, KnownNat t, KESSignAlgorithm m (SimpleKES
       | otherwise
       = return Nothing
 
+instance DirectSerialise (VerKeyDSIGNM d) => DirectSerialise (VerKeyKES (SimpleKES d t)) where
+  directSerialise push (VerKeySimpleKES vks) =
+    mapM_ (directSerialise push) vks
+
+instance (DirectDeserialise (VerKeyDSIGNM d), KnownNat t) => DirectDeserialise (VerKeyKES (SimpleKES d t)) where
+  directDeserialise pull = do
+    let duration = fromIntegral (natVal (Proxy :: Proxy t))
+    vks <- Vec.replicateM duration (directDeserialise pull)
+    return $! VerKeySimpleKES $! vks
+
+instance (DirectSerialise (SignKeyDSIGNM d)) => DirectSerialise (SignKeyKES (SimpleKES d t)) where
+  directSerialise push (SignKeySimpleKES sks) =
+    mapM_ (directSerialise push) sks
+
+instance (DirectDeserialise (SignKeyDSIGNM d), KnownNat t) => DirectDeserialise (SignKeyKES (SimpleKES d t)) where
+  directDeserialise pull = do
+    let duration = fromIntegral (natVal (Proxy :: Proxy t))
+    sks <- Vec.replicateM duration (directDeserialise pull)
+    return $! SignKeySimpleKES $! sks
+
 deriving instance DSIGNMAlgorithmBase d => Show (VerKeyKES (SimpleKES d t))
 deriving instance DSIGNMAlgorithmBase d => Show (SignKeyKES (SimpleKES d t))
 deriving instance DSIGNMAlgorithmBase d => Show (SigKES (SimpleKES d t))

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

@@ -52,6 +52,7 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Crypto.Hash.Class
 import Cardano.Crypto.DSIGNM.Class as DSIGNM
 import Cardano.Crypto.KES.Class
+import Cardano.Crypto.DirectSerialise
 
 
 -- | A standard signature scheme is a forward-secure signature scheme with a
@@ -110,7 +111,6 @@ instance (DSIGNMAlgorithmBase d) => KESAlgorithm (SingleKES d) where
     rawDeserialiseVerKeyKES  = fmap VerKeySingleKES  . rawDeserialiseVerKeyDSIGNM
     rawDeserialiseSigKES     = fmap SigSingleKES     . rawDeserialiseSigDSIGNM
 
-
 instance ( DSIGNMAlgorithm m d -- needed for secure forgetting
          , Monad m
          ) => KESSignAlgorithm m (SingleKES d) where
@@ -187,3 +187,19 @@ instance DSIGNMAlgorithmBase d => ToCBOR (SigKES (SingleKES d)) where
 
 instance DSIGNMAlgorithmBase d => FromCBOR (SigKES (SingleKES d)) where
   fromCBOR = decodeSigKES
+
+--
+-- Direct ser/deser
+--
+
+instance (DirectSerialise (SignKeyDSIGNM d)) => DirectSerialise (SignKeyKES (SingleKES d)) where
+  directSerialise push (SignKeySingleKES sk) = directSerialise push sk
+
+instance (DirectDeserialise (SignKeyDSIGNM d)) => DirectDeserialise (SignKeyKES (SingleKES d)) where
+  directDeserialise pull = SignKeySingleKES <$!> directDeserialise pull
+
+instance (DirectSerialise (VerKeyDSIGNM d)) => DirectSerialise (VerKeyKES (SingleKES d)) where
+  directSerialise push (VerKeySingleKES sk) = directSerialise push sk
+
+instance (DirectDeserialise (VerKeyDSIGNM d)) => DirectDeserialise (VerKeyKES (SingleKES d)) where
+  directDeserialise pull = VerKeySingleKES <$!> directDeserialise pull