Mercurial > openid

annotate src/ur/openidUser.ur @ 45:c39c3f63854a

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