{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Wai.Handler.Warp.HTTP2 (
http2,
http2server,
) where
import qualified Data.ByteString as BS
import Data.IORef (readIORef)
import qualified Data.IORef as I
import qualified Network.HTTP2.Frame as H2
import qualified Network.HTTP2.Server as H2
import Network.Socket (SockAddr)
import Network.Socket.BufferPool
import Network.Wai
import Network.Wai.Internal (ResponseReceived (..))
import qualified System.TimeManager as T
import qualified UnliftIO
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
-> Application
-> SockAddr
-> T.Handle
-> ByteString
-> IO ()
http2 :: Settings
-> InternalInfo
-> Connection
-> Transport
-> Application
-> SockAddr
-> Handle
-> ByteString
-> IO ()
http2 Settings
settings InternalInfo
ii Connection
conn Transport
transport Application
app SockAddr
peersa Handle
th ByteString
bs = do
RecvN
rawRecvN <- ByteString -> Recv -> IO RecvN
makeRecvN ByteString
bs (Recv -> IO RecvN) -> Recv -> IO RecvN
forall a b. (a -> b) -> a -> b
$ Connection -> Recv
connRecv Connection
conn
WriteBuffer
writeBuffer <- IORef WriteBuffer -> IO WriteBuffer
forall a. IORef a -> IO a
readIORef (IORef WriteBuffer -> IO WriteBuffer)
-> IORef WriteBuffer -> IO WriteBuffer
forall a b. (a -> b) -> a -> b
$ Connection -> IORef WriteBuffer
connWriteBuffer Connection
conn
let recvN :: RecvN
recvN = Handle -> Int -> RecvN -> RecvN
wrappedRecvN Handle
th (Settings -> Int
S.settingsSlowlorisSize Settings
settings) RecvN
rawRecvN
sendBS :: ByteString -> IO ()
sendBS ByteString
x = Connection -> ByteString -> IO ()
connSendAll Connection
conn ByteString
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
T.tickle Handle
th
conf :: Config
conf =
H2.Config
{ confWriteBuffer :: Buffer
confWriteBuffer = WriteBuffer -> Buffer
bufBuffer WriteBuffer
writeBuffer
, confBufferSize :: Int
confBufferSize = WriteBuffer -> Int
bufSize WriteBuffer
writeBuffer
, confSendAll :: ByteString -> IO ()
confSendAll = ByteString -> IO ()
sendBS
, confReadN :: RecvN
confReadN = RecvN
recvN
, confPositionReadMaker :: PositionReadMaker
confPositionReadMaker = InternalInfo -> PositionReadMaker
pReadMaker InternalInfo
ii
, confTimeoutManager :: Manager
confTimeoutManager = InternalInfo -> Manager
timeoutManager InternalInfo
ii
#if MIN_VERSION_http2(4,2,0)
, confMySockAddr :: SockAddr
confMySockAddr = Connection -> SockAddr
connMySockAddr Connection
conn
, confPeerSockAddr :: SockAddr
confPeerSockAddr = SockAddr
peersa
#endif
}
IO ()
checkTLS
Connection -> Bool -> IO ()
setConnHTTP2 Connection
conn Bool
True
ServerConfig -> Config -> Server -> IO ()
H2.run ServerConfig
H2.defaultServerConfig 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
peersa Application
app
where
checkTLS :: IO ()
checkTLS = case Transport
transport of
Transport
TCP -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Transport
tls -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Transport -> Bool
tls12orLater Transport
tls) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection
conn ErrorCodeId
H2.InadequateSecurity ByteString
"Weak TLS"
tls12orLater :: Transport -> Bool
tls12orLater Transport
tls = Transport -> Int
tlsMajorVersion Transport
tls Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 Bool -> Bool -> Bool
&& Transport -> Int
tlsMinorVersion Transport
tls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3
http2server
:: S.Settings
-> InternalInfo
-> Transport
-> SockAddr
-> Application
-> H2.Server
http2server :: Settings
-> InternalInfo -> Transport -> SockAddr -> Application -> Server
http2server Settings
settings InternalInfo
ii Transport
transport SockAddr
addr Application
app Request
h2req0 Aux
aux0 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 (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnliftIO.tryAny (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
$ \Response
rsp -> do
(Response
h2rsp, Status
st, 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
ResponseReceived
case Either SomeException ResponseReceived
eResponseReceived of
Right ResponseReceived
ResponseReceived -> do
Just (Response
h2rsp, [PushPromise]
pps, 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 = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Maybe Int -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> Maybe Int
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 SomeException
e -> 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
(Response
h2rsp', Status
_, Bool
_) <- Settings
-> InternalInfo
-> Request
-> Response
-> IO (Response, Status, Bool)
fromResponse Settings
settings InternalInfo
ii Request
req Response
ersp
let msiz :: Maybe Integer
msiz = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Maybe Int -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response -> Maybe Int
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
toWAIRequest :: Request -> Aux -> IO Request
toWAIRequest Request
h2req Aux
aux = InternalInfo -> Settings -> SockAddr -> ToReq
toRequest InternalInfo
ii Settings
settings SockAddr
addr HeaderTable
hdr Maybe Int
bdylen Recv
bdy Handle
th Transport
transport
where
!hdr :: HeaderTable
hdr = Request -> HeaderTable
H2.requestHeaders Request
h2req
!bdy :: Recv
bdy = Request -> Recv
H2.getRequestBodyChunk Request
h2req
!bdylen :: Maybe Int
bdylen = Request -> Maybe Int
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 Request
req 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 Int
H2.responseBodySize (Response -> Maybe Int) -> Response -> Maybe Int
forall a b. (a -> b) -> a -> b
$ PushPromise -> Response
H2.promiseResponse PushPromise
pp of
Maybe Int
Nothing -> Integer
0
Just Int
s -> Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s
wrappedRecvN
:: T.Handle -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
wrappedRecvN :: Handle -> Int -> RecvN -> RecvN
wrappedRecvN Handle
th Int
slowlorisSize RecvN
readN Int
bufsize = do
ByteString
bs <- (SomeException -> Recv) -> Recv -> Recv
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
UnliftIO.handleAny SomeException -> Recv
handler (Recv -> Recv) -> Recv -> Recv
forall a b. (a -> b) -> a -> b
$ RecvN
readN Int
bufsize
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
(ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
slowlorisSize Bool -> Bool -> Bool
|| Int
bufsize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
slowlorisSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Handle -> IO ()
T.tickle Handle
th
ByteString -> Recv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
where
handler :: UnliftIO.SomeException -> IO ByteString
handler :: SomeException -> Recv
handler SomeException
_ = ByteString -> Recv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection{IO ()
Recv
IORef Bool
IORef WriteBuffer
SockAddr
[ByteString] -> IO ()
RecvBuf
ByteString -> IO ()
SendFile
connRecv :: Connection -> Recv
connWriteBuffer :: Connection -> IORef WriteBuffer
connSendAll :: Connection -> ByteString -> IO ()
connMySockAddr :: Connection -> SockAddr
connSendMany :: [ByteString] -> IO ()
connSendAll :: ByteString -> IO ()
connSendFile :: SendFile
connClose :: IO ()
connRecv :: Recv
connRecvBuf :: RecvBuf
connWriteBuffer :: IORef WriteBuffer
connHTTP2 :: IORef Bool
connMySockAddr :: SockAddr
connSendMany :: Connection -> [ByteString] -> IO ()
connSendFile :: Connection -> SendFile
connClose :: Connection -> IO ()
connRecvBuf :: Connection -> RecvBuf
connHTTP2 :: Connection -> IORef Bool
..} ErrorCodeId
etype ByteString
debugmsg = ByteString -> IO ()
connSendAll ByteString
bytestream
where
einfo :: EncodeInfo
einfo = (FrameFlags -> FrameFlags) -> Int -> EncodeInfo
H2.encodeInfo FrameFlags -> FrameFlags
forall a. a -> a
id Int
0
frame :: FramePayload
frame = Int -> ErrorCodeId -> ByteString -> FramePayload
H2.GoAwayFrame Int
0 ErrorCodeId
etype ByteString
debugmsg
bytestream :: ByteString
bytestream = EncodeInfo -> FramePayload -> ByteString
H2.encodeFrame EncodeInfo
einfo FramePayload
frame