diff options
| -rw-r--r-- | Setup.hs | 2 | ||||
| -rw-r--r-- | btls.cabal | 11 | ||||
| -rw-r--r-- | cbits/btls.c | 19 | ||||
| -rw-r--r-- | src/Data/Digest.chs (renamed from src/Data/Digest.hs) | 29 | ||||
| -rw-r--r-- | src/Data/Digest/Internal.chs (renamed from src/Data/Digest/Internal.hsc) | 44 | ||||
| -rw-r--r-- | src/Data/Hmac.chs (renamed from src/Data/Hmac.hsc) | 42 | ||||
| -rw-r--r-- | src/Foreign/Ptr/Cast.hs | 21 | ||||
| -rw-r--r-- | src/Foreign/Ptr/ConstantTimeEquals.chs (renamed from src/Foreign/Ptr/ConstantTimeEquals.hs) | 11 |
8 files changed, 96 insertions, 83 deletions
@@ -23,6 +23,7 @@ import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo import qualified Distribution.Simple.Setup as Setup import qualified Distribution.Simple.Utils as Utils +import qualified Gtk2HsSetup import System.Directory (getCurrentDirectory) import System.FilePath ((</>)) @@ -42,6 +43,7 @@ main = \info flags -> do buildinfo <- Simple.confHook h info flags boringsslUpdateExtraLibDirs buildinfo + , Simple.buildHook = Simple.buildHook Gtk2HsSetup.gtk2hsUserHooks } boringsslDir = "third_party" </> "boringssl" @@ -26,23 +26,24 @@ maintainer: bbaren@google.com category: Network build-type: Custom tested-with: GHC ==8.0.2 -extra-source-files: third_party +extra-source-files: cbits + , third_party custom-setup setup-depends: base , Cabal >=1.4 && <2.1 , directory <1.4 , filepath <1.5 + , gtk2hs-buildtools >=0.13.2.1 && <0.14 library hs-source-dirs: src default-language: Haskell2010 - other-extensions: CApiFFI - , ExistentialQuantification + other-extensions: ExistentialQuantification , NamedFieldPuns , Rank2Types , ScopedTypeVariables - build-tools: hsc2hs + build-tools: c2hs include-dirs: third_party/boringssl/src/include ghc-options: -Weverything -Wno-all-missed-specialisations @@ -53,7 +54,9 @@ library exposed-modules: Data.Digest , Data.Hmac other-modules: Data.Digest.Internal + , Foreign.Ptr.Cast , Foreign.Ptr.ConstantTimeEquals + c-sources: cbits/btls.c -- Use special names for the BoringSSL libraries to avoid accidentally pulling -- in OpenSSL. extra-libraries: btls_crypto diff --git a/cbits/btls.c b/cbits/btls.c new file mode 100644 index 0000000..e922f3a --- /dev/null +++ b/cbits/btls.c @@ -0,0 +1,19 @@ +// Copyright 2018 Google LLC +// +// Licensed under the Apache License, Version 2.0 (the "License"); you may not +// use this file except in compliance with the License. You may obtain a copy of +// the License at +// +// https://www.apache.org/licenses/LICENSE-2.0 +// +// Unless required by applicable law or agreed to in writing, software +// distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +// WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +// License for the specific language governing permissions and limitations under +// the License. + +#include <openssl/digest.h> + +void btlsFinalizeEvpMdCtx(EVP_MD_CTX* const ctx) { + (void)EVP_MD_CTX_cleanup(ctx); +} diff --git a/src/Data/Digest.hs b/src/Data/Digest.chs index bec8c4f..09ab518 100644 --- a/src/Data/Digest.hs +++ b/src/Data/Digest.chs @@ -26,37 +26,24 @@ module Data.Digest import Foreign (Ptr) -import Data.Digest.Internal +{#import Data.Digest.Internal#} - -foreign import ccall "openssl/digest.h EVP_md5" evpMd5 :: Ptr EvpMd +#include <openssl/digest.h> md5 :: Algorithm -md5 = Algorithm evpMd5 - - -foreign import ccall "openssl/digest.h EVP_sha1" evpSha1 :: Ptr EvpMd +md5 = Algorithm {#call pure EVP_md5 as ^#} sha1 :: Algorithm -sha1 = Algorithm evpSha1 - - -foreign import ccall "openssl/digest.h EVP_sha224" evpSha224 :: Ptr EvpMd - -foreign import ccall "openssl/digest.h EVP_sha256" evpSha256 :: Ptr EvpMd - -foreign import ccall "openssl/digest.h EVP_sha384" evpSha384 :: Ptr EvpMd - -foreign import ccall "openssl/digest.h EVP_sha512" evpSha512 :: Ptr EvpMd +sha1 = Algorithm {#call pure EVP_sha1 as ^#} sha224 :: Algorithm -sha224 = Algorithm evpSha224 +sha224 = Algorithm {#call pure EVP_sha224 as ^#} sha256 :: Algorithm -sha256 = Algorithm evpSha256 +sha256 = Algorithm {#call pure EVP_sha256 as ^#} sha384 :: Algorithm -sha384 = Algorithm evpSha384 +sha384 = Algorithm {#call pure EVP_sha384 as ^#} sha512 :: Algorithm -sha512 = Algorithm evpSha512 +sha512 = Algorithm {#call pure EVP_sha512 as ^#} diff --git a/src/Data/Digest/Internal.hsc b/src/Data/Digest/Internal.chs index abd498c..ed4e09e 100644 --- a/src/Data/Digest/Internal.hsc +++ b/src/Data/Digest/Internal.chs @@ -12,7 +12,6 @@ -- License for the specific language governing permissions and limitations under -- the License. -{-# LANGUAGE CApiFFI #-} {-# OPTIONS_GHC -Wno-missing-methods #-} module Data.Digest.Internal where @@ -33,6 +32,8 @@ import Foreign.C.Types import Foreign.Marshal.Unsafe (unsafeLocalState) import Unsafe.Coerce (unsafeCoerce) +import Foreign.Ptr.Cast (asVoidPtr) + type LazyByteString = ByteString.Lazy.ByteString #include <openssl/digest.h> @@ -41,39 +42,30 @@ type LazyByteString = ByteString.Lazy.ByteString -- | The BoringSSL @ENGINE@ type. data Engine +{#pointer *ENGINE as 'Ptr Engine' -> Engine nocode#} noEngine :: Ptr Engine noEngine = nullPtr -- | The BoringSSL @EVP_MD@ type, representing a hash algorithm. data EvpMd +{#pointer *EVP_MD as 'Ptr EvpMd' -> EvpMd nocode#} -- | The BoringSSL @EVP_MD_CTX@ type, representing the state of a pending -- hashing operation. data EvpMdCtx +{#pointer *EVP_MD_CTX as 'Ptr EvpMdCtx' -> EvpMdCtx nocode#} instance Storable EvpMdCtx where - sizeOf _ = #size EVP_MD_CTX - alignment _ = #alignment EVP_MD_CTX + sizeOf _ = {#sizeof EVP_MD_CTX#} + alignment _ = {#alignof 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_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 +evpMaxMdSize :: Int +evpMaxMdSize = {#const EVP_MAX_MD_SIZE#} -- Some of these functions return 'CInt' even though they can never fail. Wrap -- them to prevent warnings. @@ -83,12 +75,13 @@ alwaysSucceeds f = do r <- f assert (r == 1) (return ()) -evpDigestUpdate :: Ptr EvpMdCtx -> Ptr a -> CSize -> IO () -evpDigestUpdate ctx md bytes = alwaysSucceeds $ evpDigestUpdate' ctx md bytes +evpDigestUpdate :: Ptr EvpMdCtx -> Ptr a -> CULong -> IO () +evpDigestUpdate ctx md bytes = + alwaysSucceeds $ {#call EVP_DigestUpdate as ^#} ctx (asVoidPtr md) bytes evpDigestFinalEx :: Ptr EvpMdCtx -> Ptr CUChar -> Ptr CUInt -> IO () evpDigestFinalEx ctx mdOut outSize = - alwaysSucceeds $ evpDigestFinalEx' ctx mdOut outSize + alwaysSucceeds $ {#call EVP_DigestFinal_ex as ^#} ctx mdOut outSize -- Convert functions that can in fact fail to throw exceptions instead. @@ -96,7 +89,8 @@ requireSuccess :: IO CInt -> IO () requireSuccess f = throwIf_ (/= 1) (const "BoringSSL failure") f evpDigestInitEx :: Ptr EvpMdCtx -> Ptr EvpMd -> Ptr Engine -> IO () -evpDigestInitEx ctx md engine = requireSuccess $ evpDigestInitEx' ctx md engine +evpDigestInitEx ctx md engine = + requireSuccess $ {#call EVP_DigestInit_ex as ^#} ctx md engine -- Now we can build a memory-safe allocator. @@ -104,14 +98,10 @@ evpDigestInitEx ctx md engine = requireSuccess $ evpDigestInitEx' ctx md engine mallocEvpMdCtx :: IO (ForeignPtr EvpMdCtx) mallocEvpMdCtx = do fp <- mallocForeignPtr - withForeignPtr fp evpMdCtxInit + withForeignPtr fp {#call EVP_MD_CTX_init as ^#} addForeignPtrFinalizer btlsFinalizeEvpMdCtxPtr fp return fp -#def void btlsFinalizeEvpMdCtx(EVP_MD_CTX* const ctx) { - (void)EVP_MD_CTX_cleanup(ctx); -} - foreign import ccall "&btlsFinalizeEvpMdCtx" btlsFinalizeEvpMdCtxPtr :: FinalizerPtr EvpMdCtx @@ -141,7 +131,7 @@ hash (Algorithm md) bytes = evpDigestInitEx ctx md noEngine mapM_ (updateBytes ctx) (ByteString.Lazy.toChunks bytes) d <- - allocaArray (fromIntegral evpMaxMdSize) $ \mdOut -> + allocaArray evpMaxMdSize $ \mdOut -> alloca $ \pOutSize -> do evpDigestFinalEx ctx mdOut pOutSize outSize <- fromIntegral <$> peek pOutSize diff --git a/src/Data/Hmac.hsc b/src/Data/Hmac.chs index 5be09a8..7ee68d2 100644 --- a/src/Data/Hmac.hsc +++ b/src/Data/Hmac.chs @@ -32,10 +32,11 @@ import Foreign.C.Types import Foreign.Marshal.Unsafe (unsafeLocalState) import Unsafe.Coerce (unsafeCoerce) -import Data.Digest.Internal +{#import Data.Digest.Internal#} (Algorithm(Algorithm), Digest(Digest), Engine, EvpMd, alwaysSucceeds, evpMaxMdSize, noEngine, requireSuccess) -import Foreign.Ptr.ConstantTimeEquals (constantTimeEquals) +import Foreign.Ptr.Cast (asVoidPtr) +{#import Foreign.Ptr.ConstantTimeEquals#} (constantTimeEquals) type LazyByteString = ByteString.Lazy.ByteString @@ -46,42 +47,33 @@ type LazyByteString = ByteString.Lazy.ByteString -- | The BoringSSL @HMAC_CTX@ type, representing the state of a pending HMAC -- operation. data HmacCtx +{#pointer *HMAC_CTX as 'Ptr HmacCtx' -> HmacCtx nocode#} instance Storable HmacCtx where - sizeOf _ = #size HMAC_CTX - alignment _ = #alignment HMAC_CTX + sizeOf _ = {#sizeof HMAC_CTX#} + alignment _ = {#alignof HMAC_CTX#} -- Imported functions from BoringSSL. See -- https://commondatastorage.googleapis.com/chromium-boringssl-docs/hmac.h.html -- for documentation. - -foreign import ccall "openssl/hmac.h HMAC_CTX_init" - hmacCtxInit :: Ptr HmacCtx -> IO () - -foreign import ccall "openssl/hmac.h HMAC_Init_ex" - hmacInitEx' :: - Ptr HmacCtx -> Ptr a -> CSize -> Ptr EvpMd -> Ptr Engine -> IO CInt - -foreign import ccall "openssl/hmac.h HMAC_Update" - hmacUpdate' :: Ptr HmacCtx -> Ptr CUChar -> CSize -> IO CInt - -foreign import ccall "openssl/hmac.h HMAC_Final" - hmacFinal' :: Ptr HmacCtx -> Ptr CUChar -> Ptr CUInt -> IO CInt - +-- -- Some of these functions return 'CInt' even though they can never fail. Wrap -- them to prevent warnings. -hmacUpdate :: Ptr HmacCtx -> Ptr CUChar -> CSize -> IO () -hmacUpdate ctx bytes size = alwaysSucceeds $ hmacUpdate' ctx bytes size +hmacUpdate :: Ptr HmacCtx -> Ptr CUChar -> CULong -> IO () +hmacUpdate ctx bytes size = + alwaysSucceeds $ {#call HMAC_Update as ^#} ctx bytes size -- Convert functions that can in fact fail to throw exceptions instead. -hmacInitEx :: Ptr HmacCtx -> Ptr a -> CSize -> Ptr EvpMd -> Ptr Engine -> IO () +hmacInitEx :: Ptr HmacCtx -> Ptr a -> CULong -> Ptr EvpMd -> Ptr Engine -> IO () hmacInitEx ctx bytes size md engine = - requireSuccess $ hmacInitEx' ctx bytes size md engine + requireSuccess $ + {#call HMAC_Init_ex as ^#} ctx (asVoidPtr bytes) size md engine hmacFinal :: Ptr HmacCtx -> Ptr CUChar -> Ptr CUInt -> IO () -hmacFinal ctx out outSize = requireSuccess $ hmacFinal' ctx out outSize +hmacFinal ctx out outSize = + requireSuccess $ {#call HMAC_Final as ^#} ctx out outSize -- Now we can build a memory-safe allocator. @@ -89,7 +81,7 @@ hmacFinal ctx out outSize = requireSuccess $ hmacFinal' ctx out outSize mallocHmacCtx :: IO (ForeignPtr HmacCtx) mallocHmacCtx = do fp <- mallocForeignPtr - withForeignPtr fp hmacCtxInit + withForeignPtr fp {#call HMAC_CTX_init as ^#} addForeignPtrFinalizer hmacCtxCleanup fp return fp @@ -127,7 +119,7 @@ hmac (Algorithm md) (SecretKey key) bytes = hmacInitEx ctx keyBytes (fromIntegral keySize) md noEngine mapM_ (updateBytes ctx) (ByteString.Lazy.toChunks bytes) m <- - allocaArray (fromIntegral evpMaxMdSize) $ \hmacOut -> + allocaArray evpMaxMdSize $ \hmacOut -> alloca $ \pOutSize -> do hmacFinal ctx hmacOut pOutSize outSize <- fromIntegral <$> peek pOutSize diff --git a/src/Foreign/Ptr/Cast.hs b/src/Foreign/Ptr/Cast.hs new file mode 100644 index 0000000..653604a --- /dev/null +++ b/src/Foreign/Ptr/Cast.hs @@ -0,0 +1,21 @@ +-- Copyright 2018 Google LLC +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); you may not +-- use this file except in compliance with the License. You may obtain a copy of +-- the License at +-- +-- https://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +-- License for the specific language governing permissions and limitations under +-- the License. + +module Foreign.Ptr.Cast where + +import Foreign (Ptr) +import Unsafe.Coerce (unsafeCoerce) + +asVoidPtr :: Ptr a -> Ptr () +asVoidPtr = unsafeCoerce diff --git a/src/Foreign/Ptr/ConstantTimeEquals.hs b/src/Foreign/Ptr/ConstantTimeEquals.chs index 0bd24e7..6b34e7b 100644 --- a/src/Foreign/Ptr/ConstantTimeEquals.hs +++ b/src/Foreign/Ptr/ConstantTimeEquals.chs @@ -12,20 +12,19 @@ -- License for the specific language governing permissions and limitations under -- the License. -{-# LANGUAGE ScopedTypeVariables #-} - module Foreign.Ptr.ConstantTimeEquals where import Foreign (Ptr) import Foreign.C.Types -foreign import ccall "openssl/mem.h CRYPTO_memcmp" - cryptoMemcmp :: Ptr a -> Ptr a -> CSize -> IO CInt +import Foreign.Ptr.Cast (asVoidPtr) + +#include <openssl/mem.h> -- | Directly compares two buffers for equality. This operation takes an amount -- of time dependent on the specified size but independent of either buffer's -- contents. constantTimeEquals :: Ptr a -> Ptr a -> Int -> IO Bool constantTimeEquals a b size = - let size' = fromIntegral size :: CSize - in (== 0) <$> cryptoMemcmp a b size' + let size' = fromIntegral size :: CULong + in (== 0) <$> {#call CRYPTO_memcmp as ^#} (asVoidPtr a) (asVoidPtr b) size' |