# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1294336093 18000
# Node ID 9851bc87b0d7b1dbcbe7f1186cb8e0289ac6ed4b
# Parent  35bc4da563dd400a5ed496348c31fb6fa2fa62f4
Beginning of OpenidUser

diff -r 35bc4da563dd -r 9851bc87b0d7 src/ur/lib.urp
--- a/src/ur/lib.urp	Sun Jan 02 11:22:30 2011 -0500
+++ b/src/ur/lib.urp	Thu Jan 06 12:48:13 2011 -0500
@@ -14,3 +14,4 @@
 $/option
 $/list
 openid
+openidUser
diff -r 35bc4da563dd -r 9851bc87b0d7 src/ur/openidUser.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/ur/openidUser.ur	Thu Jan 06 12:48:13 2011 -0500
@@ -0,0 +1,159 @@
+functor Make(M: sig
+                 con cols :: {Type}
+                 constraint [Id] ~ cols
+
+                 val sessionLifetime : int
+                 val afterLogout : url
+                 val secureCookies : bool
+                 val association : Openid.association_mode
+                 val realm : option string
+             end) = struct
+
+    type user = string
+    val show_user = _
+    val inj_user = _
+
+    table user : ([Id = user] ++ M.cols)
+      PRIMARY KEY Id
+
+    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
+
+    cookie signingUp : {Session : int, Key : int}
+    cookie login : {User : user, Session : int, Key : int}
+
+    val current =
+        login <- getCookie login;
+        case login of
+            None => return None
+          | Some login =>
+            ident <- oneOrNoRowsE1 (SELECT (session.Identifier)
+                                    FROM session
+                                    WHERE session.Id = {[login.Session]}
+                                      AND session.Key = {[login.Key]});
+            case ident of
+                None => error <xml>Invalid or expired session</xml>
+              | 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
+                    return (Some login.User)
+                else
+                    error <xml>Session not authorized to act as user</xml>
+
+    fun main wrap =
+        let
+            fun logout () =
+                clearCookie login;
+                redirect M.afterLogout
+
+            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 =>
+                    signup <- getCookie signingUp;
+                    case signup of
+                        Some 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
+                                return <xml>I now believe that you are {[ident]}.</xml>
+                      | None =>
+                        login <- getCookie login;
+                        case login of
+                            None => error <xml>Missing session cookie</xml>
+                          | Some 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 (UPDATE session
+                                         SET Identifier = {[Some ident]}
+                                         WHERE Key = {[login.Key]});
+                                    redirect (bless after)
+
+            fun newSession () =
+                ses <- nextval sessionIds;
+                now <- now;
+                key <- rand;
+                dml (INSERT INTO session (Id, Key, Identifier, Expires)
+                     VALUES ({[ses]}, {[key]}, NULL, {[addSeconds now M.sessionLifetime]}));
+                return {Session = ses, Key = key}
+
+            fun logon 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 ();
+                    setCookie login {Value = r ++ ses,
+                                     Expires = None,
+                                     Secure = M.secureCookies};
+                    after <- currentUrl;
+                    after <- return (show after);
+                    ses <- return ses.Session;
+                    msg <- Openid.authenticate (opCallback after ses)
+                           {Association = M.association,
+                            Realm = M.realm,
+                            Identifier = ident};
+                    error <xml>Login with your identity provider failed: {[msg]}</xml>
+
+            fun doSignup after r =
+                ses <- newSession ();
+                setCookie signingUp {Value = ses,
+                                     Expires = None,
+                                     Secure = M.secureCookies};
+                ses <- return ses.Session;
+                msg <- Openid.authenticate (opCallback after ses)
+                                           {Association = M.association,
+                                            Realm = M.realm,
+                                            Identifier = r.Identifier};
+                error <xml>Login with your identity provider failed: {[msg]}</xml>
+
+            fun signup () =
+                after <- currentUrl;
+                wrap "Account Signup" <xml>
+                  <form>
+                    OpenID Identifier: <textbox{#Identifier}/><br/>
+                    <submit value="Sign Up" action={doSignup (show after)}/>
+                  </form>
+                </xml>
+        in
+            cur <- current;
+            case cur of
+                Some cur => return <xml>Logged in as {[cur]}. <a link={logout ()}>[Log out]</a></xml>
+              | None => return <xml>
+                <form><textbox{#User}/> <submit value="Log In" action={logon}/></form>
+                <a link={signup ()}>Sign up</a>
+              </xml>
+        end
+
+    task periodic 60 = fn () => dml (DELETE FROM session
+                                     WHERE Expires >= CURRENT_TIMESTAMP)
+
+end
diff -r 35bc4da563dd -r 9851bc87b0d7 src/ur/openidUser.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/ur/openidUser.urs	Thu Jan 06 12:48:13 2011 -0500
@@ -0,0 +1,34 @@
+functor Make(M: sig
+                 con cols :: {Type}
+                 constraint [Id] ~ cols
+                 (* Extra columns to add to the user database table *)
+
+                 val sessionLifetime : int
+                 (* Number of seconds a session may live *)
+
+                 val afterLogout : url
+                 (* Where to send the user after he logs out *)
+
+                 val secureCookies : bool
+                 (* Should authentication cookies be restricted to SSL connections? *)
+
+                 val association : Openid.association_mode
+                 (* OpenID cryptography preferences *)
+
+                 val realm : option string
+                 (* See end of [Openid] module's documentation for the meaning of realms *)
+             end) : sig
+
+    type user
+    val show_user : show user
+    val inj_user : sql_injectable_prim user
+
+    table user : ([Id = user] ++ M.cols)
+      PRIMARY KEY Id
+
+    val current : transaction (option user)
+
+    val main : (string -> xbody -> transaction page) -> transaction xbody
+    (* Pass in your generic page template; get out the HTML snippet for user management *)
+
+end