adam@26: style provider adam@26: adam@26: style aol adam@26: style google adam@26: style myspace adam@26: style yahoo adam@26: adam@28: datatype choose_result a = Success of a | Failure of string adam@28: kkallio@35: signature CTLDISPLAY = sig kkallio@35: val formatUser : xbody -> xbody greenrd@48: val formatLogout : ($([]) -> transaction page) -> xbody kkallio@35: val formatSignup : url -> xbody kkallio@35: val formatLogon : ({User : string} -> transaction page) -> xbody kkallio@35: end kkallio@35: kkallio@35: structure DefaultDisplay : CTLDISPLAY = struct kkallio@35: fun formatUser user = adam@37: You are logged in as {user}. kkallio@35: greenrd@48: fun formatLogout handler = greenrd@48: greenrd@48: kkallio@35: kkallio@35: fun formatSignup url = kkallio@35: Sign Up kkallio@35: kkallio@35: fun formatLogon handler = kkallio@35: kkallio@35: kkallio@35: end kkallio@35: kkallio@35: adam@16: functor Make(M: sig adam@16: con cols :: {Type} adam@16: constraint [Id] ~ cols adam@17: val folder : folder cols adam@17: val inj : $(map sql_injectable cols) adam@17: adam@17: type creationState adam@17: type creationData adam@17: val creationState : transaction creationState adam@17: val render : creationState -> xtable adam@20: val ready : creationState -> signal bool adam@17: val tabulate : creationState -> signal creationData adam@28: val choose : sql_table ([Id = string] ++ cols) [Pkey = [Id]] -> creationData -> transaction (choose_result $cols) adam@16: adam@16: val sessionLifetime : int adam@16: val afterLogout : url adam@16: val secureCookies : bool adam@16: val association : Openid.association_mode adam@16: val realm : option string adam@17: val formClass : css_class adam@23: val fakeId : option string kkallio@31: kkallio@35: structure CtlDisplay : CTLDISPLAY adam@16: end) = struct adam@16: adam@16: type user = string adam@28: val eq_user = _ adam@28: val read_user = _ adam@16: val show_user = _ adam@16: val inj_user = _ adam@16: adam@16: table user : ([Id = user] ++ M.cols) adam@16: PRIMARY KEY Id adam@16: adam@16: table identity : {User : user, Identifier : string} adam@16: PRIMARY KEY (User, Identifier) adam@16: adam@16: sequence sessionIds adam@16: adam@16: table session : {Id : int, Key : int, Identifier : option string, Expires : time} adam@16: PRIMARY KEY Id adam@16: adam@22: datatype authMode = adam@22: SigningUp of {Session : int, Key : int} adam@22: | LoggedIn of {User : user, Session : int, Key : int} adam@22: adam@22: cookie auth : authMode adam@16: adam@17: val currentUrl = adam@17: b <- currentUrlHasPost; adam@17: if b then adam@17: return M.afterLogout adam@17: else adam@45: b <- currentUrlHasQueryString; adam@45: if b then adam@45: return M.afterLogout adam@45: else adam@45: currentUrl adam@17: adam@58: val wrongUser = adam@59: return adam@59: Username mismatch! Did your OpenID provider log you in as a different user than you expected? Try logging out at your provider first, then return to the home page. adam@59: adam@58: adam@50: fun current' tweakSession = adam@22: login <- getCookie auth; adam@16: case login of adam@22: Some (LoggedIn login) => adam@22: (ident <- oneOrNoRowsE1 (SELECT (session.Identifier) adam@22: FROM session adam@22: WHERE session.Id = {[login.Session]} adam@22: AND session.Key = {[login.Key]}); adam@22: case ident of adam@22: None => return None adam@22: | Some None => return None adam@22: | Some (Some ident) => adam@22: valid <- oneRowE1 (SELECT COUNT( * ) > 0 adam@22: FROM identity adam@22: WHERE identity.User = {[login.User]} adam@22: AND identity.Identifier = {[ident]}); adam@22: if valid then adam@50: tweakSession login.Session; adam@22: return (Some login.User) adam@22: else adam@58: clearCookie auth; adam@58: redirect (url wrongUser)) adam@22: | _ => return None adam@16: adam@50: val current = current' (fn _ => return ()) adam@50: adam@50: val renew = current' (fn id => adam@50: now <- now; adam@50: dml (UPDATE session adam@50: SET Expires = {[addSeconds now M.sessionLifetime]} adam@50: WHERE Id = {[id]})) adam@50: adam@17: fun validUser s = String.length s > 0 && String.length s < 20 adam@17: && String.all Char.isAlnum s adam@17: adam@16: fun main wrap = adam@16: let adam@16: fun logout () = greenrd@48: login <- getCookie auth; adam@22: clearCookie auth; greenrd@48: (case login of greenrd@48: Some (LoggedIn login) => greenrd@48: dml (DELETE FROM session adam@51: WHERE Id = {[login.Session]} adam@51: AND Key = {[login.Key]}) greenrd@48: | _ => return ()); adam@16: redirect M.afterLogout adam@16: adam@46: fun newSession identO = adam@46: ses <- nextval sessionIds; adam@46: now <- now; adam@46: key <- rand; adam@46: dml (INSERT INTO session (Id, Key, Identifier, Expires) adam@46: VALUES ({[ses]}, {[key]}, {[identO]}, {[addSeconds now M.sessionLifetime]})); adam@46: return {Session = ses, Key = key} adam@46: adam@17: fun signupDetails after = adam@17: let adam@17: fun finishSignup uid data = adam@17: if not (validUser uid) then adam@17: return (Some "That username is not valid. It must be between 1 and 19 characters long, containing only letters and numbers.") adam@17: else adam@17: used <- oneRowE1 (SELECT COUNT( * ) > 0 adam@17: FROM user adam@17: WHERE user.Id = {[uid]}); adam@17: if used then adam@17: return (Some "That username is taken. Please choose another.") adam@17: else adam@22: ses <- getCookie auth; adam@17: case ses of adam@17: None => return (Some "Missing session cookie") adam@22: | Some (LoggedIn _) => return (Some "Session cookie is for already logged-in user") adam@22: | Some (SigningUp ses) => adam@17: ident <- oneOrNoRowsE1 (SELECT (session.Identifier) adam@17: FROM session adam@17: WHERE session.Id = {[ses.Session]} adam@17: AND session.Key = {[ses.Key]}); adam@17: case ident of adam@17: None => return (Some "Invalid session data") adam@17: | Some None => return (Some "Session has no associated identifier") adam@17: | Some (Some ident) => adam@28: cols <- M.choose user data; adam@28: case cols of adam@28: Failure s => return (Some s) adam@28: | Success cols => adam@46: dml (DELETE FROM session adam@46: WHERE Id = {[ses.Session]}); adam@46: ses <- newSession (Some ident); adam@28: setCookie auth {Value = LoggedIn ({User = uid} ++ ses), adam@28: Expires = None, adam@28: Secure = M.secureCookies}; adam@17: adam@28: dml (insert user ({Id = (SQL {[uid]})} ++ @Sql.sqexps M.folder M.inj cols)); adam@28: dml (INSERT INTO identity (User, Identifier) adam@28: VALUES ({[uid]}, {[ident]})); adam@30: return None adam@17: in adam@17: uid <- source ""; adam@17: cs <- M.creationState; adam@17: adam@17: wrap "Your User Details" adam@17: adam@17: adam@17: {M.render cs} adam@20: adam@17:

Username:

adam@17: adam@17: end adam@17: adam@16: fun opCallback after ses res = adam@16: case res of adam@16: Openid.Canceled => error You canceled the login process. adam@16: | Openid.Failure s => error Login failed: {[s]} adam@16: | Openid.AuthenticatedAs ident => adam@22: av <- getCookie auth; adam@22: case av of adam@22: Some (SigningUp signup) => adam@16: if signup.Session <> ses then adam@16: error Session has changed suspiciously adam@16: else adam@16: invalid <- oneRowE1 (SELECT COUNT( * ) = 0 adam@16: FROM session adam@16: WHERE session.Id = {[signup.Session]} adam@16: AND session.Key = {[signup.Key]}); adam@16: if invalid then adam@16: error Invalid or expired session adam@16: else adam@46: dml (DELETE FROM session adam@17: WHERE Id = {[signup.Session]}); adam@46: ses <- newSession (Some ident); adam@46: setCookie auth {Value = SigningUp ses, adam@46: Expires = None, adam@46: Secure = M.secureCookies}; adam@17: signupDetails after adam@22: | Some (LoggedIn login) => adam@22: if login.Session <> ses then adam@22: error Session has changed suspiciously adam@22: else adam@22: invalid <- oneRowE1 (SELECT COUNT( * ) = 0 adam@22: FROM session adam@22: WHERE session.Id = {[login.Session]} adam@22: AND session.Key = {[login.Key]}); adam@22: if invalid then adam@22: error Invalid or expired session adam@16: else adam@46: dml (DELETE FROM session adam@22: WHERE Id = {[login.Session]}); adam@46: ses <- newSession (Some ident); adam@46: setCookie auth {Value = LoggedIn ({User = login.User} ++ ses), adam@46: Expires = None, adam@46: Secure = M.secureCookies}; adam@22: redirect (bless after) adam@22: | None => error Missing session cookie adam@16: adam@23: fun fakeCallback ident after ses = adam@23: av <- getCookie auth; adam@23: case av of adam@23: Some (SigningUp signup) => adam@23: invalid <- oneRowE1 (SELECT COUNT( * ) = 0 adam@23: FROM session adam@23: WHERE session.Id = {[signup.Session]} adam@23: AND session.Key = {[signup.Key]}); adam@23: if invalid then adam@23: error Invalid or expired session adam@23: else adam@23: dml (UPDATE session adam@23: SET Identifier = {[Some ident]} adam@23: WHERE Id = {[signup.Session]}); adam@23: signupDetails after adam@23: | Some (LoggedIn login) => adam@23: invalid <- oneRowE1 (SELECT COUNT( * ) = 0 adam@23: FROM session adam@23: WHERE session.Id = {[login.Session]} adam@23: AND session.Key = {[login.Key]}); adam@23: if invalid then adam@23: error Invalid or expired session adam@23: else adam@23: dml (UPDATE session adam@23: SET Identifier = {[Some ident]} adam@23: WHERE Id = {[login.Session]}); adam@23: redirect (bless after) adam@23: | None => error Missing session cookie adam@23: adam@17: fun logon after r = adam@16: ident <- oneOrNoRowsE1 (SELECT (identity.Identifier) adam@16: FROM identity adam@16: WHERE identity.User = {[r.User]} adam@16: LIMIT 1); adam@16: case ident of adam@16: None => error Username not found adam@16: | Some ident => adam@46: ses <- newSession None; adam@22: setCookie auth {Value = LoggedIn (r ++ ses), adam@22: Expires = None, adam@22: Secure = M.secureCookies}; adam@16: ses <- return ses.Session; adam@23: if M.fakeId = Some ident then adam@23: fakeCallback ident after ses adam@23: else adam@23: msg <- Openid.authenticate (opCallback after ses) adam@23: {Association = M.association, adam@23: Realm = M.realm, adam@39: Identifier = Openid.KnownIdentifier ident}; adam@23: error Login with your identity provider failed: {[msg]} adam@16: adam@16: fun doSignup after r = adam@46: ses <- newSession None; adam@22: setCookie auth {Value = SigningUp ses, adam@22: Expires = None, adam@22: Secure = M.secureCookies}; adam@16: ses <- return ses.Session; adam@23: if M.fakeId = Some r.Identifier then adam@23: fakeCallback r.Identifier after ses adam@23: else adam@23: msg <- Openid.authenticate (opCallback after ses) adam@23: {Association = M.association, adam@23: Realm = M.realm, adam@39: Identifier = Openid.ChooseIdentifier r.Identifier}; adam@23: error Login with your identity provider failed: {[msg]} adam@16: adam@22: fun signup after = adam@26: let adam@27: fun fixed cls url = adam@26: let adam@26: fun doFixedButton () = adam@26: doSignup after {Identifier = url} adam@26: in adam@26: adam@26: end adam@26: in adam@26: wrap "Account Signup" adam@26:

This web site uses the OpenID standard, which lets you log in using your account from one of several popular web sites, without revealing your password to us.

adam@26: adam@26:

You may click one of these buttons to choose to use your account from that site:

adam@27: {fixed aol "https://openid.aol.com/"} adam@27: {fixed google "https://www.google.com/accounts/o8/id"} adam@27: {fixed myspace "https://www.myspace.com/openid"} adam@27: {fixed yahoo "https://me.yahoo.com/"} adam@26: adam@26:

Visitors familiar with the details of OpenID may also enter their own identifiers:

adam@26: adam@26: end adam@16: in adam@16: cur <- current; adam@17: here <- currentUrl; kkallio@35: adam@16: case cur of kkallio@35: Some cur => return {Status = (M.CtlDisplay.formatUser {[cur]}), greenrd@48: Other = {Url = None, greenrd@48: Xml = (M.CtlDisplay.formatLogout logout)}} kkallio@35: | None => return {Status = (M.CtlDisplay.formatLogon (logon (show here))), greenrd@48: Other = {Url = Some (url (signup (show here))), kkallio@35: Xml = (M.CtlDisplay.formatSignup (url (signup (show here))))}} adam@16: end adam@16: adam@16: task periodic 60 = fn () => dml (DELETE FROM session adam@21: WHERE Expires < CURRENT_TIMESTAMP) adam@16: adam@16: end