Mercurial > openid

comparison src/ur/openid.ur @ 17:df2eb629f21a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Successfully created an account
author Adam Chlipala <adam@chlipala.net>
date Thu, 06 Jan 2011 14:42:37 -0500
parents 35bc4da563dd
children 70ab0230649b
comparison
equal deleted inserted replaced
16:9851bc87b0d7 17:df2eb629f21a
5 task initialize = fn () => OpenidFfi.init 5 task initialize = fn () => OpenidFfi.init
6 6
7 table discoveries : { Identifier : string, Endpoint : string, Expires : time } 7 table discoveries : { Identifier : string, Endpoint : string, Expires : time }
8 PRIMARY KEY Identifier 8 PRIMARY KEY Identifier
9 9
10 fun eatFragment s =
11 case String.split s #"#" of
12 Some (s', _) => s'
13 | _ => s
14
10 fun discover s = 15 fun discover s =
16 s <- return (eatFragment s);
11 endpoint <- oneOrNoRowsE1 (SELECT (discoveries.Endpoint) 17 endpoint <- oneOrNoRowsE1 (SELECT (discoveries.Endpoint)
12 FROM discoveries 18 FROM discoveries
13 WHERE discoveries.Identifier = {[s]}); 19 WHERE discoveries.Identifier = {[s]});
14 case endpoint of 20 case endpoint of
15 Some ep => return (Some ep) 21 Some ep => return (Some ep)
187 return (AssError "Suggested new modes match old ones!") 193 return (AssError "Suggested new modes match old ones!")
188 else 194 else
189 debug "Renegotiating protocol"; 195 debug "Renegotiating protocol";
190 newAssociation url alt.Atype alt.Stype 196 newAssociation url alt.Atype alt.Stype
191 | v => return v 197 | v => return v
192
193 fun eatFragment s =
194 case String.split s #"#" of
195 Some (s', _) => s'
196 | _ => s
197 198
198 datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | NoAssociation of string | HandleError of string 199 datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | NoAssociation of string | HandleError of string
199 200
200 datatype authentication = AuthenticatedAs of string | Canceled | Failure of string 201 datatype authentication = AuthenticatedAs of string | Canceled | Failure of string
201 202
308 let 309 let
309 val sign' = case atype of 310 val sign' = case atype of
310 HMAC_SHA256 => OpenidFfi.hmac_sha256 key nvps 311 HMAC_SHA256 => OpenidFfi.hmac_sha256 key nvps
311 | HMAC_SHA1 => OpenidFfi.hmac_sha1 key nvps 312 | HMAC_SHA1 => OpenidFfi.hmac_sha1 key nvps
312 in 313 in
313 (*debug ("Fields: " ^ signed);
314 debug ("Nvps: " ^ nvps);
315 debug ("Key: " ^ key);
316 debug ("His: " ^ sign);
317 debug ("Mine: " ^ sign');*)
318 if sign' = sign then 314 if sign' = sign then
319 return None 315 return None
320 else 316 else
321 return (Some "Signatures don't match") 317 return (Some "Signatures don't match")
322 end 318 end
386 None => return "Discovery failed" 382 None => return "Discovery failed"
387 | Some dy => 383 | Some dy =>
388 case r.Association of 384 case r.Association of
389 Stateless => 385 Stateless =>
390 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id=" 386 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
391 ^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.return_to=" 387 ^ eatFragment r.Identifier
388 ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.return_to="
392 ^ show (effectfulUrl returnTo) ^ realmString)) 389 ^ show (effectfulUrl returnTo) ^ realmString))
393 | Stateful ar => 390 | Stateful ar =>
394 assoc <- association ar.AssociationType ar.AssociationSessionType dy; 391 assoc <- association ar.AssociationType ar.AssociationSessionType dy;
395 case assoc of 392 case assoc of
396 AssError msg => return ("Association failure: " ^ msg) 393 AssError msg => return ("Association failure: " ^ msg)
397 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes" 394 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
398 | Association assoc => 395 | Association assoc =>
399 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id=" 396 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
400 ^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle=" 397 ^ eatFragment r.Identifier
398 ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
401 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString)) 399 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString))
402 end 400 end
403 401
404 task periodic 1 = fn () => 402 task periodic 1 = fn () =>
405 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP); 403 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);