Mercurial > openid
comparison src/ur/openid.ur @ 27:f129ddee75f3
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); |