Add unsound pure ser/deser for KES sign keys

IntersectMBO · Apr 17, 2024 · e45b28a · e45b28a
1 parent 074b048
commit e45b28a
Show file tree

Hide file tree

Showing 8 changed files with 104 additions and 0 deletions.
diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs
@@ -318,6 +318,9 @@ class KESAlgorithm v => UnsoundPureKESAlgorithm v where
     => UnsoundPureSignKeyKES v
     -> m (SignKeyKES v)
 
+  rawSerialiseUnsoundPureSignKeyKES    :: UnsoundPureSignKeyKES  v -> ByteString
+  rawDeserialiseUnsoundPureSignKeyKES  :: ByteString -> Maybe (UnsoundPureSignKeyKES v)
+
 
 -- | Unsound operations on KES sign keys. These operations violate secure
 -- forgetting constraints by leaking secrets to unprotected memory. Consider

diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs
@@ -195,6 +195,11 @@ instance ( KESAlgorithm (CompactSingleKES d)
       maybe (error "unsoundPureSignKeyKESToSoundSignKeyKES: deserialisation failure") (return . SignKeyCompactSingleKES)
       =<< (rawDeserialiseSignKeyDSIGNM . rawSerialiseSignKeyDSIGN $ sk)
 
+    rawSerialiseUnsoundPureSignKeyKES (UnsoundPureSignKeyCompactSingleKES sk) =
+      rawSerialiseSignKeyDSIGN sk
+    rawDeserialiseUnsoundPureSignKeyKES b =
+      UnsoundPureSignKeyCompactSingleKES <$> rawDeserialiseSignKeyDSIGN b
+
 instance ( KESAlgorithm (CompactSingleKES d)
          , DSIGNMAlgorithm d
          ) => OptimizedKESAlgorithm (CompactSingleKES d) where

diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs
@@ -532,6 +532,38 @@ instance ( KESAlgorithm (CompactSumKES h d)
         <*> pure vk_0
         <*> pure vk_1
 
+    rawSerialiseUnsoundPureSignKeyKES (UnsoundPureSignKeyCompactSumKES sk r_1 vk_0 vk_1) =
+      let ssk = rawSerialiseUnsoundPureSignKeyKES sk
+          sr1 = getSeedBytes r_1
+      in mconcat
+          [ ssk
+          , sr1
+          , rawSerialiseVerKeyKES vk_0
+          , rawSerialiseVerKeyKES vk_1
+          ]
+
+    rawDeserialiseUnsoundPureSignKeyKES b = do
+        guard (BS.length b == fromIntegral size_total)
+        sk   <- rawDeserialiseUnsoundPureSignKeyKES b_sk
+        let r = mkSeedFromBytes b_r
+        vk_0 <- rawDeserialiseVerKeyKES  b_vk0
+        vk_1 <- rawDeserialiseVerKeyKES  b_vk1
+        return (UnsoundPureSignKeyCompactSumKES sk r vk_0 vk_1)
+      where
+        b_sk  = slice off_sk  size_sk b
+        b_r   = slice off_r   size_r  b
+        b_vk0 = slice off_vk0 size_vk b
+        b_vk1 = slice off_vk1 size_vk b
+
+        size_sk    = sizeSignKeyKES (Proxy :: Proxy d)
+        size_r     = seedSizeKES    (Proxy :: Proxy d)
+        size_vk    = sizeVerKeyKES  (Proxy :: Proxy d)
+        size_total = sizeSignKeyKES (Proxy :: Proxy (CompactSumKES h d))
+
+        off_sk     = 0 :: Word
+        off_r      = size_sk
+        off_vk0    = off_r + size_r
+        off_vk1    = off_vk0 + size_vk
 
 
 --

diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs
@@ -204,6 +204,13 @@ instance KnownNat t => UnsoundPureKESAlgorithm (MockKES t) where
     unsoundPureSignKeyKESToSoundSignKeyKES (UnsoundPureSignKeyMockKES vk t) =
       return $ SignKeyMockKES vk t
 
+    rawSerialiseUnsoundPureSignKeyKES (UnsoundPureSignKeyMockKES vk t) =
+      rawSerialiseSignKeyMockKES (SignKeyMockKES vk t)
+
+    rawDeserialiseUnsoundPureSignKeyKES bs = do
+      SignKeyMockKES vt t <- rawDeserialiseSignKeyMockKES bs
+      return $ UnsoundPureSignKeyMockKES vt t
+
 instance KnownNat t => UnsoundKESAlgorithm (MockKES t) where
     rawSerialiseSignKeyKES sk =
       return $ rawSerialiseSignKeyMockKES sk

diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs
@@ -75,3 +75,5 @@ instance UnsoundPureKESAlgorithm NeverKES where
   unsoundPureDeriveVerKeyKES _ = NeverUsedVerKeyKES
   unsoundPureUpdateKES _ = error "KES not available"
   unsoundPureSignKeyKESToSoundSignKeyKES _ = return NeverUsedSignKeyKES
+  rawSerialiseUnsoundPureSignKeyKES _ = mempty
+  rawDeserialiseUnsoundPureSignKeyKES _ = Just NeverUsedUnsoundPureSignKeyKES
diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs
@@ -230,6 +230,22 @@ instance ( KESAlgorithm (SimpleKES d t)
                       . rawDeserialiseSignKeyDSIGNM
                       . rawSerialiseSignKeyDSIGN
 
+    rawSerialiseUnsoundPureSignKeyKES (UnsoundPureSignKeySimpleKES sks) =
+        BS.concat $! map rawSerialiseSignKeyDSIGN (Vec.toList sks)
+
+
+    rawDeserialiseUnsoundPureSignKeyKES bs
+      | let duration = fromIntegral (natVal (Proxy :: Proxy t))
+            sizeKey  = fromIntegral (sizeSignKeyDSIGN (Proxy :: Proxy d))
+            skbs     = splitsAt (replicate duration sizeKey) bs
+      , length skbs == duration
+      = do
+          sks <- mapM rawDeserialiseSignKeyDSIGN skbs
+          return $! UnsoundPureSignKeySimpleKES (Vec.fromList sks)
+
+      | otherwise
+      = Nothing
+
 
 
 instance ( UnsoundDSIGNMAlgorithm d, KnownNat t, KESAlgorithm (SimpleKES d t))

diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs
@@ -166,6 +166,11 @@ instance ( KESAlgorithm (SingleKES d)
       maybe (error "unsoundPureSignKeyKESToSoundSignKeyKES: deserialisation failure") (return . SignKeySingleKES)
       =<< (rawDeserialiseSignKeyDSIGNM . rawSerialiseSignKeyDSIGN $ sk)
 
+    rawSerialiseUnsoundPureSignKeyKES (UnsoundPureSignKeySingleKES sk) =
+      rawSerialiseSignKeyDSIGN sk
+    rawDeserialiseUnsoundPureSignKeyKES b =
+      UnsoundPureSignKeySingleKES <$> rawDeserialiseSignKeyDSIGN b
+
 instance (KESAlgorithm (SingleKES d), UnsoundDSIGNMAlgorithm d)
          => UnsoundKESAlgorithm (SingleKES d) where
     rawSerialiseSignKeyKES (SignKeySingleKES sk) =

diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs
@@ -451,6 +451,40 @@ instance ( KESAlgorithm (SumKES h d)
         <*> pure vk_0
         <*> pure vk_1
 
+    rawSerialiseUnsoundPureSignKeyKES (UnsoundPureSignKeySumKES sk r_1 vk_0 vk_1) =
+      let ssk = rawSerialiseUnsoundPureSignKeyKES sk
+          sr1 = getSeedBytes r_1
+      in mconcat
+          [ ssk
+          , sr1
+          , rawSerialiseVerKeyKES vk_0
+          , rawSerialiseVerKeyKES vk_1
+          ]
+
+    rawDeserialiseUnsoundPureSignKeyKES b = do
+        guard (BS.length b == fromIntegral size_total)
+        sk   <- rawDeserialiseUnsoundPureSignKeyKES b_sk
+        let r = mkSeedFromBytes b_r
+        vk_0 <- rawDeserialiseVerKeyKES  b_vk0
+        vk_1 <- rawDeserialiseVerKeyKES  b_vk1
+        return (UnsoundPureSignKeySumKES sk r vk_0 vk_1)
+      where
+        b_sk  = slice off_sk  size_sk b
+        b_r   = slice off_r   size_r  b
+        b_vk0 = slice off_vk0 size_vk b
+        b_vk1 = slice off_vk1 size_vk b
+
+        size_sk    = sizeSignKeyKES (Proxy :: Proxy d)
+        size_r     = seedSizeKES    (Proxy :: Proxy d)
+        size_vk    = sizeVerKeyKES  (Proxy :: Proxy d)
+        size_total = sizeSignKeyKES (Proxy :: Proxy (SumKES h d))
+
+        off_sk     = 0 :: Word
+        off_r      = size_sk
+        off_vk0    = off_r + size_r
+        off_vk1    = off_vk0 + size_vk
+
+
 
 --
 -- Direct ser/deser