1{-# LANGUAGE OverloadedStrings #-}
2{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
3module HeadersText (headers) where
4
5import Common (pathTo, rechunkT)
6import Control.Applicative
7import Criterion.Main (bench, bgroup, nf)
8import Criterion.Types (Benchmark)
9import Data.Char (isSpace)
10import qualified Data.Attoparsec.Text as T
11import qualified Data.Attoparsec.Text.Lazy as TL
12import qualified Data.Text.IO as T
13
14header = do
15  name <- T.takeWhile1 (T.inClass "a-zA-Z0-9_-") <* T.char ':' <* T.skipSpace
16  body <- (:) <$> bodyLine <*> many (T.takeWhile1 isSpace *> bodyLine)
17  return (name, body)
18
19bodyLine = T.takeTill (\c -> c == '\r' || c == '\n') <* T.endOfLine
20
21requestLine =
22    (,,) <$>
23    (method <* T.skipSpace) <*>
24    (T.takeTill isSpace <* T.skipSpace) <*>
25    httpVersion
26  where method = "GET" <|> "POST"
27
28httpVersion = "HTTP/" *> ((,) <$> (int <* T.char '.') <*> int)
29
30responseLine = (,,) <$>
31               (httpVersion <* T.skipSpace) <*>
32               (int <* T.skipSpace) <*>
33               bodyLine
34
35int :: T.Parser Int
36int = T.decimal
37
38request = (,) <$> (requestLine <* T.endOfLine) <*> many header
39
40response = (,) <$> responseLine <*> many header
41
42headers :: IO Benchmark
43headers = do
44  req <- T.readFile =<< pathTo "http-request.txt"
45  resp <- T.readFile =<< pathTo "http-response.txt"
46  let reql    = rechunkT 4 req
47      respl   = rechunkT 4 resp
48  return $ bgroup "headers" [
49      bgroup "T" [
50        bench "request" $ nf (T.parseOnly request) req
51      , bench "response" $ nf (T.parseOnly response) resp
52      ]
53    , bgroup "TL" [
54        bench "request" $ nf (TL.parse request) reql
55      , bench "response" $ nf (TL.parse response) respl
56      ]
57    ]
58