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