From 7aeeadd0647bfa649b9af859fe5dd7b5cc52afe9 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Sat, 24 Mar 2018 21:21:20 -0400 Subject: Implement HMAC --- btls.cabal | 4 + src/Data/Digest/Internal.hsc | 4 +- src/Data/Hmac.hsc | 132 +++++++++++++++++++++++ src/Foreign/Ptr/ConstantTimeEquals.hs | 17 +++ tests/Data/HmacTests.hs | 194 ++++++++++++++++++++++++++++++++++ tests/Tests.hs | 4 +- 6 files changed, 353 insertions(+), 2 deletions(-) create mode 100644 src/Data/Hmac.hsc create mode 100644 src/Foreign/Ptr/ConstantTimeEquals.hs create mode 100644 tests/Data/HmacTests.hs diff --git a/btls.cabal b/btls.cabal index 63af3db..7b52049 100644 --- a/btls.cabal +++ b/btls.cabal @@ -24,6 +24,7 @@ library , ExistentialQuantification , NamedFieldPuns , Rank2Types + , ScopedTypeVariables build-tools: hsc2hs include-dirs: third_party/boringssl/src/include ghc-options: -Weverything @@ -33,7 +34,9 @@ library -Wno-safe -Wno-unsafe -optl-Wl,-z,relro -optl-Wl,-z,now -optl-Wl,-s exposed-modules: Data.Digest + , Data.Hmac other-modules: Data.Digest.Internal + , Foreign.Ptr.ConstantTimeEquals -- Use special names for the BoringSSL libraries to avoid accidentally pulling -- in OpenSSL. extra-libraries: btls_crypto @@ -59,6 +62,7 @@ test-suite tests , Data.Digest.Md5Tests , Data.Digest.Sha1Tests , Data.Digest.Sha2Tests + , Data.HmacTests build-depends: base >=4.9 && <4.10 , btls , bytestring >=0.10 && <0.11 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' diff --git a/tests/Data/HmacTests.hs b/tests/Data/HmacTests.hs new file mode 100644 index 0000000..7e9d4f7 --- /dev/null +++ b/tests/Data/HmacTests.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.HmacTests + ( tests + ) where + +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as ByteString.Lazy +import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8 +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=), testCase) + +import Data.Digest (md5, sha1, sha224, sha256, sha384, sha512) +import Data.Hmac (SecretKey(SecretKey), hmac) + +type LazyByteString = ByteString.Lazy.ByteString + +tests :: TestTree +tests = testGroup "Data.Hmac" [testRfc2202, testFips198, testRfc4231] + +tableTestCase :: + (SecretKey -> LazyByteString -> String) + -> (SecretKey, LazyByteString, String) + -> TestTree +tableTestCase f (key, input, output) = + testCase (abbreviate input) (f key input @?= output) + +abbreviate :: LazyByteString -> String +abbreviate input = + let (x, y) = splitAt 12 (show input) + in (x ++ + if null y + then "" + else "..." ++ "\"") + +-- | Tests from RFC 2202. +testRfc2202 = testGroup "RFC 2202" [testMd5, testSha1] + where + testMd5 = + testGroup "MD5" $ + map + (tableTestCase hmacMd5) + [ ( SecretKey (ByteString.replicate 16 0x0b) + , "Hi There" + , "9294727a3638bb1c13f48ef8158bfc9d") + , ( SecretKey "Jefe" + , "what do ya want for nothing?" + , "750c783e6ab0b503eaa86e310a5db738") + , ( SecretKey (ByteString.replicate 16 0xaa) + , ByteString.Lazy.replicate 50 0xdd + , "56be34521d144c88dbb8c733f0e8b3f6") + , ( SecretKey (ByteString.pack [0x01 .. 0x19]) + , ByteString.Lazy.replicate 50 0xcd + , "697eaf0aca3a3aea3a75164746ffaa79") + , ( SecretKey (ByteString.replicate 16 0x0c) + , "Test With Truncation" + , "56461ef2342edc00f9bab995690efd4c") + , ( SecretKey (ByteString.replicate 80 0xaa) + , "Test Using Larger Than Block-Size Key - Hash Key First" + , "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd") + , ( SecretKey (ByteString.replicate 80 0xaa) + , "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" + , "6f630fad67cda0ee1fb1f562db3aa53e") + ] + testSha1 = + testGroup "SHA-1" $ + map + (tableTestCase hmacSha1) + [ ( SecretKey (ByteString.replicate 20 0x0b) + , "Hi There" + , "b617318655057264e28bc0b6fb378c8ef146be00") + , ( SecretKey "Jefe" + , "what do ya want for nothing?" + , "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79") + , ( SecretKey (ByteString.replicate 20 0xaa) + , ByteString.Lazy.replicate 50 0xdd + , "125d7342b9ac11cd91a39af48aa17b4f63f175d3") + , ( SecretKey (ByteString.pack [0x01 .. 0x19]) + , ByteString.Lazy.replicate 50 0xcd + , "4c9007f4026250c6bc8414f9bf50c86c2d7235da") + , ( SecretKey (ByteString.replicate 20 0x0c) + , "Test With Truncation" + , "4c1a03424b55e07fe7f27be1d58bb9324a9a5a04") + , ( SecretKey (ByteString.replicate 80 0xaa) + , "Test Using Larger Than Block-Size Key - Hash Key First" + , "aa4ae5e15272d00e95705637ce8a3b55ed402112") + , ( SecretKey (ByteString.replicate 80 0xaa) + , "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" + , "e8e99d0f45237d786d6bbaa7965c7808bbff1a91") + ] + +-- | Tests from FIPS 198. +testFips198 = + testGroup "FIPS 198" $ + map + (tableTestCase hmacSha1) + [ ( SecretKey (ByteString.pack [0 .. 0x3f]) + , "Sample #1" + , "4f4ca3d5d68ba7cc0a1208c9c61e9c5da0403c0a") + , ( SecretKey (ByteString.pack [0x30 .. 0x43]) + , "Sample #2" + , "0922d3405faa3d194f82a45830737d5cc6c75d24") + , ( SecretKey (ByteString.pack [0x50 .. 0xb3]) + , "Sample #3" + , "bcf41eab8bb2d802f3d05caf7cb092ecf8d1a3aa") + ] ++ + [truncatedFips198Test] + +truncatedFips198Test = + let input = "Sample #4" :: String + key = SecretKey (ByteString.pack [0x70 .. 0xa0]) + output = "9ea886efe268dbecce420c75" :: String + in testCase + (show input) + (take 24 (hmacSha1 key (ByteString.Lazy.Char8.pack input)) @?= output) + +rfc4231TestCase :: + (SecretKey, LazyByteString, String, String, String, String) -> TestTree +rfc4231TestCase (key, input, sha224Output, sha256Output, sha384Output, sha512Output) = + testGroup + (abbreviate input) + [ testCase "SHA-224" (hmacSha224 key input @?= sha224Output) + , testCase "SHA-256" (hmacSha256 key input @?= sha256Output) + , testCase "SHA-384" (hmacSha384 key input @?= sha384Output) + , testCase "SHA-512" (hmacSha512 key input @?= sha512Output) + ] + +-- | Tests from RFC 4231. +testRfc4231 = + testGroup "RFC 4231" $ + map + rfc4231TestCase + [ ( SecretKey (ByteString.replicate 20 0x0b) + , "Hi There" + , "896fb1128abbdf196832107cd49df33f47b4b1169912ba4f53684b22" + , "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" + , "afd03944d84895626b0825f4ab46907f15f9dadbe4101ec682aa034c7cebc59cfaea9ea9076ede7f4af152e8b2fa9cb6" + , "87aa7cdea5ef619d4ff0b4241a1d6cb02379f4e2ce4ec2787ad0b30545e17cdedaa833b7d6b8a702038b274eaea3f4e4be9d914eeb61f1702e696c203a126854") + , ( SecretKey "Jefe" + , "what do ya want for nothing?" + , "a30e01098bc6dbbf45690f3a7e9e6d0f8bbea2a39e6148008fd05e44" + , "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843" + , "af45d2e376484031617f78d2b58a6b1b9c7ef464f5a01b47e42ec3736322445e8e2240ca5e69e2c78b3239ecfab21649" + , "164b7a7bfcf819e2e395fbe73b56e0a387bd64222e831fd610270cd7ea2505549758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737") + , ( SecretKey (ByteString.replicate 20 0xaa) + , ByteString.Lazy.replicate 50 0xdd + , "7fb3cb3588c6c1f6ffa9694d7d6ad2649365b0c1f65d69d1ec8333ea" + , "773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe" + , "88062608d3e6ad8a0aa2ace014c8a86f0aa635d947ac9febe83ef4e55966144b2a5ab39dc13814b94e3ab6e101a34f27" + , "fa73b0089d56a284efb0f0756c890be9b1b5dbdd8ee81a3655f83e33b2279d39bf3e848279a722c806b485a47e67c807b946a337bee8942674278859e13292fb") + , ( SecretKey (ByteString.pack [0x01 .. 0x19]) + , ByteString.Lazy.replicate 50 0xcd + , "6c11506874013cac6a2abc1bb382627cec6a90d86efc012de7afec5a" + , "82558a389a443c0ea4cc819899f2083a85f0faa3e578f8077a2e3ff46729665b" + , "3e8a69b7783c25851933ab6290af6ca77a9981480850009cc5577c6e1f573b4e6801dd23c4a7d679ccf8a386c674cffb" + , "b0ba465637458c6990e5a8c5f61d4af7e576d97ff94b872de76f8050361ee3dba91ca5c11aa25eb4d679275cc5788063a5f19741120c4f2de2adebeb10a298dd") + , ( SecretKey (ByteString.replicate 131 0xaa) + , "Test Using Larger Than Block-Size Key - Hash Key First" + , "95e9a0db962095adaebe9b2d6f0dbce2d499f112f2d2b7273fa6870e" + , "60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54" + , "4ece084485813e9088d2c63a041bc5b44f9ef1012a2b588f3cd11f05033ac4c60c2ef6ab4030fe8296248df163f44952" + , "80b24263c7c1a3ebb71493c1dd7be8b49b46d1f41b4aeec1121b013783f8f3526b56d037e05f2598bd0fd2215d6a1e5295e64f73f63f0aec8b915a985d786598") + , ( SecretKey (ByteString.replicate 131 0xaa) + , "This is a test using a larger than block-size key and a larger than block-size data. The key needs to be hashed before being used by the HMAC algorithm." + , "3a854166ac5d9f023f54d517d0b39dbd946770db9c2b95c9f6f565d1" + , "9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2" + , "6617178e941f020d351e2f254e8fd32c602420feb0b8fb9adccebb82461e99c5a678cc31e799176d3860e6110c46523e" + , "e37b6a775dc87dbaa4dfa9f96e5e3ffddebd71f8867289865df5a32d20cdc944b6022cac3c4982b10d5eeb55c3e4de15134676fb6de0446065c97440fa8c6a58") + ] ++ + [truncatedRfc4231Test] + +truncatedRfc4231Test = + let key = SecretKey (ByteString.replicate 20 0x0c) + input = "Test With Truncation" :: LazyByteString + t f = take 32 (f key input) :: String + in testGroup + (abbreviate input) + [ testCase "SHA-224" (t hmacSha224 @?= "0e2aea68a90c8d37c988bcdb9fca6fa8") + , testCase "SHA-256" (t hmacSha256 @?= "a3b6167473100ee06e0c796c2955552b") + , testCase "SHA-384" (t hmacSha384 @?= "3abf34c3503b2a23a46efc619baef897") + , testCase "SHA-512" (t hmacSha512 @?= "415fad6271580a531d4179bc891d87a6") + ] + +hmacMd5 key bytes = show $ hmac md5 key bytes + +hmacSha1 key bytes = show $ hmac sha1 key bytes + +hmacSha224 key bytes = show $ hmac sha224 key bytes + +hmacSha256 key bytes = show $ hmac sha256 key bytes + +hmacSha384 key bytes = show $ hmac sha384 key bytes + +hmacSha512 key bytes = show $ hmac sha512 key bytes diff --git a/tests/Tests.hs b/tests/Tests.hs index 565ab16..342680d 100644 --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -5,6 +5,8 @@ module Main import Test.Tasty (defaultMain, testGroup) import qualified Data.DigestTests +import qualified Data.HmacTests main :: IO () -main = defaultMain $ testGroup "btls" [Data.DigestTests.tests] +main = + defaultMain $ testGroup "btls" [Data.DigestTests.tests, Data.HmacTests.tests] -- cgit v1.2.3