From 45a29b37173ab724d8b90af7e0b1a9fda3acbeb2 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Sat, 27 Jan 2018 17:05:58 -0500 Subject: Data.Digest: Switch back to EVP Use the finalizer techniques demonstrated in 4e56c79b907da4a4654e5278bdcf94b08480a426 to safely allocate `EVP_MD_CTX` on the Haskell heap. This allows us to return to the high-level EVP API, eliminating much boilerplate code. --- src/Cleanse.hsc | 62 ------------------ src/Data/Digest/Internal.hs | 92 --------------------------- src/Data/Digest/Internal.hsc | 145 +++++++++++++++++++++++++++++++++++++++++++ src/Data/Digest/Md5.hs | 12 ++++ src/Data/Digest/Md5.hsc | 38 ------------ src/Data/Digest/Sha1.hs | 12 ++++ src/Data/Digest/Sha1.hsc | 38 ------------ src/Data/Digest/Sha2.hs | 30 +++++++++ src/Data/Digest/Sha2.hsc | 109 -------------------------------- 9 files changed, 199 insertions(+), 339 deletions(-) delete mode 100644 src/Cleanse.hsc delete mode 100644 src/Data/Digest/Internal.hs create mode 100644 src/Data/Digest/Internal.hsc create mode 100644 src/Data/Digest/Md5.hs delete mode 100644 src/Data/Digest/Md5.hsc create mode 100644 src/Data/Digest/Sha1.hs delete mode 100644 src/Data/Digest/Sha1.hsc create mode 100644 src/Data/Digest/Sha2.hs delete mode 100644 src/Data/Digest/Sha2.hsc (limited to 'src') diff --git a/src/Cleanse.hsc b/src/Cleanse.hsc deleted file mode 100644 index bb60945..0000000 --- a/src/Cleanse.hsc +++ /dev/null @@ -1,62 +0,0 @@ -{-# 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 - -#include - --- 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 deleted file mode 100644 index 1538276..0000000 --- a/src/Data/Digest/Internal.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE Rank2Types #-} - -module Data.Digest.Internal where - -import Control.Exception (assert) -import Data.Bits (Bits((.&.)), shiftR) -import Data.ByteString (ByteString) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as ByteString.Lazy -import qualified Data.ByteString.Unsafe as ByteString -import Data.Char (intToDigit) -import Data.Word (Word8) -import Foreign (Ptr, Storable, allocaArray, throwIf_, withForeignPtr) -import Foreign.C.Types -import Foreign.Marshal.Unsafe (unsafeLocalState) -import Unsafe.Coerce (unsafeCoerce) - -import Cleanse (mallocCleansablePtr) - -type LazyByteString = ByteString.Lazy.ByteString - --- | A hash algorithm which follows the standard initialize-update-finalize --- pattern. -data Algo = forall ctx. Storable ctx => Algo - { mdLen :: CSize -- ^ The length of the digest. - , mdInit :: Ptr ctx -> IO CInt -- ^ Initializes the context. Must return 1. - -- | Adds the buffer to the context. Must not modify the buffer. Must return - -- 1. - , mdUpdate :: forall a. Ptr ctx -> Ptr a -> CSize -> IO CInt - -- | Adds final padding to the context and writes the digest to the buffer. - , mdFinal :: Ptr CUChar -> Ptr ctx -> IO CInt - } - --- The type signatures in 'Algo' are suggestive of the functions exposed by the --- BoringSSL API. Those functions fall into two broad categories--those which --- always return 1 and those which return 1 only on success. - -alwaysSucceeds :: IO CInt -> IO () -alwaysSucceeds f = do - r <- f - assert (r == 1) (return ()) - -requireSuccess :: IO CInt -> IO () -requireSuccess f = throwIf_ (/= 1) (const "BoringSSL failure") f - --- | The result of a hash operation. -newtype Digest = - Digest ByteString - deriving (Eq, Ord) - -instance Show Digest where - show (Digest d) = ByteString.foldr showHexPadded [] d - where - showHexPadded b xs = - hexit (b `shiftR` 4 .&. 0x0f) : hexit (b .&. 0x0f) : xs - hexit = intToDigit . fromIntegral :: Word8 -> Char - --- | Hashes according to the given 'Algo'. -hash :: Algo -> LazyByteString -> Digest -hash (Algo {mdLen, mdInit, mdUpdate, mdFinal}) bytes = - let mdLen' = fromIntegral mdLen :: Int - 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 - mapM_ (updateBytes ctx) (ByteString.Lazy.toChunks bytes) - 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, - -- 'CString' is a 'Ptr CChar', and 'CChar' is signed. This is - -- especially unfortunate given that all we really want to do is - -- convert to a 'ByteString', which is unsigned. To work around it, - -- we're going to cheat and let Haskell reinterpret-cast 'mdOut' to - -- 'Ptr CChar' before it does its 'ByteString' ingestion. - ByteString.packCStringLen (unsafeCoerce mdOut, mdLen') - return (Digest d) - where - updateBytes ctx chunk = - -- 'mdUpdate' treats its @buf@ argument as @const@, so the sharing - -- inherent in 'ByteString.unsafeUseAsCStringLen' is fine. - ByteString.unsafeUseAsCStringLen chunk $ \(buf, len) -> - alwaysSucceeds $ mdUpdate ctx buf (fromIntegral len) diff --git a/src/Data/Digest/Internal.hsc b/src/Data/Digest/Internal.hsc new file mode 100644 index 0000000..73edbd9 --- /dev/null +++ b/src/Data/Digest/Internal.hsc @@ -0,0 +1,145 @@ +{-# LANGUAGE CApiFFI #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} + +module Data.Digest.Internal where + +import Control.Exception (assert) +import Data.Bits (Bits((.&.)), shiftR) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as ByteString.Lazy +import qualified Data.ByteString.Unsafe as ByteString +import Data.Char (intToDigit) +import Data.Word (Word8) +import Foreign + (FinalizerPtr, ForeignPtr, Ptr, Storable(alignment, peek, sizeOf), + addForeignPtrFinalizer, alloca, allocaArray, mallocForeignPtr, + nullPtr, throwIf_, withForeignPtr) +import Foreign.C.Types +import Foreign.Marshal.Unsafe (unsafeLocalState) +import Unsafe.Coerce (unsafeCoerce) + +type LazyByteString = ByteString.Lazy.ByteString + +#include + +-- First, we build basic bindings to the BoringSSL EVP interface. + +-- | The BoringSSL @ENGINE@ type. +data Engine + +-- | The BoringSSL @EVP_MD@ type, representing a hash algorithm. +data EvpMd + +-- | A convenience alias for @Ptr EvpMd@. +type Algo = Ptr EvpMd + +-- | The BoringSSL @EVP_MD_CTX@ type, representing the state of a pending +-- hashing operation. +data EvpMdCtx + +instance Storable EvpMdCtx where + sizeOf _ = #size EVP_MD_CTX + alignment _ = #alignment EVP_MD_CTX + +-- Imported functions from BoringSSL. See +-- https://commondatastorage.googleapis.com/chromium-boringssl-docs/digest.h.html +-- for documentation. + +foreign import ccall "openssl/digest.h EVP_MD_CTX_init" + evpMdCtxInit :: Ptr EvpMdCtx -> IO () + +foreign import ccall "openssl/digest.h EVP_DigestInit_ex" + evpDigestInitEx' :: Ptr EvpMdCtx -> Ptr EvpMd -> Ptr Engine -> IO CInt + +foreign import capi "openssl/digest.h value EVP_MAX_MD_SIZE" + evpMaxMdSize :: CSize + +foreign import ccall "openssl/digest.h EVP_DigestUpdate" + evpDigestUpdate' :: Ptr EvpMdCtx -> Ptr a -> CSize -> IO CInt + +foreign import ccall "openssl/digest.h EVP_DigestFinal_ex" + evpDigestFinalEx' :: Ptr EvpMdCtx -> Ptr CUChar -> Ptr CUInt -> IO CInt + +-- Some of these functions return 'CInt' even though they can never fail. Wrap +-- them to prevent warnings. + +alwaysSucceeds :: IO CInt -> IO () +alwaysSucceeds f = do + r <- f + assert (r == 1) (return ()) + +evpDigestUpdate :: Ptr EvpMdCtx -> Ptr a -> CSize -> IO () +evpDigestUpdate ctx md bytes = alwaysSucceeds $ evpDigestUpdate' ctx md bytes + +evpDigestFinalEx :: Ptr EvpMdCtx -> Ptr CUChar -> Ptr CUInt -> IO () +evpDigestFinalEx ctx mdOut outSize = + alwaysSucceeds $ evpDigestFinalEx' ctx mdOut outSize + +-- Convert functions that can in fact fail to throw exceptions instead. + +requireSuccess :: IO CInt -> IO () +requireSuccess f = throwIf_ (/= 1) (const "BoringSSL failure") f + +evpDigestInitEx :: Ptr EvpMdCtx -> Ptr EvpMd -> Ptr Engine -> IO () +evpDigestInitEx ctx md engine = requireSuccess $ evpDigestInitEx' ctx md engine + +-- Now we can build a memory-safe allocator. + +-- | Memory-safe allocator for 'EvpMdCtx'. +mallocEvpMdCtx :: IO (ForeignPtr EvpMdCtx) +mallocEvpMdCtx = do + fp <- mallocForeignPtr + withForeignPtr fp evpMdCtxInit + addForeignPtrFinalizer btlsFinalizeEvpMdCtxPtr fp + return fp + +#def void btlsFinalizeEvpMdCtx(EVP_MD_CTX* const ctx) { + (void)EVP_MD_CTX_cleanup(ctx); +} + +foreign import ccall "&btlsFinalizeEvpMdCtx" + btlsFinalizeEvpMdCtxPtr :: FinalizerPtr EvpMdCtx + +-- Finally, we're ready to actually implement the hashing interface. + +-- | The result of a hash operation. +newtype Digest = + Digest ByteString + deriving (Eq, Ord) + +instance Show Digest where + show (Digest d) = ByteString.foldr showHexPadded [] d + where + showHexPadded b xs = + hexit (b `shiftR` 4 .&. 0x0f) : hexit (b .&. 0x0f) : xs + hexit = intToDigit . fromIntegral :: Word8 -> Char + +-- | Hashes according to the given 'Algo'. +hash :: Algo -> LazyByteString -> Digest +hash md bytes = + unsafeLocalState $ do + ctxFP <- mallocEvpMdCtx + withForeignPtr ctxFP $ \ctx -> do + evpDigestInitEx ctx md noEngine + mapM_ (updateBytes ctx) (ByteString.Lazy.toChunks bytes) + d <- + allocaArray (fromIntegral evpMaxMdSize) $ \mdOut -> + alloca $ \pOutSize -> do + evpDigestFinalEx ctx mdOut pOutSize + outSize <- fromIntegral <$> peek pOutSize + -- 'mdOut' is a 'Ptr CUChar'. However, to make life more + -- interesting, 'CString' is a 'Ptr CChar', and 'CChar' is signed. + -- This is especially unfortunate given that all we really want to + -- do is convert to a 'ByteString', which is unsigned. To work + -- around it, we're going to cheat and let Haskell reinterpret-cast + -- 'mdOut' to 'Ptr CChar' before it does its 'ByteString' ingestion. + ByteString.packCStringLen (unsafeCoerce mdOut, outSize) + return (Digest d) + where + noEngine = nullPtr :: Ptr Engine + updateBytes ctx chunk = + -- 'mdUpdate' treats its @buf@ argument as @const@, so the sharing + -- inherent in 'ByteString.unsafeUseAsCStringLen' is fine. + ByteString.unsafeUseAsCStringLen chunk $ \(buf, len) -> + evpDigestUpdate ctx buf (fromIntegral len) diff --git a/src/Data/Digest/Md5.hs b/src/Data/Digest/Md5.hs new file mode 100644 index 0000000..194633b --- /dev/null +++ b/src/Data/Digest/Md5.hs @@ -0,0 +1,12 @@ +module Data.Digest.Md5 + ( md5 + ) where + +import Data.ByteString.Lazy (ByteString) + +import Data.Digest.Internal + +foreign import ccall "openssl/digest.h EVP_md5" evpMd5 :: Algo + +md5 :: ByteString -> Digest +md5 = hash evpMd5 diff --git a/src/Data/Digest/Md5.hsc b/src/Data/Digest/Md5.hsc deleted file mode 100644 index 2a1303d..0000000 --- a/src/Data/Digest/Md5.hsc +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE CApiFFI #-} -{-# OPTIONS_GHC -Wno-missing-methods #-} - -module Data.Digest.Md5 - ( md5 - ) where - -import Data.ByteString.Lazy (ByteString) -import Foreign (Ptr, Storable(alignment, sizeOf)) -import Foreign.C.Types - -import Data.Digest.Internal - -#include - -data Md5Ctx - -instance Storable Md5Ctx where - sizeOf _ = #size MD5_CTX - alignment _ = #alignment MD5_CTX - -foreign import capi "openssl/md5.h value MD5_DIGEST_LENGTH" - md5DigestLength :: CSize - -foreign import ccall "openssl/md5.h MD5_Init" - md5Init :: Ptr Md5Ctx -> IO CInt - -foreign import ccall "openssl/md5.h MD5_Update" - md5Update :: Ptr Md5Ctx -> Ptr a -> CSize -> IO CInt - -foreign import ccall "openssl/md5.h MD5_Final" - md5Final :: Ptr CUChar -> Ptr Md5Ctx -> IO CInt - -md5Algo :: Algo -md5Algo = Algo md5DigestLength md5Init md5Update md5Final - -md5 :: ByteString -> Digest -md5 = hash md5Algo diff --git a/src/Data/Digest/Sha1.hs b/src/Data/Digest/Sha1.hs new file mode 100644 index 0000000..16101b0 --- /dev/null +++ b/src/Data/Digest/Sha1.hs @@ -0,0 +1,12 @@ +module Data.Digest.Sha1 + ( sha1 + ) where + +import Data.ByteString.Lazy (ByteString) + +import Data.Digest.Internal + +foreign import ccall "openssl/digest.h EVP_sha1" evpSha1 :: Algo + +sha1 :: ByteString -> Digest +sha1 = hash evpSha1 diff --git a/src/Data/Digest/Sha1.hsc b/src/Data/Digest/Sha1.hsc deleted file mode 100644 index 6ac4c34..0000000 --- a/src/Data/Digest/Sha1.hsc +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE CApiFFI #-} -{-# OPTIONS_GHC -Wno-missing-methods #-} - -module Data.Digest.Sha1 - ( sha1 - ) where - -import Data.ByteString.Lazy (ByteString) -import Foreign (Ptr, Storable(alignment, sizeOf)) -import Foreign.C.Types - -import Data.Digest.Internal - -#include - -data ShaCtx - -instance Storable ShaCtx where - sizeOf _ = #size SHA_CTX - alignment _ = #alignment SHA_CTX - -foreign import capi "openssl/sha.h value SHA_DIGEST_LENGTH" - shaDigestLength :: CSize - -foreign import ccall "openssl/sha.h SHA1_Init" - sha1Init :: Ptr ShaCtx -> IO CInt - -foreign import ccall "openssl/sha.h SHA1_Update" - sha1Update :: Ptr ShaCtx -> Ptr a -> CSize -> IO CInt - -foreign import ccall "openssl/sha.h SHA1_Final" - sha1Final :: Ptr CUChar -> Ptr ShaCtx -> IO CInt - -sha1Algo :: Algo -sha1Algo = Algo shaDigestLength sha1Init sha1Update sha1Final - -sha1 :: ByteString -> Digest -sha1 = hash sha1Algo diff --git a/src/Data/Digest/Sha2.hs b/src/Data/Digest/Sha2.hs new file mode 100644 index 0000000..965686c --- /dev/null +++ b/src/Data/Digest/Sha2.hs @@ -0,0 +1,30 @@ +module Data.Digest.Sha2 + ( sha224 + , sha256 + , sha384 + , sha512 + ) where + +import Data.ByteString.Lazy (ByteString) + +import Data.Digest.Internal + +foreign import ccall "openssl/digest.h EVP_sha224" evpSha224 :: Algo + +foreign import ccall "openssl/digest.h EVP_sha256" evpSha256 :: Algo + +foreign import ccall "openssl/digest.h EVP_sha384" evpSha384 :: Algo + +foreign import ccall "openssl/digest.h EVP_sha512" evpSha512 :: Algo + +sha224 :: ByteString -> Digest +sha224 = hash evpSha224 + +sha256 :: ByteString -> Digest +sha256 = hash evpSha256 + +sha384 :: ByteString -> Digest +sha384 = hash evpSha384 + +sha512 :: ByteString -> Digest +sha512 = hash evpSha512 diff --git a/src/Data/Digest/Sha2.hsc b/src/Data/Digest/Sha2.hsc deleted file mode 100644 index aa7c274..0000000 --- a/src/Data/Digest/Sha2.hsc +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE CApiFFI #-} -{-# OPTIONS_GHC -Wno-missing-methods #-} - -module Data.Digest.Sha2 - ( sha224 - , sha256 - , sha384 - , sha512 - ) where - -import Data.ByteString.Lazy (ByteString) -import Foreign (Ptr, Storable(alignment, sizeOf)) -import Foreign.C.Types - -import Data.Digest.Internal - -#include - --- SHA-224 - -foreign import capi "openssl/sha.h value SHA224_DIGEST_LENGTH" - sha224DigestLength :: CSize - -foreign import ccall "openssl/sha.h SHA224_Init" - sha224Init :: Ptr Sha256Ctx -> IO CInt - -foreign import ccall "openssl/sha.h SHA224_Update" - sha224Update :: Ptr Sha256Ctx -> Ptr a -> CSize -> IO CInt - -foreign import ccall "openssl/sha.h SHA224_Final" - sha224Final :: Ptr CUChar -> Ptr Sha256Ctx -> IO CInt - -sha224Algo :: Algo -sha224Algo = Algo sha224DigestLength sha224Init sha224Update sha224Final - -sha224 :: ByteString -> Digest -sha224 = hash sha224Algo - --- SHA-256 - -data Sha256Ctx - -instance Storable Sha256Ctx where - sizeOf _ = #size SHA256_CTX - alignment _ = #alignment SHA256_CTX - -foreign import capi "openssl/sha.h value SHA256_DIGEST_LENGTH" - sha256DigestLength :: CSize - -foreign import ccall "openssl/sha.h SHA256_Init" - sha256Init :: Ptr Sha256Ctx -> IO CInt - -foreign import ccall "openssl/sha.h SHA256_Update" - sha256Update :: Ptr Sha256Ctx -> Ptr a -> CSize -> IO CInt - -foreign import ccall "openssl/sha.h SHA256_Final" - sha256Final :: Ptr CUChar -> Ptr Sha256Ctx -> IO CInt - -sha256Algo :: Algo -sha256Algo = Algo sha256DigestLength sha256Init sha256Update sha256Final - -sha256 :: ByteString -> Digest -sha256 = hash sha256Algo - --- SHA-384 - -foreign import capi "openssl/sha.h value SHA384_DIGEST_LENGTH" - sha384DigestLength :: CSize - -foreign import ccall "openssl/sha.h SHA384_Init" - sha384Init :: Ptr Sha512Ctx -> IO CInt - -foreign import ccall "openssl/sha.h SHA384_Update" - sha384Update :: Ptr Sha512Ctx -> Ptr a -> CSize -> IO CInt - -foreign import ccall "openssl/sha.h SHA384_Final" - sha384Final :: Ptr CUChar -> Ptr Sha512Ctx -> IO CInt - -sha384Algo :: Algo -sha384Algo = Algo sha384DigestLength sha384Init sha384Update sha384Final - -sha384 :: ByteString -> Digest -sha384 = hash sha384Algo - --- SHA-512 - -data Sha512Ctx - -instance Storable Sha512Ctx where - sizeOf _ = #size SHA512_CTX - alignment _ = #alignment SHA512_CTX - -foreign import capi "openssl/sha.h value SHA512_DIGEST_LENGTH" - sha512DigestLength :: CSize - -foreign import ccall "openssl/sha.h SHA512_Init" - sha512Init :: Ptr Sha512Ctx -> IO CInt - -foreign import ccall "openssl/sha.h SHA512_Update" - sha512Update :: Ptr Sha512Ctx -> Ptr a -> CSize -> IO CInt - -foreign import ccall "openssl/sha.h SHA512_Final" - sha512Final :: Ptr CUChar -> Ptr Sha512Ctx -> IO CInt - -sha512Algo :: Algo -sha512Algo = Algo sha512DigestLength sha512Init sha512Update sha512Final - -sha512 :: ByteString -> Digest -sha512 = hash sha512Algo -- cgit v1.2.3