1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
|
{-# language BangPatterns #-}
module RFC2616 where
import Control.Applicative
import System.Environment (getArgs)
import Text.Trifecta hiding (token)
import Text.Parser.Token.Highlight
infixl 4 <$!>
(<$!>) :: Monad m => (a -> b) -> m a -> m b
f <$!> ma = do
a <- ma
return $! f a
token :: CharParsing m => m Char
token = noneOf $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255']
isHSpace :: Char -> Bool
isHSpace c = c == ' ' || c == '\t'
skipHSpaces :: CharParsing m => m ()
skipHSpaces = skipSome (satisfy isHSpace)
data Request = Request {
requestMethod :: String
, requestUri :: String
, requestProtocol :: String
} deriving (Eq, Ord, Show)
requestLine :: (Monad m, TokenParsing m) => m Request
requestLine = Request <$!> (highlight ReservedIdentifier (some token) <?> "request method")
<* skipHSpaces
<*> (highlight Identifier (some (satisfy (not . isHSpace))) <?> "url")
<* skipHSpaces
<*> (try (highlight ReservedIdentifier (string "HTTP/" *> many httpVersion <* endOfLine)) <?> "protocol")
where
httpVersion :: (Monad m, CharParsing m) => m Char
httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.' || c == '9'
endOfLine :: CharParsing m => m ()
endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ())
data Header = Header {
headerName :: String
, headerValue :: [String]
} deriving (Eq, Ord, Show)
messageHeader :: (Monad m, TokenParsing m) => m Header
messageHeader = (\h b c -> Header h (b : c))
<$!> (highlight ReservedIdentifier (some token) <?> "header name")
<* highlight Operator (char ':') <* skipHSpaces
<*> (highlight Identifier (manyTill anyChar endOfLine) <?> "header value")
<*> (many (skipHSpaces *> manyTill anyChar endOfLine) <?> "blank line")
request :: (Monad m, TokenParsing m) => m (Request, [Header])
request = (,) <$> requestLine <*> many messageHeader <* endOfLine
requests :: (Monad m, TokenParsing m) => m [(Request, [Header])]
requests = many request
lumpy :: String -> IO ()
lumpy arg = do
r <- parseFromFile requests arg
case r of
Nothing -> return ()
Just rs -> print (length rs)
main :: IO ()
main = mapM_ lumpy =<< getArgs
|