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-cryptonite.cabal b/happstack-server-tls-cryptonite.cabal new file mode 100644 --- /dev/null +++ b/happstack-server-tls-cryptonite.cabal @@ -0,0 +1,38 @@ +Name: happstack-server-tls-cryptonite +Version: 0.1.1 +Synopsis: Extend happstack-server with native HTTPS support (TLS/SSL) +Description: Extend happstack-server with native HTTPS support (TLS/SSL) +License: BSD3 +Author: Andrey Sverdlichenko +Maintainer: blaze@ruddy.ru +Copyright: 2012 Jeremy Shaw, 2015 Andrey Sverdlichenko +Category: Web, Happstack +Build-type: Simple +Cabal-version: >=1.6 + +source-repository head + type: git + location: https://github.com/rblaze/happstack-server-tls-cryptonite.git + +Library + hs-source-dirs: src + ghc-options: -W -Wall -fno-warn-unused-do-bind + Exposed-modules: Happstack.Server.Internal.Cryptonite.TimeoutSocketTLS + Happstack.Server.Internal.Cryptonite.TLS + Happstack.Server.SimpleTLS + + Build-Depends: base < 5, + bytestring >= 0.9 && < 0.11, + cryptonite >= 0.6, + data-default-class >= 0.0.1, + extensible-exceptions == 0.1.*, + happstack-server >= 6.6.4 && < 7.5, + hslogger >= 1.1 && < 1.3, + network >= 2.3 && < 2.7, + sendfile == 0.7.*, + time >= 1.2 && < 1.6, + tls >= 1.2 + + if !os(windows) + Build-Depends: unix + cpp-options: -DUNIX diff --git a/src/Happstack/Server/Internal/Cryptonite/TLS.hs b/src/Happstack/Server/Internal/Cryptonite/TLS.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Cryptonite/TLS.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{- | core functions and types for HTTPS support +-} +module Happstack.Server.Internal.Cryptonite.TLS where + +import Control.Concurrent (forkIO, killThread, myThreadId) +import Control.Exception.Extensible as E +import Control.Monad (forever, when) +import Crypto.Random.EntropyPool +import Data.Default.Class +import Data.Time (UTCTime) +import GHC.IO.Exception (IOErrorType(..)) +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.Cryptonite.TimeoutSocketTLS as TSS +import Happstack.Server.Internal.Types (Request, Response) +import Network.Socket (HostName, PortNumber, Socket, sClose, socketPort) +import Network.TLS +import Network.TLS.Extra.Cipher +import Happstack.Server.Types (LogAccess, logMAccess) +import System.IO.Error (ioeGetErrorType, isFullError, isDoesNotExistError) +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 + , 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 + } + +-- | a partially complete 'TLSConf' . You must sete 'tlsCert' and 'tlsKey' at a mininum. +nullTLSConf :: TLSConf +nullTLSConf = + TLSConf { tlsPort = 443 + , tlsCert = "" + , tlsKey = "" + , tlsCA = Nothing + , 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 :: ServerParams + } + +-- | generate the 'HTTPS' record needed to start the https:\/\/ event loop +-- +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 = + do creds <- credentialLoadX509 cert key + let credentials = either (\msg -> error $ "Can't load certificate " ++ cert ++ " and key " ++ key ++ ": " ++ msg) id creds + let params = def { + serverSupported = def { supportedCiphers = ciphersuite_strong }, + serverShared = def { + sharedCredentials = Credentials [credentials] + } + } +-- case mca of +-- Nothing -> return () +-- (Just ca) -> SSL.contextSetCAFile ctx ca + + return (HTTPS socket params) + +-- | accept a TLS connection +acceptTLS :: Socket -- ^ the socket returned from 'acceptLite' + -> ServerParams + -> IO Context +acceptTLS sck params = + handle (\ (e :: SomeException) -> sClose sck >> throwIO e) $ do + ssl <- contextNew sck params + handshake ssl + return ssl + +-- | 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 + tlsSocket <- listenOn (tlsPort tlsConf) + https <- httpsOnSocket (tlsCert tlsConf) (tlsKey tlsConf) (tlsCA tlsConf) tlsSocket + listenTLS' (tlsTimeout tlsConf) (tlsLogAccess tlsConf) 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) -> HTTPS -> (Request -> IO Response) -> IO () +listenTLS' timeout mlog https@(HTTPS lsocket _) handler = do +#ifndef mingw32_HOST_OS + installHandler openEndedPipe Ignore Nothing +#endif + tm <- initialize (timeout * (10^(6 :: Int))) + do let work :: (Socket, Context, HostName, PortNumber) -> IO () + work (socket, ssl, hn, p) = + do -- add this thread to the timeout table + tid <- myThreadId + thandle <- register tm $ do shutdownClose socket ssl + killThread tid + -- handle the request + let timeoutIO = TSS.timeoutSocketIO thandle socket ssl + + request timeoutIO mlog (hn, fromIntegral p) handler + `E.catches` [ Handler ignoreConnectionAbruptlyTerminated + , Handler ehs + ] + + -- remove thread from timeout table + cancel thandle + + -- close connection + shutdownClose socket ssl + + loop :: IO () + 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 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 -> Context -> IO () + shutdownClose _ ssl = + do bye ssl `E.catch` ignoreException + contextClose ssl `E.catch` ignoreException + + -- exception handlers + ignoreConnectionAbruptlyTerminated :: TLSException -> IO () -- FIXME + ignoreConnectionAbruptlyTerminated _ = return () + + ignoreSSLException :: TLSException -> IO () + ignoreSSLException _ = return () + + ignoreException :: SomeException -> IO () + ignoreException _ = 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 $ ignoreSSLException + , Handler $ \(e :: ArithException) -> h (toException e) + , Handler $ \(e :: ArrayException) -> h (toException e) + , 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 log' ERROR ("HTTPS accept loop ignoring " ++ show e) + ] + isResourceVanishedError :: IOException -> Bool + isResourceVanishedError = isResourceVanishedType . ioeGetErrorType + isResourceVanishedType :: IOErrorType -> Bool + isResourceVanishedType ResourceVanished = True + isResourceVanishedType _ = False diff --git a/src/Happstack/Server/Internal/Cryptonite/TimeoutSocketTLS.hs b/src/Happstack/Server/Internal/Cryptonite/TimeoutSocketTLS.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/Internal/Cryptonite/TimeoutSocketTLS.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{- | +-- borrowed from snap-server. Check there periodically for updates. +-} +module Happstack.Server.Internal.Cryptonite.TimeoutSocketTLS where + +import Control.Exception (SomeException, catch) +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) +import Network.Socket.SendFile (ByteCount, Offset) +import Network.TLS +import System.IO (IOMode(ReadMode), SeekMode(AbsoluteSeek), hSeek, withBinaryFile) +import System.IO.Unsafe (unsafeInterleaveIO) + +sPutLazyTickle :: TM.Handle -> Context -> L.ByteString -> IO () +sPutLazyTickle thandle ssl cs = + do L.foldrChunks (\c rest -> sendData ssl (L.fromStrict c) >> TM.tickle thandle >> rest) (return ()) cs +{-# INLINE sPutLazyTickle #-} + +sPutTickle :: TM.Handle -> Context -> B.ByteString -> IO () +sPutTickle thandle ssl cs = + do sendData ssl (L.fromStrict cs) + TM.tickle thandle +{-# INLINE sPutTickle #-} + +sGetContents :: TM.Handle + -> Context -- ^ Connected socket + -> IO L.ByteString -- ^ Data received +sGetContents handle ssl = + fmap L.fromChunks loop + where + loop = unsafeInterleaveIO $ do + s <- recvData ssl + TM.tickle handle + if S.null s + then do return [] + else do ss <- loop + return (s:ss) + +timeoutSocketIO :: TM.Handle -> Socket -> Context -> TimeoutIO +timeoutSocketIO handle _ ssl = + TimeoutIO { toHandle = handle + , toShutdown = do bye ssl `catch` ignoreException + contextClose ssl `catch` ignoreException + , toPutLazy = sPutLazyTickle handle ssl + , toPut = sPutTickle handle ssl + , toGetContents = sGetContents handle ssl + , toSendFile = sendFileTickle handle ssl + , toSecure = True + } + where + ignoreException :: SomeException -> IO () + ignoreException _ = return () + +sendFileTickle :: TM.Handle -> Context -> 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/SimpleTLS.hs b/src/Happstack/Server/SimpleTLS.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/Server/SimpleTLS.hs @@ -0,0 +1,30 @@ +module Happstack.Server.SimpleTLS + ( TLSConf(..) + , nullTLSConf + , simpleHTTPS + , simpleHTTPS' + ) where + +import Data.Maybe (fromMaybe) +import Happstack.Server (ToMessage(..), UnWebT, ServerPartT, simpleHTTP'', mapServerPartT, runValidator) +import Happstack.Server.Internal.Cryptonite.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))