Fix some mlocking-related bugs

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 (bracket)
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 
@@ -188,7 +188,7 @@ instance DSIGNMAlgorithm IO Ed25519DSIGNM where
       seed <- getSeedDSIGNM (Proxy @Ed25519DSIGNM) sk
       -- need to copy the seed into unsafe memory and finalize the MLSB, in
       -- order to avoid leaking mlocked memory
-      raw <- evaluate . (BS.copy $!) . mlsbToByteString $ seed
+      raw <- mlsbToByteString seed
       mlsbFinalize seed
       return raw
 

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

@@ -326,10 +326,10 @@ instance ( OptimizedKESAlgorithm d
 
     rawSerialiseSignKeyKES (SignKeyCompactSumKES sk r_1 vk_0 vk_1) = do
       ssk <- rawSerialiseSignKeyKES sk
-      rr1 <- NaCl.interactSafePinned r_1 return
+      sr1 <- NaCl.interactSafePinned r_1 NaCl.mlsbToByteString
       return $ mconcat
                   [ ssk
-                  , NaCl.mlsbToByteString rr1
+                  , sr1
                   , rawSerialiseVerKeyKES vk_0
                   , rawSerialiseVerKeyKES vk_1
                   ]

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

@@ -32,7 +32,8 @@ import Cardano.Crypto.Hash
 import Cardano.Crypto.Seed
 import Cardano.Crypto.KES.Class
 import Cardano.Crypto.Util
-import Cardano.Crypto.MonadSodium (mlsbToByteString)
+import Cardano.Crypto.DirectSerialise
+import Cardano.Crypto.MonadSodium (mlsbAsByteString)
 
 data MockKES (t :: Nat)
 
@@ -150,7 +151,7 @@ instance (Monad m, KnownNat t) => KESSignAlgorithm m (MockKES t) where
     --
 
     genKeyKES seed = do
-        let vk = VerKeyMockKES (runMonadRandomWithSeed (mkSeedFromBytes $ mlsbToByteString seed) getRandomWord64)
+        let vk = VerKeyMockKES (runMonadRandomWithSeed (mkSeedFromBytes $ mlsbAsByteString seed) getRandomWord64)
         return $! SignKeyMockKES vk 0
 
     rawSerialiseSignKeyKES sk =

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

@@ -39,7 +39,7 @@ import           Cardano.Crypto.KES.Class
 import           Cardano.Crypto.Seed
 import           Cardano.Crypto.Util
 import           Data.Unit.Strict (forceElemsToWHNF)
-import           Cardano.Crypto.MonadSodium (mlsbToByteString)
+import           Cardano.Crypto.MonadSodium (mlsbAsByteString)
 
 
 data SimpleKES d (t :: Nat)
@@ -179,7 +179,7 @@ instance ( KESAlgorithm (SimpleKES d t)
     --
 
     genKeyKES mlsb =
-        let seed     = mkSeedFromBytes $ mlsbToByteString mlsb
+        let seed     = mkSeedFromBytes $ mlsbAsByteString mlsb
             seedSize = seedSizeDSIGN (Proxy :: Proxy d)
             duration = fromIntegral (natVal (Proxy @t))
             seeds    = take duration

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

@@ -279,19 +279,19 @@ instance ( KESSignAlgorithm m d
     -- forgetting
     --
     forgetSignKeyKES (SignKeySumKES sk_0 r1 _ _) = do
-        forgetSignKeyKES sk_0
-        NaCl.releaseSafePinned r1
+      forgetSignKeyKES sk_0
+      NaCl.releaseSafePinned r1
 
     --
     -- raw serialise/deserialise
     --
 
     rawSerialiseSignKeyKES (SignKeySumKES sk r_1 vk_0 vk_1) = do
       ssk <- rawSerialiseSignKeyKES sk
-      rr1 <- NaCl.interactSafePinned r_1 return
+      sr1 <- NaCl.interactSafePinned r_1 NaCl.mlsbToByteString
       return $ mconcat
                   [ ssk
-                  , NaCl.mlsbToByteString rr1
+                  , sr1
                   , rawSerialiseVerKeyKES vk_0
                   , rawSerialiseVerKeyKES vk_1
                   ]

cardano-crypto-class/src/Cardano/Crypto/Libsodium.hs

@@ -11,6 +11,7 @@ module Cardano.Crypto.Libsodium (
   MLockedSizedBytes,
   mlsbFromByteString,
   mlsbFromByteStringCheck,
+  mlsbAsByteString,
   mlsbToByteString,
   mlsbFinalize,
   mlsbCopy,

cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes.hs

@@ -3,6 +3,7 @@ module Cardano.Crypto.Libsodium.MLockedBytes (
     mlsbNew,
     mlsbFromByteString,
     mlsbFromByteStringCheck,
+    mlsbAsByteString,
     mlsbToByteString,
     mlsbUseAsCPtr,
     mlsbUseAsSizedPtr,

cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs

@@ -9,6 +9,7 @@ module Cardano.Crypto.Libsodium.MLockedBytes.Internal (
     mlsbNew,
     mlsbFromByteString,
     mlsbFromByteStringCheck,
+    mlsbAsByteString,
     mlsbToByteString,
     mlsbUseAsCPtr,
     mlsbUseAsSizedPtr,
@@ -19,7 +20,7 @@ module Cardano.Crypto.Libsodium.MLockedBytes.Internal (
 import Control.DeepSeq (NFData (..))
 import Data.Proxy (Proxy (..))
 import Foreign.C.Types (CSize (..))
-import Foreign.ForeignPtr (castForeignPtr)
+import Foreign.ForeignPtr (castForeignPtr, withForeignPtr)
 import Foreign.Ptr (Ptr, castPtr)
 import GHC.TypeLits (KnownNat, natVal)
 import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
@@ -57,10 +58,13 @@ instance KnownNat n => Show (MLockedSizedBytes n) where
     --     $ showString "_ :: MLockedSizedBytes "
     --     . showsPrec 11 (natVal (Proxy @n))
     show mlsb =
-      let bytes = BS.unpack $ mlsbToByteString mlsb
+      let bytes = BS.unpack $ mlsbAsByteString mlsb
           hexstr = concatMap (printf "%02x") bytes
       in "MLSB " ++ hexstr
 
+withMLSB :: forall a b n. MLockedSizedBytes n -> (Ptr a -> IO b) -> IO b
+withMLSB (MLSB fptr) action = withMLockedForeignPtr fptr (action . castPtr)
+
 -- | Note: this doesn't need to allocate mlocked memory,
 -- but we do that for consistency
 -- mlsbZero :: forall n. KnownNat n => MLockedSizedBytes n
@@ -113,8 +117,18 @@ mlsbFromByteStringCheck bs
 -- | /Note:/ the resulting 'BS.ByteString' will still refer to secure memory,
 -- but the types don't prevent it from be exposed.
 --
-mlsbToByteString :: forall n. KnownNat n => MLockedSizedBytes n -> BS.ByteString
-mlsbToByteString (MLSB (SFP fptr)) = BSI.PS (castForeignPtr fptr) 0 size where
+mlsbAsByteString :: forall n. KnownNat n => MLockedSizedBytes n -> BS.ByteString
+mlsbAsByteString (MLSB (SFP fptr)) = BSI.PS (castForeignPtr fptr) 0 size
+  where
+    size  :: Int
+    size = fromInteger (natVal (Proxy @n))
+
+
+mlsbToByteString :: forall n. (KnownNat n) => MLockedSizedBytes n -> IO BS.ByteString
+mlsbToByteString mlsb =
+  withMLSB mlsb $ \ptr ->
+    BS.packCStringLen (castPtr ptr, size)
+  where
     size  :: Int
     size = fromInteger (natVal (Proxy @n))
 

cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs

@@ -128,7 +128,6 @@ traceMLockedForeignPtr fptr = withMLockedForeignPtr fptr $ \ptr -> do
 
 makeMLockedPool :: forall n. KnownNat n => IO (Pool n)
 makeMLockedPool = do
-  hPutStrLn stderr "makeMLockedPool"
   initPool
     (fromIntegral $ 4096 `div` (natVal (Proxy @n)) `div` 64)
     (\size -> do

cardano-crypto-class/src/Cardano/Crypto/MonadSodium.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- We need this so that we can forward the deprecated traceMLockedForeignPtr
 {-# OPTIONS_GHC -Wno-deprecations #-}
@@ -20,7 +22,7 @@ module Cardano.Crypto.MonadSodium
   NaCl.sodiumInit,
   NaCl.MLockedForeignPtr,
   NaCl.MLockedSizedBytes,
-  NaCl.mlsbToByteString,
+  NaCl.mlsbAsByteString,
   NaCl.SodiumHashAlgorithm (..),
   NaCl.digestMLockedStorable,
   NaCl.digestMLockedBS,
@@ -36,7 +38,8 @@ import Cardano.Crypto.Libsodium
   )
 import qualified Cardano.Crypto.Libsodium as NaCl
 import qualified Cardano.Crypto.SafePinned as SP
-import Cardano.Crypto.Libsodium.MLockedBytes as NaCl
+import Cardano.Crypto.Libsodium.MLockedBytes (MLockedSizedBytes)
+import qualified Cardano.Crypto.Libsodium.MLockedBytes as NaCl
 import Cardano.Crypto.Libsodium.Hash as NaCl
 import Cardano.Crypto.Hash (HashAlgorithm(SizeHash))
 import Cardano.Foreign (SizedPtr)
@@ -64,6 +67,7 @@ class Monad m => MonadSodium m where
   mlsbUseAsCPtr :: forall n r. KnownNat n => MLockedSizedBytes n -> (Ptr Word8 -> m r) -> m r
   mlsbFromByteString :: forall n. KnownNat n => BS.ByteString -> m (MLockedSizedBytes n)
   mlsbFromByteStringCheck :: forall n. KnownNat n => BS.ByteString -> m (Maybe (MLockedSizedBytes n))
+  mlsbToByteString :: forall n. KnownNat n => MLockedSizedBytes n -> m BS.ByteString
 
   -- * SafePinned
   makeSafePinned :: a -> m (SP.SafePinned a)
@@ -92,6 +96,7 @@ instance MonadSodium IO where
   interactSafePinned = SP.interactSafePinned
   mlsbFromByteString = NaCl.mlsbFromByteString
   mlsbFromByteStringCheck = NaCl.mlsbFromByteStringCheck
+  mlsbToByteString = NaCl.mlsbToByteString
   expandHash = NaCl.expandHash
 
 mapSafePinned :: MonadSodium m => (a -> m b) -> SP.SafePinned a -> m (SP.SafePinned b)

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

@@ -529,13 +529,13 @@ prop_key_overwritten_after_forget lock p seedPSB =
     NaCl.mlsbFinalize seed
 
     seedBefore <- getSeedDSIGNM p sk
-    bsBefore <- evaluate $! BS.copy (NaCl.mlsbToByteString seedBefore)
+    bsBefore <- NaCl.mlsbToByteString seedBefore
     NaCl.mlsbFinalize seedBefore
 
     forgetSignKeyDSIGNM sk
 
     seedAfter <- getSeedDSIGNM p sk
-    bsAfter <- evaluate $! BS.copy (NaCl.mlsbToByteString seedAfter)
+    bsAfter <- NaCl.mlsbToByteString seedAfter
     NaCl.mlsbFinalize seedAfter
 
     return (bsBefore =/= bsAfter)
@@ -551,8 +551,8 @@ prop_dsignm_seed_roundtrip
 prop_dsignm_seed_roundtrip lock p seedPSB = ioProperty . withLock lock . withMLSBFromPSB seedPSB $ \seed -> do
   sk <- genKeyDSIGNM seed
   seed' <- getSeedDSIGNM p sk
-  bs <- evaluate $! BS.copy (NaCl.mlsbToByteString seed)
-  bs' <- evaluate $! BS.copy (NaCl.mlsbToByteString seed')
+  bs <- NaCl.mlsbToByteString seed
+  bs' <- NaCl.mlsbToByteString seed'
   forgetSignKeyDSIGNM sk
   NaCl.mlsbFinalize seed'
   return (bs === bs')

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

@@ -156,7 +156,7 @@ prop_libsodium_model
   => Proxy h -> BS.ByteString -> Property
 prop_libsodium_model p bs = ioProperty $ do
   mlsb <- NaCl.digestMLockedBS p bs
-  let actual = NaCl.mlsbToByteString mlsb
+  let actual = NaCl.mlsbAsByteString mlsb
   return (expected === actual)
   where
     expected = digest p bs

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

@@ -102,22 +102,25 @@ instance Eq a => Eq (SafePinned a) where
 
 instance Show (SignKeyKES (SingleKES Ed25519DSIGNM)) where
   show (SignKeySingleKES (SignKeyEd25519DSIGNM mlsb)) =
-    let bytes = BS.unpack $ NaCl.mlsbToByteString mlsb
-        hexstr = concatMap (printf "%02x") bytes
+    let bytes = NaCl.mlsbAsByteString mlsb
+        hexstr = hexBS bytes
     in "SignKeySingleKES (SignKeyEd25519DSIGNM " ++ hexstr ++ ")"
 
 instance Show (SignKeyKES (SumKES h d)) where
   show _ = "<SignKeySumKES>"
 
 instance Show (SignKeyKES (CompactSingleKES Ed25519DSIGNM)) where
   show (SignKeyCompactSingleKES (SignKeyEd25519DSIGNM mlsb)) =
-    let bytes = BS.unpack $ NaCl.mlsbToByteString mlsb
-        hexstr = concatMap (printf "%02x") bytes
+    let bytes = NaCl.mlsbAsByteString mlsb
+        hexstr = hexBS bytes
     in "SignKeyCompactSingleKES (SignKeyEd25519DSIGNM " ++ hexstr ++ ")"
 
 instance Show (SignKeyKES (CompactSumKES h d)) where
   show _ = "<SignKeyCompactSumKES>"
 
+hexBS :: ByteString -> String
+hexBS = concatMap (printf "%02x") . BS.unpack
+
 deriving instance Eq (SignKeyDSIGN d) => Eq (SignKeyKES (SimpleKES d t))
 
 deriving instance Eq (SignKeyDSIGNM d)
@@ -253,6 +256,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)
+    , testProperty "no forgotten chunks in signkey" $ prop_noErasedBlocksInKey lock (Proxy @v)
     , testGroup "serialisation"
 
       [ testGroup "raw ser only"
@@ -418,14 +422,45 @@ testKESAlgorithm lock _pm _pv n =
 --     return (before =/= after)
 
 
+-- | 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.
+     KESSignAlgorithm IO v
+  -- => Lock -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property
+  -- prop_noErasedBlocksInKey lock _ seedPSB =
+  => Lock -> Proxy v -> Property
+prop_noErasedBlocksInKey lock _ =
+  ioProperty . withLock lock $ do
+    seed <- NaCl.mlsbFromByteString $ BS.replicate 1024 0
+    sk <- genKeyKES @IO @v seed
+    NaCl.mlsbFinalize seed
+    serialized <- rawSerialiseSignKeyKES sk
+    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
   => Lock -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property
-prop_onlyGenSignKeyKES lock _ seedPSB = ioProperty . withLock lock . withMLSBFromPSB seedPSB $ \seed -> do
-  sk <- genKeyKES @IO @v seed
-  forgetSignKeyKES sk
-  return True
+prop_onlyGenSignKeyKES lock _ seedPSB =
+  ioProperty . withLock lock . withMLSBFromPSB seedPSB $ \seed -> do
+    sk <- genKeyKES @IO @v seed
+    forgetSignKeyKES sk
+    return True
 
 prop_onlyGenVerKeyKES
   :: forall v.