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/Data/Digest/Internal.hsc | 145 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 145 insertions(+) create mode 100644 src/Data/Digest/Internal.hsc (limited to 'src/Data/Digest/Internal.hsc') 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) -- cgit v1.2.3