git.iko.soy/typeable/wai
on master help sign in
cleaning up InternalInfo.
commit1b0944b52e4d4ef684407b43c90cb59a6084f7a0 authorKazu Yamamoto <kazu@iij.ad.jp> dateWed 5 Jun 2019, 11:26 (7 years ago) parent919eb78
9 files changed+46−87
compare with master
unifiedsplit
warp/Network/Wai/Handler/Warp/HTTP2.hs+4−4 warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hs+4−4 warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+4−8 warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+5−6 warp/Network/Wai/Handler/Warp/Request.hs+5−9 warp/Network/Wai/Handler/Warp/Response.hs+2−2 warp/Network/Wai/Handler/Warp/Run.hs+20−23 warp/Network/Wai/Handler/Warp/Types.hs+1−30 warp/test/FdCacheSpec.hs+1−1
warp/Network/Wai/Handler/Warp/HTTP2.hs+4−4
@@ -22,8 +22,8 @@ import Network.Wai.Handler.Warp.Types
2222
2323----------------------------------------------------------------
2424
25−http2 :: Connection -> InternalInfo1 -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()
26−http2 conn ii1 addr transport settings readN app = do
25+http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()
26+http2 conn ii addr transport settings readN app = do
2727 checkTLS
2828 ok <- checkPreface
2929 when ok $ do
@@ -40,8 +40,8 @@ http2 conn ii1 addr transport settings readN app = do
4040 -- context switches happen.
4141 replicateM_ 3 $ spawnAction mgr
4242 -- Receiver
43− let mkreq = mkRequest ii1 settings addr
44− tid <- forkIO $ frameReceiver ctx mkreq readN
43+ let mkreq = mkRequest ii settings addr
44+ tid <- forkIO $ frameReceiver ctx ii mkreq readN
4545 -- Sender
4646 -- frameSender is the main thread because it ensures to send
4747 -- a goway frame.
warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hs+4−4
@@ -27,8 +27,8 @@ import Network.Wai.Handler.Warp.Types
2727
2828----------------------------------------------------------------
2929
30−frameReceiver :: Context -> MkReq -> (BufSize -> IO ByteString) -> IO ()
31−frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway
30+frameReceiver :: Context -> InternalInfo -> MkReq -> (BufSize -> IO ByteString) -> IO ()
31+frameReceiver ctx ii mkreq recvN = loop 0 `E.catch` sendGoaway
3232 where
3333 Context{ http2settings
3434 , streamTable
@@ -120,7 +120,7 @@ frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway
120120 E.throwIO $ StreamError ProtocolError streamId
121121 writeIORef streamPrecedence $ toPrecedence pri
122122 halfClosedRemote ctx strm
123− (!req, !ii) <- mkreq tbl (Just 0, return "")
123+ !req <- mkreq tbl (Just 0, return "")
124124 atomically $ writeTQueue inputQ $ Input strm req reqvt ii
125125 Open (HasBody tbl@(_,reqvt) pri) -> do
126126 resetContinued
@@ -131,7 +131,7 @@ frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway
131131 setStreamState ctx strm $ Open (Body q mcl bodyLength)
132132 readQ <- newReadBody q
133133 bodySource <- mkSource readQ
134− (!req, !ii) <- mkreq tbl (mcl, readSource bodySource)
134+ !req <- mkreq tbl (mcl, readSource bodySource)
135135 atomically $ writeTQueue inputQ $ Input strm req reqvt ii
136136 s@(Open Continued{}) -> do
137137 setContinued
warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+4−8
@@ -22,23 +22,22 @@ import Network.Wai.Internal (Request(..))
2222import System.IO.Unsafe (unsafePerformIO)
2323
2424import Network.Wai.Handler.Warp.HTTP2.Types
25−import Network.Wai.Handler.Warp.HashMap (hashByteString)
2625import Network.Wai.Handler.Warp.Imports
2726import Network.Wai.Handler.Warp.Request (getFileInfoKey)
2827import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
2928import Network.Wai.Handler.Warp.Types
3029
31−type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request,InternalInfo)
30+type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request)
3231
33−mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq
32+mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq
3433mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do
3534 ref <- newIORef Nothing
3635 mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)
3736
38−mkRequest' :: InternalInfo1 -> S.Settings -> SockAddr
37+mkRequest' :: InternalInfo -> S.Settings -> SockAddr
3938 -> IORef (Maybe HTTP2Data)
4039 -> MkReq
41−mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)
40+mkRequest' ii settings addr ref (reqths,reqvt) (bodylen,body) = return req
4241 where
4342 !req = Request {
4443 requestMethod = colonMethod
@@ -77,9 +76,6 @@ mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body) = return (req,ii)
7776 (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)
7877 !path = H.extractPath unparsedPath
7978 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
80− !h = hashByteString rawPath
81− -- timeout handler must be overwritten with worker's one.
82− !ii = toInternalInfo ii1 h
8379 !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)
8480 $ Vault.insert getHTTP2DataKey (readIORef ref)
8581 $ Vault.insert setHTTP2DataKey (writeIORef ref)
warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+5−6
@@ -44,6 +44,7 @@ import Network.Wai.Handler.Warp.Types
4444-- This type implements the second argument (Response -> IO ResponseReceived)
4545-- with extra arguments.
4646type Responder = InternalInfo
47+ -> T.Handle
4748 -> ValueTable -- for Request
4849 -> ThreadContinue
4950 -> Stream
@@ -118,7 +119,7 @@ pushStream ctx@Context{http2settings,outputQ,streamTable}
118119-- They also pass 'Response's from 'Application's to this function.
119120-- This function enqueues commands for the HTTP/2 sender.
120121response :: S.Settings -> Context -> Manager -> Responder
121−response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of
122+response settings ctx@Context{outputQ} mgr ii th reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of
122123 ResponseStream s0 hs0 strmbdy
123124 | noBody s0 -> responseNoBody s0 hs0
124125 | isHead -> responseNoBody s0 hs0
@@ -141,7 +142,6 @@ response settings ctx@Context{outputQ} mgr ii reqvt tconf strm req rsp = E.handl
141142 noBody = not . R.hasBody
142143 !isHead = requestMethod req == H.methodHead
143144 !logger = S.settingsLogger settings
144− !th = threadHandle ii
145145 sid = streamNumber strm
146146 !h2data = getHTTP2Data req
147147
@@ -245,8 +245,7 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do
245245 setStreamInfo sinfo inp
246246 T.resume th
247247 T.tickle th
248− let !ii' = ii { threadHandle = th }
249− !body = getRequestBodyChunk req
248+ let !body = getRequestBodyChunk req
250249 !body' = do
251250 T.pause th
252251 bs <- body
@@ -254,12 +253,12 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do
254253 return bs
255254 !vaultValue = Vault.insert pauseTimeoutKey (T.pause th) $ vault req
256255 !req' = req { vault = vaultValue, requestBody = body' }
257− mr <- E.try $ app req' $ responder ii' reqvt tcont strm req'
256+ mr <- E.try $ app req' $ responder ii th reqvt tcont strm req'
258257 case mr of
259258 Right ok -> return ok
260259 Left e@(SomeException _)
261260 | Just (ExceptionInsideResponseBody e') <- E.fromException e -> E.throwIO e'
262− | otherwise -> responder ii' reqvt tcont strm req' (S.settingsOnExceptionResponse set e)
261+ | otherwise -> responder ii th reqvt tcont strm req' (S.settingsOnExceptionResponse set e)
263262 cont1 <- case ex of
264263 Right ResponseReceived -> return True
265264 Left e@(SomeException _)
warp/Network/Wai/Handler/Warp/Request.hs+5−9
@@ -32,7 +32,6 @@ import qualified System.TimeManager as Timeout
3232
3333import Network.Wai.Handler.Warp.Conduit
3434import Network.Wai.Handler.Warp.FileInfoCache
35−import Network.Wai.Handler.Warp.HashMap (hashByteString)
3635import Network.Wai.Handler.Warp.Header
3736import Network.Wai.Handler.Warp.Imports hiding (readInt, lines)
3837import Network.Wai.Handler.Warp.ReadInt
@@ -52,20 +51,20 @@ maxTotalHeaderLength = 50 * 1024
5251recvRequest :: Bool -- ^ first request on this connection?
5352 -> Settings
5453 -> Connection
55− -> InternalInfo1
54+ -> InternalInfo
55+ -> Timeout.Handle
5656 -> SockAddr -- ^ Peer's address.
5757 -> Source -- ^ Where HTTP request comes from.
5858 -> IO (Request
5959 ,Maybe (I.IORef Int)
6060 ,IndexedHeader
61− ,IO ByteString
62− ,InternalInfo) -- ^
61+ ,IO ByteString) -- ^
6362 -- 'Request' passed to 'Application',
6463 -- how many bytes remain to be consumed, if known
6564 -- 'IndexedHeader' of HTTP request for internal use,
6665 -- Body producing action used for flushing the request body
6766
68−recvRequest firstRequest settings conn ii1 addr src = do
67+recvRequest firstRequest settings conn ii th addr src = do
6968 hdrlines <- headerLines firstRequest src
7069 (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines
7170 let idxhdr = indexRequestHeader hdr
@@ -74,9 +73,6 @@ recvRequest firstRequest settings conn ii1 addr src = do
7473 te = idxhdr ! fromEnum ReqTransferEncoding
7574 handle100Continue = handleExpect conn httpversion expect
7675 rawPath = if settingsNoParsePath settings then unparsedPath else path
77− h = hashByteString rawPath
78− ii = toInternalInfo ii1 h
79− th = threadHandle ii
8076 vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
8177 $ Vault.insert getFileInfoKey (getFileInfo ii)
8278 Vault.empty
@@ -103,7 +99,7 @@ recvRequest firstRequest settings conn ii1 addr src = do
10399 , requestHeaderReferer = idxhdr ! fromEnum ReqReferer
104100 , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent
105101 }
106− return (req, remainingRef, idxhdr, rbodyFlush, ii)
102+ return (req, remainingRef, idxhdr, rbodyFlush)
107103
108104----------------------------------------------------------------
109105
warp/Network/Wai/Handler/Warp/Response.hs+2−2
@@ -101,12 +101,13 @@ import Network.Wai.Handler.Warp.Types
101101sendResponse :: Settings
102102 -> Connection
103103 -> InternalInfo
104+ -> T.Handle
104105 -> Request -- ^ HTTP request.
105106 -> IndexedHeader -- ^ Indexed header of HTTP request.
106107 -> IO ByteString -- ^ source from client, for raw response
107108 -> Response -- ^ HTTP response including status code and response header.
108109 -> IO Bool -- ^ Returing True if the connection is persistent.
109−sendResponse settings conn ii req reqidxhdr src response = do
110+sendResponse settings conn ii th req reqidxhdr src response = do
110111 hs <- addServerAndDate hs0
111112 if hasBody s then do
112113 -- The response to HEAD does not have body.
@@ -133,7 +134,6 @@ sendResponse settings conn ii req reqidxhdr src response = do
133134 s = responseStatus response
134135 hs0 = sanitizeHeaders $ responseHeaders response
135136 rspidxhdr = indexResponseHeader hs0
136− th = threadHandle ii
137137 getdate = getDate ii
138138 addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr
139139 (isPersist,isChunked0) = infoFromRequest req reqidxhdr
warp/Network/Wai/Handler/Warp/Run.hs+20−23
@@ -168,15 +168,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),
168168runSettingsConnectionMakerSecure set getConnMaker app = do
169169 settingsBeforeMainLoop set
170170 counter <- newCounter
171− withII0 $ acceptConnection set getConnMaker app counter
171+ withII $ acceptConnection set getConnMaker app counter
172172 where
173− withII0 action =
173+ withII action =
174174 withTimeoutManager $ \tm ->
175175 D.withDateCache $ \dc ->
176176 F.withFdCache fdCacheDurationInSeconds $ \fdc ->
177177 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do
178− let ii0 = InternalInfo0 tm dc fdc fic
179− action ii0
178+ let ii = InternalInfo tm dc fdc fic
179+ action ii
180180
181181 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
182182 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000
@@ -205,9 +205,9 @@ acceptConnection :: Settings
205205 -> IO (IO (Connection, Transport), SockAddr)
206206 -> Application
207207 -> Counter
208− -> InternalInfo0
208+ -> InternalInfo
209209 -> IO ()
210−acceptConnection set getConnMaker app counter ii0 = do
210+acceptConnection set getConnMaker app counter ii = do
211211 -- First mask all exceptions in acceptLoop. This is necessary to
212212 -- ensure that no async exception is throw between the call to
213213 -- acceptNewConnection and the registering of connClose.
@@ -234,7 +234,7 @@ acceptConnection set getConnMaker app counter ii0 = do
234234 case mx of
235235 Nothing -> return ()
236236 Just (mkConn, addr) -> do
237− fork set mkConn addr app counter ii0
237+ fork set mkConn addr app counter ii
238238 acceptLoop
239239
240240 acceptNewConnection = do
@@ -257,9 +257,9 @@ fork :: Settings
257257 -> SockAddr
258258 -> Application
259259 -> Counter
260− -> InternalInfo0
260+ -> InternalInfo
261261 -> IO ()
262−fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
262+fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
263263 -- Call the user-supplied on exception code if any
264264 -- exceptions are thrown.
265265 handle (settingsOnException set Nothing) .
@@ -291,7 +291,6 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
291291 -- the connection immediately in case the child thread catches the
292292 -- async exception or performs some long-running cleanup action.
293293 serve unmask ref (conn, transport) = bracket register cancel $ \th -> do
294− let ii1 = toInternalInfo1 ii0 th
295294 -- We now have fully registered a connection close handler in
296295 -- the case of all exceptions, so it is safe to once again
297296 -- allow async exceptions.
@@ -301,9 +300,9 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
301300 bracket (onOpen addr) (onClose addr) $ \goingon ->
302301 -- Actually serve this connection. bracket with closeConn
303302 -- above ensures the connection is closed.
304− when goingon $ serveConnection conn ii1 addr transport set app
303+ when goingon $ serveConnection conn ii th addr transport set app
305304 where
306− register = T.registerKillThread (timeoutManager0 ii0)
305+ register = T.registerKillThread (timeoutManager ii)
307306 (closeConn ref conn)
308307 cancel = T.cancel
309308
@@ -311,13 +310,14 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
311310 onClose adr _ = decrease counter >> settingsOnClose set adr
312311
313312serveConnection :: Connection
314− -> InternalInfo1
313+ -> InternalInfo
314+ -> T.Handle
315315 -> SockAddr
316316 -> Transport
317317 -> Settings
318318 -> Application
319319 -> IO ()
320−serveConnection conn ii1 origAddr transport settings app = do
320+serveConnection conn ii th origAddr transport settings app = do
321321 -- fixme: Upgrading to HTTP/2 should be supported.
322322 (h2,bs) <- if isHTTP2 transport then
323323 return (True, "")
@@ -332,7 +332,7 @@ serveConnection conn ii1 origAddr transport settings app = do
332332 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
333333 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
334334 -- fixme: origAddr
335− http2 conn ii1 origAddr transport settings recvN app
335+ http2 conn ii origAddr transport settings recvN app
336336 else do
337337 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
338338 writeIORef istatus True
@@ -388,8 +388,6 @@ serveConnection conn ii1 origAddr transport settings app = do
388388
389389 decodeAscii = map (chr . fromEnum) . S.unpack
390390
391− th = threadHandle1 ii1
392−
393391 shouldSendErrorResponse se
394392 | Just ConnectionClosedByPeer <- fromException se = False
395393 | otherwise = True
@@ -398,8 +396,7 @@ serveConnection conn ii1 origAddr transport settings app = do
398396 status <- readIORef istatus
399397 if shouldSendErrorResponse e && status
400398 then do
401− let ii = toInternalInfo ii1 0 -- dummy
402− sendResponse settings conn ii req defaultIndexRequestHeader (return S.empty) (errorResponse e)
399+ sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)
403400 else return False
404401
405402 dummyreq addr = defaultRequest { remoteHost = addr }
@@ -407,9 +404,9 @@ serveConnection conn ii1 origAddr transport settings app = do
407404 errorResponse e = settingsOnExceptionResponse settings e
408405
409406 http1 firstRequest addr istatus src = do
410− (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src
407+ (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src
411408 let req = req' { isSecure = isTransportSecure transport }
412− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii
409+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
413410 `E.catch` \e -> do
414411 settingsOnException settings (Just req) e
415412 -- Don't throw the error again to prevent calling settingsOnException twice.
@@ -425,7 +422,7 @@ serveConnection conn ii1 origAddr transport settings app = do
425422 -- and ignore. See: https://github.com/yesodweb/wai/issues/618
426423 when keepAlive $ http1 False addr istatus src
427424
428− processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do
425+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do
429426 -- Let the application run for as long as it wants
430427 T.pause th
431428
@@ -439,7 +436,7 @@ serveConnection conn ii1 origAddr transport settings app = do
439436 -- send more meaningful error messages to the user.
440437 -- However, it may affect performance.
441438 writeIORef istatus False
442− keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res
439+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res
443440 writeIORef keepAliveRef keepAlive
444441 return ResponseReceived
445442 case r of
warp/Network/Wai/Handler/Warp/Types.hs+1−30
@@ -126,42 +126,13 @@ data Connection = Connection {
126126
127127----------------------------------------------------------------
128128
129−type Hash = Int
130−
131−
132−data InternalInfo0 =
133− InternalInfo0 T.Manager
134− (IO D.GMTDate)
135− (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))
136− (Hash -> FilePath -> IO I.FileInfo)
137−
138−timeoutManager0 :: InternalInfo0 -> T.Manager
139−timeoutManager0 (InternalInfo0 tm _ _ _) = tm
140−
141−data InternalInfo1 =
142− InternalInfo1 T.Handle
143− T.Manager
144− (IO D.GMTDate)
145− (Hash -> FilePath -> IO (Maybe F.Fd, F.Refresh))
146− (Hash -> FilePath -> IO I.FileInfo)
147−
148−toInternalInfo1 :: InternalInfo0 -> T.Handle -> InternalInfo1
149−toInternalInfo1 (InternalInfo0 b c d e) a = InternalInfo1 a b c d e
150−
151−threadHandle1 :: InternalInfo1 -> T.Handle
152−threadHandle1 (InternalInfo1 th _ _ _ _) = th
153−
154129data InternalInfo = InternalInfo {
155− threadHandle :: T.Handle
156− , timeoutManager :: T.Manager
130+ timeoutManager :: T.Manager
157131 , getDate :: IO D.GMTDate
158132 , getFd :: FilePath -> IO (Maybe F.Fd, F.Refresh)
159133 , getFileInfo :: FilePath -> IO I.FileInfo
160134 }
161135
162−toInternalInfo :: InternalInfo1 -> Hash -> InternalInfo
163−toInternalInfo (InternalInfo1 a b c d e) h = InternalInfo a b c (d h) (e h)
164−
165136----------------------------------------------------------------
166137
167138-- | Type for input streaming.
warp/test/FdCacheSpec.hs+1−1
@@ -17,7 +17,7 @@ spec = describe "withFdCache" $ do
1717 it "clean up Fd" $ do
1818 ref <- newIORef (Fd (-1))
1919 withFdCache 30000000 $ \getFd -> do
20− (Just fd,_) <- getFd 0 "warp.cabal"
20+ (Just fd,_) <- getFd "warp.cabal"
2121 writeIORef ref fd
2222 nfd <- readIORef ref
2323 fdRead nfd 1 `shouldThrow` anyIOException