Data.Digest.Sha2: Cleanse hash buffers after use

Implement a wrapper for `OPENSSL_cleanse` and use it to securely erase
hash buffers. This matches the behavior of BoringSSL’s all-in-one hash
functions (`SHA256`, `SHA512`, etc.) and memory allocation subsystem.

2 files changed, 75 insertions, 3 deletions

diff --git a/src/Cleanse.hsc b/src/Cleanse.hsc
new file mode 100644
index 0000000..bb60945
--- /dev/null
+++ b/src/Cleanse.hsc
@@ -0,0 +1,62 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | This module wraps BoringSSL's @OPENSSL_cleanse@, which securely overwrites
+-- memory. ("Securely" here means that BoringSSL uses some assembly magic to
+-- prevent the compiler from optimizing out the write.) However, the module
+-- doesn't actually expose @OPENSSL_cleanse@ directly; instead, it lets you
+-- allocate 'ForeignPtr's with cleansing registered as a finalizer. GHC runs all
+-- 'ForeignPtr' finalizers prior to program termination, which gives the
+-- 'ForeignPtr's allocated this way the approximately same security guarantees
+-- as memory allocated through BoringSSL's allocator interface. In particular,
+-- unless you exit your program through GHC's foreign function interface, all
+-- memory allocated through 'mallocCleansablePtr' will be forcibly cleared prior
+-- to program exit.
+module Cleanse
+  ( mallocCleansablePtr
+  ) where
+
+import Foreign
+       (FinalizerPtr, ForeignPtr, Storable(poke, sizeOf),
+        addForeignPtrFinalizer, mallocForeignPtrBytes, withForeignPtr)
+import Foreign.C.Types
+import Foreign.ForeignPtr.Compat (plusForeignPtr)
+
+#include <stddef.h>
+
+#include <openssl/mem.h>
+
+-- We implement 'mallocCleansablePtr' using the standard allocator technique of
+-- saving the allocated region size immediately before the allocated region.
+
+#def struct __attribute__((__packed__)) Buffer {
+  size_t size;
+  char data[];
+};
+
+bufferSize :: Int
+bufferSize = #size struct Buffer
+
+dataOffset :: Int
+dataOffset = #offset struct Buffer, data
+
+mallocCleansablePtr :: forall a. Storable a => IO (ForeignPtr a)
+mallocCleansablePtr = do
+  -- Allocate the buffer.
+  let dataSize = sizeOf (undefined :: a)
+  fp <- mallocForeignPtrBytes (bufferSize + dataSize)
+  -- Save the data size.
+  withForeignPtr fp $ \p -> poke p (fromIntegral dataSize :: CSize)
+  -- Now that the size is saved, we can register the cleansing finalizer. This
+  -- will look at the size and wipe the buffer.
+  addForeignPtrFinalizer btlsCleansePtr fp
+  -- Return a pointer to the data region.
+  return (fp `plusForeignPtr` dataOffset :: ForeignPtr a)
+
+-- The cleansing finalizer itself is totally straightforward.
+
+#def void btlsCleanse(struct Buffer* const p) {
+  OPENSSL_cleanse(p->data, p->size);
+}
+
+foreign import ccall "&btlsCleanse"
+  btlsCleansePtr :: FinalizerPtr a
diff --git a/src/Data/Digest/Internal.hs b/src/Data/Digest/Internal.hs
index 8e723ee..acfb70c 100644
--- a/src/Data/Digest/Internal.hs
+++ b/src/Data/Digest/Internal.hs
@@ -11,11 +11,13 @@ import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Unsafe as ByteString
 import Data.Char (intToDigit)
 import Data.Word (Word8)
-import Foreign (Ptr, Storable, alloca, allocaArray, throwIf_)
+import Foreign (Ptr, Storable, allocaArray, throwIf_, withForeignPtr)
 import Foreign.C.Types
 import Foreign.Marshal.Unsafe (unsafeLocalState)
 import Unsafe.Coerce (unsafeCoerce)
 
+import Cleanse (mallocCleansablePtr)
+
 -- | A hash algorithm which follows the standard initialize-update-finalize
 -- pattern.
 data Algo = forall ctx. Storable ctx => Algo
@@ -56,14 +58,22 @@ instance Show Digest where
 hash :: Algo -> ByteString -> Digest
 hash (Algo {mdLen, mdInit, mdUpdate, mdFinal}) bytes =
   let mdLen' = fromIntegral mdLen :: Int
-  in unsafeLocalState $
-     alloca $ \ctx -> do
+  in unsafeLocalState $ do
+     -- Allocate cleansable space for the hash context. This matches the
+     -- behavior of the all-in-one hash functions in BoringSSL (@SHA256@,
+     -- @SHA512@, etc.) which cleanse their buffers prior to returning.
+     ctxFP <- mallocCleansablePtr
+     withForeignPtr ctxFP $ \ctx -> do
        alwaysSucceeds $ mdInit ctx
        -- 'mdUpdate' treats its @buf@ argument as @const@, so the sharing
        -- inherent in 'ByteString.unsafeUseAsCStringLen' is fine.
        ByteString.unsafeUseAsCStringLen bytes $ \(buf, len) ->
          alwaysSucceeds $ mdUpdate ctx buf (fromIntegral len)
        d <-
+         -- We could allocate another cleansable 'ForeignPtr' to store the
+         -- digest, but we're going to be returning a copy of it as a ByteString
+         -- anyway, so there's not really any point. Use 'allocaArray'; it's
+         -- faster and simpler.
          allocaArray mdLen' $ \mdOut -> do
            requireSuccess $ mdFinal mdOut ctx
            -- 'mdOut' is a 'Ptr CUChar'. However, to make life more interesting,