Switch to c2hs

Let the computer figure out its own types for most foreign imports.
Continue using the vanilla FFI for finalizers, though, as that’s the
easiest way to deal with function pointers.

Reuse the build hook from gtk2hs-buildtools to work around Cabal’s
inability to topologically sort .chs dependencies
(haskell/cabal#1906).

Setup.hs

@@ -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"

btls.cabal

@@ -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

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);
+}

src/Data/Digest.hs → 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 ^#}

src/Data/Digest/Internal.hsc → 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,35 +75,33 @@ 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.
 
 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.
 
 -- | Memory-safe allocator for 'EvpMdCtx'.
 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

src/Data/Hmac.hsc → 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,50 +47,41 @@ 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.
 
 -- | Memory-safe allocator for 'HmacCtx'.
 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

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

src/Foreign/Ptr/ConstantTimeEquals.hs → 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'