From 92a90ad43381f6897a93503027d67ac0b1032f3e Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Fri, 31 Aug 2018 19:00:53 -0400 Subject: Begin wrapping BoringSSL’s error type MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- btls.cabal | 2 + src/BTLS/BoringSSL/Err.chs | 132 +++++++++++++++++++++++++++++++++++++++++++++ src/BTLS/Result.hs | 31 ++++++++++- 3 files changed, 164 insertions(+), 1 deletion(-) create mode 100644 src/BTLS/BoringSSL/Err.chs diff --git a/btls.cabal b/btls.cabal index f544a6e..b296e3d 100644 --- a/btls.cabal +++ b/btls.cabal @@ -39,6 +39,7 @@ custom-setup library hs-source-dirs: src default-language: Haskell2010 + other-extensions: CApiFFI build-tools: c2hs include-dirs: third_party/boringssl/src/include ghc-options: -Werror @@ -73,6 +74,7 @@ library , System.Random.Crypto other-modules: BTLS.BoringSSL.Base , BTLS.BoringSSL.Digest + , BTLS.BoringSSL.Err , BTLS.BoringSSL.HKDF , BTLS.BoringSSL.HMAC , BTLS.BoringSSL.Mem diff --git a/src/BTLS/BoringSSL/Err.chs b/src/BTLS/BoringSSL/Err.chs new file mode 100644 index 0000000..31dd862 --- /dev/null +++ b/src/BTLS/BoringSSL/Err.chs @@ -0,0 +1,132 @@ +-- 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. + +{-# LANGUAGE CApiFFI #-} + +module BTLS.BoringSSL.Err where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import Foreign (Storable(peek), alloca, nullPtr) +import Foreign.C.String (CString, peekCString) +import Foreign.C.Types + +#include + +-- Define a newtype for packed errors so c2hs doesn't try to marshal them. +newtype Err = Err {rawErrValue :: CUInt} + deriving (Eq) + +errGetLib :: Err -> ErrLib +errGetLib (Err e) = castEnum (errGetLib' e) + +foreign import capi "openssl/err.h ERR_GET_LIB" + errGetLib' :: CUInt -> CInt + +errGetReason :: Err -> ErrR +errGetReason (Err e) = castEnum (errGetReason' e) + +foreign import capi "openssl/err.h ERR_GET_REASON" + errGetReason' :: CUInt -> CInt + +errFlagString :: CInt +errFlagString = {#const ERR_FLAG_STRING#} + +{#fun ERR_get_error_line_data as errGetErrorLineData + { alloca- `FilePath' peekCStringPtr* + , alloca- `Int' peekIntPtr* + , alloca- `Maybe ByteString' peekErrorData* + , alloca- `CInt' peek* } + -> `Err' Err#} + where + peekCStringPtr p = do + s <- peek p + peekCString s + peekIntPtr p = fmap fromIntegral (peek p) + peekErrorData p = do + s <- peek p + if s == nullPtr + then return Nothing + else Just <$> ByteString.packCString s + +{#fun ERR_error_string_n as errErrorStringN + {rawErrValue `Err', id `CString', `Int'} -> `()'#} + +{#fun ERR_clear_error as errClearError {} -> `()'#} + +{#enum ERR_LIB_NONE as ErrLib + { underscoreToCase + , ERR_LIB_BN as ErrLibBN + , ERR_LIB_RSA as ErrLibRSA + , ERR_LIB_DH as ErrLibDH + , ERR_LIB_EVP as ErrLibEvp + , ERR_LIB_PEM as ErrLibPEM + , ERR_LIB_DSA as ErrLibDSA + , ERR_LIB_ASN1 as ErrLibASN1 + , ERR_LIB_EC as ErrLibEC + , ERR_LIB_SSL as ErrLibSSL + , ERR_LIB_BIO as ErrLibBIO + , ERR_LIB_PKCS7 as ErrLibPKCS7 + , ERR_LIB_PKCS8 as ErrLibPKCS8 + , ERR_LIB_OCSP as ErrLibOCSP + , ERR_LIB_UI as ErrLibUI + , ERR_LIB_ECDSA as ErrLibECDSA + , ERR_LIB_ECDH as ErrLibECDH + , ERR_LIB_HMAC as ErrLibHMAC + , ERR_LIB_HKDF as ErrLibHKDF } + omit (ERR_NUM_LIBS) + deriving (Eq)#} + +{#enum define ErrR + { ERR_R_SYS_LIB as ErrRSysLib + , ERR_R_BN_LIB as ErrRBNLib + , ERR_R_RSA_LIB as ErrRRSALib + , ERR_R_DH_LIB as ErrRDHLib + , ERR_R_EVP_LIB as ErrREVPLib + , ERR_R_BUF_LIB as ErrRBufLib + , ERR_R_OBJ_LIB as ErrRObjLib + , ERR_R_PEM_LIB as ErrRPEMLib + , ERR_R_DSA_LIB as ErrRDSALib + , ERR_R_X509_LIB as ErrRX509Lib + , ERR_R_ASN1_LIB as ErrRASN1Lib + , ERR_R_CONF_LIB as ErrRConfLib + , ERR_R_CRYPTO_LIB as ErrRCryptoLib + , ERR_R_EC_LIB as ErrRECLib + , ERR_R_SSL_LIB as ErrRSSLLib + , ERR_R_BIO_LIB as ErrRBIOLib + , ERR_R_PKCS7_LIB as ErrRPKCS7Lib + , ERR_R_PKCS8_LIB as ErrRPKCS8Lib + , ERR_R_X509V3_LIB as ErrRX509v3Lib + , ERR_R_RAND_LIB as ErrRRandLib + , ERR_R_ENGINE_LIB as ErrREngineLib + , ERR_R_OCSP_LIB as ErrROCSPLib + , ERR_R_UI_LIB as ErrRUILib + , ERR_R_COMP_LIB as ErrRCompLib + , ERR_R_ECDSA_LIB as ErrRECDSALib + , ERR_R_ECDH_LIB as ErrRECDHLib + , ERR_R_HMAC_LIB as ErrRHMACLib + , ERR_R_USER_LIB as ErrRUserLib + , ERR_R_DIGEST_LIB as ErrRDigestLib + , ERR_R_CIPHER_LIB as ErrRCipherLib + , ERR_R_HKDF_LIB as ErrRHKDFLib + , ERR_R_FATAL as ErrRFatal + , ERR_R_MALLOC_FAILURE as ErrRMallocFailure + , ERR_R_SHOULD_NOT_HAVE_BEEN_CALLED as ErrRShouldNotHaveBeenCalled + , ERR_R_PASSED_NULL_PARAMETER as ErrRPassedNullParameter + , ERR_R_INTERNAL_ERROR as ErrRInternalError + , ERR_R_OVERFLOW as ErrROverflow } + deriving (Eq)#} + +castEnum :: (Enum a, Enum b) => a -> b +castEnum = toEnum . fromEnum \ No newline at end of file diff --git a/src/BTLS/Result.hs b/src/BTLS/Result.hs index 6cac7b9..7cd5839 100644 --- a/src/BTLS/Result.hs +++ b/src/BTLS/Result.hs @@ -12,14 +12,43 @@ -- License for the specific language governing permissions and limitations under -- the License. -module BTLS.Result where +module BTLS.Result + ( alwaysSucceeds, requireSuccess + , Error, file, line, errorData, errorDataIsHumanReadable + ) where import Control.Exception (assert) import Control.Monad (when) +import Data.Bits ((.&.)) +import Data.ByteString (ByteString) +import Foreign (allocaArray) +import Foreign.C.String (peekCString) import Foreign.C.Types +import Foreign.Marshal.Unsafe (unsafeLocalState) + +import BTLS.BoringSSL.Err alwaysSucceeds :: CInt -> IO () alwaysSucceeds r = assert (r == 1) (return ()) requireSuccess :: CInt -> IO () requireSuccess r = when (r /= 1) $ ioError (userError "BoringSSL failure") + +data Error = Error + { err :: Err + , file :: FilePath + , line :: Int + , errorData :: Maybe ByteString + , flags :: CInt + } deriving Eq + +errorDataIsHumanReadable :: Error -> Bool +errorDataIsHumanReadable e = flags e .&. errFlagString == 1 + +instance Show Error where + show e = + let len = 120 in + unsafeLocalState $ + allocaArray len $ \pOut -> do + errErrorStringN (err e) pOut len + peekCString pOut -- cgit v1.2.3