Enable error checking for HMAC computations

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