adam@26
|
1 style provider
|
adam@26
|
2
|
adam@26
|
3 style aol
|
adam@26
|
4 style google
|
adam@26
|
5 style myspace
|
adam@26
|
6 style yahoo
|
adam@26
|
7
|
adam@28
|
8 datatype choose_result a = Success of a | Failure of string
|
adam@28
|
9
|
kkallio@35
|
10 signature CTLDISPLAY = sig
|
kkallio@35
|
11 val formatUser : xbody -> xbody
|
kkallio@35
|
12 val formatLogout : url -> xbody
|
kkallio@35
|
13 val formatSignup : url -> xbody
|
kkallio@35
|
14 val formatLogon : ({User : string} -> transaction page) -> xbody
|
kkallio@35
|
15 end
|
kkallio@35
|
16
|
kkallio@35
|
17 structure DefaultDisplay : CTLDISPLAY = struct
|
kkallio@35
|
18 fun formatUser user =
|
adam@37
|
19 <xml>You are logged in as {user}.</xml>
|
kkallio@35
|
20
|
kkallio@35
|
21 fun formatLogout url =
|
kkallio@35
|
22 <xml><a href={url}>Log Out</a></xml>
|
kkallio@35
|
23
|
kkallio@35
|
24 fun formatSignup url =
|
kkallio@35
|
25 <xml><a href={url}>Sign Up</a></xml>
|
kkallio@35
|
26
|
kkallio@35
|
27 fun formatLogon handler =
|
kkallio@35
|
28 <xml>
|
kkallio@35
|
29 <form><textbox{#User}/><submit value="Log In" action={handler}/></form>
|
kkallio@35
|
30 </xml>
|
kkallio@35
|
31 end
|
kkallio@35
|
32
|
kkallio@35
|
33
|
adam@16
|
34 functor Make(M: sig
|
adam@16
|
35 con cols :: {Type}
|
adam@16
|
36 constraint [Id] ~ cols
|
adam@17
|
37 val folder : folder cols
|
adam@17
|
38 val inj : $(map sql_injectable cols)
|
adam@17
|
39
|
adam@17
|
40 type creationState
|
adam@17
|
41 type creationData
|
adam@17
|
42 val creationState : transaction creationState
|
adam@17
|
43 val render : creationState -> xtable
|
adam@20
|
44 val ready : creationState -> signal bool
|
adam@17
|
45 val tabulate : creationState -> signal creationData
|
adam@28
|
46 val choose : sql_table ([Id = string] ++ cols) [Pkey = [Id]] -> creationData -> transaction (choose_result $cols)
|
adam@16
|
47
|
adam@16
|
48 val sessionLifetime : int
|
adam@16
|
49 val afterLogout : url
|
adam@16
|
50 val secureCookies : bool
|
adam@16
|
51 val association : Openid.association_mode
|
adam@16
|
52 val realm : option string
|
adam@17
|
53 val formClass : css_class
|
adam@23
|
54 val fakeId : option string
|
kkallio@31
|
55
|
kkallio@35
|
56 structure CtlDisplay : CTLDISPLAY
|
adam@16
|
57 end) = struct
|
adam@16
|
58
|
adam@16
|
59 type user = string
|
adam@28
|
60 val eq_user = _
|
adam@28
|
61 val read_user = _
|
adam@16
|
62 val show_user = _
|
adam@16
|
63 val inj_user = _
|
adam@16
|
64
|
adam@16
|
65 table user : ([Id = user] ++ M.cols)
|
adam@16
|
66 PRIMARY KEY Id
|
adam@16
|
67
|
adam@16
|
68 table identity : {User : user, Identifier : string}
|
adam@16
|
69 PRIMARY KEY (User, Identifier)
|
adam@16
|
70
|
adam@16
|
71 sequence sessionIds
|
adam@16
|
72
|
adam@16
|
73 table session : {Id : int, Key : int, Identifier : option string, Expires : time}
|
adam@16
|
74 PRIMARY KEY Id
|
adam@16
|
75
|
adam@22
|
76 datatype authMode =
|
adam@22
|
77 SigningUp of {Session : int, Key : int}
|
adam@22
|
78 | LoggedIn of {User : user, Session : int, Key : int}
|
adam@22
|
79
|
adam@22
|
80 cookie auth : authMode
|
adam@16
|
81
|
adam@17
|
82 val currentUrl =
|
adam@17
|
83 b <- currentUrlHasPost;
|
adam@17
|
84 if b then
|
adam@17
|
85 return M.afterLogout
|
adam@17
|
86 else
|
adam@45
|
87 b <- currentUrlHasQueryString;
|
adam@45
|
88 if b then
|
adam@45
|
89 return M.afterLogout
|
adam@45
|
90 else
|
adam@45
|
91 currentUrl
|
adam@17
|
92
|
adam@16
|
93 val current =
|
adam@22
|
94 login <- getCookie auth;
|
adam@16
|
95 case login of
|
adam@22
|
96 Some (LoggedIn login) =>
|
adam@22
|
97 (ident <- oneOrNoRowsE1 (SELECT (session.Identifier)
|
adam@22
|
98 FROM session
|
adam@22
|
99 WHERE session.Id = {[login.Session]}
|
adam@22
|
100 AND session.Key = {[login.Key]});
|
adam@22
|
101 case ident of
|
adam@22
|
102 None => return None
|
adam@22
|
103 | Some None => return None
|
adam@22
|
104 | Some (Some ident) =>
|
adam@22
|
105 valid <- oneRowE1 (SELECT COUNT( * ) > 0
|
adam@22
|
106 FROM identity
|
adam@22
|
107 WHERE identity.User = {[login.User]}
|
adam@22
|
108 AND identity.Identifier = {[ident]});
|
adam@22
|
109 if valid then
|
adam@22
|
110 return (Some login.User)
|
adam@22
|
111 else
|
adam@22
|
112 error <xml>Session not authorized to act as user</xml>)
|
adam@22
|
113 | _ => return None
|
adam@16
|
114
|
adam@17
|
115 fun validUser s = String.length s > 0 && String.length s < 20
|
adam@17
|
116 && String.all Char.isAlnum s
|
adam@17
|
117
|
adam@16
|
118 fun main wrap =
|
adam@16
|
119 let
|
adam@16
|
120 fun logout () =
|
adam@22
|
121 clearCookie auth;
|
adam@16
|
122 redirect M.afterLogout
|
adam@16
|
123
|
adam@17
|
124 fun signupDetails after =
|
adam@17
|
125 let
|
adam@17
|
126 fun finishSignup uid data =
|
adam@17
|
127 if not (validUser uid) then
|
adam@17
|
128 return (Some "That username is not valid. It must be between 1 and 19 characters long, containing only letters and numbers.")
|
adam@17
|
129 else
|
adam@17
|
130 used <- oneRowE1 (SELECT COUNT( * ) > 0
|
adam@17
|
131 FROM user
|
adam@17
|
132 WHERE user.Id = {[uid]});
|
adam@17
|
133 if used then
|
adam@17
|
134 return (Some "That username is taken. Please choose another.")
|
adam@17
|
135 else
|
adam@22
|
136 ses <- getCookie auth;
|
adam@17
|
137 case ses of
|
adam@17
|
138 None => return (Some "Missing session cookie")
|
adam@22
|
139 | Some (LoggedIn _) => return (Some "Session cookie is for already logged-in user")
|
adam@22
|
140 | Some (SigningUp ses) =>
|
adam@17
|
141 ident <- oneOrNoRowsE1 (SELECT (session.Identifier)
|
adam@17
|
142 FROM session
|
adam@17
|
143 WHERE session.Id = {[ses.Session]}
|
adam@17
|
144 AND session.Key = {[ses.Key]});
|
adam@17
|
145 case ident of
|
adam@17
|
146 None => return (Some "Invalid session data")
|
adam@17
|
147 | Some None => return (Some "Session has no associated identifier")
|
adam@17
|
148 | Some (Some ident) =>
|
adam@28
|
149 cols <- M.choose user data;
|
adam@28
|
150 case cols of
|
adam@28
|
151 Failure s => return (Some s)
|
adam@28
|
152 | Success cols =>
|
adam@28
|
153 setCookie auth {Value = LoggedIn ({User = uid} ++ ses),
|
adam@28
|
154 Expires = None,
|
adam@28
|
155 Secure = M.secureCookies};
|
adam@17
|
156
|
adam@28
|
157 dml (insert user ({Id = (SQL {[uid]})} ++ @Sql.sqexps M.folder M.inj cols));
|
adam@28
|
158 dml (INSERT INTO identity (User, Identifier)
|
adam@28
|
159 VALUES ({[uid]}, {[ident]}));
|
adam@30
|
160 return None
|
adam@17
|
161 in
|
adam@17
|
162 uid <- source "";
|
adam@17
|
163 cs <- M.creationState;
|
adam@17
|
164
|
adam@17
|
165 wrap "Your User Details" <xml>
|
adam@17
|
166 <table class={M.formClass}>
|
adam@17
|
167 <tr> <th class={M.formClass}>Username:</th> <td><ctextbox source={uid}/></td> </tr>
|
adam@17
|
168 {M.render cs}
|
adam@20
|
169 <tr> <td><dyn signal={b <- M.ready cs;
|
adam@20
|
170 return (if b then
|
adam@20
|
171 <xml><button value="Create Account"
|
adam@20
|
172 onclick={uid <- get uid;
|
adam@20
|
173 data <- Basis.current (M.tabulate cs);
|
adam@20
|
174 res <- rpc (finishSignup uid data);
|
adam@20
|
175 case res of
|
adam@20
|
176 None => redirect (bless after)
|
adam@20
|
177 | Some msg => alert msg}/></xml>
|
adam@20
|
178 else
|
adam@20
|
179 <xml/>)}/></td> </tr>
|
adam@17
|
180 </table>
|
adam@17
|
181 </xml>
|
adam@17
|
182 end
|
adam@17
|
183
|
adam@16
|
184 fun opCallback after ses res =
|
adam@16
|
185 case res of
|
adam@16
|
186 Openid.Canceled => error <xml>You canceled the login process.</xml>
|
adam@16
|
187 | Openid.Failure s => error <xml>Login failed: {[s]}</xml>
|
adam@16
|
188 | Openid.AuthenticatedAs ident =>
|
adam@22
|
189 av <- getCookie auth;
|
adam@22
|
190 case av of
|
adam@22
|
191 Some (SigningUp signup) =>
|
adam@16
|
192 if signup.Session <> ses then
|
adam@16
|
193 error <xml>Session has changed suspiciously</xml>
|
adam@16
|
194 else
|
adam@16
|
195 invalid <- oneRowE1 (SELECT COUNT( * ) = 0
|
adam@16
|
196 FROM session
|
adam@16
|
197 WHERE session.Id = {[signup.Session]}
|
adam@16
|
198 AND session.Key = {[signup.Key]});
|
adam@16
|
199 if invalid then
|
adam@16
|
200 error <xml>Invalid or expired session</xml>
|
adam@16
|
201 else
|
adam@17
|
202 dml (UPDATE session
|
adam@17
|
203 SET Identifier = {[Some ident]}
|
adam@17
|
204 WHERE Id = {[signup.Session]});
|
adam@17
|
205 signupDetails after
|
adam@22
|
206 | Some (LoggedIn login) =>
|
adam@22
|
207 if login.Session <> ses then
|
adam@22
|
208 error <xml>Session has changed suspiciously</xml>
|
adam@22
|
209 else
|
adam@22
|
210 invalid <- oneRowE1 (SELECT COUNT( * ) = 0
|
adam@22
|
211 FROM session
|
adam@22
|
212 WHERE session.Id = {[login.Session]}
|
adam@22
|
213 AND session.Key = {[login.Key]});
|
adam@22
|
214 if invalid then
|
adam@22
|
215 error <xml>Invalid or expired session</xml>
|
adam@16
|
216 else
|
adam@22
|
217 dml (UPDATE session
|
adam@22
|
218 SET Identifier = {[Some ident]}
|
adam@22
|
219 WHERE Id = {[login.Session]});
|
adam@22
|
220 redirect (bless after)
|
adam@22
|
221 | None => error <xml>Missing session cookie</xml>
|
adam@16
|
222
|
adam@23
|
223 fun fakeCallback ident after ses =
|
adam@23
|
224 av <- getCookie auth;
|
adam@23
|
225 case av of
|
adam@23
|
226 Some (SigningUp signup) =>
|
adam@23
|
227 invalid <- oneRowE1 (SELECT COUNT( * ) = 0
|
adam@23
|
228 FROM session
|
adam@23
|
229 WHERE session.Id = {[signup.Session]}
|
adam@23
|
230 AND session.Key = {[signup.Key]});
|
adam@23
|
231 if invalid then
|
adam@23
|
232 error <xml>Invalid or expired session</xml>
|
adam@23
|
233 else
|
adam@23
|
234 dml (UPDATE session
|
adam@23
|
235 SET Identifier = {[Some ident]}
|
adam@23
|
236 WHERE Id = {[signup.Session]});
|
adam@23
|
237 signupDetails after
|
adam@23
|
238 | Some (LoggedIn login) =>
|
adam@23
|
239 invalid <- oneRowE1 (SELECT COUNT( * ) = 0
|
adam@23
|
240 FROM session
|
adam@23
|
241 WHERE session.Id = {[login.Session]}
|
adam@23
|
242 AND session.Key = {[login.Key]});
|
adam@23
|
243 if invalid then
|
adam@23
|
244 error <xml>Invalid or expired session</xml>
|
adam@23
|
245 else
|
adam@23
|
246 dml (UPDATE session
|
adam@23
|
247 SET Identifier = {[Some ident]}
|
adam@23
|
248 WHERE Id = {[login.Session]});
|
adam@23
|
249 redirect (bless after)
|
adam@23
|
250 | None => error <xml>Missing session cookie</xml>
|
adam@23
|
251
|
adam@16
|
252 fun newSession () =
|
adam@16
|
253 ses <- nextval sessionIds;
|
adam@16
|
254 now <- now;
|
adam@16
|
255 key <- rand;
|
adam@16
|
256 dml (INSERT INTO session (Id, Key, Identifier, Expires)
|
adam@16
|
257 VALUES ({[ses]}, {[key]}, NULL, {[addSeconds now M.sessionLifetime]}));
|
adam@16
|
258 return {Session = ses, Key = key}
|
adam@16
|
259
|
adam@17
|
260 fun logon after r =
|
adam@16
|
261 ident <- oneOrNoRowsE1 (SELECT (identity.Identifier)
|
adam@16
|
262 FROM identity
|
adam@16
|
263 WHERE identity.User = {[r.User]}
|
adam@16
|
264 LIMIT 1);
|
adam@16
|
265 case ident of
|
adam@16
|
266 None => error <xml>Username not found</xml>
|
adam@16
|
267 | Some ident =>
|
adam@16
|
268 ses <- newSession ();
|
adam@22
|
269 setCookie auth {Value = LoggedIn (r ++ ses),
|
adam@22
|
270 Expires = None,
|
adam@22
|
271 Secure = M.secureCookies};
|
adam@16
|
272 ses <- return ses.Session;
|
adam@23
|
273 if M.fakeId = Some ident then
|
adam@23
|
274 fakeCallback ident after ses
|
adam@23
|
275 else
|
adam@23
|
276 msg <- Openid.authenticate (opCallback after ses)
|
adam@23
|
277 {Association = M.association,
|
adam@23
|
278 Realm = M.realm,
|
adam@39
|
279 Identifier = Openid.KnownIdentifier ident};
|
adam@23
|
280 error <xml>Login with your identity provider failed: {[msg]}</xml>
|
adam@16
|
281
|
adam@16
|
282 fun doSignup after r =
|
adam@16
|
283 ses <- newSession ();
|
adam@22
|
284 setCookie auth {Value = SigningUp ses,
|
adam@22
|
285 Expires = None,
|
adam@22
|
286 Secure = M.secureCookies};
|
adam@16
|
287 ses <- return ses.Session;
|
adam@23
|
288 if M.fakeId = Some r.Identifier then
|
adam@23
|
289 fakeCallback r.Identifier after ses
|
adam@23
|
290 else
|
adam@23
|
291 msg <- Openid.authenticate (opCallback after ses)
|
adam@23
|
292 {Association = M.association,
|
adam@23
|
293 Realm = M.realm,
|
adam@39
|
294 Identifier = Openid.ChooseIdentifier r.Identifier};
|
adam@23
|
295 error <xml>Login with your identity provider failed: {[msg]}</xml>
|
adam@16
|
296
|
adam@22
|
297 fun signup after =
|
adam@26
|
298 let
|
adam@27
|
299 fun fixed cls url =
|
adam@26
|
300 let
|
adam@26
|
301 fun doFixedButton () =
|
adam@26
|
302 doSignup after {Identifier = url}
|
adam@26
|
303 in
|
adam@26
|
304 <xml><form class={provider}>
|
adam@27
|
305 <submit class={cls} value="" action={doFixedButton}/>
|
adam@26
|
306 </form></xml>
|
adam@26
|
307 end
|
adam@26
|
308 in
|
adam@26
|
309 wrap "Account Signup" <xml>
|
adam@26
|
310 <p>This web site uses the <b><a href="http://openid.net/">OpenID</a></b> standard, which lets you log in using your account from one of several popular web sites, without revealing your password to us.</p>
|
adam@26
|
311
|
adam@26
|
312 <p>You may click one of these buttons to choose to use your account from that site:</p>
|
adam@27
|
313 {fixed aol "https://openid.aol.com/"}
|
adam@27
|
314 {fixed google "https://www.google.com/accounts/o8/id"}
|
adam@27
|
315 {fixed myspace "https://www.myspace.com/openid"}
|
adam@27
|
316 {fixed yahoo "https://me.yahoo.com/"}
|
adam@26
|
317
|
adam@26
|
318 <p>Visitors familiar with the details of OpenID may also enter their own identifiers:</p>
|
adam@26
|
319 <form>
|
adam@26
|
320 OpenID Identifier: <textbox{#Identifier}/><br/>
|
adam@26
|
321 <submit value="Sign Up" action={doSignup after}/>
|
adam@26
|
322 </form>
|
adam@26
|
323 </xml>
|
adam@26
|
324 end
|
adam@16
|
325 in
|
adam@16
|
326 cur <- current;
|
adam@17
|
327 here <- currentUrl;
|
kkallio@35
|
328
|
adam@16
|
329 case cur of
|
kkallio@35
|
330 Some cur => return {Status = (M.CtlDisplay.formatUser <xml>{[cur]}</xml>),
|
kkallio@35
|
331 Other = {Url = (url (logout ())),
|
kkallio@35
|
332 Xml = (M.CtlDisplay.formatLogout (url (logout ())))}}
|
kkallio@35
|
333 | None => return {Status = (M.CtlDisplay.formatLogon (logon (show here))),
|
kkallio@35
|
334 Other = {Url = (url (signup (show here))),
|
kkallio@35
|
335 Xml = (M.CtlDisplay.formatSignup (url (signup (show here))))}}
|
adam@16
|
336 end
|
adam@16
|
337
|
adam@16
|
338 task periodic 60 = fn () => dml (DELETE FROM session
|
adam@21
|
339 WHERE Expires < CURRENT_TIMESTAMP)
|
adam@16
|
340
|
adam@16
|
341 end
|