Network/HTTP/Cookie.hs

-----------------------------------------------------------------------------
-- |
-- Module : Network.HTTP.Cookie
-- Copyright : (c) Warrick Gray 2002, Bjorn Bringert 2003-2005, 2007 Robin Bate Boerop, 2008- Sigbjorn Finne
-- License : BSD
-- 
-- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.com>
-- 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.
 , cookieToHeader -- :: 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

-- | @cookieToHeader ck@ serialises a @Cookie@ to an HTTP request header.
cookieToHeader :: Cookie -> Header
cookieToHeader ck = Header HdrCookie text
 where
 path = maybe "" (";$Path="++) (ckPath ck)
 text = "$Version=" ++ fromMaybe "0" (ckVersion ck)
 ++ ';' : ckName ck ++ "=" ++ ckValue ck ++ path
 ++ (case ckPath ck of
 Nothing -> ""
 Just x -> ";$Path=" ++ x)
 ++ ";$Domain=" ++ ckDomain ck


-- | @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 "" (do { char '=' ; spaces_l ; v <- cvalue ; return v })
 ; 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==':'))