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:         <xml>You are logged in as {user}.</xml>
kkallio@35: 
greenrd@48:     fun formatLogout handler =
greenrd@48:         <xml>
greenrd@48: 	  <form><submit value="Logout" action={handler}/></form>
greenrd@48: 	</xml>
kkallio@35: 
kkallio@35:     fun formatSignup url =
kkallio@35:         <xml><a href={url}>Sign Up</a></xml>
kkallio@35: 
kkallio@35:     fun formatLogon handler =
kkallio@35:         <xml>
kkallio@35:           <form><textbox{#User}/><submit value="Log In" action={handler}/></form>
kkallio@35:         </xml>
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@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@22:                      error <xml>Session not authorized to act as user</xml>)
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" <xml>
adam@17:                       <table class={M.formClass}>
adam@17:                         <tr> <th class={M.formClass}>Username:</th> <td><ctextbox source={uid}/></td> </tr>
adam@17:                         {M.render cs}
adam@20:                         <tr> <td><dyn signal={b <- M.ready cs;
adam@20:                                               return (if b then
adam@20:                                                           <xml><button value="Create Account"
adam@20:                                                                        onclick={uid <- get uid;
adam@20:                                                                                 data <- Basis.current (M.tabulate cs);
adam@20:                                                                                 res <- rpc (finishSignup uid data);
adam@20:                                                                                 case res of
adam@20:                                                                                     None => redirect (bless after)
adam@20:                                                                                   | Some msg => alert msg}/></xml>
adam@20:                                                       else
adam@20:                                                           <xml/>)}/></td> </tr>
adam@17:                       </table>
adam@17:                     </xml>
adam@17:                 end
adam@17: 
adam@16:             fun opCallback after ses res =
adam@16:                 case res of
adam@16:                     Openid.Canceled => error <xml>You canceled the login process.</xml>
adam@16:                   | Openid.Failure s => error <xml>Login failed: {[s]}</xml>
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 <xml>Session has changed suspiciously</xml>
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 <xml>Invalid or expired session</xml>
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 <xml>Session has changed suspiciously</xml>
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 <xml>Invalid or expired session</xml>
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 <xml>Missing session cookie</xml>
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 <xml>Invalid or expired session</xml>
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 <xml>Invalid or expired session</xml>
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 <xml>Missing session cookie</xml>
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 <xml>Username not found</xml>
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 <xml>Login with your identity provider failed: {[msg]}</xml>
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 <xml>Login with your identity provider failed: {[msg]}</xml>
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:                             <xml><form class={provider}>
adam@27:                               <submit class={cls} value="" action={doFixedButton}/>
adam@26:                             </form></xml>
adam@26:                         end
adam@26:                 in
adam@26:                     wrap "Account Signup" <xml>
adam@26:                       <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: 
adam@26:                       <p>You may click one of these buttons to choose to use your account from that site:</p>
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:                       <p>Visitors familiar with the details of OpenID may also enter their own identifiers:</p>
adam@26:                       <form>
adam@26:                         OpenID Identifier: <textbox{#Identifier}/><br/>
adam@26:                         <submit value="Sign Up" action={doSignup after}/>
adam@26:                       </form>
adam@26:                     </xml>
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 <xml>{[cur]}</xml>),
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