warp-tls 3.2.12 → 3.4.18
raw patch · 7 files changed
Files
- ChangeLog.md +161/−0
- Network/Wai/Handler/WarpTLS.hs +516/−400
- Network/Wai/Handler/WarpTLS/Internal.hs +172/−0
- certificate.pem +15/−0
- key.pem +15/−0
- test/Spec.hs +90/−0
- warp-tls.cabal +26/−9
ChangeLog.md view
@@ -1,3 +1,164 @@+# ChangeLog++## 3.4.18++* warp-tls: build with warp before 3.4.18 again+ [#1167](https://github.com/yesodweb/wai/pull/1167)++## 3.4.17++Requires network 3.2.12.++* The listening socket, and a connection socket no TLS context or+ connection thread uses yet, are closed with `unsafeClose`.+* With warp 3.4.21's `setUnsafeClose`, a TLS connection is closed with+ `unsafeGracefulClose`.+* Sends use network's `sendAllWith`, so warp's timeout reaches a send on+ Windows too, and close_notify is given a quarter of the timeout, at+ most a second.+* A send after the peer's close_notify is dropped. The GOAWAY which ends+ an HTTP/2 connection the client has closed used to reach+ `settingsOnException` as `PostHandshake Error_EOF`.++## 3.4.16++`tlsEarlyDataSize` defaults to 0, so 0-RTT is off unless a server asks for+it: a request in early data is replayable and warp-tls has no RFC 8470+handling.++* Let a server say how much TLS early data it accepts.+ [#1145](https://github.com/yesodweb/wai/pull/1145)++## 3.4.15++* The first read of a connection is given up on when the handshake+ deadline passes, rather than interrupted by `timeout`, which does not+ reach a socket call on Windows.++## 3.4.14.1++* The accept loop is stopped the way warp's is, by being told rather than by+ having its socket closed under it. This needs `warp` 3.5.0 or later; built+ against an earlier one, warp-tls is as it was. It needs what warp needs,+ too: not Windows, and `network` 3.2.2 or later.+ [#1123](https://github.com/yesodweb/wai/pull/1123)++* Build with `warp-3.5.0`.+ [#1095](https://github.com/yesodweb/wai/pull/1095)++## 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.
Network/Wai/Handler/WarpTLS.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PatternGuards #-} -- | HTTP over TLS support for Warp via the TLS package. --@@ -11,512 +10,625 @@ -- Otherwise HTTP\/1.1 over TLS is used. -- -- Support for SSL is now obsoleted.- module Network.Wai.Handler.WarpTLS (+ -- * Runner+ runTLS,+ runTLSSocket,+ -- * Settings- TLSSettings- , defaultTlsSettings+ TLSSettings,+ defaultTlsSettings,+ -- * Smart constructors- , tlsSettings- , tlsSettingsMemory- , tlsSettingsChain- , tlsSettingsChainMemory++ -- ** From files+ tlsSettings,+ tlsSettingsChain,++ -- ** From memory+ tlsSettingsMemory,+ tlsSettingsChainMemory,++ -- ** From references+ tlsSettingsRef,+ tlsSettingsChainRef,+ CertSettings,++ -- ** Dynamically retrieved+ tlsSettingsSni,+ -- * Accessors- , certFile- , keyFile- , tlsCredentials- , tlsLogging- , tlsAllowedVersions- , tlsCiphers- , tlsWantClientCert- , tlsServerHooks- , tlsServerDHEParams- , tlsSessionManagerConfig- , tlsSessionManager- , onInsecure- , OnInsecure (..)- -- * Runner- , runTLS- , runTLSSocket+ tlsCredentials,+ tlsLogging,+ tlsAllowedVersions,+ tlsCiphers,+ tlsWantClientCert,+ tlsServerHooks,+ tlsServerDHEParams,+ tlsSessionManagerConfig,+ tlsSessionManager,+ tlsEarlyDataSize,+ onInsecure,+ OnInsecure (..),+ -- * Exception- , WarpTLSException (..)- , DH.Params- , DH.generateParams- ) where+ WarpTLSException (..), + -- * Low-level+ attachConn+) where+ import Control.Applicative ((<|>))-import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..), handleJust)+import Control.Concurrent.STM+import Control.Exception (+ Exception,+ IOException,+ SomeException (..),+ bracket,+ finally,+ fromException,+ handle,+ handleJust,+ onException,+ throwIO,+ try,+ ) import qualified Control.Exception as E-import Control.Monad (void, guard)+import Control.Monad (guard, void) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L-import Data.Default.Class (def) import qualified Data.IORef as I-import Data.Streaming.Network (bindPortTCP, safeRecv)-import Data.Typeable (Typeable)-import GHC.IO.Exception (IOErrorType(..))-import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)+import Data.Streaming.Network (bindPortTCP)+import GHC.IO.Exception (IOErrorType (..))+import Network.Socket (+ SockAddr,+ Socket,+ getSocketName,+#if !MIN_VERSION_network(3,1,1) || !MIN_VERSION_warp(3,4,18)+ close,+#endif #if MIN_VERSION_network(3,1,1)-import Network.Socket (gracefulClose)+ gracefulClose, #endif-import Network.Socket.ByteString (sendAll)+ unsafeClose,+ withSocketsDo,+ )+#if MIN_VERSION_warp(3,4,21)+import Network.Socket (unsafeGracefulClose)+#endif+import Network.Socket.BufferPool+import Network.Socket.ByteString (recvWith, sendAll, sendAllWith) import qualified Network.TLS as TLS-import qualified Crypto.PubKey.DH as DH-import qualified Network.TLS.Extra as TLSExtra import qualified Network.TLS.SessionManager as SM import Network.Wai (Application) import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp.Internal-import System.IO.Error (isEOFError, ioeGetErrorType)---------------------------------------------------------------------- | Settings for WarpTLS.-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?- --- -- >>> 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]-#if MIN_VERSION_tls(1,5,0)- -- ^ The TLS versions this server accepts.- --- -- >>> tlsAllowedVersions defaultTlsSettings- -- [TLS13,TLS12,TLS11,TLS10]- --- -- Since 1.4.2-#else- -- ^ The TLS versions this server accepts.- --- -- >>> tlsAllowedVersions defaultTlsSettings- -- [TLS12,TLS11,TLS10]- --- -- Since 1.4.2-#endif- , tlsCiphers :: [TLS.Cipher]-#if MIN_VERSION_tls(1,5,0)- -- ^ The TLS ciphers this server accepts.- --- -- >>> tlsCiphers defaultTlsSettings- -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1,AES128GCM-SHA256,AES256GCM-SHA384]- --- -- Since 1.4.2-#else- -- ^ The TLS ciphers this server accepts.- --- -- >>> tlsCiphers defaultTlsSettings- -- [ECDHE-ECDSA-AES256GCM-SHA384,ECDHE-ECDSA-AES128GCM-SHA256,ECDHE-RSA-AES256GCM-SHA384,ECDHE-RSA-AES128GCM-SHA256,DHE-RSA-AES256GCM-SHA384,DHE-RSA-AES128GCM-SHA256,ECDHE-ECDSA-AES256CBC-SHA384,ECDHE-RSA-AES256CBC-SHA384,DHE-RSA-AES256-SHA256,ECDHE-ECDSA-AES256CBC-SHA,ECDHE-RSA-AES256CBC-SHA,DHE-RSA-AES256-SHA1,RSA-AES256GCM-SHA384,RSA-AES256-SHA256,RSA-AES256-SHA1]- --- -- Since 1.4.2-#endif- , 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: def- --- -- Since 3.0.2- , tlsServerDHEParams :: Maybe DH.Params- -- ^ Configuration for ServerDHEParams- -- more function lives in `cryptonite` 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- }---- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors).-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-#if MIN_VERSION_tls(1,5,0)- , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10]-#else- , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]-#endif- , tlsCiphers = ciphers- , tlsWantClientCert = False- , tlsServerHooks = def- , tlsServerDHEParams = Nothing- , tlsSessionManagerConfig = Nothing- , tlsCredentials = Nothing- , tlsSessionManager = Nothing- }---- taken from stunnel example in tls-extra-ciphers :: [TLS.Cipher]-ciphers = TLSExtra.ciphersuite_strong---------------------------------------------------------------------- | An action when a plain HTTP comes to HTTP over TLS/SSL port.-data OnInsecure = DenyInsecure L.ByteString- | AllowInsecure- deriving (Show)+import Network.Wai.Handler.WarpTLS.Internal+import System.IO.Error (ioeGetErrorType, isEOFError)+import System.Timeout (timeout) ---------------------------------------------------------------- -- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'.-tlsSettings :: FilePath -- ^ Certificate file- -> FilePath -- ^ Key file- -> TLSSettings-tlsSettings cert key = defaultTlsSettings {- certFile = cert- , keyFile = key- }+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 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 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 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))- close- (\sock -> runTLSSocket tset set sock app)+runTLS tset set app =+ withSocketsDo $+ bracket+ (bindPortTCP (getPort set) (getHost set))+ unsafeClose+ ( \sock -> do+ setSocketCloseOnExec sock+ runTLSSocket tset set sock app+ ) ---------------------------------------------------------------- loadCredentials :: TLSSettings -> IO TLS.Credentials-loadCredentials TLSSettings{ tlsCredentials = Just creds } = return creds-loadCredentials TLSSettings{..} = case (certMemory, keyMemory) of- (Nothing, Nothing) -> do- cred <- either error id <$> TLS.credentialLoadX509Chain certFile chainCertFiles keyFile+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]- (mcert, mkey) -> do- cert <- maybe (S.readFile certFile) return mcert- key <- maybe (S.readFile keyFile) return mkey- cred <- either error return $ TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key+ 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{tlsSessionManager = Just mgr} = return mgr getSessionManager TLSSettings{..} = case tlsSessionManagerConfig of- Nothing -> return TLS.noSessionManager- Just config -> SM.newSessionManager config+ 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 set sock app = do+#if MIN_VERSION_warp(3,4,18)+ -- The accept loop is stopped by being told, not by having this socket+ -- closed under it; the socket is closed once the loop has ended. See+ -- 'Network.Wai.Handler.Warp.Internal.Listener'.+ listener <- makeListener set sock+#else+ settingsInstallShutdownHandler set (close sock)+#endif credentials <- loadCredentials tlsset mgr <- getSessionManager tlsset+#if MIN_VERSION_warp(3,4,18)+ runTLSSocket' tlsset set listener credentials mgr sock app+#else runTLSSocket' tlsset set credentials mgr sock app+#endif -runTLSSocket' :: TLSSettings -> Settings -> TLS.Credentials -> TLS.SessionManager -> Socket -> Application -> IO ()-runTLSSocket' tlsset@TLSSettings{..} set credentials mgr sock app =+runTLSSocket'+ :: TLSSettings+ -> Settings+#if MIN_VERSION_warp(3,4,18)+ -> Listener+#endif+ -> TLS.Credentials+ -> TLS.SessionManager+ -> Socket+ -> Application+ -> IO ()+#if MIN_VERSION_warp(3,4,18)+runTLSSocket' tlsset@TLSSettings{..} set listener credentials mgr sock app = do+ (_, newSettings) <- makeServerState set+ let get = getter tlsset newSettings listener sock params+ runSettingsConnectionMakerSecureWith newSettings listener get app+#elif MIN_VERSION_warp(3,4,13)+runTLSSocket' tlsset@TLSSettings{..} set credentials mgr sock app = do+ (_, newSettings) <- makeServerState set+ let get = getter tlsset newSettings sock params+ runSettingsConnectionMakerSecure newSettings get app+#else+runTLSSocket' tlsset@TLSSettings{..} set credentials mgr sock app = do+ let get = getter tlsset set sock params runSettingsConnectionMakerSecure set get app+#endif where- get = getter tlsset set sock params- params = def { -- TLS.ServerParams- TLS.serverWantClientCert = tlsWantClientCert- , TLS.serverCACertificates = []- , TLS.serverDHEParams = tlsServerDHEParams- , TLS.serverHooks = hooks- , TLS.serverShared = shared- , TLS.serverSupported = supported+ 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+ , TLS.serverEarlyDataSize = tlsEarlyDataSize #endif- }+ } -- Adding alpn to user's tlsServerHooks.- hooks = tlsServerHooks {- TLS.onALPNClientSuggest = TLS.onALPNClientSuggest tlsServerHooks <|>- (if settingsHTTP2Enabled set then Just alpn else Nothing)- }- shared = def {- TLS.sharedCredentials = credentials- , TLS.sharedSessionManager = mgr- }- supported = def { -- TLS.Supported- TLS.supportedVersions = tlsAllowedVersions- , TLS.supportedCiphers = tlsCiphers- , TLS.supportedCompressions = [TLS.nullCompression]- , TLS.supportedSecureRenegotiation = True- , TLS.supportedClientInitiatedRenegotiation = False- , TLS.supportedSession = True- , TLS.supportedFallbackScsv = True+ 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]+ , 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"+ | "h2" `elem` xs = return "h2"+ | otherwise = return "http/1.1" ---------------------------------------------------------------- -getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)-getter tlsset@TLSSettings{..} set sock params = do-#if WINDOWS- (s, sa) <- windowsThreadBlockHack $ accept sock-#else- (s, sa) <- accept sock+getter+ :: TLS.TLSParams params+ => TLSSettings+ -> Settings+#if MIN_VERSION_warp(3,4,18)+ -> Listener #endif+ -> Socket+ -> params+ -> IO (IO (Connection, Transport), SockAddr)+#if MIN_VERSION_warp(3,4,18)+getter tlsset set listener _sock params = do+ macc <- acceptOrStop listener+ (s, sa) <- maybe (throwIO AcceptStopped) return macc setSocketCloseOnExec s return (mkConn tlsset set s params, sa)+#else+getter tlsset set@Settings{settingsAccept = accept'} sock params = do+ (s, sa) <- accept' sock+ setSocketCloseOnExec s+ return (mkConn tlsset set s params, sa)+#endif -mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)-mkConn tlsset set s params = switch `onException` close s+mkConn+ :: TLS.TLSParams params+ => TLSSettings+ -> Settings+ -> Socket+ -> params+ -> IO (Connection, Transport)+mkConn tlsset set s params = do+ let tm = settingsTimeout set * 1000000+ -- The first read is given up on when the deadline passes, rather than+ -- interrupted by 'timeout': an asynchronous exception does not reach a+ -- thread blocked in a socket call on Windows.+ expired <- registerDelay tm+ ebs <- recvFirstBS expired+ case ebs of+ Left () -> throwIO IncompleteHeaders+ Right bs -> switch bs where- switch = do- firstBS <- safeRecv s 4096- if not (S.null firstBS) && S.head firstBS == 0x16 then- httpOverTls tlsset set s firstBS params- else- plainHTTP tlsset set s firstBS+ recvFirstBS expired =+ (recvWith s 4096 (check =<< readTVar expired) `E.catch` resetIsEOF)+ `onException` unsafeClose s+ -- What streaming-commons' safeRecv did for us: a connection reset is+ -- the end of the connection, not an error to report.+ resetIsEOF e+ | ioeGetErrorType e == ResourceVanished = return $ Right ""+ | otherwise = E.throwIO (e :: E.IOException)+ switch firstBS+ | S.null firstBS = unsafeClose s >> throwIO ClientClosedConnectionPrematurely+ | S.head firstBS == 0x16 = httpOverTls tlsset set s firstBS params+ | otherwise = plainHTTP tlsset set s firstBS ---------------------------------------------------------------- -httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)-httpOverTls TLSSettings{..} _set s bs0 params = do- recvN <- makePlainReceiveN s bs0- ctx <- TLS.contextNew (backend recvN) params- TLS.contextHookSetLogging ctx tlsLogging- TLS.handshake ctx+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` unsafeClose 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+ let recv = receive s pool+#endif+ 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)+ attachConnWith byeTimeout mysa ctx appsInProgress+#else+ attachConnWith byeTimeout mysa ctx+#endif+ case mconn of+ Nothing -> throwIO IncompleteHeaders+ Just conn -> return conn+ wrappedRecvN recvN n = handle (throughAsync (return "")) $ recvN n+ -- A peer which does not read is why a timed-out connection is+ -- closed, so close_notify is given a quarter of the timeout, at most+ -- a second, rather than waiting for that peer for ever.+ byeTimeout+ | settingsTimeout set <= 0 = 1000000+ | otherwise = max 1 $ min 1000000 $ settingsTimeout set * 250000+ gracefulCloser+#if MIN_VERSION_warp(3,4,21)+ | settingsUnsafeClose set = unsafeGracefulClose+#endif+ | otherwise = gracefulClose+ backend recvN =+ TLS.Backend+ { TLS.backendFlush = return ()+#if MIN_VERSION_network(3,1,1)+ , TLS.backendClose =+ gracefulCloser s 5000 `E.catch` throughAsync (return ())+#else+ , TLS.backendClose = close s+#endif+ , TLS.backendSend = sendAll' s+ , TLS.backendRecv = recvN+ }+ -- A plain send is a foreign call no asynchronous exception+ -- reaches on Windows; this one waits in STM, so the timeout can.+ sendAll' sock bs =+ E.handleJust+ ( \e ->+ if ioeGetErrorType e == ResourceVanished+ then Just ConnectionClosedByPeer+ else Nothing+ )+ throwIO+ $ void (sendAllWith sock bs (retry :: STM ()))++-- | 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)+#else+ -> IO (Connection, Transport)+#endif+attachConn = attachConnWith 1000000++-- | 'attachConn' giving close_notify the microseconds given.+attachConnWith+ :: Int+ -> SockAddr+ -> TLS.Context+#if MIN_VERSION_warp(3,4,13)+ -> TVar Int -> IO (Connection, Transport)+attachConnWith byeTimeout mysa ctx appsInProgress = do+#else+ -> IO (Connection, Transport)+attachConnWith byeTimeout mysa ctx = do+#endif h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx isH2 <- I.newIORef h2- writeBuf <- allocateBuffer bufferSize+ writeBuffer <- createWriteBuffer 16384+ writeBufferRef <- I.newIORef writeBuffer -- Creating a cache for leftover input data.- ref <- I.newIORef "" tls <- getTLSinfo ctx- return (conn ctx writeBuf ref isH2, tls)+ return (conn writeBufferRef isH2, tls) where- backend recvN = TLS.Backend {- TLS.backendFlush = return ()-#if MIN_VERSION_network(3,1,1)- , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return ()-#else- , TLS.backendClose = close s+ conn writeBufferRef isH2 =+ Connection+ { connSendMany = afterCloseNotify . 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- , 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- conn ctx writeBuf ref isH2 = Connection {- connSendMany = TLS.sendData ctx . L.fromChunks- , connSendAll = sendall- , connSendFile = sendfile- , connClose = close'- , connFree = freeBuffer writeBuf- , connRecv = recv ref- , connRecvBuf = recvBuf ref- , connWriteBuffer = writeBuf- , connBufferSize = bufferSize- , connHTTP2 = isH2- }+ } where- sendall = TLS.sendData ctx . L.fromChunks . return- sendfile fid offset len hook headers =- readSendFile writeBuf bufferSize sendall fid offset len hook headers-- close' = void (tryIO sendBye) `finally`- TLS.contextClose ctx-- 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)-- -- 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+ sendall = afterCloseNotify . TLS.sendData ctx . L.fromChunks . return+ -- tls answers the peer's close_notify with its own, so a send after+ -- it has nowhere to go: dropped, as the GOAWAY which ends an HTTP/2+ -- connection the peer has closed.+ afterCloseNotify = handle $ \e -> case E.fromException e of+ Just (TLS.PostHandshake TLS.Error_EOF) -> return ()+ _ -> throwIO (e :: SomeException)+ recv = handle onEOF $ TLS.recvData ctx where onEOF 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 S.null x then- go- else- return x+#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+-- readSendFile takes the WriteBuffer itself from 3.5.0, not from 3.4.18:+-- the Listener work went out as 3.4.18 and this did not.+#if MIN_VERSION_warp(3,5,0)+ writeBuffer+#else+ (bufBuffer writeBuffer)+ (bufSize writeBuffer)+#endif+ sendall+ fid+ offset+ len+ hook+ headers - -- 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+ close' =+ void (tryIO $ timeout byeTimeout sendBye)+ `finally` TLS.contextClose ctx -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)+ 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)-#if MIN_VERSION_tls(1,5,0)- TLS.TLS13 -> (3,4)-#endif+ 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 infoCipher- , tlsClientCertificate = clientCert- }+ 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 -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)+plainHTTP+ :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport) plainHTTP TLSSettings{..} set s bs0 = case onInsecure of AllowInsecure -> do conn' <- socketConnection set s cachedRef <- I.newIORef bs0- let conn'' = conn'- { connRecv = recvPlain cachedRef (connRecv conn')- }+ let conn'' =+ conn'+ { connRecv = recvPlain cachedRef (connRecv conn')+ } return (conn'', TCP) DenyInsecure lbs -> do -- Listening port 443 but TLS records do not arrive.@@ -529,12 +641,14 @@ -- GOAWAY + INADEQUATE_SECURITY? -- FIXME: Content-Length: -- FIXME: TLS/<version>- 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"+ 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- close s+ unsafeClose s throwIO InsecureConnectionDenied ----------------------------------------------------------------@@ -553,6 +667,8 @@ ---------------------------------------------------------------- -data WarpTLSException = InsecureConnectionDenied- deriving (Show, Typeable)+data WarpTLSException+ = InsecureConnectionDenied+ | ClientClosedConnectionPrematurely+ deriving (Show) instance Exception WarpTLSException
+ Network/Wai/Handler/WarpTLS/Internal.hs view
@@ -0,0 +1,172 @@+{-# 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+ , tlsEarlyDataSize :: Int+ -- ^ The largest TLS 1.3 early data this server accepts, 0 for none.+ -- A request sent in early data can be replayed by anyone who+ -- recorded it, and warp-tls does nothing about that: it has no RFC+ -- 8470 handling and no 425 response. So 0-RTT is off unless this+ -- says otherwise.+ --+ -- Default: 0+ --+ -- Since 3.4.16+ }++-- 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+ , tlsEarlyDataSize = 0+ }++-- taken from stunnel example in tls-extra+ciphers :: [TLS.Cipher]+ciphers = TLSExtra.ciphersuite_strong
+ certificate.pem view
@@ -0,0 +1,15 @@+-----BEGIN CERTIFICATE-----+MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV+BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX+aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF+MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50+ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB+gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx+EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs++p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV+HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM+b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk+D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0+k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw+VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w==+-----END CERTIFICATE-----
+ key.pem view
@@ -0,0 +1,15 @@+-----BEGIN RSA PRIVATE KEY-----+MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd+thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD+JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB+AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63+CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM+MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp+ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid+Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B+5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs+eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV+YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv+jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG+T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8=+-----END RSA PRIVATE KEY-----
+ test/Spec.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Concurrent (newChan, readChan, writeChan, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.Async (link, mapConcurrently, withAsync)+import Control.Exception (SomeException, bracket, fromException, throwIO)+import Control.Monad (forM_, replicateM, when)+import Data.Word (Word8)+import qualified Network.Socket as S+import qualified Network.Socket.ByteString as B+import qualified Network.Wai.Handler.Warp as Warp+import qualified Network.Wai.Handler.WarpTLS as TLS+import System.Info (os)+import System.Timeout (timeout)+import Test.Hspec++main :: IO ()+main = hspec $ do+ describe "early data" $+ -- A request in early data is replayable and warp-tls has no RFC+ -- 8470 handling, so 0-RTT is off until a server asks for it.+ it "is not accepted unless asked for" $+ TLS.tlsEarlyDataSize TLS.defaultTlsSettings `shouldBe` 0++ describe "pre-TLS exception peer (#1113)" $ do+ it "attributes sequential plaintext and premature-close failures to their sockets" $+ exercise [1, 1] False+ it "attributes concurrent plaintext and premature-close failures to their sockets" $+ exercise [1, 1] True++ -- Linux provides the whole 127/8 loopback range without interface aliases.+ -- Keep the original two-IP regression there; other platforms still check+ -- exact socket addresses (including source ports) above. The maker tests+ -- additionally check distinct IPs without binding sockets on every platform.+ when (os == "linux") $ do+ it "attributes sequential failures from distinct loopback IPs" $+ exercise [1, 2] False+ it "attributes concurrent failures from distinct loopback IPs" $+ exercise [1, 2] True++-- These regressions deliberately leave Warp's accept and fork hooks alone.+-- Keep both peers and failure kinds when changing the exception observer.+exercise :: [Word8] -> Bool -> IO ()+exercise hosts concurrent = S.withSocketsDo $+ bracket (S.socket S.AF_INET S.Stream S.defaultProtocol) S.close $ \listener -> do+ S.bind listener (S.SockAddrInet 0 (S.tupleToHostAddress (127, 0, 0, 1)))+ S.listen listener 10+ port <- S.socketPort listener+ events <- newChan+ ready <- newEmptyMVar+ let report address exception = case fromException exception of+ Just tlsException -> writeChan events (address, show (tlsException :: TLS.WarpTLSException))+ Nothing -> throwIO exception+ settings = Warp.setBeforeMainLoop (putMVar ready ()) $ observePeer report Warp.defaultSettings+ application _ _ = fail "connection must fail before the application"+ tls = TLS.tlsSettings "certificate.pem" "key.pem"+ clients = [(host, plaintext) | host <- hosts, plaintext <- [True, False]]+ send (host, plaintext) = bracket (S.socket S.AF_INET S.Stream S.defaultProtocol) S.close $ \client -> do+ S.bind client (S.SockAddrInet 0 (S.tupleToHostAddress (127, 0, 0, host)))+ S.connect client (S.SockAddrInet port (S.tupleToHostAddress (127, 0, 0, 1)))+ own <- S.getSocketName client+ if plaintext+ then do+ B.sendAll client "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ -- Let WarpTLS send its denial before closing the client;+ -- an early close could cause a different send exception.+ timeout 2000000 (drain client) `shouldReturn` Just ()+ else S.shutdown client S.ShutdownSend+ pure (Just own, if plaintext then "InsecureConnectionDenied" else "ClientClosedConnectionPrematurely")+ withAsync (TLS.runTLSSocket tls settings listener application) $ \server -> do+ link server+ timeout 2000000 (takeMVar ready) `shouldReturn` Just ()+ if concurrent+ then do+ expected <- mapConcurrently send clients+ actual <- timeout 2000000 (replicateM (length clients) (readChan events))+ fmap length actual `shouldBe` Just (length clients)+ maybe (expectationFailure "missing TLS observations") (`shouldMatchList` expected) actual+ else forM_ clients $ \client -> do+ expected <- send client+ timeout 2000000 (readChan events) `shouldReturn` Just expected++observePeer :: (Maybe S.SockAddr -> SomeException -> IO ()) -> Warp.Settings -> Warp.Settings+observePeer report = Warp.setOnConnectionException (report . Just)++drain :: S.Socket -> IO ()+drain client = do+ bytes <- B.recv client 4096+ if bytes == "" then pure () else drain client
warp-tls.cabal view
@@ -1,5 +1,5 @@ Name: warp-tls-Version: 3.2.12+Version: 3.4.18 Synopsis: HTTP over TLS support for Warp via the TLS package License: MIT License-file: LICENSE@@ -15,20 +15,21 @@ HTTP/2 can be negotiated by ALPN. API docs and the README are available at <http://www.stackage.org/package/warp-tls>.-extra-source-files: ChangeLog.md README.md+extra-source-files: ChangeLog.md README.md certificate.pem key.pem Library- Build-Depends: base >= 4.10 && < 5+ Build-Depends: base >= 4.12 && < 5 , bytestring >= 0.9 , wai >= 3.2 && < 3.3- , warp >= 3.3.6 && < 3.4- , data-default-class >= 0.0.1- , tls >= 1.5.3- , cryptonite >= 0.12- , network >= 2.2.1+ , warp >= 3.3.29 && < 3.6+ , tls >= 2.1.3 && < 2.6+ , network >= 3.2.12 , 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@@ -39,4 +40,20 @@ source-repository head type: git- location: git://github.com/yesodweb/wai.git+ location: https://github.com/yesodweb/wai.git+ subdir: warp-tls++Test-Suite spec+ Type: exitcode-stdio-1.0+ Main-Is: Spec.hs+ Hs-Source-Dirs: test+ Default-Language: Haskell2010+ Ghc-Options: -Wall -threaded+ Build-Depends: base >= 4.12 && < 5+ , async+ , bytestring+ , hspec >= 2+ , network >= 3.2.10+ , wai+ , warp >= 3.4.18 && < 3.6+ , warp-tls