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
|
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import qualified Control.Exception as E
import Control.Monad
import Crypto.Hash (Context, SHA1) -- cryptonite
import qualified Crypto.Hash as CH
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Builder (byteString)
import qualified Data.ByteString.Char8 as C8
import Network.HPACK
import Network.HPACK.Token
import Network.HTTP.Types
import Network.Run.TCP -- network-run
import System.Environment
import System.Exit
import Network.HTTP2.Server
main :: IO ()
main = do
args <- getArgs
(host, port) <- case args of
[h, p] -> return (h, p)
_ -> do
putStrLn "server <addr> <port>"
exitFailure
runTCPServer (Just host) port runHTTP2Server
where
runHTTP2Server s =
E.bracket
(allocSimpleConfig s 4096)
freeSimpleConfig
(\conf -> run defaultServerConfig conf server)
server req _aux sendResponse = case getHeaderValue tokenMethod vt of
Just "GET" -> sendResponse responseHello []
Just "POST" -> sendResponse (responseEcho req) []
_ -> sendResponse response404 []
where
(_, vt) = requestHeaders req
responseHello :: Response
responseHello = responseBuilder ok200 header body
where
header = [("Content-Type", "text/plain")]
body = byteString "Hello, world!\n"
response404 :: Response
response404 = responseNoBody notFound404 []
responseEcho :: Request -> Response
responseEcho req = setResponseTrailersMaker h2rsp maker
where
h2rsp = responseStreaming ok200 header streamingBody
header = [("Content-Type", "text/plain")]
streamingBody write _flush = loop
where
loop = do
bs <- getRequestBodyChunk req
unless (B.null bs) $ do
void $ write $ byteString bs
loop
maker = trailersMaker (CH.hashInit :: Context SHA1)
-- Strictness is important for Context.
trailersMaker :: Context SHA1 -> Maybe ByteString -> IO NextTrailersMaker
trailersMaker ctx Nothing = return $ Trailers [("X-SHA1", sha1)]
where
!sha1 = C8.pack $ show $ CH.hashFinalize ctx
trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'
where
!ctx' = CH.hashUpdate ctx bs
|
