happstack-server-tls 6.0.0 → 6.0.1
raw patch · 3 files changed
+74/−41 lines, 3 filesdep ~happstack-server
Dependency ranges changed: happstack-server
Files
- happstack-server-tls.cabal +2/−2
- src/Happstack/Server/Internal/TLS.hs +51/−27
- src/Happstack/Server/Internal/TimeoutSocketTLS.hs +21/−12
happstack-server-tls.cabal view
@@ -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.*,
src/Happstack/Server/Internal/TLS.hs view
@@ -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
src/Happstack/Server/Internal/TimeoutSocketTLS.hs view
@@ -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 =