From e74149a7569afd1ea7d67c77f40c37471e7e3e58 Mon Sep 17 00:00:00 2001 From: Benjamin Barenblat Date: Fri, 28 Sep 2018 18:33:35 -0400 Subject: Begin implementing symmetric encryption Support RC4. Future commits will add support for more modern algorithms. --- src/BTLS/BoringSSL/Base.chs | 9 +++ src/BTLS/BoringSSL/Cipher.chs | 92 +++++++++++++++++++++++++++ src/BTLS/Buffer.hs | 3 +- src/BTLS/Result.hs | 9 ++- src/Codec/Crypto/Encryption.hs | 138 +++++++++++++++++++++++++++++++++++++++++ 5 files changed, 247 insertions(+), 4 deletions(-) create mode 100644 src/BTLS/BoringSSL/Cipher.chs create mode 100644 src/Codec/Crypto/Encryption.hs (limited to 'src') diff --git a/src/BTLS/BoringSSL/Base.chs b/src/BTLS/BoringSSL/Base.chs index 347e3f4..28c287b 100644 --- a/src/BTLS/BoringSSL/Base.chs +++ b/src/BTLS/BoringSSL/Base.chs @@ -36,6 +36,15 @@ data EVPMDCtx data EVPMD {#pointer *EVP_MD as 'Ptr EVPMD' -> EVPMD nocode#} +-- | The BoringSSL @EVP_CIPHER_CTX@ type, representing the state of a pending +-- encryption or decryption operation. +data EVPCipherCtx +{#pointer *EVP_CIPHER_CTX as 'Ptr EVPCipherCtx' -> EVPCipherCtx nocode#} + +-- | The BoringSSL @EVP_CIPHER@ type, representing a cipher algorithm. +data EVPCipher +{#pointer *EVP_CIPHER as 'Ptr EVPCipher' -> EVPCipher nocode#} + -- | The BoringSSL @HMAC_CTX@ type, representing the state of a pending HMAC -- operation. data HMACCtx diff --git a/src/BTLS/BoringSSL/Cipher.chs b/src/BTLS/BoringSSL/Cipher.chs new file mode 100644 index 0000000..ac966d9 --- /dev/null +++ b/src/BTLS/BoringSSL/Cipher.chs @@ -0,0 +1,92 @@ +-- 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. + +{-# OPTIONS_GHC -Wno-missing-methods #-} + +module BTLS.BoringSSL.Cipher + ( evpRC4 + , mallocEVPCipherCtx + , evpCipherInitEx, evpCipherUpdate, evpCipherFinalEx + , evpCipherCtxSetKeyLength + , evpCipherNID, evpCipherBlockSize, evpCipherKeyLength, evpCipherIVLength + , CipherDirection(ReuseDirection, Decrypt, Encrypt) + ) where + +import Data.ByteString (ByteString) +import Foreign (FinalizerPtr, ForeignPtr, Ptr, Storable(alignment, sizeOf), withForeignPtr) +import Foreign.C.Types + +{#import BTLS.BoringSSL.Base#} +import BTLS.Buffer (unsafeUseAsCBuffer) +import BTLS.CreateWithFinalizer (createWithFinalizer) + +#include + +data CipherDirection = ReuseDirection | Decrypt | Encrypt + deriving (Eq, Show) + +instance Enum CipherDirection where + fromEnum ReuseDirection = -1 + fromEnum Decrypt = 0 + fromEnum Encrypt = 1 + +{#fun pure EVP_rc4 as evpRC4 {} -> `Ptr EVPCipher'#} + +-- | Memory-safe allocator for 'EVPCipherCtx'. +mallocEVPCipherCtx :: IO (ForeignPtr EVPCipherCtx) +mallocEVPCipherCtx = + createWithFinalizer {#call EVP_CIPHER_CTX_init as ^#} btlsFinalizeEVPCipherCtxPtr + +foreign import ccall "&btlsFinalizeEVPCipherCtx" + btlsFinalizeEVPCipherCtxPtr :: FinalizerPtr EVPCipherCtx + +{#fun EVP_CipherInit_ex as evpCipherInitEx + { withForeignPtr* `ForeignPtr EVPCipherCtx' + , `Ptr EVPCipher' + , `Ptr Engine' + , id `Ptr CUChar' + , id `Ptr CUChar' + , 'fromIntegral . fromEnum' `CipherDirection' + } -> `Int'#} + +{#fun EVP_CipherUpdate as evpCipherUpdate + { withForeignPtr* `ForeignPtr EVPCipherCtx' + , id `Ptr CUChar' + , id `Ptr CInt' + , unsafeUseAsCBuffer* `ByteString'& + } -> `Int'#} + +{#fun EVP_CipherFinal_ex as evpCipherFinalEx + { withForeignPtr* `ForeignPtr EVPCipherCtx' + , id `Ptr CUChar' + , id `Ptr CInt' + } -> `Int'#} + +{#fun EVP_CIPHER_CTX_set_key_length as evpCipherCtxSetKeyLength + {withForeignPtr* `ForeignPtr EVPCipherCtx', `Int'} -> `Int'#} + +{#fun pure EVP_CIPHER_nid as evpCipherNID {`Ptr EVPCipher'} -> `Int'#} + +{#fun pure EVP_CIPHER_block_size as evpCipherBlockSize + {`Ptr EVPCipher'} -> `Int'#} + +{#fun pure EVP_CIPHER_key_length as evpCipherKeyLength + {`Ptr EVPCipher'} -> `Int'#} + +{#fun pure EVP_CIPHER_iv_length as evpCipherIVLength + {`Ptr EVPCipher'} -> `Int'#} + +instance Storable EVPCipherCtx where + sizeOf _ = {#sizeof EVP_CIPHER_CTX#} + alignment _ = {#alignof EVP_CIPHER_CTX#} diff --git a/src/BTLS/Buffer.hs b/src/BTLS/Buffer.hs index 354c787..a74acf5 100644 --- a/src/BTLS/Buffer.hs +++ b/src/BTLS/Buffer.hs @@ -26,7 +26,8 @@ import qualified Data.ByteString.Unsafe as ByteString import Foreign (Storable(peek), Ptr, alloca, allocaArray, castPtr) import Foreign.C.Types -unsafeUseAsCBuffer :: ByteString -> ((Ptr a, CULong) -> IO b) -> IO b +unsafeUseAsCBuffer :: + Integral size => ByteString -> ((Ptr a, size) -> IO b) -> IO b unsafeUseAsCBuffer bs f = ByteString.unsafeUseAsCStringLen bs $ \(pStr, len) -> f (castPtr pStr, fromIntegral len) diff --git a/src/BTLS/Result.hs b/src/BTLS/Result.hs index a3c153c..f75d89e 100644 --- a/src/BTLS/Result.hs +++ b/src/BTLS/Result.hs @@ -15,7 +15,7 @@ module BTLS.Result ( alwaysSucceeds, requireSuccess , Result, Error, file, line, errorData, errorDataIsHumanReadable - , check + , check, check' ) where import Control.Concurrent (rtsSupportsBoundThreads, runInBoundThread) @@ -70,10 +70,13 @@ dequeueError = do return (Just (errorFromTuple e)) check :: IO Int -> ExceptT [Error] IO () -check f = do +check = ExceptT . check' + +check' :: IO Int -> IO (Either [Error] ()) +check' f = do unless rtsSupportsBoundThreads $ error "btls requires the threaded runtime. Please recompile with -threaded." - ExceptT $ runInBoundThread $ do + runInBoundThread $ do -- TODO(bbaren): Assert that the error queue is clear r <- f if r == 1 diff --git a/src/Codec/Crypto/Encryption.hs b/src/Codec/Crypto/Encryption.hs new file mode 100644 index 0000000..d22ff77 --- /dev/null +++ b/src/Codec/Crypto/Encryption.hs @@ -0,0 +1,138 @@ +-- 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 Codec.Crypto.Encryption + ( Cipher, blockSize + , rc4 + , doCipher, lazyCipher, CipherParams(..) + , CipherDirection(Encrypt, Decrypt) + + -- * Error handling + , Error + ) where + +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Foreign (ForeignPtr, Ptr, nullPtr) +import Foreign.C.Types +import Foreign.Marshal.Unsafe (unsafeLocalState) +import System.IO.Unsafe (unsafeInterleaveIO) + +import BTLS.BoringSSL.Base (EVPCipher, EVPCipherCtx, noEngine) +import BTLS.BoringSSL.Cipher +import BTLS.BoringSSL.Obj (objNID2SN) +import BTLS.Buffer (onBufferOfMaxSize', unsafeUseAsCBuffer) +import BTLS.Result (Error, check) + +-- | A cipher. +newtype Cipher = Cipher (Ptr EVPCipher) + +instance Eq Cipher where + Cipher a == Cipher b = evpCipherNID a == evpCipherNID b + +instance Show Cipher where + show (Cipher c) = maybe "" id (objNID2SN (evpCipherNID c)) + +blockSize :: Cipher -> Int +blockSize (Cipher c) = evpCipherBlockSize c + +rc4 :: Cipher +rc4 = Cipher evpRC4 + +data CipherParams = CipherParams + { cipher :: Cipher + , secretKey :: ByteString + , iv :: ByteString + , direction :: CipherDirection + } deriving (Eq, Show) + +-- | Performs an encryption or decryption operation. +doCipher :: CipherParams -> Lazy.ByteString -> Either [Error] ByteString +doCipher params plaintext = mconcat <$> sequence (lazyCipher params plaintext) + +lazyCipher :: CipherParams -> Lazy.ByteString -> [Either [Error] ByteString] +lazyCipher params plaintext = + unsafeLocalState $ do + ctx <- mallocEVPCipherCtx + -- TODO(bbaren): Do 'key params' and 'iv params' need to remain live past + -- initialization? If not, we could move these 'unsafeUseAsCBuffer's into + -- 'initializeCipherCtx'. + unsafeUseAsCBuffer (secretKey params) $ \(pKey, keyLen) -> + unsafeUseAsCBuffer (iv params) $ \(pIV, _ivLen) -> do + -- TODO(bbaren): Validate key and IV length. + initializeResult <- runExceptT $ + initializeCipherCtx ctx params (pKey, keyLen) pIV + case initializeResult of + Left e -> return [Left e] + Right () -> + cipherChunks ctx (cipher params) (ByteString.Lazy.toChunks plaintext) + +-- | Initializes a cipher context and sets the key length. +initializeCipherCtx :: + ForeignPtr EVPCipherCtx + -> CipherParams + -> (Ptr CUChar, Int) + -> Ptr CUChar + -> ExceptT [Error] IO () +initializeCipherCtx ctx params (pKey, keyLen) pIV = do + let Cipher pCipher = cipher params + engine = noEngine + -- This function deals with a catch-22: We can't call + -- 'evpCipherCtxSetKeyLength' on an uninitialized 'EVPCipherCtx', but + -- 'evpCipherInitEx' requires a key of @keyLength cipher@ in length. + -- Fortunately, @EVP_CipherInit_ex@'s documentation says that "If ctx has been + -- previously configured with a cipher then cipher, key and iv may be NULL + -- [...] to reuse the previous values." So first, we call 'evpCipherInitEx' + -- with a dummy key (@NULL@); then, we set the key length; and finally, we + -- reload 'ctx' with the actual key. + check $ evpCipherInitEx ctx pCipher engine dummyKey pIV (direction params) + check $ evpCipherCtxSetKeyLength ctx keyLen + check $ evpCipherInitEx ctx reuseCipher engine pKey reuseIV ReuseDirection + where dummyKey = nullPtr + reuseCipher = nullPtr + reuseIV = nullPtr + +-- | Lazily performs a cipher operation on 'chunks'. The operation will stop +-- when all chunks have been ciphered or at the first error. +cipherChunks :: + ForeignPtr EVPCipherCtx + -> Cipher + -> [ByteString] + -> IO [Either [Error] ByteString] +cipherChunks ctx cipher = loop + where loop (x:xs) = do + y <- cipherChunk ctx cipher x + case y of + e@(Left _) -> return [e] -- Encrypting the chunk failed, so give up. + Right _ -> do + ys <- unsafeInterleaveIO (loop xs) -- Lazily keep encrypting. + return (y : ys) + loop [] = do + -- Grab any remaining data. + y <- onBufferOfMaxSize' (blockSize cipher) $ \pOut pOutLen -> + check $ evpCipherFinalEx ctx pOut pOutLen + return [y] + +cipherChunk :: + ForeignPtr EVPCipherCtx + -> Cipher + -> ByteString + -> IO (Either [Error] ByteString) +cipherChunk ctx (Cipher pCipher) chunk = do + let maxCiphertextLen = ByteString.length chunk + evpCipherBlockSize pCipher + onBufferOfMaxSize' maxCiphertextLen $ \pOut pOutLen -> + check $ evpCipherUpdate ctx pOut pOutLen chunk -- cgit v1.2.3