Begin writing btls, a Haskell crypto and TLS library using BoringSSL

So far, btls provides SHA-224, SHA-256, SHA-384, and SHA-512 algorithms.
To do that, I

  - vendor BoringSSL and create a custom `Setup.hs` to build it,

  - wrap a number of functions and values from BoringSSL's EVP
    subsystem, and

  - implement the four SHA-2 algorithms using the wrapped routines.

I provide conformance tests incorporating the official NIST example
vectors and the vectors used in the Go SHA-2 test suite. The tests also
use SmallCheck to compare btls’s SHA-2 implementations with those
provided by the system’s Coreutils and openssl(1) installations.

3 files changed, 170 insertions, 0 deletions

diff --git a/src/Data/Digest.hs b/src/Data/Digest.hs
new file mode 100644
index 0000000..717cd0d
--- /dev/null
+++ b/src/Data/Digest.hs
@@ -0,0 +1,5 @@
+module Data.Digest
+  ( Digest
+  ) where
+
+import Data.Digest.Evp
diff --git a/src/Data/Digest/Evp.hsc b/src/Data/Digest/Evp.hsc
new file mode 100644
index 0000000..3bba247
--- /dev/null
+++ b/src/Data/Digest/Evp.hsc
@@ -0,0 +1,135 @@
+{-# LANGUAGE CApiFFI #-}
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+
+module Data.Digest.Evp
+  ( Algo
+  , Digest(Digest)
+  , hash
+  ) where
+
+import Control.Exception (bracket_)
+import Control.Monad (void)
+import Data.Bits (Bits((.&.)), shiftR)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Unsafe as ByteString
+import Data.Char (intToDigit)
+import Data.Word (Word8)
+import Foreign
+       (Ptr, Storable(alignment, peek, sizeOf), alloca, allocaArray,
+        nullPtr, throwIf_)
+import Foreign.C.Types
+import System.IO.Unsafe (unsafePerformIO)
+import Unsafe.Coerce (unsafeCoerce)
+
+#include <openssl/digest.h>
+
+-- First, we build basic bindings to the BoringSSL EVP interface.
+
+-- | The BoringSSL @ENGINE@ type.
+data Engine
+
+-- | The BoringSSL @EVP_MD@ type, representing a hash algorithm.
+data EvpMd
+
+-- | A convenience alias for @Ptr EvpMd@.
+type Algo = Ptr EvpMd
+
+-- | The BoringSSL @EVP_MD_CTX@ type, representing the state of a pending
+-- hashing operation.
+data EvpMdCtx
+
+instance Storable EvpMdCtx where
+  sizeOf _ = #size EVP_MD_CTX
+  alignment _ = #alignment EVP_MD_CTX
+
+-- Imported functions from BoringSSL. See
+-- https://commondatastorage.googleapis.com/chromium-boringssl-docs/digest.h.html
+-- for documentation.
+
+foreign import ccall "openssl/digest.h EVP_MD_CTX_init"
+  evpMdCtxInit :: Ptr EvpMdCtx -> IO ()
+
+foreign import ccall "openssl/digest.h EVP_MD_CTX_cleanup"
+  evpMdCtxCleanup' :: Ptr EvpMdCtx -> IO CInt
+
+foreign import ccall "openssl/digest.h EVP_DigestInit_ex"
+  evpDigestInitEx' :: Ptr EvpMdCtx -> Ptr EvpMd -> Ptr Engine -> IO CInt
+
+foreign import capi "openssl/digest.h value EVP_MAX_MD_SIZE"
+  evpMaxMdSize :: CSize
+
+foreign import ccall "openssl/digest.h EVP_DigestUpdate"
+  evpDigestUpdate' :: Ptr EvpMdCtx -> Ptr a -> CSize -> IO CInt
+
+foreign import ccall "openssl/digest.h EVP_DigestFinal_ex"
+  evpDigestFinalEx' :: Ptr EvpMdCtx -> Ptr CUChar -> Ptr CUInt -> IO CInt
+
+-- Some of these functions return 'CInt' even though they can never fail. Wrap
+-- them to prevent warnings.
+
+evpMdCtxCleanup :: Ptr EvpMdCtx -> IO ()
+evpMdCtxCleanup = void . evpMdCtxCleanup'
+
+evpDigestUpdate :: Ptr EvpMdCtx -> Ptr a -> CSize -> IO ()
+evpDigestUpdate ctx md bytes = void $ evpDigestUpdate' ctx md bytes
+
+evpDigestFinalEx :: Ptr EvpMdCtx -> Ptr CUChar -> Ptr CUInt -> IO ()
+evpDigestFinalEx ctx mdOut outSize = void $ evpDigestFinalEx' ctx mdOut outSize
+
+-- Convert functions that can in fact fail to throw exceptions instead.
+
+evpDigestInitEx :: Ptr EvpMdCtx -> Ptr EvpMd -> Ptr Engine -> IO ()
+evpDigestInitEx ctx md engine =
+  throwIf_ (/= 1) (const "BoringSSL failure") $ evpDigestInitEx' ctx md engine
+
+-- Now we can build a memory-safe abstraction layer.
+
+-- | Memory-safe wrapper for 'EvpMdCtx'.
+withMdCtx :: (Ptr EvpMdCtx -> IO a) -> IO a
+withMdCtx f =
+  alloca $ \ctx -> bracket_ (evpMdCtxInit ctx) (evpMdCtxCleanup ctx) (f ctx)
+
+-- Finally, we're ready to actually implement the hashing interface.
+
+-- | The result of a hash operation.
+newtype Digest =
+  Digest ByteString
+  deriving (Eq, Ord)
+
+instance Show Digest where
+  show (Digest d) = ByteString.foldr showHexPadded [] d
+    where
+      showHexPadded b xs =
+        hexit (b `shiftR` 4 .&. 0x0f) : hexit (b .&. 0x0f) : xs
+      hexit = intToDigit . fromIntegral :: Word8 -> Char
+
+hash :: Algo -> ByteString -> Digest
+hash md bytes =
+  -- We'd like to use 'unsafeLocalState' (i.e., 'unsafeDupablePerformIO') here,
+  -- but 'unsafeDupablePerformIO' runs computation in a context where it can be
+  -- arbitrarily terminated--i.e., where the cleanup in 'withMdCtx' is not
+  -- guaranteed to run. See
+  -- https://hackage.haskell.org/package/base/docs/System-IO-Unsafe.html#v:unsafeDupablePerformIO.
+  unsafePerformIO $
+  withMdCtx $ \ctx -> do
+    evpDigestInitEx ctx md noEngine
+    -- evpDigestUpdate treats its @buf@ argument as @const@, so the sharing
+    -- inherent in 'ByteString.unsafeUseAsCStringLen' is fine.
+    ByteString.unsafeUseAsCStringLen bytes $ \(buf, len) ->
+      evpDigestUpdate ctx buf (fromIntegral len)
+    d <-
+      allocaArray (fromIntegral evpMaxMdSize) $ \mdOut ->
+        alloca $ \pOutSize -> do
+          evpDigestFinalEx ctx mdOut pOutSize
+          outSize <- fromIntegral <$> peek pOutSize
+          -- 'mdOut' is a 'Ptr CUChar'. However, to make life more interesting,
+          -- 'CString' is a 'Ptr CChar', and 'CChar' is signed. This is
+          -- especially unfortunate given that all we really want to do is
+          -- convert to a 'ByteString', which is unsigned. To work around it,
+          -- we're going to cheat and let Haskell reinterpret-cast 'mdOut' to
+          -- 'Ptr CChar' before it does its 'ByteString' ingestion.
+          ByteString.packCStringLen (unsafeCoerce mdOut, outSize)
+    return (Digest d)
+  where
+    noEngine = nullPtr :: Ptr Engine
diff --git a/src/Data/Digest/Sha2.hs b/src/Data/Digest/Sha2.hs
new file mode 100644
index 0000000..0aa814e
--- /dev/null
+++ b/src/Data/Digest/Sha2.hs
@@ -0,0 +1,30 @@
+module Data.Digest.Sha2
+  ( sha224
+  , sha256
+  , sha384
+  , sha512
+  ) where
+
+import Data.ByteString (ByteString)
+
+import qualified Data.Digest.Evp as Evp
+
+foreign import ccall "openssl/digest.h EVP_sha224" evpSha224 :: Evp.Algo
+
+foreign import ccall "openssl/digest.h EVP_sha256" evpSha256 :: Evp.Algo
+
+foreign import ccall "openssl/digest.h EVP_sha384" evpSha384 :: Evp.Algo
+
+foreign import ccall "openssl/digest.h EVP_sha512" evpSha512 :: Evp.Algo
+
+sha224 :: ByteString -> Evp.Digest
+sha224 = Evp.hash evpSha224
+
+sha256 :: ByteString -> Evp.Digest
+sha256 = Evp.hash evpSha256
+
+sha384 :: ByteString -> Evp.Digest
+sha384 = Evp.hash evpSha384
+
+sha512 :: ByteString -> Evp.Digest
+sha512 = Evp.hash evpSha512