{-# 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 Data.IORef
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 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 -> (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 (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
    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
$ 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 (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 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 (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 (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
    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 (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) = do
    Handle
th <- Context -> IO Handle
registerThread Context
ctx -- fixme
    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