Direct(De-)Serialize API

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

@@ -51,6 +51,7 @@ library
     Cardano.Crypto.DSIGN.NeverUsed
     Cardano.Crypto.EllipticCurve.BLS12_381
     Cardano.Crypto.EllipticCurve.BLS12_381.Internal
+    Cardano.Crypto.DirectSerialise
     Cardano.Crypto.Hash
     Cardano.Crypto.Hash.Blake2b
     Cardano.Crypto.Hash.Class

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

@@ -56,11 +56,13 @@ import Cardano.Crypto.MonadMLock
   , psbToByteString
   , psbFromByteStringCheck
   , psbCreateSizedResult
+  , psbCreate
   )
 
 import Cardano.Crypto.DSIGNM.Class
 import Cardano.Crypto.MLockedSeed
 import Cardano.Crypto.Util (SignableRepresentation(..))
+import Cardano.Crypto.DirectSerialise
 
 data Ed25519DSIGNM
 
@@ -282,6 +284,62 @@ instance (MonadST m, MonadMLock m, MonadPSB m, MonadThrow m) => UnsoundDSIGNMAlg
           mlockedSeedFinalize seed
           return sk
 
+instance ( MonadThrow m
+         , MonadST m
+         , MonadMLock m
+         , MonadPSB m
+         ) => DirectSerialise m (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 ( MonadThrow m
+         , MonadST m
+         , MonadPSB m
+         , MonadMLock m
+         ) => DirectDeserialise m (SignKeyDSIGNM Ed25519DSIGNM) where
+  -- /Note:/ We only serialize the 32-byte seed, not the full 64-byte key. See
+  -- the DirectSerialise m instance above.
+  directDeserialise pull = do
+    bracket
+      mlockedSeedNew
+      mlockedSeedFinalize
+      (\seed -> do
+          mlockedSeedUseAsCPtr seed $ \ptr -> do
+            pull
+              (castPtr ptr)
+              (fromIntegral $ seedSizeDSIGNM (Proxy @Ed25519DSIGNM))
+          genKeyDSIGNM seed
+      )
+
+instance ( MonadPSB m
+         ) => DirectSerialise m (VerKeyDSIGNM Ed25519DSIGNM) where
+  directSerialise push (VerKeyEd25519DSIGNM psb) = do
+    psbUseAsCPtrLen psb $ \ptr _ ->
+      push
+        (castPtr ptr)
+        (fromIntegral $ sizeVerKeyDSIGNM (Proxy @Ed25519DSIGNM))
+
+instance ( MonadThrow m
+         , MonadPSB m
+         ) => DirectDeserialise m (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,41 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-- | 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 m a where
+  directDeserialise :: (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 m a where
+  directSerialise :: (Ptr CChar -> CSize -> m ()) -> a -> m ()

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

@@ -60,6 +60,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
@@ -230,3 +231,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 m (SignKeyDSIGNM d)) => DirectSerialise m (SignKeyKES (CompactSingleKES d)) where
+  directSerialise push (SignKeyCompactSingleKES sk) = directSerialise push sk
+
+instance (Monad m, DirectDeserialise m (SignKeyDSIGNM d)) => DirectDeserialise m (SignKeyKES (CompactSingleKES d)) where
+  directDeserialise pull = SignKeyCompactSingleKES <$!> directDeserialise pull
+
+instance (DirectSerialise m (VerKeyDSIGNM d)) => DirectSerialise m (VerKeyKES (CompactSingleKES d)) where
+  directSerialise push (VerKeyCompactSingleKES sk) = directSerialise push sk
+
+instance (Monad m, DirectDeserialise m (VerKeyDSIGNM d)) => DirectDeserialise m (VerKeyKES (CompactSingleKES d)) where
+  directDeserialise pull = VerKeyCompactSingleKES <$!> directDeserialise pull

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

@@ -88,8 +88,9 @@ 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           Cardano.Binary (FromCBOR (..), ToCBOR (..))
 
@@ -105,6 +106,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 +481,51 @@ instance ( OptimizedKESAlgorithm d
          )
       => FromCBOR (SigKES (CompactSumKES h d)) where
   fromCBOR = decodeSigKES
+
+--
+-- Direct ser/deser
+--
+
+instance ( DirectSerialise m (SignKeyKES d)
+         , DirectSerialise m (VerKeyKES d)
+         , MonadMLock m
+         , KESAlgorithm d
+         ) => DirectSerialise m (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 m (SignKeyKES d)
+         , DirectDeserialise m (VerKeyKES d)
+         , MonadMLock m
+         , KESAlgorithm d
+         ) => DirectDeserialise m (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 MonadByteStringMemory m => DirectSerialise m (VerKeyKES (CompactSumKES h d)) where
+  directSerialise push (VerKeyCompactSumKES h) = do
+    useByteStringAsCStringLen (hashToBytes h) $ \(ptr, len) ->
+      push (castPtr ptr) (fromIntegral len)
+
+instance (MonadMLock m, MonadST m, MonadFail m, HashAlgorithm h) => DirectDeserialise m (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 <- packByteStringCStringLen (ptr, len)
+      maybe (fail "Invalid hash") return $! VerKeyCompactSumKES <$!> hashFromBytes bs

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

@@ -24,6 +24,7 @@ import Data.Proxy (Proxy(..))
 import GHC.Generics (Generic)
 import GHC.TypeNats (Nat, KnownNat, natVal)
 import NoThunks.Class (NoThunks)
+import Control.Monad.Class.MonadST (MonadST)
 
 import Control.Exception (assert)
 
@@ -36,7 +37,13 @@ import Cardano.Crypto.Util
 import Cardano.Crypto.MLockedSeed
 import Cardano.Crypto.MonadMLock
   ( mlsbAsByteString
+  , MonadByteStringMemory
+  , MonadMLock
+  , packByteStringCStringLen
+  , useByteStringAsCStringLen
+  , allocaBytes
   )
+import Cardano.Crypto.DirectSerialise
 
 data MockKES (t :: Nat)
 
@@ -181,6 +188,34 @@ rawSerialiseSignKeyMockKES (SignKeyMockKES vk t) =
     rawSerialiseVerKeyKES vk
  <> writeBinaryWord64 (fromIntegral t)
 
+instance (MonadByteStringMemory m, KnownNat t) => DirectSerialise m (SignKeyKES (MockKES t)) where
+  directSerialise put sk = do
+    let bs = rawSerialiseSignKeyMockKES sk
+    useByteStringAsCStringLen bs $ \(cstr, len) -> put cstr (fromIntegral len)
+
+instance (MonadMLock m, MonadST m, KnownNat t) => DirectDeserialise m (SignKeyKES (MockKES t)) where
+  directDeserialise pull = do
+    let len = fromIntegral $ sizeSignKeyKES (Proxy @(MockKES t))
+    bs <- allocaBytes len $ \cstr -> do
+        pull cstr (fromIntegral len)
+        packByteStringCStringLen (cstr, len)
+    maybe (error "directDeserialise @(SignKeyKES (MockKES t))") return $
+        rawDeserialiseSignKeyMockKES bs
+
+instance (MonadByteStringMemory m, KnownNat t) => DirectSerialise m (VerKeyKES (MockKES t)) where
+  directSerialise put sk = do
+    let bs = rawSerialiseVerKeyKES sk
+    useByteStringAsCStringLen bs $ \(cstr, len) -> put cstr (fromIntegral len)
+
+instance (MonadMLock m, MonadST m, KnownNat t) => DirectDeserialise m (VerKeyKES (MockKES t)) where
+  directDeserialise pull = do
+    let len = fromIntegral $ sizeVerKeyKES (Proxy @(MockKES t))
+    bs <- allocaBytes len $ \cstr -> do
+        pull cstr (fromIntegral len)
+        packByteStringCStringLen (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

@@ -39,6 +39,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.MonadMLock (MonadMLock (..), MEq (..))
 
@@ -187,7 +188,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
     --
@@ -210,6 +210,26 @@ instance ( UnsoundDSIGNMAlgorithm m d, KnownNat t, KESSignAlgorithm m (SimpleKES
       | otherwise
       = return Nothing
 
+instance (Monad m, DirectSerialise m (VerKeyDSIGNM d)) => DirectSerialise m (VerKeyKES (SimpleKES d t)) where
+  directSerialise push (VerKeySimpleKES vks) =
+    mapM_ (directSerialise push) vks
+
+instance (Monad m, DirectDeserialise m (VerKeyDSIGNM d), KnownNat t) => DirectDeserialise m (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 (Monad m, DirectSerialise m (SignKeyDSIGNM d)) => DirectSerialise m (SignKeyKES (SimpleKES d t)) where
+  directSerialise push (SignKeySimpleKES sks) =
+    mapM_ (directSerialise push) sks
+
+instance (Monad m, DirectDeserialise m (SignKeyDSIGNM d), KnownNat t) => DirectDeserialise m (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

@@ -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
@@ -108,7 +109,6 @@ instance (DSIGNMAlgorithmBase d) => KESAlgorithm (SingleKES d) where
     rawDeserialiseVerKeyKES  = fmap VerKeySingleKES  . rawDeserialiseVerKeyDSIGNM
     rawDeserialiseSigKES     = fmap SigSingleKES     . rawDeserialiseSigDSIGNM
 
-
 instance ( DSIGNMAlgorithm m d -- needed for secure forgetting
          ) => KESSignAlgorithm m (SingleKES d) where
     newtype SignKeyKES (SingleKES d) = SignKeySingleKES (SignKeyDSIGNM d)
@@ -184,3 +184,19 @@ instance DSIGNMAlgorithmBase d => ToCBOR (SigKES (SingleKES d)) where
 
 instance DSIGNMAlgorithmBase d => FromCBOR (SigKES (SingleKES d)) where
   fromCBOR = decodeSigKES
+
+--
+-- Direct ser/deser
+--
+
+instance (DirectSerialise m (SignKeyDSIGNM d)) => DirectSerialise m (SignKeyKES (SingleKES d)) where
+  directSerialise push (SignKeySingleKES sk) = directSerialise push sk
+
+instance (Monad m, DirectDeserialise m (SignKeyDSIGNM d)) => DirectDeserialise m (SignKeyKES (SingleKES d)) where
+  directDeserialise pull = SignKeySingleKES <$!> directDeserialise pull
+
+instance (DirectSerialise m (VerKeyDSIGNM d)) => DirectSerialise m (VerKeyKES (SingleKES d)) where
+  directSerialise push (VerKeySingleKES sk) = directSerialise push sk
+
+instance (Monad m, DirectDeserialise m (VerKeyDSIGNM d)) => DirectDeserialise m (VerKeyKES (SingleKES d)) where
+  directDeserialise pull = VerKeySingleKES <$!> directDeserialise pull