Enable error checking for HMAC computations

3 files changed, 34 insertions, 34 deletions

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