{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.HTTP3.Server (
run
, Config(..)
, allocSimpleConfig
, freeSimpleConfig
, Hooks(..)
, defaultHooks
, Server
, Request
, H2.requestMethod
, H2.requestPath
, H2.requestAuthority
, H2.requestScheme
, H2.requestHeaders
, H2.requestBodySize
, H2.getRequestBodyChunk
, H2.getRequestTrailers
, Aux
, auxTimeHandle
, Response
, H2.responseNoBody
, H2.responseFile
, H2.responseStreaming
, H2.responseBuilder
, H2.responseBodySize
, H2.TrailersMaker
, H2.NextTrailersMaker(..)
, H2.defaultTrailersMaker
, H2.setResponseTrailersMaker
, PushPromise
, H2.pushPromise
, H2.promiseRequestPath
, H2.promiseResponse
, H2.Path
, H2.Authority
, H2.Scheme
, H2.FileSpec(..)
, H2.FileOffset
, H2.ByteCount
, H2.defaultReadN
, H2.PositionReadMaker
, H2.PositionRead
, H2.Sentinel(..)
, H2.defaultPositionReadMaker
) where
import Control.Concurrent
import Data.IORef
import Network.HPACK.Token
import Network.HTTP2.Internal (InpObj(..))
import qualified Network.HTTP2.Internal as H2
import Network.HTTP2.Server (Server, PushPromise)
import qualified Network.HTTP2.Server as H2
import Network.HTTP2.Server.Internal (Request(..), Response(..), Aux(..))
import Network.QUIC (Connection, Stream)
import qualified Network.QUIC as QUIC
import qualified System.TimeManager as T
import qualified UnliftIO.Exception as E
import Imports
import Network.HTTP3.Config
import Network.HTTP3.Context
import Network.HTTP3.Control
import Network.HTTP3.Error
import Network.HTTP3.Frame
import Network.HTTP3.Recv
import Network.HTTP3.Send
import Network.QPACK
import Network.QPACK.Internal
run :: Connection -> Config -> Server -> IO ()
run :: Connection -> Config -> Server -> IO ()
run Connection
conn Config
conf Server
server = forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket IO Context
open Context -> IO ()
close forall a b. (a -> b) -> a -> b
$ \Context
ctx -> do
ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Connection -> Config -> IO ()
setupUnidirectional Connection
conn Config
conf
Context -> ThreadId -> IO ()
addThreadId Context
ctx ThreadId
tid
Context -> Server -> IO ()
readerServer Context
ctx Server
server
where
open :: IO Context
open = do
IORef IFrame
ref <- forall a. a -> IO (IORef a)
newIORef IFrame
IInit
Connection -> Config -> InstructionHandler -> IO Context
newContext Connection
conn Config
conf (Connection -> IORef IFrame -> InstructionHandler
controlStream Connection
conn IORef IFrame
ref)
close :: Context -> IO ()
close = Context -> IO ()
clearContext
readerServer :: Context -> Server -> IO ()
readerServer :: Context -> Server -> IO ()
readerServer Context
ctx Server
server = forall {b}. IO b
loop
where
loop :: IO b
loop = do
Context -> IO Stream
accept Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stream -> IO ()
process
IO b
loop
process :: Stream -> IO ()
process Stream
strm
| StreamId -> Bool
QUIC.isClientInitiatedUnidirectional StreamId
sid = do
ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IO ()
unidirectional Context
ctx Stream
strm
Context -> ThreadId -> IO ()
addThreadId Context
ctx ThreadId
tid
| StreamId -> Bool
QUIC.isClientInitiatedBidirectional StreamId
sid = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Context -> Server -> Stream -> IO ()
processRequest Context
ctx Server
server Stream
strm) (\Either SomeException ()
_ -> Stream -> IO ()
closeStream Stream
strm)
| StreamId -> Bool
QUIC.isServerInitiatedUnidirectional StreamId
sid = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
sid :: StreamId
sid = Stream -> StreamId
QUIC.streamId Stream
strm
processRequest :: Context -> Server -> Stream -> IO ()
processRequest :: Context -> Server -> Stream -> IO ()
processRequest Context
ctx Server
server Stream
strm = forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
E.handleAny SomeException -> IO ()
reset forall a b. (a -> b) -> a -> b
$ do
Handle
th <- Context -> IO Handle
registerThread Context
ctx
Source
src <- Stream -> IO Source
newSource Stream
strm
Maybe HeaderTable
mvt <- Context -> Source -> IO (Maybe HeaderTable)
recvHeader Context
ctx Source
src
case Maybe HeaderTable
mvt of
Maybe HeaderTable
Nothing -> Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
Just ht :: HeaderTable
ht@(TokenHeaderList
_,ValueTable
vt) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenMethod ValueTable
vt) forall a b. (a -> b) -> a -> b
$ do
Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenScheme ValueTable
vt) forall a b. (a -> b) -> a -> b
$ do
Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenAuthority ValueTable
vt) forall a b. (a -> b) -> a -> b
$ do
Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenPath ValueTable
vt) forall a b. (a -> b) -> a -> b
$ do
Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
IORef IFrame
refI <- forall a. a -> IO (IORef a)
newIORef IFrame
IInit
IORef (Maybe HeaderTable)
refH <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
let readB :: IO HeaderValue
readB = Context
-> Source
-> IORef IFrame
-> IORef (Maybe HeaderTable)
-> IO HeaderValue
recvBody Context
ctx Source
src IORef IFrame
refI IORef (Maybe HeaderTable)
refH
req :: Request
req = InpObj -> Request
Request forall a b. (a -> b) -> a -> b
$ HeaderTable
-> Maybe StreamId
-> IO HeaderValue
-> IORef (Maybe HeaderTable)
-> InpObj
InpObj HeaderTable
ht forall a. Maybe a
Nothing IO HeaderValue
readB IORef (Maybe HeaderTable)
refH
let aux :: Aux
aux = Handle -> Aux
Aux Handle
th
Server
server Request
req Aux
aux forall a b. (a -> b) -> a -> b
$ Context -> Stream -> Handle -> Response -> [PushPromise] -> IO ()
sendResponse Context
ctx Stream
strm Handle
th
where
reset :: SomeException -> IO ()
reset SomeException
se
| Just (DecodeError
_ :: DecodeError) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = Context -> ApplicationProtocolError -> IO ()
abort Context
ctx ApplicationProtocolError
QpackDecompressionFailed
| Bool
otherwise = Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
sendResponse :: Context -> Stream -> T.Handle -> Response -> [PushPromise] -> IO ()
sendResponse :: Context -> Stream -> Handle -> Response -> [PushPromise] -> IO ()
sendResponse Context
ctx Stream
strm Handle
th (Response OutObj
outobj) [PushPromise]
_pp = do
Context -> Stream -> Handle -> ResponseHeaders -> IO ()
sendHeader Context
ctx Stream
strm Handle
th forall a b. (a -> b) -> a -> b
$ OutObj -> ResponseHeaders
H2.outObjHeaders OutObj
outobj
Context -> Stream -> Handle -> OutObj -> IO ()
sendBody Context
ctx Stream
strm Handle
th OutObj
outobj
Stream -> IO ()
QUIC.shutdownStream Stream
strm