Merge pull request #504 from IntersectMBO/tdammers/mlocked-kes-for-co…

…nsensus

UnsoundPureKES and DirectSerialise API

cardano-crypto-class/CHANGELOG.md

@@ -20,6 +20,9 @@ solidified. Ask @lehins if backport is needed.
   [#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)
+* Re-introduction of non-mlocked KES implementations to support a smoother
+  migration path:
+  [#504](https://github.com/IntersectMBO/cardano-base/pull/504)
 
 ## 2.1.0.2
 

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

@@ -39,6 +39,7 @@ library
   import:            base, project-config
   hs-source-dirs:    src
   exposed-modules:
+    Cardano.Crypto.DirectSerialise
     Cardano.Crypto.DSIGN
     Cardano.Crypto.DSIGN.Class
     Cardano.Crypto.DSIGN.Ed25519

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -66,14 +67,17 @@ import Cardano.Crypto.Libsodium.MLockedSeed
 import Cardano.Crypto.PinnedSizedBytes
   ( PinnedSizedBytes
   , psbUseAsSizedPtr
+  , psbUseAsCPtrLen
   , psbToByteString
   , psbFromByteStringCheck
+  , psbCreate
   , psbCreateSized
   , psbCreateSizedResult
   )
 import Cardano.Crypto.Seed
 import Cardano.Crypto.Util (SignableRepresentation(..))
 import Cardano.Foreign
+import Cardano.Crypto.DirectSerialise
 
 
 
@@ -261,7 +265,7 @@ instance DSIGNMAlgorithm Ed25519DSIGN where
               stToIO $ do
                 cOrError $ unsafeIOToST $
                   c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr
-          throwOnErrno "deriveVerKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno
+          throwOnErrno "deriveVerKeyDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno
           return psb
 
 
@@ -365,3 +369,48 @@ instance TypeError ('Text "CBOR encoding would violate mlocking guarantees")
 instance TypeError ('Text "CBOR decoding would violate mlocking guarantees")
   => FromCBOR (SignKeyDSIGNM Ed25519DSIGN) where
   fromCBOR = error "unsupported"
+
+instance DirectSerialise (SignKeyDSIGNM Ed25519DSIGN) where
+  -- /Note:/ We only serialize the 32-byte seed, not the full 64-byte key. The
+  -- latter contains both the seed and the 32-byte verification key, which is
+  -- convenient, but redundant, since we can always reconstruct it from the
+  -- seed. This is also reflected in the 'SizeSignKeyDSIGNM', which equals
+  -- 'SeedSizeDSIGNM' == 32, rather than reporting the in-memory size of 64.
+  directSerialise push sk = do
+    bracket
+      (getSeedDSIGNM (Proxy @Ed25519DSIGN) sk)
+      mlockedSeedFinalize
+      (\seed -> mlockedSeedUseAsCPtr seed $ \ptr ->
+          push
+            (castPtr ptr)
+            (fromIntegral $ seedSizeDSIGN (Proxy @Ed25519DSIGN)))
+
+instance DirectDeserialise (SignKeyDSIGNM Ed25519DSIGN) where
+  -- /Note:/ We only serialize the 32-byte seed, not the full 64-byte key. See
+  -- the DirectSerialise instance above.
+  directDeserialise pull = do
+    bracket
+      mlockedSeedNew
+      mlockedSeedFinalize
+      (\seed -> do
+          mlockedSeedUseAsCPtr seed $ \ptr -> do
+            pull
+              (castPtr ptr)
+              (fromIntegral $ seedSizeDSIGN (Proxy @Ed25519DSIGN))
+          genKeyDSIGNM seed
+      )
+
+instance DirectSerialise (VerKeyDSIGN Ed25519DSIGN) where
+  directSerialise push (VerKeyEd25519DSIGN psb) = do
+    psbUseAsCPtrLen psb $ \ptr _ ->
+      push
+        (castPtr ptr)
+        (fromIntegral $ sizeVerKeyDSIGN (Proxy @Ed25519DSIGN))
+
+instance DirectDeserialise (VerKeyDSIGN Ed25519DSIGN) where
+  directDeserialise pull = do
+    psb <- psbCreate $ \ptr ->
+      pull
+        (castPtr ptr)
+        (fromIntegral $ sizeVerKeyDSIGN (Proxy @Ed25519DSIGN))
+    return $! VerKeyEd25519DSIGN psb

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

@@ -0,0 +1,195 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Direct (de-)serialisation to / from raw memory.
+--
+-- The purpose of the typeclasses in this module is to abstract over data
+-- structures that can expose the data they store as one or more raw 'Ptr's,
+-- without any additional memory copying or conversion to intermediate data
+-- structures.
+--
+-- This is useful for transmitting data like KES SignKeys over a socket
+-- connection: by accessing the memory directly and copying it into or out of
+-- a file descriptor, without going through an intermediate @ByteString@
+-- representation (or other data structure that resides in the GHC heap), we
+-- can more easily assure that the data is never written to disk, including
+-- swap, which is an important requirement for KES.
+module Cardano.Crypto.DirectSerialise
+where
+
+import Foreign.Ptr
+import Foreign.C.Types
+import Control.Monad (when)
+import Control.Monad.Class.MonadThrow (MonadThrow)
+import Control.Monad.Class.MonadST (MonadST, stToIO)
+import Control.Exception
+import Data.STRef (newSTRef, readSTRef, writeSTRef)
+import Cardano.Crypto.Libsodium.Memory (copyMem)
+
+data SizeCheckException =
+  SizeCheckException
+    { expectedSize :: Int
+    , actualSize :: Int
+    }
+    deriving (Show)
+
+instance Exception SizeCheckException where
+
+sizeCheckFailed :: Int -> Int -> m ()
+sizeCheckFailed ex ac =
+  throw $ SizeCheckException ex ac
+
+-- | Direct deserialization from raw memory.
+--
+-- @directDeserialise f@ should allocate a new value of type 'a', and
+-- call @f@ with a pointer to the raw memory to be filled. @f@ may be called
+-- multiple times, for data structures that store their data in multiple
+-- non-contiguous blocks of memory.
+--
+-- The order in which memory blocks are visited matters.
+class DirectDeserialise a where
+  directDeserialise :: (MonadST m, MonadThrow m) => (Ptr CChar -> CSize -> m ()) -> m a
+
+-- | Direct serialization to raw memory.
+--
+-- @directSerialise f x@ should call @f@ to expose the raw memory underyling
+-- @x@. For data types that store their data in multiple non-contiguous blocks
+-- of memory, @f@ may be called multiple times, once for each block.
+--
+-- The order in which memory blocks are visited matters.
+class DirectSerialise a where
+  directSerialise :: (MonadST m, MonadThrow m) => (Ptr CChar -> CSize -> m ()) -> a -> m ()
+
+-- | Helper function for bounds-checked serialization.
+-- Verifies that no more than the maximum number of bytes are written, and
+-- returns the actual number of bytes written.
+directSerialiseTo :: forall m a.
+                     DirectSerialise a
+                  => MonadST m
+                  => MonadThrow m
+                  => (Int -> Ptr CChar -> CSize -> m ())
+                  -> Int
+                  -> a
+                  -> m Int
+directSerialiseTo writeBytes dstsize val = do
+  posRef <- stToIO $ newSTRef 0
+  let pusher :: Ptr CChar -> CSize -> m ()
+      pusher src srcsize = do
+        pos <- stToIO $ readSTRef posRef
+        let pos' = pos + fromIntegral srcsize
+        when (pos' > dstsize) $
+            sizeCheckFailed (dstsize - pos) (pos' - pos)
+        writeBytes pos src (fromIntegral srcsize)
+        stToIO $ writeSTRef posRef pos'
+  directSerialise pusher val
+  stToIO $ readSTRef posRef
+
+-- | Helper function for size-checked serialization.
+-- Verifies that exactly the specified number of bytes are written.
+directSerialiseToChecked :: forall m a.
+                            DirectSerialise a
+                         => MonadST m
+                         => MonadThrow m
+                         => (Int -> Ptr CChar -> CSize -> m ())
+                         -> Int
+                         -> a
+                         -> m ()
+directSerialiseToChecked writeBytes dstsize val = do
+  bytesWritten <- directSerialiseTo writeBytes dstsize val
+  when (bytesWritten /= dstsize) $
+    sizeCheckFailed dstsize bytesWritten
+
+-- | Helper function for the common use case of serializing to an in-memory
+-- buffer.
+-- Verifies that no more than the maximum number of bytes are written, and
+-- returns the actual number of bytes written.
+directSerialiseBuf :: forall m a.
+                          DirectSerialise a
+                       => MonadST m
+                       => MonadThrow m
+                       => Ptr CChar
+                       -> Int
+                       -> a
+                       -> m Int
+directSerialiseBuf dst =
+  directSerialiseTo (copyMem . plusPtr dst)
+
+-- | Helper function for size-checked serialization to an in-memory buffer.
+-- Verifies that exactly the specified number of bytes are written.
+directSerialiseBufChecked :: forall m a.
+                            DirectSerialise a
+                         => MonadST m
+                         => MonadThrow m
+                         => Ptr CChar
+                         -> Int
+                         -> a
+                         -> m ()
+directSerialiseBufChecked buf dstsize val = do
+  bytesWritten <- directSerialiseBuf buf dstsize val
+  when (bytesWritten /= dstsize) $
+    sizeCheckFailed dstsize bytesWritten
+
+-- | Helper function for size-checked deserialization.
+-- Verifies that no more than the maximum number of bytes are read, and returns
+-- the actual number of bytes read.
+directDeserialiseFrom :: forall m a.
+                            DirectDeserialise a
+                         => MonadST m
+                         => MonadThrow m
+                         => (Int -> Ptr CChar -> CSize -> m ())
+                         -> Int
+                         -> m (a, Int)
+directDeserialiseFrom readBytes srcsize = do
+  posRef <- stToIO $ newSTRef 0
+  let puller :: Ptr CChar -> CSize -> m ()
+      puller dst dstsize = do
+        pos <- stToIO $ readSTRef posRef
+        let pos' = pos + fromIntegral dstsize
+        when (pos' > srcsize) $
+            sizeCheckFailed (srcsize - pos) (pos' - pos)
+        readBytes pos dst (fromIntegral dstsize)
+        stToIO $ writeSTRef posRef pos'
+  (,) <$> directDeserialise puller <*> stToIO (readSTRef posRef)
+
+-- | Helper function for size-checked deserialization.
+-- Verifies that exactly the specified number of bytes are read.
+directDeserialiseFromChecked :: forall m a.
+                            DirectDeserialise a
+                         => MonadST m
+                         => MonadThrow m
+                         => (Int -> Ptr CChar -> CSize -> m ())
+                         -> Int
+                         -> m a
+directDeserialiseFromChecked readBytes srcsize = do
+  (r, bytesRead) <- directDeserialiseFrom readBytes srcsize
+  when (bytesRead /= srcsize) $
+    sizeCheckFailed srcsize bytesRead
+  return r
+
+-- | Helper function for the common use case of deserializing from an in-memory
+-- buffer.
+-- Verifies that no more than the maximum number of bytes are read, and returns
+-- the actual number of bytes read.
+directDeserialiseBuf :: forall m a.
+                            DirectDeserialise a
+                         => MonadST m
+                         => MonadThrow m
+                         => Ptr CChar
+                         -> Int
+                         -> m (a, Int)
+directDeserialiseBuf src =
+  directDeserialiseFrom (\pos dst -> copyMem dst (plusPtr src pos))
+
+-- | Helper function for size-checked deserialization from an in-memory buffer.
+-- Verifies that exactly the specified number of bytes are read.
+directDeserialiseBufChecked :: forall m a.
+                            DirectDeserialise a
+                         => MonadST m
+                         => MonadThrow m
+                         => Ptr CChar
+                         -> Int
+                         -> m a
+directDeserialiseBufChecked buf srcsize = do
+  (r, bytesRead) <- directDeserialiseBuf buf srcsize
+  when (bytesRead /= srcsize) $
+    sizeCheckFailed srcsize bytesRead
+  return r