-----------------------------------------------------------------------------

-- |

-- Module      :  Network.HTTP.Cookie

-- Copyright   :  See LICENSE file

-- License     :  BSD

-- 

-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>

-- Stability   :  experimental

-- Portability :  non-portable (not tested)

--

-- This module provides the data types and functions for working with HTTP cookies.

-- Right now, it contains mostly functionality needed by 'Network.Browser'.

-- 

-----------------------------------------------------------------------------

module Network.HTTP.Cookie

       ( Cookie(..)

       , cookieMatch          -- :: (String,String) -> Cookie -> Bool

          -- functions for translating cookies and headers.

       , cookiesToHeader      -- :: [Cookie] -> Header

       , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie])

       ) where

import Network.HTTP.Headers

import Data.Char

import Data.List

import Data.Maybe

import Text.ParserCombinators.Parsec

   ( Parser, char, many, many1, satisfy, parse, option, try

   , (<|>), sepBy1

   )

------------------------------------------------------------------

----------------------- Cookie Stuff -----------------------------

------------------------------------------------------------------

-- | @Cookie@ is the Haskell representation of HTTP cookie values.

-- See its relevant specs for authoritative details.

data Cookie 

 = MkCookie 

    { ckDomain  :: String

    , ckName    :: String

    , ckValue   :: String

    , ckPath    :: Maybe String

    , ckComment :: Maybe String

    , ckVersion :: Maybe String

    }

    deriving(Show,Read)

instance Eq Cookie where

    a == b  =  ckDomain a == ckDomain b 

            && ckName a == ckName b 

            && ckPath a == ckPath b

-- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header.

cookiesToHeader :: [Cookie] -> Header

cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs)

-- | Turn a list of cookies into a key=value pair list, separated by

-- semicolons.

mkCookieHeaderValue :: [Cookie] -> String

mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1

  where

    mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c

-- | @cookieMatch (domain,path) ck@ performs the standard cookie

-- match wrt the given domain and path. 

cookieMatch :: (String, String) -> Cookie -> Bool

cookieMatch (dom,path) ck =

 ckDomain ck `isSuffixOf` dom &&

 case ckPath ck of

   Nothing -> True

   Just p  -> p `isPrefixOf` path

-- | @processCookieHeaders dom hdrs@ 

processCookieHeaders :: String -> [Header] -> ([String], [Cookie])

processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs

-- | @headerToCookies dom hdr acc@ 

headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])

headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = 

    case parse cookies "" val of

        Left{}  -> (val:accErr, accCookie)

        Right x -> (accErr, x ++ accCookie)

  where

   cookies :: Parser [Cookie]

   cookies = sepBy1 cookie (char ',')

   cookie :: Parser Cookie

   cookie =

       do name <- word

          _    <- spaces_l

          _    <- char '='

          _    <- spaces_l

          val1 <- cvalue

          args <- cdetail

          return $ mkCookie name val1 args

   cvalue :: Parser String

   spaces_l = many (satisfy isSpace)

   cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return ""

   -- all keys in the result list MUST be in lower case

   cdetail :: Parser [(String,String)]

   cdetail = many $

       try (do _  <- spaces_l

               _  <- char ';'

               _  <- spaces_l

               s1 <- word

               _  <- spaces_l

               s2 <- option "" (char '=' >> spaces_l >> cvalue)

               return (map toLower s1,s2)

           )

   mkCookie :: String -> String -> [(String,String)] -> Cookie

   mkCookie nm cval more = 

          MkCookie { ckName    = nm

                   , ckValue   = cval

                   , ckDomain  = map toLower (fromMaybe dom (lookup "domain" more))

                   , ckPath    = lookup "path" more

                   , ckVersion = lookup "version" more

                   , ckComment = lookup "comment" more

                   }

headerToCookies _ _ acc = acc

word, quotedstring :: Parser String

quotedstring =

    do _   <- char '"'  -- "

       str <- many (satisfy $ not . (=='"'))

       _   <- char '"'

       return str

word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))