happstack-server-tls 7.1.1 → 7.1.2.1

raw patch · 4 files changed

+31/−29 lines, 4 filesdep ~HsOpenSSLPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: HsOpenSSL

API changes (from Hackage documentation)

Files

• happstack-server-tls.cabal +3/−3
• src/Happstack/Server/Internal/TLS.hs +24/−21
• src/Happstack/Server/Internal/TimeoutSocketTLS.hs +3/−4
• src/Happstack/Server/SimpleHTTPS.hs +1/−1

@@ -1,5 +1,5 @@ Name:                happstack-server-tls-Version:             7.1.1+Version:             7.1.2.1 Synopsis:            extend happstack-server with https:// support (TLS/SSL) Description:         extend happstack-server with https:// support (TLS/SSL) Homepage:            http://www.happstack.com/@@ -14,7 +14,7 @@  Library     hs-source-dirs:    src-+    ghc-options:       -Wall -fno-warn-unused-do-bind     Exposed-modules:   Happstack.Server.Internal.TimeoutSocketTLS                        Happstack.Server.Internal.TLS                        Happstack.Server.SimpleHTTPS@@ -24,7 +24,7 @@                        extensible-exceptions == 0.1.*,                        happstack-server      >= 6.6.4 && < 7.4,                        hslogger              >=  1.1 && < 1.3,-                       HsOpenSSL             == 0.10.*,+                       HsOpenSSL             >= 0.10 && < 0.12,                        network               >= 2.3 && < 2.6,                        sendfile              == 0.7.*,                        time                  >= 1.2 && < 1.5

@@ -4,7 +4,6 @@ module Happstack.Server.Internal.TLS where  import Control.Concurrent                         (forkIO, killThread, myThreadId)-import Control.Exception                          (catch, finally) import Control.Exception.Extensible               as E import Control.Monad                              (forever, when) import Data.Time                                  (UTCTime)@@ -15,12 +14,11 @@ import Happstack.Server.Internal.TimeoutManager   (cancel, initialize, register) import Happstack.Server.Internal.TimeoutSocketTLS as TSS import Happstack.Server.Internal.Types            (Request, Response)-import Network.Socket                             (HostName, PortNumber, Socket, getSocketName, sClose, socketPort)+import Network.Socket                             (HostName, PortNumber, Socket, 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                            (ioeGetErrorType, isFullError, isDoesNotExistError) import System.Log.Logger                          (Priority(..), logM)@@ -88,16 +86,14 @@        return (HTTPS socket ctx)  -- | accept a TLS connection-acceptTLS :: HTTPS -> IO (Socket, SSL, HostName, PortNumber)-acceptTLS (HTTPS sck' ctx) =-    do -- do normal accept-      (sck, peer, port) <- acceptLite sck'--      --  then TLS accept+acceptTLS :: Socket      -- ^ the socket returned from 'acceptLite'+          -> SSLContext+          -> IO SSL+acceptTLS sck ctx =       handle (\ (e :: SomeException) -> sClose sck >> throwIO e) $ do           ssl <- SSL.connection ctx sck           SSL.accept ssl-          return (sck, ssl, peer, port)+          return ssl  -- | https:// 'Request'/'Response' loop --@@ -112,7 +108,7 @@     do withOpenSSL $ return ()        tlsSocket <- listenOn (tlsPort tlsConf)        https     <- httpsOnSocket (tlsCert tlsConf) (tlsKey tlsConf) (tlsCA tlsConf) tlsSocket-       listenTLS' (tlsTimeout tlsConf) (tlsLogAccess tlsConf) tlsSocket https hand+       listenTLS' (tlsTimeout tlsConf) (tlsLogAccess tlsConf) https hand  -- | low-level https:// 'Request'/'Response' loop --@@ -123,8 +119,8 @@ -- Each 'Request' is processed in a separate thread. -- -- see also: 'listenTLS'-listenTLS' :: Int -> Maybe (LogAccess UTCTime) -> Socket -> HTTPS -> (Request -> IO Response) -> IO ()-listenTLS' timeout mlog socket https handler = do+listenTLS' :: Int -> Maybe (LogAccess UTCTime) -> HTTPS -> (Request -> IO Response) -> IO ()+listenTLS' timeout mlog https@(HTTPS lsocket _) handler = do #ifndef mingw32_HOST_OS   installHandler openEndedPipe Ignore Nothing #endif@@ -150,17 +146,24 @@                 shutdownClose socket ssl           loop :: IO ()-         loop = forever $ do w@(socket, ssl, _, _) <- acceptTLS https-                             forkIO $ work w `catch` (\(e :: SomeException) -> do-                                                          shutdownClose socket ssl+         loop = forever $ do -- do a normal accept+                             (sck, peer, port) <- acceptLite (httpsSocket https)+                             forkIO $ do -- do the TLS accept/handshake+                                         ssl <- acceptTLS sck (sslContext https)+                                         work (sck, ssl, peer, port)+                                           `catch` (\(e :: SomeException) -> do+                                                          shutdownClose sck ssl                                                           throwIO e)                              return ()          pe e = log' ERROR ("ERROR in https accept thread: " ++ show e)          infi = loop `catchSome` pe >> infi-     sockName <- getSocketName socket-     sockPort <- socketPort socket-     log' NOTICE ("Listening on https://" ++ show sockName ++":" ++ show sockPort)-     infi `finally` (sClose socket)+     -- sockName <- getSocketName lsocket+     sockPort <- socketPort lsocket+     log' NOTICE ("Listening for https:// on port " ++ show sockPort)+     (infi `catch` (\e -> do log' ERROR ("https:// terminated by " ++ show (e :: SomeException))+                             throwIO e))+       `finally` (sClose lsocket)+          where            shutdownClose :: Socket -> SSL -> IO ()            shutdownClose socket ssl =@@ -187,7 +190,7 @@                               , Handler $ \(e :: IOException)    ->                                   if isFullError e || isDoesNotExistError e || isResourceVanishedError e                                   then return () -- h (toException e) -- we could log the exception, but there could be thousands of them-                                  else throw e+                                  else log' ERROR ("HTTPS accept loop ignoring " ++ show e)                               ]            isResourceVanishedError :: IOException -> Bool            isResourceVanishedError = isResourceVanishedType . ioeGetErrorType

@@ -1,11 +1,10 @@ {-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-{- | +{- | -- borrowed from snap-server. Check there periodically for updates. -} 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 import qualified Data.ByteString.Lazy.Internal as L@@ -31,10 +30,10 @@        TM.tickle thandle {-# INLINE sPutTickle #-} -sGetContents :: TM.Handle +sGetContents :: TM.Handle              -> SSL              -- ^ Connected socket              -> IO L.ByteString  -- ^ Data received-sGetContents handle ssl = +sGetContents handle ssl =     fmap L.fromChunks loop     where       chunkSize = 65536

@@ -6,7 +6,7 @@      ) where  import Data.Maybe                    (fromMaybe)-import Happstack.Server              (ToMessage(..), UnWebT(..), ServerPartT, simpleHTTP'', logMAccess, mapServerPartT, runValidator)+import Happstack.Server              (ToMessage(..), UnWebT, ServerPartT, simpleHTTP'', mapServerPartT, runValidator) import Happstack.Server.Internal.TLS (TLSConf(..), nullTLSConf, listenTLS)  -- |start the https:\/\/ server, and handle requests using the supplied