@@ -1,68 +1,89 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE OverloadedStrings #-}
23{-# LANGUAGE RankNTypes #-}
34{-# LANGUAGE RecordWildCards #-}
45{-# LANGUAGE DeriveDataTypeable #-}
56{-# LANGUAGE PatternGuards #-}
67
7−-- | HTTP over SSL/TLS support for Warp via the TLS package.
8+-- | HTTP over TLS support for Warp via the TLS package.
9+--
10+-- If HTTP\/2 is negotiated by ALPN, HTTP\/2 over TLS is used.
11+-- Otherwise HTTP\/1.1 over TLS is used.
12+--
13+-- Support for SSL is now obsoleted.
814
915module Network.Wai.Handler.WarpTLS (
1016 -- * Settings
1117 TLSSettings
18+ , defaultTlsSettings
19+ -- * Smart constructors
20+ , tlsSettings
21+ , tlsSettingsMemory
22+ , tlsSettingsChain
23+ , tlsSettingsChainMemory
24+ -- * Accessors
1225 , certFile
1326 , keyFile
14− , onInsecure
1527 , tlsLogging
1628 , tlsAllowedVersions
1729 , tlsCiphers
1830 , tlsWantClientCert
1931 , tlsServerHooks
20− , defaultTlsSettings
21− , tlsSettings
22− , tlsSettingsMemory
32+ , tlsServerDHEParams
33+ , tlsSessionManagerConfig
34+ , onInsecure
2335 , OnInsecure (..)
2436 -- * Runner
2537 , runTLS
2638 , runTLSSocket
2739 -- * Exception
2840 , WarpTLSException (..)
41+ , DH.Params
42+ , DH.generateParams
2943 ) where
3044
31−import qualified Network.TLS as TLS
32−import Network.Wai.Handler.Warp
33−import Network.Wai (Application)
34−import Network.Socket (Socket, sClose, withSocketsDo, SockAddr)
45+import Control.Applicative ((<|>))
46+import Control.Exception (Exception, throwIO, bracket, finally, handle, fromException, try, IOException, onException, SomeException(..), handleJust)
47+import qualified Control.Exception as E
48+import Control.Monad (void, guard)
3549import qualified Data.ByteString as S
3650import qualified Data.ByteString.Lazy as L
37−import Control.Exception (bracket, finally, handle, fromException, try, IOException)
38−import qualified Network.TLS.Extra as TLSExtra
39−import qualified Data.ByteString as B
40−import Data.Streaming.Network (bindPortTCP, acceptSafe, safeRecv)
41−import Control.Applicative ((<$>))
51+import Data.Default.Class (def)
4252import qualified Data.IORef as I
43−import Control.Exception (Exception, throwIO)
53+import Data.Streaming.Network (bindPortTCP, safeRecv)
4454import Data.Typeable (Typeable)
45−import Data.Default.Class (def)
46−import qualified Crypto.Random.AESCtr
47−import Network.Wai.Handler.Warp.Buffer (allocateBuffer, bufferSize, freeBuffer)
55+import Network.Socket (Socket, close, withSocketsDo, SockAddr, accept)
56+#if MIN_VERSION_network(3,1,1)
57+import Network.Socket (gracefulClose)
58+#endif
4859import Network.Socket.ByteString (sendAll)
49−import Control.Monad (unless, void)
50−import Data.ByteString.Lazy.Internal (defaultChunkSize)
51−import qualified System.IO as IO
60+import qualified Network.TLS as TLS
61+import qualified Crypto.PubKey.DH as DH
62+import qualified Network.TLS.Extra as TLSExtra
63+import qualified Network.TLS.SessionManager as SM
64+import Network.Wai (Application)
65+import Network.Wai.Handler.Warp
66+import Network.Wai.Handler.Warp.Internal
5267import System.IO.Error (isEOFError)
5368
5469----------------------------------------------------------------
5570
71+-- | Settings for WarpTLS.
5672data TLSSettings = TLSSettings {
5773 certFile :: FilePath
5874 -- ^ File containing the certificate.
75+ , chainCertFiles :: [FilePath]
76+ -- ^ Files containing chain certificates.
5977 , keyFile :: FilePath
78+ -- ^ File containing the key
6079 , certMemory :: Maybe S.ByteString
80+ , chainCertsMemory :: [S.ByteString]
6181 , keyMemory :: Maybe S.ByteString
62− -- ^ File containing the key
6382 , onInsecure :: OnInsecure
64− -- ^ Do we allow insecure connections with this server as well? Default
65− -- is a simple text response stating that a secure connection is required.
83+ -- ^ Do we allow insecure connections with this server as well?
84+ --
85+ -- >>> onInsecure defaultTlsSettings
86+ -- DenyInsecure "This server only accepts secure HTTPS connections."
6687 --
6788 -- Since 1.4.0
6889 , tlsLogging :: TLS.Logging
@@ -72,79 +93,109 @@ data TLSSettings = TLSSettings {
7293 --
7394 -- Since 1.4.0
7495 , tlsAllowedVersions :: [TLS.Version]
96+#if MIN_VERSION_tls(1,5,0)
7597 -- ^ The TLS versions this server accepts.
7698 --
77− -- Default: '[TLS.TLS10,TLS.TLS11,TLS.TLS12]'.
99+ -- >>> tlsAllowedVersions defaultTlsSettings
100+ -- [TLS13,TLS12,TLS11,TLS10]
78101 --
79102 -- Since 1.4.2
103+#else
104+ -- ^ The TLS versions this server accepts.
105+ --
106+ -- >>> tlsAllowedVersions defaultTlsSettings
107+ -- [TLS12,TLS11,TLS10]
108+ --
109+ -- Since 1.4.2
110+#endif
80111 , tlsCiphers :: [TLS.Cipher]
112+#if MIN_VERSION_tls(1,5,0)
113+ -- ^ The TLS ciphers this server accepts.
114+ --
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]
117+ --
118+ -- Since 1.4.2
119+#else
81120 -- ^ The TLS ciphers this server accepts.
82121 --
83− -- 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]
84124 --
85125 -- Since 1.4.2
126+#endif
86127 , tlsWantClientCert :: Bool
87128 -- ^ Whether or not to demand a certificate from the client. If this
88129 -- is set to True, you must handle received certificates in a server hook
89130 -- or all connections will fail.
90131 --
91− -- Default: False
92− , tlsServerHooks :: TLS.ServerHooks
93− -- ^ Whether or not to demand a certificate from the client. If this
94− -- is set to True, you must handle received certificates in a server hook
95− -- or all connections will fail.
132+ -- >>> tlsWantClientCert defaultTlsSettings
133+ -- False
96134 --
97− -- Default: False
135+ -- Since 3.0.2
98136 , tlsServerHooks :: TLS.ServerHooks
99137 -- ^ The server-side hooks called by the tls package, including actions
100138 -- to take when a client certificate is received. See the "Network.TLS"
101139 -- module for details.
102140 --
103141 -- Default: def
142+ --
143+ -- Since 3.0.2
144+ , tlsServerDHEParams :: Maybe DH.Params
145+ -- ^ Configuration for ServerDHEParams
146+ -- more function lives in `cryptonite` package
147+ --
148+ -- Default: Nothing
149+ --
150+ -- Since 3.2.2
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'.
156+ --
157+ -- Default: Nothing
158+ --
159+ -- Since 3.2.4
104160 }
105161
106−-- | 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).
107163defaultTlsSettings :: TLSSettings
108164defaultTlsSettings = TLSSettings {
109165 certFile = "certificate.pem"
166+ , chainCertFiles = []
110167 , keyFile = "key.pem"
111168 , certMemory = Nothing
169+ , chainCertsMemory = []
112170 , keyMemory = Nothing
113171 , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."
114172 , tlsLogging = def
115− , tlsAllowedVersions = [TLS.TLS10,TLS.TLS11,TLS.TLS12]
173+#if MIN_VERSION_tls(1,5,0)
174+ , tlsAllowedVersions = [TLS.TLS13,TLS.TLS12,TLS.TLS11,TLS.TLS10]
175+#else
176+ , tlsAllowedVersions = [TLS.TLS12,TLS.TLS11,TLS.TLS10]
177+#endif
116178 , tlsCiphers = ciphers
117179 , tlsWantClientCert = False
118180 , tlsServerHooks = def
181+ , tlsServerDHEParams = Nothing
182+ , tlsSessionManagerConfig = Nothing
119183 }
120184
121185-- taken from stunnel example in tls-extra
122186ciphers :: [TLS.Cipher]
123−ciphers =
124− [ TLSExtra.cipher_ECDHE_RSA_AES128GCM_SHA256
125− , TLSExtra.cipher_DHE_RSA_AES128GCM_SHA256
126− , TLSExtra.cipher_DHE_RSA_AES256_SHA256
127− , TLSExtra.cipher_DHE_RSA_AES128_SHA256
128− , TLSExtra.cipher_DHE_RSA_AES256_SHA1
129− , TLSExtra.cipher_DHE_RSA_AES128_SHA1
130− , TLSExtra.cipher_DHE_DSS_AES128_SHA1
131− , TLSExtra.cipher_DHE_DSS_AES256_SHA1
132− , TLSExtra.cipher_DHE_DSS_RC4_SHA1
133− , TLSExtra.cipher_AES128_SHA1
134− , TLSExtra.cipher_AES256_SHA1
135− , TLSExtra.cipher_RC4_128_MD5
136− , TLSExtra.cipher_RC4_128_SHA1
137− ]
187+ciphers = TLSExtra.ciphersuite_strong
138188
139189----------------------------------------------------------------
140190
141191-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.
142192data OnInsecure = DenyInsecure L.ByteString
143193 | AllowInsecure
194+ deriving (Show)
144195
145196----------------------------------------------------------------
146197
147−-- | A smart constructor for 'TLSSettings'.
198+-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'.
148199tlsSettings :: FilePath -- ^ Certificate file
149200 -> FilePath -- ^ Key file
150201 -> TLSSettings
@@ -153,8 +204,23 @@ tlsSettings cert key = defaultTlsSettings {
153204 , keyFile = key
154205 }
155206
207+-- | A smart constructor for 'TLSSettings' that allows specifying
208+-- chain certificates based on 'defaultTlsSettings'.
209+--
210+-- Since 3.0.3
211+tlsSettingsChain
212+ :: FilePath -- ^ Certificate file
213+ -> [FilePath] -- ^ Chain certificate files
214+ -> FilePath -- ^ Key file
215+ -> TLSSettings
216+tlsSettingsChain cert chainCerts key = defaultTlsSettings {
217+ certFile = cert
218+ , chainCertFiles = chainCerts
219+ , keyFile = key
220+ }
221+
156222-- | A smart constructor for 'TLSSettings', but uses in-memory representations
157−-- of the certificate and key
223+-- of the certificate and key based on 'defaultTlsSettings'.
158224--
159225-- Since 3.0.1
160226tlsSettingsMemory
@@ -166,15 +232,29 @@ tlsSettingsMemory cert key = defaultTlsSettings
166232 , keyMemory = Just key
167233 }
168234
169−----------------------------------------------------------------
235+-- | A smart constructor for 'TLSSettings', but uses in-memory representations
236+-- of the certificate and key based on 'defaultTlsSettings'.
237+--
238+-- Since 3.0.3
239+tlsSettingsChainMemory
240+ :: S.ByteString -- ^ Certificate bytes
241+ -> [S.ByteString] -- ^ Chain certificate bytes
242+ -> S.ByteString -- ^ Key bytes
243+ -> TLSSettings
244+tlsSettingsChainMemory cert chainCerts key = defaultTlsSettings
245+ { certMemory = Just cert
246+ , chainCertsMemory = chainCerts
247+ , keyMemory = Just key
248+ }
170249
250+----------------------------------------------------------------
171251
172252-- | Running 'Application' with 'TLSSettings' and 'Settings'.
173253runTLS :: TLSSettings -> Settings -> Application -> IO ()
174254runTLS tset set app = withSocketsDo $
175255 bracket
176256 (bindPortTCP (getPort set) (getHost set))
177− sClose
257+ close
178258 (\sock -> runTLSSocket tset set sock app)
179259
180260----------------------------------------------------------------
@@ -184,109 +264,194 @@ runTLS tset set app = withSocketsDo $
184264runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()
185265runTLSSocket tlsset@TLSSettings{..} set sock app = do
186266 credential <- case (certMemory, keyMemory) of
187− (Nothing, Nothing) -> either error id <$> TLS.credentialLoadX509 certFile keyFile
267+ (Nothing, Nothing) ->
268+ either error id <$>
269+ TLS.credentialLoadX509Chain certFile chainCertFiles keyFile
188270 (mcert, mkey) -> do
189271 cert <- maybe (S.readFile certFile) return mcert
190272 key <- maybe (S.readFile keyFile) return mkey
191− either error return $ TLS.credentialLoadX509FromMemory cert key
192− runTLSSocket' tlsset set credential sock app
193−
194−runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> Socket -> Application -> IO ()
195−runTLSSocket' tlsset@TLSSettings{..} set credential sock app =
273+ either error return $
274+ TLS.credentialLoadX509ChainFromMemory cert chainCertsMemory key
275+ mgr <- case tlsSessionManagerConfig of
276+ Nothing -> return TLS.noSessionManager
277+ Just config -> SM.newSessionManager config
278+ runTLSSocket' tlsset set credential mgr sock app
279+
280+runTLSSocket' :: TLSSettings -> Settings -> TLS.Credential -> TLS.SessionManager -> Socket -> Application -> IO ()
281+runTLSSocket' tlsset@TLSSettings{..} set credential mgr sock app =
196282 runSettingsConnectionMakerSecure set get app
197283 where
198− get = getter tlsset sock params
199− params = def {
284+ get = getter tlsset set sock params
285+ params = def { -- TLS.ServerParams
200286 TLS.serverWantClientCert = tlsWantClientCert
201− , TLS.serverSupported = def {
202− TLS.supportedVersions = tlsAllowedVersions
203− , TLS.supportedCiphers = tlsCiphers
204− }
205− , TLS.serverShared = def {
206− TLS.sharedCredentials = TLS.Credentials [credential]
207− }
208− , TLS.serverHooks = tlsServerHooks
287+ , TLS.serverCACertificates = []
288+ , TLS.serverDHEParams = tlsServerDHEParams
289+ , TLS.serverHooks = hooks
290+ , TLS.serverShared = shared
291+ , TLS.serverSupported = supported
292+#if MIN_VERSION_tls(1,5,0)
293+ , TLS.serverEarlyDataSize = 2018
294+#endif
295+ }
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)
300+ }
301+ shared = def {
302+ TLS.sharedCredentials = TLS.Credentials [credential]
303+ , TLS.sharedSessionManager = mgr
304+ }
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]
315+#endif
209316 }
210317
211−----------------------------------------------------------------
318+alpn :: [S.ByteString] -> IO S.ByteString
319+alpn xs
320+ | "h2" `elem` xs = return "h2"
321+ | otherwise = return "http/1.1"
212322
213−getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)
214−getter tlsset@TLSSettings{..} sock params = do
215− (s, sa) <- acceptSafe sock
216− return (mkConn tlsset s params, sa)
323+----------------------------------------------------------------
217324
218−mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport)
219−mkConn tlsset s params = do
220− firstBS <- safeRecv s 4096
221− cachedRef <- I.newIORef firstBS
222− if not (B.null firstBS) && B.head firstBS == 0x16 then
223− httpOverTls tlsset s cachedRef params
224− else
225− plainHTTP tlsset s cachedRef
325+getter :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)
326+getter tlsset@TLSSettings{..} set sock params = do
327+#if WINDOWS
328+ (s, sa) <- windowsThreadBlockHack $ accept sock
329+#else
330+ (s, sa) <- accept sock
331+#endif
332+ setSocketCloseOnExec s
333+ return (mkConn tlsset set s params, sa)
334+
335+mkConn :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> params -> IO (Connection, Transport)
336+mkConn tlsset set s params = switch `onException` close s
337+ where
338+ switch = do
339+ firstBS <- safeRecv s 4096
340+ if not (S.null firstBS) && S.head firstBS == 0x16 then
341+ httpOverTls tlsset set s firstBS params
342+ else
343+ plainHTTP tlsset set s firstBS
226344
227345----------------------------------------------------------------
228346
229−httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Transport)
230−httpOverTls TLSSettings{..} s cachedRef params = do
231− gen <- Crypto.Random.AESCtr.makeSystem
232− ctx <- TLS.contextNew backend params gen
347+httpOverTls :: TLS.TLSParams params => TLSSettings -> Settings -> Socket -> S.ByteString -> params -> IO (Connection, Transport)
348+httpOverTls TLSSettings{..} _set s bs0 params = do
349+ recvN <- makePlainReceiveN s bs0
350+ ctx <- TLS.contextNew (backend recvN) params
233351 TLS.contextHookSetLogging ctx tlsLogging
234352 TLS.handshake ctx
235− readBuf <- allocateBuffer bufferSize
353+ h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx
354+ isH2 <- I.newIORef h2
236355 writeBuf <- allocateBuffer bufferSize
356+ -- Creating a cache for leftover input data.
357+ ref <- I.newIORef ""
237358 tls <- getTLSinfo ctx
238− return (conn ctx readBuf writeBuf, tls)
359+ return (conn ctx writeBuf ref isH2, tls)
239360 where
240− backend = TLS.Backend {
361+ backend recvN = TLS.Backend {
241362 TLS.backendFlush = return ()
242− , TLS.backendClose = sClose s
243− , TLS.backendSend = sendAll s
244− , TLS.backendRecv = recvTLS cachedRef s
363+#if MIN_VERSION_network(3,1,1)
364+ , TLS.backendClose = gracefulClose s 5000 `E.catch` \(SomeException _) -> return ()
365+#else
366+ , TLS.backendClose = close s
367+#endif
368+ , TLS.backendSend = sendAll' s
369+ , TLS.backendRecv = recvN
245370 }
246− conn ctx readBuf writeBuf = Connection {
371+ sendAll' sock bs = sendAll sock bs `E.catch` \(SomeException _) ->
372+ throwIO ConnectionClosedByPeer
373+ conn ctx writeBuf ref isH2 = Connection {
247374 connSendMany = TLS.sendData ctx . L.fromChunks
248− , connSendAll = TLS.sendData ctx . L.fromChunks . return
375+ , connSendAll = sendall
249376 , connSendFile = sendfile
250− , connClose = close
251− , connRecv = recv
252− , connSendFileOverride = NotOverride
253− , connReadBuffer = readBuf
377+ , connClose = close'
378+ , connFree = freeBuffer writeBuf
379+ , connRecv = recv ref
380+ , connRecvBuf = recvBuf ref
254381 , connWriteBuffer = writeBuf
255382 , connBufferSize = bufferSize
383+ , connHTTP2 = isH2
256384 }
257385 where
258− sendfile fp offset len tickle' headers = do
259− TLS.sendData ctx $ L.fromChunks headers
260− IO.withBinaryFile fp IO.ReadMode $ \h -> do
261− IO.hSeek h IO.AbsoluteSeek offset
262− loop h $ fromIntegral len
263− where
264− loop _ remaining | remaining <= 0 = return ()
265− loop h remaining = do
266− bs <- B.hGetSome h defaultChunkSize
267− unless (B.null bs) $ do
268− let x = B.take remaining bs
269− TLS.sendData ctx $ L.fromChunks [x]
270− void $ tickle' -- This tickles the Timer. It MUST be called per chunk.
271− loop h $ remaining - B.length x
272−
273− close = freeBuffer readBuf `finally`
274− freeBuffer writeBuf `finally`
275− void (tryIO $ TLS.bye ctx) `finally`
276− TLS.contextClose ctx
277−
278− recv = handle onEOF go
386+ sendall = TLS.sendData ctx . L.fromChunks . return
387+ sendfile fid offset len hook headers =
388+ readSendFile writeBuf bufferSize sendall fid offset len hook headers
389+
390+ close' = void (tryIO sendBye) `finally`
391+ TLS.contextClose ctx
392+
393+ sendBye =
394+ -- It's fine if the connection was closed by the other side before
395+ -- receiving close_notify, see RFC 5246 section 7.2.1.
396+ handleJust
397+ (\e -> guard (e == ConnectionClosedByPeer) >> return e)
398+ (const (return ()))
399+ (TLS.bye ctx)
400+
401+ -- TLS version of recv with a cache for leftover input data.
402+ -- The cache is shared with recvBuf.
403+ recv cref = do
404+ cached <- I.readIORef cref
405+ if cached /= "" then do
406+ I.writeIORef cref ""
407+ return cached
408+ else
409+ recv'
410+
411+ -- TLS version of recv (decrypting) without a cache.
412+ recv' = handle onEOF go
279413 where
280414 onEOF e
281− | Just TLS.Error_EOF <- fromException e = return B.empty
282− | Just ioe <- fromException e, isEOFError ioe = return B.empty | otherwise = throwIO e
415+ | Just TLS.Error_EOF <- fromException e = return S.empty
416+ | Just ioe <- fromException e, isEOFError ioe = return S.empty | otherwise = throwIO e
283417 go = do
284418 x <- TLS.recvData ctx
285− if B.null x then
419+ if S.null x then
286420 go
287421 else
288422 return x
289423
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
429+ return ret
430+
431+fill :: S.ByteString -> Buffer -> BufSize -> Recv -> IO (Bool,S.ByteString)
432+fill bs0 buf0 siz0 recv
433+ | siz0 <= len0 = do
434+ let (bs, leftover) = S.splitAt siz0 bs0
435+ void $ copy buf0 bs
436+ return (True, leftover)
437+ | otherwise = do
438+ buf <- copy buf0 bs0
439+ loop buf (siz0 - len0)
440+ where
441+ len0 = S.length bs0
442+ loop _ 0 = return (True, "")
443+ loop buf siz = do
444+ bs <- recv
445+ let len = S.length bs
446+ if len == 0 then return (False, "")
447+ else if (len <= siz) then do
448+ buf' <- copy buf bs
449+ loop buf' (siz - len)
450+ else do
451+ let (bs1,bs2) = S.splitAt siz bs
452+ void $ copy buf bs1
453+ return (True, bs2)
454+
290455getTLSinfo :: TLS.Context -> IO Transport
291456getTLSinfo ctx = do
292457 proto <- TLS.getNegotiatedProtocol ctx
@@ -300,11 +465,16 @@ getTLSinfo ctx = do
300465 TLS.TLS10 -> (3,1)
301466 TLS.TLS11 -> (3,2)
302467 TLS.TLS12 -> (3,3)
468+#if MIN_VERSION_tls(1,5,0)
469+ TLS.TLS13 -> (3,4)
470+#endif
471+ clientCert <- TLS.getClientCertificateChain ctx
303472 return TLS {
304473 tlsMajorVersion = major
305474 , tlsMinorVersion = minor
306475 , tlsNegotiatedProtocol = proto
307476 , tlsChiperID = TLS.cipherID infoCipher
477+ , tlsClientCertificate = clientCert
308478 }
309479
310480tryIO :: IO a -> IO (Either IOException a)
@@ -312,52 +482,46 @@ tryIO = try
312482
313483----------------------------------------------------------------
314484
315−plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Transport)
316−plainHTTP TLSSettings{..} s cachedRef = case onInsecure of
485+plainHTTP :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)
486+plainHTTP TLSSettings{..} set s bs0 = case onInsecure of
317487 AllowInsecure -> do
318− conn' <- socketConnection s
488+ conn' <- socketConnection set s
489+ cachedRef <- I.newIORef bs0
319490 let conn'' = conn'
320491 { connRecv = recvPlain cachedRef (connRecv conn')
321492 }
322493 return (conn'', TCP)
323494 DenyInsecure lbs -> do
324− sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"
495+ -- Listening port 443 but TLS records do not arrive.
496+ -- We want to let the browser know that TLS is required.
497+ -- So, we use 426.
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\
508+ \r\nContent-Type: text/plain\r\n\r\n"
325509 mapM_ (sendAll s) $ L.toChunks lbs
326− sClose s
510+ close s
327511 throwIO InsecureConnectionDenied
328512
329513----------------------------------------------------------------
330514
331−recvTLS :: I.IORef B.ByteString -> Socket -> Int -> IO B.ByteString
332−recvTLS cachedRef s size = do
333− cached <- I.readIORef cachedRef
334− loop cached
335− where
336− loop bs | B.length bs >= size = do
337− let (x, y) = B.splitAt size bs
338− I.writeIORef cachedRef y
339− return x
340− loop bs1 = do
341− bs2 <- safeRecv s 4096
342− if B.null bs2 then do
343− -- FIXME does this deserve an exception being thrown?
344− I.writeIORef cachedRef B.empty
345− return bs1
346− else
347− loop $ B.append bs1 bs2
348−
349−----------------------------------------------------------------
350−
351515-- | Modify the given receive function to first check the given @IORef@ for a
352516-- chunk of data. If present, takes the chunk of data from the @IORef@ and
353517-- empties out the @IORef@. Otherwise, calls the supplied receive function.
354−recvPlain :: I.IORef B.ByteString -> IO B.ByteString -> IO B.ByteString
518+recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString
355519recvPlain ref fallback = do
356520 bs <- I.readIORef ref
357− if B.null bs
521+ if S.null bs
358522 then fallback
359523 else do
360− I.writeIORef ref B.empty
524+ I.writeIORef ref S.empty
361525 return bs
362526
363527----------------------------------------------------------------