{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HQ.Server (
run
, Config(..)
, allocSimpleConfig
, freeSimpleConfig
, Server
, Request
, H2.requestPath
, 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)
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 ()
where
sid :: StreamId
sid = Stream -> StreamId
QUIC.streamId Stream
strm
recvHeader :: Stream -> SockAddr -> IO HeaderTable
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
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