HsOpenSSL 0.7 → 0.8
raw patch · 27 files changed
+227/−179 lines, 27 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ OpenSSL.EVP.Cipher: cipherStrictLBS :: Cipher -> ByteString -> ByteString -> CryptoMode -> ByteString -> IO ByteString
+ OpenSSL.EVP.Digest: pkcs5_pbkdf2_hmac_sha1 :: ByteString -> ByteString -> Int -> Int -> ByteString
+ OpenSSL.EVP.Sign: signFinal :: (KeyPair k) => DigestCtx -> k -> IO ByteString
+ OpenSSL.PEM: PwBS :: ByteString -> PemPasswordSupply
+ OpenSSL.RSA: rsaCopyPublic :: (RSAKey key) => key -> IO RSAPubKey
Files
- HsOpenSSL.cabal +1/−1
- NEWS +23/−1
- OpenSSL/ASN1.hsc +5/−5
- OpenSSL/BIO.hsc +7/−6
- OpenSSL/Cipher.hsc +3/−3
- OpenSSL/DSA.hsc +34/−33
- OpenSSL/ERR.hsc +2/−2
- OpenSSL/EVP/Base64.hsc +2/−1
- OpenSSL/EVP/Cipher.hsc +23/−2
- OpenSSL/EVP/Digest.hsc +8/−11
- OpenSSL/EVP/PKey.hsc +4/−8
- OpenSSL/EVP/Sign.hsc +9/−10
- OpenSSL/Objects.hsc +1/−2
- OpenSSL/PEM.hsc +32/−24
- OpenSSL/PKCS7.hsc +4/−5
- OpenSSL/RSA.hsc +15/−6
- OpenSSL/Session.hsc +17/−21
- OpenSSL/Stack.hsc +3/−3
- OpenSSL/Utils.hs +1/−1
- OpenSSL/X509.hsc +7/−7
- OpenSSL/X509/Name.hsc +1/−2
- OpenSSL/X509/Request.hsc +7/−6
- OpenSSL/X509/Revocation.hsc +6/−7
- examples/GenRSAKey.hs +6/−6
- tests/Base64.hs +1/−1
- tests/Cipher.hs +3/−3
- tests/DSA.hs +2/−2
HsOpenSSL.cabal view
@@ -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 <agl at imperialviolet.org>, PHO <pho at cielonegro.org>
NEWS view
@@ -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 -------------------------
OpenSSL/ASN1.hsc view
@@ -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
OpenSSL/BIO.hsc view
@@ -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
OpenSSL/Cipher.hsc view
@@ -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 ->
OpenSSL/DSA.hsc view
@@ -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
OpenSSL/ERR.hsc view
@@ -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
OpenSSL/EVP/Base64.hsc view
@@ -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
OpenSSL/EVP/Cipher.hsc view
@@ -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
OpenSSL/EVP/Digest.hsc view
@@ -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
OpenSSL/EVP/PKey.hsc view
@@ -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
OpenSSL/EVP/Sign.hsc view
@@ -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]
OpenSSL/Objects.hsc view
@@ -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]
OpenSSL/PEM.hsc view
@@ -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 ()
OpenSSL/PKCS7.hsc view
@@ -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)
OpenSSL/RSA.hsc view
@@ -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
OpenSSL/Session.hsc view
@@ -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 <http://www.openssl.org/docs/ssl/SSL_CTX_set_verify.html> 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 @@ -- <http://www.openssl.org/docs/ssl/SSL_CTX_load_verify_locations.html> 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)
OpenSSL/Stack.hsc view
@@ -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)
OpenSSL/Utils.hs view
@@ -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
OpenSSL/X509.hsc view
@@ -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.
OpenSSL/X509/Name.hsc view
@@ -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
OpenSSL/X509/Request.hsc view
@@ -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.
OpenSSL/X509/Revocation.hsc view
@@ -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
examples/GenRSAKey.hs view
@@ -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"
tests/Base64.hs view
@@ -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"
tests/Cipher.hs view
@@ -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"
tests/DSA.hs view
@@ -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