{-# OPTIONS_GHC -fno-monomorphism-restriction
                -fno-warn-missing-signatures #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module serialises and deserialises HTTP headers. It contains Haskell
--   representations of request and replies and can transform them to, and from,
--   the HTTP wire format.
module Network.MiniHTTP.Marshal
  ( Request(..)
  , Reply(..)
  , Range(..)
  , Headers(..)
  , Cookie(..)
  , emptyHeaders
  , emptyCookie
  , statusToMessage
  , Method(..)
  , MediaType
  , putRequest
  , putReply
  , parseRequest
  , parseReply
  , parseChunkHeader
  ) where

import           Prelude hiding (putChar)

import           Control.Applicative ((<|>), liftA, liftA2, (*>))
import           Control.Monad (when, forM_)

import qualified Data.ByteString as B
import           Data.ByteString.Char8 ()
import           Data.ByteString.Internal (c2w, w2c)
import qualified Data.Binary.Put as P
import qualified Data.Binary.Strict.ByteSet as BSet
import qualified Data.Binary.Strict.Class as C
import qualified Data.Binary.Strict.Get as G
import           Data.Int (Int64)
import           Data.List (intersperse, foldl')
import qualified Data.Map as Map
import           Data.Maybe (isJust, maybe)
import           Data.String (fromString)
import           Data.Time (UTCTime(..))
import           Data.Time.Calendar (fromGregorian)
import           Data.Time.Format (formatTime)
import           Data.Time.LocalTime (TimeOfDay(..), timeOfDayToTime)

import           GHC.Exts()

import           System.Locale (TimeLocale(..))

import qualified Network.MiniHTTP.URL as URL

-- | A HTTP request
data Request =
  Request { reqMethod :: Method
          , reqUrl :: URL.RelativeURL
          , reqMajor :: Int
          , reqMinor :: Int
          , reqHeaders :: Headers
          } deriving (Show)

-- | A HTTP reply
data Reply =
  Reply { replyMajor :: Int
        , replyMinor :: Int
        , replyStatus :: Int
        , replyMessage :: String
        , replyHeaders :: Headers
        } deriving (Show)

-- | A HTTP range
data Range = RangeFrom Int64  -- ^ everything from the given byte onwards
           | RangeOf Int64 Int64  -- ^ the bytes in the given range, inclusive
           | RangeSuffix Int64  -- ^ the final n bytes
           deriving (Show)

-- | HTTP headers, see RFC 2616 section 14
data Headers =
  Headers { httpAccept :: Maybe [(MediaType, Int)]
          , httpAcceptCharset :: Maybe [(String, Int)]
          , httpAcceptEncoding :: Maybe [(String, Int)]
          , httpAcceptLanguage :: Maybe [(String, Int)]
          , httpAcceptRanges :: Bool
          , httpAge :: Maybe Int64
          , httpAllow :: Maybe [Method]
          , httpAuthorization :: Maybe B.ByteString
          , httpCookie :: [Cookie]
          , httpConnectionClose :: Bool
          , httpConnection :: [String]
          , httpContentEncodings :: [String]
          , httpContentLanguage :: Maybe [String]
          , httpContentLength :: Maybe Int64
          , httpContentLocation :: Maybe B.ByteString
          , httpContentRange :: Maybe (Maybe (Int64, Int64), Maybe Int64)
          , httpContentType :: Maybe MediaType
          , httpDate :: Maybe UTCTime
          , httpETag :: Maybe (Bool, B.ByteString)
          , httpExpires :: Maybe UTCTime
          , httpHost :: Maybe B.ByteString
          , httpIfMatch :: Maybe (Either () [B.ByteString])
          , httpIfModifiedSince :: Maybe UTCTime
          , httpIfNoneMatch :: Maybe (Either () [(Bool, B.ByteString)])
          , httpIfRange :: Maybe (Either B.ByteString UTCTime)
          , httpIfUnmodifiedSince :: Maybe UTCTime
          , httpKeepAlive :: Maybe Int
          , httpLastModified :: Maybe UTCTime
          , httpLocation :: Maybe B.ByteString
          , httpPragma :: Maybe [(String, Maybe String)]
          , httpProxyAuthenticate :: Maybe B.ByteString
          , httpProxyAuthorization :: Maybe B.ByteString
          , httpRange :: Maybe [Range]
          , httpReferer :: Maybe B.ByteString
          , httpRetryAfter :: Maybe Int64
          , httpServer :: Maybe B.ByteString
          , httpSetCookie :: [Cookie]
          , httpTrailer :: Maybe [String]
          , httpTransferEncoding :: [String]
          , httpUserAgent :: Maybe B.ByteString
          , httpWWWAuthenticate :: Maybe B.ByteString
          , httpOtherHeaders :: Map.Map B.ByteString B.ByteString
          } deriving (Show)

-- | A HTTP Cookie. See <http://en.wikipedia.org/wiki/HTTP_cookie>
data Cookie = Cookie { cookieName :: B.ByteString
                     , cookieValue :: B.ByteString
                     , cookiePath :: Maybe String
                     , cookieDomain :: Maybe String
                     , cookieExpires :: Maybe UTCTime
                     , cookieSecure :: Bool
                     } deriving (Show, Eq, Ord)

emptyHeaders :: Headers
emptyHeaders =
  Headers Nothing Nothing Nothing Nothing
  False Nothing Nothing Nothing [] False [] [] Nothing Nothing
  Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
  Nothing Nothing Nothing Nothing Nothing Nothing Nothing
  Nothing Nothing Nothing Nothing Nothing Nothing Nothing []
  Nothing [] Nothing Nothing Map.empty

-- | The list of valid methods, see RFC 2616 section 5.1
data Method = OPTIONS
            | GET
            | HEAD
            | POST
            | PUT
            | DELETE
            | TRACE
            | CONNECT
            deriving (Ord, Enum, Show, Eq)

type MediaType = ((String, String), [(String, String)])

-- | A mapping from status code to message. Taken from Johan Tibell's Hydra
--   package
reasonPhrases :: Map.Map Int String
reasonPhrases = Map.fromList
                [(100, "Continue")
                ,(101, "Switching Protocols")
                ,(200, "OK")
                ,(201, "Created")
                ,(202, "Accepted")
                ,(203, "Non-Authoritative Information")
                ,(204, "No Content")
                ,(205, "Reset Content")
                ,(206, "Partial Content")
                ,(300, "Multiple Choices")
                ,(301, "Moved Permanently")
                ,(302, "Found")
                ,(303, "See Other")
                ,(304, "Not Modified")
                ,(305, "Use Proxy")
                ,(307, "Temporary Redirect")
                ,(400, "Bad Request")
                ,(401, "Unauthorized")
                ,(402, "Payment Required")
                ,(403, "Forbidden")
                ,(404, "Not Found")
                ,(405, "Method Not Allowed")
                ,(406, "Not Acceptable")
                ,(407, "Proxy Authentication Required")
                ,(408, "Request Time-out")
                ,(409, "Conflict")
                ,(410, "Gone")
                ,(411, "Length Required")
                ,(412, "Precondition Failed")
                ,(413, "Request Entity Too Large")
                ,(414, "Request-URI Too Large")
                ,(415, "Unsupported Media Type")
                ,(416, "Requested range not satisfiable")
                ,(417, "Expectation Failed")
                ,(500, "Internal Server Error")
                ,(501, "Not Implemented")
                ,(502, "Bad Gateway")
                ,(503, "Service Unavailable")
                ,(504, "Gateway Time-out")
                ,(505, "HTTP Version not supported")
                ]

-- | Convert a status code to a message (e.g. 200 -> "OK")
statusToMessage :: Int -> String
statusToMessage status = Map.findWithDefault "Unknown" status reasonPhrases

--------------------------------------------------------------------------------
-- These are the byte sets that we'll use for parsing.

char = C.word8 . c2w
urlSet = BSet.full `BSet.difference` (BSet.singleton 0x20)
upAlphas = BSet.range (c2w 'A') (c2w 'Z')
loAlphas = BSet.range (c2w 'a') (c2w 'z')
alphas = upAlphas `BSet.union` loAlphas
digits = BSet.range (c2w '0') (c2w '9')
chars = BSet.range 0 127
ctls = BSet.range 0 31 `BSet.union` BSet.singleton 127
hs = BSet.fromList [32, 9]
texts = (chars `BSet.difference` ctls) `BSet.union` hs
hexes = BSet.range (c2w 'a') (c2w 'f') `BSet.union`
        BSet.range (c2w 'A') (c2w 'F') `BSet.union`
        digits
separators = BSet.fromList $ map c2w "()<>@,;:\\\"/[]?={} \t"
--ctexts = texts `BSet.difference` (BSet.fromList $ map c2w "()\\")
qdtexts = texts `BSet.difference` (BSet.fromList $ map c2w "\"\\")

--------------------------------------------------------------------------------
-- Parsing functions

toString = map w2c . B.unpack

lws = do
  C.optional crlf
  C.spanOf1 $ BSet.member hs

token = C.spanOf1 $ BSet.member (texts `BSet.difference` (ctls `BSet.union` separators))
qvalue = qOne <|> qFractional
qOne = do
  char '1'
  (((char '.') >> C.many (char '0') >> return ()) <|> return ())
  return 1000

qFractional = do
  char '0'
  r <- (((char '.') >> C.spanOf (BSet.member digits)) <|> return "")
  if B.null r
     then return 0
     else return $ read $ toString r ++ replicate (3 - B.length r) '0'

{-comment = do
  char '('
  comment <- C.many ((C.spanOf $ BSet.member ctexts) <|> quotedPair <|> comment) >>= return . B.concat
  char ')'
  return comment
-}

quotedPair = (char '\\') >> (C.getWord8 >>= return . B.singleton)

quotedString = do
  char '"'
  text <- C.many ((C.spanOf1 $ BSet.member qdtexts) <|> quotedPair) >>= return . B.concat
  char '"'
  return text

-- | RFC 2616 2.1, #rule
list p = do
  let f = C.optional lws *> char ',' *> C.optional lws *> p
  v <- p
  rest <- C.many f
  return $ v : rest

crlf = C.word8 13 >> C.word8 10 >> return ()

headerQualityTaggedList parseElement = do
  let acceptParams = do
        char ';'
        C.optional lws
        C.string "q="
        q <- qvalue
        C.many $ acceptExtension
        return q
      acceptExtension = do
        char ';'
        token
        C.optional (char '=' >> (token <|> quotedString))
      listElement = do
        mr <- parseElement
        params <- C.optional acceptParams
        case params of
             Nothing -> return (mr, 1000)
             Just x -> return (mr, x)
  list listElement

stringToken = liftA toString token

mediaType = liftA2 (,) ty params where
  ty = liftA2 (,) stringToken (char '/' *> stringToken)
  params = C.many (char ';' *> (liftA2 (,) notq (char '=' *> (stringToken <|> (liftA toString quotedString)))))
  notq = do
    s <- stringToken
    if s == "q"
       then fail ""
       else return s

-- | Parse an RFC1123 date
date :: (C.BinaryParser m) => m UTCTime
date = do
  C.optional (token *> char ',' *> C.optional lws)
  day <- int64
  lws
  monthstr <- token
  lws
  year <- int64
  lws
  hour <- int64
  char ':'
  min <- int64
  char ':'
  sec <- int64
  lws
  zone <- token

  month <-
    case monthstr of
         "Jan" -> return 1
         "Feb" -> return 2
         "Mar" -> return 3
         "Apr" -> return 4
         "May" -> return 5
         "Jun" -> return 6
         "Jul" -> return 7
         "Aug" -> return 8
         "Sep" -> return 9
         "Oct" -> return 10
         "Nov" -> return 11
         "Dec" -> return 12
         _ -> fail ""


  (hoffset, moffset) <-
    case zone of
         "UT" -> return (0, 0)
         "UTC" -> return (0, 0)
         "GMT" -> return (0, 0)
         "EST" -> return (-5, 0)
         "EDT" -> return (-4, 0)
         "CST" -> return (-6, 0)
         "CDT" -> return (-5, 0)
         "MST" -> return (-7, 0)
         "MDT" -> return (-6, 0)
         "PST" -> return (-8, 0)
         "PDT" -> return (-7, 0)
         x -> return (sign * hours, sign * mins) where
                (signchar:rest) = toString x
                n = read rest
                (hours, mins) = (n `div` 100, n `mod` 100)
                sign = case signchar of
                            '+' -> (-1)
                            _ -> 1

  let yday = fromGregorian (fromIntegral year) month (fromIntegral day)
      time = timeOfDayToTime $ TimeOfDay (fromIntegral $ hour + hoffset) (fromIntegral $ min + moffset) (fromIntegral sec)
      utc = UTCTime yday time

  return utc

-- | Parse a zero, or positive, int64
int64 :: (C.BinaryParser c) => c Int64
int64 = C.spanOf1 (BSet.member digits) >>= return . readOrZero . toString

hexInt64 :: (C.BinaryParser c) => c Int64
hexInt64 = C.spanOf1 (BSet.member hexes) >>= return . readOrZero . ((++) "0x") . toString

readOrZero "" = 0
readOrZero x = read x

--------------------------------------------------------------------------------
-- Parsing functions for each header type

headerAccept req = do
  accepts <- headerQualityTaggedList mediaType
  return $ req { httpAccept = Just accepts }

headerAcceptCharset req = do
  charsets <- headerQualityTaggedList (token >>= return . toString)
  return $ req { httpAcceptCharset = Just charsets }

headerAcceptEncoding req = do
  encodings <- headerQualityTaggedList (token >>= return . toString)
  return $ req { httpAcceptEncoding = Just encodings }

headerAcceptLanguage req = do
  langs <- headerQualityTaggedList (token >>= return . toString)
  return $ req { httpAcceptLanguage = Just langs }

headerAcceptRanges req = do
  v <- C.optional $ C.string "bytes"
  case v of
       Nothing -> return req
       Just _ -> return $ req { httpAcceptRanges = True }

headerAge req = do
  v <- int64
  return $ req { httpAge = Just v }

headerAllow req = do
  methods <- list (C.spanOf (BSet.member upAlphas) >>= parseMethod)
  return $ req { httpAllow = Just methods }

headerAuth req = do
  remaining <- C.remaining
  d <- C.getByteString remaining
  return $ req { httpAuthorization = Just d }

headerConnection req = do
  tokens <- list (token >>= return . toString)
  return $ req { httpConnection = tokens,
                 httpConnectionClose = "close" `elem` tokens }

headerContentEncoding req = do
  tokens <- list (token >>= return . toString)
  return $ req { httpContentEncodings = tokens }

headerContentLanguage req = do
  tokens <- list (token >>= return . toString)
  return $ req { httpContentLanguage = Just tokens }

headerContentLength req = do
  v <- int64
  return $ req { httpContentLength = Just v }

headerContentLocation req = do
  remaining <- C.remaining
  d <- C.getByteString remaining
  return $ req { httpContentLocation = Just d }

headerContentRange req = do
  C.string "bytes "
  a <- (char '*' *> return Nothing) <|> (liftA Just (liftA2 (,) int64 (char '-' *> int64)))
  char '/'
  b <- (char '*' *> return Nothing) <|> (liftA Just int64)
  return $ req { httpContentRange = Just (a, b) }

headerContentType req = do
  ct <- mediaType
  return $ req { httpContentType = Just ct }

etag = do
  weakness <- C.optional $ C.string "W/"
  etag <- quotedString
  return (isJust weakness, etag)

headerETag req = do
  etag >>= \tag -> return $ req { httpETag = Just tag }

headerDate req = date >>= \date -> return $ req { httpDate = Just date }
headerExpires req = date >>= \date -> return $ req { httpExpires = Just date }
headerHost req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpHost = Just x }

headerIfMatch req =
  (char '*' *> return (Left ())) <|> (liftA Right $ list quotedString) >>=
  \a -> return $ req { httpIfMatch = Just a }

headerIfModifiedSince req = date >>= \date -> return $ req { httpIfModifiedSince = Just date }

headerIfNoneMatch req =
  (char '*' *> return (Left ())) <|> (liftA Right $ list etag) >>=
  \a -> return $ req { httpIfNoneMatch = Just a }

headerIfRange req = (liftA Left quotedString) <|> (liftA Right date) >>=
  \a -> return $ req { httpIfRange = Just a }

headerIfUnmodifiedSince req = date >>= \date -> return $ req { httpIfUnmodifiedSince = Just date }
headerKeepAlive req = int64 >>= \v -> return $ req { httpKeepAlive = Just $ fromIntegral v }
headerLastModified req = date >>= \date -> return $ req { httpLastModified = Just date }
headerLocation req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpLocation = Just x }

headerPragma req =
  list (liftA2 (,) stringToken (C.optional $ char '=' *> (liftA toString (token <|> quotedString)))) >>=
  \a -> return $ req { httpPragma = Just a }

headerProxyAuthenticate req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpProxyAuthenticate = Just x }
headerProxyAuthorization req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpProxyAuthorization = Just x }

-- | Check that a list of ranges are syntatically valid
checkRanges :: [Range] -> Maybe [Range]
checkRanges ranges = r where
  r = if any invalid ranges
         then Nothing
         else Just ranges
  invalid (RangeOf a b) = a > b
  invalid _ = False

headerRange req = (C.string "bytes=" *> list f) >>= \a -> return $ req { httpRange = checkRanges a } where
  f = a <|> b <|> c where
    a = char '-' *> liftA RangeSuffix int64
    b = int64 >>= (\start -> char '-' *> liftA (RangeOf start) int64)
    c = int64 >>= (\start -> char '-' *> return (RangeFrom start))

headerReferer req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpReferer = Just x }
headerRetryAfter req = int64 >>= \i -> return $ req { httpRetryAfter = Just i }
headerServer req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpServer = Just x }
headerTransferEncoding req = list stringToken >>= \xs -> return $ req { httpTransferEncoding = xs }
headerTrailer req = list stringToken >>= \xs -> return $ req { httpTrailer = Just xs }
headerUserAgent req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpUserAgent = Just x }
headerWWWAuthenticate req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpWWWAuthenticate = Just x }

emptyCookie = Cookie B.empty B.empty Nothing Nothing Nothing False

mergeCookie a b =
  Cookie { cookieName = bs cookieName
         , cookieValue = bs cookieValue
         , cookiePath = m cookiePath
         , cookieDomain = m cookieDomain
         , cookieExpires = m cookieExpires
         , cookieSecure = cookieSecure a || cookieSecure b } where
  bs f = if B.null $ f a then f b else f a
  m f = case f a of
             Nothing -> f b
             x -> x

cookie = do
  name <- C.spanOf1 (/= 0x3d {- '=' -} )
  C.word8 0x3d
  value <- C.spanOf1 (/= 0x3b {- ';' -} )

  options <- C.many $ do
    C.word8 0x3b
    lws
    key <- C.spanOf1 (BSet.member alphas)
    let value = C.spanOf1 (/= 0x3b)
    case key of
         "secure" -> return $ emptyCookie { cookieSecure = True }
         "path" -> value >>= \v -> (return $ emptyCookie { cookiePath = Just $ toString v })
         "domain" -> value >>= \v ->(return $ emptyCookie { cookieDomain = Just $ toString v })
         "expires" -> date >>= \v -> (return $ emptyCookie { cookieExpires = Just v})
         _ -> C.spanOf1 (/= 0x3d) >> return emptyCookie

  return $ foldl mergeCookie (emptyCookie { cookieName = name, cookieValue = value }) options

headerSetCookie req = cookie >>= \c -> return $ req { httpSetCookie = c : httpSetCookie req }
headerCookie req = cookie >>= \c -> return $ req { httpCookie = c : httpCookie req }

--------------------------------------------------------------------------------
-- Top level parsing functions

messageHeader = do
  name <- token
  char ':'
  C.optional lws
  value <- C.spanOf $ BSet.member texts
  crlf

  return (name, value)

requestLine = do
  method <- C.spanOf $ BSet.member upAlphas
  C.word8 0x20
  url <- C.spanOf $ BSet.member urlSet
  C.word8 0x20
  C.string "HTTP/"
  major <- C.spanOf $ BSet.member digits
  char '.'
  minor <- C.spanOf $ BSet.member digits
  crlf


  return (method, url, (readOrZero $ toString major) :: Int
                     , (readOrZero $ toString minor) :: Int)

replyLine = do
  C.string "HTTP/"
  major <- C.spanOf $ BSet.member digits
  char '.'
  minor <- C.spanOf $ BSet.member digits
  char ' '
  status <- C.spanOf $ BSet.member digits
  char ' '
  message <- C.spanOf $ BSet.member texts
  crlf

  return (readOrZero $ toString major, readOrZero $ toString minor,
          readOrZero $ toString status, toString message)

headerParsers = Map.fromList
  [ ("Accept", headerAccept)
  , ("Accept-Charset", headerAcceptCharset)
  , ("Accept-Encoding", headerAcceptEncoding)
  , ("Accept-Language", headerAcceptLanguage)
  , ("Accept-Ranges", headerAcceptRanges)
  , ("Age", headerAge)
  , ("Allow", headerAllow)
  , ("Authorization", headerAuth)
  , ("Connection", headerConnection )
  , ("Content-Encoding", headerContentEncoding)
  , ("Content-Language", headerContentLanguage)
  , ("Content-Length", headerContentLength)
  , ("Content-Location", headerContentLocation)
  , ("Content-Range", headerContentRange)
  , ("Content-Type", headerContentType)
  , ("ETag", headerETag)
  , ("Date", headerDate)
  , ("Expires", headerExpires)
  , ("Host", headerHost)
  , ("If-Match", headerIfMatch)
  , ("If-Modified-Since", headerIfModifiedSince)
  , ("If-None-Match", headerIfNoneMatch)
  , ("If-Range", headerIfRange)
  , ("If-Unmodified-Since", headerIfUnmodifiedSince)
  , ("Keep-Alive", headerKeepAlive)
  , ("Last-Modified", headerLastModified)
  , ("Location", headerLocation)
  , ("Pragma", headerPragma)
  , ("Proxy-Authenticate", headerProxyAuthenticate)
  , ("Proxy-Authorization", headerProxyAuthorization)
  , ("Range", headerRange)
  , ("Referer", headerReferer)
  , ("Retry-After", headerRetryAfter)
  , ("Server", headerServer)
  , ("Transfer-Encoding", headerTransferEncoding)
  , ("Trailer", headerTrailer)
  , ("User-Agent", headerUserAgent)
  , ("WWW-Authenticate", headerWWWAuthenticate)
  , ("Cookie", headerCookie)
  , ("Set-Cookie", headerSetCookie)
  ]

parseMethod :: (Monad m) => B.ByteString -> m Method
parseMethod strmethod =
  case strmethod of
    "OPTIONS" -> return OPTIONS
    "GET" -> return GET
    "HEAD" -> return HEAD
    "POST" -> return POST
    "PUT" -> return PUT
    "DELETE" -> return DELETE
    "TRACE" -> return TRACE
    "CONNECT" -> return CONNECT
    _ -> fail "Bad method"

parseRequest :: (C.BinaryParser m) => m Request
parseRequest = do
  (strmethod, url, major, minor) <- requestLine
  uri <- case URL.parseRelative url of
              Just uri -> return uri
              Nothing -> fail "Failed to parse URL"
  method <- parseMethod strmethod
  headers <- parseHeaders

  return $ Request method uri major minor headers

parseReply :: (C.BinaryParser m) => m Reply
parseReply = do
  (major, minor, status, message) <- replyLine
  headers <- parseHeaders

  return $ Reply major minor status message headers

parseHeaders = do
  headers <- C.many $ messageHeader
  crlf

  let req = emptyHeaders
      req' = foldl' tryHeader req headers
      tryHeader req (header, value) =
        case Map.lookup header headerParsers of
             Nothing -> req { httpOtherHeaders = Map.insert header value $ httpOtherHeaders req }
             Just p -> case G.runGet (p req) value of
                            (Left _, _) -> req { httpOtherHeaders = Map.insert header value $ httpOtherHeaders req }
                            (Right req', _) -> req'

  return req'

parseChunkHeader :: (C.BinaryParser m) => m Int64
parseChunkHeader = do
  length <- hexInt64
  C.optional lws  -- not in RFC, due to Yahoo being broken
  C.many $ char ';' >> token >> char '=' >> (token <|> quotedString)
  crlf
  return length

--------------------------------------------------------------------------------
-- Serialisation functions

putString = P.putByteString . fromString
putChar = P.putWord8 . c2w

putShow = putString . show

putQualityList :: (a -> P.Put) -> [(a, Int)] -> P.Put
putQualityList _ [] = return ()
putQualityList f ((v, q):xs) = do
  f v
  when (q /= 1000) $ do
    P.putByteString ";q=0."
    putQuality q
  putChar ','
  putQualityList f xs

putQuality x
  | x `mod` 10 == 0 = putQuality $ div x 10
  | otherwise = putString $ show x

putHeaderM :: Maybe a -> B.ByteString -> (a -> P.Put) -> P.Put
putHeaderM Nothing _ _ = return ()
putHeaderM (Just x) h f = P.putByteString h >> P.putByteString ": " >> f x >> P.putByteString "\r\n"

putHeaderML :: Maybe [a] -> B.ByteString -> (a -> P.Put) -> P.Put
putHeaderML a b c = putHeaderM a b (sequence_ . intersperse (P.putByteString ",") . map c)

putHeaderMLE :: Maybe [a] -> B.ByteString -> (a -> P.Put) -> B.ByteString -> P.Put
putHeaderMLE a b c extra = putHeaderM a b (sequence_ . ((:) (P.putByteString extra)) . intersperse (P.putByteString ", ") . map c)

putHeaderL :: [a] -> B.ByteString -> (a -> P.Put) -> P.Put
putHeaderL [] _ _ = return ()
putHeaderL xs h f = P.putByteString h >> P.putByteString ": " >> mapM_ f xs >> P.putByteString "\r\n"

putHeaderMulti :: [a] -> B.ByteString -> (a -> P.Put) -> P.Put
putHeaderMulti vs name f = forM_ vs $ \v -> do
  P.putByteString name
  P.putByteString ": "
  f v
  P.putByteString "\r\n"

whenMaybe :: Maybe a -> (a -> P.Put) -> P.Put
whenMaybe Nothing _ = return ()
whenMaybe (Just x) f = f x

putCookie :: Cookie -> P.Put
putCookie cookie = do
  P.putByteString $ cookieName cookie
  P.putWord8 0x3d  {- '=' -}
  P.putByteString $ cookieValue cookie

  whenMaybe (cookiePath cookie) $ \s -> do
    P.putByteString "; path="
    P.putByteString $ fromString s
  whenMaybe (cookieDomain cookie) $ \s -> do
    P.putByteString "; domain="
    P.putByteString $ fromString s
  whenMaybe (cookieExpires cookie) $ \date -> do
    P.putByteString "; expires="
    putDate date
  when (cookieSecure cookie) $ P.putByteString "; secure"

putContentRange (Just (a, b), Just c) = putShow a >> putChar '-' >> putShow b >> putChar '/' >> putShow c
putContentRange (Just (a, b), Nothing) = putShow a >> putChar '-' >> putShow b >> P.putByteString "/*"
putContentRange (Nothing, Just c) = P.putByteString "*/" >> putShow c
putContentRange (Nothing, Nothing) = P.putByteString "*/*"

putList :: Char -> (a -> P.Put) -> [a] -> P.Put
putList _ _ [] = return ()
putList sep f (x:xs) = f x >> mapM_ (\x -> putChar sep >> f x) xs

putMediaType ((ty, subty), opts) = do
  putString ty
  putChar '/'
  putString subty

  let f (a, b) = putChar ';' >> putString a >> putChar '=' >> putString b
  mapM_ f opts

putQuoted :: B.ByteString -> P.Put
putQuoted s = putChar '"' >> f s >> putChar '"' where
  f s
    | B.null s = return ()
    | otherwise = P.putByteString left >> f right where
        (left, right) = B.span (/= (c2w) '"') s

timeLocale = TimeLocale {wDays = [("Sunday","Sun"),("Monday","Mon"),("Tuesday","Tue"),("Wednesday","Wed"),("Thursday","Thu"),("Friday","Fri"),("Saturday","Sat")], months = [("January","Jan"),("February","Feb"),("March","Mar"),("April","Apr"),("May","May"),("June","Jun"),("July","Jul"),("August","Aug"),("September","Sep"),("October","Oct"),("November","Nov"),("December","Dec")], intervals = [("year","years"),("month","months"),("day","days"),("hour","hours"),("min","mins"),("sec","secs"),("usec","usecs")], amPm = ("AM","PM"), dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y", dateFmt = "%m/%d/%y", timeFmt = "%H:%M:%S", time12Fmt = "%I:%M:%S %p"}

putDate = putString . formatTime timeLocale "%a, %d %b %Y %H:%M:%S GMT"
putETag (weakness, tag) = (if weakness then P.putByteString "W/" else return ()) >> putQuoted tag
putETagList = either (const $ putChar '*') $ putList ',' putQuoted
putWETagList = either (const $ putChar '*') $ putList ',' putETag
putPragma (key, mvalue) = putString key >> maybe (return ()) putString mvalue

putRange (RangeOf a b) = putShow a >> putChar '-' >> putShow b
putRange (RangeSuffix a) = putChar '-' >> putShow a
putRange (RangeFrom a) = putShow a >> putChar '-'

putHeaders :: Headers -> P.Put
putHeaders headers = do
  putHeaderM (httpAccept headers) "Accept" $ putQualityList putMediaType
  putHeaderM (httpAcceptCharset headers) "Accept-Charset" $ putQualityList putString
  putHeaderM (httpAcceptEncoding headers) "Accept-Encoding" $ putQualityList putString
  putHeaderM (httpAcceptLanguage headers) "Accept-Language" $ putQualityList putString
  when (httpAcceptRanges headers) $ P.putByteString "Accept-Ranges: bytes\r\n"
  putHeaderM (httpAge headers) "Age" putShow
  putHeaderML (httpAllow headers) "Allow" putShow
  putHeaderM (httpAuthorization headers) "Authorization" P.putByteString
  putHeaderL (httpConnection headers ++ if httpConnectionClose headers then ["close"] else [])
             "Connection" putString
  putHeaderL (httpContentEncodings headers) "Content-Encoding" putString
  putHeaderML (httpContentLanguage headers) "Content-Language" putString
  putHeaderM (httpContentLength headers) "Content-Length" putShow
  putHeaderM (httpContentLocation headers) "Content-Location" P.putByteString
  putHeaderM (httpContentRange headers) "Content-Range" putContentRange
  putHeaderM (httpContentType headers) "Content-Type" putMediaType
  putHeaderM (httpDate headers) "Date" putDate
  putHeaderM (httpETag headers) "ETag" putETag
  putHeaderM (httpExpires headers) "Expires" putDate
  putHeaderM (httpHost headers) "Host" P.putByteString
  putHeaderM (httpIfMatch headers) "If-Match" putETagList
  putHeaderM (httpIfModifiedSince headers) "If-Modified-Since" putDate
  putHeaderM (httpIfNoneMatch headers) "If-None-Match" putWETagList
  putHeaderM (httpIfRange headers) "If-Range" $ either putQuoted putDate
  putHeaderM (httpIfUnmodifiedSince headers) "If-Unmodified-Since" putDate
  putHeaderM (httpKeepAlive headers) "Keep-Alive" putShow
  putHeaderM (httpLastModified headers) "Last-Modified" putDate
  putHeaderM (httpLocation headers) "Location" P.putByteString
  putHeaderML (httpPragma headers) "Pragma" putPragma
  putHeaderM (httpProxyAuthenticate headers) "Proxy-Authenticate" P.putByteString
  putHeaderM (httpProxyAuthorization headers) "Proxy-Authorization" P.putByteString
  putHeaderMLE (httpRange headers) "Range" putRange "bytes="
  putHeaderM (httpReferer headers) "Referer" P.putByteString
  putHeaderM (httpRetryAfter headers) "Retry-After" putShow
  putHeaderM (httpServer headers) "Server" P.putByteString
  putHeaderL (httpTransferEncoding headers) "Transfer-Encoding" putString
  putHeaderML (httpTrailer headers) "Trailer" putString
  putHeaderM (httpUserAgent headers) "User-Agent" P.putByteString
  putHeaderM (httpWWWAuthenticate headers) "WWW-Authenticate" P.putByteString
  putHeaderMulti (httpSetCookie headers) "Set-Cookie" putCookie
  putHeaderMulti (httpSetCookie headers) "Cookie" putCookie
  mapM_ (\(k, v) -> P.putByteString k >> putString ": " >> P.putByteString v >> P.putByteString "\r\n") $
         Map.toList $ httpOtherHeaders headers

putRequest :: Request -> P.Put
putRequest (Request method url major minor headers) = do
  putShow method >> putChar ' ' >> P.putByteString (URL.serialiseRelative url) >> putChar ' '
  P.putByteString "HTTP/"
  putShow major >> putChar '.' >> putShow minor >> P.putByteString "\r\n"
  putHeaders headers
  P.putByteString "\r\n"

putReply :: Reply -> P.Put
putReply (Reply major minor status message headers) = do
  P.putByteString "HTTP/" >> putShow major >> putChar '.' >> putShow minor
  putChar ' ' >> putShow status >> putChar ' '
  putString message >> P.putByteString "\r\n"
  putHeaders headers
  P.putByteString "\r\n"