From 3e9645495621262575df41625785d8644a64b54d Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 18 Apr 2023 13:58:53 +0200 Subject: [PATCH] Direct(De-)Serialize API --- .../cardano-crypto-class.cabal | 1 + .../src/Cardano/Crypto/DSIGN/Ed25519ML.hs | 58 +++++++ .../src/Cardano/Crypto/DirectSerialise.hs | 41 +++++ .../src/Cardano/Crypto/KES/CompactSingle.hs | 17 +++ .../src/Cardano/Crypto/KES/CompactSum.hs | 52 ++++++- .../src/Cardano/Crypto/KES/Mock.hs | 35 +++++ .../src/Cardano/Crypto/KES/Simple.hs | 22 ++- .../src/Cardano/Crypto/KES/Single.hs | 18 ++- .../src/Cardano/Crypto/KES/Sum.hs | 55 +++++++ .../src/Test/Crypto/AllocLog.hs | 2 +- cardano-crypto-tests/src/Test/Crypto/DSIGN.hs | 58 ++++++- cardano-crypto-tests/src/Test/Crypto/KES.hs | 141 +++++++++++++++++- cardano-crypto-tests/src/Test/Crypto/Util.hs | 57 +++++++ 13 files changed, 546 insertions(+), 11 deletions(-) create mode 100644 cardano-crypto-class/src/Cardano/Crypto/DirectSerialise.hs diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index a0a2490885..a602e4ce84 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs index 28680be42e..a2e80c3467 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs +++ b/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 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..d879778ae9 --- /dev/null +++ b/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 () diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs index 2a58a480be..f7280fecdd 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs +++ b/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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs index 8fa67071e7..acec7b69f1 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs +++ b/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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs index 0ab6bda6b4..64cb94c08e 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs +++ b/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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs index 3072632686..01bf32022c 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs +++ b/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)) diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs index e1777ff76b..3b9215ae69 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 @@ -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 diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs index fa9669a4a6..9f4c411daa 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs @@ -56,6 +56,7 @@ import GHC.Generics (Generic) import qualified Data.ByteString as BS import Control.Monad (guard, (<$!>)) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) +import Control.Monad.ST.Unsafe (unsafeIOToST) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) @@ -70,7 +71,9 @@ import Control.Monad.Class.MonadThrow (MonadThrow) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.DeepSeq (NFData (..)) import GHC.TypeLits (KnownNat, type (+), type (*)) +import Cardano.Crypto.DirectSerialise +import Foreign.Ptr (castPtr) -- | A 2^0 period KES type Sum0KES d = SingleKES d @@ -394,3 +397,55 @@ instance (KESAlgorithm (SumKES h d), SodiumHashAlgorithm h, SizeHash h ~ SeedSiz instance (KESAlgorithm (SumKES h d), SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) => FromCBOR (SigKES (SumKES h d)) where fromCBOR = decodeSigKES + +-- +-- Direct ser/deser +-- + +instance ( DirectSerialise m (SignKeyKES d) + , DirectSerialise m (VerKeyKES d) + , MonadMLock m + , KESAlgorithm d + ) => DirectSerialise m (SignKeyKES (SumKES h d)) where + directSerialise push (SignKeySumKES 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 (SumKES 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 $! SignKeySumKES sk r vk0 vk1 + +instance ( MonadByteStringMemory m + ) => DirectSerialise m (VerKeyKES (SumKES h d)) where + directSerialise push (VerKeySumKES h) = do + useByteStringAsCStringLen (hashToBytes h) $ \(ptr, len) -> + push (castPtr ptr) (fromIntegral len) + +instance ( HashAlgorithm h + , MonadMLock m + , MonadFail m + , MonadST m + ) => DirectDeserialise m (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 <- withLiftST $ \lift -> lift . unsafeIOToST $ BS.packCStringLen (ptr, len) + maybe (fail "Invalid hash") return $! VerKeySumKES <$!> hashFromBytes bs diff --git a/cardano-crypto-tests/src/Test/Crypto/AllocLog.hs b/cardano-crypto-tests/src/Test/Crypto/AllocLog.hs index b452bfa7ae..d34d7d6cac 100644 --- a/cardano-crypto-tests/src/Test/Crypto/AllocLog.hs +++ b/cardano-crypto-tests/src/Test/Crypto/AllocLog.hs @@ -101,7 +101,7 @@ instance (MonadIO m, MonadPSB m) psbCreateResultLen action = LogT $ do tracer <- ask lift $ psbCreateResultLen (\ptr len -> (runReaderT . unLogT) (action ptr len) tracer) - + -- | Newtype wrapper over an arbitrary event; we use this to write the generic -- 'MonadMLock' instance below while avoiding overlapping instances. diff --git a/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs b/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs index 358490d407..4ccc567efc 100644 --- a/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs +++ b/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs @@ -28,11 +28,12 @@ import Test.QuickCheck ( ioProperty, ) import Test.Tasty (TestTree, testGroup, adjustOption) -import Test.Tasty.QuickCheck (testProperty, QuickCheckTests) +import Test.Tasty.QuickCheck (testProperty, QuickCheckTests, counterexample) import qualified Data.ByteString as BS import qualified Cardano.Crypto.Libsodium as NaCl import Cardano.Crypto.MonadMLock (MEq (..), (==!)) +import Cardano.Crypto.DirectSerialise (DirectSerialise, DirectDeserialise) import Text.Show.Pretty (ppShow) @@ -131,6 +132,9 @@ import Test.Crypto.Util ( showBadInputFor, Lock, withLock, + hexBS, + directSerialiseToBS, + directDeserialiseFromBS, ) import Test.Crypto.Instances (withMLockedSeedFromPSB) import Cardano.Crypto.MLockedSeed @@ -376,6 +380,10 @@ testDSIGNMAlgorithm , FromCBOR (SigDSIGNM v) , ContextDSIGNM v ~ () , SignableM v Message + , DirectSerialise IO (SignKeyDSIGNM v) + , DirectDeserialise IO (SignKeyDSIGNM v) + , DirectSerialise IO (VerKeyDSIGNM v) + , DirectDeserialise IO (VerKeyDSIGNM v) ) => Lock -> Proxy v @@ -401,6 +409,36 @@ testDSIGNMAlgorithm lock _ n = sig <- signDSIGNM () msg sk return $ (rawDeserialiseSigDSIGNM . rawSerialiseSigDSIGNM $ sig) === Just sig ] + , testGroup "DirectSerialise" + [ testProperty "VerKey" $ + ioPropertyWithSK @v lock $ \sk -> do + vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk + serialized <- directSerialiseToBS (fromIntegral $ sizeVerKeyDSIGNM (Proxy @v)) vk + vk' <- directDeserialiseFromBS serialized + return $ vk === vk' + , testProperty "SignKey" $ + ioPropertyWithSK @v lock $ \sk -> do + serialized <- directSerialiseToBS (fromIntegral $ sizeSignKeyDSIGNM (Proxy @v)) sk + sk' <- directDeserialiseFromBS serialized + equals <- sk ==! sk' + forgetSignKeyDSIGNM sk' + return $ + counterexample ("Serialized: " ++ hexBS serialized ++ " (length: " ++ show (BS.length serialized) ++ ")") $ + equals + ] + , testGroup "DirectSerialise matches raw" + [ testProperty "VerKey" $ + ioPropertyWithSK @v lock $ \sk -> do + vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk + direct <- directSerialiseToBS (fromIntegral $ sizeVerKeyDSIGNM (Proxy @v)) vk + let raw = rawSerialiseVerKeyDSIGNM vk + return $ direct === raw + , testProperty "SignKey" $ + ioPropertyWithSK @v lock $ \sk -> do + direct <- directSerialiseToBS (fromIntegral $ sizeSignKeyDSIGNM (Proxy @v)) sk + raw <- rawSerialiseSignKeyDSIGNM sk + return $ direct === raw + ] , testGroup "size" [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> do @@ -491,6 +529,24 @@ testDSIGNMAlgorithm lock _ n = ioPropertyWithSK @v lock $ prop_no_thunks_IO . return , testProperty "Sig" $ \(msg :: Message) -> ioPropertyWithSK @v lock $ prop_no_thunks_IO . signDSIGNM () msg + , testProperty "SignKey DirectSerialise" $ + ioPropertyWithSK @v lock $ \sk -> do + direct <- directSerialiseToBS (fromIntegral $ sizeSignKeyDSIGNM (Proxy @v)) sk + prop_no_thunks_IO (return $! direct) + , testProperty "SignKey DirectDeserialise" $ + ioPropertyWithSK @v lock $ \sk -> do + direct <- directSerialiseToBS (fromIntegral $ sizeSignKeyDSIGNM (Proxy @v)) sk + prop_no_thunks_IO (directDeserialiseFromBS @IO @(SignKeyDSIGNM v) $! direct) + , testProperty "VerKey DirectSerialise" $ + ioPropertyWithSK @v lock $ \sk -> do + vk <- deriveVerKeyDSIGNM sk + direct <- directSerialiseToBS (fromIntegral $ sizeVerKeyDSIGNM (Proxy @v)) vk + prop_no_thunks_IO (return $! direct) + , testProperty "VerKey DirectDeserialise" $ + ioPropertyWithSK @v lock $ \sk -> do + vk <- deriveVerKeyDSIGNM sk + direct <- directSerialiseToBS (fromIntegral $ sizeVerKeyDSIGNM (Proxy @v)) vk + prop_no_thunks_IO (directDeserialiseFromBS @IO @(VerKeyDSIGNM v) $! direct) ] ] diff --git a/cardano-crypto-tests/src/Test/Crypto/KES.hs b/cardano-crypto-tests/src/Test/Crypto/KES.hs index 7ab96ff9b8..b8cd9fb09c 100644 --- a/cardano-crypto-tests/src/Test/Crypto/KES.hs +++ b/cardano-crypto-tests/src/Test/Crypto/KES.hs @@ -27,21 +27,23 @@ import Data.List (foldl') import qualified Data.ByteString as BS import Data.Set (Set) import qualified Data.Set as Set -import Foreign.Ptr (WordPtr) +import Foreign.Ptr (WordPtr, plusPtr) import Data.IORef import Data.Foldable (traverse_) -import GHC.TypeNats (KnownNat) +import GHC.TypeNats (KnownNat, natVal) import Control.Tracer import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadMVar (newMVar, takeMVar, putMVar) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad (void) +import Control.Monad (void, when) import Cardano.Crypto.DSIGN hiding (Signable) import Cardano.Crypto.Hash import Cardano.Crypto.KES import Cardano.Crypto.KES.ForgetMock +import Cardano.Crypto.DirectSerialise (DirectSerialise, directSerialise, DirectDeserialise) import Cardano.Crypto.Util (SignableRepresentation(..)) import Cardano.Crypto.MLockedSeed import qualified Cardano.Crypto.Libsodium as NaCl @@ -68,6 +70,8 @@ import Test.Crypto.Util ( noExceptionsThrown, Lock, withLock, + directSerialiseToBS, + directDeserialiseFromBS, ) import Test.Crypto.RunIO (RunIO (..)) import Test.Crypto.Instances (withMLockedSeedFromPSB) @@ -259,6 +263,10 @@ testKESAlgorithm , KESSignAlgorithm m v -- , KESSignAlgorithm IO v -- redundant for now , UnsoundKESSignAlgorithm IO v + , DirectSerialise IO (SignKeyKES v) + , DirectSerialise IO (VerKeyKES v) + , DirectDeserialise IO (SignKeyKES v) + , DirectDeserialise IO (VerKeyKES v) ) => Lock -> Proxy m @@ -288,9 +296,34 @@ testKESAlgorithm lock _pm _pv n = , testProperty "Sig" $ \seedPSB (msg :: Message) -> ioProperty $ withLock lock $ fmap conjoin $ withAllUpdatesKES @IO @v seedPSB $ \t sk -> do prop_no_thunks_IO (signKES () t msg sk) + + , testProperty "VerKey DirectSerialise" $ + ioPropertyWithSK @v lock $ \sk -> do + vk :: VerKeyKES v <- deriveVerKeyKES sk + direct <- directSerialiseToBS (fromIntegral $ sizeVerKeyKES (Proxy @v)) vk + prop_no_thunks_IO (return $! direct) + , testProperty "SignKey DirectSerialise" $ + ioPropertyWithSK @v lock $ \sk -> do + direct <- directSerialiseToBS (fromIntegral $ sizeSignKeyKES (Proxy @v)) sk + prop_no_thunks_IO (return $! direct) + , testProperty "VerKey DirectDeserialise" $ + ioPropertyWithSK @v lock $ \sk -> do + vk :: VerKeyKES v <- deriveVerKeyKES sk + direct <- directSerialiseToBS (fromIntegral $ sizeVerKeyKES (Proxy @v)) $! vk + prop_no_thunks_IO (directDeserialiseFromBS @IO @(VerKeyKES v) $! direct) + , testProperty "SignKey DirectDeserialise" $ + ioPropertyWithSK @v lock $ \sk -> do + direct <- directSerialiseToBS (fromIntegral $ sizeSignKeyKES (Proxy @v)) sk + bracket + (directDeserialiseFromBS @IO @(SignKeyKES v) $! direct) + forgetSignKeyKES + (prop_no_thunks_IO . return) ] , testProperty "same VerKey " $ prop_deriveVerKeyKES (Proxy @IO) (Proxy @v) + , testProperty "no forgotten chunks in signkey" $ prop_noErasedBlocksInKey (Proxy @v) + + , testGroup "serialisation" [ testGroup "raw ser only" @@ -301,12 +334,24 @@ testKESAlgorithm lock _pm _pv n = , testProperty "SignKey" $ ioPropertyWithSK @v lock $ \sk -> do serialized <- rawSerialiseSignKeyKES sk - equals <- bracket + (equals, skSer, msk'Ser) <- bracket (rawDeserialiseSignKeyKES serialized) (maybe (return ()) forgetSignKeyKES) - (\msk' -> Just sk ==! msk') + (\(msk' :: Maybe (SignKeyKES v)) -> do + skSer <- directSerialiseToBS (fromIntegral $ sizeSignKeyKES (Proxy @v)) sk + msk'Ser <- mapM (directSerialiseToBS (fromIntegral $ sizeSignKeyKES (Proxy @v))) msk' + equals <- Just sk ==! msk' + return + ( equals + , skSer + , msk'Ser + ) + ) return $ - counterexample (show serialized) equals + counterexample (show serialized) $ + counterexample (show skSer) $ + counterexample (show msk'Ser) $ + equals , testProperty "Sig" $ \(msg :: Message) -> ioPropertyWithSK @v lock $ \sk -> do sig :: SigKES v <- signKES () 0 msg sk @@ -376,6 +421,37 @@ testKESAlgorithm lock _pm _pv n = sig :: SigKES v <- signKES () 0 msg sk return $ prop_cbor_direct_vs_class encodeSigKES sig ] + , testGroup "DirectSerialise" + [ testProperty "VerKey" $ + ioPropertyWithSK @v lock $ \sk -> do + vk :: VerKeyKES v <- deriveVerKeyKES sk + serialized <- directSerialiseToBS (fromIntegral $ sizeVerKeyKES (Proxy @v)) vk + vk' <- directDeserialiseFromBS serialized + return $ vk === vk' + , testProperty "SignKey" $ + ioPropertyWithSK @v lock $ \sk -> do + serialized <- directSerialiseToBS (fromIntegral $ sizeSignKeyKES (Proxy @v)) sk + equals <- bracket + (directDeserialiseFromBS serialized) + forgetSignKeyKES + (\sk' -> sk ==! sk') + return $ + counterexample ("Serialized: " ++ hexBS serialized ++ " (length: " ++ show (BS.length serialized) ++ ")") $ + equals + ] + , testGroup "DirectSerialise matches raw" + [ testProperty "VerKey" $ + ioPropertyWithSK @v lock $ \sk -> do + vk :: VerKeyKES v <- deriveVerKeyKES sk + direct <- directSerialiseToBS (fromIntegral $ sizeVerKeyKES (Proxy @v)) vk + let raw = rawSerialiseVerKeyKES vk + return $ direct === raw + , testProperty "SignKey" $ + ioPropertyWithSK @v lock $ \sk -> do + direct <- directSerialiseToBS (fromIntegral $ sizeSignKeyKES (Proxy @v)) sk + raw <- rawSerialiseSignKeyKES sk + return $ direct === raw + ] ] , testGroup "verify" @@ -453,6 +529,59 @@ ioPropertyWithSK lock action seedPSB = -- -- return (before =/= after) +withNullSeed :: forall m n a. (MonadThrow m, MonadMLock m, MonadST m, KnownNat n) => (MLockedSeed n -> m a) -> m a +withNullSeed = bracket + (MLockedSeed <$> mlsbFromByteString (BS.replicate (fromIntegral $ natVal (Proxy @n)) 0)) + mlockedSeedFinalize + +withNullSK :: forall m v a. (KESSignAlgorithm m v, MonadThrow m, MonadMLock m, MonadST m) + => (SignKeyKES v -> m a) -> m a +withNullSK = bracket + (withNullSeed genKeyKES) + forgetSignKeyKES + + +-- | This test detects whether a sign key contains references to pool-allocated +-- blocks of memory that have been forgotten by the time the key is complete. +-- We do this based on the fact that the pooled allocator erases memory blocks +-- by overwriting them with series of 0xff bytes; thus we cut the serialized +-- key up into chunks of 16 bytes, and if any of those chunks is entirely +-- filled with 0xff bytes, we assume that we're looking at erased memory. +prop_noErasedBlocksInKey + :: forall v. + UnsoundKESSignAlgorithm IO v + => DirectSerialise IO (SignKeyKES v) + => Proxy v + -> Property +prop_noErasedBlocksInKey kesAlgorithm = + ioProperty . withNullSK @IO @v $ \sk -> do + let size :: Int = fromIntegral $ sizeSignKeyKES kesAlgorithm + serialized <- allocaBytes size $ \ptr -> do + positionVar <- newMVar (0 :: Int) + directSerialise (\buf nCSize -> do + let n = fromIntegral nCSize :: Int + bracket + (takeMVar positionVar) + (putMVar positionVar . (+ n)) + (\position -> do + when (n + position > size) (error "Buffer size exceeded") + copyMem (plusPtr ptr position) buf (fromIntegral n) + ) + ) + sk + packByteStringCStringLen (ptr, size) + forgetSignKeyKES sk + return $ counterexample (hexBS serialized) $ not (hasLongRunOfFF serialized) + +hasLongRunOfFF :: ByteString -> Bool +hasLongRunOfFF bs + | BS.length bs < 16 + = False + | otherwise + = let first16 = BS.take 16 bs + remainder = BS.drop 16 bs + in (BS.all (== 0xFF) first16) || hasLongRunOfFF remainder + prop_onlyGenSignKeyKES :: forall v. KESSignAlgorithm IO v diff --git a/cardano-crypto-tests/src/Test/Crypto/Util.hs b/cardano-crypto-tests/src/Test/Crypto/Util.hs index d28600b38d..922b93c831 100644 --- a/cardano-crypto-tests/src/Test/Crypto/Util.hs +++ b/cardano-crypto-tests/src/Test/Crypto/Util.hs @@ -63,6 +63,10 @@ module Test.Crypto.Util , Lock , withLock , mkLock + + -- * Direct ser/deser helpers + , directSerialiseToBS + , directDeserialiseFromBS ) where @@ -127,6 +131,18 @@ import Control.Monad (guard, when) import GHC.TypeLits (Nat, KnownNat, natVal) import Formatting.Buildable (Buildable (..), build) import Control.Monad.Class.MonadMVar +import Control.Monad.Class.MonadST (MonadST) +import Foreign (Ptr, plusPtr) +import Foreign.C.Types (CChar, CSize) + +import Cardano.Crypto.DirectSerialise +import Cardano.Crypto.MonadMLock + ( MonadMLock (..) + , MonadByteStringMemory (..) + , packByteStringCStringLen + , copyMem + , allocaBytes + ) -------------------------------------------------------------------------------- -- Connecting MonadRandom to Gen @@ -366,3 +382,44 @@ withLock (Lock v) = withMVar v . const mkLock :: IO Lock mkLock = Lock <$> newMVar () + +-------------------------------------------------------------------------------- +-- Helpers for direct ser/deser +-------------------------------------------------------------------------------- + +directSerialiseToBS :: forall m a. + DirectSerialise m a + => MonadMLock m + => MonadMVar m + => MonadST m + => Int -> a -> m ByteString +directSerialiseToBS dstsize val = do + allocaBytes dstsize $ \dst -> do + posVar <- newMVar 0 + let pusher :: Ptr CChar -> CSize -> m () + pusher src srcsize = do + pos <- takeMVar posVar + let pos' = pos + fromIntegral srcsize + when (pos' > dstsize) (error "Buffer overrun") + copyMem (plusPtr dst pos) src (fromIntegral srcsize) + putMVar posVar pos' + directSerialise pusher val + packByteStringCStringLen (dst, fromIntegral dstsize) + +directDeserialiseFromBS :: forall m a. + DirectDeserialise m a + => MonadMLock m + => MonadByteStringMemory m + => MonadMVar m + => ByteString -> m a +directDeserialiseFromBS bs = do + useByteStringAsCStringLen bs $ \(src, srcsize) -> do + posVar <- newMVar 0 + let puller :: Ptr CChar -> CSize -> m () + puller dst dstsize = do + pos <- takeMVar posVar + let pos' = pos + fromIntegral dstsize + when (pos' > srcsize) (error "Buffer overrun") + copyMem dst (plusPtr src pos) (fromIntegral dstsize) + putMVar posVar pos' + directDeserialise puller