{-# 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,

    -- * Internal
    runIO,
    ServerIO (..),
) where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import qualified Control.Exception as E
import Data.IORef
import GHC.Conc.Sync
import Network.HTTP.Semantics
import Network.HTTP.Semantics.Server
import Network.HTTP.Semantics.Server.Internal
import Network.HTTP2.Server.Internal (ServerIO (..))
import Network.QUIC (Connection, ConnectionInfo (..), Stream, getConnectionInfo)
import qualified Network.QUIC as QUIC
import qualified System.TimeManager as T

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 a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO 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
    IO ThreadId
myThreadId IO ThreadId -> (ThreadId -> 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
>>= \ThreadId
t -> ThreadId -> String -> IO ()
labelThread ThreadId
t String
"H3 run"
    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
    ThreadId -> String -> IO ()
labelThread ThreadId
tid String
"H3 unidirectional setter"
    Context -> ThreadId -> IO ()
addThreadId Context
ctx ThreadId
tid
    Context -> (Stream -> IO ()) -> IO ()
readerServer Context
ctx ((Stream -> IO ()) -> IO ()) -> (Stream -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Stream
strm ->
        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)
  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

runIO :: Connection -> Config -> (ServerIO Stream -> IO (IO ())) -> IO ()
runIO :: Connection -> Config -> (ServerIO Stream -> IO (IO ())) -> IO ()
runIO Connection
conn Config
conf ServerIO Stream -> IO (IO ())
action = IO Context -> (Context -> IO ()) -> (Context -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO 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
    ThreadId -> String -> IO ()
labelThread ThreadId
tid String
"H3 unidirectional setter"
    ConnectionInfo
info <- Connection -> IO ConnectionInfo
getConnectionInfo Connection
conn
    Context -> ThreadId -> IO ()
addThreadId Context
ctx ThreadId
tid
    TQueue (Stream, Request)
reqq <- IO (TQueue (Stream, Request))
forall a. IO (TQueue a)
newTQueueIO
    let sio :: ServerIO Stream
sio =
            ServerIO
                { sioMySockAddr :: SockAddr
sioMySockAddr = ConnectionInfo -> SockAddr
localSockAddr ConnectionInfo
info
                , sioPeerSockAddr :: SockAddr
sioPeerSockAddr = ConnectionInfo -> SockAddr
remoteSockAddr ConnectionInfo
info
                , sioReadRequest :: IO (Stream, Request)
sioReadRequest = STM (Stream, Request) -> IO (Stream, Request)
forall a. STM a -> IO a
atomically (STM (Stream, Request) -> IO (Stream, Request))
-> STM (Stream, Request) -> IO (Stream, Request)
forall a b. (a -> b) -> a -> b
$ TQueue (Stream, Request) -> STM (Stream, Request)
forall a. TQueue a -> STM a
readTQueue TQueue (Stream, Request)
reqq
                , sioWriteResponse :: Stream -> Response -> IO ()
sioWriteResponse = Context -> Stream -> Response -> IO ()
sendResponseIO Context
ctx
                }
        put :: (Stream, Request) -> IO ()
put (Stream, Request)
strmreq = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue (Stream, Request) -> (Stream, Request) -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Stream, Request)
reqq (Stream, Request)
strmreq
    IO ()
io <- ServerIO Stream -> IO (IO ())
action ServerIO Stream
sio
    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
concurrently_ IO ()
io (Context -> (Stream -> IO ()) -> IO ()
readerServer Context
ctx ((Stream -> IO ()) -> IO ()) -> (Stream -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> ((Stream, Request) -> IO ()) -> Stream -> IO ()
processRequestIO Context
ctx (Stream, Request) -> IO ()
put)
  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 -> (Stream -> IO ()) -> IO ()
readerServer :: Context -> (Stream -> IO ()) -> IO ()
readerServer Context
ctx Stream -> IO ()
action = 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
$ do
                ThreadId
tid <- IO ThreadId
myThreadId
                ThreadId -> String -> IO ()
labelThread ThreadId
tid String
"H3 unidirectional handler"
                Context -> Stream -> IO ()
unidirectional Context
ctx Stream
strm
            Context -> ThreadId -> IO ()
addThreadId Context
ctx ThreadId
tid
        | StreamId -> Bool
QUIC.isClientInitiatedBidirectional StreamId
sid = Stream -> IO ()
action 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 e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle SomeException -> IO ()
reset (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ThreadId
tid <- IO ThreadId
myThreadId
    ThreadId -> String -> IO ()
labelThread ThreadId
tid String
"H3 processRequest"
    Context -> (Handle -> IO ()) -> IO ()
forall a. Context -> (Handle -> IO a) -> IO a
withHandle Context
ctx ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
th -> do
        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 TokenHeaderTable
ht -> do
                Request
req <- Context -> Stream -> Source -> TokenHeaderTable -> IO Request
mkRequest Context
ctx Stream
strm Source
src TokenHeaderTable
ht
                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 AsyncException
E.ThreadKilled <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | 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

processRequestIO :: Context -> ((Stream, Request) -> IO ()) -> Stream -> IO ()
processRequestIO :: Context -> ((Stream, Request) -> IO ()) -> Stream -> IO ()
processRequestIO Context
ctx (Stream, Request) -> IO ()
put Stream
strm = (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle SomeException -> IO ()
reset (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    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 TokenHeaderTable
ht -> do
            Request
req <- Context -> Stream -> Source -> TokenHeaderTable -> IO Request
mkRequest Context
ctx Stream
strm Source
src TokenHeaderTable
ht
            (Stream, Request) -> IO ()
put (Stream
strm, Request
req)
  where
    reset :: SomeException -> IO ()
reset SomeException
se
        | Just AsyncException
E.ThreadKilled <- SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | 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

mkRequest
    :: Context
    -> Stream
    -> Source
    -> (TokenHeaderList, ValueTable)
    -> IO Request
mkRequest :: Context -> Stream -> Source -> TokenHeaderTable -> IO Request
mkRequest Context
ctx Stream
strm Source
src 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, Bool)
readB = Context
-> Source
-> IORef IFrame
-> IORef (Maybe TokenHeaderTable)
-> IO (FieldValue, Bool)
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, Bool)
-> IORef (Maybe TokenHeaderTable)
-> InpObj
InpObj TokenHeaderTable
ht Maybe StreamId
forall a. Maybe a
Nothing IO (FieldValue, Bool)
readB IORef (Maybe TokenHeaderTable)
refH
    Request -> IO Request
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
req

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

sendResponseIO
    :: Context -> Stream -> Response -> IO ()
sendResponseIO :: Context -> Stream -> Response -> IO ()
sendResponseIO Context
ctx Stream
strm (Response OutObj
outobj) =
    Context -> (Handle -> IO ()) -> IO ()
forall a. Context -> (Handle -> IO a) -> IO a
withHandle Context
ctx ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
th -> 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.closeStream Stream
strm