changeset 17:df2eb629f21a

Successfully created an account
author Adam Chlipala <adam@chlipala.net>
date Thu, 06 Jan 2011 14:42:37 -0500
parents 9851bc87b0d7
children dd8eb53da51b
files src/ur/lib.urp src/ur/openid.ur src/ur/openidUser.ur src/ur/openidUser.urs
diffstat 4 files changed, 102 insertions(+), 18 deletions(-) [+]
line wrap: on
line diff
--- a/src/ur/lib.urp	Thu Jan 06 12:48:13 2011 -0500
+++ b/src/ur/lib.urp	Thu Jan 06 14:42:37 2011 -0500
@@ -9,6 +9,7 @@
 effectful OpenidFfi.indirect
 effectful OpenidFfi.generate
 effectful OpenidFfi.compute
+library $META
 
 $/string
 $/option
--- a/src/ur/openid.ur	Thu Jan 06 12:48:13 2011 -0500
+++ b/src/ur/openid.ur	Thu Jan 06 14:42:37 2011 -0500
@@ -7,7 +7,13 @@
 table discoveries : { Identifier : string, Endpoint : string, Expires : time }
   PRIMARY KEY Identifier
 
+fun eatFragment s =
+    case String.split s #"#" of
+        Some (s', _) => s'
+      | _ => s
+
 fun discover s =
+    s <- return (eatFragment s);
     endpoint <- oneOrNoRowsE1 (SELECT (discoveries.Endpoint)
                                FROM discoveries
                                WHERE discoveries.Identifier = {[s]});
@@ -190,11 +196,6 @@
                 newAssociation url alt.Atype alt.Stype
           | v => return v
 
-fun eatFragment s =
-    case String.split s #"#" of
-        Some (s', _) => s'
-      | _ => s
-
 datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | NoAssociation of string | HandleError of string
 
 datatype authentication = AuthenticatedAs of string | Canceled | Failure of string
@@ -310,11 +311,6 @@
                                         HMAC_SHA256 => OpenidFfi.hmac_sha256 key nvps
                                       | HMAC_SHA1 => OpenidFfi.hmac_sha1 key nvps
                     in
-                        (*debug ("Fields: " ^ signed);
-                        debug ("Nvps: " ^ nvps);
-                        debug ("Key: " ^ key);
-                        debug ("His: " ^ sign);
-                        debug ("Mine: " ^ sign');*)
                         if sign' = sign then
                             return None
                         else
@@ -388,7 +384,8 @@
             case r.Association of
                 Stateless =>
                 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
-                                 ^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.return_to="
+                                 ^ eatFragment r.Identifier
+                                 ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.return_to="
                                  ^ show (effectfulUrl returnTo) ^ realmString))
               | Stateful ar =>
                 assoc <- association ar.AssociationType ar.AssociationSessionType dy;
@@ -397,7 +394,8 @@
                   | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
                   | Association assoc =>
                     redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
-                                     ^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
+                                     ^ eatFragment r.Identifier
+                                     ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
                                      ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString))
     end
 
--- a/src/ur/openidUser.ur	Thu Jan 06 12:48:13 2011 -0500
+++ b/src/ur/openidUser.ur	Thu Jan 06 14:42:37 2011 -0500
@@ -1,12 +1,22 @@
 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 tabulate : creationState -> signal creationData
+                 val choose : sql_table ([Id = string] ++ cols) [Pkey = [Id]] -> creationData -> transaction $cols
 
                  val sessionLifetime : int
                  val afterLogout : url
                  val secureCookies : bool
                  val association : Openid.association_mode
                  val realm : option string
+                 val formClass : css_class
              end) = struct
 
     type user = string
@@ -27,6 +37,13 @@
     cookie signingUp : {Session : int, Key : int}
     cookie login : {User : user, Session : int, Key : int}
 
+    val currentUrl =
+        b <- currentUrlHasPost;
+        if b then
+            return M.afterLogout
+        else
+            currentUrl
+
     val current =
         login <- getCookie login;
         case login of
@@ -49,12 +66,67 @@
                 else
                     error <xml>Session not authorized to act as user</xml>
 
+    fun validUser s = String.length s > 0 && String.length s < 20
+                      && String.all Char.isAlnum s
+
     fun main wrap =
         let
             fun logout () =
                 clearCookie login;
                 redirect M.afterLogout
 
+            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 signingUp;
+                                case ses of
+                                    None => return (Some "Missing session cookie")
+                                  | Some 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) =>
+                                        clearCookie signingUp;
+                                        setCookie login {Value = {User = uid} ++ ses,
+                                                         Expires = None,
+                                                         Secure = M.secureCookies};
+
+                                        cols <- M.choose user data;
+                                        dml (insert user ({Id = (SQL {[uid]})} ++ @Sql.sqexps M.folder M.inj cols));
+                                        dml (INSERT INTO identity (User, Identifier)
+                                             VALUES ({[uid]}, {[ident]}));
+                                        redirect (bless after)
+                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><button value="Create Account" onclick={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}/></td> </tr>
+                      </table>
+                    </xml>
+                end
+
             fun opCallback after ses res =
                 case res of
                     Openid.Canceled => error <xml>You canceled the login process.</xml>
@@ -73,7 +145,10 @@
                             if invalid then
                                 error <xml>Invalid or expired session</xml>
                             else
-                                return <xml>I now believe that you are {[ident]}.</xml>
+                                dml (UPDATE session
+                                     SET Identifier = {[Some ident]}
+                                     WHERE Id = {[signup.Session]});
+                                signupDetails after
                       | None =>
                         login <- getCookie login;
                         case login of
@@ -91,7 +166,7 @@
                                 else
                                     dml (UPDATE session
                                          SET Identifier = {[Some ident]}
-                                         WHERE Key = {[login.Key]});
+                                         WHERE Id = {[login.Session]});
                                     redirect (bless after)
 
             fun newSession () =
@@ -102,7 +177,7 @@
                      VALUES ({[ses]}, {[key]}, NULL, {[addSeconds now M.sessionLifetime]}));
                 return {Session = ses, Key = key}
 
-            fun logon r =
+            fun logon after r =
                 ident <- oneOrNoRowsE1 (SELECT (identity.Identifier)
                                         FROM identity
                                         WHERE identity.User = {[r.User]}
@@ -114,8 +189,6 @@
                     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,
@@ -145,10 +218,11 @@
                 </xml>
         in
             cur <- current;
+            here <- currentUrl;
             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>
+                <form><textbox{#User}/> <submit value="Log In" action={logon (show here)}/></form>
                 <a link={signup ()}>Sign up</a>
               </xml>
         end
--- a/src/ur/openidUser.urs	Thu Jan 06 12:48:13 2011 -0500
+++ b/src/ur/openidUser.urs	Thu Jan 06 14:42:37 2011 -0500
@@ -1,8 +1,17 @@
 functor Make(M: sig
                  con cols :: {Type}
                  constraint [Id] ~ cols
+                 val folder : folder cols
+                 val inj : $(map sql_injectable cols)
                  (* Extra columns to add to the user database table *)
 
+                 type creationState
+                 type creationData
+                 val creationState : transaction creationState
+                 val render : creationState -> xtable
+                 val tabulate : creationState -> signal creationData
+                 val choose : sql_table ([Id = string] ++ cols) [Pkey = [Id]] -> creationData -> transaction $cols
+
                  val sessionLifetime : int
                  (* Number of seconds a session may live *)
 
@@ -17,6 +26,8 @@
 
                  val realm : option string
                  (* See end of [Openid] module's documentation for the meaning of realms *)
+
+                 val formClass : css_class
              end) : sig
 
     type user