diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 3.1.0 + +* Supporting HTTP/2 [#399](https://github.com/yesodweb/wai/pull/399) +* Removing RC4 [#400](https://github.com/yesodweb/wai/issues/400) + ## 3.0.4.2 * tls 1.3 support [#390](https://github.com/yesodweb/wai/issues/390) diff --git a/Network/Wai/Handler/WarpTLS.hs b/Network/Wai/Handler/WarpTLS.hs --- a/Network/Wai/Handler/WarpTLS.hs +++ b/Network/Wai/Handler/WarpTLS.hs @@ -4,25 +4,33 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} --- | HTTP over SSL/TLS support for Warp via the TLS package. +-- | HTTP over TLS support for Warp via the TLS package. +-- +-- If HTTP\/2 is negotiated by ALPN, HTTP\/2 over TLS is used. +-- Otherwise HTTP\/1.1 over TLS is used. +-- +-- Support for SSL is now obsoleted. module Network.Wai.Handler.WarpTLS ( -- * Settings TLSSettings + , defaultTlsSettings + -- * Smart constructors + , tlsSettings + , tlsSettingsMemory + , tlsSettingsChain + , tlsSettingsChainMemory + -- * Accessors , certFile , keyFile - , onInsecure , tlsLogging , tlsAllowedVersions , tlsCiphers , tlsWantClientCert , tlsServerHooks - , defaultTlsSettings - , tlsSettings - , tlsSettingsMemory - , tlsSettingsChain - , tlsSettingsChainMemory + , onInsecure , OnInsecure (..) -- * Runner , runTLS @@ -31,31 +39,30 @@ , WarpTLSException (..) ) where -import qualified Network.TLS as TLS -import Network.Wai.Handler.Warp -import Network.Wai (Application) -import Network.Socket (Socket, sClose, withSocketsDo, SockAddr, accept) +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative ((<$>)) +#endif +import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException) +import Control.Monad (void) +import qualified Crypto.Random.AESCtr import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Control.Exception (bracket, finally, handle, fromException, try, IOException, onException) -import qualified Network.TLS.Extra as TLSExtra -import qualified Data.ByteString as B -import Data.Streaming.Network (bindPortTCP, safeRecv) -import Control.Applicative ((<$>)) +import Data.Default.Class (def) import qualified Data.IORef as I -import Control.Exception (Exception, throwIO) +import Data.Streaming.Network (bindPortTCP, safeRecv) import Data.Typeable (Typeable) -import Data.Default.Class (def) -import qualified Crypto.Random.AESCtr -import Network.Wai.Handler.Warp.Buffer (allocateBuffer, bufferSize, freeBuffer) +import Network.Socket (Socket, sClose, withSocketsDo, SockAddr, accept) import Network.Socket.ByteString (sendAll) -import Control.Monad (unless, void) -import Data.ByteString.Lazy.Internal (defaultChunkSize) -import qualified System.IO as IO +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLSExtra +import Network.Wai (Application) +import Network.Wai.Handler.Warp +import Network.Wai.Handler.Warp.Internal import System.IO.Error (isEOFError) ---------------------------------------------------------------- +-- | Settings for WarpTLS. data TLSSettings = TLSSettings { certFile :: FilePath -- ^ File containing the certificate. @@ -67,9 +74,11 @@ , chainCertsMemory :: [S.ByteString] , keyMemory :: Maybe S.ByteString , onInsecure :: OnInsecure - -- ^ Do we allow insecure connections with this server as well? Default - -- is a simple text response stating that a secure connection is required. + -- ^ Do we allow insecure connections with this server as well? -- + -- >>> onInsecure defaultTlsSettings + -- DenyInsecure "This server only accepts secure HTTPS connections." + -- -- Since 1.4.0 , tlsLogging :: TLS.Logging -- ^ The level of logging to turn on. @@ -80,13 +89,15 @@ , tlsAllowedVersions :: [TLS.Version] -- ^ The TLS versions this server accepts. -- - -- Default: '[TLS.TLS10,TLS.TLS11,TLS.TLS12]'. + -- >>> tlsAllowedVersions defaultTlsSettings + -- [TLS12,TLS11,TLS10] -- -- Since 1.4.2 , tlsCiphers :: [TLS.Cipher] -- ^ The TLS ciphers this server accepts. -- - -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSEtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]' + -- >>> tlsCiphers defaultTlsSettings + -- [ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256-SHA256,DHE-RSA-AES128-SHA256,DHE-RSA-AES256-SHA1,DHE-RSA-AES128-SHA1,DHE-DSA-AES128-SHA1,DHE-DSA-AES256-SHA1,RSA-aes128-sha1,RSA-aes256-sha1] -- -- Since 1.4.2 , tlsWantClientCert :: Bool @@ -94,7 +105,8 @@ -- is set to True, you must handle received certificates in a server hook -- or all connections will fail. -- - -- Default: False + -- >>> tlsWantClientCert defaultTlsSettings + -- False -- -- Since 3.0.2 , tlsServerHooks :: TLS.ServerHooks @@ -107,7 +119,7 @@ -- Since 3.0.2 } --- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name. +-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors). defaultTlsSettings :: TLSSettings defaultTlsSettings = TLSSettings { certFile = "certificate.pem" @@ -118,7 +130,7 @@ , keyMemory = Nothing , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections." , tlsLogging = def - , tlsAllowedVersions = [TLS.TLS10,TLS.TLS11,TLS.TLS12] + , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10] , tlsCiphers = ciphers , tlsWantClientCert = False , tlsServerHooks = def @@ -135,11 +147,8 @@ , TLSExtra.cipher_DHE_RSA_AES128_SHA1 , TLSExtra.cipher_DHE_DSS_AES128_SHA1 , TLSExtra.cipher_DHE_DSS_AES256_SHA1 - , TLSExtra.cipher_DHE_DSS_RC4_SHA1 , TLSExtra.cipher_AES128_SHA1 , TLSExtra.cipher_AES256_SHA1 - , TLSExtra.cipher_RC4_128_MD5 - , TLSExtra.cipher_RC4_128_SHA1 ] ---------------------------------------------------------------- @@ -147,10 +156,11 @@ -- | An action when a plain HTTP comes to HTTP over TLS/SSL port. data OnInsecure = DenyInsecure L.ByteString | AllowInsecure + deriving (Show) ---------------------------------------------------------------- --- | A smart constructor for 'TLSSettings'. +-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'. tlsSettings :: FilePath -- ^ Certificate file -> FilePath -- ^ Key file -> TLSSettings @@ -160,7 +170,7 @@ } -- | A smart constructor for 'TLSSettings' that allows specifying --- chain certificates. +-- chain certificates based on 'defaultTlsSettings'. -- -- Since 3.0.3 tlsSettingsChain @@ -175,7 +185,7 @@ } -- | A smart constructor for 'TLSSettings', but uses in-memory representations --- of the certificate and key +-- of the certificate and key based on 'defaultTlsSettings'. -- -- Since 3.0.1 tlsSettingsMemory @@ -188,7 +198,7 @@ } -- | A smart constructor for 'TLSSettings', but uses in-memory representations --- of the certificate and key +-- of the certificate and key based on 'defaultTlsSettings'. -- -- Since 3.0.3 tlsSettingsChainMemory @@ -235,18 +245,45 @@ runSettingsConnectionMakerSecure set get app where get = getter tlsset sock params - params = def { + params = TLS.ServerParams { TLS.serverWantClientCert = tlsWantClientCert - , TLS.serverSupported = def { - TLS.supportedVersions = tlsAllowedVersions - , TLS.supportedCiphers = tlsCiphers - } - , TLS.serverShared = def { - TLS.sharedCredentials = TLS.Credentials [credential] - } - , TLS.serverHooks = tlsServerHooks + , TLS.serverCACertificates = [] + , TLS.serverDHEParams = Nothing + , TLS.serverHooks = hooks + , TLS.serverShared = shared + , TLS.serverSupported = supported } + -- Adding alpn to user's tlsServerHooks. + hooks = tlsServerHooks { + TLS.onALPNClientSuggest = Just alpn + } + shared = def { + TLS.sharedCredentials = TLS.Credentials [credential] + } + supported = TLS.Supported { + TLS.supportedVersions = tlsAllowedVersions + , TLS.supportedCiphers = tlsCiphers + , TLS.supportedCompressions = [TLS.nullCompression] + , TLS.supportedHashSignatures = [ + (TLS.HashSHA512, TLS.SignatureRSA) + , (TLS.HashSHA384, TLS.SignatureRSA) + , (TLS.HashSHA256, TLS.SignatureRSA) + , (TLS.HashSHA224, TLS.SignatureRSA) + , (TLS.HashSHA1, TLS.SignatureRSA) + , (TLS.HashSHA1, TLS.SignatureDSS) + ] + , TLS.supportedSecureRenegotiation = True + , TLS.supportedSession = True + } +alpn :: [S.ByteString] -> IO S.ByteString +alpn xs + | "h2" `elem` xs = return "h2" + | "h2-16" `elem` xs = return "h2-16" + | "h2-15" `elem` xs = return "h2-15" + | "h2-14" `elem` xs = return "h2-14" + | otherwise = return "http/1.1" + ---------------------------------------------------------------- getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr) @@ -257,79 +294,109 @@ mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport) mkConn tlsset s params = do firstBS <- safeRecv s 4096 - cachedRef <- I.newIORef firstBS - (if not (B.null firstBS) && B.head firstBS == 0x16 then - httpOverTls tlsset s cachedRef params + (if not (S.null firstBS) && S.head firstBS == 0x16 then + httpOverTls tlsset s firstBS params else - plainHTTP tlsset s cachedRef) `onException` sClose s + plainHTTP tlsset s firstBS) `onException` sClose s ---------------------------------------------------------------- -httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Transport) -httpOverTls TLSSettings{..} s cachedRef params = do +httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> S.ByteString -> params -> IO (Connection, Transport) +httpOverTls TLSSettings{..} s bs0 params = do + recvN <- makePlainReceiveN s bs0 #if MIN_VERSION_tls(1,3,0) - ctx <- TLS.contextNew backend params + ctx <- TLS.contextNew (backend recvN) params #else gen <- Crypto.Random.AESCtr.makeSystem - ctx <- TLS.contextNew backend params gen + ctx <- TLS.contextNew (backend recvN) params gen #endif TLS.contextHookSetLogging ctx tlsLogging TLS.handshake ctx - readBuf <- allocateBuffer bufferSize writeBuf <- allocateBuffer bufferSize + -- Creating a cache for leftover input data. + ref <- I.newIORef "" tls <- getTLSinfo ctx - return (conn ctx readBuf writeBuf, tls) + return (conn ctx writeBuf ref, tls) where - backend = TLS.Backend { + backend recvN = TLS.Backend { TLS.backendFlush = return () , TLS.backendClose = sClose s , TLS.backendSend = sendAll s - , TLS.backendRecv = recvTLS cachedRef s + , TLS.backendRecv = recvN } - conn ctx readBuf writeBuf = Connection { + conn ctx writeBuf ref = Connection { connSendMany = TLS.sendData ctx . L.fromChunks - , connSendAll = TLS.sendData ctx . L.fromChunks . return + , connSendAll = sendall , connSendFile = sendfile , connClose = close - , connRecv = recv - , connSendFileOverride = NotOverride - , connReadBuffer = readBuf + , connRecv = recv ref + , connRecvBuf = recvBuf ref , connWriteBuffer = writeBuf , connBufferSize = bufferSize } where - sendfile fp offset len tickle' headers = do - TLS.sendData ctx $ L.fromChunks headers - IO.withBinaryFile fp IO.ReadMode $ \h -> do - IO.hSeek h IO.AbsoluteSeek offset - loop h $ fromIntegral len - where - loop _ remaining | remaining <= 0 = return () - loop h remaining = do - bs <- B.hGetSome h defaultChunkSize - unless (B.null bs) $ do - let x = B.take remaining bs - TLS.sendData ctx $ L.fromChunks [x] - void $ tickle' -- This tickles the Timer. It MUST be called per chunk. - loop h $ remaining - B.length x + sendall = TLS.sendData ctx . L.fromChunks . return + sendfile fid offset len hook headers = + readSendFile writeBuf bufferSize sendall fid offset len hook headers - close = freeBuffer readBuf `finally` - freeBuffer writeBuf `finally` + close = freeBuffer writeBuf `finally` void (tryIO $ TLS.bye ctx) `finally` TLS.contextClose ctx - recv = handle onEOF go + -- TLS version of recv with a cache for leftover input data. + -- The cache is shared with recvBuf. + recv cref = do + cached <- I.readIORef cref + if cached /= "" then do + I.writeIORef cref "" + return cached + else + recv' + + -- TLS version of recv (decrypting) without a cache. + recv' = handle onEOF go where onEOF e - | Just TLS.Error_EOF <- fromException e = return B.empty - | Just ioe <- fromException e, isEOFError ioe = return B.empty | otherwise = throwIO e + | Just TLS.Error_EOF <- fromException e = return S.empty + | Just ioe <- fromException e, isEOFError ioe = return S.empty | otherwise = throwIO e go = do x <- TLS.recvData ctx - if B.null x then + if S.null x then go else return x + -- TLS version of recvBuf with a cache for leftover input data. + recvBuf cref buf siz = do + cached <- I.readIORef cref + (ret, leftover) <- fill cached buf siz recv' + I.writeIORef cref leftover + return ret + +fill :: S.ByteString -> Buffer -> BufSize -> Recv -> IO (Bool,S.ByteString) +fill bs0 buf0 siz0 recv + | siz0 <= len0 = do + let (bs, leftover) = S.splitAt siz0 bs0 + void $ copy buf0 bs + return (True, leftover) + | otherwise = do + buf <- copy buf0 bs0 + loop buf (siz0 - len0) + where + len0 = S.length bs0 + loop _ 0 = return (True, "") + loop buf siz = do + bs <- recv + let len = S.length bs + if len == 0 then return (False, "") + else if (len <= siz) then do + buf' <- copy buf bs + loop buf' (siz - len) + else do + let (bs1,bs2) = S.splitAt siz bs + void $ copy buf bs1 + return (True, bs2) + getTLSinfo :: TLS.Context -> IO Transport getTLSinfo ctx = do proto <- TLS.getNegotiatedProtocol ctx @@ -355,10 +422,11 @@ ---------------------------------------------------------------- -plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Transport) -plainHTTP TLSSettings{..} s cachedRef = case onInsecure of +plainHTTP :: TLSSettings -> Socket -> S.ByteString -> IO (Connection, Transport) +plainHTTP TLSSettings{..} s bs0 = case onInsecure of AllowInsecure -> do conn' <- socketConnection s + cachedRef <- I.newIORef bs0 let conn'' = conn' { connRecv = recvPlain cachedRef (connRecv conn') } @@ -371,36 +439,16 @@ ---------------------------------------------------------------- -recvTLS :: I.IORef B.ByteString -> Socket -> Int -> IO B.ByteString -recvTLS cachedRef s size = do - cached <- I.readIORef cachedRef - loop cached - where - loop bs | B.length bs >= size = do - let (x, y) = B.splitAt size bs - I.writeIORef cachedRef y - return x - loop bs1 = do - bs2 <- safeRecv s 4096 - if B.null bs2 then do - -- FIXME does this deserve an exception being thrown? - I.writeIORef cachedRef B.empty - return bs1 - else - loop $ B.append bs1 bs2 - ----------------------------------------------------------------- - -- | Modify the given receive function to first check the given @IORef@ for a -- chunk of data. If present, takes the chunk of data from the @IORef@ and -- empties out the @IORef@. Otherwise, calls the supplied receive function. -recvPlain :: I.IORef B.ByteString -> IO B.ByteString -> IO B.ByteString +recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString recvPlain ref fallback = do bs <- I.readIORef ref - if B.null bs + if S.null bs then fallback else do - I.writeIORef ref B.empty + I.writeIORef ref S.empty return bs ---------------------------------------------------------------- diff --git a/warp-tls.cabal b/warp-tls.cabal --- a/warp-tls.cabal +++ b/warp-tls.cabal @@ -1,6 +1,6 @@ Name: warp-tls -Version: 3.0.4.2 -Synopsis: HTTP over SSL/TLS support for Warp via the TLS package +Version: 3.1.0 +Synopsis: HTTP over TLS support for Warp via the TLS package License: MIT License-file: LICENSE Author: Michael Snoyman @@ -10,14 +10,17 @@ Build-Type: Simple Cabal-Version: >=1.6 Stability: Stable -description: API docs and the README are available at . +description: Support for SSL is now obsoleted. + HTTP/2 can be negotiated by ALPN. + API docs and the README are available at + . extra-source-files: ChangeLog.md README.md Library Build-Depends: base >= 4 && < 5 , bytestring >= 0.9 , wai >= 3.0 && < 3.1 - , warp >= 3.0.8 && < 3.1 + , warp >= 3.1 && < 3.2 , data-default-class >= 0.0.1 , tls >= 1.2.16 , network >= 2.2.1