Mercurial > openid

annotate src/ur/openidUser.ur @ 32:90b8ce9be9f5

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