snap-server 0.9.4.5 → 0.9.4.6
raw patch · 6 files changed
+66/−36 lines, 6 filesdep ~timePVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependency ranges changed: time
API changes (from Hackage documentation)
+ Snap.Http.Server.Config: getSSLChainCert :: Config m a -> Maybe Bool
+ Snap.Http.Server.Config: setSSLChainCert :: Bool -> Config m a -> Config m a
Files
- snap-server.cabal +5/−5
- src/Snap/Http/Server.hs +6/−5
- src/Snap/Http/Server/Config.hs +2/−0
- src/Snap/Internal/Http/Server.hs +10/−13
- src/Snap/Internal/Http/Server/Config.hs +20/−1
- src/Snap/Internal/Http/Server/TLS.hs +23/−12
snap-server.cabal view
@@ -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
src/Snap/Http/Server.hs view
@@ -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
src/Snap/Http/Server/Config.hs view
@@ -32,6 +32,7 @@ , getSSLBind , getSSLCert , getSSLKey+ , getSSLChainCert , getSSLPort , getVerbose , getStartupHook@@ -50,6 +51,7 @@ , setSSLBind , setSSLCert , setSSLKey+ , setSSLChainCert , setSSLPort , setVerbose , setStartupHook
src/Snap/Internal/Http/Server.hs view
@@ -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 ------------------------------------------------------------------------------
src/Snap/Internal/Http/Server/Config.hs view
@@ -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
src/Snap/Internal/Http/Server/TLS.hs view
@@ -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!" ------------------------------------------------------------------------------