Skip to content
Permalink
master
Go to file
 
 
Cannot retrieve contributors at this time
104 lines (96 sloc) 3.58 KB
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Wai.Handler.Warp.HTTP2 (
http2
, http2server
) where
import qualified Data.IORef as I
import qualified Control.Exception as E
import qualified Network.HTTP2.Server as H2
import Network.Socket (SockAddr)
import Network.Wai
import Network.Wai.Internal (ResponseReceived(..))
import qualified System.TimeManager as T
import Network.Wai.Handler.Warp.HTTP2.File
import Network.Wai.Handler.Warp.HTTP2.PushPromise
import Network.Wai.Handler.Warp.HTTP2.Request
import Network.Wai.Handler.Warp.HTTP2.Response
import Network.Wai.Handler.Warp.Imports
import qualified Network.Wai.Handler.Warp.Settings as S
import Network.Wai.Handler.Warp.Types
----------------------------------------------------------------
http2 :: S.Settings
-> InternalInfo
-> Connection
-> Transport
-> SockAddr
-> (BufSize -> IO ByteString)
-> (ByteString -> IO ())
-> Application
-> IO ()
http2 settings ii conn transport addr readN send app =
H2.run conf $ http2server settings ii transport addr app
where
conf = H2.Config {
confWriteBuffer = connWriteBuffer conn
, confBufferSize = connBufferSize conn
, confSendAll = send
, confReadN = readN
, confPositionReadMaker = pReadMaker ii
}
-- | Converting WAI application to the server type of http2 library.
--
-- Since 3.3.11
http2server :: S.Settings
-> InternalInfo
-> Transport
-> SockAddr
-> Application
-> H2.Server
http2server settings ii transport addr app h2req0 aux0 response = do
req <- toWAIRequest h2req0 aux0
ref <- I.newIORef Nothing
eResponseReceived <- E.try $ app req $ \rsp -> do
(h2rsp,st,hasBody) <- fromResponse settings ii req rsp
pps <- if hasBody then fromPushPromises ii req else return []
I.writeIORef ref $ Just (h2rsp, pps, st)
_ <- response h2rsp pps
return ResponseReceived
case eResponseReceived of
Right ResponseReceived -> do
Just (h2rsp, pps, st) <- I.readIORef ref
let msiz = fromIntegral <$> H2.responseBodySize h2rsp
logResponse req st msiz
mapM_ (logPushPromise req) pps
Left e@(E.SomeException _)
-- killed by the local worker manager
| Just E.ThreadKilled <- E.fromException e -> return ()
-- killed by the local timeout manager
| Just T.TimeoutThread <- E.fromException e -> return ()
| otherwise -> do
S.settingsOnException settings (Just req) e
let ersp = S.settingsOnExceptionResponse settings e
st = responseStatus ersp
(h2rsp',_,_) <- fromResponse settings ii req ersp
let msiz = fromIntegral <$> H2.responseBodySize h2rsp'
_ <- response h2rsp' []
logResponse req st msiz
return ()
where
toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport
where
!hdr = H2.requestHeaders h2req
!bdy = H2.getRequestBodyChunk h2req
!bdylen = H2.requestBodySize h2req
!th = H2.auxTimeHandle aux
logResponse = S.settingsLogger settings
logPushPromise req pp = logger req path siz
where
!logger = S.settingsServerPushLogger settings
!path = H2.promiseRequestPath pp
!siz = case H2.responseBodySize $ H2.promiseResponse pp of
Nothing -> 0
Just s -> fromIntegral s
You can’t perform that action at this time.