94ae923 · typeable/wai

git.iko.soy/typeable/wai

Fix isSecure in warp-tls #245

commit94ae92399b71f35c7c5d071e2a63ecac8cfed619 authorMichael Snoyman <michael@snoyman.com> dateTue 8 Apr 2014, 19:03 (13 years ago) parentfa25d19

6 files changed+29−14

compare with master

unifiedsplit

warp-tls/Network/Wai/Handler/WarpTLS.hs+4−4 warp-tls/pong.hs+4−1 warp-tls/warp-tls.cabal+2−2 warp/Network/Wai/Handler/Warp.hs+1 warp/Network/Wai/Handler/Warp/Run.hs+17−6 warp/warp.cabal+1−1

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

@@ -121,7 +121,7 @@ runTLSSocket TLSSettings {..} set sock app = do

121121 { TLS.sharedCredentials = TLS.Credentials [credential]

122122 }

123123 }

124− runSettingsConnectionMaker set (getter params) app

124+ runSettingsConnectionMakerSecure set (getter params) app

125125 where

126126 getter params = do

127127 (s, sa) <- acceptSafe sock

@@ -171,14 +171,14 @@ runTLSSocket TLSSettings {..} set sock app = do

171171 , connBuffer = buf

172172 , connBufferSize = bufferSize

173173 }

174− return conn

174+ return (conn, True)

175175 else

176176 case onInsecure of

177177 AllowInsecure -> do

178178 conn' <- socketConnection s

179− return conn'

179+ return (conn'

180180 { connRecv = getNext $ fmap (fromMaybe B.empty) C.await

181− }

181+ }, False)

182182 DenyInsecure lbs -> do

183183 let src = do

184184 C.yield "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\n\r\n"

warp-tls/pong.hs+4−1

@@ -13,7 +13,9 @@ import Network.HTTP.Conduit

1313main = do

1414 putStrLn "https://localhost:3009/"

1515 --manager <- newManager def

16− runTLS (tlsSettings "certificate.pem" "key.pem") defaultSettings { settingsPort = 3009 } app

16+ runTLS (tlsSettings "certificate.pem" "key.pem")

17+ { onInsecure = AllowInsecure

18+ } defaultSettings { settingsPort = 3009 } app

1719

1820app req = return $

1921 case rawPathInfo req of

@@ -23,6 +25,7 @@ app req = return $

2325 "/file/nolen" -> fileNoLen

2426 "/source/withlen" -> sourceWithLen

2527 "/source/nolen" -> sourceNoLen

28+ "/secure" -> responseLBS status200 [] $ if isSecure req then "secure" else "insecure"

2629 x -> index x

2730

2831builderWithLen = responseBuilder

warp-tls/warp-tls.cabal+2−2

@@ -1,5 +1,5 @@

11Name: warp-tls

2−Version: 2.0.3.2

2+Version: 2.0.3.3

33Synopsis: HTTP over SSL/TLS support for Warp via the TLS package

44License: MIT

55License-file: LICENSE

@@ -16,7 +16,7 @@ Library

1616 Build-Depends: base >= 4 && < 5

1717 , bytestring >= 0.9

1818 , wai >= 2.0 && < 2.2

19− , warp >= 2.0.2 && < 2.2

19+ , warp >= 2.1.4 && < 2.2

2020 , transformers >= 0.2

2121 , conduit >= 0.5 && < 1.2

2222 , conduit-extra

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

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

2323 , runSettingsSocket

2424 , runSettingsConnection

2525 , runSettingsConnectionMaker

26+ , runSettingsConnectionMakerSecure

2627 -- * Settings

2728 , Settings

2829 , defaultSettings

warp/Network/Wai/Handler/Warp/Run.hs+17−6

@@ -1,6 +1,7 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TupleSections #-}

45{-# OPTIONS_GHC -fno-warn-deprecations #-}

67module Network.Wai.Handler.Warp.Run where

@@ -124,10 +125,18 @@ runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMa

124125 (conn, sa) <- getConn

125126 return (return conn, sa)

126127

128+runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()

129+runSettingsConnectionMaker x y =

130+ runSettingsConnectionMakerSecure x (go y)

131+ where

132+ go = fmap (\(a, b) -> (fmap (, False) a, b))

133+

127134-- | Allows you to provide a function which will return a function

128135-- which will return 'Connection'.

129−runSettingsConnectionMaker :: Settings -> IO (IO Connection, SockAddr) -> Application -> IO ()

130−runSettingsConnectionMaker set getConnMaker app = do

136+--

137+-- Since 2.1.4

138+runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Bool), SockAddr) -> Application -> IO ()

139+runSettingsConnectionMakerSecure set getConnMaker app = do

131140 settingsBeforeMainLoop set

132141

133142 -- Note that there is a thorough discussion of the exception safety of the

@@ -175,7 +184,7 @@ runSettingsConnectionMaker set getConnMaker app = do

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

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

177186 -- fact that async exceptions are still masked.

178− bracket mkConn connClose $ \conn' ->

187+ bracket mkConn (connClose . fst) $ \(conn', isSecure') ->

179188

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

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

@@ -195,7 +204,7 @@ runSettingsConnectionMaker set getConnMaker app = do

195204

196205 -- Actually serve this connection.

197206 -- onnClose above ensures the termination of the connection.

198− when goingon $ serveConnection conn ii addr set app

207+ when goingon $ serveConnection conn ii addr isSecure' set app

199208 where

200209 -- FIXME: only IOEception is caught. What about other exceptions?

201210 getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do

@@ -222,10 +231,11 @@ runSettingsConnectionMaker set getConnMaker app = do

222231serveConnection :: Connection

223232 -> InternalInfo

224233 -> SockAddr

234+ -> Bool -- ^ is secure?

225235 -> Settings

226236 -> Application

227237 -> IO ()

228−serveConnection conn ii addr settings app = do

238+serveConnection conn ii addr isSecure' settings app = do

229239 istatus <- newIORef False

230240 recvSendLoop istatus (connSource conn th istatus) `E.catch` \e -> do

231241 sendErrorResponse istatus e

@@ -244,7 +254,8 @@ serveConnection conn ii addr settings app = do

244254 errorResponse e = settingsOnExceptionResponse settings e

245255

246256 recvSendLoop istatus fromClient = do

247− (req, idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient

257+ (req', idxhdr, getSource, leftover') <- recvRequest settings conn ii addr fromClient

258+ let req = req' { isSecure = isSecure' }

248259 intercept' <- settingsIntercept settings req

249260 case intercept' of

250261 Nothing -> do

warp/warp.cabal+1−1

@@ -1,5 +1,5 @@

11Name: warp

2−Version: 2.1.3.4

2+Version: 2.1.4

33Synopsis: A fast, light-weight web server for WAI applications.

44License: MIT

55License-file: LICENSE