Permalink
Browse files

Fixed erroneous error handling in OpenSSL.Session

SSL_get_error() must be called within the OS thread which caused
the failed operation as it inspects the thread-local storage.
  • Loading branch information...
1 parent 4f86772 commit 022bbd9a94e4bcc8694bb9bc9439fa28e3f4078b @depressed-pho committed Nov 12, 2011
Showing with 65 additions and 64 deletions.
  1. +4 −0 NEWS
  2. +7 −18 OpenSSL/ERR.hsc
  3. +54 −46 OpenSSL/Session.hsc
View
4 NEWS
@@ -5,6 +5,10 @@ Changes from 0.10.1.1 to ?
* Applied a patch by Mikhail Vorozhtsov:
- Moved all EVP-related private functions to OpenSSL.EVP.Internal.
+* Fixed erroneous error handling in OpenSSL.Session:
+ - SSL_get_error() must be called within the OS thread which caused
+ the failed operation as it inspects the thread-local storage.
+
Changes from 0.10.1 to 0.10.1.1
-------------------------------
View
@@ -5,29 +5,18 @@ module OpenSSL.ERR
, errorString
)
where
-
-import Foreign
-import Foreign.C
-
+import Foreign
+import Foreign.C
foreign import ccall unsafe "ERR_get_error"
- _get_error :: IO CULong
+ getError :: IO CULong
foreign import ccall unsafe "ERR_peek_error"
- _peek_error :: IO CULong
+ peekError :: IO CULong
foreign import ccall unsafe "ERR_error_string"
- _error_string :: CULong -> CString -> IO CString
-
-
-getError :: IO Integer
-getError = fmap fromIntegral _get_error
-
-
-peekError :: IO Integer
-peekError = fmap fromIntegral _peek_error
-
+ _error_string :: CULong -> CString -> IO CString
-errorString :: Integer -> IO String
+errorString :: CULong -> IO String
errorString code
- = _error_string (fromIntegral code) nullPtr >>= peekCString
+ = _error_string code nullPtr >>= peekCString
View
@@ -53,15 +53,14 @@ module OpenSSL.Session
, WantConnect
, WantAccept
, WantX509Lookup
- , SSLIOError
, ProtocolError
, UnknownError(..)
) where
#include "openssl/ssl.h"
import Prelude hiding (catch, read, ioError, mapM, mapM_)
-import Control.Concurrent (threadWaitWrite, threadWaitRead)
+import Control.Concurrent (threadWaitWrite, threadWaitRead, runInBoundThread)
import Control.Concurrent.QSem
import Control.Exception
import Control.Applicative ((<$>), (<$))
@@ -84,6 +83,7 @@ import System.IO.Unsafe
import System.Posix.Types (Fd(..))
import Network.Socket (Socket(..))
+import OpenSSL.ERR
import OpenSSL.EVP.PKey
import OpenSSL.EVP.Internal
import OpenSSL.Utils
@@ -337,10 +337,24 @@ throwSSLException (#const SSL_ERROR_ZERO_RETURN ) = throwIO ConnectionCleanl
throwSSLException (#const SSL_ERROR_WANT_CONNECT ) = throwIO WantConnect
throwSSLException (#const SSL_ERROR_WANT_ACCEPT ) = throwIO WantAccept
throwSSLException (#const SSL_ERROR_WANT_X509_LOOKUP) = throwIO WantX509Lookup
-throwSSLException (#const SSL_ERROR_SYSCALL ) = throwIO SSLIOError
throwSSLException (#const SSL_ERROR_SSL ) = throwIO ProtocolError
throwSSLException x = throwIO (UnknownError (fromIntegral x))
+inspectSyscallError :: String -> CInt -> IO a
+inspectSyscallError loc ret
+ = do e <- getError
+ if e == 0 then
+ if ret == 0 then
+ throwIO ConnectionAbruptlyTerminated
+ else
+ do errno <- getErrno
+ if errno == ePIPE then
+ throwIO ConnectionAbruptlyTerminated
+ else
+ ioError (errnoToIOError loc errno Nothing Nothing)
+ else
+ errorString e >>= fail
+
-- | 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.
@@ -361,17 +375,23 @@ sslBlock action ssl = do
-- | 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.
-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
+sslTryHandshake :: (Ptr SSL_ -> IO CInt)
+ -> (CInt -> Bool)
+ -> SSL
+ -> IO (SSLResult CInt)
+sslTryHandshake action isSuccess
+ = flip withSSL $ \pSsl ->
+ runInBoundThread $
+ do n <- action pSsl
+ if isSuccess n 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
+ (#const SSL_ERROR_SYSCALL ) -> inspectSyscallError "sslTryHandshake" n
+ _ -> throwSSLException err
-- | Perform an SSL server handshake
accept :: SSL -> IO ()
@@ -380,7 +400,7 @@ accept = sslBlock tryAccept
-- | Try to perform an SSL server handshake without blocking
tryAccept :: SSL -> IO (SSLResult ())
tryAccept ssl = do
- result <- sslTryHandshake _ssl_accept ssl
+ result <- sslTryHandshake _ssl_accept (== 1) ssl
forM result $ failIf_ (/= 1)
-- | Perform an SSL client handshake
@@ -390,7 +410,7 @@ connect = sslBlock tryConnect
-- | Try to perform an SSL client handshake without blocking
tryConnect :: SSL -> IO (SSLResult ())
tryConnect ssl = do
- result <- sslTryHandshake _ssl_connect ssl
+ result <- sslTryHandshake _ssl_connect (== 1) ssl
forM result $ failIf_ (/= 1)
foreign import ccall "SSL_read" _ssl_read :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
@@ -410,21 +430,23 @@ sslIOInner :: (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt) -- ^ the SSL IO functi
-> Int -- ^ the length to pass
-> Ptr SSL_
-> IO (SSLResult CInt)
-sslIOInner f ptr nbytes ssl = do
- n <- f ssl (castPtr ptr) $ fromIntegral nbytes
- case n of
- n | n > 0 -> return $ SSLDone $ fromIntegral n
- | n == 0 -> do
- shutdown <- _ssl_get_shutdown ssl
- if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) == 0
- then throw ConnectionAbruptlyTerminated
- 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
- _ -> throwSSLException err
+sslIOInner f ptr nbytes ssl
+ = runInBoundThread $
+ do n <- f ssl (castPtr ptr) $ fromIntegral nbytes
+ case n of
+ n | n > 0 -> return $ SSLDone $ fromIntegral n
+ | n == 0 ->
+ do shutdown <- _ssl_get_shutdown ssl
+ if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) == 0 then
+ throwIO ConnectionAbruptlyTerminated
+ 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
+ (#const SSL_ERROR_SYSCALL ) -> inspectSyscallError "sslIOInner" n
+ _ -> throwSSLException err
catchEOF :: a -> IO a -> IO a
catchEOF x m = m `catch` \e -> if isEOFError e then return x else throwIO e
@@ -505,7 +527,7 @@ 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
+ result <- sslTryHandshake _ssl_shutdown (>= 0) ssl
case result of
SSLDone n -> case ty of
Bidirectional | n /= 1 -> tryShutdown ssl ty
@@ -623,20 +645,6 @@ instance Exception WantX509Lookup where
toException = sslExceptionToException
fromException = sslExceptionFromException
--- | Some I\/O error occurred. The OpenSSL error queue may contain
--- more information on the error. If the error queue is empty
--- (i.e. ERR_get_error() returns 0), ret can be used to find out more
--- about the error: If ret == 0, an EOF was observed that violates the
--- protocol. If ret == -1, the underlying BIO reported an I\/O error
--- (for socket I\/O on Unix systems, consult errno for details).
-data SSLIOError
- = SSLIOError
- deriving (Typeable, Show, Eq)
-
-instance Exception SSLIOError where
- toException = sslExceptionToException
- fromException = sslExceptionFromException
-
-- | A failure in the SSL library occurred, usually a protocol
-- error. The OpenSSL error queue contains more information on the
-- error.

0 comments on commit 022bbd9

Please sign in to comment.