happstack-server-tls (empty) → 6.0.0
raw patch · 6 files changed
+323/−0 lines, 6 filesdep +HsOpenSSLdep +basedep +bytestringsetup-changed
Dependencies added: HsOpenSSL, base, bytestring, extensible-exceptions, happstack-server, hslogger, network, sendfile, time, unix
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- happstack-server-tls.cabal +35/−0
- src/Happstack/Server/Internal/TLS.hs +166/−0
- src/Happstack/Server/Internal/TimeoutSocketTLS.hs +60/−0
- src/Happstack/Server/SimpleHTTPS.hs +30/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Jeremy Shaw++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jeremy Shaw nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ happstack-server-tls.cabal view
@@ -0,0 +1,35 @@+Name: happstack-server-tls+Version: 6.0.0+Synopsis: extend happstack-server with https:// support (TLS/SSL)+Description: extend happstack-server with https:// support (TLS/SSL)+Homepage: http://www.happstack.com/+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw+Maintainer: jeremy@n-heptane.com+Copyright: 2012 Jeremy Shaw+Category: Web+Build-type: Simple+Cabal-version: >=1.6++Library+ hs-source-dirs: src++ Exposed-modules: Happstack.Server.Internal.TimeoutSocketTLS+ Happstack.Server.Internal.TLS+ Happstack.Server.SimpleHTTPS++ Build-Depends: base < 5,+ bytestring == 0.9.*,+ extensible-exceptions == 0.1.*,+ happstack-server == 6.6.*,+ hslogger == 1.1.*,+ HsOpenSSL == 0.10.*,+ network == 2.3.*,+ sendfile == 0.7.*,+ time == 1.4.*+ Extra-Libraries: cryptopp ssl++ if !os(windows)+ Build-Depends: unix+ cpp-options: -DUNIX
+ src/Happstack/Server/Internal/TLS.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE CPP, ScopedTypeVariables #-}+{- | core functions and types for HTTPS support+-}+module Happstack.Server.Internal.TLS where++import Control.Concurrent (forkIO, killThread, myThreadId)+import Control.Exception (finally)+import Control.Exception.Extensible as E+import Control.Monad (forever, when)+import Data.Time (UTCTime)+import Happstack.Server.Internal.Listen (listenOn)+import Happstack.Server.Internal.Handler (request)+import Happstack.Server.Internal.Socket (acceptLite)+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 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.Log.Logger (Priority(..), logM)+#ifndef mingw32_HOST_OS+import System.Posix.Signals (Handler(Ignore), installHandler, openEndedPipe)+#endif++-- | wrapper around 'logM' for this module +log':: Priority -> String -> IO ()+log' = logM "Happstack.Server.Internal.TLS"+++-- | configuration for using https:\/\/+data TLSConf = TLSConf {+ tlsPort :: Int -- port (usually 443)+ , tlsCert :: FilePath -- path to SSL certificate+ , tlsKey :: FilePath -- path to SSL private key+ , 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+ }++-- | a partially complete 'TLSConf' . You must sete 'tlsCert' and 'tlsKey' at a mininum.+nullTLSConf :: TLSConf+nullTLSConf = + TLSConf { tlsPort = 443+ , tlsCert = ""+ , tlsKey = ""+ , tlsTimeout = 30+ , tlsLogAccess = Just logMAccess+ , tlsValidator = Nothing+ }+ ++-- | record that holds the 'Socket' and 'SSLContext' needed to start+-- the https:\/\/ event loop. Used with 'simpleHTTPWithSocket''+--+-- see also: 'httpOnSocket'+data HTTPS = HTTPS+ { httpsSocket :: Socket+ , sslContext :: SSLContext+ }++-- | generate the 'HTTPS' record needed to start the https:\/\/ event loop+--+httpsOnSocket :: FilePath -- ^ path to ssl certificate+ -> FilePath -- ^ path to ssl private key+ -> Socket -- ^ listening socket (on which listen() has been called, but not accept())+ -> IO HTTPS+httpsOnSocket cert key socket =+ do ctx <- SSL.context+ SSL.contextSetPrivateKeyFile ctx key+ SSL.contextSetCertificateFile ctx cert+ SSL.contextSetDefaultCiphers ctx++ b <- SSL.contextCheckPrivateKey ctx+ when (not b) $ error $ "OpenTLS certificate and key do not match."++ return (HTTPS socket ctx)++-- | accept a TLS connection+acceptTLS :: HTTPS -> IO (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)++-- | https:// 'Request'/'Response' loop+--+-- This function initializes SSL, and starts accepting and handling+-- 'Request's and sending 'Respone's.+--+-- Each 'Request' is processed in a separate thread.+listenTLS :: TLSConf -- ^ tls configuration+ -> (Request -> IO Response) -- ^ request handler+ -> IO ()+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++-- | low-level https:// 'Request'/'Response' loop+--+-- This is the low-level loop that reads 'Request's and sends+-- 'Respone's. It assumes that SSL has already been initialized and+-- that socket is listening.+--+-- 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 hand = 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+ killThread tid+ let timeoutIO = TSS.timeoutSocketIO thandle ssl+ request timeoutIO mlog (hn,fromIntegral p) hand `E.catches` [ Handler ignoreConnectionAbruptlyTerminated+ , Handler ehs + ]+ -- remove thread from timeout table+ cancel (toHandle timeoutIO)+ toShutdown timeoutIO `E.catch` ignoreSSLException++ loop :: IO ()+ loop = forever $ do w <- acceptTLS https+ forkIO $ work w+ 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)+ where+ ignoreSSLException :: SSL.SomeSSLException -> IO ()+ ignoreSSLException _ = return ()+ -- exception handlers+ ignoreConnectionAbruptlyTerminated :: SSL.ConnectionAbruptlyTerminated -> IO ()+ ignoreConnectionAbruptlyTerminated _ = 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+ , Handler $ \(e :: ArithException) -> h (toException e)+ , Handler $ \(e :: ArrayException) -> h (toException e)+ , Handler $ \(e :: IOException) ->+ if isFullError e+ then return () -- h (toException e) -- we could log the exception, but there could be thousands of them+ else throw e+ ]+
+ src/Happstack/Server/Internal/TimeoutSocketTLS.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+{- | +-- borrowed from snap-server. Check there periodically for updates.+-}+module Happstack.Server.Internal.TimeoutSocketTLS where++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.SendFile (ByteCount, Offset)+import OpenSSL.Session (SSL)+import qualified OpenSSL.Session as SSL+import Prelude hiding (catch)+import System.IO (IOMode(ReadMode), SeekMode(AbsoluteSeek), hSeek, withBinaryFile)+import System.IO.Unsafe (unsafeInterleaveIO)++sPutLazyTickle :: TM.Handle -> SSL -> L.ByteString -> IO ()+sPutLazyTickle thandle ssl cs =+ do L.foldrChunks (\c rest -> SSL.write ssl c >> TM.tickle thandle >> rest) (return ()) cs+{-# INLINE sPutLazyTickle #-}++sPutTickle :: TM.Handle -> SSL -> B.ByteString -> IO ()+sPutTickle thandle ssl cs =+ do SSL.write ssl cs+ TM.tickle thandle+{-# INLINE sPutTickle #-}++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++timeoutSocketIO :: TM.Handle -> SSL -> TimeoutIO+timeoutSocketIO handle ssl =+ TimeoutIO { toHandle = handle+ , toShutdown = SSL.shutdown ssl SSL.Unidirectional+ , toPutLazy = sPutLazyTickle handle ssl+ , toPut = sPutTickle handle ssl+ , toGetContents = sGetContents handle ssl+ , toSendFile = sendFileTickle handle ssl+ , toSecure = True+ }++sendFileTickle :: TM.Handle -> SSL -> FilePath -> Offset -> ByteCount -> IO ()+sendFileTickle thandle ssl fp offset count =+ do withBinaryFile fp ReadMode $ \h -> do+ hSeek h AbsoluteSeek offset+ c <- L.hGetContents h+ sPutLazyTickle thandle ssl (L.take (fromIntegral count) c)
+ src/Happstack/Server/SimpleHTTPS.hs view
@@ -0,0 +1,30 @@+module Happstack.Server.SimpleHTTPS + ( TLSConf(..)+ , nullTLSConf+ , simpleHTTPS+ , simpleHTTPS'+ ) where++import Data.Maybe (fromMaybe)+import Happstack.Server (ToMessage(..), UnWebT(..), ServerPartT, simpleHTTP'', logMAccess, mapServerPartT, runValidator)+import Happstack.Server.Internal.TLS (TLSConf(..), nullTLSConf, listenTLS)++-- |start the https:\/\/ server, and handle requests using the supplied+-- 'ServerPart'.+--+-- This function will not return, though it may throw an exception.+--+simpleHTTPS :: (ToMessage a) =>+ TLSConf -- ^ tls server configuration+ -> ServerPartT IO a -- ^ server part to run+ -> IO ()+simpleHTTPS = simpleHTTPS' id++-- | similar 'simpleHTTPS' but allows you to supply a function to convert 'm' to 'IO'.+simpleHTTPS' :: (ToMessage b, Monad m, Functor m) => + (UnWebT m a -> UnWebT IO b)+ -> TLSConf + -> ServerPartT m a + -> IO ()+simpleHTTPS' toIO tlsConf hs =+ listenTLS tlsConf (\req -> runValidator (fromMaybe return (tlsValidator tlsConf)) =<< (simpleHTTP'' (mapServerPartT toIO hs) req))