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
142
143
144
145
|
-----------------------------------------------------------------------------
-- |
-- 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==':'))
|
