{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

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

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

    -- * HQ server
    Server,

    -- * Request
    Request,

    -- ** Accessing request
    requestPath,

    -- * Response
    Response,

    -- ** Creating response
    responseNoBody,
    responseFile,
    responseStreaming,
    responseBuilder,
) where

import Control.Concurrent
import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.ByteString.Internal as BS
import Data.IORef
import Foreign.ForeignPtr
import Network.HPACK.Internal (toTokenHeaderTable)
import Network.HTTP.Semantics.IO
import Network.HTTP.Semantics.Server
import Network.HTTP.Semantics.Server.Internal

import Network.QUIC (Connection, Stream)
import qualified Network.QUIC as QUIC
import Network.SockAddr (showSockAddrBS)
import Network.Socket (SockAddr)
import qualified System.TimeManager as T

import Imports
import Network.HTTP3.Config
import Network.HTTP3.Recv (newSource, readSource)

-- | Running an HQ server.
run :: Connection -> Config -> Server -> IO ()
run :: Connection -> Config -> Server -> IO ()
run Connection
conn Config
conf Server
server = do
    ConnectionInfo
info <- Connection -> IO ConnectionInfo
QUIC.getConnectionInfo Connection
conn
    let mysa :: SockAddr
mysa = ConnectionInfo -> SockAddr
QUIC.localSockAddr ConnectionInfo
info
        peersa :: SockAddr
peersa = ConnectionInfo -> SockAddr
QUIC.remoteSockAddr ConnectionInfo
info
    IO ThreadId -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Stream
strm <- Connection -> IO Stream
QUIC.acceptStream Connection
conn
        IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally
            (Config -> SockAddr -> SockAddr -> Server -> Stream -> IO ()
processRequest Config
conf SockAddr
mysa SockAddr
peersa Server
server Stream
strm)
            (\Either SomeException ()
_ -> Stream -> IO ()
QUIC.closeStream Stream
strm)

processRequest :: Config -> SockAddr -> SockAddr -> Server -> Stream -> IO ()
processRequest :: Config -> SockAddr -> SockAddr -> Server -> Stream -> IO ()
processRequest Config
conf SockAddr
mysa SockAddr
peersa Server
server Stream
strm
    | Int -> Bool
QUIC.isClientInitiatedBidirectional Int
sid = do
        Handle
th <- Manager -> IO () -> IO Handle
T.register (Config -> Manager
confTimeoutManager Config
conf) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        TokenHeaderTable
vt <- Stream -> SockAddr -> IO TokenHeaderTable
recvHeader Stream
strm SockAddr
mysa
        Source
src <- Stream -> IO Source
newSource Stream
strm
        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 ByteString
readB = Source -> IO ByteString
readSource Source
src
            req :: Request
req = InpObj -> Request
Request (InpObj -> Request) -> InpObj -> Request
forall a b. (a -> b) -> a -> b
$ TokenHeaderTable
-> Maybe Int
-> IO ByteString
-> IORef (Maybe TokenHeaderTable)
-> InpObj
InpObj TokenHeaderTable
vt Maybe Int
forall a. Maybe a
Nothing IO ByteString
readB IORef (Maybe TokenHeaderTable)
refH
            aux :: Aux
aux = Handle -> SockAddr -> SockAddr -> Aux
Aux Handle
th SockAddr
mysa SockAddr
peersa
        Server
server Request
req Aux
aux ((Response -> [PushPromise] -> IO ()) -> IO ())
-> (Response -> [PushPromise] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Stream -> Response -> [PushPromise] -> IO ()
sendResponse Config
conf Stream
strm
    | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- fixme: should consume the data?
  where
    sid :: Int
sid = Stream -> Int
QUIC.streamId Stream
strm

recvHeader :: Stream -> SockAddr -> IO TokenHeaderTable
recvHeader :: Stream -> SockAddr -> IO TokenHeaderTable
recvHeader Stream
strm SockAddr
myaddr = do
    (ByteString
method, ByteString
path) <- ([ByteString] -> [ByteString]) -> IO (ByteString, ByteString)
forall {a}.
IsString a =>
([ByteString] -> [ByteString]) -> IO (a, ByteString)
recvRequestLine [ByteString] -> [ByteString]
forall a. a -> a
id
    let auth :: ByteString
auth = SockAddr -> ByteString
showSockAddrBS SockAddr
myaddr
        vt :: [(HeaderName, ByteString)]
vt =
            (HeaderName
":path", ByteString
path)
                (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: (HeaderName
":method", ByteString
method)
                (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: (HeaderName
":scheme", ByteString
"https")
                (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: (HeaderName
":authority", ByteString
auth)
                (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: []
    [(HeaderName, ByteString)] -> IO TokenHeaderTable
toTokenHeaderTable [(HeaderName, ByteString)]
vt
  where
    recvRequestLine :: ([ByteString] -> [ByteString]) -> IO (a, ByteString)
recvRequestLine [ByteString] -> [ByteString]
builder = do
        ByteString
bs <- Stream -> Int -> IO ByteString
QUIC.recvStream Stream
strm Int
1024
        if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
""
            then do
                (a, ByteString) -> IO (a, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, ByteString) -> IO (a, ByteString))
-> (a, ByteString) -> IO (a, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> (a, ByteString)
forall {a}. IsString a => ByteString -> (a, ByteString)
parseRequestLine (ByteString -> (a, ByteString)) -> ByteString -> (a, ByteString)
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
builder []
            else ([ByteString] -> [ByteString]) -> IO (a, ByteString)
recvRequestLine ([ByteString] -> [ByteString]
builder ([ByteString] -> [ByteString])
-> ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:))
    parseRequestLine :: ByteString -> (a, ByteString)
parseRequestLine ByteString
bs = (a
method, ByteString
path)
      where
        method :: a
method = a
"GET"
        path0 :: ByteString
path0 = Int -> ByteString -> ByteString
BS.drop Int
4 ByteString
bs
        path :: ByteString
path = Int -> ByteString -> ByteString
BS.take (ByteString -> Int
BS.length ByteString
path0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) ByteString
path0

sendResponse :: Config -> Stream -> Response -> [PushPromise] -> IO ()
sendResponse :: Config -> Stream -> Response -> [PushPromise] -> IO ()
sendResponse Config
conf Stream
strm (Response OutObj
outobj) [PushPromise]
_ = case OutObj -> OutBody
outObjBody OutObj
outobj of
    OutBody
OutBodyNone -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    OutBodyFile (FileSpec FilePath
path FileOffset
fileoff FileOffset
bytecount) -> do
        (PositionRead
pread, Sentinel
sentinel') <- Config -> PositionReadMaker
confPositionReadMaker Config
conf FilePath
path
        let timmgr :: Manager
timmgr = Config -> Manager
confTimeoutManager Config
conf
        IO ()
refresh <- case Sentinel
sentinel' of
            Closer IO ()
closer -> do
                Handle
th <- Manager -> IO () -> IO Handle
T.register Manager
timmgr IO ()
closer
                IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
T.tickle Handle
th
            Refresher IO ()
refresher -> IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
refresher
        let next :: DynaNext
next = PositionRead -> FileOffset -> FileOffset -> IO () -> DynaNext
fillFileBodyGetNext PositionRead
pread FileOffset
fileoff FileOffset
bytecount IO ()
refresh
        Stream -> DynaNext -> IO ()
sendNext Stream
strm DynaNext
next
    OutBodyBuilder Builder
builder -> do
        let next :: DynaNext
next = Builder -> DynaNext
fillBuilderBodyGetNext Builder
builder
        Stream -> DynaNext -> IO ()
sendNext Stream
strm DynaNext
next
    OutBodyStreaming (Builder -> IO ()) -> IO () -> IO ()
strmbdy -> Stream -> ((Builder -> IO ()) -> IO () -> IO ()) -> IO ()
sendStreaming Stream
strm (Builder -> IO ()) -> IO () -> IO ()
strmbdy
    OutBodyStreamingUnmask (forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ()
_ ->
        FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"sendResponse: server does not support OutBodyStreamingUnmask"

sendNext :: Stream -> DynaNext -> IO ()
sendNext :: Stream -> DynaNext -> IO ()
sendNext Stream
strm DynaNext
action = do
    ForeignPtr Word8
fp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
BS.mallocByteString Int
2048
    Next Int
len Bool
_reqflush Maybe DynaNext
mnext <- ForeignPtr Word8 -> (Ptr Word8 -> IO Next) -> IO Next
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO Next) -> IO Next)
-> (Ptr Word8 -> IO Next) -> IO Next
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf -> DynaNext
action Ptr Word8
buf Int
2048 Int
65536 -- window size
    if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
            let bs :: ByteString
bs = ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
fp Int
0 Int
len
            Stream -> ByteString -> IO ()
QUIC.sendStream Stream
strm ByteString
bs
            case Maybe DynaNext
mnext of
                Maybe DynaNext
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just DynaNext
next -> Stream -> DynaNext -> IO ()
sendNext Stream
strm DynaNext
next

sendStreaming :: Stream -> ((Builder -> IO ()) -> IO () -> IO ()) -> IO ()
sendStreaming :: Stream -> ((Builder -> IO ()) -> IO () -> IO ()) -> IO ()
sendStreaming Stream
strm (Builder -> IO ()) -> IO () -> IO ()
strmbdy = do
    (Builder -> IO ()) -> IO () -> IO ()
strmbdy Builder -> IO ()
write IO ()
flush
  where
    flush :: IO ()
flush = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    write :: Builder -> IO ()
write Builder
builder = do
        Stream -> BufferWriter -> IO Next
newByteStringAndSend Stream
strm (Builder -> BufferWriter
B.runBuilder Builder
builder) IO Next -> (Next -> 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
>>= Next -> IO ()
loop
      where
        loop :: Next -> IO ()
loop Next
B.Done = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        loop (B.More Int
_ BufferWriter
writer) =
            Stream -> BufferWriter -> IO Next
newByteStringAndSend Stream
strm BufferWriter
writer IO Next -> (Next -> 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
>>= Next -> IO ()
loop
        loop (B.Chunk ByteString
bs BufferWriter
writer) = do
            Stream -> ByteString -> IO ()
QUIC.sendStream Stream
strm ByteString
bs
            Stream -> BufferWriter -> IO Next
newByteStringAndSend Stream
strm BufferWriter
writer IO Next -> (Next -> 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
>>= Next -> IO ()
loop

newByteStringAndSend :: Stream -> B.BufferWriter -> IO B.Next
newByteStringAndSend :: Stream -> BufferWriter -> IO Next
newByteStringAndSend Stream
strm BufferWriter
action = do
    ForeignPtr Word8
fp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
BS.mallocByteString Int
2048
    (Int
len, Next
signal) <- ForeignPtr Word8 -> (Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next))
-> (Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf -> BufferWriter
action Ptr Word8
buf Int
2048
    if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then Next -> IO Next
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Next
signal
        else do
            let bs :: ByteString
bs = ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
fp Int
0 Int
len
            Stream -> ByteString -> IO ()
QUIC.sendStream Stream
strm ByteString
bs
            Next -> IO Next
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Next
signal