1{-# LANGUAGE BangPatterns, CPP, FlexibleContexts #-}
2
3module Main (main) where
4
5import Control.Applicative
6import Control.Exception (bracket)
7import System.Environment (getArgs)
8import System.IO (hClose, openFile, IOMode(ReadMode))
9import Text.Parsec.Char (anyChar, char, satisfy, string)
10import Text.Parsec.Combinator (many1, manyTill, skipMany1)
11import Text.Parsec.Prim hiding (many, token, (<|>))
12import qualified Data.IntSet as S
13
14#if 1
15import Text.Parsec.ByteString.Lazy (Parser, parseFromFile)
16import qualified Data.ByteString.Lazy as B
17#else
18import Text.Parsec.ByteString (Parser, parseFromFile)
19import qualified Data.ByteString as B
20#endif
21
22token :: Stream s m Char => ParsecT s u m Char
23token = satisfy $ \c -> S.notMember (fromEnum c) set
24  where set = S.fromList . map fromEnum $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255']
25
26isHorizontalSpace :: Char -> Bool
27isHorizontalSpace c = c == ' ' || c == '\t'
28
29skipHSpaces :: Stream s m Char => ParsecT s u m ()
30skipHSpaces = skipMany1 (satisfy isHorizontalSpace)
31
32data Request = Request {
33      _requestMethod   :: String
34    , _requestUri      :: String
35    , _requestProtocol :: String
36    } deriving (Eq, Ord, Show)
37
38requestLine :: Stream s m Char => ParsecT s u m Request
39requestLine = do
40  method <- many1 token <* skipHSpaces
41  uri <- many1 (satisfy (not . isHorizontalSpace)) <* skipHSpaces <* string "HTTP/"
42  proto <- many httpVersion <* endOfLine
43  return $! Request method uri proto
44 where
45  httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.'
46
47endOfLine :: Stream s m Char => ParsecT s u m ()
48endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ())
49
50data Header = Header {
51      _headerName  :: String
52    , _headerValue :: [String]
53    } deriving (Eq, Ord, Show)
54
55messageHeader :: Stream s m Char => ParsecT s u m Header
56messageHeader = do
57  header <- many1 token <* char ':' <* skipHSpaces
58  body <- manyTill anyChar endOfLine
59  conts <- many $ skipHSpaces *> manyTill anyChar endOfLine
60  return $! Header header (body:conts)
61
62request :: Stream s m Char => ParsecT s u m (Request, [Header])
63request = (,) <$> requestLine <*> many messageHeader <* endOfLine
64
65listy :: FilePath -> IO ()
66listy arg = do
67  r <- parseFromFile (many request) arg
68  case r of
69    Left err -> putStrLn $ arg ++ ": " ++ show err
70    Right rs -> print (length rs)
71
72chunky :: FilePath -> IO ()
73chunky arg = bracket (openFile arg ReadMode) hClose $ \h ->
74               loop (0::Int) =<< B.hGetContents h
75 where
76  loop !n bs
77      | B.null bs = print n
78      | otherwise = case parse myReq arg bs of
79                      Left err      -> putStrLn $ arg ++ ": " ++ show err
80                      Right (r,bs') -> loop (n+1) bs'
81  myReq :: Parser ((Request, [Header]), B.ByteString)
82  myReq = liftA2 (,) request getInput
83
84main :: IO ()
85main = mapM_ f =<< getArgs
86  where
87    --f = listy
88    f = chunky
89