Mercurial > openid

comparison src/ur/openid.ur @ 27:f129ddee75f3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Some XRDS fixes; ignore query strings in naming endpoints for association purposes
author Adam Chlipala <adam@chlipala.net>
date Sun, 23 Jan 2011 17:40:42 -0500
parents ee97bc0e08fa
children f6b3fbf10dac
comparison
equal deleted inserted replaced
26:ee97bc0e08fa 27:f129ddee75f3
104 (Some "unsupported-type", at, st) => Some (AssAlternate {Atype = Option.get atype (Option.bind read at), 104 (Some "unsupported-type", at, st) => Some (AssAlternate {Atype = Option.get atype (Option.bind read at),
105 Stype = Option.get stype (Option.bind read st)}) 105 Stype = Option.get stype (Option.bind read st)})
106 | _ => Some (AssError ("OP error during association: " ^ v))) 106 | _ => Some (AssError ("OP error during association: " ^ v)))
107 | None => None 107 | None => None
108 108
109 fun eatQstring s =
110 case String.split s #"?" of
111 Some (s', _) => s'
112 | _ => s
113
109 fun associateNoEncryption url atype = 114 fun associateNoEncryption url atype =
115 url <- return (eatQstring url);
110 is <- createInputs; 116 is <- createInputs;
111 OpenidFfi.addInput is "openid.mode" "associate"; 117 OpenidFfi.addInput is "openid.mode" "associate";
112 OpenidFfi.addInput is "openid.assoc_type" (show atype); 118 OpenidFfi.addInput is "openid.assoc_type" (show atype);
113 OpenidFfi.addInput is "openid.session_type" (show NoEncryption); 119 OpenidFfi.addInput is "openid.session_type" (show NoEncryption);
114 120
128 | (None, _, _) => return (AssError "Missing assoc_handle") 134 | (None, _, _) => return (AssError "Missing assoc_handle")
129 | (_, None, _) => return (AssError "Missing mac_key") 135 | (_, None, _) => return (AssError "Missing mac_key")
130 | _ => return (AssError "Missing expires_in") 136 | _ => return (AssError "Missing expires_in")
131 137
132 fun associateDh url atype stype = 138 fun associateDh url atype stype =
139 url <- return (eatQstring url);
133 dh <- OpenidFfi.generate; 140 dh <- OpenidFfi.generate;
134 141
135 is <- createInputs; 142 is <- createInputs;
136 OpenidFfi.addInput is "openid.mode" "associate"; 143 OpenidFfi.addInput is "openid.mode" "associate";
137 OpenidFfi.addInput is "openid.assoc_type" (show atype); 144 OpenidFfi.addInput is "openid.assoc_type" (show atype);
164 | (_, None, _, _) => return (AssError "Missing dh_server_public") 171 | (_, None, _, _) => return (AssError "Missing dh_server_public")
165 | (_, _, None, _) => return (AssError "Missing enc_mac_key") 172 | (_, _, None, _) => return (AssError "Missing enc_mac_key")
166 | _ => return (AssError "Missing expires_in") 173 | _ => return (AssError "Missing expires_in")
167 174
168 fun oldAssociation url = 175 fun oldAssociation url =
176 url <- return (eatQstring url);
169 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Typ, associations.Key 177 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Typ, associations.Key
170 FROM associations 178 FROM associations
171 WHERE associations.Endpoint = {[url]}); 179 WHERE associations.Endpoint = {[url]});
172 case secret of 180 case secret of
173 Some r => return (Some (r -- #Typ ++ {Typ = deserialize r.Typ})) 181 Some r => return (Some (r -- #Typ ++ {Typ = deserialize r.Typ}))
379 in 387 in
380 dy <- discover r.Identifier; 388 dy <- discover r.Identifier;
381 case dy of 389 case dy of
382 None => return "Discovery failed" 390 None => return "Discovery failed"
383 | Some dy => 391 | Some dy =>
384 case r.Association of 392 let
385 Stateless => 393 val begin = case String.index dy #"?" of
386 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup" 394 None => "?"
387 ^ "&openid.claimed_id=http://specs.openid.net/auth/2.0/identifier_select" 395 | Some _ => "&"
388 ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle=" 396 in
389 ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString)) 397 case r.Association of
390 | Stateful ar => 398 Stateless =>
391 assoc <- association ar.AssociationType ar.AssociationSessionType dy; 399 redirect (bless (dy ^ begin ^ "openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup"
392 case assoc of
393 AssError msg => return ("Association failure: " ^ msg)
394 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
395 | Association assoc =>
396 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup"
397 ^ "&openid.claimed_id=http://specs.openid.net/auth/2.0/identifier_select" 400 ^ "&openid.claimed_id=http://specs.openid.net/auth/2.0/identifier_select"
398 ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle=" 401 ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
399 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString)) 402 ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString))
403 | Stateful ar =>
404 assoc <- association ar.AssociationType ar.AssociationSessionType dy;
405 case assoc of
406 AssError msg => return ("Association failure: " ^ msg)
407 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
408 | Association assoc =>
409 redirect (bless (dy ^ begin ^ "openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup"
410 ^ "&openid.claimed_id=http://specs.openid.net/auth/2.0/identifier_select"
411 ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
412 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString))
413 end
400 end 414 end
401 415
402 task periodic 60 = fn () => 416 task periodic 60 = fn () =>
403 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP); 417 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);
404 dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP); 418 dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP);