Mercurial > openid

annotate src/ur/openidUser.ur @ 27:f129ddee75f3

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