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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
{-# LANGUAGE OverloadedStrings #-}
module Web.Cookie
( -- * Server to client
-- ** Data type
SetCookie
, setCookieName
, setCookieValue
, setCookiePath
, setCookieExpires
, setCookieMaxAge
, setCookieDomain
, setCookieHttpOnly
, setCookieSecure
-- ** Functions
, parseSetCookie
, renderSetCookie
, def
-- * Client to server
, Cookies
, parseCookies
, renderCookies
-- ** UTF8 Version
, CookiesText
, parseCookiesText
, renderCookiesText
-- * Expires field
, expiresFormat
, formatCookieExpires
, parseCookieExpires
) where
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.Char (toLower)
import Blaze.ByteString.Builder (Builder, fromByteString, copyByteString)
import Blaze.ByteString.Builder.Char8 (fromChar)
import Data.Monoid (mempty, mappend, mconcat)
import Data.Word (Word8)
import Data.Ratio (numerator, denominator)
import Data.Time (UTCTime (UTCTime), toGregorian, fromGregorian, formatTime, parseTime)
import Data.Time.Clock (DiffTime, secondsToDiffTime)
import System.Locale (defaultTimeLocale)
import Control.Arrow (first)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Control.Arrow ((***))
import Data.Maybe (isJust)
import Data.Default (Default (def))
import Control.DeepSeq (NFData (rnf))
-- | Textual cookies. Functions assume UTF8 encoding.
type CookiesText = [(Text, Text)]
parseCookiesText :: S.ByteString -> CookiesText
parseCookiesText =
map (go *** go) . parseCookies
where
go = decodeUtf8With lenientDecode
-- FIXME to speed things up, skip encodeUtf8 and use fromText instead
renderCookiesText :: CookiesText -> Builder
renderCookiesText = renderCookies . map (encodeUtf8 *** encodeUtf8)
type Cookies = [(S.ByteString, S.ByteString)]
-- | Decode the value of a \"Cookie\" request header into key/value pairs.
parseCookies :: S.ByteString -> Cookies
parseCookies s
| S.null s = []
| otherwise =
let (x, y) = breakDiscard 59 s -- semicolon
in parseCookie x : parseCookies y
parseCookie :: S.ByteString -> (S.ByteString, S.ByteString)
parseCookie s =
let (key, value) = breakDiscard 61 s -- equals sign
key' = S.dropWhile (== 32) key -- space
in (key', value)
breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)
breakDiscard w s =
let (x, y) = S.breakByte w s
in (x, S.drop 1 y)
renderCookies :: Cookies -> Builder
renderCookies [] = mempty
renderCookies cs =
foldr1 go $ map renderCookie cs
where
go x y = x `mappend` fromChar ';' `mappend` y
renderCookie :: (S.ByteString, S.ByteString) -> Builder
renderCookie (k, v) = fromByteString k `mappend` fromChar '='
`mappend` fromByteString v
data SetCookie = SetCookie
{ setCookieName :: S.ByteString
, setCookieValue :: S.ByteString
, setCookiePath :: Maybe S.ByteString
, setCookieExpires :: Maybe UTCTime
, setCookieMaxAge :: Maybe DiffTime
, setCookieDomain :: Maybe S.ByteString
, setCookieHttpOnly :: Bool
, setCookieSecure :: Bool
}
deriving (Eq, Show)
instance NFData SetCookie where
rnf (SetCookie a b c d e f g h) =
a `seq`
b `seq`
rnfMBS c `seq`
rnf d `seq`
rnf e `seq`
rnfMBS f `seq`
rnf g `seq`
rnf h
where
-- For backwards compatibility
rnfMBS Nothing = ()
rnfMBS (Just bs) = bs `seq` ()
instance Default SetCookie where
def = SetCookie
{ setCookieName = "name"
, setCookieValue = "value"
, setCookiePath = Nothing
, setCookieExpires = Nothing
, setCookieMaxAge = Nothing
, setCookieDomain = Nothing
, setCookieHttpOnly = False
, setCookieSecure = False
}
renderSetCookie :: SetCookie -> Builder
renderSetCookie sc = mconcat
[ fromByteString (setCookieName sc)
, fromChar '='
, fromByteString (setCookieValue sc)
, case setCookiePath sc of
Nothing -> mempty
Just path -> copyByteString "; Path="
`mappend` fromByteString path
, case setCookieExpires sc of
Nothing -> mempty
Just e -> copyByteString "; Expires=" `mappend`
fromByteString (formatCookieExpires e)
, case setCookieMaxAge sc of
Nothing -> mempty
Just ma -> copyByteString"; Max-Age=" `mappend`
fromByteString (formatCookieMaxAge ma)
, case setCookieDomain sc of
Nothing -> mempty
Just d -> copyByteString "; Domain=" `mappend`
fromByteString d
, if setCookieHttpOnly sc
then copyByteString "; HttpOnly"
else mempty
, if setCookieSecure sc
then copyByteString "; Secure"
else mempty
]
parseSetCookie :: S.ByteString -> SetCookie
parseSetCookie a = SetCookie
{ setCookieName = name
, setCookieValue = value
, setCookiePath = lookup "path" flags
, setCookieExpires =
lookup "expires" flags >>= parseCookieExpires
, setCookieMaxAge =
lookup "max-age" flags >>= parseCookieMaxAge
, setCookieDomain = lookup "domain" flags
, setCookieHttpOnly = isJust $ lookup "httponly" flags
, setCookieSecure = isJust $ lookup "secure" flags
}
where
pairs = map (parsePair . dropSpace) $ S.split 59 a ++ [S8.empty] -- 59 = semicolon
(name, value) = head pairs
flags = map (first (S8.map toLower)) $ tail pairs
parsePair = breakDiscard 61 -- equals sign
dropSpace = S.dropWhile (== 32) -- space
expiresFormat :: String
expiresFormat = "%a, %d-%b-%Y %X GMT"
-- | Format a 'UTCTime' for a cookie.
formatCookieExpires :: UTCTime -> S.ByteString
formatCookieExpires =
S8.pack . formatTime defaultTimeLocale expiresFormat
parseCookieExpires :: S.ByteString -> Maybe UTCTime
parseCookieExpires =
fmap fuzzYear . parseTime defaultTimeLocale expiresFormat . S8.unpack
where
-- See: https://github.com/snoyberg/cookie/issues/5
fuzzYear orig@(UTCTime day diff)
| x >= 70 && x <= 99 = addYear 1900
| x >= 0 && x <= 69 = addYear 2000
| otherwise = orig
where
(x, y, z) = toGregorian day
addYear x' = UTCTime (fromGregorian (x + x') y z) diff
-- | Format a 'DiffTime' for a cookie.
formatCookieMaxAge :: DiffTime -> S.ByteString
formatCookieMaxAge difftime = S8.pack $ show (num `div` denom)
where rational = toRational difftime
num = numerator rational
denom = denominator rational
parseCookieMaxAge :: S.ByteString -> Maybe DiffTime
parseCookieMaxAge bs
| all (\ c -> c >= '0' && c <= '9') $ unpacked = Just $ secondsToDiffTime $ read unpacked
| otherwise = Nothing
where unpacked = S8.unpack bs
|
