diff --git a/HsOpenSSL.cabal b/HsOpenSSL.cabal --- a/HsOpenSSL.cabal +++ b/HsOpenSSL.cabal @@ -5,16 +5,17 @@ generate RSA and DSA keys, read and write PEM files, generate message digests, sign and verify messages, encrypt and decrypt messages. -Version: 0.4 +Version: 0.4.1 License: PublicDomain License-File: COPYING -Author: PHO -Maintainer: PHO +Author: PHO +Maintainer: PHO Stability: experimental Homepage: http://ccm.sherry.jp/HsOpenSSL/ Category: Cryptography Tested-With: GHC == 6.8.1 Cabal-Version: >= 1.2 +Build-Type: Configure Extra-Source-Files: AUTHORS @@ -66,7 +67,6 @@ OpenSSL.X509.Revocation OpenSSL.X509.Request OpenSSL.X509.Store - OpenSSL.SocketBIO OpenSSL.Session Other-Modules: OpenSSL.ASN1 diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,15 @@ +Changes from 0.4 to 0.4.1 +------------------------- +* Applied patches by Adam Langley: + - Fix BN<->Integer conversions on 64-bit systems + - Another 64-bit fix (OpenSSL.ASN1.peekASN1String) + - Add ByteString version of digestBS + - Fix the foreign types of the cipher functions to use CInt, not Int + - 64-bit fix for HMAC + - Turn the Session IO inside out + - Silly cosmetic change + + Changes from 0.3.1 to 0.4 ------------------------- * Applied patches by Adam Langley: diff --git a/OpenSSL/ASN1.hsc b/OpenSSL/ASN1.hsc --- a/OpenSSL/ASN1.hsc +++ b/OpenSSL/ASN1.hsc @@ -61,8 +61,8 @@ peekASN1String :: Ptr ASN1_STRING -> IO String peekASN1String strPtr = do buf <- (#peek ASN1_STRING, data ) strPtr - len <- (#peek ASN1_STRING, length) strPtr - peekCStringLen (buf, len) + len <- (#peek ASN1_STRING, length) strPtr :: IO CInt + peekCStringLen (buf, fromIntegral len) {- ASN1_INTEGER -------------------------------------------------------------- -} diff --git a/OpenSSL/BN.hsc b/OpenSSL/BN.hsc --- a/OpenSSL/BN.hsc +++ b/OpenSSL/BN.hsc @@ -51,7 +51,6 @@ import Foreign.C #else import Foreign.C.Types -import Data.Word (Word32) import GHC.Base import GHC.Num import GHC.Prim @@ -164,11 +163,11 @@ -- | Convert a BIGNUM to an Integer bnToInteger :: BigNum -> IO Integer bnToInteger bn = do - nlimbs <- (#peek BIGNUM, top) (unwrapBN bn) :: IO CSize + nlimbs <- (#peek BIGNUM, top) (unwrapBN bn) :: IO CInt case nlimbs of 0 -> return 0 1 -> do (I## i) <- (#peek BIGNUM, d) (unwrapBN bn) >>= peek - negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO Word32 + negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt if negative == 0 then return $ S## i else return $ 0 - (S## i) @@ -179,7 +178,7 @@ (BA ba) <- freezeByteArray arr limbs <- (#peek BIGNUM, d) (unwrapBN bn) _copy_in ba limbs $ fromIntegral $ nlimbs * (#size unsigned long) - negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO Word32 + negative <- (#peek BIGNUM, neg) (unwrapBN bn) :: IO CInt if negative == 0 then return $ J## nlimbsi ba else return $ 0 - (J## nlimbsi ba) @@ -191,9 +190,9 @@ bnptr <- mallocBytes (#size BIGNUM) (#poke BIGNUM, d) bnptr nullPtr -- This is needed to give GHC enough type information - let one :: Word32 + let one :: CInt one = 1 - zero :: Word32 + zero :: CInt zero = 0 (#poke BIGNUM, flags) bnptr one (#poke BIGNUM, top) bnptr zero @@ -203,12 +202,12 @@ integerToBN (S## v) = do bnptr <- mallocBytes (#size BIGNUM) - limbs <- malloc :: IO (Ptr Word32) + limbs <- malloc :: IO (Ptr CULong) poke limbs $ fromIntegral $ abs $ I## v (#poke BIGNUM, d) bnptr limbs -- This is needed to give GHC enough type information since #poke just -- uses an offset - let one :: Word32 + let one :: CInt one = 1 (#poke BIGNUM, flags) bnptr one (#poke BIGNUM, top) bnptr one @@ -220,16 +219,16 @@ | v >= 0 = do let nlimbs = (I## nlimbs_) bnptr <- mallocBytes (#size BIGNUM) - limbs <- mallocBytes ((#size unsigned) * nlimbs) + limbs <- mallocBytes ((#size unsigned long) * nlimbs) (#poke BIGNUM, d) bnptr limbs - (#poke BIGNUM, flags) bnptr (1 :: Word32) - _copy_out limbs bytearray (fromIntegral $ (#size unsigned) * nlimbs) - (#poke BIGNUM, top) bnptr ((fromIntegral nlimbs) :: Word32) - (#poke BIGNUM, dmax) bnptr ((fromIntegral nlimbs) :: Word32) - (#poke BIGNUM, neg) bnptr (0 :: Word32) + (#poke BIGNUM, flags) bnptr (1 :: CInt) + _copy_out limbs bytearray (fromIntegral $ (#size unsigned long) * nlimbs) + (#poke BIGNUM, top) bnptr ((fromIntegral nlimbs) :: CInt) + (#poke BIGNUM, dmax) bnptr ((fromIntegral nlimbs) :: CInt) + (#poke BIGNUM, neg) bnptr (0 :: CInt) return (wrapBN bnptr) | otherwise = do bnptr <- integerToBN (0-v) - (#poke BIGNUM, neg) (unwrapBN bnptr) (1 :: Word32) + (#poke BIGNUM, neg) (unwrapBN bnptr) (1 :: CInt) return bnptr -- TODO: we could make a function which doesn't even allocate BN data if we diff --git a/OpenSSL/EVP/Cipher.hsc b/OpenSSL/EVP/Cipher.hsc --- a/OpenSSL/EVP/Cipher.hsc +++ b/OpenSSL/EVP/Cipher.hsc @@ -121,16 +121,16 @@ foreign import ccall unsafe "EVP_CipherInit" - _CipherInit :: Ptr EVP_CIPHER_CTX -> Ptr EVP_CIPHER -> CString -> CString -> Int -> IO Int + _CipherInit :: Ptr EVP_CIPHER_CTX -> Ptr EVP_CIPHER -> CString -> CString -> CInt -> IO CInt foreign import ccall unsafe "EVP_CipherUpdate" - _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr Int -> Ptr CChar -> Int -> IO Int + _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> Ptr CChar -> CInt -> IO CInt foreign import ccall unsafe "EVP_CipherFinal" - _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr Int -> IO Int + _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> IO CInt -cryptoModeToInt :: CryptoMode -> Int +cryptoModeToInt :: CryptoMode -> CInt cryptoModeToInt Encrypt = 1 cryptoModeToInt Decrypt = 0 @@ -152,9 +152,9 @@ unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) -> createAndTrim (inLen + _ctx_block_size ctxPtr - 1) $ \ outBuf -> alloca $ \ outLenPtr -> - _CipherUpdate ctxPtr (castPtr outBuf) outLenPtr inBuf inLen + _CipherUpdate ctxPtr (castPtr outBuf) outLenPtr inBuf (fromIntegral inLen) >>= failIf (/= 1) - >> peek outLenPtr + >> liftM fromIntegral (peek outLenPtr) cipherFinalBS :: CipherCtx -> IO B8.ByteString @@ -164,7 +164,7 @@ alloca $ \ outLenPtr -> _CipherFinal ctxPtr (castPtr outBuf) outLenPtr >>= failIf (/= 1) - >> peek outLenPtr + >> liftM fromIntegral (peek outLenPtr) -- |@'cipher'@ lazilly encrypts or decrypts a stream of data. The -- input string doesn't necessarily have to be finite. diff --git a/OpenSSL/EVP/Digest.hsc b/OpenSSL/EVP/Digest.hsc --- a/OpenSSL/EVP/Digest.hsc +++ b/OpenSSL/EVP/Digest.hsc @@ -23,6 +23,7 @@ , digest , digestBS + , digestBS' , digestLBS , hmacBS @@ -30,6 +31,7 @@ where import Control.Monad +import Data.ByteString.Internal (createAndTrim) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy.Char8 as L8 @@ -133,7 +135,15 @@ bufLen <- liftM fromIntegral $ peek bufLenPtr peekCStringLen (bufPtr, bufLen) +digestFinalBS :: DigestCtx -> IO B8.ByteString +digestFinalBS ctx = + withDigestCtxPtr ctx $ \ctxPtr -> + createAndTrim (#const EVP_MAX_MD_SIZE) $ \bufPtr -> + alloca $ \bufLenPtr -> + do _DigestFinal ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf (/= 1) + liftM fromIntegral $ peek bufLenPtr + digestStrictly :: Digest -> B8.ByteString -> IO DigestCtx digestStrictly md input = do ctx <- digestInit md @@ -161,6 +171,12 @@ do ctx <- digestStrictly md input digestFinal ctx +digestBS' :: Digest -> B8.ByteString -> B8.ByteString +digestBS' md input + = unsafePerformIO $ + do ctx <- digestStrictly md input + digestFinalBS ctx + -- |@'digestLBS'@ digests a stream of data. digestLBS :: Digest -> L8.ByteString -> String digestLBS md input @@ -171,7 +187,7 @@ {- HMAC ---------------------------------------------------------------------- -} foreign import ccall unsafe "HMAC" - _HMAC :: Ptr EVP_MD -> Ptr CChar -> CInt -> Ptr CChar -> CInt + _HMAC :: Ptr EVP_MD -> Ptr CChar -> CInt -> Ptr CChar -> CSize -> Ptr CChar -> Ptr CUInt -> IO () -- | Perform a private key signing using the HMAC template with a given hash diff --git a/OpenSSL/Session.hsc b/OpenSSL/Session.hsc --- a/OpenSSL/Session.hsc +++ b/OpenSSL/Session.hsc @@ -1,8 +1,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} --- | Functions for handling SSL/TLS connections over Sockets. The Sockets are --- wrapped in BIO objects so that openssl works well with Haskell's threading --- system (i.e. a 'blocking' read will actually allow other green threads to --- run rather than blocking the whole OS thread) +-- | 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. module OpenSSL.Session ( -- * Contexts SSLContext @@ -12,29 +11,41 @@ , contextSetCiphers , contextSetDefaultCiphers , contextCheckPrivateKey + , VerificationMode(..) + , contextSetVerificationMode + , contextSetCAFile + , contextSetCADirectory -- * SSL connections , SSL , connection , accept + , connect , read , write - , ShutdownType(..) , shutdown + , ShutdownType(..) + , getPeerCertificate + , getVerifyResult + , sslSocket ) where #include "openssl/ssl.h" -import Prelude hiding (read) +import Prelude hiding (read, ioError) +import Control.Concurrent (threadWaitWrite, threadWaitRead) +import Control.Concurrent.QSem +import Control.Exception (finally) import Foreign import Foreign.C import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B -import Network.Socket (Socket) +import System.IO.Error (mkIOError, ioError, eofErrorType) +import System.Posix.Types (Fd(..)) +import Network.Socket (Socket(..)) -import OpenSSL.Utils (failIfNull, failIf, raiseOpenSSLError) -import OpenSSL.BIO (BIO, BIO_, withBioPtr) -import OpenSSL.SocketBIO (socketToBIO) +import OpenSSL.Utils (failIfNull, failIf) +import OpenSSL.X509 (X509, X509_, wrapX509) data SSLContext_ -- | An SSL context. Contexts carry configuration such as a server's private @@ -42,7 +53,11 @@ -- start empty and various options are set on them by the functions in this -- module. Note that an empty context will pretty much cause any operation to -- fail since it doesn't even have any ciphers enabled. -newtype SSLContext = SSLContext (ForeignPtr SSLContext_) +-- +-- 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 SSLMethod_ @@ -52,12 +67,23 @@ -- | Create a new SSL context. context :: IO SSLContext -context = _ssl_method >>= _ssl_ctx_new >>= newForeignPtr _ssl_ctx_free >>= return . SSLContext +context = do + ctx <- _ssl_method >>= _ssl_ctx_new + context <- newForeignPtr _ssl_ctx_free ctx + sem <- newQSem 1 + return $ SSLContext (sem, context) +-- | 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 + contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO Int) -> SSLContext -> String -> IO () -contextLoadFile f (SSLContext context) path = - withForeignPtr context $ \ctx -> +contextLoadFile f context path = + withContext context $ \ctx -> withCString path $ \cpath -> do result <- f ctx cpath (#const SSL_FILETYPE_PEM) if result == 1 @@ -91,8 +117,8 @@ -- Unrecognised ciphers are ignored. If no ciphers from the list are -- recognised, an exception is raised. contextSetCiphers :: SSLContext -> String -> IO () -contextSetCiphers (SSLContext context) list = - withForeignPtr context $ \ctx -> +contextSetCiphers context list = + withContext context $ \ctx -> withCString list $ \cpath -> _ssl_ctx_set_cipher_list ctx cpath >>= failIf (/= 1) >> return () @@ -105,75 +131,202 @@ -- | Return true iff the private key installed in the given context matches the -- certificate also installed. contextCheckPrivateKey :: SSLContext -> IO Bool -contextCheckPrivateKey (SSLContext context) = - withForeignPtr context $ \ctx -> +contextCheckPrivateKey context = + withContext context $ \ctx -> _ssl_ctx_check_private_key ctx >>= return . (==) 1 +-- | See +data VerificationMode = VerifyNone + | VerifyPeer Bool -- ^ is a certificate required + Bool -- ^ only request once per connection + +foreign import ccall unsafe "SSL_CTX_set_verify" + _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> Ptr () -> IO () + +contextSetVerificationMode :: SSLContext -> VerificationMode -> IO () +contextSetVerificationMode context VerifyNone = do + withContext context $ \ctx -> + _ssl_set_verify_mode ctx (#const SSL_VERIFY_NONE) nullPtr >> return () + +contextSetVerificationMode context (VerifyPeer reqp oncep) = 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 () + +foreign import ccall unsafe "SSL_CTX_load_verify_locations" + _ssl_load_verify_locations :: Ptr SSLContext_ -> Ptr CChar -> Ptr CChar -> IO CInt + +-- | 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 + withContext context $ \ctx -> + withCString path $ \cpath -> do + _ssl_load_verify_locations ctx cpath nullPtr >>= failIf (/= 1) + return () + +-- | Set the path to a directory which contains the PEM encoded CA root +-- certificates. This is an alternative to 'contextSetCAFile'. See +-- for +-- details of the file naming scheme +contextSetCADirectory :: SSLContext -> FilePath -> IO () +contextSetCADirectory context path = do + withContext context $ \ctx -> + withCString path $ \cpath -> do + _ssl_load_verify_locations ctx nullPtr cpath >>= failIf (/= 1) + return () + + + data SSL_ -- | This is the type of an SSL connection -newtype SSL = SSL (Socket, BIO, ForeignPtr SSL_) +-- +-- SSL objects are not thread safe, so they carry a QSem around with them +-- which only lets a single thread work inside them at a time. Thus, one must +-- always use withSSL, rather than withForeignPtr directly. +-- +-- IO with SSL objects is non-blocking and many SSL functions return a error +-- code which signifies that it needs to read or write more data. We handle +-- these calls and call threadWaitRead and threadWaitWrite at the correct +-- 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, 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 ()) -foreign import ccall unsafe "SSL_set_bio" _ssl_set_bio :: Ptr SSL_ -> Ptr BIO_ -> Ptr BIO_ -> IO () +foreign import ccall unsafe "SSL_set_fd" _ssl_set_fd :: Ptr SSL_ -> CInt -> IO () -- | 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 -- carries a handle to the Socket so you need not worry about the garbage -- collector closing the file descriptor out from under you. connection :: SSLContext -> Socket -> IO SSL -connection (SSLContext context) sock = do - bio <- socketToBIO sock - ssl <- withBioPtr bio (\bio -> do - withForeignPtr context (\ctx -> do - ssl <- _ssl_new ctx >>= failIfNull - _ssl_set_bio ssl bio bio - return ssl)) +connection context sock@(MkSocket fd _ _ _ _) = do + sem <- newQSem 1 + ssl <- withContext context (\ctx -> do + ssl <- _ssl_new ctx >>= failIfNull + _ssl_set_fd ssl fd + return ssl) fpssl <- newForeignPtr _ssl_free ssl - return $ SSL (sock, bio, fpssl) + return $ SSL (sem, fpssl, Fd fd, sock) +withSSL :: SSL -> (Ptr SSL_ -> IO a) -> IO a +withSSL (SSL (sem, ssl, _, _)) action = do + waitQSem sem + finally (withForeignPtr ssl action) $ signalQSem sem + foreign import ccall "SSL_accept" _ssl_accept :: Ptr SSL_ -> IO CInt +foreign import ccall "SSL_connect" _ssl_connect :: Ptr SSL_ -> IO CInt +foreign import ccall unsafe "SSL_get_error" _ssl_get_error :: Ptr SSL_ -> CInt -> IO CInt +sslErrorToString :: CInt -> String +sslErrorToString (#const SSL_ERROR_NONE) = "SSL: No error" +sslErrorToString (#const SSL_ERROR_ZERO_RETURN) = "SSL: connection cleanly closed" +sslErrorToString (#const SSL_ERROR_WANT_CONNECT) = "SSL: want connect" +sslErrorToString (#const SSL_ERROR_WANT_ACCEPT) = "SSL: want accept" +sslErrorToString (#const SSL_ERROR_WANT_X509_LOOKUP) = "SSL: want X509 lookup" +sslErrorToString (#const SSL_ERROR_SYSCALL) = "SSL: syscall error" +sslErrorToString (#const SSL_ERROR_SSL) = "SSL: ssl protocol error" +sslErrorToString x = "SSL: unknown error " ++ show x + +-- | 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 + | WantRead -- ^ needs more data from the network + | WantWrite -- ^ needs more outgoing buffer space + deriving (Eq) + + +-- | 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 + _ -> fail $ sslErrorToString err + result <- withSSL ssl f + case result of + Done n -> return n + WantRead -> threadWaitRead fd >> sslDoHandshake action ssl + WantWrite -> threadWaitWrite fd >> sslDoHandshake action ssl + -- | Perform an SSL server handshake accept :: SSL -> IO () -accept (SSL (_, _, ssl)) = withForeignPtr ssl (\ssl -> do - _ssl_accept ssl >>= failIf (/= 1)) >> return () +accept ssl = sslDoHandshake _ssl_accept ssl >>= failIf (/= 1) >> return () +-- | Perform an SSL client handshake +connect :: SSL -> IO () +connect ssl = sslDoHandshake _ssl_connect ssl >>= failIf (/= 1) >> return () + 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 +-- | Perform an SSL operation which operates of a buffer and can return +-- non-blocking error codes, thus requesting that it be performed again when +-- more data or buffer space is availible. +-- +-- Note that these SSL functions generally require that the arguments to the +-- repeated call be exactly the same. This presents an issue because multiple +-- threads could try writing at the same time (with different buffers) so the +-- calling function should probably hold the lock on the SSL object over the +-- whole time (include repeated calls) +sslIOInner :: (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt) -- ^ the SSL IO function to call + -> Ptr CChar -- ^ the buffer to pass + -> Int -- ^ the length to pass + -> Ptr SSL_ + -> IO SSLIOResult +sslIOInner f ptr nbytes ssl = do + n <- f ssl (castPtr ptr) $ fromIntegral nbytes + case n of + n | n > 0 -> return $ Done $ fromIntegral n + | n == 0 -> do + shutdown <- _ssl_get_shutdown ssl + if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) == 0 + then fail "SSL connection abruptly terminated" + else ioError $ mkIOError eofErrorType "" Nothing Nothing + _ -> do + err <- _ssl_get_error ssl n + case err of + (#const SSL_ERROR_WANT_READ) -> return WantRead + (#const SSL_ERROR_WANT_WRITE) -> return WantWrite + _ -> fail $ sslErrorToString err + -- | Try the 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)) nbytes = B.createAndTrim nbytes $ \ptr -> - withForeignPtr ssl $ \ssl -> do - n <- _ssl_read ssl ptr $ fromIntegral nbytes - if n > 0 - then return $ fromIntegral n - else if n < 0 - then raiseOpenSSLError - else do - shutdown <- _ssl_get_shutdown ssl - if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) /= 0 - then return 0 - else fail "SSL connection abruptly terminated" +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 -foreign import ccall "SSL_write" _ssl_write :: Ptr SSL_ -> Ptr CChar -> CInt -> IO CInt +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)) bs = do - withForeignPtr ssl $ \ssl -> - B.unsafeUseAsCStringLen bs $ \(ptr, nbytes) -> - let f _ 0 = return () - f ptr nbytes = do - n <- _ssl_write ssl ptr (fromIntegral nbytes) >>= return . fromIntegral - if n <= 0 - then raiseOpenSSLError - else f (ptr `plusPtr` n) (nbytes - n) - in f ptr nbytes +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) foreign import ccall "SSL_shutdown" _ssl_shutdown :: Ptr SSL_ -> IO CInt @@ -187,12 +340,44 @@ -- This can either just send a shutdown, or can send and wait for the peer's -- shutdown message. shutdown :: SSL -> ShutdownType -> IO () -shutdown (SSL (_, _, ssl)) ty = - withForeignPtr ssl $ \ssl -> do - n <- _ssl_shutdown ssl >>= failIf (< 0) - case ty of - Unidirectional -> return () - Bidirectional -> do - if n == 1 - then return () - else _ssl_shutdown ssl >>= failIf (< 0) >> return () +shutdown ssl ty = do + n <- sslDoHandshake _ssl_shutdown ssl + case ty of + Unidirectional -> return () + Bidirectional -> do + if n == 1 + then return () + else shutdown ssl ty + +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 +-- this is a server connection, you probably won't get a certificate unless +-- you asked for it with contextSetVerificationMode +getPeerCertificate :: SSL -> IO (Maybe X509) +getPeerCertificate ssl = + withSSL ssl $ \ssl -> do + cert <- _ssl_get_peer_cert ssl + if cert == nullPtr + then return Nothing + else wrapX509 cert >>= return . Just + +foreign import ccall "SSL_get_verify_result" _ssl_get_verify_result :: Ptr SSL_ -> IO CLong + +-- | Get the result of verifing the peer's certificate. This is mostly for +-- clients to verify the certificate of the server that they have connected +-- it. You must set a list of root CA certificates with contextSetCA... for +-- this to make sense. +-- +-- Note that this returns True iff the peer's certificate has a valid chain +-- 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 + withSSL ssl $ \ssl -> do + r <- _ssl_get_verify_result ssl + return $ r == (#const X509_V_OK) + +-- | Get the socket underlying an SSL connection +sslSocket :: SSL -> Socket +sslSocket (SSL (_, _, _, socket)) = socket diff --git a/OpenSSL/SocketBIO.hsc b/OpenSSL/SocketBIO.hsc deleted file mode 100644 --- a/OpenSSL/SocketBIO.hsc +++ /dev/null @@ -1,75 +0,0 @@ --- | This module wraps a Haskell Socket in a BIO. It's different from the --- @BIO@ module in that it works the 'other way' - gather than being the --- client of a BIO, we are the implementation. -module OpenSSL.SocketBIO (socketToBIO) where - -import Foreign -import Foreign.C -import Network.Socket (Socket(..)) -import GHC.Conc (threadWaitRead, threadWaitWrite) - -import OpenSSL.BIO (BIO, BIO_, wrapBioPtr) - -foreign import ccall "socket_BIO_wrapper" _wrapper :: CInt -> IO (Ptr BIO_) - --- | Convert a Socket into a BIO object. Warning: the file descriptor --- underlying this Socket is saved in the BIO, but it doesn't carry a --- reference to the Socket itself. Thus, if you don't keep your own reference --- then the GC could close the socket from under the BIO. -socketToBIO :: Socket -> IO BIO -socketToBIO (MkSocket s _ _ _ _) = _wrapper s >>= wrapBioPtr - -foreign import ccall unsafe "send" - c_send :: CInt -> Ptr a -> CSize -> CInt -> IO CInt -foreign import ccall unsafe "recv" - c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt - --------------------------------------------------------------------------------- --- Taken from network-bytestring - -{-# SPECIALISE - throwErrnoIfMinus1Retry_mayBlock - :: String -> IO CInt -> IO CInt -> IO CInt #-} -throwErrnoIfMinus1Retry_mayBlock :: Num a => String -> IO a -> IO a -> IO a -throwErrnoIfMinus1Retry_mayBlock name on_block act = do - res <- act - if res == -1 - then do - err <- getErrno - if err == eINTR - then throwErrnoIfMinus1Retry_mayBlock name on_block act - else if err == eWOULDBLOCK || err == eAGAIN - then on_block - else return (-1) - else return res - -throwErrnoIfMinus1Retry_repeatOnBlock :: Num a => String -> IO b -> IO a -> IO a -throwErrnoIfMinus1Retry_repeatOnBlock name on_block act = do - throwErrnoIfMinus1Retry_mayBlock name (on_block >> repeat) act - where repeat = throwErrnoIfMinus1Retry_repeatOnBlock name on_block act - --------------------------------------------------------------------------------- --- The following functions are callback Haskell functions which are exported to --- the C code - -bioRead :: CInt -> Ptr Word8 -> CInt -> IO CInt -bioRead fd ptr nbytes = do - len <- throwErrnoIfMinus1Retry_repeatOnBlock "bioRead" - (threadWaitRead (fromIntegral fd)) $ - c_recv fd (castPtr ptr) (fromIntegral nbytes) 0 - if fromIntegral len == (-1 :: Int) - then do errno <- getErrno - if errno == eINTR - then bioRead fd ptr nbytes - else return (-1) - else return len - -bioWrite :: CInt -> Ptr Word8 -> CInt -> IO CInt -bioWrite fd ptr nbytes = do - len <- throwErrnoIfMinus1Retry_repeatOnBlock "bioWrite" - (threadWaitWrite (fromIntegral fd)) $ - c_send fd (castPtr ptr) (fromIntegral nbytes) 0 - return len - -foreign export ccall "bioRead" bioRead :: CInt -> Ptr Word8 -> CInt -> IO CInt -foreign export ccall "bioWrite" bioWrite :: CInt -> Ptr Word8 -> CInt -> IO CInt diff --git a/OpenSSL/X509/Name.hsc b/OpenSSL/X509/Name.hsc --- a/OpenSSL/X509/Name.hsc +++ b/OpenSSL/X509/Name.hsc @@ -64,7 +64,7 @@ peekX509Name :: Ptr X509_NAME -> Bool -> IO [(String, String)] peekX509Name namePtr wantLongName = do count <- _entry_count namePtr >>= failIf (< 0) - mapM peekEntry $ take count [0..] + mapM peekEntry [0..count - 1] where peekEntry :: Int -> IO (String, String) peekEntry n diff --git a/cbits/HsOpenSSL.c b/cbits/HsOpenSSL.c --- a/cbits/HsOpenSSL.c +++ b/cbits/HsOpenSSL.c @@ -203,99 +203,3 @@ sig.s = s; return dsa->meth->dsa_do_verify(ddata, dlen, &sig, dsa); } - -/* Socket BIO *****************************************************************/ - -extern int bioRead(int fd, char *buffer, int size); -extern int bioWrite(int fd, const char *buffer, int size); - -static int -wrapped_bio_fd(BIO *b) { - return (int) ((intptr_t) b->ptr); -} - -static int -wrapped_bio_write(BIO *b, const char *ptr, int size) { - const int fd = wrapped_bio_fd(b); - return bioWrite(fd, ptr, size); -} - -static int -wrapped_bio_read(BIO *b, char *ptr, int size) { - const int fd = wrapped_bio_fd(b); - return bioRead(fd, ptr, size); -} - -static int -wrapped_bio_puts(BIO *b, const char *str) { - const int fd = wrapped_bio_fd(b); - const int n = strlen(str); - return bioWrite(fd, str, n); -} - -static int -wrapped_bio_new(BIO *b) { - b->init = 1; - b->shutdown = 0; - b->flags = 0; - b->retry_reason = 0; - b->num = 0; - b->ptr = NULL; - b->next_bio = b->prev_bio = NULL; - b->callback = NULL; - // By default, reference is set to one and functions like SSL_set_bio 'steal' - // the reference. This makes sense for C programmers who can then ignore the - // reference count and everything will work out. However, we want to keep a - // reference because this ends up in a ForeignPtr and so the GC will want to - // destroy it at some point. - b->references = 2; - - return 1; -} - -static int -wrapped_bio_free(BIO *b) { - return 1; -} - -static long -wrapped_bio_ctl(BIO *b, int cmd, long num, void *ptr) { - long ret = 1; - - switch (cmd) { - case BIO_CTRL_RESET: - case BIO_C_FILE_SEEK: - case BIO_C_FILE_TELL: - case BIO_CTRL_INFO: - case BIO_C_SET_FD: - case BIO_C_GET_FD: - case BIO_CTRL_GET_CLOSE: - case BIO_CTRL_PENDING: - case BIO_CTRL_WPENDING: - return 0; - case BIO_CTRL_SET_CLOSE: - case BIO_CTRL_DUP: - case BIO_CTRL_FLUSH: - return 1; - default: - return 0; - } -} - -static BIO_METHOD wrapper_methods = - { BIO_TYPE_SOCKET, - "socket", - wrapped_bio_write, - wrapped_bio_read, - wrapped_bio_puts, - NULL, /* gets */ - wrapped_bio_ctl, - wrapped_bio_new, - wrapped_bio_free, - NULL, }; - -BIO *socket_BIO_wrapper(int fd) { - BIO *const b = BIO_new(&wrapper_methods); - b->ptr = (void *) ((intptr_t) fd); - return b; -} diff --git a/cbits/HsOpenSSL.h b/cbits/HsOpenSSL.h --- a/cbits/HsOpenSSL.h +++ b/cbits/HsOpenSSL.h @@ -69,8 +69,4 @@ int HsOpenSSL_dsa_verify(DSA *dsa, const unsigned char *ddata, int len, BIGNUM *r, BIGNUM *s); -/* Socket BIO *****************************************************************/ - -BIO *socket_BIO_wrapper(int fd); - #endif