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

comparison src/ur/openid.ur @ 10:194577b60771

Call user-specified function after authentication

author	Adam Chlipala <adam@chlipala.net>
date	Wed, 29 Dec 2010 14:38:56 -0500
parents	426dd5c88df1
children	e637249abfd2

comparison

equal deleted inserted replaced

-:426dd5c88df1
+:194577b60771
 newAssociation url alt.Atype alt.Stype
 | v => return v
 fun eatFragment s =
 case String.split s #"#" of
-Some (_, s') => s'
+Some (s', _) => s'
 | _ => s
 datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | HandleError of string
 fun verifyHandle os id =
-ep <- discover (eatFragment id);
+id' <- return (eatFragment id);
+ep <- discover id';
 case ep of
-None => return (HandleError "Discovery failed on returned endpoint")
+None => return (HandleError ("Discovery failed on returned identifier: " ^ id'))
 | Some ep =>
 case OpenidFfi.getOutput os "openid.assoc_handle" of
 None => return (HandleError "Missing association handle in response")
 | Some handle =>
 assoc <- oldAssociation ep;
 return (Some "Signatures don't match")
 end
 | Some (left, _) => return (Some ("openid.signed is missing required fields: " ^ show left))
 end
-fun returnTo (qs : option queryString) =
+datatype authentication = AuthenticatedAs of string | Canceled | Failure of string
-case qs of
-None => error <xml>Empty query string for OpenID callback</xml>
+fun authenticate after r =
-| Some qs =>
+let
-os <- OpenidFfi.indirect qs;
+fun returnTo (qs : option queryString) =
-case OpenidFfi.getOutput os "openid.error" of
+case qs of
-Some v => error <xml>Authentication failed: {[v]}</xml>
+None => after (Failure "Empty query string for OpenID callback")
-| None =>
+| Some qs =>
-case OpenidFfi.getOutput os "openid.mode" of
+os <- OpenidFfi.indirect qs;
-None => error <xml>No <tt>openid.mode</tt> in response ({[qs]})</xml>
+case OpenidFfi.getOutput os "openid.error" of
-| Some mode =>
+Some v => after (Failure "Authentication failed: {[v]}")
-case mode of
+| None =>
-"cancel" => error <xml>You canceled the authentication!</xml>
+case OpenidFfi.getOutput os "openid.mode" of
-| "id_res" =>
+None => after (Failure "No openid.mode in response")
-(case OpenidFfi.getOutput os "openid.identity" of
+| Some mode =>
-None => error <xml>Missing identity in OP response</xml>
+case mode of
-| Some id =>
+"cancel" => after Canceled
-errO <- verifyHandle os id;
+| "id_res" =>
-case errO of
+(case OpenidFfi.getOutput os "openid.claimed_id" of
-HandleError s => error <xml>{[s]}</xml>
+None => after (Failure "Missing identity in OP response")
-| HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
+| Some id =>
-errO <- verifyReturnTo os;
+errO <- verifyHandle os id;
-case errO of
-Some s => error <xml>{[s]}</xml>
-| None =>
-errO <- verifyNonce os ep;
 case errO of
-Some s => error <xml>{[s]}</xml>
+HandleError s => after (Failure s)
-| None =>
+| HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
-errO <- verifySig os atype key;
+errO <- verifyReturnTo os;
 case errO of
-Some s => error <xml>{[s]}</xml>
+Some s => after (Failure s)
-| None => return <xml>Identity: {[id]}</xml>)
+| None =>
-| _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml>
+errO <- verifyNonce os ep;
+case errO of
-and verifyReturnTo os =
+Some s => after (Failure s)
-case OpenidFfi.getOutput os "openid.return_to" of
+| None =>
-None => return (Some "Missing return_to in OP response")
+errO <- verifySig os atype key;
-| Some rt =>
+case errO of
-if rt <> show (effectfulUrl returnTo) then
+Some s => after (Failure s)
-return (Some "Wrong return_to in OP response")
+| None => after (AuthenticatedAs id))
-else
+| _ => after (Failure ("Unexpected openid.mode: " ^ mode))
-return None
+and verifyReturnTo os =
-fun authenticate atype stype id =
+case OpenidFfi.getOutput os "openid.return_to" of
-dy <- discover id;
+None => return (Some "Missing return_to in OP response")
-case dy of
+| Some rt =>
-None => return "Discovery failed"
+if rt <> show (effectfulUrl returnTo) then
-| Some dy =>
+return (Some "Wrong return_to in OP response")
-assoc <- association atype stype dy;
+else
-case assoc of
+return None
-AssError msg => return ("Association failure: " ^ msg)
+in
-| AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
+dy <- discover r.Identifier;
-| Association assoc =>
+case dy of
-redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
+None => return "Discovery failed"
-^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
+| Some dy =>
-^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
+assoc <- association r.AssociationType r.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);
 dml (DELETE FROM nonces WHERE Expires < CURRENT_TIMESTAMP)

Mercurial > openid

comparison src/ur/openid.ur @ 10:194577b60771