{-# 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
  , H2.requestPath
  -- * Response
  , Response
  -- ** Creating response
  , H2.responseNoBody
  , H2.responseFile
  , H2.responseStreaming
  , H2.responseBuilder
  ) where

import Control.Concurrent
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString as BS
import Data.IORef
import Foreign.ForeignPtr
import Network.HPACK (HeaderTable, toHeaderTable)
import Network.HTTP2.Internal (InpObj(..))
import qualified Network.HTTP2.Internal as H2
import qualified Network.HTTP2.Server as H2
import Network.HTTP2.Server (Server, PushPromise)
import Network.HTTP2.Server.Internal (Request(..), Response(..), Aux(..))
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
    SockAddr
myaddr <- ConnectionInfo -> SockAddr
QUIC.localSockAddr (ConnectionInfo -> SockAddr) -> IO ConnectionInfo -> IO SockAddr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> IO ConnectionInfo
QUIC.getConnectionInfo Connection
conn
    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 -> Server -> Stream -> IO ()
processRequest Config
conf SockAddr
myaddr Server
server Stream
strm) (\Either SomeException ()
_ -> Stream -> IO ()
QUIC.closeStream Stream
strm)

processRequest :: Config -> SockAddr -> Server -> Stream -> IO ()
processRequest :: Config -> SockAddr -> Server -> Stream -> IO ()
processRequest Config
conf SockAddr
myaddr Server
server Stream
strm
  | StreamId -> Bool
QUIC.isClientInitiatedBidirectional StreamId
sid = do
        Handle
th <- Manager -> IO () -> IO Handle
T.register (Config -> Manager
confTimeoutManager Config
conf) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        HeaderTable
vt <- Stream -> SockAddr -> IO HeaderTable
recvHeader Stream
strm SockAddr
myaddr
        Source
src <- Stream -> IO Source
newSource Stream
strm
        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 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
$ HeaderTable
-> Maybe StreamId
-> IO ByteString
-> IORef (Maybe HeaderTable)
-> InpObj
InpObj HeaderTable
vt Maybe StreamId
forall a. Maybe a
Nothing IO ByteString
readB IORef (Maybe HeaderTable)
refH
            aux :: Aux
aux = Handle -> Aux
Aux Handle
th
        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 (m :: * -> *) a. Monad m => a -> m a
return () -- fixme: should consume the data?
  where
    sid :: StreamId
sid = Stream -> StreamId
QUIC.streamId Stream
strm

recvHeader :: Stream -> SockAddr -> IO HeaderTable
recvHeader :: Stream -> SockAddr -> IO HeaderTable
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 :: [(CI ByteString, ByteString)]
vt = (CI ByteString
":path",ByteString
path)
           (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: (CI ByteString
":method", ByteString
method)
           (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: (CI ByteString
":scheme", ByteString
"https")
           (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: (CI ByteString
":authority", ByteString
auth)
           (CI ByteString, ByteString)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. a -> [a] -> [a]
: []
    [(CI ByteString, ByteString)] -> IO HeaderTable
toHeaderTable [(CI ByteString, ByteString)]
vt
  where
    recvRequestLine :: ([ByteString] -> [ByteString]) -> IO (a, ByteString)
recvRequestLine [ByteString] -> [ByteString]
builder = do
        ByteString
bs <- Stream -> StreamId -> IO ByteString
QUIC.recvStream Stream
strm StreamId
1024
        if ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then do
            (a, ByteString) -> IO (a, ByteString)
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 = StreamId -> ByteString -> ByteString
BS.drop StreamId
4 ByteString
bs
        path :: ByteString
path = StreamId -> ByteString -> ByteString
BS.take (ByteString -> StreamId
BS.length ByteString
path0 StreamId -> StreamId -> StreamId
forall a. Num a => a -> a -> a
- StreamId
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
H2.outObjBody OutObj
outobj of
    OutBody
H2.OutBodyNone -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    H2.OutBodyFile (H2.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
                     H2.Closer IO ()
closer       -> do
                         Handle
th <- Manager -> IO () -> IO Handle
T.register Manager
timmgr IO ()
closer
                         IO () -> IO (IO ())
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
                     H2.Refresher IO ()
refresher -> IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
refresher
        let next :: DynaNext
next = PositionRead -> FileOffset -> FileOffset -> IO () -> DynaNext
H2.fillFileBodyGetNext PositionRead
pread FileOffset
fileoff FileOffset
bytecount IO ()
refresh
        Stream -> DynaNext -> IO ()
sendNext Stream
strm DynaNext
next
    H2.OutBodyBuilder Builder
builder -> do
        let next :: DynaNext
next = Builder -> DynaNext
H2.fillBuilderBodyGetNext Builder
builder
        Stream -> DynaNext -> IO ()
sendNext Stream
strm DynaNext
next
    H2.OutBodyStreaming (Builder -> IO ()) -> IO () -> IO ()
strmbdy -> Stream -> ((Builder -> IO ()) -> IO () -> IO ()) -> IO ()
sendStreaming Stream
strm (Builder -> IO ()) -> IO () -> IO ()
strmbdy

sendNext :: Stream -> H2.DynaNext -> IO ()
sendNext :: Stream -> DynaNext -> IO ()
sendNext Stream
strm DynaNext
action = do
    ForeignPtr Word8
fp <- StreamId -> IO (ForeignPtr Word8)
forall a. StreamId -> IO (ForeignPtr a)
BS.mallocByteString StreamId
2048
    H2.Next StreamId
len 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 StreamId
2048 StreamId
65536 -- window size
    if StreamId
len StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
== StreamId
0 then
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else do
        let bs :: ByteString
bs = ForeignPtr Word8 -> StreamId -> StreamId -> ByteString
PS ForeignPtr Word8
fp StreamId
0 StreamId
len
        Stream -> ByteString -> IO ()
QUIC.sendStream Stream
strm ByteString
bs
        case Maybe DynaNext
mnext of
          Maybe DynaNext
Nothing   -> () -> IO ()
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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()
        loop (B.More StreamId
_ BufferWriter
writer) =
            Stream -> BufferWriter -> IO Next
newByteStringAndSend Stream
strm BufferWriter
writer IO Next -> (Next -> IO ()) -> IO ()
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 (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 <- StreamId -> IO (ForeignPtr Word8)
forall a. StreamId -> IO (ForeignPtr a)
BS.mallocByteString StreamId
2048
    (StreamId
len, Next
signal) <- ForeignPtr Word8
-> (Ptr Word8 -> IO (StreamId, Next)) -> IO (StreamId, Next)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO (StreamId, Next)) -> IO (StreamId, Next))
-> (Ptr Word8 -> IO (StreamId, Next)) -> IO (StreamId, Next)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf -> BufferWriter
action Ptr Word8
buf StreamId
2048
    if StreamId
len StreamId -> StreamId -> Bool
forall a. Eq a => a -> a -> Bool
== StreamId
0 then
        Next -> IO Next
forall (m :: * -> *) a. Monad m => a -> m a
return Next
signal
      else do
        let bs :: ByteString
bs = ForeignPtr Word8 -> StreamId -> StreamId -> ByteString
PS ForeignPtr Word8
fp StreamId
0 StreamId
len
        Stream -> ByteString -> IO ()
QUIC.sendStream Stream
strm ByteString
bs
        Next -> IO Next
forall (m :: * -> *) a. Monad m => a -> m a
return Next
signal