Source

attoparsec / examples / Parsec_RFC2616.hs

{-# LANGUAGE BangPatterns, CPP, FlexibleContexts #-}

module Main (main) where

import Control.Applicative
import Control.Exception (bracket)
import System.Environment (getArgs)
import System.IO (hClose, openFile, IOMode(ReadMode))
import Text.Parsec.Char (anyChar, char, satisfy, string)
import Text.Parsec.Combinator (many1, manyTill, skipMany1)
import Text.Parsec.Prim hiding (many, token, (<|>))
import qualified Data.IntSet as S

#if 1
import Text.Parsec.ByteString.Lazy (Parser, parseFromFile)
import qualified Data.ByteString.Lazy as B
#else
import Text.Parsec.ByteString (Parser, parseFromFile)
import qualified Data.ByteString as B
#endif

token :: Stream s m Char => ParsecT s u m Char
token = satisfy $ \c -> S.notMember (fromEnum c) set
  where set = S.fromList . map fromEnum $ ['\0'..'\31'] ++ "()<>@,;:\\\"/[]?={} \t" ++ ['\128'..'\255']

isHorizontalSpace c = c == ' ' || c == '\t'

skipHSpaces :: Stream s m Char => ParsecT s u m ()
skipHSpaces = skipMany1 (satisfy isHorizontalSpace)

data Request = Request {
      requestMethod   :: String
    , requestUri      :: String
    , requestProtocol :: String
    } deriving (Eq, Ord, Show)

requestLine :: Stream s m Char => ParsecT s u m Request
requestLine = do
  method <- many1 token <* skipHSpaces
  uri <- many1 (satisfy (not . isHorizontalSpace)) <* skipHSpaces <* string "HTTP/"
  proto <- many httpVersion <* endOfLine
  return $! Request method uri proto
 where
  httpVersion = satisfy $ \c -> c == '1' || c == '0' || c == '.'

endOfLine :: Stream s m Char => ParsecT s u m ()
endOfLine = (string "\r\n" *> pure ()) <|> (char '\n' *> pure ())

data Header = Header {
      headerName  :: String
    , headerValue :: [String]
    } deriving (Eq, Ord, Show)

messageHeader :: Stream s m Char => ParsecT s u m Header
messageHeader = do
  header <- many1 token <* char ':' <* skipHSpaces
  body <- manyTill anyChar endOfLine
  conts <- many $ skipHSpaces *> manyTill anyChar endOfLine
  return $! Header header (body:conts)

request :: Stream s m Char => ParsecT s u m (Request, [Header])
request = (,) <$> requestLine <*> many messageHeader <* endOfLine

listy arg = do
  r <- parseFromFile (many request) arg
  case r of
    Left err -> putStrLn $ arg ++ ": " ++ show err
    Right rs -> print (length rs)

chunky arg = bracket (openFile arg ReadMode) hClose $ \h ->
               loop 0 =<< B.hGetContents h
 where
  loop !n bs
      | B.null bs = print n
      | otherwise = case parse myReq arg bs of
                      Left err      -> putStrLn $ arg ++ ": " ++ show err
                      Right (r,bs') -> loop (n+1) bs'
  myReq :: Parser ((Request, [Header]), B.ByteString)
  myReq = liftA2 (,) request getInput

main :: IO ()
main = mapM_ f =<< getArgs
  where
    --f = listy
    f = chunky
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.