KES Agent prerequisites

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

@@ -39,6 +39,7 @@ library
   import:            base, project-config
   hs-source-dirs:    src
   exposed-modules:
+    Cardano.Crypto.DirectSerialise
     Cardano.Crypto.DSIGN
     Cardano.Crypto.DSIGN.Class
     Cardano.Crypto.DSIGN.Ed25519

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -66,14 +67,17 @@ import Cardano.Crypto.Libsodium.MLockedSeed
 import Cardano.Crypto.PinnedSizedBytes
   ( PinnedSizedBytes
   , psbUseAsSizedPtr
+  , psbUseAsCPtrLen
   , psbToByteString
   , psbFromByteStringCheck
+  , psbCreate
   , psbCreateSized
   , psbCreateSizedResult
   )
 import Cardano.Crypto.Seed
 import Cardano.Crypto.Util (SignableRepresentation(..))
 import Cardano.Foreign
+import Cardano.Crypto.DirectSerialise
 
 
 
@@ -261,7 +265,7 @@ instance DSIGNMAlgorithm Ed25519DSIGN where
               stToIO $ do
                 cOrError $ unsafeIOToST $
                   c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr
-          throwOnErrno "deriveVerKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno
+          throwOnErrno "deriveVerKeyDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno
           return psb
 
 
@@ -365,3 +369,48 @@ instance TypeError ('Text "CBOR encoding would violate mlocking guarantees")
 instance TypeError ('Text "CBOR decoding would violate mlocking guarantees")
   => FromCBOR (SignKeyDSIGNM Ed25519DSIGN) where
   fromCBOR = error "unsupported"
+
+instance DirectSerialise (SignKeyDSIGNM Ed25519DSIGN) 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 @Ed25519DSIGN) sk)
+      mlockedSeedFinalize
+      (\seed -> mlockedSeedUseAsCPtr seed $ \ptr ->
+          push
+            (castPtr ptr)
+            (fromIntegral $ seedSizeDSIGN (Proxy @Ed25519DSIGN)))
+
+instance DirectDeserialise (SignKeyDSIGNM Ed25519DSIGN) 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 $ seedSizeDSIGN (Proxy @Ed25519DSIGN))
+          genKeyDSIGNM seed
+      )
+
+instance DirectSerialise (VerKeyDSIGN Ed25519DSIGN) where
+  directSerialise push (VerKeyEd25519DSIGN psb) = do
+    psbUseAsCPtrLen psb $ \ptr _ ->
+      push
+        (castPtr ptr)
+        (fromIntegral $ sizeVerKeyDSIGN (Proxy @Ed25519DSIGN))
+
+instance DirectDeserialise (VerKeyDSIGN Ed25519DSIGN) where
+  directDeserialise pull = do
+    psb <- psbCreate $ \ptr ->
+      pull
+        (castPtr ptr)
+        (fromIntegral $ sizeVerKeyDSIGN (Proxy @Ed25519DSIGN))
+    return $! VerKeyEd25519DSIGN $! psb

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

@@ -0,0 +1,41 @@
+-- | 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
+import Control.Monad.Class.MonadThrow (MonadThrow)
+import Control.Monad.Class.MonadST (MonadST)
+
+-- | 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 :: (MonadST m, MonadThrow m) => (Ptr CChar -> CSize -> m ()) -> m 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 :: (MonadST m, MonadThrow m) => (Ptr CChar -> CSize -> m ()) -> a -> m ()

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

@@ -60,7 +60,7 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Crypto.Hash.Class
 import Cardano.Crypto.DSIGN.Class as DSIGN
 import Cardano.Crypto.KES.Class
-
+import Cardano.Crypto.DirectSerialise
 
 -- | A standard signature scheme is a forward-secure signature scheme with a
 -- single time period.
@@ -227,3 +227,19 @@ instance (DSIGNMAlgorithm d, KnownNat (SizeSigKES (CompactSingleKES d))) => From
 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 (VerKeyDSIGN d)) => DirectSerialise (VerKeyKES (CompactSingleKES d)) where
+  directSerialise push (VerKeyCompactSingleKES sk) = directSerialise push sk
+
+instance (DirectDeserialise (VerKeyDSIGN d)) => DirectDeserialise (VerKeyKES (CompactSingleKES d)) where
+  directDeserialise pull = VerKeyCompactSingleKES <$!> directDeserialise pull

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

@@ -6,6 +6,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -86,7 +87,8 @@ module Cardano.Crypto.KES.CompactSum (
 import           Data.Proxy (Proxy(..))
 import           GHC.Generics (Generic)
 import qualified Data.ByteString as BS
-import           Control.Monad (guard)
+import qualified Data.ByteString.Internal as BS
+import           Control.Monad (guard, (<$!>))
 import           NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
 
 import           Cardano.Binary (FromCBOR (..), ToCBOR (..))
@@ -97,10 +99,14 @@ import           Cardano.Crypto.KES.CompactSingle (CompactSingleKES)
 import           Cardano.Crypto.Util
 import           Cardano.Crypto.Libsodium.MLockedSeed
 import           Cardano.Crypto.Libsodium
+import           Cardano.Crypto.Libsodium.Memory
+import           Cardano.Crypto.DirectSerialise
+
 import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
 import           Control.Monad.Trans (lift)
 import           Control.DeepSeq (NFData (..))
 import           GHC.TypeLits (KnownNat, type (+), type (*))
+import           Foreign.Ptr (castPtr)
 
 -- | A 2^0 period KES
 type CompactSum0KES d   = CompactSingleKES d
@@ -461,3 +467,52 @@ 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) =
+    unpackByteStringCStringLen (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)
+    fptr <- mallocForeignPtrBytes len
+    withForeignPtr fptr $ \ptr -> do
+      pull (castPtr ptr) len
+    let bs = BS.fromForeignPtr (unsafeRawForeignPtr fptr) 0 len
+    maybe (error "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.Internal as BS
+import Foreign.Ptr (castPtr)
 
 import Control.Exception (assert)
 
@@ -35,8 +37,15 @@ import Cardano.Crypto.KES.Class
 import Cardano.Crypto.Util
 import Cardano.Crypto.Libsodium.MLockedSeed
 import Cardano.Crypto.Libsodium
-  ( mlsbAsByteString
+  ( mlsbToByteString
   )
+import Cardano.Crypto.Libsodium.Memory
+  ( unpackByteStringCStringLen
+  , ForeignPtr (..)
+  , mallocForeignPtrBytes
+  , withForeignPtr
+  )
+import Cardano.Crypto.DirectSerialise
 
 data MockKES (t :: Nat)
 
@@ -151,7 +160,8 @@ instance KnownNat t => KESAlgorithm (MockKES t) where
     --
 
     genKeyKESWith _allocator seed = do
-        let vk = VerKeyMockKES (runMonadRandomWithSeed (mkSeedFromBytes . mlsbAsByteString . mlockedSeedMLSB $ seed) getRandomWord64)
+        seedBS <- mlsbToByteString . mlockedSeedMLSB $ seed
+        let vk = VerKeyMockKES (runMonadRandomWithSeed (mkSeedFromBytes seedBS) getRandomWord64)
         return $! SignKeyMockKES vk 0
 
     forgetSignKeyKESWith _ = const $ return ()
@@ -194,3 +204,33 @@ instance KnownNat t => ToCBOR (SigKES (MockKES t)) where
 
 instance KnownNat t => FromCBOR (SigKES (MockKES t)) where
   fromCBOR = decodeSigKES
+
+instance (KnownNat t) => DirectSerialise (SignKeyKES (MockKES t)) where
+  directSerialise put sk = do
+    let bs = rawSerialiseSignKeyMockKES sk
+    unpackByteStringCStringLen 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))
+    fptr <- mallocForeignPtrBytes len
+    withForeignPtr fptr $ \ptr ->
+        pull (castPtr ptr) (fromIntegral len)
+    let bs = BS.fromForeignPtr (unsafeRawForeignPtr fptr) 0 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
+    unpackByteStringCStringLen 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))
+    fptr <- mallocForeignPtrBytes len
+    withForeignPtr fptr $ \ptr ->
+        pull (castPtr ptr) (fromIntegral len)
+    let bs = BS.fromForeignPtr (unsafeRawForeignPtr fptr) 0 len
+    maybe (error "directDeserialise @(VerKeyKES (MockKES t))") return $
+        rawDeserialiseVerKeyKES bs

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

@@ -43,6 +43,7 @@ import           Cardano.Crypto.KES.Class
 import           Cardano.Crypto.Libsodium.MLockedSeed
 import           Cardano.Crypto.Libsodium.MLockedBytes
 import           Cardano.Crypto.Util
+import           Cardano.Crypto.DirectSerialise
 import           Data.Unit.Strict (forceElemsToWHNF)
 
 data SimpleKES d (t :: Nat)
@@ -249,3 +250,22 @@ instance (DSIGNMAlgorithm d
       => FromCBOR (SigKES (SimpleKES d t)) where
   fromCBOR = decodeSigKES
 
+instance (DirectSerialise (VerKeyDSIGN d)) => DirectSerialise (VerKeyKES (SimpleKES d t)) where
+  directSerialise push (VerKeySimpleKES vks) =
+    mapM_ (directSerialise push) vks
+
+instance (DirectDeserialise (VerKeyDSIGN 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

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

@@ -50,7 +50,7 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Crypto.Hash.Class
 import Cardano.Crypto.DSIGN.Class as DSIGN
 import Cardano.Crypto.KES.Class
-
+import Cardano.Crypto.DirectSerialise
 
 -- | A standard signature scheme is a forward-secure signature scheme with a
 -- single time period.
@@ -187,4 +187,19 @@ instance DSIGNMAlgorithm d => ToCBOR (SigKES (SingleKES d)) where
 
 instance DSIGNMAlgorithm d => FromCBOR (SigKES (SingleKES d)) where
   fromCBOR = decodeSigKES
-  {-# INLINE fromCBOR #-}
+
+--
+-- 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 (VerKeyDSIGN d)) => DirectSerialise (VerKeyKES (SingleKES d)) where
+  directSerialise push (VerKeySingleKES sk) = directSerialise push sk
+
+instance (DirectDeserialise (VerKeyDSIGN d)) => DirectDeserialise (VerKeyKES (SingleKES d)) where
+  directDeserialise pull = VerKeySingleKES <$!> directDeserialise pull