Begin switching to `fun` in c2hs

Replace most invocations of `call` with `fun`. There’s a lot of explicit
`id`-marshalling going on; future commits will remove it.

7 files changed, 37 insertions, 61 deletions

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 <openssl/digest.h>
 
-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 <openssl/hkdf.h>
 
-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 <openssl/rand.h>
 
-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)