diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,8 @@ +happstack-server-tls [![Hackage](https://img.shields.io/hackage/v/happstack-server-tls.svg)](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. + + diff --git a/happstack-server-tls.cabal b/happstack-server-tls.cabal --- a/happstack-server-tls.cabal +++ b/happstack-server-tls.cabal @@ -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 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,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 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 @@ -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 diff --git a/src/Happstack/Server/SimpleHTTPS.hs b/src/Happstack/Server/SimpleHTTPS.hs --- a/src/Happstack/Server/SimpleHTTPS.hs +++ b/src/Happstack/Server/SimpleHTTPS.hs @@ -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