diff --git a/snap-server.cabal b/snap-server.cabal --- a/snap-server.cabal +++ b/snap-server.cabal @@ -1,5 +1,5 @@ name: snap-server -version: 0.9.4.5 +version: 0.9.4.6 synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework description: Snap is a simple and fast web development framework and server written in @@ -101,11 +101,11 @@ enumerator >= 0.4.15 && < 0.5, MonadCatchIO-transformers >= 0.2.1 && < 0.4, mtl >= 2 && < 3, - network >= 2.3 && < 2.6, + network >= 2.3 && < 2.7, old-locale, snap-core >= 0.9.3 && < 0.10, - text >= 0.11 && < 1.2, - time >= 1.0 && < 1.5, + text >= 0.11 && < 1.3, + time >= 1.0 && < 1.6, unix-compat >= 0.2 && < 0.5 extensions: @@ -129,7 +129,7 @@ if flag(openssl) cpp-options: -DOPENSSL - build-depends: HsOpenSSL >= 0.10 && <0.11 + build-depends: HsOpenSSL >= 0.10 && <0.12 if os(linux) && !flag(portable) cpp-options: -DLINUX -DHAS_SENDFILE diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -119,11 +119,12 @@ listeners conf = catMaybes [ httpListener, httpsListener ] where httpsListener = do - b <- getSSLBind conf - p <- getSSLPort conf - cert <- getSSLCert conf - key <- getSSLKey conf - return $! Int.HttpsPort b p cert key + b <- getSSLBind conf + p <- getSSLPort conf + cert <- getSSLCert conf + chainCert <- getSSLChainCert conf + key <- getSSLKey conf + return $! Int.HttpsPort b p cert chainCert key httpListener = do p <- getPort conf diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -32,6 +32,7 @@ , getSSLBind , getSSLCert , getSSLKey + , getSSLChainCert , getSSLPort , getVerbose , getStartupHook @@ -50,6 +51,7 @@ , setSSLBind , setSSLCert , setSSLKey + , setSSLChainCert , setSSLPort , setVerbose , setStartupHook diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs --- a/src/Snap/Internal/Http/Server.hs +++ b/src/Snap/Internal/Http/Server.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -46,7 +47,9 @@ import Prelude hiding (catch) #endif import System.IO +#if !MIN_VERSION_time(1,5,0) import System.Locale +#endif ------------------------------------------------------------------------------ import Snap.Internal.Debug import Snap.Internal.Exceptions (EscapeHttpException (..)) @@ -95,15 +98,15 @@ data ListenPort = -- (bind address, port) HttpPort ByteString Int | - -- (bind address, port, path to certificate, path to key) - HttpsPort ByteString Int FilePath FilePath + -- (bind address, port, path to certificate, whether certificate is a complete chain, path to key) + HttpsPort ByteString Int FilePath Bool FilePath ------------------------------------------------------------------------------ instance Show ListenPort where show (HttpPort b p ) = concat [ "http://" , SC.unpack b, ":", show p, "/" ] - show (HttpsPort b p _ _) = + show (HttpsPort b p _ _ _) = concat [ "https://", SC.unpack b, ":", show p, "/" ] @@ -166,13 +169,7 @@ , Handler otherException ] -------------------------------------------------------------------------- - sslException (e :: TLS.TLSException) = do - let msg = SC.concat [ - "This version of snap-server was not built with SSL " - , "support.\n" - , "Please compile snap-server with -fopenssl to enable it." - ] - + sslException (e@(TLS.TLSException msg)) = do logE elog' msg SC.hPutStrLn stderr msg throw e @@ -196,7 +193,7 @@ logE elog $ S.concat [ "Server.httpServe: START, binding to " , bshow ports ] - let isHttps p = case p of { (HttpsPort _ _ _ _) -> True; _ -> False;} + let isHttps p = case p of { (HttpsPort _ _ _ _ _) -> True; _ -> False;} let initHttps = foldr (\p b -> b || isHttps p) False ports if initHttps @@ -219,8 +216,8 @@ -------------------------------------------------------------------------- bindPort (HttpPort baddr port ) = bindHttp baddr port - bindPort (HttpsPort baddr port cert key) = - TLS.bindHttps baddr port cert key + bindPort (HttpsPort baddr port cert chainCert key) = + TLS.bindHttps baddr port cert chainCert key ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs --- a/src/Snap/Internal/Http/Server/Config.hs +++ b/src/Snap/Internal/Http/Server/Config.hs @@ -87,6 +87,7 @@ , sslport :: Maybe Int , sslbind :: Maybe ByteString , sslcert :: Maybe FilePath + , sslchaincert :: Maybe Bool , sslkey :: Maybe FilePath , compression :: Maybe Bool , verbose :: Maybe Bool @@ -125,6 +126,7 @@ , "sslport: " ++ _sslport , "sslbind: " ++ _sslbind , "sslcert: " ++ _sslcert + , "sslchaincert: " ++ _sslchaincert , "sslkey: " ++ _sslkey , "compression: " ++ _compression , "verbose: " ++ _verbose @@ -143,6 +145,7 @@ _sslport = show $ sslport c _sslbind = show $ sslbind c _sslcert = show $ sslcert c + _sslchaincert = show $ sslchaincert c _sslkey = show $ sslkey c _compression = show $ compression c _verbose = show $ verbose c @@ -170,6 +173,7 @@ , sslport = Nothing , sslbind = Nothing , sslcert = Nothing + , sslchaincert = Nothing , sslkey = Nothing , compression = Nothing , verbose = Nothing @@ -191,6 +195,7 @@ , sslport = ov sslport , sslbind = ov sslbind , sslcert = ov sslcert + , sslchaincert = ov sslchaincert , sslkey = ov sslkey , compression = ov compression , verbose = ov verbose @@ -219,6 +224,7 @@ , bind = Just "0.0.0.0" , sslbind = Just "0.0.0.0" , sslcert = Just "cert.pem" + , sslchaincert = Just False , sslkey = Just "key.pem" , defaultTimeout = Just 60 } @@ -266,6 +272,10 @@ getSSLCert :: Config m a -> Maybe FilePath getSSLCert = sslcert +-- | Path to the SSL certificate file +getSSLChainCert :: Config m a -> Maybe Bool +getSSLChainCert = sslchaincert + -- | Path to the SSL key file getSSLKey :: Config m a -> Maybe FilePath getSSLKey = sslkey @@ -330,6 +340,9 @@ setSSLCert :: FilePath -> Config m a -> Config m a setSSLCert x c = c { sslcert = Just x } +setSSLChainCert :: Bool -> Config m a -> Config m a +setSSLChainCert x c = c { sslchaincert = Just x } + setSSLKey :: FilePath -> Config m a -> Config m a setSSLKey x c = c { sslkey = Just x } @@ -443,6 +456,12 @@ , Option [] ["ssl-cert"] (ReqArg (\s -> Just $ mempty { sslcert = Just s}) "PATH") $ "path to ssl certificate in PEM format" ++ defaultO sslcert + , Option [] ["ssl-chain-cert"] + (NoArg $ Just $ setConfig setSSLChainCert True) + $ "certificate file contains complete certificate chain" ++ defaultB sslchaincert "site certificate only" "complete certificate chain" + , Option [] ["no-ssl-chain-cert"] + (NoArg $ Just $ setConfig setSSLChainCert False) + $ "certificate file contains only the site certificate" ++ defaultB sslchaincert "site certificate only" "complete certificate chain" , Option [] ["ssl-key"] (ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH") $ "path to ssl private key in PEM format" ++ defaultO sslkey @@ -496,7 +515,7 @@ conf = defaultConfig `mappend` defaults defaultB f y n = maybe "" (\b -> ", default " ++ if b then y - else n) $ f conf + else n) $ f conf :: String defaultC f = maybe "" ((", default " ++) . show) $ f conf defaultO f = maybe ", default off" ((", default " ++) . show) $ f conf diff --git a/src/Snap/Internal/Http/Server/TLS.hs b/src/Snap/Internal/Http/Server/TLS.hs --- a/src/Snap/Internal/Http/Server/TLS.hs +++ b/src/Snap/Internal/Http/Server/TLS.hs @@ -6,7 +6,7 @@ ------------------------------------------------------------------------------ module Snap.Internal.Http.Server.TLS - ( TLSException + ( TLSException (..) , initTLS , stopTLS , bindHttps @@ -22,10 +22,10 @@ import Data.ByteString.Char8 (ByteString) import Data.Dynamic import Foreign.C +import qualified Data.ByteString.Char8 as S ------------------------------------------------------------------------------ #ifdef OPENSSL import Control.Monad -import qualified Data.ByteString.Char8 as S import qualified Network.Socket as Socket import Network.Socket hiding ( accept , shutdown @@ -46,15 +46,23 @@ ------------------------------------------------------------------------------ -data TLSException = TLSException String +data TLSException = TLSException S.ByteString deriving (Show, Typeable) instance Exception TLSException #ifndef OPENSSL ------------------------------------------------------------------------------ +sslNotSupportedException :: TLSException +sslNotSupportedException = TLSException $ S.concat [ + "This version of snap-server was not built with SSL " + , "support.\n" + , "Please compile snap-server with -fopenssl to enable it." + ] + +------------------------------------------------------------------------------ initTLS :: IO () -initTLS = throwIO $ TLSException "TLS is not supported" +initTLS = throwIO sslNotSupportedException ------------------------------------------------------------------------------ @@ -63,8 +71,8 @@ ------------------------------------------------------------------------------ -bindHttps :: ByteString -> Int -> FilePath -> FilePath -> IO ListenSocket -bindHttps _ _ _ _ = throwIO $ TLSException "TLS is not supported" +bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath -> IO ListenSocket +bindHttps _ _ _ _ _ = throwIO sslNotSupportedException ------------------------------------------------------------------------------ @@ -74,7 +82,7 @@ ------------------------------------------------------------------------------ createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession -createSession _ _ _ _ = throwIO $ TLSException "TLS is not supported" +createSession _ _ _ _ = throwIO sslNotSupportedException ------------------------------------------------------------------------------ @@ -89,7 +97,7 @@ ------------------------------------------------------------------------------ recv :: IO b -> NetworkSession -> IO (Maybe ByteString) -recv _ _ = throwIO $ TLSException "TLS is not supported" +recv _ _ = throwIO sslNotSupportedException #else @@ -107,9 +115,10 @@ bindHttps :: ByteString -> Int -> FilePath + -> Bool -> FilePath -> IO ListenSocket -bindHttps bindAddress bindPort cert key = do +bindHttps bindAddress bindPort cert chainCert key = do (family, addr) <- getSockAddr bindPort bindAddress sock <- Socket.socket family Socket.Stream 0 @@ -119,7 +128,9 @@ ctx <- context contextSetPrivateKeyFile ctx key - contextSetCertificateFile ctx cert + if chainCert + then contextSetCertificateChainFile ctx cert + else contextSetCertificateFile ctx cert contextSetDefaultCiphers ctx certOK <- contextCheckPrivateKey ctx @@ -127,8 +138,8 @@ return $! ListenHttps sock ctx where - certificateError = "OpenSSL says that the certificate " ++ - "doesn't match the private key!" + certificateError = + "OpenSSL says that the certificate doesn't match the private key!" ------------------------------------------------------------------------------