{-# 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
-> InternalInfo
-> Connection
-> Transport
-> SockAddr
-> (BufSize -> IO ByteString)
-> (ByteString -> IO ())
-> Application
-> IO ()
http2 settings :: Settings
settings ii :: InternalInfo
ii conn :: Connection
conn transport :: Transport
transport addr :: SockAddr
addr readN :: BufSize -> IO ByteString
readN send :: ByteString -> IO ()
send app :: Application
app =
Config -> Server -> IO ()
H2.run Config
conf (Server -> IO ()) -> Server -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings
-> InternalInfo -> Transport -> SockAddr -> Application -> Server
http2server Settings
settings InternalInfo
ii Transport
transport SockAddr
addr Application
app
where
conf :: Config
conf = $WConfig :: Buffer
-> BufSize
-> (ByteString -> IO ())
-> (BufSize -> IO ByteString)
-> PositionReadMaker
-> Config
H2.Config {
confWriteBuffer :: Buffer
confWriteBuffer = Connection -> Buffer
connWriteBuffer Connection
conn
, confBufferSize :: BufSize
confBufferSize = Connection -> BufSize
connBufferSize Connection
conn
, confSendAll :: ByteString -> IO ()
confSendAll = ByteString -> IO ()
send
, confReadN :: BufSize -> IO ByteString
confReadN = BufSize -> IO ByteString
readN
, confPositionReadMaker :: PositionReadMaker
confPositionReadMaker = InternalInfo -> PositionReadMaker
pReadMaker InternalInfo
ii
}
http2server :: S.Settings
-> InternalInfo
-> Transport
-> SockAddr
-> Application
-> H2.Server
http2server :: Settings
-> InternalInfo -> Transport -> SockAddr -> Application -> Server
http2server settings :: Settings
settings ii :: InternalInfo
ii transport :: Transport
transport addr :: SockAddr
addr app :: Application
app h2req0 :: Request
h2req0 aux0 :: Aux
aux0 response :: Response -> [PushPromise] -> IO ()
response = do
Request
req <- Request -> Aux -> IO Request
toWAIRequest Request
h2req0 Aux
aux0
IORef (Maybe (Response, [PushPromise], Status))
ref <- Maybe (Response, [PushPromise], Status)
-> IO (IORef (Maybe (Response, [PushPromise], Status)))
forall a. a -> IO (IORef a)
I.newIORef Maybe (Response, [PushPromise], Status)
forall a. Maybe a
Nothing
Either SomeException ResponseReceived
eResponseReceived <- IO ResponseReceived -> IO (Either SomeException ResponseReceived)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ResponseReceived -> IO (Either SomeException ResponseReceived))
-> IO ResponseReceived
-> IO (Either SomeException ResponseReceived)
forall a b. (a -> b) -> a -> b
$ Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \rsp :: Response
rsp -> do
(h2rsp :: Response
h2rsp,st :: Status
st,hasBody :: Bool
hasBody) <- Settings
-> InternalInfo
-> Request
-> Response
-> IO (Response, Status, Bool)
fromResponse Settings
settings InternalInfo
ii Request
req Response
rsp
[PushPromise]
pps <- if Bool
hasBody then InternalInfo -> Request -> IO [PushPromise]
fromPushPromises InternalInfo
ii Request
req else [PushPromise] -> IO [PushPromise]
forall (m :: * -> *) a. Monad m => a -> m a
return []
IORef (Maybe (Response, [PushPromise], Status))
-> Maybe (Response, [PushPromise], Status) -> IO ()
forall a. IORef a -> a -> IO ()
I.writeIORef IORef (Maybe (Response, [PushPromise], Status))
ref (Maybe (Response, [PushPromise], Status) -> IO ())
-> Maybe (Response, [PushPromise], Status) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Response, [PushPromise], Status)
-> Maybe (Response, [PushPromise], Status)
forall a. a -> Maybe a
Just (Response
h2rsp, [PushPromise]
pps, Status
st)
()
_ <- Response -> [PushPromise] -> IO ()
response Response
h2rsp [PushPromise]
pps
ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
case Either SomeException ResponseReceived
eResponseReceived of
Right ResponseReceived -> do
Just (h2rsp :: Response
h2rsp, pps :: [PushPromise]
pps, st :: Status
st) <- IORef (Maybe (Response, [PushPromise], Status))
-> IO (Maybe (Response, [PushPromise], Status))
forall a. IORef a -> IO a
I.readIORef IORef (Maybe (Response, [PushPromise], Status))
ref
let msiz :: Maybe Integer
msiz = BufSize -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BufSize -> Integer) -> Maybe BufSize -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> Maybe BufSize
H2.responseBodySize Response
h2rsp
Request -> Status -> Maybe Integer -> IO ()
logResponse Request
req Status
st Maybe Integer
msiz
(PushPromise -> IO ()) -> [PushPromise] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Request -> PushPromise -> IO ()
logPushPromise Request
req) [PushPromise]
pps
Left e :: SomeException
e@(E.SomeException _)
| Just E.ThreadKilled <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just T.TimeoutThread <- SomeException -> Maybe TimeoutThread
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> do
Settings -> Maybe Request -> SomeException -> IO ()
S.settingsOnException Settings
settings (Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req) SomeException
e
let ersp :: Response
ersp = Settings -> SomeException -> Response
S.settingsOnExceptionResponse Settings
settings SomeException
e
st :: Status
st = Response -> Status
responseStatus Response
ersp
(h2rsp' :: Response
h2rsp',_,_) <- Settings
-> InternalInfo
-> Request
-> Response
-> IO (Response, Status, Bool)
fromResponse Settings
settings InternalInfo
ii Request
req Response
ersp
let msiz :: Maybe Integer
msiz = BufSize -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BufSize -> Integer) -> Maybe BufSize -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> Maybe BufSize
H2.responseBodySize Response
h2rsp'
()
_ <- Response -> [PushPromise] -> IO ()
response Response
h2rsp' []
Request -> Status -> Maybe Integer -> IO ()
logResponse Request
req Status
st Maybe Integer
msiz
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
toWAIRequest :: Request -> Aux -> IO Request
toWAIRequest h2req :: Request
h2req aux :: Aux
aux = InternalInfo -> Settings -> SockAddr -> ToReq
toRequest InternalInfo
ii Settings
settings SockAddr
addr HeaderTable
hdr Maybe BufSize
bdylen IO ByteString
bdy Handle
th Transport
transport
where
!hdr :: HeaderTable
hdr = Request -> HeaderTable
H2.requestHeaders Request
h2req
!bdy :: IO ByteString
bdy = Request -> IO ByteString
H2.getRequestBodyChunk Request
h2req
!bdylen :: Maybe BufSize
bdylen = Request -> Maybe BufSize
H2.requestBodySize Request
h2req
!th :: Handle
th = Aux -> Handle
H2.auxTimeHandle Aux
aux
logResponse :: Request -> Status -> Maybe Integer -> IO ()
logResponse = Settings -> Request -> Status -> Maybe Integer -> IO ()
S.settingsLogger Settings
settings
logPushPromise :: Request -> PushPromise -> IO ()
logPushPromise req :: Request
req pp :: PushPromise
pp = Request -> ByteString -> Integer -> IO ()
logger Request
req ByteString
path Integer
siz
where
!logger :: Request -> ByteString -> Integer -> IO ()
logger = Settings -> Request -> ByteString -> Integer -> IO ()
S.settingsServerPushLogger Settings
settings
!path :: ByteString
path = PushPromise -> ByteString
H2.promiseRequestPath PushPromise
pp
!siz :: Integer
siz = case Response -> Maybe BufSize
H2.responseBodySize (Response -> Maybe BufSize) -> Response -> Maybe BufSize
forall a b. (a -> b) -> a -> b
$ PushPromise -> Response
H2.promiseResponse PushPromise
pp of
Nothing -> 0
Just s :: BufSize
s -> BufSize -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral BufSize
s