happstack-server-tls 7.0.4 → 7.2.1.7
raw patch · 5 files changed
Files
- README.md +8/−0
- happstack-server-tls.cabal +39/−13
- src/Happstack/Server/Internal/TLS.hs +34/−25
- src/Happstack/Server/Internal/TimeoutSocketTLS.hs +18/−6
- src/Happstack/Server/SimpleHTTPS.hs +1/−1
+ README.md view
@@ -0,0 +1,8 @@+happstack-server-tls [](https://hackage.haskell.org/package/happstack-server-tls)+=========++A very fine Haskell web server. Details in [The Happstack Book](http://www.happstack.com/docs/crashcourse/index.html).++This library provides TLS/SSL/HTTPS support.++
happstack-server-tls.cabal view
@@ -1,36 +1,62 @@ Name: happstack-server-tls-Version: 7.0.4+Version: 7.2.1.7 Synopsis: extend happstack-server with https:// support (TLS/SSL)-Description: extend happstack-server with https:// support (TLS/SSL)+Description: Allows you to use https:// without relying on apache, nginx, etc Homepage: http://www.happstack.com/ License: BSD3 License-file: LICENSE Author: Jeremy Shaw Maintainer: jeremy@n-heptane.com-Copyright: 2012 Jeremy Shaw+Copyright: 2012-2019, Jeremy Shaw Category: Web, Happstack Build-type: Simple-Cabal-version: >=1.6+Cabal-version: >=1.10+extra-source-files: README.md+tested-with:+ GHC == 9.14.1+ GHC == 9.12.2+ GHC == 9.10.2+ GHC == 9.8.2+ GHC == 9.6.7+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2 +++source-repository head+ type: git+ location: https://github.com/Happstack/happstack-server-tls.git+ Library+ Default-language: Haskell2010 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 Build-Depends: base < 5,- bytestring >= 0.9 && < 0.11,+ bytestring >= 0.9 && < 0.13, extensible-exceptions == 0.1.*,- happstack-server >= 6.6.4 && < 7.4,- hslogger >= 1.1 && < 1.3,- HsOpenSSL == 0.10.*,- network >= 2.3 && < 2.5,+ happstack-server >= 6.6.4 && < 7.10,+ hslogger >= 1.1 && < 1.4,+ HsOpenSSL >= 0.10 && < 0.12,+ network >= 3.0.0 && < 3.3, sendfile == 0.7.*,- time >= 1.2 && < 1.5+ time >= 1.2 && < 1.16+ -- these extra libraries are not needed to build/install the server+ -- but they do need to be installed if you want to use GHCi or+ -- Template Haskell afterwards Extra-Libraries: ssl- if !os(darwin)- Extra-Libraries: cryptopp+-- if !os(darwin)+-- Extra-Libraries: cryptopp if !os(windows) Build-Depends: unix
src/Happstack/Server/Internal/TLS.hs view
@@ -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, close, 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)@@ -38,6 +36,7 @@ tlsPort :: Int -- port (usually 443) , tlsCert :: FilePath -- path to SSL certificate , tlsKey :: FilePath -- path to SSL private key+ , tlsCA :: Maybe FilePath -- PEM encoded list of CA certificates , tlsTimeout :: Int -- kill connect of timeout (in seconds) , tlsLogAccess :: Maybe (LogAccess UTCTime) -- see 'logMAccess' , tlsValidator :: Maybe (Response -> IO Response) -- ^ a function to validate the output on-the-fly@@ -49,6 +48,7 @@ TLSConf { tlsPort = 443 , tlsCert = "" , tlsKey = ""+ , tlsCA = Nothing , tlsTimeout = 30 , tlsLogAccess = Just logMAccess , tlsValidator = Nothing@@ -68,12 +68,16 @@ -- httpsOnSocket :: FilePath -- ^ path to ssl certificate -> FilePath -- ^ path to ssl private key+ -> Maybe FilePath -- ^ path to PEM encoded list of CA certificates -> Socket -- ^ listening socket (on which listen() has been called, but not accept()) -> IO HTTPS-httpsOnSocket cert key socket =+httpsOnSocket cert key mca socket = do ctx <- SSL.context SSL.contextSetPrivateKeyFile ctx key SSL.contextSetCertificateFile ctx cert+ case mca of+ Nothing -> return ()+ (Just ca) -> SSL.contextSetCAFile ctx ca SSL.contextSetDefaultCiphers ctx certOk <- SSL.contextCheckPrivateKey ctx@@ -82,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- handle (\ (e :: SomeException) -> sClose sck >> throwIO e) $ do+acceptTLS :: Socket -- ^ the socket returned from 'acceptLite'+ -> SSLContext+ -> IO SSL+acceptTLS sck ctx =+ handle (\ (e :: SomeException) -> close sck >> throwIO e) $ do ssl <- SSL.connection ctx sck SSL.accept ssl- return (sck, ssl, peer, port)+ return ssl -- | https:// 'Request'/'Response' loop --@@ -105,8 +107,8 @@ listenTLS tlsConf hand = do withOpenSSL $ return () tlsSocket <- listenOn (tlsPort tlsConf)- https <- httpsOnSocket (tlsCert tlsConf) (tlsKey tlsConf) tlsSocket- listenTLS' (tlsTimeout tlsConf) (tlsLogAccess tlsConf) tlsSocket https hand+ https <- httpsOnSocket (tlsCert tlsConf) (tlsKey tlsConf) (tlsCA tlsConf) tlsSocket+ listenTLS' (tlsTimeout tlsConf) (tlsLogAccess tlsConf) https hand -- | low-level https:// 'Request'/'Response' loop --@@ -117,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@@ -144,22 +146,29 @@ 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` (close lsocket)+ where shutdownClose :: Socket -> SSL -> IO () shutdownClose socket ssl = do SSL.shutdown ssl SSL.Unidirectional `E.catch` ignoreException- sClose socket `E.catch` ignoreException+ close socket `E.catch` ignoreException -- exception handlers ignoreConnectionAbruptlyTerminated :: SSL.ConnectionAbruptlyTerminated -> IO ()@@ -181,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
src/Happstack/Server/Internal/TimeoutSocketTLS.hs view
@@ -1,18 +1,17 @@ {-# 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 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 (Socket, close) import Network.Socket.SendFile (ByteCount, Offset) import OpenSSL.Session (SSL) import qualified OpenSSL.Session as SSL@@ -31,10 +30,22 @@ TM.tickle thandle {-# INLINE sPutTickle #-} -sGetContents :: TM.Handle +sGet :: TM.Handle+ -> SSL+ -> IO (Maybe B.ByteString)+sGet handle ssl =+ do s <- SSL.read ssl chunkSize+ TM.tickle handle+ if S.null s+ then pure Nothing+ else pure (Just s)+ where+ chunkSize = 65536++sGetContents :: TM.Handle -> SSL -- ^ Connected socket -> IO L.ByteString -- ^ Data received-sGetContents handle ssl = +sGetContents handle ssl = fmap L.fromChunks loop where chunkSize = 65536@@ -50,9 +61,10 @@ timeoutSocketIO handle socket ssl = TimeoutIO { toHandle = handle , toShutdown = do SSL.shutdown ssl SSL.Unidirectional `catch` ignoreException- sClose socket `catch` ignoreException+ close socket `catch` ignoreException , toPutLazy = sPutLazyTickle handle ssl , toPut = sPutTickle handle ssl+ , toGet = sGet handle ssl , toGetContents = sGetContents handle ssl , toSendFile = sendFileTickle handle ssl , toSecure = True
src/Happstack/Server/SimpleHTTPS.hs view
@@ -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