awpr/HTTP2Example.hs Secret

## HTTP2Example.hs
{-# LANGUAGE OverloadedStrings, TupleSections, RankNTypes #-}
module Main where

import qualified Data.ByteString.Builder as B
import           Data.Monoid ((<>))

import qualified Network.HTTP.Types as H
import           Network.HTTP.Types.Status (badRequest400, ok200, notFound404)
import           Network.Wai
    ( Application
    , FilePart(..)
    , requestHeaders
    , responseLBS
    , pathInfo
    )
import           Network.Wai.HTTP2
    ( HTTP2Application
    , PushPromise(..)
    , Responder
    , respond
    , respondFile
    , respondFilePart
    , respondIO
    , streamBuilder
    )
import           Network.Wai.Handler.Warp
    ( defaultSettings
    , setOnException
    , setPort
    , setFdCacheDuration
    )
import           Network.Wai.Handler.WarpTLS
    ( runHTTP2TLS
    , tlsSettings
    )

someHtml :: B.Builder
someHtml = mconcat $ map (<> "\n")
    [ "<!DOCTYPE html>"
    , "<html>"
    ,     "<body>"
    ,         "<script type=\"text/javascript\" src=\"/script.js\"></script>"
    ,         "<img src=\"/img/ego_cover.jpg\" />"
    ,         "hi"
    ,     "</body>"
    , "</html>"
    ]

scriptDotJs :: Responder
scriptDotJs =
    respond ok200 [("cache-control", "max-age=10000,public")] mempty $
        streamBuilder "document.write(\"got expected script\");"

indexPage :: HTTP2Application
indexPage _ push = respondIO $ do
    pushed <- push
        (PushPromise "GET" "/script.js" "localhost:1204" "https" [])
        scriptDotJs

    pushed2 <- push
        (PushPromise "GET" "/img/ego_cover.jpg" "localhost:1204" "https" []) $
        egoCover []

    print (pushed, pushed2)

    return $ respond ok200 [("cache-control", "max-age=10000,public")] mempty $
        --streamFilePart "example.html" Nothing
        streamBuilder someHtml

-- Pushing this when it won't be used by the associated resource hangs the
-- SpdySession in Chrome by consuming the entire connection window in an
-- un-adopted pushed stream.  (Total size ~= 10 MB if you want to substitute
-- another file)
excessivelyLargeUnwantedResource :: Responder
excessivelyLargeUnwantedResource =
    respondFilePart ok200 [] "/dev/urandom" $ FilePart 0 10485760 10485760

-- This one's fine -- it's only 2MB.
egoCover :: H.RequestHeaders -> Responder
egoCover = respondFile ok200 [] "/home/sp/Music/David Maxim Micic/EGO/cover.jpg"

notFound :: Responder
notFound = respond notFound404 [] mempty $ streamBuilder "Not found."

http11NotSupported :: Application
http11NotSupported _ respondFn = respondFn $
    responseLBS badRequest400 []
        "Don't use HTTP/1.1 -- this server is for testing HTTP/2."

-- An Application that only knows the URLs "/" and "/img/ego_cover.jpg".  The
-- handler for "/" will push "/script.js", so the script will execute iff the
-- push was successfully adopted.
app :: HTTP2Application
app req push = case pathInfo req of
    ["img", "ego_cover.jpg"] -> egoCover $ requestHeaders req
    [] -> indexPage req push
    _ -> notFound

main :: IO ()
main = do
    let settings = setFdCacheDuration 1
                 . setPort 1204
                 . setOnException (\_ e -> print (show e))
                 $ defaultSettings
        tlssettings = tlsSettings
            "/tmp/certificate.pem"
            "/tmp/test_key.pem"
    runHTTP2TLS tlssettings settings app http11NotSupported
	{-# LANGUAGE OverloadedStrings, TupleSections, RankNTypes #-}
	module Main where

	import qualified Data.ByteString.Builder as B
	import Data.Monoid ((<>))

	import qualified Network.HTTP.Types as H
	import Network.HTTP.Types.Status (badRequest400, ok200, notFound404)
	import Network.Wai
	( Application
	, FilePart(..)
	, requestHeaders
	, responseLBS
	, pathInfo
	)
	import Network.Wai.HTTP2
	( HTTP2Application
	, PushPromise(..)
	, Responder
	, respond
	, respondFile
	, respondFilePart
	, respondIO
	, streamBuilder
	)
	import Network.Wai.Handler.Warp
	( defaultSettings
	, setOnException
	, setPort
	, setFdCacheDuration
	)
	import Network.Wai.Handler.WarpTLS
	( runHTTP2TLS
	, tlsSettings
	)

	someHtml :: B.Builder
	someHtml = mconcat $ map (<> "\n")
	[ "<!DOCTYPE html>"
	, "<html>"
	, "<body>"
	, "<script type=\"text/javascript\" src=\"/script.js\"></script>"
	, "<img src=\"/img/ego_cover.jpg\" />"
	, "hi"
	, "</body>"
	, "</html>"
	]

	scriptDotJs :: Responder
	scriptDotJs =
	respond ok200 [("cache-control", "max-age=10000,public")] mempty $
	streamBuilder "document.write(\"got expected script\");"

	indexPage :: HTTP2Application
	indexPage _ push = respondIO $ do
	pushed <- push
	(PushPromise "GET" "/script.js" "localhost:1204" "https" [])
	scriptDotJs

	pushed2 <- push
	(PushPromise "GET" "/img/ego_cover.jpg" "localhost:1204" "https" []) $
	egoCover []

	print (pushed, pushed2)

	return $ respond ok200 [("cache-control", "max-age=10000,public")] mempty $
	--streamFilePart "example.html" Nothing
	streamBuilder someHtml

	-- Pushing this when it won't be used by the associated resource hangs the
	-- SpdySession in Chrome by consuming the entire connection window in an
	-- un-adopted pushed stream. (Total size ~= 10 MB if you want to substitute
	-- another file)
	excessivelyLargeUnwantedResource :: Responder
	excessivelyLargeUnwantedResource =
	respondFilePart ok200 [] "/dev/urandom" $ FilePart 0 10485760 10485760

	-- This one's fine -- it's only 2MB.
	egoCover :: H.RequestHeaders -> Responder
	egoCover = respondFile ok200 [] "/home/sp/Music/David Maxim Micic/EGO/cover.jpg"

	notFound :: Responder
	notFound = respond notFound404 [] mempty $ streamBuilder "Not found."

	http11NotSupported :: Application
	http11NotSupported _ respondFn = respondFn $
	responseLBS badRequest400 []
	"Don't use HTTP/1.1 -- this server is for testing HTTP/2."

	-- An Application that only knows the URLs "/" and "/img/ego_cover.jpg". The
	-- handler for "/" will push "/script.js", so the script will execute iff the
	-- push was successfully adopted.
	app :: HTTP2Application
	app req push = case pathInfo req of
	["img", "ego_cover.jpg"] -> egoCover $ requestHeaders req
	[] -> indexPage req push
	_ -> notFound

	main :: IO ()
	main = do
	let settings = setFdCacheDuration 1
	. setPort 1204
	. setOnException (\_ e -> print (show e))
	$ defaultSettings
	tlssettings = tlsSettings
	"/tmp/certificate.pem"
	"/tmp/test_key.pem"
	runHTTP2TLS tlssettings settings app http11NotSupported