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

@@ -28,7 +28,7 @@ import Foreign.Ptr (castPtr, nullPtr)
 import qualified Data.ByteString as BS
 -- import qualified Data.ByteString.Unsafe as BS
 import Data.Proxy
-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)
 import Control.Monad.ST.Unsafe (unsafeIOToST)
@@ -45,6 +45,7 @@ import Cardano.Crypto.MonadSodium (MonadSodium (..), mlsbToByteString, mlsbFromB
 import Cardano.Crypto.DSIGNM.Class
 -- import Cardano.Crypto.Seed
 import Cardano.Crypto.Util (SignableRepresentation(..))
+import Cardano.Crypto.DirectSerialise
 
 data Ed25519DSIGNM
 
@@ -249,6 +250,39 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS
           mlsbFinalize seed
           return sk
 
+instance DirectSerialise (SignKeyDSIGNM Ed25519DSIGNM) where
+  directSerialise push sk = do
+    bracket
+      (getSeedDSIGNM (Proxy @Ed25519DSIGNM) sk)
+      mlsbFinalize
+      (\mlsb -> mlsbUseAsCPtr mlsb $ \ptr ->
+          push
+            (castPtr ptr)
+            (fromIntegral $ seedSizeDSIGNM (Proxy @Ed25519DSIGNM)))
+
+instance DirectDeserialise (SignKeyDSIGNM Ed25519DSIGNM) where
+  directDeserialise pull = do
+    mlsb <- mlsbNew
+    mlsbUseAsCPtr mlsb $ \ptr ->
+      pull
+        (castPtr ptr)
+        (fromIntegral $ seedSizeDSIGNM (Proxy @Ed25519DSIGNM))
+    return $ SignKeyEd25519DSIGNM mlsb
+
+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

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
@@ -63,6 +67,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)
 
@@ -390,6 +395,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

@@ -61,6 +61,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
@@ -240,3 +241,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

@@ -89,6 +89,8 @@ import           GHC.Generics (Generic)
 import qualified Data.ByteString as BS
 import           Control.Monad (guard)
 import           NoThunks.Class (NoThunks)
+import           Foreign.Ptr (castPtr)
+import           Foreign.Marshal.Alloc (allocaBytes)
 
 import           Cardano.Binary (FromCBOR (..), ToCBOR (..))
 
@@ -101,6 +103,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
@@ -471,3 +474,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
+    NaCl.mlsbUseAsCPtr 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 <- NaCl.mlsbNew
+    NaCl.mlsbUseAsCPtr 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

@@ -23,6 +23,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)
 
@@ -33,6 +35,7 @@ import Cardano.Crypto.Seed
 import Cardano.Crypto.KES.Class
 import Cardano.Crypto.Util
 import Cardano.Crypto.MonadSodium (mlsbAsByteString)
+import Cardano.Crypto.DirectSerialise
 
 data MockKES (t :: Nat)
 
@@ -48,9 +51,6 @@ data MockKES (t :: Nat)
 -- keys. Mock KES is more suitable for a basic testnet, since it doesn't suffer
 -- from the performance implications of shuffling a giant list of keys around
 instance KnownNat t => KESAlgorithm (MockKES t) where
-    -- We only need 8 bytes for the seed, but in order to satisfy
-    -- @instance MLockedPoolSize (SeedSizeKES (MockKES t))@, we pick 32, one
-    -- of the block sizes for which pools exist.
     type SeedSizeKES (MockKES t) = 8
 
     --
@@ -177,6 +177,20 @@ 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 = 16
+    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 => ToCBOR (VerKeyKES (MockKES t)) where
   toCBOR = encodeVerKeyKES
   encodedSizeExpr _size = encodedVerKeyKESSizeExpr

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

@@ -50,6 +50,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
@@ -107,7 +108,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
@@ -185,3 +185,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

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

@@ -62,10 +62,15 @@ import           Cardano.Crypto.Hash.Class
 import           Cardano.Crypto.KES.Class
 import           Cardano.Crypto.KES.Single (SingleKES)
 import           Cardano.Crypto.Util
-import qualified Cardano.Crypto.MonadSodium as NaCl
 import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
 import           Control.DeepSeq (NFData)
 import           GHC.TypeLits (KnownNat, type (+), type (*))
+import           Cardano.Crypto.DirectSerialise
+
+import qualified Cardano.Crypto.MonadSodium as NaCl
+
+import           Foreign.Ptr (castPtr)
+import           Foreign.Marshal.Alloc
 
 -- | A 2^0 period KES
 type Sum0KES d   = SingleKES d
@@ -376,3 +381,48 @@ instance (KESAlgorithm (SumKES h d), NaCl.SodiumHashAlgorithm h, SizeHash h ~ Se
 instance (KESAlgorithm (SumKES h d), NaCl.SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d)
       => FromCBOR (SigKES (SumKES h d)) where
   fromCBOR = decodeSigKES
+
+--
+-- Direct ser/deser
+--
+
+instance ( DirectSerialise (SignKeyKES d)
+         , DirectSerialise (VerKeyKES d)
+         , KESAlgorithm d
+         ) => DirectSerialise (SignKeyKES (SumKES h d)) where
+  directSerialise push (SignKeySumKES sk r vk0 vk1) = do
+    directSerialise push sk
+    NaCl.mlsbUseAsCPtr 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 (SumKES h d)) where
+  directDeserialise pull = do
+    sk <- directDeserialise pull
+
+    r <- NaCl.mlsbNew
+    NaCl.mlsbUseAsCPtr r $ \ptr ->
+      pull (castPtr ptr) (fromIntegral $ seedSizeKES (Proxy :: Proxy d))
+
+    vk0 <- directDeserialise pull
+    vk1 <- directDeserialise pull
+
+    return $ SignKeySumKES sk r vk0 vk1
+
+instance DirectSerialise (VerKeyKES (SumKES h d)) where
+  directSerialise push (VerKeySumKES h) = do
+    BS.useAsCStringLen (hashToBytes h) $ \(ptr, len) ->
+      push (castPtr ptr) (fromIntegral len)
+
+instance HashAlgorithm h => DirectDeserialise (VerKeyKES (SumKES 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 $ VerKeySumKES <$> hashFromBytes bs