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