Mercurial > openid

comparison src/ur/openid.ur @ 12:c778455fe570

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Diffie-Hellman seems to be working
author Adam Chlipala <adam@chlipala.net>
date Sat, 01 Jan 2011 14:00:52 -0500
parents e637249abfd2
children de04a3fc6b72
comparison
equal deleted inserted replaced
11:e637249abfd2 12:c778455fe570
138 OpenidFfi.getOutput os "enc_mac_key", OpenidFfi.getOutput os "expires_in") of 138 OpenidFfi.getOutput os "enc_mac_key", OpenidFfi.getOutput os "expires_in") of
139 (Some handle, Some pub, Some mac, Some expires) => 139 (Some handle, Some pub, Some mac, Some expires) =>
140 (case read expires of 140 (case read expires of
141 None => return (AssError "Invalid 'expires_in' field") 141 None => return (AssError "Invalid 'expires_in' field")
142 | Some expires => 142 | Some expires =>
143 key <- OpenidFfi.compute dh pub; 143 secret <- OpenidFfi.compute dh pub;
144 digest <- return (case stype of
145 DH_SHA1 => OpenidFfi.sha1 secret
146 | DH_SHA256 => OpenidFfi.sha256 secret
147 | _ => error <xml>Non-DH stype in associateDh</xml>);
148 key <- return (OpenidFfi.xor mac digest);
144 tm <- now; 149 tm <- now;
145 dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires) 150 dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires)
146 VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]})); 151 VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]}));
147 return (Association {Handle = handle, Typ = atype, Key = key})) 152 return (Association {Handle = handle, Typ = atype, Key = key}))
148 | (None, _, _, _) => return (AssError "Missing assoc_handle") 153 | (None, _, _, _) => return (AssError "Missing assoc_handle")
175 case r of 180 case r of
176 AssAlternate alt => 181 AssAlternate alt =>
177 if alt.Atype = atype && alt.Stype = stype then 182 if alt.Atype = atype && alt.Stype = stype then
178 return (AssError "Suggested new modes match old ones!") 183 return (AssError "Suggested new modes match old ones!")
179 else 184 else
185 debug "Renegotiating protocol";
180 newAssociation url alt.Atype alt.Stype 186 newAssociation url alt.Atype alt.Stype
181 | v => return v 187 | v => return v
182 188
183 fun eatFragment s = 189 fun eatFragment s =
184 case String.split s #"#" of 190 case String.split s #"#" of
271 case gatherNvps signed ("op_endpoint" :: "return_to" :: "response_nonce" :: "assoc_handle" :: "claimed_id" :: "identity" :: []) "" of 277 case gatherNvps signed ("op_endpoint" :: "return_to" :: "response_nonce" :: "assoc_handle" :: "claimed_id" :: "identity" :: []) "" of
272 None => return (Some "openid.signed mentions missing field") 278 None => return (Some "openid.signed mentions missing field")
273 | Some ([], nvps) => 279 | Some ([], nvps) =>
274 let 280 let
275 val sign' = case atype of 281 val sign' = case atype of
276 HMAC_SHA256 => OpenidFfi.sha256 key nvps 282 HMAC_SHA256 => OpenidFfi.hmac_sha256 key nvps
277 | HMAC_SHA1 => OpenidFfi.sha1 key nvps 283 | HMAC_SHA1 => OpenidFfi.hmac_sha1 key nvps
278 in 284 in
279 (*debug ("Fields: " ^ signed); 285 (*debug ("Fields: " ^ signed);
280 debug ("Nvps: " ^ nvps); 286 debug ("Nvps: " ^ nvps);
281 debug ("Key: " ^ key); 287 debug ("Key: " ^ key);
282 debug ("His: " ^ sign); 288 debug ("His: " ^ sign);
289 | Some (left, _) => return (Some ("openid.signed is missing required fields: " ^ show left)) 295 | Some (left, _) => return (Some ("openid.signed is missing required fields: " ^ show left))
290 end 296 end
291 297
292 datatype authentication = AuthenticatedAs of string | Canceled | Failure of string 298 datatype authentication = AuthenticatedAs of string | Canceled | Failure of string
293 299
294 sequence nextNonce
295
296 fun authenticate after r = 300 fun authenticate after r =
297 let 301 let
298 fun returnTo myNonce (qs : option queryString) = 302 fun returnTo (qs : option queryString) =
299 case qs of 303 case qs of
300 None => after (Failure "Empty query string for OpenID callback") 304 None => after (Failure "Empty query string for OpenID callback")
301 | Some qs => 305 | Some qs =>
302 os <- OpenidFfi.indirect qs; 306 os <- OpenidFfi.indirect qs;
303 case OpenidFfi.getOutput os "openid.error" of 307 case OpenidFfi.getOutput os "openid.error" of
314 | Some id => 318 | Some id =>
315 errO <- verifyHandle os id; 319 errO <- verifyHandle os id;
316 case errO of 320 case errO of
317 HandleError s => after (Failure s) 321 HandleError s => after (Failure s)
318 | HandleOk {Endpoint = ep, Typ = atype, Key = key} => 322 | HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
319 errO <- verifyReturnTo os myNonce; 323 errO <- verifyReturnTo os;
320 case errO of 324 case errO of
321 Some s => after (Failure s) 325 Some s => after (Failure s)
322 | None => 326 | None =>
323 errO <- verifyNonce os ep; 327 errO <- verifyNonce os ep;
324 case errO of 328 case errO of
328 case errO of 332 case errO of
329 Some s => after (Failure s) 333 Some s => after (Failure s)
330 | None => after (AuthenticatedAs id)) 334 | None => after (AuthenticatedAs id))
331 | _ => after (Failure ("Unexpected openid.mode: " ^ mode)) 335 | _ => after (Failure ("Unexpected openid.mode: " ^ mode))
332 336
333 and verifyReturnTo os myNonce = 337 and verifyReturnTo os =
334 case OpenidFfi.getOutput os "openid.return_to" of 338 case OpenidFfi.getOutput os "openid.return_to" of
335 None => return (Some "Missing return_to in OP response") 339 None => return (Some "Missing return_to in OP response")
336 | Some rt => 340 | Some rt =>
337 if rt <> show (effectfulUrl (returnTo myNonce)) then 341 if rt <> show (effectfulUrl returnTo) then
338 return (Some "Wrong return_to in OP response") 342 return (Some "Wrong return_to in OP response")
339 else 343 else
340 return None 344 return None
341 in 345 in
342 dy <- discover r.Identifier; 346 dy <- discover r.Identifier;
346 assoc <- association r.AssociationType r.AssociationSessionType dy; 350 assoc <- association r.AssociationType r.AssociationSessionType dy;
347 case assoc of 351 case assoc of
348 AssError msg => return ("Association failure: " ^ msg) 352 AssError msg => return ("Association failure: " ^ msg)
349 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes" 353 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
350 | Association assoc => 354 | Association assoc =>
351 myNonce <- nextval nextNonce;
352 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id=" 355 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
353 ^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle=" 356 ^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
354 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl (returnTo myNonce)))) 357 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
355 end 358 end
356 359
357 task periodic 1 = fn () => 360 task periodic 1 = fn () =>
358 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP); 361 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);
359 dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP); 362 dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP);