diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index 8a53bc0c6f..ea5698049f 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/cardano-crypto-class/cardano-crypto-class.cabal @@ -56,6 +56,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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs index b9479ecce1..c334d85a7a 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs +++ b/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 qualified Data.ByteString.Unsafe as BS import Data.Proxy -import Control.Exception (evaluate) +import Control.Exception (evaluate, bracket) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) @@ -44,6 +44,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 @@ -203,6 +204,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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/DirectSerialise.hs b/cardano-crypto-class/src/Cardano/Crypto/DirectSerialise.hs new file mode 100644 index 0000000000..fdd8346fbc --- /dev/null +++ b/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 () diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs index 659d685024..b43b727e9d 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs +++ b/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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs index 0daa1872e7..7ad89c56ba 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs +++ b/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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs index 3e60f6c18d..4e92638be1 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs +++ b/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 deriveVerKeyKES (SignKeySingleKES v) = @@ -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 (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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs index 6b37bfe853..90847e72b4 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs +++ b/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