Ur/Web OpenID Library: src/ur/openid.ur comparison

comparison src/ur/openid.ur @ 13:de04a3fc6b72

Stateless verification worked

author	Adam Chlipala <adam@chlipala.net>
date	Sun, 02 Jan 2011 10:11:38 -0500
parents	c778455fe570
children	6b2a44da71b0

comparison

equal deleted inserted replaced

-:c778455fe570
+:de04a3fc6b72
 OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0";
 return is
 datatype association_type = HMAC_SHA1 | HMAC_SHA256
 datatype association_session_type = NoEncryption | DH_SHA1 | DH_SHA256
+datatype association_mode =
+Stateless
+| Stateful of {AssociationType : association_type,
+AssociationSessionType : association_session_type}
 table associations : { Endpoint : string, Handle : string, Typ : serialized association_type, Key : string, Expires : time }
 PRIMARY KEY Endpoint
 datatype association = Association of {Handle : string, Typ : association_type, Key : string}
 fun eatFragment s =
 case String.split s #"#" of
 Some (s', _) => s'
 | _ => s
-datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | HandleError of string
+datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | NoAssociation of string | HandleError of string
+datatype authentication = AuthenticatedAs of string | Canceled | Failure of string
 fun verifyHandle os id =
 id' <- return (eatFragment id);
 ep <- discover id';
 case ep of
 case OpenidFfi.getOutput os "openid.assoc_handle" of
 None => return (HandleError "Missing association handle in response")
 | Some handle =>
 assoc <- oldAssociation ep;
 case assoc of
-None => return (HandleError "Couldn't find association handle")
+None => return (NoAssociation ep)
 | Some assoc =>
 if assoc.Handle <> handle then
 return (HandleError "Association handles don't match")
 else
 return (HandleOk {Endpoint = ep, Typ = assoc.Typ, Key = assoc.Key})
+fun verifyStateless os ep id =
+os' <- OpenidFfi.direct ep (OpenidFfi.remode os "check_authentication");
+case OpenidFfi.getOutput os' "error" of
+Some msg => return (Failure ("Failure confirming message contents with OP: " ^ msg))
+| None =>
+case OpenidFfi.getOutput os' "is_valid" of
+Some "true" => return (AuthenticatedAs id)
+| _ => return (Failure "OP does not confirm message contents")
 table nonces : { Endpoint : string, Nonce : string, Expires : time }
 PRIMARY KEY (Endpoint, Nonce)
 fun timeOfNonce s =
 return (Some "Signatures don't match")
 end
 | Some (left, _) => return (Some ("openid.signed is missing required fields: " ^ show left))
 end
-datatype authentication = AuthenticatedAs of string | Canceled | Failure of string
 fun authenticate after r =
 let
 fun returnTo (qs : option queryString) =
 case qs of
 None => after (Failure "Empty query string for OpenID callback")
 | Some qs =>
 os <- OpenidFfi.indirect qs;
 case OpenidFfi.getOutput os "openid.error" of
-Some v => after (Failure "Authentication failed: {[v]}")
+Some v => after (Failure ("Authentication failed: " ^ v))
 | None =>
 case OpenidFfi.getOutput os "openid.mode" of
 None => after (Failure "No openid.mode in response")
 | Some mode =>
 case mode of
 "cancel" => after Canceled
 | "id_res" =>
 (case OpenidFfi.getOutput os "openid.claimed_id" of
 None => after (Failure "Missing identity in OP response")
 | Some id =>
-errO <- verifyHandle os id;
+errO <- verifyReturnTo os;
 case errO of
-HandleError s => after (Failure s)
+Some s => after (Failure s)
-| HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
+| None =>
-errO <- verifyReturnTo os;
+errO <- verifyHandle os id;
 case errO of
-Some s => after (Failure s)
+HandleError s => after (Failure s)
-| None =>
+| NoAssociation ep =>
+r <- verifyStateless os ep id;
+after r
+| HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
 errO <- verifyNonce os ep;
 case errO of
 Some s => after (Failure s)
 | None =>
 errO <- verifySig os atype key;
 in
 dy <- discover r.Identifier;
 case dy of
 None => return "Discovery failed"
 | Some dy =>
-assoc <- association r.AssociationType r.AssociationSessionType dy;
+case r.Association of
-case assoc of
+Stateless =>
-AssError msg => return ("Association failure: " ^ msg)
-| AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
-| Association assoc =>
 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
-^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
+^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.return_to="
-^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
+^ show (effectfulUrl returnTo)))
+| Stateful ar =>
+assoc <- association ar.AssociationType ar.AssociationSessionType dy;
+case assoc of
+AssError msg => return ("Association failure: " ^ msg)
+| AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
+| Association assoc =>
+redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
+^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
+^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
 end
 task periodic 1 = fn () =>
 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);
 dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP);

Mercurial > openid

comparison src/ur/openid.ur @ 13:de04a3fc6b72