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 --- 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 +++++++++++++++--------- 5 files changed, 58 insertions(+), 49 deletions(-) (limited to 'src') 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) -- cgit v1.2.3