Merge pull request #404 from input-output-hk/tdammers/just-use-monad-st

Generalized mlocking via MonadST
IntersectMBO · Jun 27, 2023 · cb31fe9 · cb31fe9
2 parents a344b32 + 4ee7879
commit cb31fe9
Show file tree

Hide file tree

Showing 36 changed files with 1,163 additions and 1,381 deletions.
diff --git a/cardano-crypto-class/CHANGELOG.md b/cardano-crypto-class/CHANGELOG.md
@@ -7,12 +7,19 @@ solidified. Ask @lehins if backport is needed.
 
 * Introduce memory locking and secure forgetting functionality:
   [#255](https://github.com/input-output-hk/cardano-base/pull/255)
+  [#404](https://github.com/input-output-hk/cardano-base/pull/404)
 * KES started using the new memlocking functionality:
   [#255](https://github.com/input-output-hk/cardano-base/pull/255)
+  [#404](https://github.com/input-output-hk/cardano-base/pull/404)
 * Introduction of `DSIGNM` that uses the new memlocking functionality:
-  [#255](https://github.com/input-output-hk/cardano-base/pull/255)
+  [#404](https://github.com/input-output-hk/cardano-base/pull/404)
 * Included bindings to `blst` library to enable operations over curve BLS12-381
   [#266](https://github.com/input-output-hk/cardano-base/pull/266)
+* Introduction of `DirectSerialise` / `DirectDeserialise` APIs, providing
+  direct access to mlocked keys in RAM:
+  [#404](https://github.com/input-output-hk/cardano-base/pull/404)
+* Restructuring of libsodium bindings and related APIs:
+  [#404](https://github.com/input-output-hk/cardano-base/pull/404)
 
 ## 2.1.0.2
 

diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal
@@ -77,12 +77,8 @@ library
     Cardano.Crypto.Libsodium.Memory.Internal
     Cardano.Crypto.Libsodium.MLockedBytes
     Cardano.Crypto.Libsodium.MLockedBytes.Internal
+    Cardano.Crypto.Libsodium.MLockedSeed
     Cardano.Crypto.Libsodium.UnsafeC
-    Cardano.Crypto.MEqOrd
-    Cardano.Crypto.MLockedSeed
-    Cardano.Crypto.MonadSodium
-    Cardano.Crypto.MonadSodium.Class
-    Cardano.Crypto.MonadSodium.Alloc
     Cardano.Crypto.PinnedSizedBytes
     Cardano.Crypto.Seed
     Cardano.Crypto.Util

diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs
@@ -39,22 +39,26 @@ import Control.Monad.ST.Unsafe (unsafeIOToST)
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 
 import Cardano.Foreign
-import Cardano.Crypto.PinnedSizedBytes
 import Cardano.Crypto.Libsodium.C
-import Cardano.Crypto.Libsodium (MLockedSizedBytes)
-import Cardano.Crypto.MonadSodium
-  ( MonadSodium (..)
+import Cardano.Crypto.Libsodium
+  ( MLockedSizedBytes
   , mlsbToByteString
-  , mlsbFromByteStringCheck
+  , mlsbFromByteStringCheckWith
   , mlsbUseAsSizedPtr
-  , mlsbNew
+  , mlsbNewWith
   , mlsbFinalize
-  , mlsbCopy
-  , MEq (..)
+  , mlsbCopyWith
+  )
+import Cardano.Crypto.PinnedSizedBytes
+  ( PinnedSizedBytes
+  , psbUseAsSizedPtr
+  , psbToByteString
+  , psbFromByteStringCheck
+  , psbCreateSizedResult
   )
 
 import Cardano.Crypto.DSIGNM.Class
-import Cardano.Crypto.MLockedSeed
+import Cardano.Crypto.Libsodium.MLockedSeed
 import Cardano.Crypto.Util (SignableRepresentation(..))
 
 data Ed25519DSIGNM
@@ -83,8 +87,8 @@ cOrError action = do
     else
       Just <$> unsafeIOToST getErrno
 
--- | Throws an appropriate 'IOException' when 'Just' an 'Errno' is given.
-throwOnErrno :: (MonadThrow m) => String -> String -> Maybe Errno -> m ()
+-- | Throws an error when 'Just' an 'Errno' is given.
+throwOnErrno :: MonadThrow m => String -> String -> Maybe Errno -> m ()
 throwOnErrno contextDesc cFunName maybeErrno = do
   case maybeErrno of
     Just errno -> throwIO $ errnoToIOError (contextDesc ++ ": " ++ cFunName) errno Nothing Nothing
@@ -171,7 +175,7 @@ instance DSIGNMAlgorithmBase Ed25519DSIGNM where
 -- reflects this.
 --
 -- Various libsodium primitives, particularly 'MLockedSizedBytes' primitives,
--- are used via the 'MonadSodium' typeclass, which is responsible for
+-- are used via the 'MonadST' typeclass, which is responsible for
 -- guaranteeing orderly execution of these actions. We avoid using these
 -- primitives inside 'unsafeIOToST', as well as any 'IO' actions that would be
 -- unsafe to use inside 'unsafePerformIO'.
@@ -186,14 +190,13 @@ instance DSIGNMAlgorithmBase Ed25519DSIGNM where
 --   memory passed to them via C pointers.
 -- - 'getErrno'; however, 'ST' guarantees sequentiality in the context where
 --   we use 'getErrno', so this is fine.
--- - 'BS.useAsCStringLen', which is fine and shouldn't require 'IO' to begin
---   with, but unfortunately, for historical reasons, does.
-instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DSIGNM where
+instance DSIGNMAlgorithm Ed25519DSIGNM where
     deriveVerKeyDSIGNM (SignKeyEd25519DSIGNM sk) =
       VerKeyEd25519DSIGNM <$!> do
         mlsbUseAsSizedPtr sk $ \skPtr -> do
-          (psb, maybeErrno) <- withLiftST $ \fromST -> fromST $ do
-              psbCreateSizedResult $ \pkPtr ->
+          (psb, maybeErrno) <-
+            psbCreateSizedResult $ \pkPtr ->
+              withLiftST $ \fromST -> fromST $ do
                 cOrError $ unsafeIOToST $
                   c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr
           throwOnErrno "deriveVerKeyDSIGNM @Ed25519DSIGNM" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno
@@ -204,8 +207,9 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS
       let bs = getSignableRepresentation a
       in SigEd25519DSIGNM <$!> do
           mlsbUseAsSizedPtr sk $ \skPtr -> do
-            (psb, maybeErrno) <- withLiftST $ \fromST -> fromST $ do
-                psbCreateSizedResult $ \sigPtr -> do
+            (psb, maybeErrno) <-
+              psbCreateSizedResult $ \sigPtr -> do
+                withLiftST $ \fromST -> fromST $ do
                   cOrError $ unsafeIOToST $ do
                     BS.useAsCStringLen bs $ \(ptr, len) ->
                       c_crypto_sign_ed25519_detached sigPtr nullPtr (castPtr ptr) (fromIntegral len) skPtr
@@ -215,9 +219,9 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS
     --
     -- Key generation
     --
-    {-# NOINLINE genKeyDSIGNM #-}
-    genKeyDSIGNM seed = SignKeyEd25519DSIGNM <$!> do
-      sk <- mlsbNew
+    {-# NOINLINE genKeyDSIGNMWith #-}
+    genKeyDSIGNMWith allocator seed = SignKeyEd25519DSIGNM <$!> do
+      sk <- mlsbNewWith allocator
       mlsbUseAsSizedPtr sk $ \skPtr ->
         mlockedSeedUseAsCPtr seed $ \seedPtr -> do
           maybeErrno <- withLiftST $ \fromST ->
@@ -230,11 +234,11 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS
         allocaSizedST k =
           unsafeIOToST $ allocaSized $ \ptr -> stToIO $ k ptr
 
-    cloneKeyDSIGNM (SignKeyEd25519DSIGNM sk) =
-      SignKeyEd25519DSIGNM <$!> mlsbCopy sk
+    cloneKeyDSIGNMWith allocator (SignKeyEd25519DSIGNM sk) =
+      SignKeyEd25519DSIGNM <$!> mlsbCopyWith allocator sk
 
-    getSeedDSIGNM _ (SignKeyEd25519DSIGNM sk) = do
-      seed <- mlockedSeedNew
+    getSeedDSIGNMWith allocator _ (SignKeyEd25519DSIGNM sk) = do
+      seed <- mlockedSeedNewWith allocator
       mlsbUseAsSizedPtr sk $ \skPtr ->
         mlockedSeedUseAsSizedPtr seed $ \seedPtr -> do
           maybeErrno <- withLiftST $ \fromST ->
@@ -247,13 +251,9 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS
     --
     -- Secure forgetting
     --
-    forgetSignKeyDSIGNM (SignKeyEd25519DSIGNM sk) = do
-      mlsbFinalize sk
-
-deriving via (MLockedSizedBytes (SizeSignKeyDSIGNM Ed25519DSIGNM))
-  instance (MonadST m, MonadSodium m) => MEq m (SignKeyDSIGNM Ed25519DSIGNM)
+    forgetSignKeyDSIGNMWith _ (SignKeyEd25519DSIGNM sk) = mlsbFinalize sk
 
-instance (MonadST m, MonadSodium m, MonadThrow m) => UnsoundDSIGNMAlgorithm m Ed25519DSIGNM where
+instance UnsoundDSIGNMAlgorithm Ed25519DSIGNM where
     --
     -- Ser/deser (dangerous - do not use in production code)
     --
@@ -266,12 +266,12 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => UnsoundDSIGNMAlgorithm m Ed
       mlockedSeedFinalize seed
       return raw
 
-    rawDeserialiseSignKeyDSIGNM raw = do
-      mseed <- fmap MLockedSeed <$> mlsbFromByteStringCheck raw
+    rawDeserialiseSignKeyDSIGNMWith allocator raw = do
+      mseed <- fmap MLockedSeed <$> mlsbFromByteStringCheckWith allocator raw
       case mseed of
         Nothing -> return Nothing
         Just seed -> do
-          sk <- Just <$> genKeyDSIGNM seed
+          sk <- Just <$> genKeyDSIGNMWith allocator seed
           mlockedSeedFinalize seed
           return sk
 

diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs
@@ -2,7 +2,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -11,6 +10,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
 
 -- | Abstract digital signatures.
 module Cardano.Crypto.DSIGNM.Class
@@ -23,6 +23,10 @@ module Cardano.Crypto.DSIGNM.Class
   , sizeVerKeyDSIGNM
   , sizeSignKeyDSIGNM
   , sizeSigDSIGNM
+  , genKeyDSIGNM
+  , cloneKeyDSIGNM
+  , getSeedDSIGNM
+  , forgetSignKeyDSIGNM
 
     -- * 'SignedDSIGNM' wrapper
   , SignedDSIGNM (..)
@@ -46,6 +50,7 @@ module Cardano.Crypto.DSIGNM.Class
   , UnsoundDSIGNMAlgorithm (..)
   , encodeSignKeyDSIGNM
   , decodeSignKeyDSIGNM
+  , rawDeserialiseSignKeyDSIGNM
   )
 where
 
@@ -56,14 +61,17 @@ import Data.Proxy (Proxy(..))
 import Data.Typeable (Typeable)
 import GHC.Exts (Constraint)
 import GHC.Generics (Generic)
-import GHC.Stack
+import GHC.Stack (HasCallStack)
 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.MLockedSeed
+import Cardano.Crypto.Libsodium.MLockedSeed
+import Cardano.Crypto.Libsodium (MLockedAllocator, mlockedMalloc)
 import Cardano.Crypto.Hash.Class (HashAlgorithm, Hash, hashWith)
 
 class ( Typeable v
@@ -135,23 +143,20 @@ class ( Typeable v
   rawDeserialiseVerKeyDSIGNM  :: ByteString -> Maybe (VerKeyDSIGNM v)
   rawDeserialiseSigDSIGNM     :: ByteString -> Maybe (SigDSIGNM v)
 
-class ( DSIGNMAlgorithmBase v
-      , Monad m
-      )
-      => DSIGNMAlgorithm m v where
+class DSIGNMAlgorithmBase v => DSIGNMAlgorithm v where
 
   --
   -- Metadata and basic key operations
   --
 
-  deriveVerKeyDSIGNM :: SignKeyDSIGNM v -> m (VerKeyDSIGNM v)
+  deriveVerKeyDSIGNM :: (MonadThrow m, MonadST m) => SignKeyDSIGNM v -> m (VerKeyDSIGNM v)
 
   --
   -- Core algorithm operations
   --
 
   signDSIGNM
-    :: (SignableM v a, HasCallStack)
+    :: (SignableM v a, MonadST m, MonadThrow m)
     => ContextDSIGNM v
     -> a
     -> SignKeyDSIGNM v
@@ -161,29 +166,69 @@ class ( DSIGNMAlgorithmBase v
   -- Key generation
   --
 
-  genKeyDSIGNM :: MLockedSeed (SeedSizeDSIGNM v) -> m (SignKeyDSIGNM v)
+  genKeyDSIGNMWith :: (MonadST m, MonadThrow m)
+                   => MLockedAllocator m
+                   -> MLockedSeed (SeedSizeDSIGNM v)
+                   -> m (SignKeyDSIGNM v)
 
-  cloneKeyDSIGNM :: SignKeyDSIGNM v -> m (SignKeyDSIGNM v)
+  cloneKeyDSIGNMWith :: MonadST m => MLockedAllocator m -> SignKeyDSIGNM v -> m (SignKeyDSIGNM v)
 
-  getSeedDSIGNM :: Proxy v -> SignKeyDSIGNM v -> m (MLockedSeed (SeedSizeDSIGNM v))
+  getSeedDSIGNMWith :: (MonadST m, MonadThrow m)
+                    => MLockedAllocator m
+                    -> Proxy v
+                    -> SignKeyDSIGNM v
+                    -> m (MLockedSeed (SeedSizeDSIGNM v))
 
   --
   -- Secure forgetting
   --
 
-  forgetSignKeyDSIGNM :: SignKeyDSIGNM v -> m ()
+  forgetSignKeyDSIGNMWith :: (MonadST m, MonadThrow m) => MLockedAllocator m -> SignKeyDSIGNM v -> m ()
+
+
+forgetSignKeyDSIGNM :: (DSIGNMAlgorithm v, MonadST m, MonadThrow m) => SignKeyDSIGNM v -> m ()
+forgetSignKeyDSIGNM = forgetSignKeyDSIGNMWith mlockedMalloc
+
+
+genKeyDSIGNM ::
+     (DSIGNMAlgorithm v, MonadST m, MonadThrow m)
+  => MLockedSeed (SeedSizeDSIGNM v)
+  -> m (SignKeyDSIGNM v)
+genKeyDSIGNM = genKeyDSIGNMWith mlockedMalloc
+
+cloneKeyDSIGNM ::
+  (DSIGNMAlgorithm v, MonadST m) => SignKeyDSIGNM v -> m (SignKeyDSIGNM v)
+cloneKeyDSIGNM = cloneKeyDSIGNMWith mlockedMalloc
+
+getSeedDSIGNM ::
+     (DSIGNMAlgorithm v, MonadST m, MonadThrow m)
+  => Proxy v
+  -> SignKeyDSIGNM v
+  -> m (MLockedSeed (SeedSizeDSIGNM v))
+getSeedDSIGNM = getSeedDSIGNMWith mlockedMalloc
+
 
 -- | 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 m v => UnsoundDSIGNMAlgorithm m v where
+class DSIGNMAlgorithm v => UnsoundDSIGNMAlgorithm v where
   --
   -- Serialisation/(de)serialisation in fixed-size raw format
   --
 
-  rawSerialiseSignKeyDSIGNM   :: SignKeyDSIGNM v -> m ByteString
+  rawSerialiseSignKeyDSIGNM ::
+    (MonadST m, MonadThrow m) => SignKeyDSIGNM v -> m ByteString
+
+  rawDeserialiseSignKeyDSIGNMWith ::
+    (MonadST m, MonadThrow m) => MLockedAllocator m -> ByteString -> m (Maybe (SignKeyDSIGNM v))
+
+rawDeserialiseSignKeyDSIGNM ::
+     (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m)
+  => ByteString
+  -> m (Maybe (SignKeyDSIGNM v))
+rawDeserialiseSignKeyDSIGNM =
+  rawDeserialiseSignKeyDSIGNMWith mlockedMalloc
 
-  rawDeserialiseSignKeyDSIGNM :: ByteString -> m (Maybe (SignKeyDSIGNM v))
 
 --
 -- Do not provide Ord instances for keys, see #38
@@ -221,7 +266,10 @@ sizeSigDSIGNM     _ = fromInteger (natVal (Proxy @(SizeSigDSIGNM v)))
 encodeVerKeyDSIGNM :: DSIGNMAlgorithmBase v => VerKeyDSIGNM v -> Encoding
 encodeVerKeyDSIGNM = encodeBytes . rawSerialiseVerKeyDSIGNM
 
-encodeSignKeyDSIGNM :: (UnsoundDSIGNMAlgorithm m v) => SignKeyDSIGNM v -> m Encoding
+encodeSignKeyDSIGNM ::
+     (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m)
+  => SignKeyDSIGNM v
+  -> m Encoding
 encodeSignKeyDSIGNM = fmap encodeBytes . rawSerialiseSignKeyDSIGNM
 
 encodeSigDSIGNM :: DSIGNMAlgorithmBase v => SigDSIGNM v -> Encoding
@@ -242,7 +290,7 @@ decodeVerKeyDSIGNM = do
           actual   = BS.length bs
 
 decodeSignKeyDSIGNM :: forall m v s
-                     . (UnsoundDSIGNMAlgorithm m v)
+                     . (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m)
                     => Decoder s (m (SignKeyDSIGNM v))
 decodeSignKeyDSIGNM = do
     bs <- decodeBytes
@@ -282,7 +330,7 @@ instance DSIGNMAlgorithmBase v => NoThunks (SignedDSIGNM v a)
   -- use generic instance
 
 signedDSIGNM
-  :: (DSIGNMAlgorithm m v, SignableM v a)
+  :: (DSIGNMAlgorithm v, SignableM v a, MonadST m, MonadThrow m)
   => ContextDSIGNM v
   -> a
   -> SignKeyDSIGNM v