Mercurial > openid
view src/ur/openidUser.ur @ 64:81632203928f
Fix 'hidden' constraint
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Wed, 11 Dec 2013 17:11:32 -0500 |
| parents | 089ad1d33e2f |
| children |
line wrap: on
line source
style provider style aol style google style myspace style yahoo datatype choose_result a = Success of a | Failure of string signature CTLDISPLAY = sig val formatUser : xbody -> xbody val formatLogout : ($([]) -> transaction page) -> xbody val formatSignup : url -> xbody val formatLogon : ({User : string} -> transaction page) -> xbody end structure DefaultDisplay : CTLDISPLAY = struct fun formatUser user = <xml>You are logged in as {user}.</xml> fun formatLogout handler = <xml> <form><submit value="Logout" action={handler}/></form> </xml> fun formatSignup url = <xml><a href={url}>Sign Up</a></xml> fun formatLogon handler = <xml> <form><textbox{#User}/><submit value="Log In" action={handler}/></form> </xml> end functor Make(M: sig con cols :: {Type} constraint [Id] ~ cols val folder : folder cols val inj : $(map sql_injectable cols) type creationState type creationData val creationState : transaction creationState val render : creationState -> xtable val ready : creationState -> signal bool val tabulate : creationState -> signal creationData val choose : sql_table ([Id = string] ++ cols) [Pkey = [Id]] -> creationData -> transaction (choose_result $cols) val sessionLifetime : int val afterLogout : url val secureCookies : bool val association : Openid.association_mode val realm : option string val formClass : css_class val fakeId : option string structure CtlDisplay : CTLDISPLAY end) = struct type user = string val eq_user = _ val read_user = _ val show_user = _ val inj_user = _ table user : ([Id = user] ++ M.cols) PRIMARY KEY Id con user_hidden_constraints = [] constraint [Pkey = [Id]] ~ user_hidden_constraints table identity : {User : user, Identifier : string} PRIMARY KEY (User, Identifier) sequence sessionIds table session : {Id : int, Key : int, Identifier : option string, Expires : time} PRIMARY KEY Id datatype authMode = SigningUp of {Session : int, Key : int} | LoggedIn of {User : user, Session : int, Key : int} cookie auth : authMode val currentUrl = b <- currentUrlHasPost; if b then return M.afterLogout else b <- currentUrlHasQueryString; if b then return M.afterLogout else currentUrl val wrongUser = return <xml><body> 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>. </body></xml> fun current' tweakSession = login <- getCookie auth; case login of Some (LoggedIn login) => (ident <- oneOrNoRowsE1 (SELECT (session.Identifier) FROM session WHERE session.Id = {[login.Session]} AND session.Key = {[login.Key]}); case ident of None => return None | Some None => return None | Some (Some ident) => valid <- oneRowE1 (SELECT COUNT( * ) > 0 FROM identity WHERE identity.User = {[login.User]} AND identity.Identifier = {[ident]}); if valid then tweakSession login.Session; return (Some login.User) else clearCookie auth; redirect (url wrongUser)) | _ => return None val current = current' (fn _ => return ()) val renew = current' (fn id => now <- now; dml (UPDATE session SET Expires = {[addSeconds now M.sessionLifetime]} WHERE Id = {[id]})) fun validUser s = String.length s > 0 && String.length s < 20 && String.all Char.isAlnum s fun main wrap = let fun logout () = login <- getCookie auth; clearCookie auth; (case login of Some (LoggedIn login) => dml (DELETE FROM session WHERE Id = {[login.Session]} AND Key = {[login.Key]}) | _ => return ()); redirect M.afterLogout fun newSession identO = ses <- nextval sessionIds; now <- now; key <- rand; dml (INSERT INTO session (Id, Key, Identifier, Expires) VALUES ({[ses]}, {[key]}, {[identO]}, {[addSeconds now M.sessionLifetime]})); return {Session = ses, Key = key} fun signupDetails after = let fun finishSignup uid data = if not (validUser uid) then return (Some "That username is not valid. It must be between 1 and 19 characters long, containing only letters and numbers.") else used <- oneRowE1 (SELECT COUNT( * ) > 0 FROM user WHERE user.Id = {[uid]}); if used then return (Some "That username is taken. Please choose another.") else ses <- getCookie auth; case ses of None => return (Some "Missing session cookie") | Some (LoggedIn _) => return (Some "Session cookie is for already logged-in user") | Some (SigningUp ses) => ident <- oneOrNoRowsE1 (SELECT (session.Identifier) FROM session WHERE session.Id = {[ses.Session]} AND session.Key = {[ses.Key]}); case ident of None => return (Some "Invalid session data") | Some None => return (Some "Session has no associated identifier") | Some (Some ident) => cols <- M.choose user data; case cols of Failure s => return (Some s) | Success cols => dml (DELETE FROM session WHERE Id = {[ses.Session]}); ses <- newSession (Some ident); setCookie auth {Value = LoggedIn ({User = uid} ++ ses), Expires = None, Secure = M.secureCookies}; dml (insert user ({Id = (SQL {[uid]})} ++ @Sql.sqexps M.folder M.inj cols)); dml (INSERT INTO identity (User, Identifier) VALUES ({[uid]}, {[ident]})); return None in uid <- source ""; cs <- M.creationState; wrap "Your User Details" <xml> <table class={M.formClass}> <tr> <th class={M.formClass}>Username:</th> <td><ctextbox source={uid}/></td> </tr> {M.render cs} <tr> <td><dyn signal={b <- M.ready cs; return (if b then <xml><button value="Create Account" onclick={fn _ => uid <- get uid; data <- Basis.current (M.tabulate cs); res <- rpc (finishSignup uid data); case res of None => redirect (bless after) | Some msg => alert msg}/></xml> else <xml/>)}/></td> </tr> </table> </xml> end fun opCallback after ses res = case res of Openid.Canceled => error <xml>You canceled the login process.</xml> | Openid.Failure s => error <xml>Login failed: {[s]}</xml> | Openid.AuthenticatedAs ident => av <- getCookie auth; case av of Some (SigningUp signup) => if signup.Session <> ses then error <xml>Session has changed suspiciously</xml> else invalid <- oneRowE1 (SELECT COUNT( * ) = 0 FROM session WHERE session.Id = {[signup.Session]} AND session.Key = {[signup.Key]}); if invalid then error <xml>Invalid or expired session</xml> else dml (DELETE FROM session WHERE Id = {[signup.Session]}); ses <- newSession (Some ident); setCookie auth {Value = SigningUp ses, Expires = None, Secure = M.secureCookies}; signupDetails after | Some (LoggedIn login) => if login.Session <> ses then error <xml>Session has changed suspiciously</xml> else invalid <- oneRowE1 (SELECT COUNT( * ) = 0 FROM session WHERE session.Id = {[login.Session]} AND session.Key = {[login.Key]}); if invalid then error <xml>Invalid or expired session</xml> else dml (DELETE FROM session WHERE Id = {[login.Session]}); ses <- newSession (Some ident); setCookie auth {Value = LoggedIn ({User = login.User} ++ ses), Expires = None, Secure = M.secureCookies}; redirect (bless after) | None => error <xml>Missing session cookie</xml> fun fakeCallback ident after ses = av <- getCookie auth; case av of Some (SigningUp signup) => invalid <- oneRowE1 (SELECT COUNT( * ) = 0 FROM session WHERE session.Id = {[signup.Session]} AND session.Key = {[signup.Key]}); if invalid then error <xml>Invalid or expired session</xml> else dml (UPDATE session SET Identifier = {[Some ident]} WHERE Id = {[signup.Session]}); signupDetails after | Some (LoggedIn login) => invalid <- oneRowE1 (SELECT COUNT( * ) = 0 FROM session WHERE session.Id = {[login.Session]} AND session.Key = {[login.Key]}); if invalid then error <xml>Invalid or expired session</xml> else dml (UPDATE session SET Identifier = {[Some ident]} WHERE Id = {[login.Session]}); redirect (bless after) | None => error <xml>Missing session cookie</xml> fun logon after r = ident <- oneOrNoRowsE1 (SELECT (identity.Identifier) FROM identity WHERE identity.User = {[r.User]} LIMIT 1); case ident of None => error <xml>Username not found</xml> | Some ident => ses <- newSession None; setCookie auth {Value = LoggedIn (r ++ ses), Expires = None, Secure = M.secureCookies}; ses <- return ses.Session; if M.fakeId = Some ident then fakeCallback ident after ses else msg <- Openid.authenticate (opCallback after ses) {Association = M.association, Realm = M.realm, Identifier = Openid.KnownIdentifier ident}; error <xml>Login with your identity provider failed: {[msg]}</xml> fun doSignup after r = ses <- newSession None; setCookie auth {Value = SigningUp ses, Expires = None, Secure = M.secureCookies}; ses <- return ses.Session; if M.fakeId = Some r.Identifier then fakeCallback r.Identifier after ses else msg <- Openid.authenticate (opCallback after ses) {Association = M.association, Realm = M.realm, Identifier = Openid.ChooseIdentifier r.Identifier}; error <xml>Login with your identity provider failed: {[msg]}</xml> fun signup after = let fun fixed cls url = let fun doFixedButton () = doSignup after {Identifier = url} in <xml><form class={provider}> <submit class={cls} value="" action={doFixedButton}/> </form></xml> end in wrap "Account Signup" <xml> <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> <p>You may click one of these buttons to choose to use your account from that site:</p> {fixed aol "https://openid.aol.com/"} {fixed google "https://www.google.com/accounts/o8/id"} {fixed myspace "https://www.myspace.com/openid"} {fixed yahoo "https://me.yahoo.com/"} <p>Visitors familiar with the details of OpenID may also enter their own identifiers:</p> <form> OpenID Identifier: <textbox{#Identifier}/><br/> <submit value="Sign Up" action={doSignup after}/> </form> </xml> end in cur <- current; here <- currentUrl; case cur of Some cur => return {Status = (M.CtlDisplay.formatUser <xml>{[cur]}</xml>), Other = {Url = None, Xml = (M.CtlDisplay.formatLogout logout)}} | None => return {Status = (M.CtlDisplay.formatLogon (logon (show here))), Other = {Url = Some (url (signup (show here))), Xml = (M.CtlDisplay.formatSignup (url (signup (show here))))}} end task periodic 60 = fn () => dml (DELETE FROM session WHERE Expires < CURRENT_TIMESTAMP) end