{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.HTTP3.Server (
run,
Config (..),
allocSimpleConfig,
freeSimpleConfig,
Hooks (..),
defaultHooks,
module Network.HTTP.Semantics.Server,
) where
import Control.Concurrent
import Data.IORef
import Network.HTTP.Semantics
import Network.HTTP.Semantics.Server
import Network.HTTP.Semantics.Server.Internal
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.Internal
run :: Connection -> Config -> Server -> IO ()
run :: Connection -> Config -> Server -> IO ()
run Connection
conn Config
conf Server
server = IO Context -> (Context -> IO ()) -> (Context -> IO ()) -> IO ()
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 ((Context -> IO ()) -> IO ()) -> (Context -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Context
ctx -> do
ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
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 <- IFrame -> IO (IORef IFrame)
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 = IO ()
forall {b}. IO b
loop
where
loop :: IO b
loop = do
Context -> IO Stream
accept Context
ctx IO Stream -> (Stream -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 (IO () -> IO ThreadId) -> IO () -> IO ThreadId
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 =
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
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 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = () -> IO ()
forall a. a -> IO a
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 = (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
E.handleAny SomeException -> IO ()
reset (IO () -> IO ()) -> IO () -> IO ()
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 TokenHeaderTable
mvt <- Context -> Source -> IO (Maybe TokenHeaderTable)
recvHeader Context
ctx Source
src
case Maybe TokenHeaderTable
mvt of
Maybe TokenHeaderTable
Nothing -> Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
Just ht :: TokenHeaderTable
ht@(TokenHeaderList
_, ValueTable
vt) -> do
let mMethod :: Maybe FieldValue
mMethod = Token -> ValueTable -> Maybe FieldValue
getFieldValue Token
tokenMethod ValueTable
vt
mScheme :: Maybe FieldValue
mScheme = Token -> ValueTable -> Maybe FieldValue
getFieldValue Token
tokenScheme ValueTable
vt
mAuthority :: Maybe FieldValue
mAuthority = Token -> ValueTable -> Maybe FieldValue
getFieldValue Token
tokenAuthority ValueTable
vt
mPath :: Maybe FieldValue
mPath = Token -> ValueTable -> Maybe FieldValue
getFieldValue Token
tokenPath ValueTable
vt
case (Maybe FieldValue
mMethod, Maybe FieldValue
mScheme, Maybe FieldValue
mAuthority, Maybe FieldValue
mPath) of
(Just FieldValue
"CONNECT", Maybe FieldValue
_, Just FieldValue
_, Maybe FieldValue
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Just FieldValue
_, Just FieldValue
_, Just FieldValue
_, Just FieldValue
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Maybe FieldValue, Maybe FieldValue, Maybe FieldValue,
Maybe FieldValue)
_ -> Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
IORef IFrame
refI <- IFrame -> IO (IORef IFrame)
forall a. a -> IO (IORef a)
newIORef IFrame
IInit
IORef (Maybe TokenHeaderTable)
refH <- Maybe TokenHeaderTable -> IO (IORef (Maybe TokenHeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe TokenHeaderTable
forall a. Maybe a
Nothing
let readB :: IO FieldValue
readB = Context
-> Source
-> IORef IFrame
-> IORef (Maybe TokenHeaderTable)
-> IO FieldValue
recvBody Context
ctx Source
src IORef IFrame
refI IORef (Maybe TokenHeaderTable)
refH
req :: Request
req = InpObj -> Request
Request (InpObj -> Request) -> InpObj -> Request
forall a b. (a -> b) -> a -> b
$ TokenHeaderTable
-> Maybe StreamId
-> IO FieldValue
-> IORef (Maybe TokenHeaderTable)
-> InpObj
InpObj TokenHeaderTable
ht Maybe StreamId
forall a. Maybe a
Nothing IO FieldValue
readB IORef (Maybe TokenHeaderTable)
refH
let aux :: Aux
aux = Handle -> SockAddr -> SockAddr -> Aux
Aux Handle
th (Context -> SockAddr
getMySockAddr Context
ctx) (Context -> SockAddr
getPeerSockAddr Context
ctx)
Server
server Request
req Aux
aux ((Response -> [PushPromise] -> IO ()) -> IO ())
-> (Response -> [PushPromise] -> IO ()) -> IO ()
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) <- SomeException -> Maybe 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 (ResponseHeaders -> IO ()) -> ResponseHeaders -> IO ()
forall a b. (a -> b) -> a -> b
$ OutObj -> ResponseHeaders
outObjHeaders OutObj
outobj
Context -> Stream -> Handle -> OutObj -> IO ()
sendBody Context
ctx Stream
strm Handle
th OutObj
outobj
Stream -> IO ()
QUIC.shutdownStream Stream
strm