-----------------------------------------------------------------------------
-- |
-- 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==':'))