Benchmark server: all benchmarks from 'Utf8Html' can be requested through this
server via URL's. At the same time, the server shows some information about
these benchmarks at the root URL.
Example:
GET /manyAttributes HTTP/1.1
Will give you the @manyAttributes@ benchmark.
Example:
GET / HTTP/1.1
Will give you a page with some information and a benchmark listing As always in
a literate Haskell file, feel free to skip the imports.
> {-# LANGUAGE OverloadedStrings #-}
> module BenchmarkServer where
> import Prelude hiding (putStrLn)
> import Control.Concurrent (forkIO)
> import Data.Monoid (mappend, mconcat)
> import Control.Applicative ((<$>))
> import Control.Monad (forever, forM_)
> import Network.Socket (accept, sClose)
> import Network (listenOn, PortID (PortNumber))
> import System (getArgs)
> import Data.Char (ord, toLower)
> import Data.Map (Map)
> import qualified Data.Map as M
> import Network.Socket.ByteString (recv, send, sendAll)
> import qualified Network.Socket.ByteString.Lazy as LN (sendAll)
> import qualified Data.ByteString as SB
> import qualified Data.ByteString.Char8 as SBC
> import qualified Data.ByteString.Lazy as LB
> import HtmlBenchmarks (HtmlBenchmark (..), benchmarks)
> import Text.Blaze.Html5 hiding (map, head)
> import qualified Text.Blaze.Html5 as H
> import Text.Blaze.Html5.Attributes hiding (title, rows, accept)
> import qualified Text.Blaze.Html5.Attributes as A
> import Text.Blaze.Renderer.Utf8 (renderHtml, renderHtmlToByteStringIO)
Our first template is the root page. It's a static template, so it takes no
parameters.
> root :: Html
> root = docTypeHtml $ do
> H.head $ do
> title "BlazeHtml benchmarks"
> body ! A.style "width: 500px; margin: 0px auto 0px auto;" $ do
> h1 "Benchmarks"
> p $ do
> "This is a server showing BlazeHtml benchmarks, written using"
> " BlazeHtml. You can check out this benchmarks here, but it is"
> " probably more interesting to measure them using a tool like"
> " " >> code "ab" >> " or " >> code "httperf" >> "."
Now, the interesting part comes. `benchmarks` is a list of `HtmlBenchmark`'s,
imported from the `Utf8Html` module, which contains a number of benchmarks for
BlazeHtml. Here, we *loop* over these benchmarks and render them using the
`benchmark` template (defined below).
> forM_ benchmarks benchmark
Alternatively, one could have written `mconcat $ map benchmark benchmarks`.
And so, we arrive at our second benchmark. It simply pattern matches on a
`HtmlBenchmark` (which only has one constructor) and generates some HTML
describing this benchmark.
> benchmark :: HtmlBenchmark -> Html
> benchmark (HtmlBenchmark name _ _ description) = do
> h2 $ string name
> p $ description
> p $ "URL: " >> code ("/" >> string name)
> p $ a ! href (stringValue name) $ "Go to benchmark."
The auxiliary function builds the lookup table of benchmarks. Note that we store
the key as lowercase, so our URL's we be case-independent.
> benchmarkMap :: Map String HtmlBenchmark
> benchmarkMap = let t b@(HtmlBenchmark n _ _ _) = (map toLower n, b)
> in M.fromList $ map t benchmarks
This is the main function that runs the server. It takes one command line
argument: the port it should listen on.
> main :: IO ()
> main = do
> port <- PortNumber . fromIntegral . read . head <$> getArgs
> socket <- listenOn port
It forks for every incoming connection -- this is the standard control flow in
most Haskell servers.
> forever $ do
> (s, _) <- accept socket
> forkIO (respond s)
> where
Okay, now we get to the fun part: parsing the request and building the response.
> respond s = do
We take 1024 bytes from the socket -- this should be plenty. The HTTP request
will look something like `GET /url HTTP/1.1`. We are only interested in the url,
so we split the input on spaces and take the second part (`!!` is zero-based).
> input <- recv s 1024
> let requestUrl = (SB.split (fromIntegral $ ord ' ') input) !! 1
We split the URL on '/' characters and drop the first element of the resulting
list -- this element contains no information, since the URL will always start
with a '/'.
> case tail (SB.split (fromIntegral $ ord '/') requestUrl) of
If the result of this split is empty, it means we have accessed the root URL. In
that case, we send the root template back. The `ok s` sends a `200 OK` response,
letting the browser know all is fine.
> [""] -> do
> ok s
> LN.sendAll s $ renderHtml root
renderHtmlToByteStringIO root (sendAll s)
We do a very broad pattern match now, taking the first part of the URL. This is
supposed to be the name of a benchmark.
> (x : _) -> do
We convert the benchmark name to lowercase, and then look it up in a lookup
table which maps benchmark names to actual benchmarks.
> let requestedBenchmark = map toLower $ SBC.unpack x
> benchmark = M.lookup requestedBenchmark benchmarkMap
If all goes well, we found a benchmark. In that case, we can run and send it.
> case benchmark of
> Just (HtmlBenchmark _ f x _) -> do
> ok s
> LN.sendAll s $ renderHtml $ f x
renderHtmlToByteStringIO (f x) (sendAll s)
If the benchmark is not found, we give a `404` error back.
> Nothing -> notFound s
If our earlier pattern match failed (which really should not happen) we send a
`404`, too.
> _ -> notFound s
After this, we can safely close the connection.
> sClose s
Now, we have two functions which send a response header back to the browser,
nothing special going on here.
> ok s = do
> _ <- send s $ "HTTP/1.1 200 OK\r\n"
> `mappend` "Content-Type: text/html; charset=UTF-8\r\n"
> `mappend` "\r\n"
> return ()
>
> notFound s = do
> _ <- send s $ "HTTP/1.1 404 Not Found\r\n"
> `mappend` "Content-Type: text/html; charset=UTF-8\r\n"
> `mappend` "\r\n"
> `mappend` "<h1>Page not found</h1>"
> return ()
Note that while we directly used sockets here, this is probably *not* the way
you want to go if you are writing a serious web application. In that case, you
should use BlazeHtml behind some kind of web framework (unless you're really
masochistic).