{-# 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 (Server, PushPromise)
import qualified Network.HTTP2.Server as H2
import Network.HTTP2.Server.Internal (Request(..), Response(..), Aux(..))
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 = 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 forall a b. (a -> b) -> a -> b
$ \Context
ctx -> do
    ThreadId
tid <- IO () -> IO ThreadId
forkIO 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 <- 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 = forall {b}. IO b
loop
  where
    loop :: IO b
loop = do
        Context -> IO Stream
accept Context
ctx 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 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. Monad m => a -> m a
return () -- error
      | Bool
otherwise                                = 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 = forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
E.handleAny SomeException -> IO ()
reset 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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenMethod ValueTable
vt) forall a b. (a -> b) -> a -> b
$ do
              Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenScheme ValueTable
vt) forall a b. (a -> b) -> a -> b
$ do
              Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenAuthority ValueTable
vt) forall a b. (a -> b) -> a -> b
$ do
              Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ Token -> ValueTable -> Maybe HeaderValue
getHeaderValue Token
tokenPath ValueTable
vt) forall a b. (a -> b) -> a -> b
$ do
              Stream -> ApplicationProtocolError -> IO ()
QUIC.resetStream Stream
strm ApplicationProtocolError
H3MessageError
          -- fixme: Content-Length
          IORef IFrame
refI <- forall a. a -> IO (IORef a)
newIORef IFrame
IInit
          IORef (Maybe HeaderTable)
refH <- forall a. a -> IO (IORef a)
newIORef 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 forall a b. (a -> b) -> a -> b
$ HeaderTable
-> Maybe StreamId
-> IO HeaderValue
-> IORef (Maybe HeaderTable)
-> InpObj
InpObj HeaderTable
ht forall a. Maybe a
Nothing IO HeaderValue
readB IORef (Maybe HeaderTable)
refH
          let aux :: Aux
aux = Handle -> Aux
Aux Handle
th
          Server
server Request
req Aux
aux 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) <- 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 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