diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,205 @@ +# ChangeLog + +## 3.4.14 + +* Build with `warp-3.4.13`. + [#1071](https://github.com/yesodweb/wai/pull/1071) + +## 3.4.13 + +* Introduced new smart constructor `tlsSettingsSni` to make it more convenient + to dynamically change certificates. Deprecates `tlsSettingsRef` and + `tlsSettingsChainRef`. + [#1025](https://github.com/yesodweb/wai/pull/1025) + +## 3.4.12 + +* Rethrowing asynchronous exceptions + [#1013](https://github.com/yesodweb/wai/pull/1013) + +## 3.4.11 + +* Removing `unliftio`. + +## 3.4.10 + +* Removed `data-default` dependency entirely. Does now require `>= tls-2.1.3`. + [#1011](https://github.com/yesodweb/wai/pull/1011) + +## 3.4.9 + +* Using `timeout` for `handshake` to prevent thread leaks. + +## 3.4.8 + +* Substituted `data-default-class` for `data-default` [#1010](https://github.com/yesodweb/wai/pull/1010) + +## 3.4.7 + +* Expose `attachConn` to use post-handshake TLS connection. + [#1007](https://github.com/yesodweb/wai/pull/1007) + +## 3.4.6 + +* Preparing for tls v2.1 + +## 3.4.5 + +* Making mkConn of WarpTLS interruptible + [#984](https://github.com/yesodweb/wai/pull/984) + +## 3.4.4 + +* Allow warp v3.4. + +## 3.4.3 + +* Install shutdown handlers passed via `Settings` to `run...` functions + +## 3.4.2 + +* Requiring warp v3.3.29. + +## 3.4.1 + +* Supporting `tls` v1.8.0. + +## 3.4.0 + +* Major version up to deprecate v3.3.7 due to the incompatibility + against cryptonite. + +## 3.3.7 + +* Using crypton instead of cryptonite. + [#931](https://github.com/yesodweb/wai/pull/931) + +## 3.3.6 + +* Setting FD_CLOEXEC on the listening socket. + [#923](https://github.com/yesodweb/wai/pull/923) + +## 3.3.5 + +* Switching the version of the "recv" package from 0.0.x to 0.1.x. + +## 3.3.4 + +* Integrated customizable `accept` hook from `Network.Wai.Handler.Warp.Settings` (cf. `setAccept`) + [#912](https://github.com/yesodweb/wai/pull/912) +* Adjusted `httpOverTls` because of the factoring out of `Network.Wai.Handler.Warp.Recv` to its own package `recv` in the `warp` package. + [#899](https://github.com/yesodweb/wai/pull/899) + +## 3.3.3 + +* Creating a bigger buffer when the current one is too small to fit the Builder + [#895](https://github.com/yesodweb/wai/pull/895) +* Expose TLS.supportedHashSignatures via TLSSettings + [#872](https://github.com/yesodweb/wai/pull/872) + +## 3.3.2 + +* Providing the Internal module. + [#841](https://github.com/yesodweb/wai/issues/841) + +## 3.3.1 + +* Move exception handling over to `unliftio` for better async exception support [#845](https://github.com/yesodweb/wai/issues/845) +* Cleanly close connection when client closes connection prematurely [#844](https://github.com/yesodweb/wai/issues/844) + +## 3.3.0 + +* Breaking changes: certFile and keyFile are not exported anymore. +* Allow TLS credentials to be retrieved from an IORef. + [#806](https://github.com/yesodweb/wai/pull/806) + +## 3.2.12 + +* A config field: tlsCredentials and tlsSessionManager. + [#805](https://github.com/yesodweb/wai/pull/805) + +## 3.2.11 + +* Ignoring an exception from shutdown (gracefulClose). + +## 3.2.10 + +* Passing client certificate, if any, to Warp + [#783](https://github.com/yesodweb/wai/pull/783) + +## 3.2.9 + +* Cooperating setGracefulCloseTimeout1 and setGracefulCloseTimeout2 of Warp. + [#782](https://github.com/yesodweb/wai/pull/782) + +## 3.2.8 + +* Using gracefullClose of network 3.1.1 or later if available. + +## 3.2.7 + +* Relaxing version constraint. + +## 3.2.6 + +* Using the Strict and StrictData language extensions for GHC >8. + [#752](https://github.com/yesodweb/wai/pull/752) + +## 3.2.5 + +* When tls 1.5.0 is available, TLS 1.3 is automatically supported. + +## 3.2.4.3 + +* Using warp >= 3.2.17. + +## 3.2.4.2 + +* Ignore socket errors while sending `close_notify` [#640](https://github.com/yesodweb/wai/issues/640) + +## 3.2.4 + +* Using tls-session-manager. + +## 3.2.3 + +* Stop using obsoleted APIs of network. + +## 3.2.2 + +* New settting parameter: tlsServerDHEParams [#556](https://github.com/yesodweb/wai/pull/556) +* Preventing socket leakage [#559](https://github.com/yesodweb/wai/pull/559) + +## 3.2.1 + +* Removing dependency to cprng-aes. + +## 3.2.0 + +* Major version up due to breaking changes. +* runHTTP2TLS and runHTTP2TLSSocket were removed. + +## 3.1.4 + +* Add an option to disable HTTP2 [#450](https://github.com/yesodweb/wai/pull/450) + +## 3.1.3 + +* Removing SHA 512 and SHA 384 from supportedCiphers to rescue Safari and golang. [#429](https://github.com/yesodweb/wai/issues/429) + +## 3.1.2 + +* [Getting Rating A from the SSL Server Test](http://www.yesodweb.com/blog/2015/08/ssl-server-test) + +## 3.1.1 + +* Converting "send: resource vanished (Broken pipe)" to ConnectionClosedByPeer. [#421](https://github.com/yesodweb/wai/issues/421) + +## 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 @@ -1,410 +1,592 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE PatternGuards #-} --- | 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 - , certFile - , keyFile - , onInsecure - , tlsLogging - , tlsAllowedVersions - , tlsCiphers - , tlsWantClientCert - , tlsServerHooks - , defaultTlsSettings - , tlsSettings - , tlsSettingsMemory - , tlsSettingsChain - , tlsSettingsChainMemory - , OnInsecure (..) -- * Runner - , runTLS - , runTLSSocket - -- * Exception - , WarpTLSException (..) - ) where + runTLS, + runTLSSocket, -import qualified Network.TLS as TLS -import Network.Wai.Handler.Warp -import Network.Wai (Application) -import Network.Socket (Socket, sClose, withSocketsDo, SockAddr, accept) -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 qualified Data.IORef as I -import Control.Exception (Exception, throwIO) -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.ByteString (sendAll) -import Control.Monad (unless, void) -import Data.ByteString.Lazy.Internal (defaultChunkSize) -import qualified System.IO as IO -import System.IO.Error (isEOFError) + -- * Settings + TLSSettings, + defaultTlsSettings, ----------------------------------------------------------------- + -- * Smart constructors -data TLSSettings = TLSSettings { - certFile :: FilePath - -- ^ File containing the certificate. - , chainCertFiles :: [FilePath] - -- ^ Files containing chain certificates. - , keyFile :: FilePath - -- ^ File containing the key - , certMemory :: Maybe S.ByteString - , 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. - -- - -- Since 1.4.0 - , tlsLogging :: TLS.Logging - -- ^ The level of logging to turn on. - -- - -- Default: 'TLS.defaultLogging'. - -- - -- Since 1.4.0 - , tlsAllowedVersions :: [TLS.Version] - -- ^ The TLS versions this server accepts. - -- - -- Default: '[TLS.TLS10,TLS.TLS11,TLS.TLS12]'. - -- - -- 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]' - -- - -- Since 1.4.2 - , tlsWantClientCert :: Bool - -- ^ Whether or not to demand a certificate from the client. If this - -- is set to True, you must handle received certificates in a server hook - -- or all connections will fail. - -- - -- Default: False - -- - -- Since 3.0.2 - , tlsServerHooks :: TLS.ServerHooks - -- ^ The server-side hooks called by the tls package, including actions - -- to take when a client certificate is received. See the "Network.TLS" - -- module for details. - -- - -- Default: def - -- - -- Since 3.0.2 - } + -- ** From files + tlsSettings, + tlsSettingsChain, --- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name. -defaultTlsSettings :: TLSSettings -defaultTlsSettings = TLSSettings { - certFile = "certificate.pem" - , chainCertFiles = [] - , keyFile = "key.pem" - , certMemory = Nothing - , chainCertsMemory = [] - , keyMemory = Nothing - , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections." - , tlsLogging = def - , tlsAllowedVersions = [TLS.TLS10,TLS.TLS11,TLS.TLS12] - , tlsCiphers = ciphers - , tlsWantClientCert = False - , tlsServerHooks = def - } + -- ** From memory + tlsSettingsMemory, + tlsSettingsChainMemory, --- taken from stunnel example in tls-extra -ciphers :: [TLS.Cipher] -ciphers = - [ TLSExtra.cipher_ECDHE_RSA_AES128GCM_SHA256 - , TLSExtra.cipher_DHE_RSA_AES128GCM_SHA256 - , TLSExtra.cipher_DHE_RSA_AES256_SHA256 - , TLSExtra.cipher_DHE_RSA_AES128_SHA256 - , TLSExtra.cipher_DHE_RSA_AES256_SHA1 - , 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 - ] + -- ** From references + tlsSettingsRef, + tlsSettingsChainRef, + CertSettings, ----------------------------------------------------------------- + -- ** Dynamically retrieved + tlsSettingsSni, --- | An action when a plain HTTP comes to HTTP over TLS/SSL port. -data OnInsecure = DenyInsecure L.ByteString - | AllowInsecure + -- * Accessors + tlsCredentials, + tlsLogging, + tlsAllowedVersions, + tlsCiphers, + tlsWantClientCert, + tlsServerHooks, + tlsServerDHEParams, + tlsSessionManagerConfig, + tlsSessionManager, + onInsecure, + OnInsecure (..), + -- * Exception + WarpTLSException (..), + + -- * Low-level + attachConn +) where + +import Control.Applicative ((<|>)) +#if MIN_VERSION_warp(3,4,13) +import Control.Concurrent.STM (newTVarIO, TVar) +#endif +import Control.Exception ( + Exception, + IOException, + SomeException (..), + bracket, + finally, + fromException, + handle, + handleJust, + onException, + throwIO, + try, + ) +import qualified Control.Exception as E +import Control.Monad (guard, void) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.IORef as I +import Data.Streaming.Network (bindPortTCP, safeRecv) +import Data.Typeable (Typeable) +import GHC.IO.Exception (IOErrorType (..)) +import Network.Socket ( + SockAddr, + Socket, + close, + getSocketName, +#if MIN_VERSION_network(3,1,1) + gracefulClose, +#endif + withSocketsDo, + ) +import Network.Socket.BufferPool +import Network.Socket.ByteString (sendAll) +import qualified Network.TLS as TLS +import qualified Network.TLS.SessionManager as SM +import Network.Wai (Application) +import Network.Wai.Handler.Warp +import Network.Wai.Handler.Warp.Internal +import Network.Wai.Handler.WarpTLS.Internal +import System.IO.Error (ioeGetErrorType, isEOFError) +import System.Timeout (timeout) + ---------------------------------------------------------------- --- | A smart constructor for 'TLSSettings'. -tlsSettings :: FilePath -- ^ Certificate file - -> FilePath -- ^ Key file - -> TLSSettings -tlsSettings cert key = defaultTlsSettings { - certFile = cert - , keyFile = key - } +-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'. +tlsSettings + :: FilePath + -- ^ Certificate file + -> FilePath + -- ^ Key file + -> TLSSettings +tlsSettings cert key = + defaultTlsSettings + { certSettings = CertFromFile cert [] key + } -- | A smart constructor for 'TLSSettings' that allows specifying --- chain certificates. +-- chain certificates based on 'defaultTlsSettings'. -- -- Since 3.0.3 tlsSettingsChain - :: FilePath -- ^ Certificate file - -> [FilePath] -- ^ Chain certificate files - -> FilePath -- ^ Key file - -> TLSSettings -tlsSettingsChain cert chainCerts key = defaultTlsSettings { - certFile = cert - , chainCertFiles = chainCerts - , keyFile = key - } + :: FilePath + -- ^ Certificate file + -> [FilePath] + -- ^ Chain certificate files + -> FilePath + -- ^ Key file + -> TLSSettings +tlsSettingsChain cert chainCerts key = + defaultTlsSettings + { certSettings = CertFromFile cert chainCerts key + } -- | 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 - :: S.ByteString -- ^ Certificate bytes - -> S.ByteString -- ^ Key bytes + :: S.ByteString + -- ^ Certificate bytes + -> S.ByteString + -- ^ Key bytes -> TLSSettings -tlsSettingsMemory cert key = defaultTlsSettings - { certMemory = Just cert - , keyMemory = Just key - } +tlsSettingsMemory cert key = + defaultTlsSettings + { certSettings = CertFromMemory cert [] key + } -- | 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 - :: S.ByteString -- ^ Certificate bytes - -> [S.ByteString] -- ^ Chain certificate bytes - -> S.ByteString -- ^ Key bytes + :: S.ByteString + -- ^ Certificate bytes + -> [S.ByteString] + -- ^ Chain certificate bytes + -> S.ByteString + -- ^ Key bytes -> TLSSettings -tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings - { certMemory = Just cert - , chainCertsMemory = chainCerts - , keyMemory = Just key +tlsSettingsChainMemory cert chainCerts key = + defaultTlsSettings + { certSettings = CertFromMemory cert chainCerts key + } + +-- | Smart constructor for TLS settings that obtains its credentials during +-- Server Name Indication. Can be used to return different credentials +-- depending on the hostname but also to retrieve dynamically updated +-- credentials from an IORef. Credentials can be loaded from PEM-encoded chain +-- and key files using 'TLS.credentialLoadX509'. +-- +-- @since 3.4.13 +tlsSettingsSni :: (Maybe TLS.HostName -> IO TLS.Credentials) -> TLSSettings +tlsSettingsSni onServerNameIndicationHook = + defaultTlsSettings + { tlsCredentials = Just (TLS.Credentials []) + , tlsServerHooks = (tlsServerHooks defaultTlsSettings) + { TLS.onServerNameIndication = onServerNameIndicationHook + } } ----------------------------------------------------------------- +-- | A smart constructor for 'TLSSettings', but uses references to in-memory +-- representations of the certificate and key based on 'defaultTlsSettings'. +-- +-- @since 3.3.0 +tlsSettingsRef + :: I.IORef S.ByteString + -- ^ Reference to certificate bytes + -> I.IORef S.ByteString + -- ^ Reference to key bytes + -> TLSSettings +tlsSettingsRef cert key = + defaultTlsSettings + { certSettings = CertFromRef cert [] key + } +{-# DEPRECATED tlsSettingsRef "This function was added to allow Warp to serve new certificates without restarting, but it has always behaved the same as 'tlsSettingsMemory'. It will be removed in the next major release. To retain existing behavior, swich to 'tlsSettingsMemory'. To dynamically update credentials, see 'tlsSettingsSni'." #-} +-- | A smart constructor for 'TLSSettings', but uses references to in-memory +-- representations of the certificate and key based on 'defaultTlsSettings'. +-- +-- @since 3.3.0 +tlsSettingsChainRef + :: I.IORef S.ByteString + -- ^ Reference to certificate bytes + -> [I.IORef S.ByteString] + -- ^ Reference to chain certificate bytes + -> I.IORef S.ByteString + -- ^ Reference to key bytes + -> TLSSettings +tlsSettingsChainRef cert chainCerts key = + defaultTlsSettings + { certSettings = CertFromRef cert chainCerts key + } + +{-# DEPRECATED tlsSettingsChainRef "This function was added to allow Warp to serve new certificates without restarting, but it has always behaved the same as 'tlsSettingsChainMemory'. It will be removed in the next major release. To retain existing behavior, swich to 'tlsSettingsChainMemory'. To dynamically update credentials, see 'tlsSettingsSni'." #-} + +---------------------------------------------------------------- + -- | Running 'Application' with 'TLSSettings' and 'Settings'. runTLS :: TLSSettings -> Settings -> Application -> IO () -runTLS tset set app = withSocketsDo $ - bracket - (bindPortTCP (getPort set) (getHost set)) - sClose - (\sock -> runTLSSocket tset set sock app) +runTLS tset set app = + withSocketsDo $ + bracket + (bindPortTCP (getPort set) (getHost set)) + close + ( \sock -> do + setSocketCloseOnExec sock + runTLSSocket tset set sock app + ) ---------------------------------------------------------------- +loadCredentials :: TLSSettings -> IO TLS.Credentials +loadCredentials TLSSettings{tlsCredentials = Just creds} = return creds +loadCredentials TLSSettings{..} = case certSettings of + CertFromFile cert chainFiles key -> do + cred <- either error id <$> TLS.credentialLoadX509Chain cert chainFiles key + return $ TLS.Credentials [cred] + CertFromRef certRef chainCertsRef keyRef -> do + cert <- I.readIORef certRef + chainCerts <- mapM I.readIORef chainCertsRef + key <- I.readIORef keyRef + cred <- + either error return $ TLS.credentialLoadX509ChainFromMemory cert chainCerts key + return $ TLS.Credentials [cred] + CertFromMemory certMemory chainCertsMemory keyMemory -> do + cred <- + either error return $ + TLS.credentialLoadX509ChainFromMemory certMemory chainCertsMemory keyMemory + return $ TLS.Credentials [cred] + +getSessionManager :: TLSSettings -> IO TLS.SessionManager +getSessionManager TLSSettings{tlsSessionManager = Just mgr} = return mgr +getSessionManager TLSSettings{..} = case tlsSessionManagerConfig of + Nothing -> return TLS.noSessionManager + Just config -> SM.newSessionManager config + -- | Running 'Application' with 'TLSSettings' and 'Settings' using -- specified 'Socket'. runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO () -runTLSSocket tlsset@TLSSettings{..} set sock app = do - credential <- case (certMemory, keyMemory) of - (Nothing, Nothing) -> - either error id <$> - TLS.credentialLoadX509Chain certFile chainCertFiles keyFile - (mcert, mkey) -> do - cert <- maybe (S.readFile certFile) return mcert - key <- maybe (S.readFile keyFile) return mkey - either error return $ - TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key - runTLSSocket' tlsset set credential sock app +runTLSSocket tlsset set sock app = do + settingsInstallShutdownHandler set (close sock) + credentials <- loadCredentials tlsset + mgr <- getSessionManager tlsset + runTLSSocket' tlsset set credentials mgr sock app -runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> Application -> IO () -runTLSSocket' tlsset@TLSSettings{..} set credential sock app = +runTLSSocket' + :: TLSSettings + -> Settings + -> TLS.Credentials + -> TLS.SessionManager + -> Socket + -> Application + -> IO () +runTLSSocket' tlsset@TLSSettings{..} set credentials mgr sock app = do +#if MIN_VERSION_warp(3,4,13) + (_, newSettings) <- makeServerState set + let get = getter tlsset newSettings sock params + runSettingsConnectionMakerSecure newSettings get app +#else + let get = getter tlsset set sock params runSettingsConnectionMakerSecure set get app +#endif where - get = getter tlsset sock params - params = def { - TLS.serverWantClientCert = tlsWantClientCert - , TLS.serverSupported = def { - TLS.supportedVersions = tlsAllowedVersions - , TLS.supportedCiphers = tlsCiphers - } - , TLS.serverShared = def { - TLS.sharedCredentials = TLS.Credentials [credential] - } - , TLS.serverHooks = tlsServerHooks - } + params = + TLS.defaultParamsServer + { TLS.serverWantClientCert = tlsWantClientCert + , TLS.serverCACertificates = [] + , TLS.serverDHEParams = tlsServerDHEParams + , TLS.serverHooks = hooks + , TLS.serverShared = shared + , TLS.serverSupported = supported +#if MIN_VERSION_tls(1,5,0) + , TLS.serverEarlyDataSize = 2018 +#endif + } + -- Adding alpn to user's tlsServerHooks. + hooks = + tlsServerHooks + { TLS.onALPNClientSuggest = + TLS.onALPNClientSuggest tlsServerHooks + <|> (if settingsHTTP2Enabled set then Just alpn else Nothing) + } + shared = + TLS.defaultShared + { TLS.sharedCredentials = credentials + , TLS.sharedSessionManager = mgr + } + supported = + TLS.defaultSupported + { TLS.supportedVersions = tlsAllowedVersions + , TLS.supportedCiphers = tlsCiphers + , TLS.supportedCompressions = [TLS.nullCompression] + , TLS.supportedSecureRenegotiation = True + , TLS.supportedClientInitiatedRenegotiation = False + , TLS.supportedSession = True + , TLS.supportedFallbackScsv = True + , TLS.supportedHashSignatures = tlsSupportedHashSignatures +#if MIN_VERSION_tls(1,5,0) + , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384] +#endif + } +alpn :: [S.ByteString] -> IO S.ByteString +alpn xs + | "h2" `elem` xs = return "h2" + | otherwise = return "http/1.1" + ---------------------------------------------------------------- -getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr) -getter tlsset@TLSSettings{..} sock params = do - (s, sa) <- accept sock - return (mkConn tlsset s params, sa) +getter + :: TLS.TLSParams params + => TLSSettings + -> Settings + -> Socket + -> params + -> IO (IO (Connection, Transport), SockAddr) +getter tlsset set@Settings{settingsAccept = accept'} sock params = do + (s, sa) <- accept' sock + setSocketCloseOnExec s + return (mkConn tlsset set s params, sa) -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 - else - plainHTTP tlsset s cachedRef) `onException` sClose s +mkConn + :: TLS.TLSParams params + => TLSSettings + -> Settings + -> Socket + -> params + -> IO (Connection, Transport) +mkConn tlsset set s params = do + let tm = settingsTimeout set * 1000000 + mbs <- timeout tm recvFirstBS + case mbs of + Nothing -> throwIO IncompleteHeaders + Just bs -> switch bs + where + recvFirstBS = safeRecv s 4096 `onException` close s + switch firstBS + | S.null firstBS = close s >> throwIO ClientClosedConnectionPrematurely + | S.head firstBS == 0x16 = httpOverTls tlsset set s firstBS params + | otherwise = plainHTTP tlsset set s firstBS ---------------------------------------------------------------- -httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Transport) -httpOverTls TLSSettings{..} s cachedRef params = do -#if MIN_VERSION_tls(1,3,0) - ctx <- TLS.contextNew backend params +isAsyncException :: Exception e => e -> Bool +isAsyncException e = + case E.fromException (E.toException e) of + Just (E.SomeAsyncException _) -> True + Nothing -> False + +throughAsync :: IO a -> SomeException -> IO a +throughAsync action (SomeException e) + | isAsyncException e = E.throwIO e + | otherwise = action + +httpOverTls + :: TLS.TLSParams params + => TLSSettings + -> Settings + -> Socket + -> S.ByteString + -> params + -> IO (Connection, Transport) +httpOverTls TLSSettings{..} set s bs0 params = + makeConn `onException` close s + where + makeConn = do + pool <- newBufferPool 2048 16384 +#if MIN_VERSION_warp(3,4,13) + appsInProgress <- newTVarIO 0 + (ss, _) <- makeServerState set + let recv = makeGracefulRecv s pool ss appsInProgress #else - gen <- Crypto.Random.AESCtr.makeSystem - ctx <- TLS.contextNew backend params gen + let recv = receive s pool #endif - TLS.contextHookSetLogging ctx tlsLogging - TLS.handshake ctx - readBuf <- allocateBuffer bufferSize - writeBuf <- allocateBuffer bufferSize + rawRecvN <- makeRecvN bs0 recv + let recvN = wrappedRecvN rawRecvN + ctx <- TLS.contextNew (backend recvN) params + TLS.contextHookSetLogging ctx tlsLogging + let tm = settingsTimeout set * 1000000 + mconn <- timeout tm $ do + TLS.handshake ctx + mysa <- getSocketName s +#if MIN_VERSION_warp(3,4,13) + attachConn mysa ctx appsInProgress +#else + attachConn mysa ctx +#endif + case mconn of + Nothing -> throwIO IncompleteHeaders + Just conn -> return conn + wrappedRecvN recvN n = handle (throughAsync (return "")) $ recvN n + backend recvN = + TLS.Backend + { TLS.backendFlush = return () +#if MIN_VERSION_network(3,1,1) + , TLS.backendClose = + gracefulClose s 5000 `E.catch` throughAsync (return ()) +#else + , TLS.backendClose = close s +#endif + , TLS.backendSend = sendAll' s + , TLS.backendRecv = recvN + } + sendAll' sock bs = + E.handleJust + ( \e -> + if ioeGetErrorType e == ResourceVanished + then Just ConnectionClosedByPeer + else Nothing + ) + throwIO + $ sendAll sock bs + +-- | Get "Connection" and "Transport" for a TLS connection that is already did the handshake. +-- @since 3.4.7 +attachConn + :: SockAddr + -> TLS.Context +#if MIN_VERSION_warp(3,4,13) + -> TVar Int -> IO (Connection, Transport) +attachConn mysa ctx appsInProgress = do +#else + -> IO (Connection, Transport) +attachConn mysa ctx = do +#endif + h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx + isH2 <- I.newIORef h2 + writeBuffer <- createWriteBuffer 16384 + writeBufferRef <- I.newIORef writeBuffer + -- Creating a cache for leftover input data. tls <- getTLSinfo ctx - return (conn ctx readBuf writeBuf, tls) + return (conn writeBufferRef isH2, tls) where - backend = TLS.Backend { - TLS.backendFlush = return () - , TLS.backendClose = sClose s - , TLS.backendSend = sendAll s - , TLS.backendRecv = recvTLS cachedRef s - } - conn ctx readBuf writeBuf = Connection { - connSendMany = TLS.sendData ctx . L.fromChunks - , connSendAll = TLS.sendData ctx . L.fromChunks . return - , connSendFile = sendfile - , connClose = close - , connRecv = recv - , connSendFileOverride = NotOverride - , connReadBuffer = readBuf - , connWriteBuffer = writeBuf - , connBufferSize = bufferSize - } + conn writeBufferRef isH2 = + Connection + { connSendMany = TLS.sendData ctx . L.fromChunks + , connSendAll = sendall + , connSendFile = sendfile + , connClose = close' + , connRecv = recv + , connRecvBuf = \_ _ -> return True -- obsoleted + , connWriteBuffer = writeBufferRef + , connHTTP2 = isH2 + , connMySockAddr = mysa +#if MIN_VERSION_warp(3,4,13) + , connAppsInProgress = appsInProgress +#endif + } 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 + sendall = TLS.sendData ctx . L.fromChunks . return + recv = handle onEOF $ TLS.recvData ctx 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 + onEOF e +#if MIN_VERSION_tls(1,8,0) + | Just (TLS.PostHandshake TLS.Error_EOF) <- E.fromException e = return S.empty +#else + | Just TLS.Error_EOF <- fromException e = return S.empty +#endif + | Just ioe <- fromException e, isEOFError ioe = return S.empty + | otherwise = throwIO e + sendfile fid offset len hook headers = do + writeBuffer <- I.readIORef writeBufferRef + readSendFile + (bufBuffer writeBuffer) + (bufSize writeBuffer) + sendall + fid + offset + len + hook + headers - close = freeBuffer readBuf `finally` - freeBuffer writeBuf `finally` - void (tryIO $ TLS.bye ctx) `finally` - TLS.contextClose ctx + close' = + void (tryIO sendBye) + `finally` TLS.contextClose ctx - 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 - go = do - x <- TLS.recvData ctx - if B.null x then - go - else - return x + sendBye = + -- It's fine if the connection was closed by the other side before + -- receiving close_notify, see RFC 5246 section 7.2.1. + handleJust + (\e -> guard (e == ConnectionClosedByPeer) >> return e) + (const (return ())) + (TLS.bye ctx) getTLSinfo :: TLS.Context -> IO Transport getTLSinfo ctx = do proto <- TLS.getNegotiatedProtocol ctx minfo <- TLS.contextGetInformation ctx case minfo of - Nothing -> return TCP - Just TLS.Information{..} -> do - let (major, minor) = case infoVersion of - TLS.SSL2 -> (2,0) - TLS.SSL3 -> (3,0) - TLS.TLS10 -> (3,1) - TLS.TLS11 -> (3,2) - TLS.TLS12 -> (3,3) - return TLS { - tlsMajorVersion = major - , tlsMinorVersion = minor - , tlsNegotiatedProtocol = proto - , tlsChiperID = TLS.cipherID infoCipher - } + Nothing -> return TCP + Just info -> do + let (major, minor) = case TLS.infoVersion info of + TLS.SSL2 -> (2, 0) + TLS.SSL3 -> (3, 0) + TLS.TLS10 -> (3, 1) + TLS.TLS11 -> (3, 2) + TLS.TLS12 -> (3, 3) + _ -> (3,4) + clientCert <- TLS.getClientCertificateChain ctx + return + TLS + { tlsMajorVersion = major + , tlsMinorVersion = minor + , tlsNegotiatedProtocol = proto + , tlsChiperID = TLS.cipherID $ TLS.infoCipher info + , tlsClientCertificate = clientCert + } tryIO :: IO a -> IO (Either IOException a) tryIO = try ---------------------------------------------------------------- -plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Transport) -plainHTTP TLSSettings{..} s cachedRef = case onInsecure of +plainHTTP + :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport) +plainHTTP TLSSettings{..} set s bs0 = case onInsecure of AllowInsecure -> do - conn' <- socketConnection s - let conn'' = conn' - { connRecv = recvPlain cachedRef (connRecv conn') - } + conn' <- socketConnection set s + cachedRef <- I.newIORef bs0 + let conn'' = + conn' + { connRecv = recvPlain cachedRef (connRecv conn') + } return (conn'', TCP) DenyInsecure lbs -> do - sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n" + -- Listening port 443 but TLS records do not arrive. + -- We want to let the browser know that TLS is required. + -- So, we use 426. + -- http://tools.ietf.org/html/rfc2817#section-4.2 + -- https://tools.ietf.org/html/rfc7231#section-6.5.15 + -- FIXME: should we distinguish HTTP/1.1 and HTTP/2? + -- In the case of HTTP/2, should we send + -- GOAWAY + INADEQUATE_SECURITY? + -- FIXME: Content-Length: + -- FIXME: TLS/ + sendAll + s + "HTTP/1.1 426 Upgrade Required\ + \\r\nUpgrade: TLS/1.0, HTTP/1.1\ + \\r\nConnection: Upgrade\ + \\r\nContent-Type: text/plain\r\n\r\n" mapM_ (sendAll s) $ L.toChunks lbs - sClose s + close s throwIO InsecureConnectionDenied ---------------------------------------------------------------- -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 ---------------------------------------------------------------- -data WarpTLSException = InsecureConnectionDenied +data WarpTLSException + = InsecureConnectionDenied + | ClientClosedConnectionPrematurely deriving (Show, Typeable) instance Exception WarpTLSException diff --git a/Network/Wai/Handler/WarpTLS/Internal.hs b/Network/Wai/Handler/WarpTLS/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/WarpTLS/Internal.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Wai.Handler.WarpTLS.Internal ( + CertSettings (..), + TLSSettings (..), + defaultTlsSettings, + OnInsecure (..), + + -- * Accessors + getCertSettings, +) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.IORef as I +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLSExtra +import qualified Network.TLS.SessionManager as SM + +---------------------------------------------------------------- + +-- | Determines where to load the certificate, chain +-- certificates, and key from. +data CertSettings + = CertFromFile !FilePath ![FilePath] !FilePath + | CertFromMemory !S.ByteString ![S.ByteString] !S.ByteString + | CertFromRef + !(I.IORef S.ByteString) + ![I.IORef S.ByteString] + !(I.IORef S.ByteString) + +instance Show CertSettings where + show (CertFromFile a b c) = "CertFromFile " ++ show a ++ " " ++ show b ++ " " ++ show c + show (CertFromMemory a b c) = "CertFromMemory " ++ show a ++ " " ++ show b ++ " " ++ show c + show CertFromRef{} = "CertFromRef" + +---------------------------------------------------------------- + +-- | An action when a plain HTTP comes to HTTP over TLS/SSL port. +data OnInsecure + = DenyInsecure L.ByteString + | AllowInsecure + deriving (Show) + +---------------------------------------------------------------- + +-- | Settings for WarpTLS. +data TLSSettings = TLSSettings + { certSettings :: CertSettings + -- ^ Where are the certificate, chain certificates, and key + -- loaded from? + -- + -- >>> certSettings defaultTlsSettings + -- CertFromFile "certificate.pem" [] "key.pem" + -- + -- @since 3.3.0 + , onInsecure :: OnInsecure + -- ^ 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. + -- + -- Default: 'TLS.defaultLogging'. + -- + -- Since 1.4.0 + , tlsAllowedVersions :: [TLS.Version] + -- ^ The TLS versions this server accepts. + -- + -- Since 1.4.2 + , tlsCiphers + :: [TLS.Cipher] + -- ^ The TLS ciphers this server accepts. + -- + -- Since 1.4.2 + , tlsWantClientCert :: Bool + -- ^ Whether or not to demand a certificate from the client. If this + -- is set to True, you must handle received certificates in a server hook + -- or all connections will fail. + -- + -- >>> tlsWantClientCert defaultTlsSettings + -- False + -- + -- Since 3.0.2 + , tlsServerHooks :: TLS.ServerHooks + -- ^ The server-side hooks called by the tls package, including actions + -- to take when a client certificate is received. See the "Network.TLS" + -- module for details. + -- + -- Default: defaultServerHooks + -- + -- Since 3.0.2 + , tlsServerDHEParams :: Maybe TLS.DHParams + -- ^ Configuration for ServerDHEParams + -- more function lives in `crypton` package + -- + -- Default: Nothing + -- + -- Since 3.2.2 + , tlsSessionManagerConfig :: Maybe SM.Config + -- ^ Configuration for in-memory TLS session manager. + -- If Nothing, 'TLS.noSessionManager' is used. + -- Otherwise, an in-memory TLS session manager is created + -- according to 'Config'. + -- + -- Default: Nothing + -- + -- Since 3.2.4 + , tlsCredentials :: Maybe TLS.Credentials + -- ^ Specifying 'TLS.Credentials' directly. If this value is + -- specified, other fields such as 'certFile' are ignored. + -- + -- Since 3.2.12 + , tlsSessionManager :: Maybe TLS.SessionManager + -- ^ Specifying 'TLS.SessionManager' directly. If this value is + -- specified, 'tlsSessionManagerConfig' is ignored. + -- + -- Since 3.2.12 + , tlsSupportedHashSignatures :: [TLS.HashAndSignatureAlgorithm] + -- ^ Specifying supported hash/signature algorithms, ordered by decreasing + -- priority. See the "Network.TLS" module for details + -- + -- Since 3.3.3 + } + +-- Since 3.3.1 + +-- | Some programs need access to cert settings +getCertSettings :: TLSSettings -> CertSettings +getCertSettings = certSettings + +-- | The default 'CertSettings'. +defaultCertSettings :: CertSettings +defaultCertSettings = CertFromFile "certificate.pem" [] "key.pem" + +---------------------------------------------------------------- + +-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors). +defaultTlsSettings :: TLSSettings +defaultTlsSettings = + TLSSettings + { certSettings = defaultCertSettings + , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections." + , tlsLogging = TLS.defaultLogging + , tlsAllowedVersions = TLS.supportedVersions TLS.defaultSupported + , tlsCiphers = ciphers + , tlsWantClientCert = False + , tlsServerHooks = TLS.defaultServerHooks + , tlsServerDHEParams = Nothing + , tlsSessionManagerConfig = Nothing + , tlsCredentials = Nothing + , tlsSessionManager = Nothing + , tlsSupportedHashSignatures = TLS.supportedHashSignatures TLS.defaultSupported + } + +-- taken from stunnel example in tls-extra +ciphers :: [TLS.Cipher] +ciphers = TLSExtra.ciphersuite_strong 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.4.14 +Synopsis: HTTP over TLS support for Warp via the TLS package License: MIT License-file: LICENSE Author: Michael Snoyman @@ -8,24 +8,37 @@ Homepage: http://github.com/yesodweb/wai Category: Web, Yesod Build-Type: Simple -Cabal-Version: >=1.6 +Cabal-Version: >= 1.10 Stability: Stable -description: API docs and the README are available at . +description: SSLv1 and SSLv2 are obsoleted by IETF. + We should use TLS 1.2 (or TLS 1.1 or TLS 1.0 if necessary). + 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 + Build-Depends: base >= 4.12 && < 5 , bytestring >= 0.9 - , wai >= 3.0 && < 3.1 - , warp >= 3.0.8 && < 3.1 - , data-default-class >= 0.0.1 - , tls >= 1.2.16 + , wai >= 3.2 && < 3.3 + , warp >= 3.3.29 && < 3.5 + , tls >= 2.1.3 && < 2.5 , network >= 2.2.1 - , cprng-aes >= 0.5.0 , streaming-commons + , stm >= 2.3 + , tls-session-manager >= 0.0.4 + , recv >= 0.1.0 && < 0.2.0 Exposed-modules: Network.Wai.Handler.WarpTLS + Network.Wai.Handler.WarpTLS.Internal ghc-options: -Wall + if os(windows) + Cpp-Options: -DWINDOWS + if impl(ghc >= 8) + Default-Extensions: Strict StrictData + Default-Language: Haskell2010 + source-repository head type: git - location: git://github.com/yesodweb/wai.git + location: https://github.com/yesodweb/wai.git + subdir: warp-tls