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

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

    -- * Runner arguments
    Config (..),
    allocSimpleConfig,
    freeSimpleConfig,
    Hooks (..),
    defaultHooks,

    -- * HTTP\/3 server
    Server,

    -- * Request
    Request,

    -- ** Accessing request
    H2.requestMethod,
    H2.requestPath,
    H2.requestAuthority,
    H2.requestScheme,
    H2.requestHeaders,
    H2.requestBodySize,
    H2.getRequestBodyChunk,
    H2.getRequestTrailers,

    -- * Aux
    Aux,
    auxTimeHandle,

    -- * Response
    Response,

    -- ** Creating response
    H2.responseNoBody,
    H2.responseFile,
    H2.responseStreaming,
    H2.responseBuilder,

    -- ** Accessing response
    H2.responseBodySize,

    -- ** Trailers maker
    H2.TrailersMaker,
    H2.NextTrailersMaker (..),
    H2.defaultTrailersMaker,
    H2.setResponseTrailersMaker,

    -- * Push promise
    PushPromise,
    H2.pushPromise,
    H2.promiseRequestPath,
    H2.promiseResponse,

    -- * Types
    H2.Path,
    H2.Authority,
    H2.Scheme,
    H2.FileSpec (..),
    H2.FileOffset,
    H2.ByteCount,

    -- * RecvN
    H2.defaultReadN,

    -- * Position read for files
    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 (PushPromise, Server)
import qualified Network.HTTP2.Server as H2
import Network.HTTP2.Server.Internal (Aux (..), Request (..), Response (..))
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

-- | 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 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
            let mMethod :: Maybe HeaderValue
mMethod = Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenMethod ValueTable
vt
                mScheme :: Maybe HeaderValue
mScheme = Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenScheme ValueTable
vt
                mAuthority :: Maybe HeaderValue
mAuthority = Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenAuthority ValueTable
vt
                mPath :: Maybe HeaderValue
mPath = Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenPath ValueTable
vt
            case (Maybe HeaderValue
mMethod, Maybe HeaderValue
mScheme, Maybe HeaderValue
mAuthority, Maybe HeaderValue
mPath) of
                (Just HeaderValue
"CONNECT", Maybe HeaderValue
_, Just HeaderValue
_, Maybe HeaderValue
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                (Just HeaderValue
_, Just HeaderValue
_, Just HeaderValue
_, Just HeaderValue
_) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                (Maybe HeaderValue, Maybe HeaderValue, Maybe HeaderValue,
 Maybe HeaderValue)
_ -> 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 HeaderTable)
refH <- Maybe HeaderTable -> IO (IORef (Maybe HeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe HeaderTable
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 (InpObj -> Request) -> InpObj -> Request
forall a b. (a -> b) -> a -> b
$ HeaderTable
-> Maybe StreamId
-> IO HeaderValue
-> IORef (Maybe HeaderTable)
-> InpObj
InpObj HeaderTable
ht Maybe StreamId
forall a. Maybe a
Nothing IO HeaderValue
readB IORef (Maybe HeaderTable)
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
H2.outObjHeaders OutObj
outobj
    Context -> Stream -> Handle -> OutObj -> IO ()
sendBody Context
ctx Stream
strm Handle
th OutObj
outobj
    Stream -> IO ()
QUIC.shutdownStream Stream
strm