Mercurial > openid

annotate src/ur/openidUser.ur @ 25:c560ec5bf514

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