From df02d73d57bcc5cc4093070b00f0a32b46d5e82c Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 7 Dec 2022 12:04:45 +0100 Subject: [PATCH] Rewrite free-after-use test in terms of the safe mlocking API and re-enable it --- .../src/Cardano/Crypto/DSIGN/Ed25519ML.hs | 2 +- .../src/Cardano/Crypto/KES/Simple.hs | 9 +++++ cardano-crypto-tests/src/Test/Crypto/KES.hs | 37 +++++++++++++++---- 3 files changed, 39 insertions(+), 9 deletions(-) diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs index f9a3b09ca0..0abf7f938a 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs @@ -26,8 +26,8 @@ import System.IO.Unsafe (unsafeDupablePerformIO) import Foreign.C.Error (errnoToIOError, getErrno, Errno) import Foreign.Ptr (castPtr, nullPtr) import qualified Data.ByteString as BS --- import qualified Data.ByteString.Unsafe as BS import Data.Proxy + import Control.Monad.Class.MonadThrow (MonadThrow (..), throwIO, bracket) import Control.Monad.Class.MonadST (MonadST (..)) import Control.Monad.ST (ST) diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs index cd5c1b8a66..f297d77dbe 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.Seed import Cardano.Crypto.MLockedSeed import Cardano.Crypto.Util +import Cardano.Crypto.DirectSerialise (DirectSerialise (..)) import Data.Unit.Strict (forceElemsToWHNF) import Cardano.Crypto.MonadSodium (mlsbAsByteString) @@ -203,6 +204,14 @@ instance ( DSIGNAlgorithm d, KnownNat t, KESSignAlgorithm m (SimpleKES d t)) => | otherwise = return Nothing +-- | Needed for testing purposes. +instance DSIGNAlgorithm d => DirectSerialise (SignKeyKES (SimpleKES d t)) where + directSerialise push (SignKeySimpleKES sks) = + mapM_ (\sk -> do + let bs = rawSerialiseSignKeyDSIGN sk + BS.useAsCStringLen bs (\(ptr, len) -> push ptr (fromIntegral len)) + ) sks + deriving instance DSIGNAlgorithm d => Show (VerKeyKES (SimpleKES d t)) deriving instance DSIGNAlgorithm d => Show (SignKeyKES (SimpleKES d t)) deriving instance DSIGNAlgorithm d => Show (SigKES (SimpleKES d t)) diff --git a/cardano-crypto-tests/src/Test/Crypto/KES.hs b/cardano-crypto-tests/src/Test/Crypto/KES.hs index 9f8a17457c..334e4da2a2 100644 --- a/cardano-crypto-tests/src/Test/Crypto/KES.hs +++ b/cardano-crypto-tests/src/Test/Crypto/KES.hs @@ -25,21 +25,25 @@ 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 Text.Printf +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Marshal.Alloc (allocaBytes) import Control.Concurrent (threadDelay) import Control.Tracer -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Class.MonadThrow +import Control.Concurrent.MVar (newMVar, takeMVar, putMVar) import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow +import Control.Monad.IO.Class (MonadIO, liftIO) +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) import Cardano.Crypto.Util (SignableRepresentation(..)) import Cardano.Crypto.MLockedSeed import qualified Cardano.Crypto.Libsodium as NaCl @@ -247,6 +251,7 @@ testKESAlgorithm , KESSignAlgorithm m v -- , KESSignAlgorithm IO v -- redundant for now , UnsoundKESSignAlgorithm IO v + , DirectSerialise (SignKeyKES v) ) => Lock -> Proxy m @@ -432,16 +437,32 @@ testKESAlgorithm lock _pm _pv n = -- filled with 0xff bytes, we assume that we're looking at erased memory. prop_noErasedBlocksInKey :: forall v. - UnsoundKESSignAlgorithm IO v + KESSignAlgorithm IO v + => DirectSerialise (SignKeyKES v) -- => Lock -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property -- prop_noErasedBlocksInKey lock _ seedPSB = => Lock -> Proxy v -> Property -prop_noErasedBlocksInKey lock _ = +prop_noErasedBlocksInKey lock kesAlgorithm = ioProperty . withLock lock $ do - seed <- MLockedSeed <$> NaCl.mlsbFromByteString (BS.replicate 1024 0) + seed <- MLockedSeed <$> mlsbFromByteString (BS.replicate 1024 0) sk <- genKeyKES @IO @v seed mlockedSeedFinalize seed - serialized <- rawSerialiseSignKeyKES sk + 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") + copyBytes (plusPtr ptr position) buf n + ) + ) + sk + bs <- BS.packCStringLen (ptr, size) + return bs forgetSignKeyKES sk return $ counterexample (hexBS serialized) $ not (hasLongRunOfFF serialized)