content: {-# 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
  