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