diff --git a/happstack-server-tls.cabal b/happstack-server-tls.cabal --- a/happstack-server-tls.cabal +++ b/happstack-server-tls.cabal @@ -1,5 +1,5 @@ Name: happstack-server-tls -Version: 6.0.0 +Version: 6.0.1 Synopsis: extend happstack-server with https:// support (TLS/SSL) Description: extend happstack-server with https:// support (TLS/SSL) Homepage: http://www.happstack.com/ @@ -22,7 +22,7 @@ Build-Depends: base < 5, bytestring == 0.9.*, extensible-exceptions == 0.1.*, - happstack-server == 6.6.*, + happstack-server >= 6.6.4 && < 7, hslogger == 1.1.*, HsOpenSSL == 0.10.*, network == 2.3.*, diff --git a/src/Happstack/Server/Internal/TLS.hs b/src/Happstack/Server/Internal/TLS.hs --- a/src/Happstack/Server/Internal/TLS.hs +++ b/src/Happstack/Server/Internal/TLS.hs @@ -4,10 +4,11 @@ module Happstack.Server.Internal.TLS where import Control.Concurrent (forkIO, killThread, myThreadId) -import Control.Exception (finally) +import Control.Exception (catch, finally) import Control.Exception.Extensible as E import Control.Monad (forever, when) import Data.Time (UTCTime) +import GHC.IO.Exception (IOErrorType(..)) import Happstack.Server.Internal.Listen (listenOn) import Happstack.Server.Internal.Handler (request) import Happstack.Server.Internal.Socket (acceptLite) @@ -15,12 +16,13 @@ import Happstack.Server.Internal.TimeoutSocketTLS as TSS import Happstack.Server.Internal.Types (Request, Response) import Network.Socket (HostName, PortNumber, Socket, getSocketName, sClose, socketPort) +import Prelude hiding (catch) import OpenSSL (withOpenSSL) import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL.Session as SSL import Happstack.Server.Internal.TimeoutIO (TimeoutIO(toHandle, toShutdown)) import Happstack.Server.Types (LogAccess, logMAccess) -import System.IO.Error (isFullError) +import System.IO.Error (ioeGetErrorType, isFullError, isDoesNotExistError) import System.Log.Logger (Priority(..), logM) #ifndef mingw32_HOST_OS import System.Posix.Signals (Handler(Ignore), installHandler, openEndedPipe) @@ -74,22 +76,22 @@ SSL.contextSetCertificateFile ctx cert SSL.contextSetDefaultCiphers ctx - b <- SSL.contextCheckPrivateKey ctx - when (not b) $ error $ "OpenTLS certificate and key do not match." + certOk <- SSL.contextCheckPrivateKey ctx + when (not certOk) $ error $ "OpenTLS certificate and key do not match." return (HTTPS socket ctx) -- | accept a TLS connection -acceptTLS :: HTTPS -> IO (SSL, HostName, PortNumber) +acceptTLS :: HTTPS -> IO (Socket, SSL, HostName, PortNumber) acceptTLS (HTTPS sck' ctx) = do -- do normal accept (sck, peer, port) <- acceptLite sck' -- then TLS accept - ssl <- SSL.connection ctx sck - SSL.accept ssl - - return (ssl, peer, port) + handle (\ (e :: SomeException) -> sClose sck >> throwIO e) $ do + ssl <- SSL.connection ctx sck + SSL.accept ssl + return (sck, ssl, peer, port) -- | https:// 'Request'/'Response' loop -- @@ -116,27 +118,36 @@ -- -- see also: 'listenTLS' listenTLS' :: Int -> Maybe (LogAccess UTCTime) -> Socket -> HTTPS -> (Request -> IO Response) -> IO () -listenTLS' timeout mlog socket https hand = do +listenTLS' timeout mlog socket https handler = do #ifndef mingw32_HOST_OS installHandler openEndedPipe Ignore Nothing #endif tm <- initialize (timeout * (10^(6 :: Int))) - do let work :: (SSL, HostName, PortNumber) -> IO () - work (ssl, hn, p) = - do tid <- myThreadId - thandle <- register tm $ do SSL.shutdown ssl SSL.Unidirectional `E.catch` ignoreSSLException + do let work :: (Socket, SSL, HostName, PortNumber) -> IO () + work (socket, ssl, hn, p) = + do -- add this thread to the timeout table + tid <- myThreadId + thandle <- register tm $ do shutdownClose socket ssl killThread tid - let timeoutIO = TSS.timeoutSocketIO thandle ssl - request timeoutIO mlog (hn,fromIntegral p) hand `E.catches` [ Handler ignoreConnectionAbruptlyTerminated - , Handler ehs - ] + -- handle the request + let timeoutIO = TSS.timeoutSocketIO thandle socket ssl + + request timeoutIO mlog (hn, fromIntegral p) handler + `E.catches` [ Handler ignoreConnectionAbruptlyTerminated + , Handler ehs + ] + -- remove thread from timeout table - cancel (toHandle timeoutIO) - toShutdown timeoutIO `E.catch` ignoreSSLException + cancel thandle + -- close connection + shutdownClose socket ssl + loop :: IO () - loop = forever $ do w <- acceptTLS https - forkIO $ work w + loop = forever $ do w@(socket, ssl, _, _) <- acceptTLS https + forkIO $ work w `catch` (\(e :: SomeException) -> do + shutdownClose socket ssl + throwIO e) return () pe e = log' ERROR ("ERROR in https accept thread: " ++ show e) infi = loop `catchSome` pe >> infi @@ -145,22 +156,35 @@ log' NOTICE ("Listening on https://" ++ show sockName ++":" ++ show sockPort) infi `finally` (sClose socket) where - ignoreSSLException :: SSL.SomeSSLException -> IO () - ignoreSSLException _ = return () + shutdownClose :: Socket -> SSL -> IO () + shutdownClose socket ssl = + do SSL.shutdown ssl SSL.Unidirectional `E.catch` ignoreException + sClose socket `E.catch` ignoreException + -- exception handlers ignoreConnectionAbruptlyTerminated :: SSL.ConnectionAbruptlyTerminated -> IO () ignoreConnectionAbruptlyTerminated _ = return () + ignoreSSLException :: SSL.SomeSSLException -> IO () + ignoreSSLException _ = return () + + ignoreException :: SomeException -> IO () + ignoreException _ = return () + ehs :: SomeException -> IO () ehs x = when ((fromException x) /= Just ThreadKilled) $ log' ERROR ("HTTPS request failed with: " ++ show x) catchSome op h = - op `E.catches` [ Handler ignoreConnectionAbruptlyTerminated + op `E.catches` [ Handler $ ignoreSSLException , Handler $ \(e :: ArithException) -> h (toException e) , Handler $ \(e :: ArrayException) -> h (toException e) , Handler $ \(e :: IOException) -> - if isFullError e + if isFullError e || isDoesNotExistError e then return () -- h (toException e) -- we could log the exception, but there could be thousands of them else throw e ] - + isResourceVanishedError :: IOException -> Bool + isResourceVanishedError = isResourceVanishedType . ioeGetErrorType + isResourceVanishedType :: IOErrorType -> Bool + isResourceVanishedType ResourceVanished = True + isResourceVanishedType _ = False diff --git a/src/Happstack/Server/Internal/TimeoutSocketTLS.hs b/src/Happstack/Server/Internal/TimeoutSocketTLS.hs --- a/src/Happstack/Server/Internal/TimeoutSocketTLS.hs +++ b/src/Happstack/Server/Internal/TimeoutSocketTLS.hs @@ -4,6 +4,7 @@ -} module Happstack.Server.Internal.TimeoutSocketTLS where +import Control.Exception (SomeException, catch) import Control.Monad (liftM) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L @@ -11,10 +12,11 @@ import qualified Data.ByteString as S import qualified Happstack.Server.Internal.TimeoutManager as TM import Happstack.Server.Internal.TimeoutIO (TimeoutIO(..)) +import Network.Socket (Socket, sClose) import Network.Socket.SendFile (ByteCount, Offset) import OpenSSL.Session (SSL) import qualified OpenSSL.Session as SSL -import Prelude hiding (catch) +import Prelude hiding (catch) import System.IO (IOMode(ReadMode), SeekMode(AbsoluteSeek), hSeek, withBinaryFile) import System.IO.Unsafe (unsafeInterleaveIO) @@ -32,25 +34,32 @@ sGetContents :: TM.Handle -> SSL -- ^ Connected socket -> IO L.ByteString -- ^ Data received -sGetContents handle ssl = loop where - loop = unsafeInterleaveIO $ do - s <- SSL.read ssl 65536 - TM.tickle handle - if S.null s - then do -- SSL.shutdown ssl SSL.Unidirectional `catch` (\e -> when (not $ isDoesNotExistError e) (throw e)) - return L.Empty - else L.Chunk s `liftM` loop +sGetContents handle ssl = + fmap L.fromChunks loop + where + chunkSize = 65536 + loop = unsafeInterleaveIO $ do + s <- SSL.read ssl chunkSize + TM.tickle handle + if S.null s + then do return [] + else do ss <- loop + return (s:ss) -timeoutSocketIO :: TM.Handle -> SSL -> TimeoutIO -timeoutSocketIO handle ssl = +timeoutSocketIO :: TM.Handle -> Socket -> SSL -> TimeoutIO +timeoutSocketIO handle socket ssl = TimeoutIO { toHandle = handle - , toShutdown = SSL.shutdown ssl SSL.Unidirectional + , toShutdown = do SSL.shutdown ssl SSL.Unidirectional `catch` ignoreException + sClose socket `catch` ignoreException , toPutLazy = sPutLazyTickle handle ssl , toPut = sPutTickle handle ssl , toGetContents = sGetContents handle ssl , toSendFile = sendFileTickle handle ssl , toSecure = True } + where + ignoreException :: SomeException -> IO () + ignoreException _ = return () sendFileTickle :: TM.Handle -> SSL -> FilePath -> Offset -> ByteCount -> IO () sendFileTickle thandle ssl fp offset count =