diff --git a/snap-server.cabal b/snap-server.cabal index bf5e582e..d5146117 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -220,7 +220,7 @@ Test-suite testsuite clock, containers, directory >= 1.1 && < 1.4, - filepath, + filepath >= 1.1 && < 2.0, io-streams, io-streams-haproxy, lifted-base, @@ -506,6 +506,7 @@ Executable snap-test-server clock, containers, directory, + filepath >= 1.1 && < 2.0, io-streams, io-streams-haproxy, lifted-base, diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs index 620fa8c2..d41c67f4 100644 --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -219,7 +219,7 @@ listeners conf = TLS.withTLS $ do , b , ":" , bshow p ], - do (sock, ctx) <- TLS.bindHttps b p cert chainCert key + do (sock, ctx) <- TLS.bindHttps b p cert chainCert key (getSSLCiphers conf) return (sock, TLS.httpsAcceptFunc sock ctx) ) httpListener = do diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index c163f607..033c1370 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -32,6 +32,7 @@ module Snap.Http.Server.Config , getSSLKey , getSSLChainCert , getSSLPort + , getSSLCiphers , getVerbose , getStartupHook , getUnixSocket @@ -53,6 +54,7 @@ module Snap.Http.Server.Config , setSSLKey , setSSLChainCert , setSSLPort + , setSSLCiphers , setVerbose , setUnixSocket , setUnixSocketAccessMode diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs index 73b31c34..71c0d99c 100644 --- a/src/Snap/Internal/Http/Server/Config.hs +++ b/src/Snap/Internal/Http/Server/Config.hs @@ -39,6 +39,7 @@ module Snap.Internal.Http.Server.Config , getSSLChainCert , getSSLKey , getSSLPort + , getSSLCiphers , getVerbose , getStartupHook , getUnixSocket @@ -60,6 +61,7 @@ module Snap.Internal.Http.Server.Config , setSSLChainCert , setSSLKey , setSSLPort + , setSSLCiphers , setVerbose , setUnixSocket , setUnixSocketAccessMode @@ -212,6 +214,7 @@ data Config m a = Config , sslcert :: Maybe FilePath , sslchaincert :: Maybe Bool , sslkey :: Maybe FilePath + , sslCiphers :: Maybe String , unixsocket :: Maybe FilePath , unixaccessmode :: Maybe Int , compression :: Maybe Bool @@ -251,6 +254,7 @@ instance Show (Config m a) where , "sslcert: " ++ _sslcert , "sslchaincert: " ++ _sslchaincert , "sslkey: " ++ _sslkey + , "sslCiphers: " ++ _sslCiphers , "unixsocket: " ++ _unixsocket , "unixaccessmode: " ++ _unixaccessmode , "compression: " ++ _compression @@ -271,6 +275,7 @@ instance Show (Config m a) where _sslcert = show $ sslcert c _sslchaincert = show $ sslchaincert c _sslkey = show $ sslkey c + _sslCiphers = show $ sslCiphers c _compression = show $ compression c _verbose = show $ verbose c _defaultTimeout = show $ defaultTimeout c @@ -302,6 +307,7 @@ instance Semigroup (Config m a) where , sslcert = ov sslcert , sslchaincert = ov sslchaincert , sslkey = ov sslkey + , sslCiphers = ov sslCiphers , unixsocket = ov unixsocket , unixaccessmode = ov unixaccessmode , compression = ov compression @@ -330,6 +336,7 @@ instance Monoid (Config m a) where , sslcert = Nothing , sslchaincert = Nothing , sslkey = Nothing + , sslCiphers = Nothing , unixsocket = Nothing , unixaccessmode = Nothing , compression = Nothing @@ -361,6 +368,7 @@ defaultConfig = mempty , sslbind = Nothing , sslcert = Nothing , sslkey = Nothing + , sslCiphers = Nothing , sslchaincert = Nothing , defaultTimeout = Just 60 } @@ -416,6 +424,10 @@ getSSLChainCert = sslchaincert getSSLKey :: Config m a -> Maybe FilePath getSSLKey = sslkey +-- | The list of ciphers, as understood by OPENSSL +getSSLCiphers :: Config m a -> Maybe String +getSSLCiphers = sslCiphers + -- | File path to unix socket. Must be absolute path, but allows for symbolic -- links. getUnixSocket :: Config m a -> Maybe FilePath @@ -497,6 +509,9 @@ setSSLChainCert x c = c { sslchaincert = Just x } setSSLKey :: FilePath -> Config m a -> Config m a setSSLKey x c = c { sslkey = Just x } +setSSLCiphers :: String -> Config m a -> Config m a +setSSLCiphers x c = c { sslCiphers = Just x } + setUnixSocket :: FilePath -> Config m a -> Config m a setUnixSocket x c = c { unixsocket = Just x } @@ -566,6 +581,7 @@ completeConfig config = do sslVals = map ($ cfg) [ isJust . getSSLPort , isJust . getSSLBind , isJust . getSSLKey + , isJust . getSSLCiphers , isJust . getSSLCert ] sslValid = and sslVals @@ -621,6 +637,9 @@ optDescrs defaults = , Option [] ["ssl-key"] (ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH") $ "path to ssl private key in PEM format" ++ defaultO sslkey + , Option [] ["ssl-ciphers"] + (ReqArg (\s -> Just $ mempty { sslCiphers = Just s}) "CIPHER-LIST") + $ "list of ciphers as understood by openssl" ++ defaultO sslCiphers , Option "" ["access-log"] (ReqArg (Just . setConfig setAccessLog . ConfigFileLog) "PATH") $ "access log" ++ defaultC getAccessLog diff --git a/src/Snap/Internal/Http/Server/TLS.hs b/src/Snap/Internal/Http/Server/TLS.hs index 551966f5..3151fe7f 100644 --- a/src/Snap/Internal/Http/Server/TLS.hs +++ b/src/Snap/Internal/Http/Server/TLS.hs @@ -25,7 +25,7 @@ import qualified Network.Socket as Socket import OpenSSL (withOpenSSL) import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL.Session as SSL -import Prelude (Bool, FilePath, IO, Int, Maybe (..), Monad (..), Show, flip, fromIntegral, fst, not, ($), ($!), (.)) +import Prelude (Bool, FilePath, IO, Int, String, Maybe (..), Monad (..), Show, flip, fromIntegral, fst, not, ($), ($!), (.)) import Snap.Internal.Http.Server.Address (getAddress, getSockAddr) import Snap.Internal.Http.Server.Socket (acceptAndInitialize) import qualified System.IO.Streams as Streams @@ -33,7 +33,7 @@ import qualified System.IO.Streams.SSL as SStreams #else import Control.Exception (Exception, throwIO) -import Prelude (Bool, FilePath, IO, Int, Show, id, ($)) +import Prelude (Bool, FilePath, IO, Int, String, Maybe (..), Show, id, ($)) #endif ------------------------------------------------------------------------------ import Snap.Internal.Http.Server.Types (AcceptFunc (..), SendFileHandler) @@ -67,9 +67,9 @@ barf = throwIO sslNotSupportedException ------------------------------------------------------------------------------ -bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath +bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath -> Maybe String -> IO (Socket, SSLContext) -bindHttps _ _ _ _ _ = barf +bindHttps _ _ _ _ _ _ = barf ------------------------------------------------------------------------------ @@ -94,8 +94,9 @@ bindHttps :: ByteString -> FilePath -> Bool -> FilePath + -> Maybe String -> IO (Socket, SSLContext) -bindHttps bindAddress bindPort cert chainCert key = +bindHttps bindAddress bindPort cert chainCert key maybeCiphers = withTLS $ bracketOnError (do (family, addr) <- getSockAddr bindPort bindAddress @@ -105,11 +106,16 @@ bindHttps bindAddress bindPort cert chainCert key = (Socket.close . fst) $ \(sock, addr) -> do Socket.setSocketOption sock Socket.ReuseAddr 1 - Socket.bindSocket sock addr + Socket.bind sock addr Socket.listen sock 150 ctx <- SSL.context SSL.contextSetPrivateKeyFile ctx key + case maybeCiphers of + Just ciphers -> + SSL.contextSetCiphers ctx ciphers + Nothing -> + SSL.contextSetDefaultCiphers ctx if chainCert then SSL.contextSetCertificateChainFile ctx cert else SSL.contextSetCertificateFile ctx cert diff --git a/test/Snap/Internal/Http/Server/Session/Tests.hs b/test/Snap/Internal/Http/Server/Session/Tests.hs index 0e8f34b7..4b0a324c 100644 --- a/test/Snap/Internal/Http/Server/Session/Tests.hs +++ b/test/Snap/Internal/Http/Server/Session/Tests.hs @@ -112,9 +112,9 @@ testTLSKeyMismatch = testCase "session/tls-key-mismatch" $ do testCoverTLSStubs :: Test testCoverTLSStubs = testCase "session/tls-stubs" $ do expectException $ TLS.bindHttps "127.0.0.1" 9999 - "test/cert.pem" False "test/key.pem" + "test/cert.pem" False "test/key.pem" Nothing expectException $ TLS.bindHttps "127.0.0.1" 9999 - "test/cert.pem" True "test/key.pem" + "test/cert.pem" True "test/key.pem" Nothing let (AcceptFunc afunc) = TLS.httpsAcceptFunc undefined undefined expectException $ mask $ \restore -> afunc restore let u = undefined diff --git a/test/Test/Blackbox.hs b/test/Test/Blackbox.hs index d54f1620..1646e8dd 100644 --- a/test/Test/Blackbox.hs +++ b/test/Test/Blackbox.hs @@ -139,6 +139,7 @@ startTestSocketServer serverType = do "test/cert.pem" False "test/key.pem" + Nothing #ifdef OPENSSL -- Set client code not to verify HTTP.modifyContextSSL $ \ctx -> do