1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.Server.Run where
import Control.Concurrent.STM
import Control.Exception
import Imports
import Network.Control (defaultMaxData)
import Network.Socket (SockAddr)
import UnliftIO.Async (concurrently_)
import Network.HTTP2.Frame
import Network.HTTP2.H2
import Network.HTTP2.Server.Types
import Network.HTTP2.Server.Worker
-- | Server configuration
data ServerConfig = ServerConfig
{ numberOfWorkers :: Int
-- ^ The number of workers
, connectionWindowSize :: WindowSize
-- ^ The window size of incoming streams
, settings :: Settings
-- ^ Settings
}
deriving (Eq, Show)
-- | The default server config.
--
-- >>> defaultServerConfig
-- ServerConfig {numberOfWorkers = 8, connectionWindowSize = 1048576, settings = Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Just 64, initialWindowSize = 262144, maxFrameSize = 16384, maxHeaderListSize = Nothing}}
defaultServerConfig :: ServerConfig
defaultServerConfig =
ServerConfig
{ numberOfWorkers = 8
, connectionWindowSize = defaultMaxData
, settings = defaultSettings
}
----------------------------------------------------------------
-- | Running HTTP/2 server.
run :: ServerConfig -> Config -> Server -> IO ()
run sconf@ServerConfig{numberOfWorkers} conf server = do
ok <- checkPreface conf
when ok $ do
(ctx, mgr) <- setup sconf conf
let wc = fromContext ctx
setAction mgr $ worker wc mgr server
replicateM_ numberOfWorkers $ spawnAction mgr
runH2 conf ctx mgr
----------------------------------------------------------------
data ServerIO = ServerIO
{ sioMySockAddr :: SockAddr
, sioPeerSockAddr :: SockAddr
, sioReadRequest :: IO (StreamId, Stream, Request)
, sioWriteResponse :: Stream -> Response -> IO ()
, sioWriteBytes :: ByteString -> IO ()
}
-- | Launching a receiver and a sender without workers.
-- Any frames can be sent with `sioWriteBytes`.
runIO
:: ServerConfig
-> Config
-> (ServerIO -> IO (IO ()))
-> IO ()
runIO sconf conf@Config{..} action = do
ok <- checkPreface conf
when ok $ do
(ctx@Context{..}, mgr) <- setup sconf conf
let ServerInfo{..} = toServerInfo roleInfo
get = do
Input strm inObj <- atomically $ readTQueue inputQ
return (streamNumber strm, strm, Request inObj)
putR strm (Response outObj) = do
let out = Output strm outObj OObj Nothing (return ())
enqueueOutput outputQ out
putB bs = enqueueControl controlQ $ CFrames Nothing [bs]
io <- action $ ServerIO confMySockAddr confPeerSockAddr get putR putB
concurrently_ io $ runH2 conf ctx mgr
checkPreface :: Config -> IO Bool
checkPreface conf@Config{..} = do
preface <- confReadN connectionPrefaceLength
if connectionPreface /= preface
then do
goaway conf ProtocolError "Preface mismatch"
return False
else return True
setup :: ServerConfig -> Config -> IO (Context, Manager)
setup ServerConfig{..} conf@Config{..} = do
serverInfo <- newServerInfo
ctx <-
newContext
serverInfo
conf
0
connectionWindowSize
settings
-- Workers, worker manager and timer manager
mgr <- start confTimeoutManager
return (ctx, mgr)
runH2 :: Config -> Context -> Manager -> IO ()
runH2 conf ctx mgr = do
let runReceiver = frameReceiver ctx conf
runSender = frameSender ctx conf mgr
runBackgroundThreads = concurrently_ runReceiver runSender
stopAfter mgr runBackgroundThreads $ \res -> do
closeAllStreams (oddStreamTable ctx) (evenStreamTable ctx) $
either Just (const Nothing) res
case res of
Left err ->
throwIO err
Right x ->
return x
-- connClose must not be called here since Run:fork calls it
goaway :: Config -> ErrorCode -> ByteString -> IO ()
goaway Config{..} etype debugmsg = confSendAll bytestream
where
bytestream = goawayFrame 0 etype debugmsg
|
