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

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