diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -5,7 +5,7 @@ can generate RSA and DSA keys, read and write PEM files, generate message digests, sign and verify messages, encrypt and decrypt messages. -Version: 0.7 +Version: 0.8 License: PublicDomain License-File: COPYING Author: Adam Langley , PHO diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,4 +1,26 @@ --*- Coding: utf-8 -*- +-*- coding: utf-8 -*- + +Changes from 0.7 to 0.8 +----------------------- +* Applied 7 patches by Taru Karttunen: + + - Add cipherStrictLBS - Encrypt a lazy bytestring in a strict + manner. Does not leak the keys + + - Add rsaCopyPublic and rsaKeyPairFinalize to OpenSSL.RSA + + - Document pkcs5_pbkdf2_hmac_sha1 in OpenSSL.EVP.Digest + + - Make OpenSSL.EVP.Sign.signFinal use ByteStrings internally + + - Export OpenSSL.EVP.Sign.signFinal + + - Add PEM-functionality with a new PwBS that works like PwStr except + there are no superfluous extra copies retained in the memory. + + - Make PEM callbacks use bracket which makes cleanup work even if + there are exceptions. + Changes from 0.6.5 to 0.7 ------------------------- diff --git a/OpenSSL/ASN1.hsc b/OpenSSL/ASN1.hsc --- a/OpenSSL/ASN1.hsc +++ b/OpenSSL/ASN1.hsc @@ -90,8 +90,8 @@ allocaASN1Integer :: (Ptr ASN1_INTEGER -> IO a) -> IO a -allocaASN1Integer m - = bracket _ASN1_INTEGER_new _ASN1_INTEGER_free m +allocaASN1Integer + = bracket _ASN1_INTEGER_new _ASN1_INTEGER_free withASN1Integer :: Integer -> (Ptr ASN1_INTEGER -> IO a) -> IO a @@ -149,13 +149,13 @@ allocaASN1Time :: (Ptr ASN1_TIME -> IO a) -> IO a -allocaASN1Time m - = bracket _ASN1_TIME_new _ASN1_TIME_free m +allocaASN1Time + = bracket _ASN1_TIME_new _ASN1_TIME_free withASN1Time :: UTCTime -> (Ptr ASN1_TIME -> IO a) -> IO a withASN1Time utc m = allocaASN1Time $ \ time -> - do _ASN1_TIME_set time (fromIntegral $ (round $ utcTimeToPOSIXSeconds utc :: Integer)) + do _ASN1_TIME_set time (fromIntegral (round $ utcTimeToPOSIXSeconds utc :: Integer)) >>= failIfNull_ m time diff --git a/OpenSSL/BIO.hsc b/OpenSSL/BIO.hsc --- a/OpenSSL/BIO.hsc +++ b/OpenSSL/BIO.hsc @@ -113,7 +113,8 @@ wrapBioPtr :: Ptr BIO_ -> IO BIO -wrapBioPtr bioPtr = Conc.newForeignPtr bioPtr (_free bioPtr) >>= return . BIO +wrapBioPtr bioPtr + = fmap BIO (Conc.newForeignPtr bioPtr (_free bioPtr)) withBioPtr :: BIO -> (Ptr BIO_ -> IO a) -> IO a @@ -174,13 +175,13 @@ setFlags :: BIO -> CInt -> IO () setFlags bio flags - = withBioPtr bio $ \ bioPtr -> - _set_flags bioPtr flags + = withBioPtr bio $ flip _set_flags flags + bioShouldRetry :: BIO -> IO Bool bioShouldRetry bio = withBioPtr bio $ \ bioPtr -> - _should_retry bioPtr >>= return . (/= 0) + fmap (/= 0) (_should_retry bioPtr) {- ctrl --------------------------------------------------------------------- -} @@ -215,7 +216,7 @@ bioEOF :: BIO -> IO Bool bioEOF bio = withBioPtr bio $ \ bioPtr -> - _eof bioPtr >>= return . (== 1) + fmap (==1) (_eof bioPtr) {- I/O ---------------------------------------------------------------------- -} @@ -253,7 +254,7 @@ -- |@'bioReadLBS' bio@ lazily reads all data in @bio@, then return a -- LazyByteString. bioReadLBS :: BIO -> IO L.ByteString -bioReadLBS bio = lazyRead >>= return . L.fromChunks +bioReadLBS bio = fmap L.fromChunks lazyRead where chunkSize = L.defaultChunkSize diff --git a/OpenSSL/Cipher.hsc b/OpenSSL/Cipher.hsc --- a/OpenSSL/Cipher.hsc +++ b/OpenSSL/Cipher.hsc @@ -20,7 +20,7 @@ , aesCTR) where -import Control.Monad (when) +import Control.Monad (when, unless) import Data.IORef import Foreign import Foreign.C.Types @@ -69,7 +69,7 @@ -> IO AESCtx newAESCtx mode key iv = do let keyLen = BS.length key * 8 - when (not $ any ((==) keyLen) [128, 192, 256]) $ fail "Bad AES key length" + unless (any (keyLen ==) [128, 192, 256]) $ fail "Bad AES key length" when (BS.length iv /= 16) $ fail "Bad AES128 iv length" ctx <- mallocForeignPtrBytes (#size AES_KEY) withForeignPtr ctx $ \ctxPtr -> @@ -105,7 +105,7 @@ -> BS.ByteString -- ^ input, any number of bytes -> IO BS.ByteString aesCTR (AESCtx _ _ _ _ Decrypt) _ = fail "the context mode must be Encrypt" -aesCTR (AESCtx ctx iv ecounter nref Encrypt) input = do +aesCTR (AESCtx ctx iv ecounter nref Encrypt) input = withForeignPtr ctx $ \ctxPtr -> withForeignPtr iv $ \ivPtr -> withForeignPtr ecounter $ \ecptr -> diff --git a/OpenSSL/DSA.hsc b/OpenSSL/DSA.hsc --- a/OpenSSL/DSA.hsc +++ b/OpenSSL/DSA.hsc @@ -62,7 +62,7 @@ dsaSize dsa = unsafePerformIO $ withDSAPtr dsa $ \ dsaPtr -> - _size dsaPtr >>= return . fromIntegral + fmap fromIntegral (_size dsaPtr) -- |Return the public prime number of the key. dsaP :: k -> Integer @@ -89,7 +89,7 @@ instance DSAKey DSAPubKey where withDSAPtr (DSAPubKey fp) = withForeignPtr fp peekDSAPtr dsaPtr = _pubDup dsaPtr >>= absorbDSAPtr - absorbDSAPtr dsaPtr = newForeignPtr _free dsaPtr >>= return . Just . DSAPubKey + absorbDSAPtr dsaPtr = fmap (Just . DSAPubKey) (newForeignPtr _free dsaPtr) instance DSAKey DSAKeyPair where @@ -103,14 +103,14 @@ absorbDSAPtr dsaPtr = do hasP <- hasDSAPrivateKey dsaPtr if hasP then - newForeignPtr _free dsaPtr >>= return . Just . DSAKeyPair + fmap (Just . DSAKeyPair) (newForeignPtr _free dsaPtr) else return Nothing hasDSAPrivateKey :: Ptr DSA -> IO Bool hasDSAPrivateKey dsaPtr - = (#peek DSA, priv_key) dsaPtr >>= return . (/= nullPtr) + = fmap (/= nullPtr) ((#peek DSA, priv_key) dsaPtr) foreign import ccall unsafe "&DSA_free" @@ -162,8 +162,8 @@ -> IO (Int, Int, Integer, Integer, Integer) -- ^ (iteration count, generator count, p, q, g) generateDSAParameters nbits mseed = do when (nbits < 512 || nbits > 1024) $ fail "Invalid DSA bit size" - alloca (\i1 -> do - alloca (\i2 -> do + alloca (\i1 -> + alloca (\i2 -> (\x -> case mseed of Nothing -> x (nullPtr, 0) Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do @@ -204,11 +204,11 @@ -> IO DSAKeyPair generateDSAKey p q g = do ptr <- _dsa_new - newBN p >>= return . unwrapBN >>= (#poke DSA, p) ptr - newBN q >>= return . unwrapBN >>= (#poke DSA, q) ptr - newBN g >>= return . unwrapBN >>= (#poke DSA, g) ptr + fmap unwrapBN (newBN p) >>= (#poke DSA, p) ptr + fmap unwrapBN (newBN q) >>= (#poke DSA, q) ptr + fmap unwrapBN (newBN g) >>= (#poke DSA, g) ptr _dsa_generate_key ptr - newForeignPtr _free ptr >>= return . DSAKeyPair + fmap DSAKeyPair (newForeignPtr _free ptr) -- |Return the private key @x@. dsaPrivate :: DSAKeyPair -> Integer @@ -242,47 +242,47 @@ tupleToDSAPubKey :: (Integer, Integer, Integer, Integer) -> DSAPubKey tupleToDSAPubKey (p, q, g, pub) = unsafePerformIO $ do ptr <- _dsa_new - newBN p >>= return . unwrapBN >>= (#poke DSA, p) ptr - newBN q >>= return . unwrapBN >>= (#poke DSA, q) ptr - newBN g >>= return . unwrapBN >>= (#poke DSA, g) ptr - newBN pub >>= return . unwrapBN >>= (#poke DSA, pub_key) ptr + fmap unwrapBN (newBN p ) >>= (#poke DSA, p) ptr + fmap unwrapBN (newBN q ) >>= (#poke DSA, q) ptr + fmap unwrapBN (newBN g ) >>= (#poke DSA, g) ptr + fmap unwrapBN (newBN pub) >>= (#poke DSA, pub_key) ptr (#poke DSA, priv_key) ptr nullPtr - newForeignPtr _free ptr >>= return . DSAPubKey + fmap DSAPubKey (newForeignPtr _free ptr) -- | Convert a tuple of members (in the same format as from -- 'dsaPubKeyToTuple') into a DSAPubKey object tupleToDSAKeyPair :: (Integer, Integer, Integer, Integer, Integer) -> DSAKeyPair tupleToDSAKeyPair (p, q, g, pub, pri) = unsafePerformIO $ do ptr <- _dsa_new - newBN p >>= return . unwrapBN >>= (#poke DSA, p) ptr - newBN q >>= return . unwrapBN >>= (#poke DSA, q) ptr - newBN g >>= return . unwrapBN >>= (#poke DSA, g) ptr - newBN pub >>= return . unwrapBN >>= (#poke DSA, pub_key ) ptr - newBN pri >>= return . unwrapBN >>= (#poke DSA, priv_key) ptr - newForeignPtr _free ptr >>= return . DSAKeyPair + fmap unwrapBN (newBN p ) >>= (#poke DSA, p) ptr + fmap unwrapBN (newBN q ) >>= (#poke DSA, q) ptr + fmap unwrapBN (newBN g ) >>= (#poke DSA, g) ptr + fmap unwrapBN (newBN pub) >>= (#poke DSA, pub_key ) ptr + fmap unwrapBN (newBN pri) >>= (#poke DSA, priv_key) ptr + fmap DSAKeyPair (newForeignPtr _free ptr) -- | A utility function to generate both the parameters and the key pair at the -- same time. Saves serialising and deserialising the parameters too generateDSAParametersAndKey :: Int -- ^ The number of bits in the generated prime: 512 <= x <= 1024 -> Maybe BS.ByteString -- ^ optional seed, its length must be 20 bytes -> IO DSAKeyPair -generateDSAParametersAndKey nbits mseed = do +generateDSAParametersAndKey nbits mseed = (\x -> case mseed of Nothing -> x (nullPtr, 0) Just seed -> BS.useAsCStringLen seed x) (\(seedptr, seedlen) -> do ptr <- _generate_params (fromIntegral nbits) seedptr (fromIntegral seedlen) nullPtr nullPtr nullPtr nullPtr failIfNull_ ptr _dsa_generate_key ptr - newForeignPtr _free ptr >>= return . DSAKeyPair) + fmap DSAKeyPair (newForeignPtr _free ptr)) -- | Sign pre-digested data. The DSA specs call for SHA1 to be used so, if you -- use anything else, YMMV. Returns a pair of Integers which, together, are -- the signature signDigestedDataWithDSA :: DSAKeyPair -> BS.ByteString -> IO (Integer, Integer) -signDigestedDataWithDSA dsa bytes = do - BS.useAsCStringLen bytes (\(ptr, len) -> do - alloca (\rptr -> do - alloca (\sptr -> do +signDigestedDataWithDSA dsa bytes = + BS.useAsCStringLen bytes (\(ptr, len) -> + alloca (\rptr -> + alloca (\sptr -> withDSAPtr dsa (\dsaptr -> do _dsa_sign dsaptr ptr (fromIntegral len) rptr sptr >>= failIf_ (== 0) r <- peek rptr >>= peekBN . wrapBN @@ -293,12 +293,13 @@ -- | Verify pre-digested data given a signature. verifyDigestedDataWithDSA :: DSAKey k => k -> BS.ByteString -> (Integer, Integer) -> IO Bool -verifyDigestedDataWithDSA dsa bytes (r, s) = do - BS.useAsCStringLen bytes (\(ptr, len) -> do - withBN r (\bnR -> do - withBN s (\bnS -> do - withDSAPtr dsa (\dsaptr -> do - _dsa_verify dsaptr ptr (fromIntegral len) (unwrapBN bnR) (unwrapBN bnS) >>= return . (== 1))))) +verifyDigestedDataWithDSA dsa bytes (r, s) = + BS.useAsCStringLen bytes (\(ptr, len) -> + withBN r (\bnR -> + withBN s (\bnS -> + withDSAPtr dsa (\dsaptr -> + fmap (== 1) + (_dsa_verify dsaptr ptr (fromIntegral len) (unwrapBN bnR) (unwrapBN bnS)))))) instance Eq DSAPubKey where diff --git a/OpenSSL/ERR.hsc b/OpenSSL/ERR.hsc --- a/OpenSSL/ERR.hsc +++ b/OpenSSL/ERR.hsc @@ -21,11 +21,11 @@ getError :: IO Integer -getError = _get_error >>= return . fromIntegral +getError = fmap fromIntegral _get_error peekError :: IO Integer -peekError = _peek_error >>= return . fromIntegral +peekError = fmap fromIntegral _peek_error errorString :: Integer -> IO String diff --git a/OpenSSL/EVP/Base64.hsc b/OpenSSL/EVP/Base64.hsc --- a/OpenSSL/EVP/Base64.hsc +++ b/OpenSSL/EVP/Base64.hsc @@ -54,7 +54,8 @@ = unsafePerformIO $ unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> createAndTrim maxOutLen $ \ outBuf -> - _EncodeBlock (castPtr outBuf) inBuf (fromIntegral inLen) >>= return . fromIntegral + fmap fromIntegral + (_EncodeBlock (castPtr outBuf) inBuf (fromIntegral inLen)) where maxOutLen = (inputLen `div` 3 + 1) * 4 + 1 -- +1: '\0' inputLen = B8.length inBS diff --git a/OpenSSL/EVP/Cipher.hsc b/OpenSSL/EVP/Cipher.hsc --- a/OpenSSL/EVP/Cipher.hsc +++ b/OpenSSL/EVP/Cipher.hsc @@ -29,9 +29,11 @@ , cipher , cipherBS , cipherLBS + , cipherStrictLBS ) where +import Control.Exception(bracket_) import Control.Monad import Data.ByteString.Internal (createAndTrim) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) @@ -98,14 +100,16 @@ foreign import ccall unsafe "&EVP_CIPHER_CTX_cleanup" _ctx_cleanup :: FunPtr (Ptr EVP_CIPHER_CTX -> IO ()) +foreign import ccall unsafe "EVP_CIPHER_CTX_cleanup" + _ctx_cleanup' :: Ptr EVP_CIPHER_CTX -> IO () + foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_CTX_block_size" _ctx_block_size :: Ptr EVP_CIPHER_CTX -> CInt newCtx :: IO CipherCtx newCtx = do ctx <- mallocForeignPtrBytes (#size EVP_CIPHER_CTX) - withForeignPtr ctx $ \ ctxPtr -> - _ctx_init ctxPtr + withForeignPtr ctx _ctx_init addForeignPtrFinalizer _ctx_cleanup ctx return $ CipherCtx ctx @@ -145,6 +149,23 @@ >>= failIf_ (/= 1) return ctx +-- | Encrypt a lazy bytestring in a strict manner. Does not leak the keys. +cipherStrictLBS :: Cipher -- ^ Cipher + -> B8.ByteString -- ^ Key + -> B8.ByteString -- ^ IV + -> CryptoMode -- ^ Encrypt\/Decrypt + -> L8.ByteString -- ^ Input + -> IO L8.ByteString +cipherStrictLBS (Cipher c) key iv mode input = + allocaBytes (#size EVP_CIPHER_CTX) $ \cptr -> + bracket_ (_ctx_init cptr) (_ctx_cleanup' cptr) $ + unsafeUseAsCStringLen key $ \(keyp,_) -> + unsafeUseAsCStringLen iv $ \(ivp, _) -> do + failIf_ (/= 1) =<< _CipherInit cptr c keyp ivp (cryptoModeToInt mode) + cc <- fmap CipherCtx (newForeignPtr_ cptr) + rr <- cipherUpdateBS cc `mapM` L8.toChunks input + rf <- cipherFinalBS cc + return $ L8.fromChunks (rr++[rf]) cipherUpdateBS :: CipherCtx -> B8.ByteString -> IO B8.ByteString cipherUpdateBS ctx inBS diff --git a/OpenSSL/EVP/Digest.hsc b/OpenSSL/EVP/Digest.hsc --- a/OpenSSL/EVP/Digest.hsc +++ b/OpenSSL/EVP/Digest.hsc @@ -90,8 +90,7 @@ newCtx :: IO DigestCtx newCtx = do ctx <- mallocForeignPtrBytes (#size EVP_MD_CTX) - withForeignPtr ctx $ \ ctxPtr -> - _ctx_init ctxPtr + withForeignPtr ctx _ctx_init addForeignPtrFinalizer _ctx_cleanup ctx return $ DigestCtx ctx @@ -168,22 +167,19 @@ -- |@'digestBS'@ digests a chunk of data. digestBS :: Digest -> B8.ByteString -> String digestBS md input - = unsafePerformIO $ - do ctx <- digestStrictly md input - digestFinal ctx + = unsafePerformIO + (digestStrictly md input >>= digestFinal) digestBS' :: Digest -> B8.ByteString -> B8.ByteString digestBS' md input - = unsafePerformIO $ - do ctx <- digestStrictly md input - digestFinalBS ctx + = unsafePerformIO + (digestStrictly md input >>= digestFinalBS) -- |@'digestLBS'@ digests a stream of data. digestLBS :: Digest -> L8.ByteString -> String digestLBS md input - = unsafePerformIO $ - do ctx <- digestLazily md input - digestFinal ctx + = unsafePerformIO + (digestLazily md input >>= digestFinal) {- HMAC ---------------------------------------------------------------------- -} @@ -206,6 +202,7 @@ bufLen <- liftM fromIntegral $ peek bufLenPtr B8.packCStringLen (bufPtr, bufLen) +-- | Calculate a PKCS5-PBKDF2 SHA1-HMAC suitable for password hashing. pkcs5_pbkdf2_hmac_sha1 :: B8.ByteString -- ^ password -> B8.ByteString -- ^ salt -> Int -- ^ iterations diff --git a/OpenSSL/EVP/PKey.hsc b/OpenSSL/EVP/PKey.hsc --- a/OpenSSL/EVP/PKey.hsc +++ b/OpenSSL/EVP/PKey.hsc @@ -183,8 +183,8 @@ wrapPKeyPtr :: Ptr EVP_PKEY -> IO VaguePKey -wrapPKeyPtr ptr - = newForeignPtr _pkey_free ptr >>= return . VaguePKey +wrapPKeyPtr + = fmap VaguePKey . newForeignPtr _pkey_free withPKeyPtr' :: PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a @@ -226,9 +226,7 @@ do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt case pkeyType of (#const EVP_PKEY_RSA) - -> do rsaPtr <- _get1_RSA pkeyPtr - rsaM <- absorbRSAPtr rsaPtr - return rsaM + -> _get1_RSA pkeyPtr >>= absorbRSAPtr _ -> return Nothing instance PublicKey RSAPubKey @@ -268,9 +266,7 @@ do pkeyType <- (#peek EVP_PKEY, type) pkeyPtr :: IO CInt case pkeyType of (#const EVP_PKEY_DSA) - -> do dsaPtr <- _get1_DSA pkeyPtr - dsaM <- absorbDSAPtr dsaPtr - return dsaM + -> _get1_DSA pkeyPtr >>= absorbDSAPtr _ -> return Nothing instance PublicKey DSAPubKey diff --git a/OpenSSL/EVP/Sign.hsc b/OpenSSL/EVP/Sign.hsc --- a/OpenSSL/EVP/Sign.hsc +++ b/OpenSSL/EVP/Sign.hsc @@ -7,11 +7,13 @@ ( sign , signBS , signLBS + , signFinal -- private ) where import Control.Monad import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Internal as B8 import qualified Data.ByteString.Lazy.Char8 as L8 import Foreign import Foreign.C @@ -21,20 +23,18 @@ foreign import ccall unsafe "EVP_SignFinal" - _SignFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> Ptr EVP_PKEY -> IO CInt + _SignFinal :: Ptr EVP_MD_CTX -> Ptr Word8 -> Ptr CUInt -> Ptr EVP_PKEY -> IO CInt -signFinal :: KeyPair k => DigestCtx -> k -> IO String +signFinal :: KeyPair k => DigestCtx -> k -> IO B8.ByteString signFinal ctx k = do let maxLen = pkeySize k withDigestCtxPtr ctx $ \ ctxPtr -> withPKeyPtr' k $ \ pkeyPtr -> - allocaArray maxLen $ \ bufPtr -> + B8.createAndTrim maxLen $ \ bufPtr -> alloca $ \ bufLenPtr -> - do _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr - >>= failIf_ (/= 1) - bufLen <- liftM fromIntegral $ peek bufLenPtr - peekCStringLen (bufPtr, bufLen) + do failIf_ (/= 1) =<< _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr + liftM fromIntegral $ peek bufLenPtr -- |@'sign'@ generates a signature from a stream of data. The string @@ -56,8 +56,7 @@ -> IO B8.ByteString -- ^ the result signature signBS md pkey input = do ctx <- digestStrictly md input - sig <- signFinal ctx pkey - return $ B8.pack sig + signFinal ctx pkey -- |@'signLBS'@ generates a signature from a stream of data. signLBS :: KeyPair key => @@ -68,4 +67,4 @@ signLBS md pkey input = do ctx <- digestLazily md input sig <- signFinal ctx pkey - return $ L8.pack sig + return $ L8.fromChunks [sig] diff --git a/OpenSSL/Objects.hsc b/OpenSSL/Objects.hsc --- a/OpenSSL/Objects.hsc +++ b/OpenSSL/Objects.hsc @@ -52,8 +52,7 @@ objNameStr :: ObjName -> IO String objNameStr name - = do strPtr <- (#peek OBJ_NAME, name) name - peekCString strPtr + = (#peek OBJ_NAME, name) name >>= peekCString getObjNames :: ObjNameType -> Bool -> IO [String] diff --git a/OpenSSL/PEM.hsc b/OpenSSL/PEM.hsc --- a/OpenSSL/PEM.hsc +++ b/OpenSSL/PEM.hsc @@ -37,6 +37,7 @@ import Control.Exception hiding (try) import Control.Monad +import qualified Data.ByteString.Char8 as B8 import Data.Maybe import Foreign import Foreign.C @@ -81,6 +82,7 @@ -- password\" data PemPasswordSupply = PwNone -- ^ no password | PwStr String -- ^ password in a static string + | PwBS B8.ByteString -- ^ password in a static bytestring. | PwCallback PemPasswordCallback -- ^ get a -- password -- by a @@ -148,16 +150,17 @@ -> _write_bio_PKCS8PrivateKey bioPtr pkeyPtr nullPtr nullPtr 0 nullFunPtr nullPtr Just (cipher, PwStr passStr) - -> withCStringLen passStr $ \ (passPtr, passLen) -> + -> withCStringLen passStr $ \(passPtr, passLen) -> withCipherPtr cipher $ \ cipherPtr -> _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr (fromIntegral passLen) nullFunPtr nullPtr - + Just (cipher, PwBS passStr) + -> withBS passStr $ \(passPtr, passLen) -> + withCipherPtr cipher $ \ cipherPtr -> + _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr passPtr (fromIntegral passLen) nullFunPtr nullPtr Just (cipher, PwCallback cb) -> withCipherPtr cipher $ \ cipherPtr -> - do cbPtr <- mkPemPasswordCallback $ callPasswordCB cb - ret <- _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 cbPtr nullPtr - freeHaskellFunPtr cbPtr - return ret + bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr -> + _write_bio_PKCS8PrivateKey bioPtr pkeyPtr cipherPtr nullPtr 0 cbPtr nullPtr Just (cipher, PwTTY) -> withCipherPtr cipher $ \ cipherPtr -> @@ -186,7 +189,7 @@ _read_bio_PrivateKey :: Ptr BIO_ -> Ptr (Ptr EVP_PKEY) -> FunPtr PemPasswordCallback' - -> Ptr () + -> CString -> IO (Ptr EVP_PKEY) readPrivateKey' :: BIO -> PemPasswordSupply -> IO SomeKeyPair @@ -196,23 +199,19 @@ PwNone -> withCString "" $ \ strPtr -> _read_bio_PrivateKey bioPtr nullPtr nullFunPtr (castPtr strPtr) - PwStr passStr - -> do cbPtr <- mkPemPasswordCallback $ - callPasswordCB $ \ _ _ -> - return passStr - pkeyPtr <- _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr - freeHaskellFunPtr cbPtr - return pkeyPtr + -> withCString passStr $ + _read_bio_PrivateKey bioPtr nullPtr nullFunPtr + PwBS passStr + -> withBS passStr $ \(passPtr,_) -> + _read_bio_PrivateKey bioPtr nullPtr nullFunPtr passPtr PwCallback cb - -> do cbPtr <- mkPemPasswordCallback $ callPasswordCB cb - pkeyPtr <- _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr - freeHaskellFunPtr cbPtr - return pkeyPtr + -> bracket (mkPemPasswordCallback $ callPasswordCB cb) freeHaskellFunPtr $ \cbPtr -> + _read_bio_PrivateKey bioPtr nullPtr cbPtr nullPtr PwTTY -> _read_bio_PrivateKey bioPtr nullPtr nullFunPtr nullPtr failIfNull_ pkeyPtr - wrapPKeyPtr pkeyPtr >>= fromPKey >>= return . fromJust + fmap fromJust (wrapPKeyPtr pkeyPtr >>= fromPKey) -- |@'readPrivateKey' pem supply@ reads a private key in PEM string. readPrivateKey :: String -> PemPasswordSupply -> IO SomeKeyPair @@ -253,11 +252,12 @@ readPublicKey' bio = withBioPtr bio $ \ bioPtr -> withCString "" $ \ passPtr -> - _read_bio_PUBKEY bioPtr nullPtr nullFunPtr (castPtr passPtr) - >>= failIfNull - >>= wrapPKeyPtr - >>= fromPKey - >>= return . fromJust + fmap fromJust + ( _read_bio_PUBKEY bioPtr nullPtr nullFunPtr (castPtr passPtr) + >>= failIfNull + >>= wrapPKeyPtr + >>= fromPKey + ) -- |@'readPublicKey' pem@ reads a public key in PEM string. readPublicKey :: String -> IO SomePublicKey @@ -464,3 +464,11 @@ readPkcs7 :: String -> IO Pkcs7 readPkcs7 pemStr = newConstMem pemStr >>= readPkcs7' + +withBS :: B8.ByteString -> ((Ptr CChar, Int) -> IO t) -> IO t +withBS passStr act = + B8.useAsCStringLen passStr $ \ (passPtr, passLen) -> + flip finally (memset passPtr 0 $ fromIntegral passLen) $ + act (castPtr passPtr, passLen) + +foreign import ccall unsafe memset :: Ptr a -> CInt -> CSize -> IO () diff --git a/OpenSSL/PKCS7.hsc b/OpenSSL/PKCS7.hsc --- a/OpenSSL/PKCS7.hsc +++ b/OpenSSL/PKCS7.hsc @@ -115,7 +115,7 @@ wrapPkcs7Ptr :: Ptr PKCS7 -> IO Pkcs7 -wrapPkcs7Ptr p7Ptr = newForeignPtr _free p7Ptr >>= return . Pkcs7 +wrapPkcs7Ptr = fmap Pkcs7 . newForeignPtr _free withPkcs7Ptr :: Pkcs7 -> (Ptr PKCS7 -> IO a) -> IO a @@ -125,8 +125,7 @@ isDetachedSignature :: Pkcs7 -> IO Bool isDetachedSignature pkcs7 = withPkcs7Ptr pkcs7 $ \ pkcs7Ptr -> - _is_detached pkcs7Ptr - >>= return . (== 1) + fmap (== 1) (_is_detached pkcs7Ptr) pkcs7Sign' :: KeyPair key => X509 -> key -> [X509] -> BIO -> [Pkcs7Flag] -> IO Pkcs7 @@ -213,7 +212,7 @@ outData <- if isDetached then return Nothing else - newMem >>= return . Just + fmap Just newMem withBioPtr' outData $ \ outDataPtr -> _verify pkcs7Ptr certStack storePtr inDataPtr outDataPtr (flagListToInt flagList) >>= interpret outData @@ -416,6 +415,6 @@ outBio <- if outBioPtr == nullPtr then return Nothing else - wrapBioPtr outBioPtr >>= return . Just + fmap Just (wrapBioPtr outBioPtr) return (pkcs7, outBio) diff --git a/OpenSSL/RSA.hsc b/OpenSSL/RSA.hsc --- a/OpenSSL/RSA.hsc +++ b/OpenSSL/RSA.hsc @@ -25,6 +25,8 @@ , rsaDMP1 , rsaDMQ1 , rsaIQMP + , rsaCopyPublic + , rsaKeyPairFinalize -- private ) where @@ -57,7 +59,7 @@ rsaSize rsa = unsafePerformIO $ withRSAPtr rsa $ \ rsaPtr -> - _size rsaPtr >>= return . fromIntegral + fmap fromIntegral (_size rsaPtr) -- |@'rsaN' key@ returns the public modulus of the key. rsaN :: k -> Integer @@ -76,7 +78,7 @@ instance RSAKey RSAPubKey where withRSAPtr (RSAPubKey fp) = withForeignPtr fp peekRSAPtr rsaPtr = _pubDup rsaPtr >>= absorbRSAPtr - absorbRSAPtr rsaPtr = newForeignPtr _free rsaPtr >>= return . Just . RSAPubKey + absorbRSAPtr rsaPtr = fmap (Just . RSAPubKey) (newForeignPtr _free rsaPtr) instance RSAKey RSAKeyPair where @@ -90,7 +92,7 @@ absorbRSAPtr rsaPtr = do hasP <- hasRSAPrivateKey rsaPtr if hasP then - newForeignPtr _free rsaPtr >>= return . Just . RSAKeyPair + fmap (Just . RSAKeyPair) (newForeignPtr _free rsaPtr) else return Nothing @@ -116,7 +118,14 @@ foreign import ccall unsafe "RSA_size" _size :: Ptr RSA -> IO CInt +-- | Make a copy of the public parameters of the given key. +rsaCopyPublic :: RSAKey key => key -> IO RSAPubKey +rsaCopyPublic key = withRSAPtr key (fmap RSAPubKey . (newForeignPtr _free =<<) . _pubDup) +-- private +rsaKeyPairFinalize :: RSAKeyPair -> IO () +rsaKeyPairFinalize (RSAKeyPair fp) = finalizeForeignPtr fp + {- generation --------------------------------------------------------------- -} -- |@'RSAGenKeyCallback'@ represents a callback function to get @@ -158,7 +167,7 @@ generateRSAKey nbits e Nothing = do ptr <- _generate_key (fromIntegral nbits) (fromIntegral e) nullFunPtr nullPtr failIfNull_ ptr - newForeignPtr _free ptr >>= return . RSAKeyPair + fmap RSAKeyPair (newForeignPtr _free ptr) generateRSAKey nbits e (Just cb) = do cbPtr <- mkGenKeyCallback @@ -166,7 +175,7 @@ ptr <- _generate_key (fromIntegral nbits) (fromIntegral e) cbPtr nullPtr freeHaskellFunPtr cbPtr failIfNull_ ptr - newForeignPtr _free ptr >>= return . RSAKeyPair + fmap RSAKeyPair (newForeignPtr _free ptr) -- |A simplified alternative to 'generateRSAKey' generateRSAKey' :: Int -- ^ The number of bits of the public modulus @@ -197,7 +206,7 @@ if bn == nullPtr then return Nothing else - peekBN (wrapBN bn) >>= return . Just + fmap Just (peekBN (wrapBN bn)) -- |@'rsaD' privKey@ returns the private exponent of the key. rsaD :: RSAKeyPair -> Integer diff --git a/OpenSSL/Session.hsc b/OpenSSL/Session.hsc --- a/OpenSSL/Session.hsc +++ b/OpenSSL/Session.hsc @@ -41,6 +41,7 @@ import Control.Concurrent (threadWaitWrite, threadWaitRead) import Control.Concurrent.QSem import Control.Exception (finally) +import Control.Monad import Foreign import Foreign.C import qualified Data.ByteString as B @@ -101,9 +102,8 @@ withContext context $ \ctx -> withCString path $ \cpath -> do result <- f ctx cpath (#const SSL_FILETYPE_PEM) - if result == 1 - then return () - else f ctx cpath (#const SSL_FILETYPE_ASN1) >>= failIf (/= 1) >> return () + unless (result == 1) + $ f ctx cpath (#const SSL_FILETYPE_ASN1) >>= failIf_ (/= 1) foreign import ccall unsafe "SSL_CTX_use_PrivateKey" _ssl_ctx_use_privatekey :: Ptr SSLContext_ -> Ptr EVP_PKEY -> IO CInt @@ -116,8 +116,7 @@ = withContext context $ \ ctx -> withPKeyPtr' key $ \ keyPtr -> _ssl_ctx_use_privatekey ctx keyPtr - >>= failIf (/= 1) - >> return () + >>= failIf_ (/= 1) -- | Install a certificate (public key) into a context. contextSetCertificate :: SSLContext -> X509 -> IO () @@ -125,8 +124,7 @@ = withContext context $ \ ctx -> withX509Ptr cert $ \ certPtr -> _ssl_ctx_use_certificate ctx certPtr - >>= failIf (/= 1) - >> return () + >>= failIf_ (/= 1) foreign import ccall unsafe "SSL_CTX_use_PrivateKey_file" _ssl_ctx_use_privatekey_file :: Ptr SSLContext_ -> CString -> CInt -> IO CInt @@ -158,7 +156,7 @@ contextSetCiphers context list = withContext context $ \ctx -> withCString list $ \cpath -> - _ssl_ctx_set_cipher_list ctx cpath >>= failIf (/= 1) >> return () + _ssl_ctx_set_cipher_list ctx cpath >>= failIf_ (/= 1) contextSetDefaultCiphers :: SSLContext -> IO () contextSetDefaultCiphers = flip contextSetCiphers "DEFAULT" @@ -171,7 +169,7 @@ contextCheckPrivateKey :: SSLContext -> IO Bool contextCheckPrivateKey context = withContext context $ \ctx -> - _ssl_ctx_check_private_key ctx >>= return . (==) 1 + fmap (== 1) (_ssl_ctx_check_private_key ctx) -- | See data VerificationMode = VerifyNone @@ -184,7 +182,7 @@ _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> Ptr () -> IO () contextSetVerificationMode :: SSLContext -> VerificationMode -> IO () -contextSetVerificationMode context VerifyNone = do +contextSetVerificationMode context VerifyNone = withContext context $ \ctx -> _ssl_set_verify_mode ctx (#const SSL_VERIFY_NONE) nullPtr >> return () @@ -201,7 +199,7 @@ -- | Set the location of a PEM encoded list of CA certificates to be used when -- verifying a server's certificate contextSetCAFile :: SSLContext -> FilePath -> IO () -contextSetCAFile context path = do +contextSetCAFile context path = withContext context $ \ctx -> withCString path $ \cpath -> _ssl_load_verify_locations ctx cpath nullPtr >>= failIf_ (/= 1) @@ -211,7 +209,7 @@ -- for -- details of the file naming scheme contextSetCADirectory :: SSLContext -> FilePath -> IO () -contextSetCADirectory context path = do +contextSetCADirectory context path = withContext context $ \ctx -> withCString path $ \cpath -> _ssl_load_verify_locations ctx nullPtr cpath >>= failIf_ (/= 1) @@ -312,11 +310,11 @@ -- | Perform an SSL server handshake accept :: SSL -> IO () -accept ssl = sslDoHandshake _ssl_accept ssl >>= failIf (/= 1) >> return () +accept ssl = sslDoHandshake _ssl_accept ssl >>= failIf_ (/= 1) -- | Perform an SSL client handshake connect :: SSL -> IO () -connect ssl = sslDoHandshake _ssl_connect ssl >>= failIf (/= 1) >> return () +connect ssl = sslDoHandshake _ssl_connect ssl >>= failIf_ (/= 1) foreign import ccall "SSL_read" _ssl_read :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt foreign import ccall unsafe "SSL_get_shutdown" _ssl_get_shutdown :: Ptr SSL_ -> IO CInt @@ -386,7 +384,7 @@ -- | Lazily read all data until reaching EOF. If the connection dies -- without a graceful SSL shutdown, an exception is raised. lazyRead :: SSL -> IO L.ByteString -lazyRead ssl = lazyRead' >>= return . L.fromChunks +lazyRead ssl = fmap L.fromChunks lazyRead' where chunkSize = L.defaultChunkSize @@ -424,10 +422,8 @@ n <- sslDoHandshake _ssl_shutdown ssl case ty of Unidirectional -> return () - Bidirectional -> do - if n == 1 - then return () - else shutdown ssl ty + Bidirectional -> unless (n == 1) + $ shutdown ssl ty foreign import ccall "SSL_get_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_) @@ -440,7 +436,7 @@ cert <- _ssl_get_peer_cert ssl if cert == nullPtr then return Nothing - else wrapX509 cert >>= return . Just + else fmap Just (wrapX509 cert) foreign import ccall "SSL_get_verify_result" _ssl_get_verify_result :: Ptr SSL_ -> IO CLong @@ -453,7 +449,7 @@ -- to a root CA. You also need to check that the certificate is correct (i.e. -- has the correct hostname in it) with getPeerCertificate. getVerifyResult :: SSL -> IO Bool -getVerifyResult ssl = do +getVerifyResult ssl = withSSL ssl $ \ssl -> do r <- _ssl_get_verify_result ssl return $ r == (#const X509_V_OK) diff --git a/OpenSSL/Stack.hsc b/OpenSSL/Stack.hsc --- a/OpenSSL/Stack.hsc +++ b/OpenSSL/Stack.hsc @@ -33,7 +33,7 @@ mapStack :: (Ptr a -> IO b) -> Ptr STACK -> IO [b] mapStack m st = do num <- skNum st - mapM (\ i -> skValue st i >>= return . castPtr >>= m) + mapM (\ i -> fmap castPtr (skValue st i) >>= m) $ take (fromIntegral num) [0..] @@ -45,8 +45,8 @@ withStack :: [Ptr a] -> (Ptr STACK -> IO b) -> IO b -withStack values f - = bracket (newStack values) skFree f +withStack values + = bracket (newStack values) skFree withForeignStack :: (fp -> Ptr obj) diff --git a/OpenSSL/Utils.hs b/OpenSSL/Utils.hs --- a/OpenSSL/Utils.hs +++ b/OpenSSL/Utils.hs @@ -71,7 +71,7 @@ -- | Convert a hex string to an integer fromHex :: (Bits i) => String -> i fromHex = foldl step 0 where - step acc hexchar = (acc `shiftL` 4) .|. (byteHex hexchar) + step acc hexchar = (acc `shiftL` 4) .|. byteHex hexchar byteHex '0' = 0 byteHex '1' = 1 diff --git a/OpenSSL/X509.hsc b/OpenSSL/X509.hsc --- a/OpenSSL/X509.hsc +++ b/OpenSSL/X509.hsc @@ -156,7 +156,7 @@ wrapX509 :: Ptr X509_ -> IO X509 -wrapX509 x509Ptr = newForeignPtr _free x509Ptr >>= return . X509 +wrapX509 = fmap X509 . newForeignPtr _free withX509Ptr :: X509 -> (Ptr X509_ -> IO a) -> IO a @@ -179,7 +179,7 @@ compareX509 cert1 cert2 = withX509Ptr cert1 $ \ cert1Ptr -> withX509Ptr cert2 $ \ cert2Ptr -> - _cmp cert1Ptr cert2Ptr >>= return . interpret + fmap interpret (_cmp cert1Ptr cert2Ptr) where interpret :: CInt -> Ordering interpret n @@ -350,11 +350,11 @@ getPublicKey :: X509 -> IO SomePublicKey getPublicKey x509 = withX509Ptr x509 $ \ x509Ptr -> - _get_pubkey x509Ptr - >>= failIfNull - >>= wrapPKeyPtr - >>= fromPKey - >>= return . fromJust + fmap fromJust ( _get_pubkey x509Ptr + >>= failIfNull + >>= wrapPKeyPtr + >>= fromPKey + ) -- |@'setPublicKey' cert pubkey@ updates the public key of the subject -- of certificate. diff --git a/OpenSSL/X509/Name.hsc b/OpenSSL/X509/Name.hsc --- a/OpenSSL/X509/Name.hsc +++ b/OpenSSL/X509/Name.hsc @@ -42,8 +42,7 @@ allocaX509Name :: (Ptr X509_NAME -> IO a) -> IO a -allocaX509Name m - = bracket _new _free m +allocaX509Name = bracket _new _free withX509Name :: [(String, String)] -> (Ptr X509_NAME -> IO a) -> IO a diff --git a/OpenSSL/X509/Request.hsc b/OpenSSL/X509/Request.hsc --- a/OpenSSL/X509/Request.hsc +++ b/OpenSSL/X509/Request.hsc @@ -100,7 +100,7 @@ wrapX509Req :: Ptr X509_REQ -> IO X509Req -wrapX509Req reqPtr = newForeignPtr _free reqPtr >>= return . X509Req +wrapX509Req = fmap X509Req . newForeignPtr _free withX509ReqPtr :: X509Req -> (Ptr X509_REQ -> IO a) -> IO a @@ -194,11 +194,12 @@ getPublicKey :: X509Req -> IO SomePublicKey getPublicKey req = withX509ReqPtr req $ \ reqPtr -> - _get_pubkey reqPtr - >>= failIfNull - >>= wrapPKeyPtr - >>= fromPKey - >>= return . fromJust + fmap fromJust + ( _get_pubkey reqPtr + >>= failIfNull + >>= wrapPKeyPtr + >>= fromPKey + ) -- |@'setPublicKey' req@ updates the public key of the subject of -- certificate request. diff --git a/OpenSSL/X509/Revocation.hsc b/OpenSSL/X509/Revocation.hsc --- a/OpenSSL/X509/Revocation.hsc +++ b/OpenSSL/X509/Revocation.hsc @@ -154,7 +154,7 @@ wrapCRL :: Ptr X509_CRL -> IO CRL -wrapCRL crlPtr = newForeignPtr _free crlPtr >>= return . CRL +wrapCRL = fmap CRL . newForeignPtr _free withCRLPtr :: CRL -> (Ptr X509_CRL -> IO a) -> IO a @@ -278,8 +278,7 @@ getRevokedList :: CRL -> IO [RevokedCertificate] getRevokedList crl = withCRLPtr crl $ \ crlPtr -> - do stRevoked <- _get_REVOKED crlPtr - mapStack peekRevoked stRevoked + (_get_REVOKED crlPtr >>= mapStack peekRevoked) where peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate peekRevoked rev @@ -294,11 +293,11 @@ newRevoked revoked = do revPtr <- _new_revoked - seriRet <- withASN1Integer (revSerialNumber revoked) $ \ serialPtr -> - _set_serialNumber revPtr serialPtr + seriRet <- withASN1Integer (revSerialNumber revoked) $ + _set_serialNumber revPtr - dateRet <- withASN1Time (revRevocationDate revoked) $ \ datePtr -> - _set_revocationDate revPtr datePtr + dateRet <- withASN1Time (revRevocationDate revoked) $ + _set_revocationDate revPtr if seriRet /= 1 || dateRet /= 1 then freeRevoked revPtr >> raiseOpenSSLError diff --git a/examples/GenRSAKey.hs b/examples/GenRSAKey.hs --- a/examples/GenRSAKey.hs +++ b/examples/GenRSAKey.hs @@ -13,12 +13,12 @@ printf "Generating RSA key-pair, nbits = %d, e = %d:\n" keyBits keyE rsa <- generateRSAKey keyBits keyE $ Just $ \ phase _ -> - do hPutChar stdout $ case phase of - 0 -> '.' - 1 -> '+' - 2 -> '*' - 3 -> '\n' - n -> head $ show n + do putChar $ case phase of + 0 -> '.' + 1 -> '+' + 2 -> '*' + 3 -> '\n' + n -> head $ show n hFlush stdout printf "Done.\n" diff --git a/tests/Base64.hs b/tests/Base64.hs --- a/tests/Base64.hs +++ b/tests/Base64.hs @@ -65,7 +65,7 @@ decoding = all id $ map (\(a, v) -> decodeBase64BS a == v) decodeTests main = do - mapM (print . encodeBase64LBS . fst) lazyEncodeTests + mapM_ (print . encodeBase64LBS . fst) lazyEncodeTests if encoding && lazyEncoding && decoding then putStrLn "PASS" else putStrLn "FAIL" diff --git a/tests/Cipher.hs b/tests/Cipher.hs --- a/tests/Cipher.hs +++ b/tests/Cipher.hs @@ -1,7 +1,7 @@ -- | Tests for the non-EVP ciphers module Main where -import Control.Monad (when) +import Control.Monad (unless) import qualified Data.ByteString as BS import OpenSSL.Cipher @@ -83,9 +83,9 @@ return (ct == ciphertext) runCtrTests :: IO Bool -runCtrTests = mapM runCtrTest ctrTests >>= return . all ((==) True) +runCtrTests = fmap (all (== True)) (mapM runCtrTest ctrTests) main = do r <- runCtrTests - when (r == False) $ fail "CTR tests failed" + unless r $ fail "CTR tests failed" putStrLn "PASS" diff --git a/tests/DSA.hs b/tests/DSA.hs --- a/tests/DSA.hs +++ b/tests/DSA.hs @@ -1,7 +1,7 @@ module Main where +import Control.Monad import System.Time - import OpenSSL.DSA import qualified Data.ByteString as BS @@ -35,7 +35,7 @@ return () starttime <- getClockTime - sequence_ $ take 2000 $ repeat test + replicateM_ 2000 test endtime <- getClockTime print $ diffClockTimes endtime starttime