diff --git a/AUTHORS b/AUTHORS --- a/AUTHORS +++ b/AUTHORS @@ -1,7 +1,8 @@ -This is a list of contributors to the HsOpenSSL. +This is the list of contributors to the HsOpenSSL. * Adam Langley * John Van Enk and his friend +* Mikhail Vorozhtsov * Taru Karttunen * PHO diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -4,16 +4,16 @@ HsOpenSSL is an (incomplete) OpenSSL binding for Haskell. It can generate RSA and DSA keys, read and write PEM files, generate message digests, sign and verify messages, encrypt - and decrypt messages. -Version: 0.10 + and decrypt messages. It also has some capabilities of + creating SSL clients and servers. +Version: 0.10.1 License: PublicDomain License-File: COPYING -Author: Adam Langley , - PHO , - Taru Karttunen +Author: Adam Langley, Mikhail Vorozhtsov, PHO, Taru Karttunen Maintainer: PHO Stability: stable Homepage: http://cielonegro.org/HsOpenSSL.html +Bug-Reports: http://static.cielonegro.org/ditz/HsOpenSSL/ Category: Cryptography Tested-With: GHC == 7.0.3 Cabal-Version: >= 1.6 @@ -33,8 +33,8 @@ tests/Makefile Source-Repository head - Type: darcs - Location: http://darcs.cielonegro.org/HsOpenSSL/ + Type: git + Location: git://github.com/phonohawk/HsOpenSSL.git Library Build-Depends: base >= 4 && < 5, bytestring, ghc-prim, time >= 1.1.1, old-locale, network>=2.1.0.0 @@ -77,6 +77,7 @@ OpenSSL.X509.Request OpenSSL.X509.Store OpenSSL.Session + OpenSSL.DH Other-Modules: OpenSSL.ASN1 OpenSSL.BIO @@ -86,6 +87,7 @@ OpenSSL.Stack OpenSSL.Utils OpenSSL.X509.Name + OpenSSL.DH.Internal Extensions: ForeignFunctionInterface, EmptyDataDecls, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable, diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,8 +1,20 @@ -*- coding: utf-8 -*- +Changes from 0.10 to 0.10.1 +--------------------------- +* Applied patches by Mikhail Vorozhtsov: + - Added optional verification callback to VerifyPeer. + - Added revocation lookup function. + - Added bindings to Diffie-Hellman functions. + - Expose low-level asynchronous versions of accept, connect, read, + write and shutdown. + +* Moved the repository to GitHub: + git://github.com/phonohawk/HsOpenSSL.git + + Changes from 0.9.0.1 to 0.10 ---------------------------- - * Applied a patch by Mikhail Vorozhtsov to support wrapping plain file descriptors in SSL connections. diff --git a/OpenSSL/BN.hsc b/OpenSSL/BN.hsc --- a/OpenSSL/BN.hsc +++ b/OpenSSL/BN.hsc @@ -153,8 +153,8 @@ _copy_out :: Ptr () -> ByteArray## -> CSize -> IO () -- These are taken from Data.Binary's disabled fast Integer support -data ByteArray = BA {-# UNPACK #-} !ByteArray## -data MBA = MBA {-# UNPACK #-} !(MutableByteArray## RealWorld) +data ByteArray = BA !ByteArray## +data MBA = MBA !(MutableByteArray## RealWorld) newByteArray :: Int## -> IO MBA newByteArray sz = IO $ \s -> diff --git a/OpenSSL/DH.hsc b/OpenSSL/DH.hsc new file mode 100644 --- /dev/null +++ b/OpenSSL/DH.hsc @@ -0,0 +1,93 @@ +-- | Diffie-Hellman key exchange +module OpenSSL.DH ( + DHP, + DH, + DHGen(..), + genDHParams, + getDHLength, + checkDHParams, + genDH, + getDHParams, + getDHPublicKey, + computeDHKey, + ) where + +import Data.Word (Word8) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import Control.Applicative ((<$>)) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.C.Types (CInt) +import Foreign.Marshal.Alloc (alloca) +import OpenSSL.BN +import OpenSSL.DH.Internal +import OpenSSL.Utils + +data DHGen = DHGen2 + | DHGen5 + deriving (Eq, Ord, Show) + +-- | @'genDHParams' gen n@ generates @n@-bit long DH parameters. +genDHParams :: DHGen -> Int -> IO DHP +genDHParams gen len = do + _DH_generate_parameters (fromIntegral len) gen' nullPtr nullPtr + >>= failIfNull + >>= wrapDHPPtr + where gen' = case gen of + DHGen2 -> 2 + DHGen5 -> 5 + +-- | Get DH parameters length (in bits). +getDHLength :: DHP -> IO Int +getDHLength dh = fromIntegral <$> withDHPPtr dh _DH_length + +-- | Check that DH parameters are coherent. +checkDHParams :: DHP -> IO Bool +checkDHParams dh = alloca $ \pErr -> + withDHPPtr dh $ \dhPtr -> _DH_check dhPtr pErr + +-- | The first step of a key exchange. Public and private keys are generated. +genDH :: DHP -> IO DH +genDH dh = do + dh' <- withDHPPtr dh _DH_dup >>= failIfNull >>= wrapDHPPtr + withDHPPtr dh' _DH_generate_key >>= failIf_ (/= 1) + return $ asDH dh' + +-- | Get parameters of a key exchange. +getDHParams :: DH -> DHP +getDHParams = asDHP + +-- | Get the public key. +getDHPublicKey :: DH -> IO Integer +getDHPublicKey dh = + withDHPtr dh $ \dhPtr -> do + pKey <- _DH_get_pub_key dhPtr + bnToInteger (wrapBN pKey) + +-- | Compute the shared key using the other party's public key. +computeDHKey :: DH -> Integer -> IO ByteString +computeDHKey dh pubKey = + withDHPtr dh $ \dhPtr -> + withBN pubKey $ \bn -> do + size <- fromIntegral <$> _DH_size dhPtr + BS.createAndTrim size $ \bsPtr -> + fromIntegral <$> _DH_compute_key bsPtr (unwrapBN bn) dhPtr + >>= failIf (< 0) + +foreign import ccall "DH_generate_parameters" + _DH_generate_parameters :: CInt -> CInt -> Ptr () -> Ptr () -> IO (Ptr DH_) +foreign import ccall "DH_generate_key" + _DH_generate_key :: Ptr DH_ -> IO CInt +foreign import ccall "DH_compute_key" + _DH_compute_key :: Ptr Word8 -> Ptr BIGNUM -> Ptr DH_ -> IO CInt +foreign import ccall "DH_check" + _DH_check :: Ptr DH_ -> Ptr CInt -> IO Bool +foreign import ccall unsafe "DH_size" + _DH_size :: Ptr DH_ -> IO CInt +foreign import ccall unsafe "DHparams_dup" + _DH_dup :: Ptr DH_ -> IO (Ptr DH_) +foreign import ccall unsafe "HsOpenSSL_DH_get_pub_key" + _DH_get_pub_key :: Ptr DH_ -> IO (Ptr BIGNUM) +foreign import ccall unsafe "HsOpenSSL_DH_length" + _DH_length :: Ptr DH_ -> IO CInt + diff --git a/OpenSSL/DH/Internal.hsc b/OpenSSL/DH/Internal.hsc new file mode 100644 --- /dev/null +++ b/OpenSSL/DH/Internal.hsc @@ -0,0 +1,51 @@ +module OpenSSL.DH.Internal ( + DH_, + DHP, + withDHPPtr, + wrapDHPPtrWith, + wrapDHPPtr, + DH, + withDHPtr, + wrapDHPtrWith, + wrapDHPtr, + asDH, + asDHP + ) where + +import Control.Applicative ((<$>)) +import Foreign.Ptr (Ptr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import qualified Foreign.Concurrent as FC + +data DH_ +newtype DHP = DHP (ForeignPtr DH_) + +withDHPPtr :: DHP -> (Ptr DH_ -> IO a) -> IO a +withDHPPtr (DHP fp) = withForeignPtr fp + +wrapDHPPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DHP +wrapDHPPtrWith fin p = DHP <$> FC.newForeignPtr p (fin p) + +wrapDHPPtr :: Ptr DH_ -> IO DHP +wrapDHPPtr = wrapDHPPtrWith _DH_free + +newtype DH = DH (ForeignPtr DH_) + +withDHPtr :: DH -> (Ptr DH_ -> IO a) -> IO a +withDHPtr (DH fp) = withForeignPtr fp + +wrapDHPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DH +wrapDHPtrWith fin p = DH <$> FC.newForeignPtr p (fin p) + +wrapDHPtr :: Ptr DH_ -> IO DH +wrapDHPtr = wrapDHPtrWith _DH_free + +asDH :: DHP -> DH +asDH (DHP fp) = DH fp + +asDHP :: DH -> DHP +asDHP (DH fp) = DHP fp + +foreign import ccall "DH_free" + _DH_free :: Ptr DH_ -> IO () + diff --git a/OpenSSL/PEM.hsc b/OpenSSL/PEM.hsc --- a/OpenSSL/PEM.hsc +++ b/OpenSSL/PEM.hsc @@ -32,6 +32,10 @@ -- * PKCS#7 structure , writePkcs7 , readPkcs7 + + -- * DH parameters + , writeDHParams + , readDHParams ) where @@ -44,6 +48,7 @@ import OpenSSL.BIO import OpenSSL.EVP.Cipher hiding (cipher) import OpenSSL.EVP.PKey +import OpenSSL.DH.Internal import OpenSSL.PKCS7 import OpenSSL.Utils import OpenSSL.X509 @@ -464,6 +469,47 @@ readPkcs7 :: String -> IO Pkcs7 readPkcs7 pemStr = newConstMem pemStr >>= readPkcs7' + +{- DH parameters ------------------------------------------------------------- -} + +foreign import ccall unsafe "PEM_write_bio_DHparams" + _write_bio_DH :: Ptr BIO_ + -> Ptr DH_ + -> IO CInt + +foreign import ccall safe "PEM_read_bio_DHparams" + _read_bio_DH :: Ptr BIO_ + -> Ptr (Ptr DH_) + -> FunPtr PemPasswordCallback' + -> Ptr () + -> IO (Ptr DH_) + +writeDHParams' :: BIO -> DHP -> IO () +writeDHParams' bio dh + = withBioPtr bio $ \ bioPtr -> + withDHPPtr dh $ \ dhPtr -> + _write_bio_DH bioPtr dhPtr >>= failIf_ (/= 1) + +-- |@'writeDHParams' dh@ writes DH parameters to PEM string. +writeDHParams :: DHP -> IO String +writeDHParams dh + = do mem <- newMem + writeDHParams' mem dh + bioRead mem + +readDHParams' :: BIO -> IO DHP +readDHParams' bio + = withBioPtr bio $ \ bioPtr -> + withCString "" $ \ passPtr -> + _read_bio_DH bioPtr nullPtr nullFunPtr (castPtr passPtr) + >>= failIfNull + >>= wrapDHPPtr + +-- |@'readDHParams' pem@ reads DH parameters in PEM string. +readDHParams :: String -> IO DHP +readDHParams pemStr + = newConstMem pemStr >>= readDHParams' + withBS :: B8.ByteString -> ((Ptr CChar, Int) -> IO t) -> IO t withBS passStr act = diff --git a/OpenSSL/Session.hsc b/OpenSSL/Session.hsc --- a/OpenSSL/Session.hsc +++ b/OpenSSL/Session.hsc @@ -1,4 +1,8 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NamedFieldPuns #-} -- | Functions for handling SSL connections. These functions use GHC specific -- calls to cooperative the with the scheduler so that 'blocking' functions -- only actually block the Haskell thread, not a whole OS thread. @@ -21,15 +25,21 @@ -- * SSL connections , SSL + , SSLResult(..) , connection , fdConnection , accept + , tryAccept , connect + , tryConnect , read + , tryRead , write + , tryWrite , lazyRead , lazyWrite , shutdown + , tryShutdown , ShutdownType(..) , getPeerCertificate , getVerifyResult @@ -50,14 +60,20 @@ #include "openssl/ssl.h" -import Prelude hiding (catch, read, ioError) +import Prelude hiding (catch, read, ioError, mapM, mapM_) import Control.Concurrent (threadWaitWrite, threadWaitRead) import Control.Concurrent.QSem import Control.Exception -import Control.Monad +import Control.Applicative ((<$>), (<$)) +import Control.Monad (void, unless) import Data.Typeable -import Foreign +import Data.Foldable (Foldable, mapM_, forM_) +import Data.Traversable (Traversable, mapM, forM) +import Data.Maybe (fromMaybe) +import Data.IORef +import Foreign hiding (void) import Foreign.C +import qualified Foreign.Concurrent as FC import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B @@ -73,6 +89,10 @@ import OpenSSL.X509 (X509, X509_, wrapX509, withX509Ptr) import OpenSSL.X509.Store +type VerifyCb = Bool -> Ptr X509_STORE_CTX -> IO Bool + +foreign import ccall "wrapper" mkVerifyCb :: VerifyCb -> IO (FunPtr VerifyCb) + data SSLContext_ -- | An SSL context. Contexts carry configuration such as a server's private -- key, root CA certiifcates etc. Contexts are stateful IO objects; they @@ -83,32 +103,37 @@ -- Contexts are not thread safe so they carry a QSem with them which only -- lets a single thread work inside them at a time. Thus, one must always use -- withContext, not withForeignPtr directly. -newtype SSLContext = SSLContext (QSem, ForeignPtr SSLContext_) +data SSLContext = SSLContext { ctxSem :: QSem + , ctxPtr :: ForeignPtr SSLContext_ + , ctxVfCb :: IORef (Maybe (FunPtr VerifyCb)) + } data SSLMethod_ foreign import ccall unsafe "SSL_CTX_new" _ssl_ctx_new :: Ptr SSLMethod_ -> IO (Ptr SSLContext_) -foreign import ccall unsafe "&SSL_CTX_free" _ssl_ctx_free :: FunPtr (Ptr SSLContext_ -> IO ()) +foreign import ccall unsafe "SSL_CTX_free" _ssl_ctx_free :: Ptr SSLContext_ -> IO () foreign import ccall unsafe "SSLv23_method" _ssl_method :: IO (Ptr SSLMethod_) -- | Create a new SSL context. context :: IO SSLContext context = do - ctx <- _ssl_method >>= _ssl_ctx_new - context <- newForeignPtr _ssl_ctx_free ctx - sem <- newQSem 1 - return $ SSLContext (sem, context) + ctx <- _ssl_method >>= _ssl_ctx_new + cbRef <- newIORef Nothing + ptr <- FC.newForeignPtr ctx $ do + _ssl_ctx_free ctx + readIORef cbRef >>= mapM_ freeHaskellFunPtr + sem <- newQSem 1 + return $ SSLContext { ctxSem = sem, ctxPtr = ptr, ctxVfCb = cbRef } -- | Run the given action with the raw context pointer and obtain the lock -- while doing so. withContext :: SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a -withContext (SSLContext (sem, ctxfp)) action = do - waitQSem sem - finally (withForeignPtr ctxfp action) $ signalQSem sem +withContext (SSLContext {ctxSem, ctxPtr}) action = do + waitQSem ctxSem + finally (withForeignPtr ctxPtr action) $ signalQSem ctxSem touchContext :: SSLContext -> IO () -touchContext (SSLContext (_, fp)) - = touchForeignPtr fp +touchContext = touchForeignPtr . ctxPtr contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO CInt) -> SSLContext -> String -> IO () @@ -190,22 +215,29 @@ | VerifyPeer { vpFailIfNoPeerCert :: Bool -- ^ is a certificate required , vpClientOnce :: Bool -- ^ only request once per connection + , vpCallback :: Maybe (Bool -> X509StoreCtx -> IO Bool) -- ^ optional callback } foreign import ccall unsafe "SSL_CTX_set_verify" - _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> Ptr () -> IO () + _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> FunPtr VerifyCb -> IO () contextSetVerificationMode :: SSLContext -> VerificationMode -> IO () contextSetVerificationMode context VerifyNone = withContext context $ \ctx -> - _ssl_set_verify_mode ctx (#const SSL_VERIFY_NONE) nullPtr >> return () + void $ _ssl_set_verify_mode ctx (#const SSL_VERIFY_NONE) nullFunPtr -contextSetVerificationMode context (VerifyPeer reqp oncep) = do +contextSetVerificationMode context (VerifyPeer reqp oncep cbp) = do let mode = (#const SSL_VERIFY_PEER) .|. (if reqp then (#const SSL_VERIFY_FAIL_IF_NO_PEER_CERT) else 0) .|. (if oncep then (#const SSL_VERIFY_CLIENT_ONCE) else 0) - withContext context $ \ctx -> - _ssl_set_verify_mode ctx mode nullPtr >> return () + withContext context $ \ctx -> do + let cbRef = ctxVfCb context + newCb <- mapM mkVerifyCb $ (<$> cbp) $ \cb pvf pStoreCtx -> + cb pvf =<< wrapX509StoreCtx (return ()) pStoreCtx + oldCb <- readIORef cbRef + writeIORef cbRef newCb + forM_ oldCb freeHaskellFunPtr + void $ _ssl_set_verify_mode ctx mode $ fromMaybe nullFunPtr newCb foreign import ccall unsafe "SSL_CTX_load_verify_locations" _ssl_load_verify_locations :: Ptr SSLContext_ -> Ptr CChar -> Ptr CChar -> IO CInt @@ -253,7 +285,11 @@ -- times. Thus multiple OS threads can be 'blocked' inside IO in the same SSL -- object at a time, because they aren't really in the SSL object, they are -- waiting for the RTS to wake the Haskell thread. -newtype SSL = SSL (QSem, ForeignPtr SSL_, Fd, Maybe Socket) +data SSL = SSL { sslSem :: QSem + , sslPtr :: ForeignPtr SSL_ + , sslFd :: Fd + , sslSocket :: Maybe Socket + } foreign import ccall unsafe "SSL_new" _ssl_new :: Ptr SSLContext_ -> IO (Ptr SSL_) foreign import ccall unsafe "&SSL_free" _ssl_free :: FunPtr (Ptr SSL_ -> IO ()) @@ -267,7 +303,11 @@ _ssl_set_fd ssl fdInt return ssl fpssl <- newForeignPtr _ssl_free ssl - return $ SSL (sem, fpssl, fd, sock) + return $ SSL { sslSem = sem + , sslPtr = fpssl + , sslFd = fd + , sslSocket = sock + } -- | Wrap a Socket in an SSL connection. Reading and writing to the Socket -- after this will cause weird errors in the SSL code. The SSL object @@ -282,9 +322,9 @@ fdConnection context fd = connection' context fd Nothing withSSL :: SSL -> (Ptr SSL_ -> IO a) -> IO a -withSSL (SSL (sem, ssl, _, _)) action = do - waitQSem sem - finally (withForeignPtr ssl action) $ signalQSem sem +withSSL (SSL {sslSem, sslPtr}) action = do + waitQSem sslSem + finally (withForeignPtr sslPtr action) $ signalQSem sslSem foreign import ccall "SSL_accept" _ssl_accept :: Ptr SSL_ -> IO CInt foreign import ccall "SSL_connect" _ssl_connect :: Ptr SSL_ -> IO CInt @@ -302,41 +342,55 @@ -- | This is the type of an SSL IO operation. EOF and termination are handled -- by exceptions while everything else is one of these. Note that reading -- from an SSL socket can result in WantWrite and vice versa. -data SSLIOResult = Done CInt -- ^ successfully mananged *n* bytes +data SSLResult a = SSLDone a -- ^ operation finished successfully | WantRead -- ^ needs more data from the network | WantWrite -- ^ needs more outgoing buffer space - deriving (Eq) + deriving (Eq, Show, Functor, Foldable, Traversable) +-- | Block until the operation is finished. +sslBlock :: (SSL -> IO (SSLResult a)) -> SSL -> IO a +sslBlock action ssl = do + result <- action ssl + case result of + SSLDone r -> return r + WantRead -> threadWaitRead (sslFd ssl) >> sslBlock action ssl + WantWrite -> threadWaitWrite (sslFd ssl) >> sslBlock action ssl -- | Perform an SSL operation which can return non-blocking error codes, thus -- requesting that the operation be performed when data or buffer space is -- availible. -sslDoHandshake :: (Ptr SSL_ -> IO CInt) -> SSL -> IO CInt -sslDoHandshake action ssl@(SSL (_, _, fd, _)) = do - let f ssl = do - n <- action ssl - case n of - n | n >= 0 -> return $ Done n - _ -> do - err <- _ssl_get_error ssl n - case err of - (#const SSL_ERROR_WANT_READ) -> return WantRead - (#const SSL_ERROR_WANT_WRITE) -> return WantWrite - _ -> throwSSLException err - result <- withSSL ssl f - case result of - Done n -> return n - WantRead -> threadWaitRead fd >> sslDoHandshake action ssl - WantWrite -> threadWaitWrite fd >> sslDoHandshake action ssl +sslTryHandshake :: (Ptr SSL_ -> IO CInt) -> SSL -> IO (SSLResult CInt) +sslTryHandshake action = flip withSSL $ \pSsl -> do + n <- action pSsl + if n >= 0 + then return $ SSLDone n + else do + err <- _ssl_get_error pSsl n + case err of + (#const SSL_ERROR_WANT_READ) -> return WantRead + (#const SSL_ERROR_WANT_WRITE) -> return WantWrite + _ -> throwSSLException err -- | Perform an SSL server handshake accept :: SSL -> IO () -accept ssl = sslDoHandshake _ssl_accept ssl >>= failIf_ (/= 1) +accept = sslBlock tryAccept +-- | Try to perform an SSL server handshake without blocking +tryAccept :: SSL -> IO (SSLResult ()) +tryAccept ssl = do + result <- sslTryHandshake _ssl_accept ssl + forM result $ failIf_ (/= 1) + -- | Perform an SSL client handshake connect :: SSL -> IO () -connect ssl = sslDoHandshake _ssl_connect ssl >>= failIf_ (/= 1) +connect = sslBlock tryConnect +-- | Try to perform an SSL client handshake without blocking +tryConnect :: SSL -> IO (SSLResult ()) +tryConnect ssl = do + result <- sslTryHandshake _ssl_connect ssl + forM result $ 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 @@ -353,11 +407,11 @@ -> Ptr CChar -- ^ the buffer to pass -> Int -- ^ the length to pass -> Ptr SSL_ - -> IO SSLIOResult + -> IO (SSLResult CInt) sslIOInner f ptr nbytes ssl = do n <- f ssl (castPtr ptr) $ fromIntegral nbytes case n of - n | n > 0 -> return $ Done $ fromIntegral n + n | n > 0 -> return $ SSLDone $ fromIntegral n | n == 0 -> do shutdown <- _ssl_get_shutdown ssl if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) == 0 @@ -370,38 +424,43 @@ (#const SSL_ERROR_WANT_WRITE) -> return WantWrite _ -> throwSSLException err --- | Try the read the given number of bytes from an SSL connection. On EOF an +catchEOF :: a -> IO a -> IO a +catchEOF x m = m `catch` \e -> if isEOFError e then return x else throwIO e + +-- | Try to read the given number of bytes from an SSL connection. On EOF an -- empty ByteString is returned. If the connection dies without a graceful -- SSL shutdown, an exception is raised. read :: SSL -> Int -> IO B.ByteString -read ssl@(SSL (_, _, fd, _)) nbytes = B.createAndTrim nbytes $ f ssl - where - f ssl ptr - = do result <- withSSL ssl $ sslIOInner _ssl_read (castPtr ptr) nbytes - case result of - Done n -> return $ fromIntegral n - WantRead -> threadWaitRead fd >> f ssl ptr - WantWrite -> threadWaitWrite fd >> f ssl ptr - `catch` - \ ioe -> - if isEOFError ioe then - return 0 - else - ioError ioe -- rethrow +read ssl nbytes = B.createAndTrim nbytes $ \ptr -> do + let doRead = withSSL ssl $ sslIOInner _ssl_read (castPtr ptr) nbytes + catchEOF 0 $ fromIntegral <$> sslBlock (const doRead) ssl +-- | Try to read the given number of bytes from an SSL connection +-- without blocking. +tryRead :: SSL -> Int -> IO (SSLResult B.ByteString) +tryRead ssl nbytes = do + (bs, result) <- B.createAndTrim' nbytes $ \ptr -> do + result <- catchEOF (SSLDone 0) $ withSSL ssl $ + sslIOInner _ssl_read (castPtr ptr) nbytes + return $ case result of + SSLDone n -> (0, fromIntegral n, SSLDone ()) + WantRead -> (0, 0, WantRead) + WantWrite -> (0, 0, WantWrite) + return $ bs <$ result + foreign import ccall "SSL_write" _ssl_write :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt -- | Write a given ByteString to the SSL connection. Either all the data is -- written or an exception is raised because of an error write :: SSL -> B.ByteString -> IO () -write ssl@(SSL (_, _, fd, _)) bs = B.unsafeUseAsCStringLen bs $ f ssl where - f ssl (ptr, len) = do - result <- withSSL ssl $ sslIOInner _ssl_write ptr len - case result of - Done _ -> return () - WantRead -> threadWaitRead fd >> f ssl (ptr, len) - WantWrite -> threadWaitWrite fd >> f ssl (ptr, len) +write ssl bs = void $ sslBlock (`tryWrite` bs) ssl +-- | Try to write a given ByteString to the SSL connection without blocking. +tryWrite :: SSL -> B.ByteString -> IO (SSLResult ()) +tryWrite ssl bs = + B.unsafeUseAsCStringLen bs $ \(ptr, len) -> + ((() <$) <$>) $ withSSL ssl $ sslIOInner _ssl_write ptr len + -- | 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 @@ -439,13 +498,19 @@ -- This can either just send a shutdown, or can send and wait for the peer's -- shutdown message. shutdown :: SSL -> ShutdownType -> IO () -shutdown ssl ty = do - n <- sslDoHandshake _ssl_shutdown ssl - case ty of - Unidirectional -> return () - Bidirectional -> unless (n == 1) - $ shutdown ssl ty +shutdown ssl ty = sslBlock (`tryShutdown` ty) ssl +-- | Try to cleanly shutdown an SSL connection without blocking. +tryShutdown :: SSL -> ShutdownType -> IO (SSLResult ()) +tryShutdown ssl ty = do + result <- sslTryHandshake _ssl_shutdown ssl + case result of + SSLDone n -> case ty of + Bidirectional | n /= 1 -> tryShutdown ssl ty + _ -> return $ SSLDone () + WantRead -> return WantRead + WantWrite -> return WantWrite + foreign import ccall "SSL_get_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_) -- | After a successful connection, get the certificate of the other party. If @@ -477,11 +542,9 @@ -- | Get the socket underlying an SSL connection sslSocket :: SSL -> Maybe Socket -sslSocket (SSL (_, _, _, socket)) = socket -- | Get the underlying socket Fd sslFd :: SSL -> Fd -sslFd (SSL (_, _, fd, _)) = fd -- | The root exception type for all SSL exceptions. data SomeSSLException diff --git a/OpenSSL/X509/Revocation.hsc b/OpenSSL/X509/Revocation.hsc --- a/OpenSSL/X509/Revocation.hsc +++ b/OpenSSL/X509/Revocation.hsc @@ -39,6 +39,7 @@ , getRevokedList , addRevoked + , getRevoked ) where @@ -119,6 +120,10 @@ foreign import ccall unsafe "X509_CRL_add0_revoked" _add0_revoked :: Ptr X509_CRL -> Ptr X509_REVOKED -> IO CInt +foreign import ccall unsafe "X509_CRL_get0_by_serial" + _get0_by_serial :: Ptr X509_CRL -> Ptr (Ptr X509_REVOKED) + -> Ptr ASN1_INTEGER -> IO CInt + foreign import ccall unsafe "X509_CRL_sort" _sort :: Ptr X509_CRL -> IO CInt @@ -278,17 +283,16 @@ getRevokedList :: CRL -> IO [RevokedCertificate] getRevokedList crl = withCRLPtr crl $ \ crlPtr -> - (_get_REVOKED crlPtr >>= mapStack peekRevoked) - where - peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate - peekRevoked rev - = do serial <- peekASN1Integer =<< (#peek X509_REVOKED, serialNumber ) rev - date <- peekASN1Time =<< (#peek X509_REVOKED, revocationDate) rev - return RevokedCertificate { - revSerialNumber = serial - , revRevocationDate = date - } + _get_REVOKED crlPtr >>= mapStack peekRevoked +peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate +peekRevoked rev = do + serial <- peekASN1Integer =<< (#peek X509_REVOKED, serialNumber ) rev + date <- peekASN1Time =<< (#peek X509_REVOKED, revocationDate) rev + return RevokedCertificate { revSerialNumber = serial + , revRevocationDate = date + } + newRevoked :: RevokedCertificate -> IO (Ptr X509_REVOKED) newRevoked revoked = do revPtr <- _new_revoked @@ -315,10 +319,19 @@ 1 -> return () _ -> freeRevoked revPtr >> raiseOpenSSLError +-- |@'getRevoked' crl serial@ looks up the corresponding revocation. +getRevoked :: CRL -> Integer -> IO (Maybe RevokedCertificate) +getRevoked crl serial = + withCRLPtr crl $ \crlPtr -> + alloca $ \revPtr -> + withASN1Integer serial $ \serialPtr -> do + r <- _get0_by_serial crlPtr revPtr serialPtr + if r == 1 + then fmap Just $ peek revPtr >>= peekRevoked + else return Nothing + -- |@'sortCRL' crl@ sorts the certificates in the revocation list. sortCRL :: CRL -> IO () sortCRL crl = withCRLPtr crl $ \ crlPtr -> - _sort crlPtr - >>= failIf (/= 1) - >> return () + _sort crlPtr >>= failIf_ (/= 1) diff --git a/OpenSSL/X509/Store.hsc b/OpenSSL/X509/Store.hsc --- a/OpenSSL/X509/Store.hsc +++ b/OpenSSL/X509/Store.hsc @@ -15,15 +15,22 @@ , addCertToStore , addCRLToStore + + , X509StoreCtx + , X509_STORE_CTX -- private + + , withX509StoreCtxPtr -- private + , wrapX509StoreCtx -- private ) where -import Foreign -import Foreign.C -import Foreign.Concurrent as FC -import OpenSSL.X509 -import OpenSSL.X509.Revocation -import OpenSSL.Utils +import Control.Applicative ((<$>)) +import Foreign +import Foreign.C +import Foreign.Concurrent as FC +import OpenSSL.X509 +import OpenSSL.X509.Revocation +import OpenSSL.Utils -- |@'X509Store'@ is an opaque object that represents X.509 -- certificate store. The certificate store is usually used for chain @@ -77,3 +84,14 @@ _add_crl storePtr crlPtr >>= failIf (/= 1) >> return () + +data X509_STORE_CTX +newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX) + +withX509StoreCtxPtr :: X509StoreCtx -> (Ptr X509_STORE_CTX -> IO a) -> IO a +withX509StoreCtxPtr (X509StoreCtx fp) = withForeignPtr fp + +wrapX509StoreCtx :: IO () -> Ptr X509_STORE_CTX -> IO X509StoreCtx +wrapX509StoreCtx finaliser ptr = + X509StoreCtx <$> FC.newForeignPtr ptr finaliser + diff --git a/cbits/HsOpenSSL.c b/cbits/HsOpenSSL.c --- a/cbits/HsOpenSSL.c +++ b/cbits/HsOpenSSL.c @@ -105,6 +105,16 @@ } +/* DH *************************************************************************/ +BIGNUM *HsOpenSSL_DH_get_pub_key(DH *dh) { + return dh->pub_key; +} + +int HsOpenSSL_DH_length(DH *dh) { + return BN_num_bits(dh->p); +} + + /* ASN1 ***********************************************************************/ ASN1_INTEGER* HsOpenSSL_M_ASN1_INTEGER_new() { return M_ASN1_INTEGER_new();