02e2120 · typeable/wai

git.iko.soy/typeable/wai

changing the type of runSettingsConnectionMakerSecure #302

commit02e21202cbe80ec99a3a1f190475f7518b0c7787 authorKazu Yamamoto <kazu@iij.ad.jp> dateWed 4 Feb 2015, 21:23 (12 years ago) parent49928b8

4 files changed+58−20

compare with master

unifiedsplit

warp-tls/Network/Wai/Handler/WarpTLS.hs+28−7 warp/Network/Wai/Handler/Warp.hs+1 warp/Network/Wai/Handler/Warp/Run.hs+10−10 warp/Network/Wai/Handler/Warp/Types.hs+19−3

warp-tls/Network/Wai/Handler/WarpTLS.hs+28−7

@@ -182,17 +182,17 @@ runTLSSocket' tlsset@TLSSettings{..} set credential sock app =

182182 }

183183 , TLS.serverShared = def {

184184 TLS.sharedCredentials = TLS.Credentials [credential]

185− }

185+ }

186186 }

187187

188188----------------------------------------------------------------

189189

190−getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Bool), SockAddr)

190+getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)

191191getter tlsset@TLSSettings{..} sock params = do

192192 (s, sa) <- acceptSafe sock

193193 return (mkConn tlsset s params, sa)

194194

195−mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Bool)

195+mkConn :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (Connection, Transport)

196196mkConn tlsset s params = do

197197 firstBS <- safeRecv s 4096

198198 cachedRef <- I.newIORef firstBS

@@ -203,7 +203,7 @@ mkConn tlsset s params = do

203203

204204----------------------------------------------------------------

205205

206−httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Bool)

206+httpOverTls :: TLS.TLSParams params => TLSSettings -> Socket -> I.IORef B.ByteString -> params -> IO (Connection, Transport)

207207httpOverTls TLSSettings{..} s cachedRef params = do

208208 gen <- Crypto.Random.AESCtr.makeSystem

209209 ctx <- TLS.contextNew backend params gen

@@ -211,7 +211,8 @@ httpOverTls TLSSettings{..} s cachedRef params = do

211211 TLS.handshake ctx

212212 readBuf <- allocateBuffer bufferSize

213213 writeBuf <- allocateBuffer bufferSize

214− return (conn ctx readBuf writeBuf, True)

214+ tls <- getTLSinfo ctx

215+ return (conn ctx readBuf writeBuf, tls)

215216 where

216217 backend = TLS.Backend {

217218 TLS.backendFlush = return ()

@@ -263,19 +264,39 @@ httpOverTls TLSSettings{..} s cachedRef params = do

263264 else

264265 return x

265266

267+getTLSinfo :: TLS.Context -> IO Transport

268+getTLSinfo ctx = do

269+ proto <- TLS.getNegotiatedProtocol ctx

270+ minfo <- TLS.contextGetInformation ctx

271+ case minfo of

272+ Nothing -> return TCP

273+ Just TLS.Information{..} -> do

274+ let (major, minor) = case infoVersion of

275+ TLS.SSL2 -> (2,0)

276+ TLS.SSL3 -> (3,0)

277+ TLS.TLS10 -> (3,1)

278+ TLS.TLS11 -> (3,2)

279+ TLS.TLS12 -> (3,3)

280+ return TLS {

281+ tlsMajorVersion = major

282+ , tlsMinorVersion = minor

283+ , tlsNegotiatedProtocol = proto

284+ , tlsChiperID = TLS.cipherID infoCipher

285+ }

286+

266287tryIO :: IO a -> IO (Either IOException a)

267288tryIO = try

268289

269290----------------------------------------------------------------

270291

271−plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Bool)

292+plainHTTP :: TLSSettings -> Socket -> I.IORef B.ByteString -> IO (Connection, Transport)

272293plainHTTP TLSSettings{..} s cachedRef = case onInsecure of

273294 AllowInsecure -> do

274295 conn' <- socketConnection s

275296 let conn'' = conn'

276297 { connRecv = recvPlain cachedRef (connRecv conn')

277298 }

278− return (conn'', False)

299+ return (conn'', TCP)

279300 DenyInsecure lbs -> do

280301 sendAll s "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"

281302 mapM_ (sendAll s) $ L.toChunks lbs

warp/Network/Wai/Handler/Warp.hs+1

@@ -67,6 +67,7 @@ module Network.Wai.Handler.Warp (

6767 , exceptionResponseForDebug

6868 , defaultShouldDisplayException

6969 -- * Data types

70+ , Transport (..)

7071 , HostPreference (..)

7172 , Port

7273 , InvalidRequest (..)

warp/Network/Wai/Handler/Warp/Run.hs+10−10

@@ -124,7 +124,7 @@ runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Applic

124124runSettingsConnectionMaker x y =

125125 runSettingsConnectionMakerSecure x (go y)

126126 where

127− go = fmap (first (fmap (, False)))

127+ go = fmap (first (fmap (, TCP)))

128128

129129----------------------------------------------------------------

130130

@@ -132,7 +132,7 @@ runSettingsConnectionMaker x y =

132132-- which will return 'Connection'.

133133--

134134-- Since 2.1.4

135−runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Bool), SockAddr) -> Application -> IO ()

135+runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()

136136runSettingsConnectionMakerSecure set getConnMaker app = do

137137 settingsBeforeMainLoop set

138138 counter <- newCounter

@@ -169,7 +169,7 @@ onE set mreq e = case fromException e of

169169--

170170-- Our approach is explained in the comments below.

171171acceptConnection :: Settings

172− -> IO (IO (Connection, Bool), SockAddr)

172+ -> IO (IO (Connection, Transport), SockAddr)

173173 -> Application

174174 -> D.DateCache

175175 -> Maybe F.MutableFdCache

@@ -220,7 +220,7 @@ acceptConnection set getConnMaker app dc fc tm counter = do

220220-- Fork a new worker thread for this connection maker, and ask for a

221221-- function to unmask (i.e., allow async exceptions to be thrown).

222222fork :: Settings

223− -> IO (Connection, Bool)

223+ -> IO (Connection, Transport)

224224 -> SockAddr

225225 -> Application

226226 -> D.DateCache

@@ -239,7 +239,7 @@ fork set mkConn addr app dc fc tm counter = settingsFork set $ \ unmask ->

239239 -- We grab the connection before registering timeouts since the

240240 -- timeouts will be useless during connection creation, due to the

241241 -- fact that async exceptions are still masked.

242− bracket mkConn closeConn $ \(conn0, isSecure') ->

242+ bracket mkConn closeConn $ \(conn0, transport) ->

243243

244244 -- We need to register a timeout handler for this thread, and

245245 -- cancel that handler as soon as we exit.

@@ -260,9 +260,9 @@ fork set mkConn addr app dc fc tm counter = settingsFork set $ \ unmask ->

260260

261261 -- Actually serve this connection.

262262 -- bracket with closeConn above ensures the connection is closed.

263− when goingon $ serveConnection conn ii addr isSecure' set app

263+ when goingon $ serveConnection conn ii addr transport set app

264264 where

265− closeConn (conn, _isSecure) = connClose conn

265+ closeConn (conn, _transport) = connClose conn

266266

267267 onOpen adr = increase counter >> settingsOnOpen set adr

268268 onClose adr _ = decrease counter >> settingsOnClose set adr

@@ -270,11 +270,11 @@ fork set mkConn addr app dc fc tm counter = settingsFork set $ \ unmask ->

270270serveConnection :: Connection

271271 -> InternalInfo

272272 -> SockAddr

273− -> Bool -- ^ is secure?

273+ -> Transport

274274 -> Settings

275275 -> Application

276276 -> IO ()

277−serveConnection conn ii origAddr isSecure' settings app = do

277+serveConnection conn ii origAddr transport settings app = do

278278 istatus <- newIORef False

279279 src <- mkSource (connSource conn th istatus)

280280 addr <- getProxyProtocolAddr src

@@ -338,7 +338,7 @@ serveConnection conn ii origAddr isSecure' settings app = do

338338

339339 http1 addr istatus src = do

340340 (req', mremainingRef, idxhdr) <- recvRequest settings conn ii addr src

341− let req = req' { isSecure = isSecure' }

341+ let req = req' { isSecure = isTransportSecure transport }

342342 keepAlive <- processRequest istatus src req mremainingRef idxhdr

343343 `E.catch` \e -> do

344344 -- Call the user-supplied exception handlers, passing the request.

warp/Network/Wai/Handler/Warp/Types.hs+19−3

@@ -6,15 +6,16 @@ module Network.Wai.Handler.Warp.Types where

77import Control.Exception

88import Data.ByteString (ByteString)

9+import qualified Data.ByteString as S

10+import Data.IORef (IORef, readIORef, writeIORef, newIORef)

911import Data.Typeable (Typeable)

12+import Data.Word (Word16)

1013import Network.HTTP.Types.Header

1114import Network.Socket (Socket)

15+import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize)

1216import qualified Network.Wai.Handler.Warp.Date as D

1317import qualified Network.Wai.Handler.Warp.FdCache as F

1418import qualified Network.Wai.Handler.Warp.Timeout as T

15−import Network.Wai.Handler.Warp.Buffer (Buffer,BufSize)

16−import qualified Data.ByteString as S

17−import Data.IORef (IORef, readIORef, writeIORef, newIORef)

1819

1920----------------------------------------------------------------

2021

@@ -120,3 +121,18 @@ leftoverSource (Source ref _) bs = writeIORef ref bs

120121

121122readLeftoverSource :: Source -> IO ByteString

122123readLeftoverSource (Source ref _) = readIORef ref

124+

125+----------------------------------------------------------------

126+

127+-- | What kind of transport is used for this connection?

128+data Transport = TCP -- ^ Plain channel: TCP

129+ | TLS {

130+ tlsMajorVersion :: Int

131+ , tlsMinorVersion :: Int

132+ , tlsNegotiatedProtocol :: Maybe ByteString -- ^ The result of Application Layer Protocol Negociation in RFC 7301

133+ , tlsChiperID :: Word16

134+ } -- ^ Encrypted channel: TLS or SSL

135+

136+isTransportSecure :: Transport -> Bool

137+isTransportSecure TCP = False

138+isTransportSecure _ = True