Mercurial > openid

annotate src/ur/openidUser.ur @ 20:2342d9baa0df

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
New OpenidUser.Make parameter: ready
author Adam Chlipala <adam@chlipala.net>
date Thu, 06 Jan 2011 16:46:09 -0500
parents dd8eb53da51b
children 354dae3008de
rev   line source
adam@16 1 functor Make(M: sig
adam@16 2 con cols :: {Type}
adam@16 3 constraint [Id] ~ cols
adam@17 4 val folder : folder cols
adam@17 5 val inj : $(map sql_injectable cols)
adam@17 6
adam@17 7 type creationState
adam@17 8 type creationData
adam@17 9 val creationState : transaction creationState
adam@17 10 val render : creationState -> xtable
adam@20 11 val ready : creationState -> signal bool
adam@17 12 val tabulate : creationState -> signal creationData
adam@17 13 val choose : sql_table ([Id = string] ++ cols) [Pkey = [Id]] -> creationData -> transaction $cols
adam@16 14
adam@16 15 val sessionLifetime : int
adam@16 16 val afterLogout : url
adam@16 17 val secureCookies : bool
adam@16 18 val association : Openid.association_mode
adam@16 19 val realm : option string
adam@17 20 val formClass : css_class
adam@16 21 end) = struct
adam@16 22
adam@16 23 type user = string
adam@16 24 val show_user = _
adam@16 25 val inj_user = _
adam@16 26
adam@16 27 table user : ([Id = user] ++ M.cols)
adam@16 28 PRIMARY KEY Id
adam@16 29
adam@16 30 table identity : {User : user, Identifier : string}
adam@16 31 PRIMARY KEY (User, Identifier)
adam@16 32
adam@16 33 sequence sessionIds
adam@16 34
adam@16 35 table session : {Id : int, Key : int, Identifier : option string, Expires : time}
adam@16 36 PRIMARY KEY Id
adam@16 37
adam@16 38 cookie signingUp : {Session : int, Key : int}
adam@16 39 cookie login : {User : user, Session : int, Key : int}
adam@16 40
adam@17 41 val currentUrl =
adam@17 42 b <- currentUrlHasPost;
adam@17 43 if b then
adam@17 44 return M.afterLogout
adam@17 45 else
adam@17 46 currentUrl
adam@17 47
adam@16 48 val current =
adam@16 49 login <- getCookie login;
adam@16 50 case login of
adam@16 51 None => return None
adam@16 52 | Some login =>
adam@16 53 ident <- oneOrNoRowsE1 (SELECT (session.Identifier)
adam@16 54 FROM session
adam@16 55 WHERE session.Id = {[login.Session]}
adam@16 56 AND session.Key = {[login.Key]});
adam@16 57 case ident of
adam@18 58 None => return None
adam@16 59 | Some None => return None
adam@16 60 | Some (Some ident) =>
adam@16 61 valid <- oneRowE1 (SELECT COUNT( * ) > 0
adam@16 62 FROM identity
adam@16 63 WHERE identity.User = {[login.User]}
adam@16 64 AND identity.Identifier = {[ident]});
adam@16 65 if valid then
adam@16 66 return (Some login.User)
adam@16 67 else
adam@16 68 error <xml>Session not authorized to act as user</xml>
adam@16 69
adam@17 70 fun validUser s = String.length s > 0 && String.length s < 20
adam@17 71 && String.all Char.isAlnum s
adam@17 72
adam@16 73 fun main wrap =
adam@16 74 let
adam@16 75 fun logout () =
adam@16 76 clearCookie login;
adam@16 77 redirect M.afterLogout
adam@16 78
adam@17 79 fun signupDetails after =
adam@17 80 let
adam@17 81 fun finishSignup uid data =
adam@17 82 if not (validUser uid) then
adam@17 83 return (Some "That username is not valid. It must be between 1 and 19 characters long, containing only letters and numbers.")
adam@17 84 else
adam@17 85 used <- oneRowE1 (SELECT COUNT( * ) > 0
adam@17 86 FROM user
adam@17 87 WHERE user.Id = {[uid]});
adam@17 88 if used then
adam@17 89 return (Some "That username is taken. Please choose another.")
adam@17 90 else
adam@17 91 ses <- getCookie signingUp;
adam@17 92 case ses of
adam@17 93 None => return (Some "Missing session cookie")
adam@17 94 | Some ses =>
adam@17 95 ident <- oneOrNoRowsE1 (SELECT (session.Identifier)
adam@17 96 FROM session
adam@17 97 WHERE session.Id = {[ses.Session]}
adam@17 98 AND session.Key = {[ses.Key]});
adam@17 99 case ident of
adam@17 100 None => return (Some "Invalid session data")
adam@17 101 | Some None => return (Some "Session has no associated identifier")
adam@17 102 | Some (Some ident) =>
adam@17 103 clearCookie signingUp;
adam@17 104 setCookie login {Value = {User = uid} ++ ses,
adam@17 105 Expires = None,
adam@17 106 Secure = M.secureCookies};
adam@17 107
adam@17 108 cols <- M.choose user data;
adam@17 109 dml (insert user ({Id = (SQL {[uid]})} ++ @Sql.sqexps M.folder M.inj cols));
adam@17 110 dml (INSERT INTO identity (User, Identifier)
adam@17 111 VALUES ({[uid]}, {[ident]}));
adam@17 112 redirect (bless after)
adam@17 113 in
adam@17 114 uid <- source "";
adam@17 115 cs <- M.creationState;
adam@17 116
adam@17 117 wrap "Your User Details" <xml>
adam@17 118 <table class={M.formClass}>
adam@17 119 <tr> <th class={M.formClass}>Username:</th> <td><ctextbox source={uid}/></td> </tr>
adam@17 120 {M.render cs}
adam@20 121 <tr> <td><dyn signal={b <- M.ready cs;
adam@20 122 return (if b then
adam@20 123 <xml><button value="Create Account"
adam@20 124 onclick={uid <- get uid;
adam@20 125 data <- Basis.current (M.tabulate cs);
adam@20 126 res <- rpc (finishSignup uid data);
adam@20 127 case res of
adam@20 128 None => redirect (bless after)
adam@20 129 | Some msg => alert msg}/></xml>
adam@20 130 else
adam@20 131 <xml/>)}/></td> </tr>
adam@17 132 </table>
adam@17 133 </xml>
adam@17 134 end
adam@17 135
adam@16 136 fun opCallback after ses res =
adam@16 137 case res of
adam@16 138 Openid.Canceled => error <xml>You canceled the login process.</xml>
adam@16 139 | Openid.Failure s => error <xml>Login failed: {[s]}</xml>
adam@16 140 | Openid.AuthenticatedAs ident =>
adam@16 141 signup <- getCookie signingUp;
adam@16 142 case signup of
adam@16 143 Some signup =>
adam@16 144 if signup.Session <> ses then
adam@16 145 error <xml>Session has changed suspiciously</xml>
adam@16 146 else
adam@16 147 invalid <- oneRowE1 (SELECT COUNT( * ) = 0
adam@16 148 FROM session
adam@16 149 WHERE session.Id = {[signup.Session]}
adam@16 150 AND session.Key = {[signup.Key]});
adam@16 151 if invalid then
adam@16 152 error <xml>Invalid or expired session</xml>
adam@16 153 else
adam@17 154 dml (UPDATE session
adam@17 155 SET Identifier = {[Some ident]}
adam@17 156 WHERE Id = {[signup.Session]});
adam@17 157 signupDetails after
adam@16 158 | None =>
adam@16 159 login <- getCookie login;
adam@16 160 case login of
adam@16 161 None => error <xml>Missing session cookie</xml>
adam@16 162 | Some login =>
adam@16 163 if login.Session <> ses then
adam@16 164 error <xml>Session has changed suspiciously</xml>
adam@16 165 else
adam@16 166 invalid <- oneRowE1 (SELECT COUNT( * ) = 0
adam@16 167 FROM session
adam@16 168 WHERE session.Id = {[login.Session]}
adam@16 169 AND session.Key = {[login.Key]});
adam@16 170 if invalid then
adam@16 171 error <xml>Invalid or expired session</xml>
adam@16 172 else
adam@16 173 dml (UPDATE session
adam@16 174 SET Identifier = {[Some ident]}
adam@17 175 WHERE Id = {[login.Session]});
adam@16 176 redirect (bless after)
adam@16 177
adam@16 178 fun newSession () =
adam@16 179 ses <- nextval sessionIds;
adam@16 180 now <- now;
adam@16 181 key <- rand;
adam@16 182 dml (INSERT INTO session (Id, Key, Identifier, Expires)
adam@16 183 VALUES ({[ses]}, {[key]}, NULL, {[addSeconds now M.sessionLifetime]}));
adam@16 184 return {Session = ses, Key = key}
adam@16 185
adam@17 186 fun logon after r =
adam@16 187 ident <- oneOrNoRowsE1 (SELECT (identity.Identifier)
adam@16 188 FROM identity
adam@16 189 WHERE identity.User = {[r.User]}
adam@16 190 LIMIT 1);
adam@16 191 case ident of
adam@16 192 None => error <xml>Username not found</xml>
adam@16 193 | Some ident =>
adam@16 194 ses <- newSession ();
adam@16 195 setCookie login {Value = r ++ ses,
adam@16 196 Expires = None,
adam@16 197 Secure = M.secureCookies};
adam@16 198 ses <- return ses.Session;
adam@16 199 msg <- Openid.authenticate (opCallback after ses)
adam@16 200 {Association = M.association,
adam@16 201 Realm = M.realm,
adam@16 202 Identifier = ident};
adam@16 203 error <xml>Login with your identity provider failed: {[msg]}</xml>
adam@16 204
adam@16 205 fun doSignup after r =
adam@16 206 ses <- newSession ();
adam@16 207 setCookie signingUp {Value = ses,
adam@16 208 Expires = None,
adam@16 209 Secure = M.secureCookies};
adam@16 210 ses <- return ses.Session;
adam@16 211 msg <- Openid.authenticate (opCallback after ses)
adam@16 212 {Association = M.association,
adam@16 213 Realm = M.realm,
adam@16 214 Identifier = r.Identifier};
adam@16 215 error <xml>Login with your identity provider failed: {[msg]}</xml>
adam@16 216
adam@16 217 fun signup () =
adam@16 218 after <- currentUrl;
adam@16 219 wrap "Account Signup" <xml>
adam@16 220 <form>
adam@16 221 OpenID Identifier: <textbox{#Identifier}/><br/>
adam@16 222 <submit value="Sign Up" action={doSignup (show after)}/>
adam@16 223 </form>
adam@16 224 </xml>
adam@16 225 in
adam@16 226 cur <- current;
adam@17 227 here <- currentUrl;
adam@16 228 case cur of
adam@16 229 Some cur => return <xml>Logged in as {[cur]}. <a link={logout ()}>[Log out]</a></xml>
adam@16 230 | None => return <xml>
adam@17 231 <form><textbox{#User}/> <submit value="Log In" action={logon (show here)}/></form>
adam@16 232 <a link={signup ()}>Sign up</a>
adam@16 233 </xml>
adam@16 234 end
adam@16 235
adam@16 236 task periodic 60 = fn () => dml (DELETE FROM session
adam@16 237 WHERE Expires >= CURRENT_TIMESTAMP)
adam@16 238
adam@16 239 end