Direct serialisation from/to raw memory

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

@@ -43,6 +43,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
 
@@ -201,6 +202,39 @@ instance DSIGNMAlgorithm IO Ed25519DSIGNM where
           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/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

@@ -87,6 +87,8 @@ import           Control.Monad.Trans (lift)
 import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
 import           Control.DeepSeq (NFData)
 import           NoThunks.Class (NoThunks)
+import           Foreign.Ptr (castPtr)
+import           Foreign.Marshal.Alloc (allocaBytes)
 
 import           Cardano.Binary (FromCBOR (..), ToCBOR (..))
 
@@ -96,6 +98,7 @@ import           Cardano.Crypto.KES.CompactSingle (CompactSingleKES)
 import qualified Cardano.Crypto.MonadSodium as NaCl
 
 import           Cardano.Crypto.Util
+import           Cardano.Crypto.DirectSerialise
 
 -- | A 2^0 period KES
 type CompactSum0KES d   = CompactSingleKES d
@@ -464,3 +467,53 @@ instance ( OptimizedKESAlgorithm d
          )
       => FromCBOR (SigKES (CompactSumKES h d)) where
   fromCBOR = decodeSigKES
+
+--
+-- Direct ser/deser
+--
+
+instance ( DirectSerialise (SignKeyKES d)
+         , DirectSerialise (VerKeyKES d)
+         , KESAlgorithm d
+         , KnownNat (SeedSizeKES d)
+         ) => DirectSerialise (SignKeyKES (CompactSumKES h d)) where
+  directSerialise push (SignKeyCompactSumKES sk r vk0 vk1) = do
+    directSerialise push sk
+    NaCl.interactSafePinned r $ \mlsb ->
+      NaCl.mlsbUseAsCPtr mlsb $ \ptr ->
+        push (castPtr ptr) (fromIntegral $ seedSizeKES (Proxy :: Proxy d))
+    directSerialise push vk0
+    directSerialise push vk1
+
+instance ( DirectDeserialise (SignKeyKES d)
+         , DirectDeserialise (VerKeyKES d)
+         , KESAlgorithm d
+         , KnownNat (SeedSizeKES d)
+         ) => DirectDeserialise (SignKeyKES (CompactSumKES h d)) where
+  directDeserialise pull = do
+    sk <- directDeserialise pull
+
+    mlsb <- NaCl.mlsbNew
+    NaCl.mlsbUseAsCPtr mlsb $ \ptr ->
+      pull (castPtr ptr) (fromIntegral $ seedSizeKES (Proxy :: Proxy d))
+    r <- NaCl.makeSafePinned mlsb
+
+    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/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
@@ -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
@@ -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

@@ -57,11 +57,14 @@ import           Cardano.Crypto.Hash.Class
 import           Cardano.Crypto.KES.Class
 import           Cardano.Crypto.KES.Single (SingleKES)
 import           Cardano.Crypto.Util
+import           Cardano.Crypto.DirectSerialise
 
 import qualified Cardano.Crypto.MonadSodium as NaCl
 import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
 import Control.DeepSeq (NFData)
 
+import Foreign.Ptr (castPtr)
+import Foreign.Marshal.Alloc
 import GHC.TypeLits (KnownNat, type (+), type (*))
 
 -- | A 2^0 period KES
@@ -372,3 +375,52 @@ 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
+         , KnownNat (SeedSizeKES d)
+         ) => DirectSerialise (SignKeyKES (SumKES h d)) where
+  directSerialise push (SignKeySumKES sk r vk0 vk1) = do
+    directSerialise push sk
+    NaCl.interactSafePinned r $ \mlsb ->
+      NaCl.mlsbUseAsCPtr mlsb $ \ptr ->
+        push (castPtr ptr) (fromIntegral $ seedSizeKES (Proxy :: Proxy d))
+    directSerialise push vk0
+    directSerialise push vk1
+
+instance ( DirectDeserialise (SignKeyKES d)
+         , DirectDeserialise (VerKeyKES d)
+         , KESAlgorithm d
+         , KnownNat (SeedSizeKES d)
+         ) => DirectDeserialise (SignKeyKES (SumKES h d)) where
+  directDeserialise pull = do
+    sk <- directDeserialise pull
+
+    mlsb <- NaCl.mlsbNew
+    NaCl.mlsbUseAsCPtr mlsb $ \ptr ->
+      pull (castPtr ptr) (fromIntegral $ seedSizeKES (Proxy :: Proxy d))
+    r <- NaCl.makeSafePinned mlsb
+
+    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