@@ -1,62 +1,74 @@
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE PatternGuards #-}
6{-# LANGUAGE PatternGuards #-}
8−-- | HTTP over SSL/TLS support for Warp via the TLS package.
8+-- | HTTP over TLS support for Warp via the TLS package.
10+-- If HTTP\/2 is negotiated by ALPN, HTTP\/2 over TLS is used.
11+-- Otherwise HTTP\/1.1 over TLS is used.
13+-- Support for SSL is now obsoleted.
10module Network.Wai.Handler.WarpTLS (
15module Network.Wai.Handler.WarpTLS (
11 -- * Settings
16 -- * Settings
12 TLSSettings
17 TLSSettings
19+ -- * Smart constructors
23+ , tlsSettingsChainMemory
13 , certFile
25 , certFile
16 , tlsLogging
27 , tlsLogging
17 , tlsAllowedVersions
28 , tlsAllowedVersions
18 , tlsCiphers
29 , tlsCiphers
19 , tlsWantClientCert
30 , tlsWantClientCert
20 , tlsServerHooks
31 , tlsServerHooks
21− , defaultTlsSettings
32+ , tlsServerDHEParams
22− , tlsSettings
33+ , tlsSessionManagerConfig
23− , tlsSettingsMemory
34+ , onInsecure
25− , tlsSettingsChainMemory
26 , OnInsecure (..)
35 , OnInsecure (..)
27 -- * Runner
36 -- * Runner
29 , runTLSSocket
38 , runTLSSocket
30 -- * Exception
39 -- * Exception
31 , WarpTLSException (..)
40 , WarpTLSException (..)
34−#if __GLASGOW_HASKELL__ < 709
35−import Control.Applicative ((<$>))
45+import Control.Applicative ((<|>))
37−import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException)
46+import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..), handleJust)
47+import qualified Control.Exception as E
38−import Control.Monad (unless, void)
48+import Control.Monad (void, guard)
39−import qualified Crypto.Random.AESCtr
40−import qualified Data.ByteString as B
41import qualified Data.ByteString as S
49import qualified Data.ByteString as S
42import qualified Data.ByteString.Lazy as L
50import qualified Data.ByteString.Lazy as L
43−import Data.ByteString.Lazy.Internal (defaultChunkSize)
44import Data.Default.Class (def)
51import Data.Default.Class (def)
45import qualified Data.IORef as I
52import qualified Data.IORef as I
46import Data.Streaming.Network (bindPortTCP, safeRecv)
53import Data.Streaming.Network (bindPortTCP, safeRecv)
47import Data.Typeable (Typeable)
54import Data.Typeable (Typeable)
48−import Network.Socket (Socket, sClose, withSocketsDo, SockAddr, accept)
55+import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)
56+#if MIN_VERSION_network(3,1,1)
57+import Network.Socket (gracefulClose)
49import Network.Socket.ByteString (sendAll)
59import Network.Socket.ByteString (sendAll)
50import qualified Network.TLS as TLS
60import qualified Network.TLS as TLS
61+import qualified Crypto.PubKey.DH as DH
51import qualified Network.TLS.Extra as TLSExtra
62import qualified Network.TLS.Extra as TLSExtra
63+import qualified Network.TLS.SessionManager as SM
52import Network.Wai (Application)
64import Network.Wai (Application)
53import Network.Wai.Handler.Warp
65import Network.Wai.Handler.Warp
54−import Network.Wai.Handler.Warp.Buffer (allocateBuffer, bufferSize, freeBuffer)
66+import Network.Wai.Handler.Warp.Internal
55−import qualified System.IO as IO
56import System.IO.Error (isEOFError)
67import System.IO.Error (isEOFError)
58----------------------------------------------------------------
69----------------------------------------------------------------
71+-- | Settings for WarpTLS.
60data TLSSettings = TLSSettings {
72data TLSSettings = TLSSettings {
61 certFile :: FilePath
73 certFile :: FilePath
62 -- ^ File containing the certificate.
74 -- ^ File containing the certificate.
@@ -68,8 +80,10 @@ data TLSSettings = TLSSettings {
68 , chainCertsMemory :: [S.ByteString]
80 , chainCertsMemory :: [S.ByteString]
69 , keyMemory :: Maybe S.ByteString
81 , keyMemory :: Maybe S.ByteString
70 , onInsecure :: OnInsecure
82 , onInsecure :: OnInsecure
71− -- ^ Do we allow insecure connections with this server as well? Default
83+ -- ^ Do we allow insecure connections with this server as well?
72− -- is a simple text response stating that a secure connection is required.
84+ --
85+ -- >>> onInsecure defaultTlsSettings
86+ -- DenyInsecure "This server only accepts secure HTTPS connections."
74 -- Since 1.4.0
88 -- Since 1.4.0
75 , tlsLogging :: TLS.Logging
89 , tlsLogging :: TLS.Logging
@@ -79,23 +93,44 @@ data TLSSettings = TLSSettings {
80 -- Since 1.4.0
94 -- Since 1.4.0
81 , tlsAllowedVersions :: [TLS.Version]
95 , tlsAllowedVersions :: [TLS.Version]
96+#if MIN_VERSION_tls(1,5,0)
97+ -- ^ The TLS versions this server accepts.
99+ -- >>> tlsAllowedVersions defaultTlsSettings
100+ -- [TLS13,TLS12,TLS11,TLS10]
82 -- ^ The TLS versions this server accepts.
104 -- ^ The TLS versions this server accepts.
84− -- Default: '[TLS.TLS10,TLS.TLS11,TLS.TLS12]'.
106+ -- >>> tlsAllowedVersions defaultTlsSettings
107+ -- [TLS12,TLS11,TLS10]
86 -- Since 1.4.2
109 -- Since 1.4.2
87 , tlsCiphers :: [TLS.Cipher]
111 , tlsCiphers :: [TLS.Cipher]
112+#if MIN_VERSION_tls(1,5,0)
113+ -- ^ The TLS ciphers this server accepts.
115+ -- >>> tlsCiphers defaultTlsSettings
116+ -- [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]
88 -- ^ The TLS ciphers this server accepts.
120 -- ^ The TLS ciphers this server accepts.
90− -- Default: '[TLSExtra.cipher_AES128_SHA1, TLSExtra.cipher_AES256_SHA1, TLSEtra.cipher_RC4_128_MD5, TLSExtra.cipher_RC4_128_SHA1]'
122+ -- >>> tlsCiphers defaultTlsSettings
123+ -- [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]
92 -- Since 1.4.2
125 -- Since 1.4.2
93 , tlsWantClientCert :: Bool
127 , tlsWantClientCert :: Bool
94 -- ^ Whether or not to demand a certificate from the client. If this
128 -- ^ Whether or not to demand a certificate from the client. If this
95 -- is set to True, you must handle received certificates in a server hook
129 -- is set to True, you must handle received certificates in a server hook
96 -- or all connections will fail.
130 -- or all connections will fail.
132+ -- >>> tlsWantClientCert defaultTlsSettings
98− -- Default: False
133+ -- False
100 -- Since 3.0.2
135 -- Since 3.0.2
101 , tlsServerHooks :: TLS.ServerHooks
136 , tlsServerHooks :: TLS.ServerHooks
@@ -106,9 +141,25 @@ data TLSSettings = TLSSettings {
106 -- Default: def
141 -- Default: def
108 -- Since 3.0.2
143 -- Since 3.0.2
144+ , tlsServerDHEParams :: Maybe DH.Params
145+ -- ^ Configuration for ServerDHEParams
146+ -- more function lives in `cryptonite` package
151+ , tlsSessionManagerConfig :: Maybe SM.Config
152+ -- ^ Configuration for in-memory TLS session manager.
153+ -- If Nothing, 'TLS.noSessionManager' is used.
154+ -- Otherwise, an in-memory TLS session manager is created
155+ -- according to 'Config'.
111−-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name.
162+-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors).
112defaultTlsSettings :: TLSSettings
163defaultTlsSettings :: TLSSettings
113defaultTlsSettings = TLSSettings {
164defaultTlsSettings = TLSSettings {
114 certFile = "certificate.pem"
165 certFile = "certificate.pem"
@@ -119,39 +170,32 @@ defaultTlsSettings = TLSSettings {
119 , keyMemory = Nothing
170 , keyMemory = Nothing
120 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
171 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
121 , tlsLogging = def
172 , tlsLogging = def
173+#if MIN_VERSION_tls(1,5,0)
122− , tlsAllowedVersions = [TLS.TLS10,TLS.TLS11,TLS.TLS12]
174+ , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10]
176+ , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]
123 , tlsCiphers = ciphers
178 , tlsCiphers = ciphers
124 , tlsWantClientCert = False
179 , tlsWantClientCert = False
125 , tlsServerHooks = def
180 , tlsServerHooks = def
181+ , tlsServerDHEParams = Nothing
182+ , tlsSessionManagerConfig = Nothing
128-- taken from stunnel example in tls-extra
185-- taken from stunnel example in tls-extra
129ciphers :: [TLS.Cipher]
186ciphers :: [TLS.Cipher]
130−ciphers =
187+ciphers = TLSExtra.ciphersuite_strong
131− [ TLSExtra.cipher_ECDHE_RSA_AES128GCM_SHA256
132− , TLSExtra.cipher_DHE_RSA_AES128GCM_SHA256
133− , TLSExtra.cipher_DHE_RSA_AES256_SHA256
134− , TLSExtra.cipher_DHE_RSA_AES128_SHA256
135− , TLSExtra.cipher_DHE_RSA_AES256_SHA1
136− , TLSExtra.cipher_DHE_RSA_AES128_SHA1
137− , TLSExtra.cipher_DHE_DSS_AES128_SHA1
138− , TLSExtra.cipher_DHE_DSS_AES256_SHA1
139− , TLSExtra.cipher_DHE_DSS_RC4_SHA1
140− , TLSExtra.cipher_AES128_SHA1
141− , TLSExtra.cipher_AES256_SHA1
142− , TLSExtra.cipher_RC4_128_MD5
143− , TLSExtra.cipher_RC4_128_SHA1
146----------------------------------------------------------------
189----------------------------------------------------------------
148-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.
191-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.
149data OnInsecure = DenyInsecure L.ByteString
192data OnInsecure = DenyInsecure L.ByteString
150 | AllowInsecure
193 | AllowInsecure
152----------------------------------------------------------------
196----------------------------------------------------------------
154−-- | A smart constructor for 'TLSSettings'.
198+-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'.
155tlsSettings :: FilePath -- ^ Certificate file
199tlsSettings :: FilePath -- ^ Certificate file
156 -> FilePath -- ^ Key file
200 -> FilePath -- ^ Key file
157 -> TLSSettings
201 -> TLSSettings
@@ -161,7 +205,7 @@ tlsSettings cert key = defaultTlsSettings {
163-- | A smart constructor for 'TLSSettings' that allows specifying
207-- | A smart constructor for 'TLSSettings' that allows specifying
164−-- chain certificates.
208+-- chain certificates based on 'defaultTlsSettings'.
166-- Since 3.0.3
210-- Since 3.0.3
167tlsSettingsChain
211tlsSettingsChain
@@ -176,7 +220,7 @@ tlsSettingsChain cert chainCerts key = defaultTlsSettings {
178-- | A smart constructor for 'TLSSettings', but uses in-memory representations
222-- | A smart constructor for 'TLSSettings', but uses in-memory representations
179−-- of the certificate and key
223+-- of the certificate and key based on 'defaultTlsSettings'.
181-- Since 3.0.1
225-- Since 3.0.1
182tlsSettingsMemory
226tlsSettingsMemory
@@ -189,7 +233,7 @@ tlsSettingsMemory cert key = defaultTlsSettings
191-- | A smart constructor for 'TLSSettings', but uses in-memory representations
235-- | A smart constructor for 'TLSSettings', but uses in-memory representations
192−-- of the certificate and key
236+-- of the certificate and key based on 'defaultTlsSettings'.
194-- Since 3.0.3
238-- Since 3.0.3
195tlsSettingsChainMemory
239tlsSettingsChainMemory
@@ -205,13 +249,12 @@ tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings
206----------------------------------------------------------------
250----------------------------------------------------------------
209-- | Running 'Application' with 'TLSSettings' and 'Settings'.
252-- | Running 'Application' with 'TLSSettings' and 'Settings'.
210runTLS :: TLSSettings -> Settings -> Application -> IO ()
253runTLS :: TLSSettings -> Settings -> Application -> IO ()
211runTLS tset set app = withSocketsDo $
254runTLS tset set app = withSocketsDo $
213 (bindPortTCP (getPort set) (getHost set))
256 (bindPortTCP (getPort set) (getHost set))
215 (\sock -> runTLSSocket tset set sock app)
258 (\sock -> runTLSSocket tset set sock app)
217----------------------------------------------------------------
260----------------------------------------------------------------
@@ -229,104 +272,186 @@ runTLSSocket tlsset@TLSSettings{..} set sock app = do
229 key <- maybe (S.readFile keyFile) return mkey
272 key <- maybe (S.readFile keyFile) return mkey
230 either error return $
273 either error return $
231 TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key
274 TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key
275+ mgr <- case tlsSessionManagerConfig of
276+ Nothing -> return TLS.noSessionManager
277+ Just config -> SM.newSessionManager config
232− runTLSSocket' tlsset set credential sock app
278+ runTLSSocket' tlsset set credential mgr sock app
234−runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> Application -> IO ()
280+runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> TLS.SessionManager -> Socket -> Application -> IO ()
235−runTLSSocket' tlsset@TLSSettings{..} set credential sock app =
281+runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =
236 runSettingsConnectionMakerSecure set get app
282 runSettingsConnectionMakerSecure set get app
238− get = getter tlsset sock params
284+ get = getter tlsset set sock params
239− params = def {
285+ params = def { -- TLS.ServerParams
240 TLS.serverWantClientCert = tlsWantClientCert
286 TLS.serverWantClientCert = tlsWantClientCert
241− , TLS.serverSupported = def {
287+ , TLS.serverCACertificates = []
242− TLS.supportedVersions = tlsAllowedVersions
288+ , TLS.serverDHEParams = tlsServerDHEParams
243− , TLS.supportedCiphers = tlsCiphers
245− , TLS.serverShared = def {
246− TLS.sharedCredentials = TLS.Credentials [credential]
248− , TLS.serverHooks = tlsServerHooks
289+ , TLS.serverHooks = hooks
290+ , TLS.serverShared = shared
291+ , TLS.serverSupported = supported
292+#if MIN_VERSION_tls(1,5,0)
293+ , TLS.serverEarlyDataSize = 2018
296+ -- Adding alpn to user's tlsServerHooks.
297+ hooks = tlsServerHooks {
298+ TLS.onALPNClientSuggest = TLS.onALPNClientSuggest tlsServerHooks <|>
299+ (if settingsHTTP2Enabled set then Just alpn else Nothing)
302+ TLS.sharedCredentials = TLS.Credentials [credential]
303+ , TLS.sharedSessionManager = mgr
305+ supported = def { -- TLS.Supported
306+ TLS.supportedVersions = tlsAllowedVersions
307+ , TLS.supportedCiphers = tlsCiphers
308+ , TLS.supportedCompressions = [TLS.nullCompression]
309+ , TLS.supportedSecureRenegotiation = True
310+ , TLS.supportedClientInitiatedRenegotiation = False
311+ , TLS.supportedSession = True
312+ , TLS.supportedFallbackScsv = True
313+#if MIN_VERSION_tls(1,5,0)
314+ , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]
318+alpn :: [S.ByteString] -> IO S.ByteString
320+ | "h2" `elem` xs = return "h2"
321+ | otherwise = return "http/1.1"
251----------------------------------------------------------------
323----------------------------------------------------------------
253−getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)
325+getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)
254−getter tlsset@TLSSettings{..} sock params = do
326+getter tlsset@TLSSettings{..} set sock params = do
328+ (s, sa) <- windowsThreadBlockHack $ accept sock
255 (s, sa) <- accept sock
330 (s, sa) <- accept sock
332+ setSocketCloseOnExec s
256− return (mkConn tlsset s params, sa)
333+ return (mkConn tlsset set s params, sa)
258−mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport)
335+mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)
259−mkConn tlsset s params = do
336+mkConn tlsset set s params = switch `onException` close s
260− firstBS <- safeRecv s 4096
339+ firstBS <- safeRecv s 4096
261− cachedRef <- I.newIORef firstBS
262− (if not (B.null firstBS) && B.head firstBS == 0x16 then
340+ if not (S.null firstBS) && S.head firstBS == 0x16 then
263− httpOverTls tlsset s cachedRef params
341+ httpOverTls tlsset set s firstBS params
265− plainHTTP tlsset s cachedRef) `onException` sClose s
343+ plainHTTP tlsset set s firstBS
267----------------------------------------------------------------
345----------------------------------------------------------------
269−httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Transport)
347+httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)
270−httpOverTls TLSSettings{..} s cachedRef params = do
348+httpOverTls TLSSettings{..} _set s bs0 params = do
271− gen <- Crypto.Random.AESCtr.makeSystem
349+ recvN <- makePlainReceiveN s bs0
272− ctx <- TLS.contextNew backend params gen
350+ ctx <- TLS.contextNew (backend recvN) params
273 TLS.contextHookSetLogging ctx tlsLogging
351 TLS.contextHookSetLogging ctx tlsLogging
274 TLS.handshake ctx
352 TLS.handshake ctx
275− readBuf <- allocateBuffer bufferSize
353+ h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx
354+ isH2 <- I.newIORef h2
276 writeBuf <- allocateBuffer bufferSize
355 writeBuf <- allocateBuffer bufferSize
356+ -- Creating a cache for leftover input data.
357+ ref <- I.newIORef ""
277 tls <- getTLSinfo ctx
358 tls <- getTLSinfo ctx
278− return (conn ctx readBuf writeBuf, tls)
359+ return (conn ctx writeBuf ref isH2, tls)
280− backend = TLS.Backend {
361+ backend recvN = TLS.Backend {
281 TLS.backendFlush = return ()
362 TLS.backendFlush = return ()
282− , TLS.backendClose = sClose s
363+#if MIN_VERSION_network(3,1,1)
364+ , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return ()
366+ , TLS.backendClose = close s
283− , TLS.backendSend = sendAll s
368+ , TLS.backendSend = sendAll' s
284− , TLS.backendRecv = recvTLS cachedRef s
369+ , TLS.backendRecv = recvN
371+ sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->
372+ throwIO ConnectionClosedByPeer
286− conn ctx readBuf writeBuf = Connection {
373+ conn ctx writeBuf ref isH2 = Connection {
287 connSendMany = TLS.sendData ctx . L.fromChunks
374 connSendMany = TLS.sendData ctx . L.fromChunks
288− , connSendAll = TLS.sendData ctx . L.fromChunks . return
375+ , connSendAll = sendall
289 , connSendFile = sendfile
376 , connSendFile = sendfile
290− , connClose = close
377+ , connClose = close'
378+ , connFree = freeBuffer writeBuf
291− , connRecv = recv
379+ , connRecv = recv ref
292− , connSendFileOverride = NotOverride
380+ , connRecvBuf = recvBuf ref
293− , connReadBuffer = readBuf
294 , connWriteBuffer = writeBuf
381 , connWriteBuffer = writeBuf
295 , connBufferSize = bufferSize
382 , connBufferSize = bufferSize
386+ sendall = TLS.sendData ctx . L.fromChunks . return
298− sendfile fp offset len tickle' headers = do
387+ sendfile fid offset len hook headers =
299− TLS.sendData ctx $ L.fromChunks headers
388+ readSendFile writeBuf bufferSize sendall fid offset len hook headers
300− IO.withBinaryFile fp IO.ReadMode $ \h -> do
389+
301− IO.hSeek h IO.AbsoluteSeek offset
390+ close' = void (tryIO sendBye) `finally`
302− loop h $ fromIntegral len
391+ TLS.contextClose ctx
304− loop _ remaining | remaining <= 0 = return ()
393+ sendBye =
305− loop h remaining = do
394+ -- It's fine if the connection was closed by the other side before
306− bs <- B.hGetSome h defaultChunkSize
395+ -- receiving close_notify, see RFC 5246 section 7.2.1.
307− unless (B.null bs) $ do
396+ handleJust
308− let x = B.take remaining bs
397+ (\e -> guard (e == ConnectionClosedByPeer) >> return e)
309− TLS.sendData ctx $ L.fromChunks [x]
398+ (const (return ()))
310− void $ tickle' -- This tickles the Timer. It MUST be called per chunk.
399+ (TLS.bye ctx)
311− loop h $ remaining - B.length x
400+
312−
401+ -- TLS version of recv with a cache for leftover input data.
313− close = freeBuffer readBuf `finally`
402+ -- The cache is shared with recvBuf.
314− freeBuffer writeBuf `finally`
403+ recv cref = do
315− void (tryIO $ TLS.bye ctx) `finally`
404+ cached <- I.readIORef cref
316− TLS.contextClose ctx
405+ if cached /= "" then do
317−
406+ I.writeIORef cref ""
411+ -- TLS version of recv (decrypting) without a cache.
318− recv = handle onEOF go
412+ recv' = handle onEOF go
321− | Just TLS.Error_EOF <- fromException e = return B.empty
415+ | Just TLS.Error_EOF <- fromException e = return S.empty
322− | Just ioe <- fromException e, isEOFError ioe = return B.empty | otherwise = throwIO e
416+ | Just ioe <- fromException e, isEOFError ioe = return S.empty | otherwise = throwIO e
324 x <- TLS.recvData ctx
418 x <- TLS.recvData ctx
325− if B.null x then
419+ if S.null x then
424+ -- TLS version of recvBuf with a cache for leftover input data.
425+ recvBuf cref buf siz = do
426+ cached <- I.readIORef cref
427+ (ret, leftover) <- fill cached buf siz recv'
428+ I.writeIORef cref leftover
431+fill :: S.ByteString -> Buffer -> BufSize -> Recv -> IO (Bool,S.ByteString)
432+fill bs0 buf0 siz0 recv
434+ let (bs, leftover) = S.splitAt siz0 bs0
436+ return (True, leftover)
438+ buf <- copy buf0 bs0
439+ loop buf (siz0 - len0)
442+ loop _ 0 = return (True, "")
445+ let len = S.length bs
446+ if len == 0 then return (False, "")
447+ else if (len <= siz) then do
449+ loop buf' (siz - len)
451+ let (bs1,bs2) = S.splitAt siz bs
330getTLSinfo :: TLS.Context -> IO Transport
455getTLSinfo :: TLS.Context -> IO Transport
331getTLSinfo ctx = do
456getTLSinfo ctx = do
332 proto <- TLS.getNegotiatedProtocol ctx
457 proto <- TLS.getNegotiatedProtocol ctx
@@ -340,11 +465,16 @@ getTLSinfo ctx = do
340 TLS.TLS10 -> (3,1)
465 TLS.TLS10 -> (3,1)
341 TLS.TLS11 -> (3,2)
466 TLS.TLS11 -> (3,2)
342 TLS.TLS12 -> (3,3)
467 TLS.TLS12 -> (3,3)
468+#if MIN_VERSION_tls(1,5,0)
471+ clientCert <- TLS.getClientCertificateChain ctx
343 return TLS {
472 return TLS {
344 tlsMajorVersion = major
473 tlsMajorVersion = major
345 , tlsMinorVersion = minor
474 , tlsMinorVersion = minor
346 , tlsNegotiatedProtocol = proto
475 , tlsNegotiatedProtocol = proto
347 , tlsChiperID = TLS.cipherID infoCipher
476 , tlsChiperID = TLS.cipherID infoCipher
477+ , tlsClientCertificate = clientCert
350tryIO :: IO a -> IO (Either IOException a)
480tryIO :: IO a -> IO (Either IOException a)
@@ -352,52 +482,46 @@ tryIO = try
353----------------------------------------------------------------
483----------------------------------------------------------------
355−plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Transport)
485+plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)
356−plainHTTP TLSSettings{..} s cachedRef = case onInsecure of
486+plainHTTP TLSSettings{..} set s bs0 = case onInsecure of
357 AllowInsecure -> do
487 AllowInsecure -> do
358− conn' <- socketConnection s
488+ conn' <- socketConnection set s
489+ cachedRef <- I.newIORef bs0
359 let conn'' = conn'
490 let conn'' = conn'
360 { connRecv = recvPlain cachedRef (connRecv conn')
491 { connRecv = recvPlain cachedRef (connRecv conn')
362 return (conn'', TCP)
493 return (conn'', TCP)
363 DenyInsecure lbs -> do
494 DenyInsecure lbs -> do
495+ -- Listening port 443 but TLS records do not arrive.
496+ -- We want to let the browser know that TLS is required.
498+ -- http://tools.ietf.org/html/rfc2817#section-4.2
499+ -- https://tools.ietf.org/html/rfc7231#section-6.5.15
500+ -- FIXME: should we distinguish HTTP/1.1 and HTTP/2?
501+ -- In the case of HTTP/2, should we send
502+ -- GOAWAY + INADEQUATE_SECURITY?
503+ -- FIXME: Content-Length:
504+ -- FIXME: TLS/<version>
505+ sendAll s "HTTP/1.1 426 Upgrade Required\
506+ \r\nUpgrade: TLS/1.0, HTTP/1.1\
507+ \r\nConnection: Upgrade\
364− sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"
508+ \r\nContent-Type: text/plain\r\n\r\n"
365 mapM_ (sendAll s) $ L.toChunks lbs
509 mapM_ (sendAll s) $ L.toChunks lbs
366− sClose s
510+ close s
367 throwIO InsecureConnectionDenied
511 throwIO InsecureConnectionDenied
369----------------------------------------------------------------
513----------------------------------------------------------------
371−recvTLS :: I.IORef B.ByteString -> Socket -> Int -> IO B.ByteString
372−recvTLS cachedRef s size = do
373− cached <- I.readIORef cachedRef
376− loop bs | B.length bs >= size = do
377− let (x, y) = B.splitAt size bs
378− I.writeIORef cachedRef y
381− bs2 <- safeRecv s 4096
382− if B.null bs2 then do
383− -- FIXME does this deserve an exception being thrown?
384− I.writeIORef cachedRef B.empty
387− loop $ B.append bs1 bs2
389−----------------------------------------------------------------
391-- | Modify the given receive function to first check the given @IORef@ for a
515-- | Modify the given receive function to first check the given @IORef@ for a
392-- chunk of data. If present, takes the chunk of data from the @IORef@ and
516-- chunk of data. If present, takes the chunk of data from the @IORef@ and
393-- empties out the @IORef@. Otherwise, calls the supplied receive function.
517-- empties out the @IORef@. Otherwise, calls the supplied receive function.
394−recvPlain :: I.IORef B.ByteString -> IO B.ByteString -> IO B.ByteString
518+recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString
395recvPlain ref fallback = do
519recvPlain ref fallback = do
396 bs <- I.readIORef ref
520 bs <- I.readIORef ref
397− if B.null bs
521+ if S.null bs
398 then fallback
522 then fallback
400− I.writeIORef ref B.empty
524+ I.writeIORef ref S.empty
401 return bs
525 return bs
403----------------------------------------------------------------
527----------------------------------------------------------------