From 7aeeadd0647bfa649b9af859fe5dd7b5cc52afe9 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Sat, 24 Mar 2018 21:21:20 -0400 Subject: Implement HMAC --- src/Data/Digest/Internal.hsc | 4 +- src/Data/Hmac.hsc | 132 ++++++++++++++++++++++++++++++++++ src/Foreign/Ptr/ConstantTimeEquals.hs | 17 +++++ 3 files changed, 152 insertions(+), 1 deletion(-) create mode 100644 src/Data/Hmac.hsc create mode 100644 src/Foreign/Ptr/ConstantTimeEquals.hs (limited to 'src') diff --git a/src/Data/Digest/Internal.hsc b/src/Data/Digest/Internal.hsc index a7f19d7..8906797 100644 --- a/src/Data/Digest/Internal.hsc +++ b/src/Data/Digest/Internal.hsc @@ -28,6 +28,9 @@ type LazyByteString = ByteString.Lazy.ByteString -- | The BoringSSL @ENGINE@ type. data Engine +noEngine :: Ptr Engine +noEngine = nullPtr + -- | The BoringSSL @EVP_MD@ type, representing a hash algorithm. data EvpMd @@ -137,7 +140,6 @@ hash (Algorithm md) bytes = 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. diff --git a/src/Data/Hmac.hsc b/src/Data/Hmac.hsc new file mode 100644 index 0000000..26a797b --- /dev/null +++ b/src/Data/Hmac.hsc @@ -0,0 +1,132 @@ +{-# OPTIONS_GHC -Wno-missing-methods #-} + +module Data.Hmac + ( SecretKey(SecretKey) + , Hmac + , hmac + ) where + +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 Foreign + (FinalizerPtr, ForeignPtr, Ptr, Storable(alignment, peek, sizeOf), + addForeignPtrFinalizer, alloca, allocaArray, mallocForeignPtr, + withForeignPtr) +import Foreign.C.Types +import Foreign.Marshal.Unsafe (unsafeLocalState) +import Unsafe.Coerce (unsafeCoerce) + +import Data.Digest.Internal + (Algorithm(Algorithm), Digest(Digest), Engine, EvpMd, + alwaysSucceeds, evpMaxMdSize, noEngine, requireSuccess) +import Foreign.Ptr.ConstantTimeEquals (constantTimeEquals) + +type LazyByteString = ByteString.Lazy.ByteString + +#include + +-- First, we build basic bindings to the BoringSSL HMAC interface. + +-- | The BoringSSL @HMAC_CTX@ type, representing the state of a pending HMAC +-- operation. +data HmacCtx + +instance Storable HmacCtx where + sizeOf _ = #size HMAC_CTX + alignment _ = #alignment HMAC_CTX + +-- Imported functions from BoringSSL. See +-- https://commondatastorage.googleapis.com/chromium-boringssl-docs/hmac.h.html +-- for documentation. + +foreign import ccall "openssl/hmac.h HMAC_CTX_init" + hmacCtxInit :: Ptr HmacCtx -> IO () + +foreign import ccall "openssl/hmac.h HMAC_Init_ex" + hmacInitEx' :: + Ptr HmacCtx -> Ptr a -> CSize -> Ptr EvpMd -> Ptr Engine -> IO CInt + +foreign import ccall "openssl/hmac.h HMAC_Update" + hmacUpdate' :: Ptr HmacCtx -> Ptr CUChar -> CSize -> IO CInt + +foreign import ccall "openssl/hmac.h HMAC_Final" + hmacFinal' :: Ptr HmacCtx -> Ptr CUChar -> Ptr CUInt -> IO CInt + +-- Some of these functions return 'CInt' even though they can never fail. Wrap +-- them to prevent warnings. + +hmacUpdate :: Ptr HmacCtx -> Ptr CUChar -> CSize -> IO () +hmacUpdate ctx bytes size = alwaysSucceeds $ hmacUpdate' ctx bytes size + +-- Convert functions that can in fact fail to throw exceptions instead. + +hmacInitEx :: Ptr HmacCtx -> Ptr a -> CSize -> Ptr EvpMd -> Ptr Engine -> IO () +hmacInitEx ctx bytes size md engine = + requireSuccess $ hmacInitEx' ctx bytes size md engine + +hmacFinal :: Ptr HmacCtx -> Ptr CUChar -> Ptr CUInt -> IO () +hmacFinal ctx out outSize = requireSuccess $ hmacFinal' ctx out outSize + +-- Now we can build a memory-safe allocator. + +-- | Memory-safe allocator for 'HmacCtx'. +mallocHmacCtx :: IO (ForeignPtr HmacCtx) +mallocHmacCtx = do + fp <- mallocForeignPtr + withForeignPtr fp hmacCtxInit + addForeignPtrFinalizer hmacCtxCleanup fp + return fp + +foreign import ccall "&HMAC_CTX_cleanup" + hmacCtxCleanup :: FinalizerPtr HmacCtx + +-- Finally, we're ready to actually implement the HMAC interface. + +-- | A secret key used as input to a cipher or HMAC. Equality comparisons on +-- this type are variable-time. +newtype SecretKey = SecretKey ByteString + deriving (Eq, Ord, Show) + +-- | A hash-based message authentication code. Equality comparisons on this type +-- are constant-time. +newtype Hmac = Hmac ByteString + +instance Eq Hmac where + (Hmac a) == (Hmac b) = + unsafeLocalState $ + ByteString.unsafeUseAsCStringLen a $ \(a', size) -> + ByteString.unsafeUseAsCStringLen b $ \(b', _) -> + constantTimeEquals a' b' size + +instance Show Hmac where + show (Hmac m) = show (Digest m) + +-- | Creates an HMAC according to the given 'Algorithm'. +hmac :: Algorithm -> SecretKey -> LazyByteString -> Hmac +hmac (Algorithm md) (SecretKey key) bytes = + unsafeLocalState $ do + ctxFP <- mallocHmacCtx + withForeignPtr ctxFP $ \ctx -> do + ByteString.unsafeUseAsCStringLen key $ \(keyBytes, keySize) -> + hmacInitEx ctx keyBytes (fromIntegral keySize) md noEngine + mapM_ (updateBytes ctx) (ByteString.Lazy.toChunks bytes) + m <- + allocaArray (fromIntegral evpMaxMdSize) $ \hmacOut -> + alloca $ \pOutSize -> do + hmacFinal ctx hmacOut pOutSize + outSize <- fromIntegral <$> peek pOutSize + -- As in 'Data.Digest.Internal', 'hmacOut' is a 'Ptr CUChar'. Have + -- GHC reinterpret it as a 'Ptr CChar' so that it can be ingested + -- into a 'ByteString'. + ByteString.packCStringLen (unsafeCoerce hmacOut, outSize) + return (Hmac m) + where + updateBytes ctx chunk = + -- 'hmacUpdate' treats its @bytes@ argument as @const@, so the sharing + -- inherent in 'ByteString.unsafeUseAsCStringLen' is fine. + ByteString.unsafeUseAsCStringLen chunk $ \(buf, len) -> + -- 'buf' is a 'Ptr CChar', but 'hmacUpdate' takes a 'Ptr CUChar', so we + -- do the 'unsafeCoerce' dance yet again. + hmacUpdate ctx (unsafeCoerce buf) (fromIntegral len) diff --git a/src/Foreign/Ptr/ConstantTimeEquals.hs b/src/Foreign/Ptr/ConstantTimeEquals.hs new file mode 100644 index 0000000..bb8d2d4 --- /dev/null +++ b/src/Foreign/Ptr/ConstantTimeEquals.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Foreign.Ptr.ConstantTimeEquals where + +import Foreign (Ptr) +import Foreign.C.Types + +foreign import ccall "openssl/mem.h CRYPTO_memcmp" + cryptoMemcmp :: Ptr a -> Ptr a -> CSize -> IO CInt + +-- | Directly compares two buffers for equality. This operation takes an amount +-- of time dependent on the specified size but independent of either buffer's +-- contents. +constantTimeEquals :: Ptr a -> Ptr a -> Int -> IO Bool +constantTimeEquals a b size = + let size' = fromIntegral size :: CSize + in (== 0) <$> cryptoMemcmp a b size' -- cgit v1.2.3