From a31daa3545c0a8cb5f95e88d66cfcee55a7ee925 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Sat, 1 Sep 2018 15:12:30 -0400 Subject: Enable error checking for HMAC computations --- README.md | 2 +- btls.cabal | 3 +++ src/BTLS/BoringSSL/HMAC.chs | 2 +- src/BTLS/BoringSSLPatterns.hs | 33 ++------------------------------- src/BTLS/Result.hs | 33 +++++++++++++++++++++++++++++++-- src/Data/Digest.hs | 15 +++++++++------ src/Data/HMAC.hs | 24 +++++++++++++++--------- tests/Data/HMACTests.hs | 38 +++++++++++++++++++------------------- 8 files changed, 81 insertions(+), 69 deletions(-) diff --git a/README.md b/README.md index e0e711d..7d3f21f 100644 --- a/README.md +++ b/README.md @@ -30,7 +30,7 @@ btls needs GHC, c2hs and a few Haskell libraries to build. On Debian, should get you everything you need; you can also run - apt install libghc-{base16-bytestring,smallcheck,tasty,tasty-hunit,tasty-smallcheck}-dev + apt install libghc-{base16-bytestring,monad-loops,smallcheck,tasty,tasty-hunit,tasty-smallcheck}-dev if you want to install everything you can through APT instead of Cabal. Once you’ve done so, you can build and run the test suite. diff --git a/btls.cabal b/btls.cabal index b296e3d..c75c448 100644 --- a/btls.cabal +++ b/btls.cabal @@ -90,6 +90,8 @@ library extra-libraries: btls_crypto build-depends: base >=4.9 && <4.10 , bytestring >=0.10 && <0.11 + , monad-loops >=0.4.3 && <0.5 + , transformers >=0.5.2 && <0.6 test-suite tests type: exitcode-stdio-1.0 @@ -121,6 +123,7 @@ test-suite tests -Wunused-matches -Wunused-type-variables -Wwrong-do-bind + -threaded -optl-Wl,-z,relro -optl-Wl,-z,now -optl-Wl,-s main-is: Tests.hs other-modules: Codec.Crypto.HKDFTests diff --git a/src/BTLS/BoringSSL/HMAC.chs b/src/BTLS/BoringSSL/HMAC.chs index b708f85..ea9fd03 100644 --- a/src/BTLS/BoringSSL/HMAC.chs +++ b/src/BTLS/BoringSSL/HMAC.chs @@ -39,7 +39,7 @@ foreign import ccall "&HMAC_CTX_cleanup" {#fun HMAC_Init_ex as hmacInitEx {`Ptr HMACCtx', unsafeUseAsCBuffer* `ByteString'&, `Ptr EVPMD', `Ptr Engine'} - -> `()' requireSuccess*-#} + -> `Int'#} {#fun HMAC_Update as hmacUpdate {`Ptr HMACCtx', unsafeUseAsCBuffer* `ByteString'&} -> `()' alwaysSucceeds*-#} diff --git a/src/BTLS/BoringSSLPatterns.hs b/src/BTLS/BoringSSLPatterns.hs index b7fe223..8d852a1 100644 --- a/src/BTLS/BoringSSLPatterns.hs +++ b/src/BTLS/BoringSSLPatterns.hs @@ -13,44 +13,15 @@ -- the License. module BTLS.BoringSSLPatterns - ( initUpdateFinalize - , onBufferOfMaxSize + ( onBufferOfMaxSize ) where import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as ByteString.Lazy -import Foreign (ForeignPtr, Storable(peek), Ptr, alloca, allocaArray, withForeignPtr) +import Foreign (Storable(peek), Ptr, alloca, allocaArray) import Foreign.C.Types -import BTLS.BoringSSL.Digest (evpMaxMDSize) import BTLS.Buffer (packCUStringLen) -type LazyByteString = ByteString.Lazy.ByteString - --- | Encapsulates a common pattern of operation between hashing and HMAC --- computation. Both of these operations require an allocated context local to --- the operation. The context gets initialized once, updated repeatedly, and --- then finalized. Finally, we read the result out of a buffer produced by the --- finalizer. --- --- The updater must not mutate any argument other than the context. --- --- If all arguments are safe to use under 'unsafeLocalState', this whole --- function is safe to use under 'unsafeLocalState'. -initUpdateFinalize :: - IO (ForeignPtr ctx) - -> (Ptr ctx -> IO ()) - -> (Ptr ctx -> ByteString -> IO ()) - -> (Ptr ctx -> Ptr CUChar -> Ptr CUInt -> IO ()) - -> LazyByteString - -> IO ByteString -initUpdateFinalize mallocCtx initialize update finalize bytes = do - ctxFP <- mallocCtx - withForeignPtr ctxFP $ \ctx -> do - initialize ctx - mapM_ (update ctx) (ByteString.Lazy.toChunks bytes) - onBufferOfMaxSize evpMaxMDSize (finalize ctx) - -- | Allocates a buffer, runs a function 'f' to partially fill it, and packs the -- filled data into a 'ByteString'. 'f' must write the size of the filled data, -- in bytes and not including any trailing null, into its second argument. diff --git a/src/BTLS/Result.hs b/src/BTLS/Result.hs index 7cd5839..63626bd 100644 --- a/src/BTLS/Result.hs +++ b/src/BTLS/Result.hs @@ -14,11 +14,15 @@ module BTLS.Result ( alwaysSucceeds, requireSuccess - , Error, file, line, errorData, errorDataIsHumanReadable + , Result, Error, file, line, errorData, errorDataIsHumanReadable + , check ) where +import Control.Concurrent (rtsSupportsBoundThreads, runInBoundThread) import Control.Exception (assert) -import Control.Monad (when) +import Control.Monad (guard, unless, when) +import Control.Monad.Loops (unfoldM) +import Control.Monad.Trans.Except (ExceptT(ExceptT)) import Data.Bits ((.&.)) import Data.ByteString (ByteString) import Foreign (allocaArray) @@ -34,6 +38,8 @@ alwaysSucceeds r = assert (r == 1) (return ()) requireSuccess :: CInt -> IO () requireSuccess r = when (r /= 1) $ ioError (userError "BoringSSL failure") +type Result = Either [Error] + data Error = Error { err :: Err , file :: FilePath @@ -52,3 +58,26 @@ instance Show Error where allocaArray len $ \pOut -> do errErrorStringN (err e) pOut len peekCString pOut + +errorFromTuple :: (Err, FilePath, Int, Maybe ByteString, CInt) -> Error +errorFromTuple = uncurry5 Error + +dequeueError :: IO (Maybe Error) +dequeueError = do + e@((Err code), _file, _line, _extra, _flags) <- errGetErrorLineData + guard (code /= 0) + return (Just (errorFromTuple e)) + +check :: IO Int -> ExceptT [Error] IO () +check f = do + unless rtsSupportsBoundThreads $ + error "btls requires the threaded runtime. Please recompile with -threaded." + ExceptT $ runInBoundThread $ do + -- TODO(bbaren): Assert that the error queue is clear + r <- f + if r == 1 + then Right <$> return () + else Left <$> unfoldM dequeueError + +uncurry5 :: (a -> b -> c -> d -> e -> z) -> (a, b, c, d, e) -> z +uncurry5 f (a, b, c, d, e) = f a b c d e diff --git a/src/Data/Digest.hs b/src/Data/Digest.hs index 3e6f263..2faf66e 100644 --- a/src/Data/Digest.hs +++ b/src/Data/Digest.hs @@ -22,11 +22,12 @@ module Data.Digest ) where import qualified Data.ByteString.Lazy as ByteString.Lazy +import Foreign (withForeignPtr) import Foreign.Marshal.Unsafe (unsafeLocalState) import BTLS.BoringSSL.Base import BTLS.BoringSSL.Digest -import BTLS.BoringSSLPatterns (initUpdateFinalize) +import BTLS.BoringSSLPatterns (onBufferOfMaxSize) import BTLS.Types (Algorithm(Algorithm), Digest(Digest)) type LazyByteString = ByteString.Lazy.ByteString @@ -41,8 +42,10 @@ sha512 = Algorithm evpSHA512 -- | Hashes according to the given 'Algorithm'. hash :: Algorithm -> LazyByteString -> Digest -hash (Algorithm md) = - Digest - . unsafeLocalState - . initUpdateFinalize mallocEVPMDCtx initialize evpDigestUpdate evpDigestFinalEx - where initialize ctx = evpDigestInitEx ctx md noEngine +hash (Algorithm md) bytes = + unsafeLocalState $ do + ctxFP <- mallocEVPMDCtx + withForeignPtr ctxFP $ \ctx -> do + evpDigestInitEx ctx md noEngine + mapM_ (evpDigestUpdate ctx) (ByteString.Lazy.toChunks bytes) + Digest <$> onBufferOfMaxSize evpMaxMDSize (evpDigestFinalEx ctx) diff --git a/src/Data/HMAC.hs b/src/Data/HMAC.hs index e659749..812b638 100644 --- a/src/Data/HMAC.hs +++ b/src/Data/HMAC.hs @@ -14,19 +14,24 @@ module Data.HMAC ( SecretKey(SecretKey) - , HMAC + , HMAC, Result , hmac ) where +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (runExceptT) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.ByteString.Unsafe as ByteString +import Foreign (withForeignPtr) import Foreign.Marshal.Unsafe (unsafeLocalState) import BTLS.BoringSSL.Base +import BTLS.BoringSSL.Digest (evpMaxMDSize) import BTLS.BoringSSL.HMAC import BTLS.BoringSSL.Mem (cryptoMemcmp) -import BTLS.BoringSSLPatterns (initUpdateFinalize) +import BTLS.BoringSSLPatterns (onBufferOfMaxSize) +import BTLS.Result (Result, check) import BTLS.Types (Algorithm(Algorithm), Digest(Digest), SecretKey(SecretKey)) type LazyByteString = ByteString.Lazy.ByteString @@ -46,10 +51,11 @@ 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) = - HMAC - . unsafeLocalState - . initUpdateFinalize mallocHMACCtx initialize hmacUpdate hmacFinal - where - initialize ctx = hmacInitEx ctx key md noEngine +hmac :: Algorithm -> SecretKey -> LazyByteString -> Result HMAC +hmac (Algorithm md) (SecretKey key) bytes = + unsafeLocalState $ do + ctxFP <- mallocHMACCtx + withForeignPtr ctxFP $ \ctx -> runExceptT $ do + check $ hmacInitEx ctx key md noEngine + lift $ mapM_ (hmacUpdate ctx) (ByteString.Lazy.toChunks bytes) + lift $ HMAC <$> onBufferOfMaxSize evpMaxMDSize (hmacFinal ctx) diff --git a/tests/Data/HMACTests.hs b/tests/Data/HMACTests.hs index 06ee8eb..ea786c0 100644 --- a/tests/Data/HMACTests.hs +++ b/tests/Data/HMACTests.hs @@ -23,7 +23,7 @@ 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) +import Data.HMAC (Result, SecretKey(SecretKey), hmac) type LazyByteString = ByteString.Lazy.ByteString @@ -35,11 +35,11 @@ tests = testGroup "Data.HMAC" ] tableTestCase :: - (SecretKey -> LazyByteString -> String) + (SecretKey -> LazyByteString -> Result String) -> (SecretKey, LazyByteString, String) -> TestTree tableTestCase f (key, input, output) = - testCase (abbreviate input) (f key input @?= output) + testCase (abbreviate input) (f key input @?= Right output) abbreviate :: LazyByteString -> String abbreviate input = @@ -119,16 +119,16 @@ truncatedFips198Test = output = "9ea886efe268dbecce420c75" :: String in testCase (show input) - (take 24 (hmacSha1 key (ByteString.Lazy.Char8.pack input)) @?= output) + (take 24 <$> hmacSha1 key (ByteString.Lazy.Char8.pack input) @?= Right 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) + [ testCase "SHA-224" (hmacSha224 key input @?= Right sha224Output) + , testCase "SHA-256" (hmacSha256 key input @?= Right sha256Output) + , testCase "SHA-384" (hmacSha384 key input @?= Right sha384Output) + , testCase "SHA-512" (hmacSha512 key input @?= Right sha512Output) ] -- | Tests from RFC 4231. @@ -176,17 +176,17 @@ testRFC4231 = testGroup "RFC 4231" $ truncatedRFC4231Test = let key = SecretKey (ByteString.replicate 20 0x0c) input = "Test With Truncation" :: LazyByteString - t f = take 32 (f key input) :: String + t f = take 32 <$> f key input :: Result 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") + [ testCase "SHA-224" (t hmacSha224 @?= Right "0e2aea68a90c8d37c988bcdb9fca6fa8") + , testCase "SHA-256" (t hmacSha256 @?= Right "a3b6167473100ee06e0c796c2955552b") + , testCase "SHA-384" (t hmacSha384 @?= Right "3abf34c3503b2a23a46efc619baef897") + , testCase "SHA-512" (t hmacSha512 @?= Right "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 +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 -- cgit v1.2.3