@@ -1,40 +1,58 @@
11{-# LANGUAGE OverloadedStrings #-}
2−module RFC2616 where
3−
4−import Data.Attoparsec.Incremental.Char8
5−import Data.ByteString.Lazy.Char8 (ByteString)
6−import qualified Data.ByteString.Lazy.Char8 as L
7−import Data.ByteString.Char8 ()
8−import Control.Applicative
9−import Data.Char
10−import Control.Monad
11−import Prelude hiding (takeWhile)
12−import Data.Time.Clock
13−import Data.Time.Format
14−import System.Locale
15−
16−date = rfc1123Date -- <|> rfc850Date <|> asctimeDate
17−
18−fallible :: Parser r (Maybe a) -> Parser r a
19−fallible p = maybe mzero return =<< p
20−
21−rfc1123Date :: Parser r UTCTime
22−rfc1123Date =
23− fallible (q <$> (manyTill anyChar (string " GMT")))
24− <?> "RFC1123 date"
25− where q = parseTime defaultTimeLocale "%a, %d %b %Y %T"
26−
27−time = liftA3 (,,) (d <* c) (d <* c) d <?> "time"
28− where d = replicateM 2 (satisfy isDigit)
29− c = char ':'
30−
31−eol = (char '\n' *> pure Nothing) <|> (string "\r\n" *> pure Nothing)
32−
33−header =
34− (,) <$> (takeWhile fieldChar <* char ':' <* skipWhile space)
35− <*> ((:) <$> tillEOL <*> many cont)
36− where tillEOL = takeTill newline <* eol
37− newline c = c == '\r' || c == '\n'
38− fieldChar c = c /= ':' && c >= '!' && c <= '~'
39− cont = some (satisfy space) *> tillEOL
40− space c = c == ' ' || c == '\t'
2+
3+module RFC2616
4+ (
5+ Request(..)
6+ , Header(..)
7+ , isToken
8+ , requestLine
9+ , messageHeader
10+ , request
11+ ) where
12+
13+import Control.Applicative hiding (many)
14+import Data.Attoparsec as P
15+import Data.Attoparsec.Char8 (char8, endOfLine)
16+import Data.Word (Word8)
17+import qualified Data.ByteString.Char8 as B
18+
19+isToken :: Word8 -> Bool
20+isToken w = w <= 127 && notInClass "\0-\31()<>@,;:\\\"/[]?={} \t" w
21+
22+skipSpaces :: Parser ()
23+skipSpaces = satisfy spc *> skipWhile spc
24+ where spc = inClass " \t"
25+
26+data Request = Request {
27+ requestMethod :: !B.ByteString
28+ , requestUri :: !B.ByteString
29+ , requestProtocol :: !B.ByteString
30+ } deriving (Eq, Ord, Show)
31+
32+requestLine :: Parser Request
33+requestLine = do
34+ method <- P.takeWhile isToken
35+ skipSpaces
36+ uri <- P.takeWhile (notInClass " \t")
37+ skipSpaces >> string "HTTP/"
38+ proto <- P.takeWhile (inClass "0-9.")
39+ endOfLine
40+ return $! Request method uri proto
41+
42+data Header = Header {
43+ headerName :: !B.ByteString
44+ , headerValue :: [B.ByteString]
45+ } deriving (Eq, Ord, Show)
46+
47+messageHeader :: Parser Header
48+messageHeader = do
49+ header <- P.takeWhile isToken
50+ char8 ':' *> skipSpaces
51+ body <- takeTill (inClass "\r\n")
52+ endOfLine
53+ bodies <- many $ satisfy (inClass " \t") *> skipSpaces *>
54+ takeTill (inClass "\r\n") <* endOfLine
55+ return $! Header header (body:bodies)
56+
57+request :: Parser (Request, [Header])
58+request = (,) <$> requestLine <*> many messageHeader <* endOfLine