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
|
module HTML.Session
( sessionCookie, doesSessionExist, withSessionCookie, withSessionCookieInfo
, SessionStore, emptySessionStore
, getSessionMaybeData, getSessionData, putSessionData, removeSessionData
, updateSessionData
) where
import Global
import List ( findIndex, replace )
import Maybe ( fromMaybe )
import Time ( ClockTime, addMinutes, clockTimeToInt, getClockTime )
import HTML.Base
import Crypto.Hash ( randomString )
inDataDir :: String -> String
inDataDir filename = filename
sessionLifespan :: Int
sessionLifespan = 60
sessionCookieName :: String
sessionCookieName = "currySessionId"
lastId :: Global (Int, Int)
lastId = global (0, 0) (Persistent (inDataDir sessionCookieName))
data SessionId = SessionId String
deriving Eq
getId :: SessionId -> String
getId (SessionId i) = i
getUnusedId :: IO SessionId
getUnusedId = do
(ltime,lsid) <- safeReadGlobal lastId (0,0)
clockTime <- getClockTime
if clockTimeToInt clockTime /= ltime
then writeGlobal lastId (clockTimeToInt clockTime, 0)
else writeGlobal lastId (clockTimeToInt clockTime, lsid+1)
rans <- randomString 30
return (SessionId (show (clockTimeToInt clockTime) ++ show (lsid+1) ++ rans))
doesSessionExist :: IO Bool
doesSessionExist = do
cookies <- getCookies
return $ maybe False (const True) (lookup sessionCookieName cookies)
getSessionId :: IO SessionId
getSessionId = do
cookies <- getCookies
case (lookup sessionCookieName cookies) of
Just sessionCookieValue -> return (SessionId sessionCookieValue)
Nothing -> getUnusedId
sessionCookie :: IO PageParam
sessionCookie = do
sessionId <- getSessionId
clockTime <- getClockTime
return $ PageCookie sessionCookieName (getId (sessionId))
[CookiePath "/",
CookieExpire (addMinutes sessionLifespan clockTime)]
withSessionCookie :: HtmlPage -> IO HtmlPage
withSessionCookie p = do
cookie <- sessionCookie
return $ (p `addPageParam` cookie)
withSessionCookieInfo :: HtmlPage -> IO HtmlPage
withSessionCookieInfo p = do
hassession <- doesSessionExist
if hassession then withSessionCookie p
else cookieInfoPage
cookieInfoPage :: IO HtmlPage
cookieInfoPage = do
urlparam <- getUrlParameter
withSessionCookie $ standardPage "Cookie Info"
[ par [ htxt $ "This web site uses cookies for navigation and user " ++
"inputs and preferences. In order to proceed, "
, bold [href ('?' : urlparam) [htxt "please click here."]]]]
data SessionStore a = SessionStore [(SessionId, Int, a)]
emptySessionStore :: SessionStore _
emptySessionStore = SessionStore []
getSessionMaybeData :: Global (SessionStore a) -> IO (Maybe a)
getSessionMaybeData sessionData = do
sid <- getSessionId
SessionStore sdata <- safeReadGlobal sessionData emptySessionStore
return (findInSession sid sdata)
where
findInSession si ((id, _, storedData):rest) =
if getId id == getId si
then Just storedData
else findInSession si rest
findInSession _ [] = Nothing
getSessionData :: Global (SessionStore a) -> a -> IO a
getSessionData sessionData defaultdata =
getSessionMaybeData sessionData >>= return . fromMaybe defaultdata
putSessionData :: Global (SessionStore a) -> a -> IO ()
putSessionData sessionData newData = do
sid <- getSessionId
SessionStore sdata <- safeReadGlobal sessionData emptySessionStore
currentTime <- getClockTime
case findIndex (\ (id, _, _) -> id == sid) sdata of
Just i ->
writeGlobal sessionData
(SessionStore (replace (sid, clockTimeToInt currentTime, newData) i
(cleanup currentTime sdata)))
Nothing ->
writeGlobal sessionData
(SessionStore ((sid, clockTimeToInt currentTime, newData)
: cleanup currentTime sdata))
updateSessionData :: Global (SessionStore a) -> a -> (a -> a) -> IO ()
updateSessionData sessiondata defaultdata upd = do
sd <- getSessionData sessiondata defaultdata
putSessionData sessiondata (upd sd)
removeSessionData :: Global (SessionStore a) -> IO ()
removeSessionData sessionData = do
sid <- getSessionId
SessionStore sdata <- safeReadGlobal sessionData emptySessionStore
currentTime <- getClockTime
writeGlobal sessionData
(SessionStore (filter (\ (id, _, _) -> id /= sid)
(cleanup currentTime sdata)))
cleanup :: ClockTime -> [(SessionId, Int, a)] -> [(SessionId, Int, a)]
cleanup currentTime sessionData =
filter (\ (_, time, _) ->
time > clockTimeToInt (addMinutes (0-sessionLifespan) currentTime))
sessionData
|