Rewrite free-after-use test in terms of the safe mlocking API and re-…

…enable it

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

@@ -28,9 +28,7 @@ import Foreign.C.Error (errnoToIOError, getErrno, Errno)
 import Foreign.Ptr (castPtr, nullPtr)
 import qualified Data.ByteString as BS
 
-#ifdef ALLOW_MLOCK_VIOLATIONS
 import Data.Proxy
-#endif
 
 import Control.Monad.Class.MonadThrow (MonadThrow (..), throwIO, bracket)
 import Control.Monad.Class.MonadST (MonadST (..))

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

@@ -38,6 +38,7 @@ import qualified Cardano.Crypto.DSIGN as DSIGN
 import           Cardano.Crypto.KES.Class
 import           Cardano.Crypto.Seed
 import           Cardano.Crypto.Util
+import           Cardano.Crypto.DirectSerialise (DirectSerialise (..))
 import           Data.Unit.Strict (forceElemsToWHNF)
 import           Cardano.Crypto.MonadSodium (mlsbAsByteString)
 
@@ -209,6 +210,14 @@ instance ( KESAlgorithm (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))

cardano-crypto-tests/src/Test/Crypto/KES.hs

@@ -25,21 +25,26 @@ import Data.List (isPrefixOf, 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.Monad (void)
+import Control.Monad (void, when)
 import Control.Monad.IO.Class (MonadIO)
+import Control.Concurrent.MVar (newMVar, takeMVar, putMVar)
 
 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 qualified Cardano.Crypto.Libsodium as NaCl
 import qualified Cardano.Crypto.Libsodium.Memory as NaCl
+
 #ifdef ALLOW_MLOCK_VIOLATIONS
 import Cardano.Prelude (ReaderT, runReaderT, evaluate, bracket)
 #else
@@ -242,6 +247,7 @@ testKESAlgorithm
      , ContextKES v ~ ()
      , KESSignAlgorithm m v
      , KESSignAlgorithm IO v
+     , DirectSerialise (SignKeyKES v)
      )
   => Lock
   -> Proxy m
@@ -256,11 +262,7 @@ testKESAlgorithm lock _pm _pv n =
     , testProperty "all updates signkey" $ prop_allUpdatesSignKeyKES lock (Proxy @IO) (Proxy @v)
     , testProperty "total periods" $ prop_totalPeriodsKES lock (Proxy @IO) (Proxy @v)
     , testProperty "same VerKey "  $ prop_deriveVerKeyKES lock (Proxy @IO) (Proxy @v)
-#ifdef ALLOW_MLOCK_VIOLATIONS
-      -- TODO: rewrite the property, and re-enable it, when direct
-      -- serialisation becomes available.
     , testProperty "no forgotten chunks in signkey" $ prop_noErasedBlocksInKey lock (Proxy @v)
-#endif
     , testGroup "serialisation"
 
       [ testGroup "raw ser only"
@@ -427,7 +429,6 @@ testKESAlgorithm lock _pm _pv n =
 --     return (before =/= after)
 
 
-#ifdef ALLOW_MLOCK_VIOLATIONS
 -- | 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
@@ -440,15 +441,31 @@ testKESAlgorithm lock _pm _pv n =
 prop_noErasedBlocksInKey
   :: forall 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 <- NaCl.mlsbFromByteString $ BS.replicate 1024 0
     sk <- genKeyKES @IO @v seed
     NaCl.mlsbFinalize 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)
 
@@ -460,7 +477,6 @@ hasLongRunOfFF bs
   = let first16 = BS.take 16 bs
         remainder = BS.drop 16 bs
     in (BS.all (== 0xFF) first16) || hasLongRunOfFF remainder
-#endif
 
 prop_onlyGenSignKeyKES
   :: forall v.