------------------------------------------------------------------------------- |-- 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'.-------------------------------------------------------------------------------moduleNetwork.HTTP.Cookie(Cookie (..),cookieMatch -- :: (String,String) -> Cookie -> Bool-- functions for translating cookies and headers.,cookiesToHeader -- :: [Cookie] -> Header,processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]))whereimportNetwork.HTTP.Headers importData.CharimportData.ListimportData.MaybeimportText.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.dataCookie =MkCookie {Cookie -> String
ckDomain ::String,Cookie -> String
ckName ::String,Cookie -> String
ckValue ::String,Cookie -> Maybe String
ckPath ::MaybeString,Cookie -> Maybe String
ckComment ::MaybeString,Cookie -> Maybe String
ckVersion ::MaybeString}deriving(Int -> Cookie -> ShowS
[Cookie] -> ShowS
Cookie -> String
(Int -> Cookie -> ShowS)
-> (Cookie -> String) -> ([Cookie] -> ShowS) -> Show Cookie
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cookie] -> ShowS
$cshowList :: [Cookie] -> ShowS
show :: Cookie -> String
$cshow :: Cookie -> String
showsPrec :: Int -> Cookie -> ShowS
$cshowsPrec :: Int -> Cookie -> ShowS
Show,ReadPrec [Cookie]
ReadPrec Cookie
Int -> ReadS Cookie
ReadS [Cookie]
(Int -> ReadS Cookie)
-> ReadS [Cookie]
-> ReadPrec Cookie
-> ReadPrec [Cookie]
-> Read Cookie
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Cookie]
$creadListPrec :: ReadPrec [Cookie]
readPrec :: ReadPrec Cookie
$creadPrec :: ReadPrec Cookie
readList :: ReadS [Cookie]
$creadList :: ReadS [Cookie]
readsPrec :: Int -> ReadS Cookie
$creadsPrec :: Int -> ReadS Cookie
Read)instanceEqCookie whereCookie
a == :: Cookie -> Cookie -> Bool
==Cookie
b =Cookie -> String
ckDomain Cookie
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==Cookie -> String
ckDomain Cookie
b Bool -> Bool -> Bool
&&Cookie -> String
ckName Cookie
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==Cookie -> String
ckName Cookie
b Bool -> Bool -> Bool
&&Cookie -> Maybe String
ckPath Cookie
a Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==Cookie -> Maybe String
ckPath Cookie
b -- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header.cookiesToHeader ::[Cookie ]->Header cookiesToHeader :: [Cookie] -> Header
cookiesToHeader [Cookie]
cs =HeaderName -> String -> Header
Header HeaderName
HdrCookie ([Cookie] -> String
mkCookieHeaderValue [Cookie]
cs )-- | Turn a list of cookies into a key=value pair list, separated by-- semicolons.mkCookieHeaderValue ::[Cookie ]->StringmkCookieHeaderValue :: [Cookie] -> String
mkCookieHeaderValue =String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalateString
"; "([String] -> String)
-> ([Cookie] -> [String]) -> [Cookie] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Cookie -> String) -> [Cookie] -> [String]
forall a b. (a -> b) -> [a] -> [b]
mapCookie -> String
mkCookieHeaderValue1 wheremkCookieHeaderValue1 :: Cookie -> String
mkCookieHeaderValue1 Cookie
c =Cookie -> String
ckName Cookie
c String -> ShowS
forall a. [a] -> [a] -> [a]
++String
"="String -> ShowS
forall a. [a] -> [a] -> [a]
++Cookie -> String
ckValue Cookie
c -- | @cookieMatch (domain,path) ck@ performs the standard cookie-- match wrt the given domain and path.cookieMatch ::(String,String)->Cookie ->BoolcookieMatch :: (String, String) -> Cookie -> Bool
cookieMatch (String
dom ,String
path )Cookie
ck =Cookie -> String
ckDomain Cookie
ck String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`String
dom Bool -> Bool -> Bool
&&caseCookie -> Maybe String
ckPath Cookie
ck ofMaybe String
Nothing->Bool
TrueJustString
p ->String
p String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`String
path -- | @processCookieHeaders dom hdrs@processCookieHeaders ::String->[Header ]->([String],[Cookie ])processCookieHeaders :: String -> [Header] -> ([String], [Cookie])
processCookieHeaders String
dom [Header]
hdrs =(Header -> ([String], [Cookie]) -> ([String], [Cookie]))
-> ([String], [Cookie]) -> [Header] -> ([String], [Cookie])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr(String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])
headerToCookies String
dom )([],[])[Header]
hdrs -- | @headerToCookies dom hdr acc@headerToCookies ::String->Header ->([String],[Cookie ])->([String],[Cookie ])headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie])
headerToCookies String
dom (Header HeaderName
HdrSetCookie String
val )([String]
accErr ,[Cookie]
accCookie )=caseParsec String () [Cookie]
-> String -> String -> Either ParseError [Cookie]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parseParsec String () [Cookie]
cookies String
""String
val ofLeft{}->(String
val String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
accErr ,[Cookie]
accCookie )Right[Cookie]
x ->([String]
accErr ,[Cookie]
x [Cookie] -> [Cookie] -> [Cookie]
forall a. [a] -> [a] -> [a]
++[Cookie]
accCookie )wherecookies ::Parser[Cookie ]cookies :: Parsec String () [Cookie]
cookies =ParsecT String () Identity Cookie
-> ParsecT String () Identity Char -> Parsec String () [Cookie]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy1ParsecT String () Identity Cookie
cookie (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
',')cookie ::ParserCookie cookie :: ParsecT String () Identity Cookie
cookie =doString
name <-Parser String
word String
_<-Parser String
forall u. ParsecT String u Identity String
spaces_l Char
_<-Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
'='String
_<-Parser String
forall u. ParsecT String u Identity String
spaces_l String
val1 <-Parser String
cvalue [(String, String)]
args <-Parser [(String, String)]
cdetail Cookie -> ParsecT String () Identity Cookie
forall (m :: * -> *) a. Monad m => a -> m a
return(Cookie -> ParsecT String () Identity Cookie)
-> Cookie -> ParsecT String () Identity Cookie
forall a b. (a -> b) -> a -> b
$String -> String -> [(String, String)] -> Cookie
mkCookie String
name String
val1 [(String, String)]
args cvalue ::ParserStringspaces_l :: ParsecT String u Identity String
spaces_l =ParsecT String u Identity Char -> ParsecT String u Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many((Char -> Bool) -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfyChar -> Bool
isSpace)cvalue :: Parser String
cvalue =Parser String
quotedstring Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy((Char -> Bool) -> ParsecT String () Identity Char)
-> (Char -> Bool) -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
';'))Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
returnString
""-- all keys in the result list MUST be in lower casecdetail ::Parser[(String,String)]cdetail :: Parser [(String, String)]
cdetail =ParsecT String () Identity (String, String)
-> Parser [(String, String)]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many(ParsecT String () Identity (String, String)
 -> Parser [(String, String)])
-> ParsecT String () Identity (String, String)
-> Parser [(String, String)]
forall a b. (a -> b) -> a -> b
$ParsecT String () Identity (String, String)
-> ParsecT String () Identity (String, String)
forall tok st a. GenParser tok st a -> GenParser tok st a
try(doString
_<-Parser String
forall u. ParsecT String u Identity String
spaces_l Char
_<-Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
';'String
_<-Parser String
forall u. ParsecT String u Identity String
spaces_l String
s1 <-Parser String
word String
_<-Parser String
forall u. ParsecT String u Identity String
spaces_l String
s2 <-String -> Parser String -> Parser String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
optionString
""(Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
'='ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>Parser String
forall u. ParsecT String u Identity String
spaces_l Parser String -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>Parser String
cvalue )(String, String) -> ParsecT String () Identity (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
mapChar -> Char
toLowerString
s1 ,String
s2 ))mkCookie ::String->String->[(String,String)]->Cookie mkCookie :: String -> String -> [(String, String)] -> Cookie
mkCookie String
nm String
cval [(String, String)]
more =MkCookie :: String
-> String
-> String
-> Maybe String
-> Maybe String
-> Maybe String
-> Cookie
MkCookie {ckName :: String
ckName =String
nm ,ckValue :: String
ckValue =String
cval ,ckDomain :: String
ckDomain =(Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
mapChar -> Char
toLower(String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybeString
dom (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"domain"[(String, String)]
more )),ckPath :: Maybe String
ckPath =String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"path"[(String, String)]
more ,ckVersion :: Maybe String
ckVersion =String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"version"[(String, String)]
more ,ckComment :: Maybe String
ckComment =String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookupString
"comment"[(String, String)]
more }headerToCookies String
_Header
_([String], [Cookie])
acc =([String], [Cookie])
acc word ,quotedstring ::ParserStringquotedstring :: Parser String
quotedstring =doChar
_<-Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
'"'-- "String
str <-ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy((Char -> Bool) -> ParsecT String () Identity Char)
-> (Char -> Bool) -> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'"'))Char
_<-Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
charChar
'"'String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
returnString
str word :: Parser String
word =ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy(\Char
x ->Char -> Bool
isAlphaNumChar
x Bool -> Bool -> Bool
||Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'_'Bool -> Bool -> Bool
||Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'.'Bool -> Bool -> Bool
||Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-'Bool -> Bool -> Bool
||Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':'))