UserAgent.hs

{-# LANGUAGE OverloadedStrings #-}
{- |
  This module parses a user-agent header according to the specification in
  RFC-2616.
-}
module Network.Legion.Discovery.UserAgent (
  parseUserAgent,
  UserAgent(..),
  Product(..),
) 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, parseOnly)
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. 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 {
       productName :: ByteString,
    productVersion :: Maybe ByteString
  }


{- |
  Parse a user-agent header according to the specification in RFC-2616, or else
  return a reason why parsing failed.
-}
parseUserAgent :: ByteString -> Either String [UserAgent]
parseUserAgent = parseOnly userAgent


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


{- |
  product - http product token.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.8
-}
product :: Parser Product
product =
    Product
      <$> token
      <*> option Nothing versionParser 
  where
    versionParser = do
      void $ string "/"
      Just <$> 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 = do
  void $ word8 40 -- "("
  segments <- many (
      takeWhile1 ctext
      <|> (BS.singleton <$> quotedPair)
      <|> 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 x = text x && x /= 40 && x /= 41 -- "(", ")"


{- |
  quotedPair - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
quotedPair :: Parser Word8
quotedPair = do
  void $ word8 92 -- <\>
  satisfy char


{- |
  text - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
text :: Word8 -> Bool
text = not . ctl


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


{-
  CTL - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
ctl :: Word8 -> Bool
ctl x = (x >= 0 && x <= 31) || x == 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 = do
  option () lws
  t <- takeWhile1 (\x -> char x && not (separators x) && not (ctl x))
  option () lws
  return t

 
{- |
  separators - basic http grammar rule.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
separators :: Word8 -> Bool
separators = inClass "()<>@,;:\\\"/[]?={} \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 = do
  option () crlf
  void $ takeWhile1 (\x -> x == 32 || x == 9)


{- |
  crlf - basic http grammar rule.

  Consumes one crlf.
  https://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2
-}
crlf :: Parser ()
crlf = void $ string "\r\n"