Mercurial > openid

annotate src/ur/openidUser.ur @ 58:9f392276d614

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