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

@@ -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)

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))

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)