From 80f2fb2e3be2c4074fbfb0adbc47746d2d88813b Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Fri, 31 Aug 2018 16:50:41 -0400 Subject: Begin switching to `fun` in c2hs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace most invocations of `call` with `fun`. There’s a lot of explicit `id`-marshalling going on; future commits will remove it. --- src/BTLS/BoringSSL/Digest.chs | 28 ++++++++++++---------------- src/BTLS/BoringSSL/HKDF.chs | 24 ++++++------------------ src/BTLS/BoringSSL/HMAC.chs | 21 +++++++++------------ src/BTLS/BoringSSL/Mem.chs | 7 ++----- src/BTLS/BoringSSL/Rand.chs | 4 ++-- src/BTLS/Result.hs | 12 +++++------- src/Data/HMAC.hs | 2 +- 7 files changed, 37 insertions(+), 61 deletions(-) (limited to 'src') diff --git a/src/BTLS/BoringSSL/Digest.chs b/src/BTLS/BoringSSL/Digest.chs index 69f3a0a..f675c61 100644 --- a/src/BTLS/BoringSSL/Digest.chs +++ b/src/BTLS/BoringSSL/Digest.chs @@ -31,13 +31,12 @@ import BTLS.Result #include -evpMD5, evpSHA1, evpSHA224, evpSHA256, evpSHA384, evpSHA512 :: Ptr EVPMD -evpMD5 = {#call pure EVP_md5 as ^#} -evpSHA1 = {#call pure EVP_sha1 as ^#} -evpSHA224 = {#call pure EVP_sha224 as ^#} -evpSHA256 = {#call pure EVP_sha256 as ^#} -evpSHA384 = {#call pure EVP_sha384 as ^#} -evpSHA512 = {#call pure EVP_sha512 as ^#} +{#fun pure EVP_md5 as evpMD5 {} -> `Ptr EVPMD'#} +{#fun pure EVP_sha1 as evpSHA1 {} -> `Ptr EVPMD'#} +{#fun pure EVP_sha224 as evpSHA224 {} -> `Ptr EVPMD'#} +{#fun pure EVP_sha256 as evpSHA256 {} -> `Ptr EVPMD'#} +{#fun pure EVP_sha384 as evpSHA384 {} -> `Ptr EVPMD'#} +{#fun pure EVP_sha512 as evpSHA512 {} -> `Ptr EVPMD'#} -- | Memory-safe allocator for 'EVPMDCtx'. mallocEVPMDCtx :: IO (ForeignPtr EVPMDCtx) @@ -47,17 +46,14 @@ mallocEVPMDCtx = foreign import ccall "&btlsFinalizeEVPMDCtx" btlsFinalizeEVPMDCtxPtr :: FinalizerPtr EVPMDCtx -evpDigestInitEx :: Ptr EVPMDCtx -> Ptr EVPMD -> Ptr Engine -> IO () -evpDigestInitEx ctx md engine = - requireSuccess $ {#call EVP_DigestInit_ex as ^#} ctx md engine +{#fun EVP_DigestInit_ex as evpDigestInitEx + {`Ptr EVPMDCtx', `Ptr EVPMD', `Ptr Engine'} -> `()' requireSuccess*-#} -evpDigestUpdate :: Ptr EVPMDCtx -> Ptr a -> CULong -> IO () -evpDigestUpdate ctx md bytes = - alwaysSucceeds $ {#call EVP_DigestUpdate as ^#} ctx (asVoidPtr md) bytes +{#fun EVP_DigestUpdate as evpDigestUpdate + {`Ptr EVPMDCtx', asVoidPtr `Ptr a', id `CULong'} -> `()' alwaysSucceeds*-#} -evpDigestFinalEx :: Ptr EVPMDCtx -> Ptr CUChar -> Ptr CUInt -> IO () -evpDigestFinalEx ctx mdOut outSize = - alwaysSucceeds $ {#call EVP_DigestFinal_ex as ^#} ctx mdOut outSize +{#fun EVP_DigestFinal_ex as evpDigestFinalEx + {`Ptr EVPMDCtx', id `Ptr CUChar', id `Ptr CUInt'} -> `()' alwaysSucceeds*-#} evpMaxMDSize :: Int evpMaxMDSize = {#const EVP_MAX_MD_SIZE#} diff --git a/src/BTLS/BoringSSL/HKDF.chs b/src/BTLS/BoringSSL/HKDF.chs index 3710c0c..87945d5 100644 --- a/src/BTLS/BoringSSL/HKDF.chs +++ b/src/BTLS/BoringSSL/HKDF.chs @@ -24,22 +24,10 @@ import BTLS.Result #include -hkdfExtract :: - Ptr CUChar -> Ptr CULong - -> Ptr EVPMD - -> Ptr CUChar -> CULong - -> Ptr CUChar -> CULong - -> IO () -hkdfExtract outKey outLen digest secret secretLen salt saltLen = - requireSuccess $ - {#call HKDF_extract as ^#} outKey outLen digest secret secretLen salt saltLen +{#fun HKDF_extract as hkdfExtract + { id `Ptr CUChar', id `Ptr CULong', `Ptr EVPMD', id `Ptr CUChar', id `CULong' + , id `Ptr CUChar', id `CULong' } -> `()' requireSuccess*-#} -hkdfExpand :: - Ptr CUChar -> CULong - -> Ptr EVPMD - -> Ptr CUChar -> CULong - -> Ptr CUChar -> CULong - -> IO () -hkdfExpand outKey outLen digest prk prkLen info infoLen = - requireSuccess $ - {#call HKDF_expand as ^#} outKey outLen digest prk prkLen info infoLen +{#fun HKDF_expand as hkdfExpand + { id `Ptr CUChar', id `CULong', `Ptr EVPMD', id `Ptr CUChar', id `CULong' + , id `Ptr CUChar', id `CULong' } -> `()' requireSuccess*-#} diff --git a/src/BTLS/BoringSSL/HMAC.chs b/src/BTLS/BoringSSL/HMAC.chs index 5c53122..1e5e82c 100644 --- a/src/BTLS/BoringSSL/HMAC.chs +++ b/src/BTLS/BoringSSL/HMAC.chs @@ -36,18 +36,15 @@ mallocHMACCtx = createWithFinalizer {#call HMAC_CTX_init as ^#} hmacCtxCleanup foreign import ccall "&HMAC_CTX_cleanup" hmacCtxCleanup :: FinalizerPtr HMACCtx -hmacInitEx :: Ptr HMACCtx -> Ptr a -> CULong -> Ptr EVPMD -> Ptr Engine -> IO () -hmacInitEx ctx bytes size md engine = - requireSuccess $ - {#call HMAC_Init_ex as ^#} ctx (asVoidPtr bytes) size md engine - -hmacUpdate :: Ptr HMACCtx -> Ptr CUChar -> CULong -> IO () -hmacUpdate ctx bytes size = - alwaysSucceeds $ {#call HMAC_Update as ^#} ctx bytes size - -hmacFinal :: Ptr HMACCtx -> Ptr CUChar -> Ptr CUInt -> IO () -hmacFinal ctx out outSize = - requireSuccess $ {#call HMAC_Final as ^#} ctx out outSize +{#fun HMAC_Init_ex as hmacInitEx + {`Ptr HMACCtx', asVoidPtr `Ptr a', id `CULong', `Ptr EVPMD', `Ptr Engine'} + -> `()' requireSuccess*-#} + +{#fun HMAC_Update as hmacUpdate + {`Ptr HMACCtx', id `Ptr CUChar', id `CULong'} -> `()' alwaysSucceeds*-#} + +{#fun HMAC_Final as hmacFinal + {`Ptr HMACCtx', id `Ptr CUChar', id `Ptr CUInt'} -> `()' requireSuccess*-#} instance Storable HMACCtx where sizeOf _ = {#sizeof HMAC_CTX#} diff --git a/src/BTLS/BoringSSL/Mem.chs b/src/BTLS/BoringSSL/Mem.chs index 969cf91..6f828ad 100644 --- a/src/BTLS/BoringSSL/Mem.chs +++ b/src/BTLS/BoringSSL/Mem.chs @@ -15,7 +15,6 @@ module BTLS.BoringSSL.Mem where import Foreign (Ptr) -import Foreign.C.Types import BTLS.Cast (asVoidPtr) @@ -24,7 +23,5 @@ import BTLS.Cast (asVoidPtr) -- | 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. -cryptoMemcmp :: Ptr a -> Ptr a -> Int -> IO Bool -cryptoMemcmp a b size = - let size' = fromIntegral size :: CULong in - (== 0) <$> {#call CRYPTO_memcmp as ^#} (asVoidPtr a) (asVoidPtr b) size' +{#fun CRYPTO_memcmp as cryptoMemcmp + {asVoidPtr `Ptr a', asVoidPtr `Ptr a', `Int'} -> `Int'#} diff --git a/src/BTLS/BoringSSL/Rand.chs b/src/BTLS/BoringSSL/Rand.chs index f7de732..d43d26b 100644 --- a/src/BTLS/BoringSSL/Rand.chs +++ b/src/BTLS/BoringSSL/Rand.chs @@ -23,5 +23,5 @@ import BTLS.Result #include -randBytes :: Ptr CUChar -> CULong -> IO () -randBytes buf len = alwaysSucceeds $ {#call RAND_bytes as ^#} buf len +{#fun RAND_bytes as randBytes + {id `Ptr CUChar', id `CULong'} -> `()' alwaysSucceeds*-#} diff --git a/src/BTLS/Result.hs b/src/BTLS/Result.hs index b9ad4a7..6cac7b9 100644 --- a/src/BTLS/Result.hs +++ b/src/BTLS/Result.hs @@ -15,13 +15,11 @@ module BTLS.Result where import Control.Exception (assert) -import Foreign (throwIf_) +import Control.Monad (when) import Foreign.C.Types -alwaysSucceeds :: IO CInt -> IO () -alwaysSucceeds f = do - r <- f - assert (r == 1) (return ()) +alwaysSucceeds :: CInt -> IO () +alwaysSucceeds r = assert (r == 1) (return ()) -requireSuccess :: IO CInt -> IO () -requireSuccess f = throwIf_ (/= 1) (const "BoringSSL failure") f +requireSuccess :: CInt -> IO () +requireSuccess r = when (r /= 1) $ ioError (userError "BoringSSL failure") diff --git a/src/Data/HMAC.hs b/src/Data/HMAC.hs index 1850103..df7e8e6 100644 --- a/src/Data/HMAC.hs +++ b/src/Data/HMAC.hs @@ -41,7 +41,7 @@ instance Eq HMAC where unsafeLocalState $ ByteString.unsafeUseAsCStringLen a $ \(a', size) -> ByteString.unsafeUseAsCStringLen b $ \(b', _) -> - cryptoMemcmp a' b' size + (==0) <$> cryptoMemcmp a' b' size instance Show HMAC where show (HMAC m) = show (Digest m) -- cgit v1.2.3