{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.Server.Run where
import Control.Concurrent (forkIO, killThread)
import qualified Control.Exception as E
import Imports
import Network.HTTP2
import Network.HTTP2.Server.API
import Network.HTTP2.Server.EncodeFrame
import Network.HTTP2.Server.Manager
import Network.HTTP2.Server.Receiver
import Network.HTTP2.Server.Sender
import Network.HTTP2.Server.Worker
import Network.HTTP2.Server.Context
run :: Config -> Server -> IO ()
run :: Config -> Server -> IO ()
run conf :: Config
conf@Config{BufferSize
Buffer
BufferSize -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> BufferSize -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> BufferSize
confWriteBuffer :: Config -> Buffer
confPositionReadMaker :: PositionReadMaker
confReadN :: BufferSize -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: BufferSize
confWriteBuffer :: Buffer
..} Server
server = do
Bool
ok <- IO Bool
checkPreface
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Context
ctx <- IO Context
newContext
Manager
mgr <- IO Manager
start
Manager -> IO () -> IO ()
setAction Manager
mgr (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Manager -> Server -> IO ()
worker Context
ctx Manager
mgr Server
server
BufferSize -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => BufferSize -> m a -> m ()
replicateM_ BufferSize
3 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Manager -> IO ()
spawnAction Manager
mgr
ThreadId
tid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Context -> (BufferSize -> IO ByteString) -> IO ()
frameReceiver Context
ctx BufferSize -> IO ByteString
confReadN
Context -> Config -> Manager -> IO ()
frameSender Context
ctx Config
conf Manager
mgr IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.finally` do
Context -> IO ()
clearContext Context
ctx
Manager -> IO ()
stop Manager
mgr
ThreadId -> IO ()
killThread ThreadId
tid
where
checkPreface :: IO Bool
checkPreface = do
ByteString
preface <- BufferSize -> IO ByteString
confReadN BufferSize
connectionPrefaceLength
if ByteString
connectionPreface ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
preface then do
Config -> ErrorCodeId -> ByteString -> IO ()
goaway Config
conf ErrorCodeId
ProtocolError ByteString
"Preface mismatch"
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
goaway :: Config -> ErrorCodeId -> ByteString -> IO ()
goaway :: Config -> ErrorCodeId -> ByteString -> IO ()
goaway Config{BufferSize
Buffer
BufferSize -> IO ByteString
PositionReadMaker
ByteString -> IO ()
confPositionReadMaker :: PositionReadMaker
confReadN :: BufferSize -> IO ByteString
confSendAll :: ByteString -> IO ()
confBufferSize :: BufferSize
confWriteBuffer :: Buffer
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> BufferSize -> IO ByteString
confSendAll :: Config -> ByteString -> IO ()
confBufferSize :: Config -> BufferSize
confWriteBuffer :: Config -> Buffer
..} ErrorCodeId
etype ByteString
debugmsg = ByteString -> IO ()
confSendAll ByteString
bytestream
where
bytestream :: ByteString
bytestream = BufferSize -> ErrorCodeId -> ByteString -> ByteString
goawayFrame BufferSize
0 ErrorCodeId
etype ByteString
debugmsg