module Network.Parser.Rfc2616 where
import Control.Applicative hiding (many)
import Control.Monad (liftM)
import Data.Attoparsec
import Data.Attoparsec.Char8 (decimal, stringCI, take)
import Data.ByteString as W hiding (concat, take)
import Data.ByteString.Char8 as C hiding (concat, take)
import Data.ByteString.Internal (c2w)
import Data.Word (Word8 ())
import Prelude hiding (take, takeWhile)
import Network.Parser.Rfc2234
import Network.Parser.Rfc3986 as R3986
import Network.Parser.RfcCommon
import Network.Types
separatorsPred, tokenPred :: Word8 -> Bool
tokenPred w = charPred w && not (ctlPred w || separatorsPred w)
token :: Parser [Word8]
token = many1 $ satisfy tokenPred
separatorsPred = inClass "()<>@,;:\\\"/[]?={} \t"
separators :: Parser Word8
separators = satisfy separatorsPred
comment :: Parser [Word8]
comment
= word8 40
*> (concat <$> many' (quotedPair <|> ((:[]) <$> ctext)))
<* word8 41
httpVersion :: Parser HttpVersion
httpVersion = stringCI "http/" *>
(HttpVersion <$> (num <* sep) <*> num)
where num = liftM (read . C.unpack . W.pack) $ many1 digit
sep = word8 . c2w $ '.'
method :: Parser Method
method = (GET <$ stringCI "get")
<|> (PUT <$ stringCI "put")
<|> (POST <$ stringCI "post")
<|> (HEAD <$ stringCI "head")
<|> (DELETE <$ stringCI "delete")
<|> (TRACE <$ stringCI "trace")
<|> (CONNECT <$ stringCI "connect")
<|> (OPTIONS <$ stringCI "options")
<|> ((EXTENSIONMETHOD . W.pack) <$> token)
requestUri :: Parser RequestUri
requestUri = try (Asterisk <$ word8 42)
<|> RelativeRef <$> R3986.relativeRef
<|> AbsoluteUri <$> R3986.absoluteUri
<|> (AbsolutePath . W.pack) <$> R3986.pathAbsolute
<|> Authority <$> R3986.authority
requestLine :: Parser (Method, RequestUri, HttpVersion)
requestLine = ret <$> method <* sp
<*> requestUri <* sp
<*> httpVersion <* crlf
where ret m u h = (m,u,h)
headerContentNcPred :: Word8 -> Bool
headerContentNcPred w
= (w >= 0x00 && w <= 0x08)
|| (w >= 0x0b && w <= 0x0c)
|| (w >= 0x0e && w <= 0x1f)
|| (w >= 0x21 && w <= 0x39)
|| (w >= 0x3b && w <= 0xff)
headerContent :: Parser Word8
headerContent = satisfy (\w -> headerContentNcPred w || w == 58)
headerName :: Parser [Word8]
headerName = many1 $ satisfy headerContentNcPred
headerValue :: Parser [Word8]
headerValue = do
c <- headerContent
r <- option [] (many' (headerContent <|> lws))
return (c:r)
header :: Parser (ByteString,ByteString)
header = ret <$> headerName <* (word8 58 <* lwss)
<*> headerValue <* lwss
where ret n v = (W.pack n, W.pack v)
entityBody :: Parser [Word8]
entityBody = many' octet
messageBody :: Parser [Word8]
messageBody = entityBody
request :: Parser Request
request = do
(m, ru, v) <- requestLine
hdrs <- many' (header <* crlf)
_ <- crlf
return Request
{ rqMethod = m
, rqUri = ru
, rqVersion = v
, rqHeaders = hdrs
, rqBody = W.empty
}
reasonPhraseText :: Parser Word8
reasonPhraseText = satisfy char_not_ctl
where char_not_ctl w = charPred w && not (ctlPred w)
reasonPhrase :: Parser [Word8]
reasonPhrase = many1 reasonPhraseText
statusLine :: Parser (HttpVersion, Int, [Word8])
statusLine = (,,) <$> httpVersion <* sp
<*> decimal <* sp
<*> reasonPhrase <* crlf
response :: Parser Response
response = do
(ver, code, reason) <- statusLine
hdrs <- many' (header <* crlf)
_ <- crlf
return Response
{ rpCode = code
, rpHeaders = hdrs
, rpVersion = ver
, rpMessage = W.empty
}