Mercurial > openid
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