Restructure DSIGN classes

cardano-crypto-class/cardano-crypto-class.cabal

@@ -50,9 +50,7 @@ library
     Cardano.Crypto.DSIGN
     Cardano.Crypto.DSIGN.Class
     Cardano.Crypto.DSIGN.Ed25519
-    Cardano.Crypto.DSIGN.Ed25519ML
     Cardano.Crypto.DSIGN.Ed448
-    Cardano.Crypto.DSIGNM.Class
     Cardano.Crypto.DSIGN.Mock
     Cardano.Crypto.DSIGN.NeverUsed
     Cardano.Crypto.DirectSerialise

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

@@ -6,9 +6,7 @@ module Cardano.Crypto.DSIGN
 where
 
 import Cardano.Crypto.DSIGN.Class as X
-import Cardano.Crypto.DSIGNM.Class as X
 import Cardano.Crypto.DSIGN.Ed25519 as X
-import Cardano.Crypto.DSIGN.Ed25519ML as X
 import Cardano.Crypto.DSIGN.Ed448 as X
 import Cardano.Crypto.DSIGN.Mock as X
 import Cardano.Crypto.DSIGN.NeverUsed as X

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

@@ -3,12 +3,14 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 
 -- | Abstract digital signatures.
 module Cardano.Crypto.DSIGN.Class
@@ -21,11 +23,19 @@ module Cardano.Crypto.DSIGN.Class
   , sizeSignKeyDSIGN
   , sizeSigDSIGN
 
+    -- * DSIGNMM algorithm class
+  , DSIGNMAlgorithm (..)
+  , MonadDSIGNM
+  , MLockedSeed
+
     -- * 'SignedDSIGN' wrapper
   , SignedDSIGN (..)
   , signedDSIGN
   , verifySignedDSIGN
 
+    -- * 'SignedDSIGNM' wrapper
+  , signedDSIGNM
+
     -- * CBOR encoding and decoding
   , encodeVerKeyDSIGN
   , decodeVerKeyDSIGN
@@ -40,12 +50,17 @@ module Cardano.Crypto.DSIGN.Class
   , encodedVerKeyDSIGNSizeExpr
   , encodedSignKeyDSIGNSizeExpr
   , encodedSigDSIGNSizeExpr
+
+    -- * Unsound API
+  , UnsoundDSIGNMAlgorithm (..)
+  , encodeSignKeyDSIGNM
+  , decodeSignKeyDSIGNM
   )
 where
 
 import Control.DeepSeq (NFData)
-import qualified Data.ByteString as BS
 import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
 import Data.Kind (Type)
 import Data.Proxy (Proxy(..))
 import Data.Typeable (Typeable)
@@ -55,18 +70,22 @@ import GHC.Stack
 import GHC.TypeLits (KnownNat, Nat, natVal, TypeError, ErrorMessage (..))
 import NoThunks.Class (NoThunks)
 
+import Control.Monad.Class.MonadST (MonadST)
+import Control.Monad.Class.MonadThrow (MonadThrow)
+
 import Cardano.Binary (Decoder, decodeBytes, Encoding, encodeBytes, Size, withWordSize)
 
-import Cardano.Crypto.Util (Empty)
-import Cardano.Crypto.Seed
 import Cardano.Crypto.Hash.Class (HashAlgorithm, Hash, hashWith)
+import Cardano.Crypto.MLockedSeed
+import Cardano.Crypto.MonadMLock.Class (MonadMLock)
+import Cardano.Crypto.Seed
+import Cardano.Crypto.Util (Empty)
 
 
 
 class ( Typeable v
       , Show (VerKeyDSIGN v)
       , Eq (VerKeyDSIGN v)
-      , Show (SignKeyDSIGN v)
       , Show (SigDSIGN v)
       , Eq (SigDSIGN v)
       , NoThunks (SigDSIGN v)
@@ -306,3 +325,110 @@ encodedSigDSIGNSizeExpr _proxy =
       fromIntegral ((withWordSize :: Word -> Integer) (sizeSigDSIGN (Proxy :: Proxy v)))
       -- payload
     + fromIntegral (sizeSigDSIGN (Proxy :: Proxy v))
+
+--
+-- DSIGNM (mlocked DSIGN operations)
+--
+
+class (MonadST m, MonadMLock m, MonadThrow m) => MonadDSIGNM m
+instance (MonadST m, MonadMLock m, MonadThrow m) => MonadDSIGNM m
+
+class ( DSIGNAlgorithm v
+      )
+      => DSIGNMAlgorithm v where
+
+  data SignKeyDSIGNM v :: Type
+
+  --
+  -- Metadata and basic key operations
+  --
+
+  deriveVerKeyDSIGNM :: forall m. MonadDSIGNM m
+                     => SignKeyDSIGNM v -> m (VerKeyDSIGN v)
+
+  --
+  -- Core algorithm operations
+  --
+
+  signDSIGNM
+    :: forall m a.
+       (Signable v a, HasCallStack, MonadDSIGNM m)
+    => ContextDSIGN v
+    -> a
+    -> SignKeyDSIGNM v
+    -> m (SigDSIGN v)
+
+  --
+  -- Key generation
+  --
+
+  genKeyDSIGNM :: forall m.
+                  (MonadDSIGNM m)
+               => MLockedSeed (SeedSizeDSIGN v) -> m (SignKeyDSIGNM v)
+
+  cloneKeyDSIGNM :: forall m.
+                    (MonadDSIGNM m)
+                 => SignKeyDSIGNM v -> m (SignKeyDSIGNM v)
+
+  getSeedDSIGNM :: forall m.
+                   (MonadDSIGNM m)
+                => Proxy v -> SignKeyDSIGNM v -> m (MLockedSeed (SeedSizeDSIGN v))
+
+  --
+  -- Secure forgetting
+  --
+
+  forgetSignKeyDSIGNM :: forall m.
+                         (MonadDSIGNM m)
+                      => SignKeyDSIGNM v -> m ()
+
+--
+-- Do not provide Ord instances for keys, see #38
+--
+
+instance ( TypeError ('Text "Ord not supported for signing keys, use the hash instead")
+         , Eq (SignKeyDSIGNM v)
+         )
+      => Ord (SignKeyDSIGNM v) where
+    compare = error "unsupported"
+
+signedDSIGNM
+  :: (DSIGNMAlgorithm v, Signable v a, MonadDSIGNM m)
+  => ContextDSIGN v
+  -> a
+  -> SignKeyDSIGNM v
+  -> m (SignedDSIGN v a)
+signedDSIGNM ctxt a key = SignedDSIGN <$> signDSIGNM ctxt a key
+
+
+-- | Unsound operations on DSIGNM sign keys. These operations violate secure
+-- forgetting constraints by leaking secrets to unprotected memory. Consider
+-- using the 'DirectSerialise' / 'DirectDeserialise' APIs instead.
+class DSIGNMAlgorithm v => UnsoundDSIGNMAlgorithm v where
+  --
+  -- Serialisation/(de)serialisation in fixed-size raw format
+  --
+
+  rawSerialiseSignKeyDSIGNM   :: forall m. (MonadDSIGNM m) => SignKeyDSIGNM v -> m ByteString
+
+  rawDeserialiseSignKeyDSIGNM :: forall m. (MonadDSIGNM m) => ByteString -> m (Maybe (SignKeyDSIGNM v))
+
+encodeSignKeyDSIGNM :: (UnsoundDSIGNMAlgorithm v, MonadDSIGNM m) => SignKeyDSIGNM v -> m Encoding
+encodeSignKeyDSIGNM = fmap encodeBytes . rawSerialiseSignKeyDSIGNM
+
+decodeSignKeyDSIGNM :: forall m v s
+                     . (UnsoundDSIGNMAlgorithm v, MonadDSIGNM m)
+                    => Decoder s (m (SignKeyDSIGNM v))
+decodeSignKeyDSIGNM = do
+    bs <- decodeBytes
+    return $ rawDeserialiseSignKeyDSIGNM bs >>= \case
+      Just vk -> return vk
+      Nothing
+        | actual /= expected
+                    -> error ("decodeSignKeyDSIGNM: wrong length, expected " ++
+                             show expected ++ " bytes but got " ++ show actual)
+        | otherwise -> error "decodeSignKeyDSIGNM: cannot decode key"
+        where
+          expected = fromIntegral (sizeSignKeyDSIGN (Proxy :: Proxy v))
+          actual   = BS.length bs
+