Mercurial > openid

annotate src/ur/openidUser.ur @ 64:81632203928f

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