Expose set ssl ciphers

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,

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

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

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

src/Snap/Internal/Http/Server/TLS.hs

@@ -25,15 +25,15 @@ 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
 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

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

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