diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/happstack-server-tls.cabal b/happstack-server-tls.cabal new file mode 100644 --- /dev/null +++ b/happstack-server-tls.cabal @@ -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 diff --git a/src/Happstack/Server/Internal/TLS.hs b/src/Happstack/Server/Internal/TLS.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/TLS.hs @@ -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 + ] + diff --git a/src/Happstack/Server/Internal/TimeoutSocketTLS.hs b/src/Happstack/Server/Internal/TimeoutSocketTLS.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/TimeoutSocketTLS.hs @@ -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) diff --git a/src/Happstack/Server/SimpleHTTPS.hs b/src/Happstack/Server/SimpleHTTPS.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/SimpleHTTPS.hs @@ -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))