git.iko.soy/typeable/attoparsec
on master help sign in
typeable/attoparsec/examples/Parsec_RFC2616.hs
88 lines 2.9 kB history raw
1{-# LANGUAGE BangPatterns, CPP, FlexibleContexts #-}
3module Main (main) where
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
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
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']
26isHorizontalSpace :: Char -> Bool
27isHorizontalSpace c = c == ' ' || c == '\t'
29skipHSpaces :: Stream s m Char => ParsecT s u m ()
30skipHSpaces = skipMany1 (satisfy isHorizontalSpace)
32data Request = Request {
33 _requestMethod :: String
34 , _requestUri :: String
35 , _requestProtocol :: String
36 } deriving (Eq, Ord, Show)
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 == '.'
47endOfLine :: Stream s m Char => ParsecT s u m ()
48endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ())
50data Header = Header {
51 _headerName :: String
52 , _headerValue :: [String]
53 } deriving (Eq, Ord, Show)
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)
62request :: Stream s m Char => ParsecT s u m (Request, [Header])
63request = (,) <$> requestLine <*> many messageHeader <* endOfLine
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)
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
84main :: IO ()
85main = mapM_ f =<< getArgs
86 where
87 --f = listy
88 f = chunky