{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | A server library for HTTP/3.
module Network.HTTP3.Server (
    -- * Runner
    run,

    -- * Runner arguments
    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

-- | Running an HTTP\/3 server.
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 () -- error
        | 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
            -- fixme: Content-Length
            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