1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
-----------------------------------------------------------------------------
-- |
-- 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==':'))
|
