From d1a85eb87934d348c9789aec59c751fa615ec363 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Thu, 23 Aug 2018 17:24:47 -0400 Subject: Clean up casts Use unsigned char buffers more pervasively throughout the code. This removes most calls to `asCUCharBuf`, isolating `unsafeCoerce` further. By making some type signatures slightly more flexible, also eliminate most explicit integer conversions. --- btls.cabal | 1 + src/BTLS/BoringSSLPatterns.hs | 18 ++++++++---------- src/BTLS/Buffer.hs | 41 +++++++++++++++++++++++++++++++++++++++++ src/BTLS/Cast.hs | 4 ---- src/Codec/Crypto/HKDF.hs | 30 ++++++++++-------------------- src/Data/Digest.hs | 13 ++----------- src/Data/HMAC.hs | 14 ++++---------- src/System/Random/Crypto.hs | 7 +++---- 8 files changed, 69 insertions(+), 59 deletions(-) create mode 100644 src/BTLS/Buffer.hs diff --git a/btls.cabal b/btls.cabal index 3461300..5c9d68a 100644 --- a/btls.cabal +++ b/btls.cabal @@ -78,6 +78,7 @@ library , BTLS.BoringSSL.Mem , BTLS.BoringSSL.Rand , BTLS.BoringSSLPatterns + , BTLS.Buffer , BTLS.Cast , BTLS.CreateWithFinalizer , BTLS.Result diff --git a/src/BTLS/BoringSSLPatterns.hs b/src/BTLS/BoringSSLPatterns.hs index e77abcb..44f4b0c 100644 --- a/src/BTLS/BoringSSLPatterns.hs +++ b/src/BTLS/BoringSSLPatterns.hs @@ -18,13 +18,12 @@ module BTLS.BoringSSLPatterns ) where import Data.ByteString (ByteString) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Unsafe as ByteString import qualified Data.ByteString.Lazy as ByteString.Lazy import Foreign (ForeignPtr, Storable(peek), Ptr, alloca, allocaArray, withForeignPtr) import Foreign.C.Types import BTLS.BoringSSL.Digest (evpMaxMDSize) +import BTLS.Buffer (packCUStringLen, unsafeUseAsCUStringLen) type LazyByteString = ByteString.Lazy.ByteString @@ -41,8 +40,8 @@ type LazyByteString = ByteString.Lazy.ByteString initUpdateFinalize :: IO (ForeignPtr ctx) -> (Ptr ctx -> IO ()) - -> (Ptr ctx -> Ptr CChar -> CULong -> IO ()) - -> (Ptr ctx -> Ptr CChar -> Ptr CUInt -> IO ()) + -> (Ptr ctx -> Ptr CUChar -> CULong -> IO ()) + -> (Ptr ctx -> Ptr CUChar -> Ptr CUInt -> IO ()) -> LazyByteString -> IO ByteString initUpdateFinalize mallocCtx initialize update finalize bytes = do @@ -54,9 +53,8 @@ initUpdateFinalize mallocCtx initialize update finalize bytes = do where updateBytes ctx chunk = -- The updater won't mutate its arguments, so the sharing inherent in - -- 'ByteString.unsafeUseAsCStringLen' is fine. - ByteString.unsafeUseAsCStringLen chunk $ \(buf, len) -> - update ctx buf (fromIntegral len) + -- 'unsafeUseAsCUStringLen' is fine. + unsafeUseAsCUStringLen chunk $ \(buf, len) -> update ctx buf len -- | Allocates a buffer, runs a function 'f' to partially fill it, and packs the -- filled data into a 'ByteString'. 'f' must write the size of the filled data, @@ -67,11 +65,11 @@ initUpdateFinalize mallocCtx initialize update finalize bytes = do onBufferOfMaxSize :: (Integral size, Storable size) => Int - -> (Ptr CChar -> Ptr size -> IO ()) + -> (Ptr CUChar -> Ptr size -> IO ()) -> IO ByteString onBufferOfMaxSize maxSize f = allocaArray maxSize $ \pOut -> alloca $ \pOutLen -> do f pOut pOutLen - outLen <- fromIntegral <$> peek pOutLen - ByteString.packCStringLen (pOut, outLen) + outLen <- peek pOutLen + packCUStringLen (pOut, outLen) diff --git a/src/BTLS/Buffer.hs b/src/BTLS/Buffer.hs new file mode 100644 index 0000000..d7b3f14 --- /dev/null +++ b/src/BTLS/Buffer.hs @@ -0,0 +1,41 @@ +-- 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 BTLS.Buffer + ( unsafeUseAsCUStringLen + , packCUStringLen + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Unsafe as ByteString +import Foreign (Ptr) +import Foreign.C.Types +import Unsafe.Coerce (unsafeCoerce) + +unsafeUseAsCUStringLen :: + Integral n => ByteString -> ((Ptr CUChar, n) -> IO a) -> IO a +unsafeUseAsCUStringLen bs f = + ByteString.unsafeUseAsCStringLen bs $ \(pStr, len) -> + f (asCUCharBuf pStr, fromIntegral len) + +packCUStringLen :: Integral n => (Ptr CUChar, n) -> IO ByteString +packCUStringLen (pStr, len) = + ByteString.packCStringLen (asCCharBuf pStr, fromIntegral len) + +asCUCharBuf :: Ptr CChar -> Ptr CUChar +asCUCharBuf = unsafeCoerce + +asCCharBuf :: Ptr CUChar -> Ptr CChar +asCCharBuf = unsafeCoerce diff --git a/src/BTLS/Cast.hs b/src/BTLS/Cast.hs index a467c90..6f29469 100644 --- a/src/BTLS/Cast.hs +++ b/src/BTLS/Cast.hs @@ -15,11 +15,7 @@ module BTLS.Cast where import Foreign (Ptr) -import Foreign.C.Types import Unsafe.Coerce (unsafeCoerce) -asCUCharBuf :: Ptr CChar -> Ptr CUChar -asCUCharBuf = unsafeCoerce - asVoidPtr :: Ptr a -> Ptr () asVoidPtr = unsafeCoerce diff --git a/src/Codec/Crypto/HKDF.hs b/src/Codec/Crypto/HKDF.hs index ac86bcc..724ab04 100644 --- a/src/Codec/Crypto/HKDF.hs +++ b/src/Codec/Crypto/HKDF.hs @@ -17,15 +17,13 @@ module Codec.Crypto.HKDF , hkdf, extract, expand ) where -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Unsafe as ByteString import Foreign (allocaArray) import Foreign.Marshal.Unsafe (unsafeLocalState) import BTLS.BoringSSL.Digest (evpMaxMDSize) import BTLS.BoringSSL.HKDF import BTLS.BoringSSLPatterns (onBufferOfMaxSize) -import BTLS.Cast (asCUCharBuf) +import BTLS.Buffer (packCUStringLen, unsafeUseAsCUStringLen) import BTLS.Types ( Algorithm(Algorithm), AssociatedData(AssociatedData), Salt(Salt) , SecretKey(SecretKey), noSalt @@ -42,14 +40,10 @@ extract (Algorithm md) (Salt salt) (SecretKey secret) = unsafeLocalState $ onBufferOfMaxSize evpMaxMDSize $ \pOutKey pOutLen -> do -- @HKDF_extract@ won't mutate @secret@ or @salt@, so the sharing inherent - -- in 'ByteString.unsafeUseAsCStringLen' is fine. - ByteString.unsafeUseAsCStringLen secret $ \(pSecret, secretLen) -> - ByteString.unsafeUseAsCStringLen salt $ \(pSalt, saltLen) -> - hkdfExtract - (asCUCharBuf pOutKey) pOutLen - md - (asCUCharBuf pSecret) (fromIntegral secretLen) - (asCUCharBuf pSalt) (fromIntegral saltLen) + -- in 'unsafeUseAsCUStringLen' is fine. + unsafeUseAsCUStringLen secret $ \(pSecret, secretLen) -> + unsafeUseAsCUStringLen salt $ \(pSalt, saltLen) -> + hkdfExtract pOutKey pOutLen md pSecret secretLen pSalt saltLen -- | Computes HKDF output key material (OKM) as specified by RFC 5869. expand :: Algorithm -> AssociatedData -> Int -> SecretKey -> SecretKey @@ -58,12 +52,8 @@ expand (Algorithm md) (AssociatedData info) outLen (SecretKey secret) = unsafeLocalState $ allocaArray outLen $ \pOutKey -> do -- @HKDF_expand@ won't mutate @secret@ or @info@, so the sharing inherent - -- in 'ByteString.unsafeUseAsCStringLen' is fine. - ByteString.unsafeUseAsCStringLen secret $ \(pSecret, secretLen) -> - ByteString.unsafeUseAsCStringLen info $ \(pInfo, infoLen) -> - hkdfExpand - (asCUCharBuf pOutKey) (fromIntegral outLen) - md - (asCUCharBuf pSecret) (fromIntegral secretLen) - (asCUCharBuf pInfo) (fromIntegral infoLen) - ByteString.packCStringLen (pOutKey, outLen) + -- in 'unsafeUseAsCUStringLen' is fine. + unsafeUseAsCUStringLen secret $ \(pSecret, secretLen) -> + unsafeUseAsCUStringLen info $ \(pInfo, infoLen) -> + hkdfExpand pOutKey (fromIntegral outLen) md pSecret secretLen pInfo infoLen + packCUStringLen (pOutKey, outLen) diff --git a/src/Data/Digest.hs b/src/Data/Digest.hs index 0587d2b..3e6f263 100644 --- a/src/Data/Digest.hs +++ b/src/Data/Digest.hs @@ -27,7 +27,6 @@ import Foreign.Marshal.Unsafe (unsafeLocalState) import BTLS.BoringSSL.Base import BTLS.BoringSSL.Digest import BTLS.BoringSSLPatterns (initUpdateFinalize) -import BTLS.Cast (asCUCharBuf) import BTLS.Types (Algorithm(Algorithm), Digest(Digest)) type LazyByteString = ByteString.Lazy.ByteString @@ -45,13 +44,5 @@ hash :: Algorithm -> LazyByteString -> Digest hash (Algorithm md) = Digest . unsafeLocalState - . initUpdateFinalize mallocEVPMDCtx initialize evpDigestUpdate finalize - where - initialize ctx = evpDigestInitEx ctx md noEngine - - finalize ctx mdOut pOutSize = - -- 'mdOut' is a 'Ptr CChar'. However, to make life more interesting, - -- 'evpDigestFinalEx' requires a 'Ptr CUChar'. To work around this, - -- we're going to cheat and let Haskell reinterpret-cast 'mdOut' to 'Ptr - -- CUChar. - evpDigestFinalEx ctx (asCUCharBuf mdOut) pOutSize + . initUpdateFinalize mallocEVPMDCtx initialize evpDigestUpdate evpDigestFinalEx + where initialize ctx = evpDigestInitEx ctx md noEngine diff --git a/src/Data/HMAC.hs b/src/Data/HMAC.hs index 8697c20..1850103 100644 --- a/src/Data/HMAC.hs +++ b/src/Data/HMAC.hs @@ -27,7 +27,7 @@ import BTLS.BoringSSL.Base import BTLS.BoringSSL.HMAC import BTLS.BoringSSL.Mem (cryptoMemcmp) import BTLS.BoringSSLPatterns (initUpdateFinalize) -import BTLS.Cast (asCUCharBuf) +import BTLS.Buffer (unsafeUseAsCUStringLen) import BTLS.Types (Algorithm(Algorithm), Digest(Digest), SecretKey(SecretKey)) type LazyByteString = ByteString.Lazy.ByteString @@ -51,14 +51,8 @@ hmac :: Algorithm -> SecretKey -> LazyByteString -> HMAC hmac (Algorithm md) (SecretKey key) = HMAC . unsafeLocalState - . initUpdateFinalize mallocHMACCtx initialize update finalize + . initUpdateFinalize mallocHMACCtx initialize hmacUpdate hmacFinal where initialize ctx = - ByteString.unsafeUseAsCStringLen key $ \(keyBytes, keySize) -> - hmacInitEx ctx keyBytes (fromIntegral keySize) md noEngine - - -- initUpdateFinalize deals with buffers that are 'Ptr CChar'. However, - -- BoringSSL's HMAC functions deal with buffers that are 'Ptr CUChar'. As - -- in Data.Digest, we'll let Haskell reinterpret-cast the buffers. - update ctx buf len = hmacUpdate ctx (asCUCharBuf buf) len - finalize ctx hmacOut pOutSize = hmacFinal ctx (asCUCharBuf hmacOut) pOutSize + unsafeUseAsCUStringLen key $ \(keyBytes, keySize) -> + hmacInitEx ctx keyBytes keySize md noEngine diff --git a/src/System/Random/Crypto.hs b/src/System/Random/Crypto.hs index ca2fba5..903f7aa 100644 --- a/src/System/Random/Crypto.hs +++ b/src/System/Random/Crypto.hs @@ -17,15 +17,14 @@ module System.Random.Crypto ) where import Data.ByteString (ByteString) -import qualified Data.ByteString as ByteString import Foreign (allocaArray) import BTLS.BoringSSL.Rand (randBytes) -import BTLS.Cast (asCUCharBuf) +import BTLS.Buffer (packCUStringLen) -- | Generates a cryptographically random buffer of the specified size. randomBytes :: Int -> IO ByteString randomBytes len = allocaArray len $ \pBuf -> do - randBytes (asCUCharBuf pBuf) (fromIntegral len) - ByteString.packCStringLen (pBuf, len) + randBytes pBuf (fromIntegral len) + packCUStringLen (pBuf, len) -- cgit v1.2.3