More progress?

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

@@ -28,6 +28,8 @@ import Foreign.C.Error (errnoToIOError, getErrno)
 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 Cardano.Binary (FromCBOR (..), ToCBOR (..))
 
@@ -167,6 +169,14 @@ instance DSIGNMAlgorithm IO Ed25519DSIGNM where
                   $ c_crypto_sign_ed25519_seed_keypair pkPtr skPtr (SizedPtr . castPtr $ seedPtr)
           return sk
 
+    getSeedDSIGNM _ (SignKeyEd25519DSIGNM sk) = do
+        seed <- mlsbNew
+        mlsbUseAsSizedPtr sk $ \skPtr ->
+          mlsbUseAsSizedPtr seed $ \seedPtr ->
+            cOrError "rawSerialiseSignKeyDSIGNM @Ed25519DSIGNM" "c_crypto_sign_ed25519_sk_to_seed"
+              $ c_crypto_sign_ed25519_sk_to_seed seedPtr skPtr
+        return seed
+
     --
     -- Secure forgetting
     --
@@ -176,14 +186,13 @@ instance DSIGNMAlgorithm IO Ed25519DSIGNM where
     --
     -- Ser/deser (dangerous)
     --
-    rawSerialiseSignKeyDSIGNM   (SignKeyEd25519DSIGNM sk) = do
-      psbToByteString @(SeedSizeDSIGNM Ed25519DSIGNM) <$> do
-        let seed = psbZero
-        mlsbUseAsSizedPtr sk $ \skPtr ->
-          psbUseAsSizedPtr seed $ \seedPtr ->
-            cOrError "rawSerialiseSignKeyDSIGNM @Ed25519DSIGNM" "c_crypto_sign_ed25519_sk_to_seed"
-              $ c_crypto_sign_ed25519_sk_to_seed seedPtr skPtr
-        return seed
+    rawSerialiseSignKeyDSIGNM sk = do
+      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
+      mlsbFinalize seed
+      return raw
 
     rawDeserialiseSignKeyDSIGNM raw = do
       let mseed = mlsbFromByteStringCheck raw

cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs

@@ -168,6 +168,8 @@ class ( DSIGNMAlgorithmBase v
 
   genKeyDSIGNM :: MLockedSeed (SeedSizeDSIGNM v) -> m (SignKeyDSIGNM v)
 
+  getSeedDSIGNM :: Proxy v -> SignKeyDSIGNM v -> m (MLockedSeed (SeedSizeDSIGNM v))
+
   --
   -- Secure forgetting
   --

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

@@ -104,10 +104,9 @@ instance KnownNat t => KESAlgorithm (MockKES t) where
     rawSerialiseVerKeyKES (VerKeyMockKES vk) =
         writeBinaryWord64 vk
 
-    rawSerialiseSigKES (SigMockKES h (SignKeyMockKES k t)) =
+    rawSerialiseSigKES (SigMockKES h sk) =
         hashToBytes h
-     <> rawSerialiseVerKeyKES k
-     <> writeBinaryWord64 (fromIntegral t)
+     <> rawSerialiseSignKeyMockKES sk
 
     rawDeserialiseVerKeyKES bs
       | [vkb] <- splitsAt [8] bs
@@ -118,12 +117,10 @@ instance KnownNat t => KESAlgorithm (MockKES t) where
       = Nothing
 
     rawDeserialiseSigKES bs
-      | [hb, kb, tb] <- splitsAt [16, 8, 8] bs
+      | [hb, skb] <- splitsAt [8, 16] bs
       , Just h    <- hashFromBytes hb
-      , Just k    <- rawDeserialiseVerKeyKES kb
-      , t    <- fromIntegral (readBinaryWord64 tb)
-      = Just $! SigMockKES h (SignKeyMockKES k t)
-
+      , Just sk   <- rawDeserialiseSignKeyMockKES skb
+      = Just $! SigMockKES h sk
       | otherwise
       = Nothing
 
@@ -152,18 +149,23 @@ instance (Monad m, KnownNat t) => KESSignAlgorithm m (MockKES t) where
         let vk = VerKeyMockKES (runMonadRandomWithSeed (mkSeedFromBytes $ mlsbToByteString seed) getRandomWord64)
         return $ SignKeyMockKES vk 0
 
-    rawSerialiseSignKeyKES (SignKeyMockKES vk t) = return $
-        rawSerialiseVerKeyKES vk
-     <> writeBinaryWord64 (fromIntegral t)
+    rawSerialiseSignKeyKES sk =
+      return $ rawSerialiseSignKeyMockKES sk
 
-    rawDeserialiseSignKeyKES bs
-      | [vkb, tb] <- splitsAt [8, 8] bs
-      , Just vk   <- rawDeserialiseVerKeyKES vkb
-      , let t      = fromIntegral (readBinaryWord64 tb)
-      = return . Just $! SignKeyMockKES vk t
+    rawDeserialiseSignKeyKES bs =
+      return $ rawDeserialiseSignKeyMockKES bs
 
-      | otherwise
-      = return Nothing
+rawDeserialiseSignKeyMockKES bs
+    | [vkb, tb] <- splitsAt [8, 8] bs
+    , Just vk   <- rawDeserialiseVerKeyKES vkb
+    , let t      = fromIntegral (readBinaryWord64 tb)
+    = Just $! SignKeyMockKES vk t
+    | otherwise
+    = Nothing
+
+rawSerialiseSignKeyMockKES (SignKeyMockKES vk t) =
+    rawSerialiseVerKeyKES vk
+ <> writeBinaryWord64 (fromIntegral t)
 
 instance KnownNat t => ToCBOR (VerKeyKES (MockKES t)) where
   toCBOR = encodeVerKeyKES

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

@@ -27,6 +27,7 @@ import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
 import System.IO.Unsafe (unsafeDupablePerformIO)
 import Data.Word (Word8)
 import Control.Monad (void)
+import Text.Printf
 
 import Cardano.Foreign
 import Cardano.Crypto.Libsodium.Memory.Internal
@@ -53,9 +54,13 @@ instance KnownNat n => Ord (MLockedSizedBytes n) where
         size = natVal (Proxy @n)
 
 instance KnownNat n => Show (MLockedSizedBytes n) where
-    showsPrec d _ = showParen (d > 10)
-        $ showString "_ :: MLockedSizedBytes "
-        . showsPrec 11 (natVal (Proxy @n))
+    -- showsPrec d _ = showParen (d > 10)
+    --     $ showString "_ :: MLockedSizedBytes "
+    --     . showsPrec 11 (natVal (Proxy @n))
+    show mlsb =
+      let bytes = BS.unpack $ mlsbToByteString mlsb
+          hexstr = concatMap (printf "%02x") bytes
+      in "MLSB " ++ hexstr
 
 -- | Note: this doesn't need to allocate mlocked memory,
 -- but we do that for consistency

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

@@ -14,6 +14,7 @@ where
 
 import Data.Proxy (Proxy (..))
 import Data.Word (Word8)
+import Control.Monad
 
 import Cardano.Crypto.DSIGN
 import Cardano.Crypto.Util (SignableRepresentation(..))
@@ -67,18 +68,20 @@ testDSIGNMAlgorithm
 testDSIGNMAlgorithm _ _ n =
   testGroup n
     [ testGroup "serialisation"
-      []
-      -- [ testGroup "raw"
-      --   [ testProperty "VerKey"  $ prop_raw_serialise_IO @(VerKeyDSIGNM v)
-      --                                                 (return . rawSerialiseVerKeyDSIGNM)
-      --                                                 (return . rawDeserialiseVerKeyDSIGNM)
-      --   , testProperty "SignKey" $ prop_raw_serialise_IO @(SignKeyDSIGNM v)
-      --                                                 rawSerialiseSignKeyDSIGNM
-      --                                                 rawDeserialiseSignKeyDSIGNM
-      --   , testProperty "Sig"     $ prop_raw_serialise_IO @(SigDSIGNM v)
-      --                                                 (return . rawSerialiseSigDSIGNM)
-      --                                                 (return . rawDeserialiseSigDSIGNM)
-      --   ]
+      [ testGroup "raw"
+        [ testProperty "VerKey"  $ prop_raw_serialise_IO_from @(VerKeyDSIGNM v)
+                                                      (return . rawSerialiseVerKeyDSIGNM)
+                                                      (return . rawDeserialiseVerKeyDSIGNM)
+                                                      (genKeyDSIGNM >=> deriveVerKeyDSIGNM)
+        -- , testProperty "SignKey" $ prop_raw_serialise_IO_from @(SignKeyDSIGNM v)
+        --                                               rawSerialiseSignKeyDSIGNM
+        --                                               rawDeserialiseSignKeyDSIGNM
+        --                                               genKeyDSIGNM
+        -- , testProperty "Sig"     $ prop_raw_serialise_IO_from @(SigDSIGNM v)
+        --                                               (return . rawSerialiseSigDSIGNM)
+        --                                               (return . rawDeserialiseSigDSIGNM)
+        --                                               return
+        ]
 
       -- , testGroup "size"
       --   [ testProperty "VerKey"  $ prop_size_serialise @(VerKeyDSIGNM v)
@@ -124,10 +127,13 @@ testDSIGNMAlgorithm _ _ n =
       --   , testProperty "Sig"     $ prop_cbor_direct_vs_class @(SigDSIGNM v)
       --                                                        encodeSigDSIGNM
       --   ]
-      -- ]
+        , testGroup "Seed/SK"
+          [ testProperty "Seed round-trip" $ prop_dsignm_seed_roundtrip (Proxy @v)
+          ]
+      ]
 
     -- , testGroup "verify"
-    --   [ testProperty "verify positive" $ prop_dsign_verify_pos @v
+    --   [ testProperty "verify positive" $ prop_dsignm_verify_pos @v
     --   , testProperty "verify negative (wrong key)" $ prop_dsign_verify_neg_key @v
     --   , testProperty "verify negative (wrong message)" $ prop_dsign_verify_neg_msg @v
     --   ]
@@ -228,6 +234,16 @@ testDSIGNAlgorithm _ n =
       ]
     ]
 
+prop_dsignm_seed_roundtrip
+  :: forall v. (DSIGNMAlgorithm IO v)
+  => Proxy v
+  -> MLockedSeed (SeedSizeDSIGNM v)
+  -> Property
+prop_dsignm_seed_roundtrip p seed = ioProperty $ do
+  sk <- genKeyDSIGNM seed
+  seed' <- getSeedDSIGNM p sk
+  return (seed === seed')
+
 -- | If we sign a message @a@ with the signing key, then we can verify the
 -- signature using the corresponding verification key.
 --

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

@@ -27,6 +27,7 @@ import Foreign.Ptr (WordPtr)
 import System.IO.Unsafe (unsafePerformIO)
 import Data.IORef
 import Data.Maybe (fromJust)
+import Text.Printf
 
 import Control.Exception (evaluate)
 import Control.Concurrent (threadDelay)
@@ -79,8 +80,12 @@ instance Eq a => Eq (SafePinned a) where
       interactSafePinned bp $ \b ->
         return (a == b)
 
-instance Show (SignKeyKES (SingleKES d)) where
-  show _ = "<SignKeySingleKES>"
+instance Show (SignKeyKES (SingleKES Ed25519DSIGNM)) where
+  show (SignKeySingleKES (SignKeyEd25519DSIGNM mlsb)) =
+    let bytes = BS.unpack $ NaCl.mlsbToByteString mlsb
+        hexstr = concatMap (printf "%02x") bytes
+    in "SignKeySingleKES (SignKeyEd25519DSIGNM " ++ hexstr ++ ")"
+
 instance Show (SignKeyKES (SumKES h d)) where
   show _ = "<SignKeySumKES>"
 
@@ -235,9 +240,10 @@ testKESAlgorithm _pm _pv n =
         , testProperty "Sig"     $ prop_raw_serialise @(SigKES v)
                                                       rawSerialiseSigKES
                                                       rawDeserialiseSigKES
-        , testProperty "SignKey" $ prop_raw_serialise @(SignKeyKES v)
-                                                      (unsafePerformIO . io . rawSerialiseSignKeyKES @m @v)
-                                                      (unsafePerformIO . io . rawDeserialiseSignKeyKES @m @v)
+        , testProperty "SignKey" $ prop_raw_serialise_IO_from @(SignKeyKES v)
+                                                      (io . rawSerialiseSignKeyKES @m @v)
+                                                      (io . rawDeserialiseSignKeyKES @m @v)
+                                                      (io . genKeyKES @m @v)
         ]
 
       , testGroup "size"
@@ -592,3 +598,5 @@ instance ( KESSignAlgorithm IO v
     let sig = unsafePerformIO $ signKES () 0 a sk
     return sig
   shrink = const []
+
+-- MLockedSizedBytes

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

@@ -16,7 +16,7 @@ module Test.Crypto.Util
   , prop_cbor_valid
   , prop_cbor_roundtrip
   , prop_raw_serialise
-  , prop_raw_serialise_IO
+  , prop_raw_serialise_IO_from
   , prop_raw_serialise_only
   , prop_size_serialise
   , prop_size_serialise_IO
@@ -180,14 +180,15 @@ prop_raw_serialise serialise deserialise x =
       Just y  -> y === x
       Nothing -> property False
 
-prop_raw_serialise_IO :: forall a. (Eq a, Show a)
+prop_raw_serialise_IO_from :: forall a b. (Eq a, Show a)
                    => (a -> IO ByteString)
                    -> (ByteString -> IO (Maybe a))
-                   -> IO a
+                   -> (b -> IO a)
+                   -> b
                    -> Property
-prop_raw_serialise_IO serialise deserialise mkX = do
+prop_raw_serialise_IO_from serialise deserialise mkX seed = do
   ioProperty $ do
-    x <- mkX
+    x <- mkX seed
     serialise x >>= deserialise >>= \case
       Just y  -> return (y === x)
       Nothing -> return (property False)