Mercurial > openid

comparison src/ur/openidUser.ur @ 17:df2eb629f21a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Successfully created an account
author Adam Chlipala <adam@chlipala.net>
date Thu, 06 Jan 2011 14:42:37 -0500
parents 9851bc87b0d7
children dd8eb53da51b
comparison
equal deleted inserted replaced
16:9851bc87b0d7 17:df2eb629f21a
1 functor Make(M: sig 1 functor Make(M: sig
2 con cols :: {Type} 2 con cols :: {Type}
3 constraint [Id] ~ cols 3 constraint [Id] ~ cols
4 val folder : folder cols
5 val inj : $(map sql_injectable cols)
6
7 type creationState
8 type creationData
9 val creationState : transaction creationState
10 val render : creationState -> xtable
11 val tabulate : creationState -> signal creationData
12 val choose : sql_table ([Id = string] ++ cols) [Pkey = [Id]] -> creationData -> transaction $cols
4 13
5 val sessionLifetime : int 14 val sessionLifetime : int
6 val afterLogout : url 15 val afterLogout : url
7 val secureCookies : bool 16 val secureCookies : bool
8 val association : Openid.association_mode 17 val association : Openid.association_mode
9 val realm : option string 18 val realm : option string
19 val formClass : css_class
10 end) = struct 20 end) = struct
11 21
12 type user = string 22 type user = string
13 val show_user = _ 23 val show_user = _
14 val inj_user = _ 24 val inj_user = _
24 table session : {Id : int, Key : int, Identifier : option string, Expires : time} 34 table session : {Id : int, Key : int, Identifier : option string, Expires : time}
25 PRIMARY KEY Id 35 PRIMARY KEY Id
26 36
27 cookie signingUp : {Session : int, Key : int} 37 cookie signingUp : {Session : int, Key : int}
28 cookie login : {User : user, Session : int, Key : int} 38 cookie login : {User : user, Session : int, Key : int}
39
40 val currentUrl =
41 b <- currentUrlHasPost;
42 if b then
43 return M.afterLogout
44 else
45 currentUrl
29 46
30 val current = 47 val current =
31 login <- getCookie login; 48 login <- getCookie login;
32 case login of 49 case login of
33 None => return None 50 None => return None
47 if valid then 64 if valid then
48 return (Some login.User) 65 return (Some login.User)
49 else 66 else
50 error <xml>Session not authorized to act as user</xml> 67 error <xml>Session not authorized to act as user</xml>
51 68
69 fun validUser s = String.length s > 0 && String.length s < 20
70 && String.all Char.isAlnum s
71
52 fun main wrap = 72 fun main wrap =
53 let 73 let
54 fun logout () = 74 fun logout () =
55 clearCookie login; 75 clearCookie login;
56 redirect M.afterLogout 76 redirect M.afterLogout
77
78 fun signupDetails after =
79 let
80 fun finishSignup uid data =
81 if not (validUser uid) then
82 return (Some "That username is not valid. It must be between 1 and 19 characters long, containing only letters and numbers.")
83 else
84 used <- oneRowE1 (SELECT COUNT( * ) > 0
85 FROM user
86 WHERE user.Id = {[uid]});
87 if used then
88 return (Some "That username is taken. Please choose another.")
89 else
90 ses <- getCookie signingUp;
91 case ses of
92 None => return (Some "Missing session cookie")
93 | Some ses =>
94 ident <- oneOrNoRowsE1 (SELECT (session.Identifier)
95 FROM session
96 WHERE session.Id = {[ses.Session]}
97 AND session.Key = {[ses.Key]});
98 case ident of
99 None => return (Some "Invalid session data")
100 | Some None => return (Some "Session has no associated identifier")
101 | Some (Some ident) =>
102 clearCookie signingUp;
103 setCookie login {Value = {User = uid} ++ ses,
104 Expires = None,
105 Secure = M.secureCookies};
106
107 cols <- M.choose user data;
108 dml (insert user ({Id = (SQL {[uid]})} ++ @Sql.sqexps M.folder M.inj cols));
109 dml (INSERT INTO identity (User, Identifier)
110 VALUES ({[uid]}, {[ident]}));
111 redirect (bless after)
112 in
113 uid <- source "";
114 cs <- M.creationState;
115
116 wrap "Your User Details" <xml>
117 <table class={M.formClass}>
118 <tr> <th class={M.formClass}>Username:</th> <td><ctextbox source={uid}/></td> </tr>
119 {M.render cs}
120 <tr> <td><button value="Create Account" onclick={uid <- get uid;
121 data <- Basis.current (M.tabulate cs);
122 res <- rpc (finishSignup uid data);
123 case res of
124 None => redirect (bless after)
125 | Some msg => alert msg}/></td> </tr>
126 </table>
127 </xml>
128 end
57 129
58 fun opCallback after ses res = 130 fun opCallback after ses res =
59 case res of 131 case res of
60 Openid.Canceled => error <xml>You canceled the login process.</xml> 132 Openid.Canceled => error <xml>You canceled the login process.</xml>
61 | Openid.Failure s => error <xml>Login failed: {[s]}</xml> 133 | Openid.Failure s => error <xml>Login failed: {[s]}</xml>
71 WHERE session.Id = {[signup.Session]} 143 WHERE session.Id = {[signup.Session]}
72 AND session.Key = {[signup.Key]}); 144 AND session.Key = {[signup.Key]});
73 if invalid then 145 if invalid then
74 error <xml>Invalid or expired session</xml> 146 error <xml>Invalid or expired session</xml>
75 else 147 else
76 return <xml>I now believe that you are {[ident]}.</xml> 148 dml (UPDATE session
149 SET Identifier = {[Some ident]}
150 WHERE Id = {[signup.Session]});
151 signupDetails after
77 | None => 152 | None =>
78 login <- getCookie login; 153 login <- getCookie login;
79 case login of 154 case login of
80 None => error <xml>Missing session cookie</xml> 155 None => error <xml>Missing session cookie</xml>
81 | Some login => 156 | Some login =>
89 if invalid then 164 if invalid then
90 error <xml>Invalid or expired session</xml> 165 error <xml>Invalid or expired session</xml>
91 else 166 else
92 dml (UPDATE session 167 dml (UPDATE session
93 SET Identifier = {[Some ident]} 168 SET Identifier = {[Some ident]}
94 WHERE Key = {[login.Key]}); 169 WHERE Id = {[login.Session]});
95 redirect (bless after) 170 redirect (bless after)
96 171
97 fun newSession () = 172 fun newSession () =
98 ses <- nextval sessionIds; 173 ses <- nextval sessionIds;
99 now <- now; 174 now <- now;
100 key <- rand; 175 key <- rand;
101 dml (INSERT INTO session (Id, Key, Identifier, Expires) 176 dml (INSERT INTO session (Id, Key, Identifier, Expires)
102 VALUES ({[ses]}, {[key]}, NULL, {[addSeconds now M.sessionLifetime]})); 177 VALUES ({[ses]}, {[key]}, NULL, {[addSeconds now M.sessionLifetime]}));
103 return {Session = ses, Key = key} 178 return {Session = ses, Key = key}
104 179
105 fun logon r = 180 fun logon after r =
106 ident <- oneOrNoRowsE1 (SELECT (identity.Identifier) 181 ident <- oneOrNoRowsE1 (SELECT (identity.Identifier)
107 FROM identity 182 FROM identity
108 WHERE identity.User = {[r.User]} 183 WHERE identity.User = {[r.User]}
109 LIMIT 1); 184 LIMIT 1);
110 case ident of 185 case ident of
112 | Some ident => 187 | Some ident =>
113 ses <- newSession (); 188 ses <- newSession ();
114 setCookie login {Value = r ++ ses, 189 setCookie login {Value = r ++ ses,
115 Expires = None, 190 Expires = None,
116 Secure = M.secureCookies}; 191 Secure = M.secureCookies};
117 after <- currentUrl;
118 after <- return (show after);
119 ses <- return ses.Session; 192 ses <- return ses.Session;
120 msg <- Openid.authenticate (opCallback after ses) 193 msg <- Openid.authenticate (opCallback after ses)
121 {Association = M.association, 194 {Association = M.association,
122 Realm = M.realm, 195 Realm = M.realm,
123 Identifier = ident}; 196 Identifier = ident};
143 <submit value="Sign Up" action={doSignup (show after)}/> 216 <submit value="Sign Up" action={doSignup (show after)}/>
144 </form> 217 </form>
145 </xml> 218 </xml>
146 in 219 in
147 cur <- current; 220 cur <- current;
221 here <- currentUrl;
148 case cur of 222 case cur of
149 Some cur => return <xml>Logged in as {[cur]}. <a link={logout ()}>[Log out]</a></xml> 223 Some cur => return <xml>Logged in as {[cur]}. <a link={logout ()}>[Log out]</a></xml>
150 | None => return <xml> 224 | None => return <xml>
151 <form><textbox{#User}/> <submit value="Log In" action={logon}/></form> 225 <form><textbox{#User}/> <submit value="Log In" action={logon (show here)}/></form>
152 <a link={signup ()}>Sign up</a> 226 <a link={signup ()}>Sign up</a>
153 </xml> 227 </xml>
154 end 228 end
155 229
156 task periodic 60 = fn () => dml (DELETE FROM session 230 task periodic 60 = fn () => dml (DELETE FROM session