{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wwarn=missing-import-lists #-}

{- |
  This module provides Attoparsec-based parsers for the HTTP grammar
  rules as defined by RFC-2616.
-}
module Network.HTTP.Grammar (
  -- * Parsable data types.
  UserAgent(..),
  Product(..),

  -- * Productions
  userAgent,
  product,
  comment,
  ctext,
  quotedPair,
  text,
  char,
  ctl,
  token,
  separators,
  lws,
  crlf,
) where

import Prelude hiding (product)

import Control.Applicative (many, (<|>))
import Control.Monad (void)
import Data.Attoparsec.ByteString (Parser, word8, takeWhile1, satisfy,
  inClass, option, string, many1)
import Data.ByteString (ByteString)
import Data.Word (Word8)
import qualified Data.ByteString as BS


{- |
  The User-Agent header field is defined as a list of tokens, each
  of which is either a product or a comment. Values of this data type
  represents one such token.
-}
data UserAgent
  = UAProduct Product
  | UAComment ByteString


{- |
  A representation of an HTTP User-Agent product.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.8
-}
data Product = Product {
       Product -> ByteString
productName :: ByteString,
    Product -> Maybe ByteString
productVersion :: Maybe ByteString
  }


{- |
  Parser for the User-Agent header, defined:
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.43
-}
userAgent :: Parser [UserAgent]
userAgent :: Parser [UserAgent]
userAgent = Parser ByteString UserAgent -> Parser [UserAgent]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (
    (Product -> UserAgent
UAProduct (Product -> UserAgent)
-> Parser ByteString Product -> Parser ByteString UserAgent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Product
product)
    Parser ByteString UserAgent
-> Parser ByteString UserAgent -> Parser ByteString UserAgent
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (ByteString -> UserAgent
UAComment (ByteString -> UserAgent)
-> Parser ByteString ByteString -> Parser ByteString UserAgent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
comment)
  )


{- |
  product - http product token.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.8
-}
product :: Parser Product
product :: Parser ByteString Product
product =
    ByteString -> Maybe ByteString -> Product
Product
      (ByteString -> Maybe ByteString -> Product)
-> Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString -> Product)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
token
      Parser ByteString (Maybe ByteString -> Product)
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString Product
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ByteString
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe ByteString
forall a. Maybe a
Nothing Parser ByteString (Maybe ByteString)
versionParser 
  where
    versionParser :: Parser ByteString (Maybe ByteString)
versionParser = do
      Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString ByteString -> Parser ByteString ())
-> Parser ByteString ByteString -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString ByteString
string ByteString
"/"
      ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
token


{- |
  comment - basic http grammar rule.
  The result is the parsed comment content, rather than the raw source.

  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
comment :: Parser ByteString
comment :: Parser ByteString ByteString
comment = do
  Parser ByteString Word8 -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString Word8 -> Parser ByteString ())
-> Parser ByteString Word8 -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ Word8 -> Parser ByteString Word8
word8 Word8
40 -- "("
  segments <- Parser ByteString ByteString -> Parser ByteString [ByteString]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (
      (Word8 -> Bool) -> Parser ByteString ByteString
takeWhile1 Word8 -> Bool
ctext
      Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Word8 -> ByteString
BS.singleton (Word8 -> ByteString)
-> Parser ByteString Word8 -> Parser ByteString ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
quotedPair)
      Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
comment
    )
  void $ word8 41 -- ")"
  return (mconcat segments)


{- |
  ctext - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
ctext :: Word8 -> Bool
ctext :: Word8 -> Bool
ctext Word8
x = Word8 -> Bool
text Word8
x Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
40 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
41 -- "(", ")"


{- |
  quotedPair - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
quotedPair :: Parser Word8
quotedPair :: Parser ByteString Word8
quotedPair = do
  Parser ByteString Word8 -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString Word8 -> Parser ByteString ())
-> Parser ByteString Word8 -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ Word8 -> Parser ByteString Word8
word8 Word8
92 -- <\>
  (Word8 -> Bool) -> Parser ByteString Word8
satisfy Word8 -> Bool
char


{- |
  TEXT - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
text :: Word8 -> Bool
text :: Word8 -> Bool
text = Bool -> Bool
not (Bool -> Bool) -> (Word8 -> Bool) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Bool
ctl


{- |
  CHAR - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
char :: Word8 -> Bool
char :: Word8 -> Bool
char Word8
x = Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
127


{- |
  CTL - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
ctl :: Word8 -> Bool
ctl :: Word8 -> Bool
ctl Word8
x = (Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
31) Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
127


{- |
  token - basic http grammar rule.

  The grammar specifies that adjacent LWS should be consumed without affecting
  the meaning of the token. This parser returns the token stripped of any
  adjacent lws.

  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
token :: Parser ByteString
token :: Parser ByteString ByteString
token = do
  () -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () Parser ByteString ()
lws
  t <- (Word8 -> Bool) -> Parser ByteString ByteString
takeWhile1 (\Word8
x -> Word8 -> Bool
char Word8
x Bool -> Bool -> Bool
&& Bool -> Bool
not (Word8 -> Bool
separators Word8
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (Word8 -> Bool
ctl Word8
x))
  option () lws
  return t

 
{- |
  separators - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
separators :: Word8 -> Bool
separators :: Word8 -> Bool
separators = String -> Word8 -> Bool
inClass String
"()<>@,;:\\\"/[]?={} \t"


{- |
  LWS - basic http grammar rule. (L)inear (W)hite(S)pace.

  Consumes all linear whitespace.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
lws :: Parser ()
lws :: Parser ByteString ()
lws = do
  () -> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () Parser ByteString ()
crlf
  Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString ByteString -> Parser ByteString ())
-> Parser ByteString ByteString -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> Parser ByteString ByteString
takeWhile1 (\Word8
x -> Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
32 Bool -> Bool -> Bool
|| Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
9)


{- |
  crlf - basic http grammar rule.

  Consumes one crlf.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
crlf :: Parser ()
crlf :: Parser ByteString ()
crlf = Parser ByteString ByteString -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString ByteString -> Parser ByteString ())
-> Parser ByteString ByteString -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Parser ByteString ByteString
string ByteString
"\r\n"