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