adam@6: val discoveryExpiry = 3600
adam@6: val nonceExpiry = 3600
adam@6:
adam@0: task initialize = fn () => OpenidFfi.init
adam@1:
adam@6: table discoveries : { Identifier : string, Endpoint : string, Expires : time }
adam@6: PRIMARY KEY Identifier
adam@6:
adam@2: fun discover s =
adam@6: endpoint <- oneOrNoRowsE1 (SELECT (discoveries.Endpoint)
adam@6: FROM discoveries
adam@6: WHERE discoveries.Identifier = {[s]});
adam@6: case endpoint of
adam@6: Some ep => return (Some ep)
adam@6: | None =>
adam@6: r <- OpenidFfi.discover s;
adam@6: case r of
adam@6: None => return None
adam@6: | Some r =>
adam@6: tm <- now;
adam@6: dml (INSERT INTO discoveries (Identifier, Endpoint, Expires)
adam@6: VALUES ({[s]}, {[OpenidFfi.endpoint r]}, {[addSeconds tm discoveryExpiry]}));
adam@6: return (Some (OpenidFfi.endpoint r))
adam@3:
adam@3: val createInputs =
adam@3: is <- OpenidFfi.createInputs;
adam@3: OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0";
adam@3: return is
adam@3:
adam@4: table associations : { Endpoint : string, Handle : string, Key : string, Expires : time }
adam@3: PRIMARY KEY Endpoint
adam@3:
adam@4: datatype association = Association of {Handle : string, Key : string} | AssError of string
adam@3:
adam@3: fun association url =
adam@4: secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Key
adam@3: FROM associations
adam@3: WHERE associations.Endpoint = {[url]});
adam@3: case secret of
adam@4: Some r => return (Association r)
adam@3: | None =>
adam@3: is <- createInputs;
adam@3: OpenidFfi.addInput is "openid.mode" "associate";
adam@3: OpenidFfi.addInput is "openid.assoc_type" "HMAC-SHA256";
adam@3: OpenidFfi.addInput is "openid.session_type" "no-encryption";
adam@4:
adam@4: os <- OpenidFfi.direct url is;
adam@3: case OpenidFfi.getOutput os "error" of
adam@4: Some v => return (AssError v)
adam@3: | None =>
adam@4: case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "mac_key", OpenidFfi.getOutput os "expires_in") of
adam@4: (Some handle, Some key, Some expires) =>
adam@3: (case read expires of
adam@4: None => return (AssError "Invalid 'expires_in' field")
adam@3: | Some expires =>
adam@3: tm <- now;
adam@4: dml (INSERT INTO associations (Endpoint, Handle, Key, Expires)
adam@4: VALUES ({[url]}, {[handle]}, {[key]}, {[addSeconds tm expires]}));
adam@4: return (Association {Handle = handle, Key = key}))
adam@4: | _ => return (AssError "Missing fields in response from OP")
adam@4:
adam@6: fun eatFragment s =
adam@6: case String.split s #"#" of
adam@6: Some (_, s') => s'
adam@6: | _ => s
adam@6:
adam@6: datatype handle_result = HandleOk of string | HandleError of string
adam@6:
adam@6: fun verifyHandle os id =
adam@6: ep <- discover (eatFragment id);
adam@6: case ep of
adam@6: None => return (HandleError "Discovery failed on returned endpoint")
adam@6: | Some ep =>
adam@6: case OpenidFfi.getOutput os "openid.assoc_handle" of
adam@6: None => return (HandleError "Missing association handle in response")
adam@6: | Some handle =>
adam@6: assoc <- association ep;
adam@6: case assoc of
adam@6: AssError s => return (HandleError s)
adam@6: | Association assoc =>
adam@6: if assoc.Handle <> handle then
adam@6: return (HandleError "Association handles don't match")
adam@6: else
adam@6: return (HandleOk ep)
adam@6:
adam@6: table nonces : { Endpoint : string, Nonce : string, Expires : time }
adam@6: PRIMARY KEY (Endpoint, Nonce)
adam@6:
adam@6: fun timeOfNonce s =
adam@6: case String.split s #"T" of
adam@6: None => None
adam@6: | Some (date, s) =>
adam@6: case String.split s #"Z" of
adam@6: None => None
adam@6: | Some (time, _) => read (date ^ " " ^ time)
adam@6:
adam@6: fun verifyNonce os ep =
adam@6: case OpenidFfi.getOutput os "openid.response_nonce" of
adam@6: None => return (Some "Missing nonce in OP response")
adam@6: | Some nonce =>
adam@6: case timeOfNonce nonce of
adam@6: None => return (Some "Invalid timestamp in nonce")
adam@6: | Some tm =>
adam@6: now <- now;
adam@6: exp <- return (addSeconds now nonceExpiry);
adam@6: if tm < exp then
adam@6: return (Some "Nonce timestamp is too old")
adam@6: else
adam@6: b <- oneRowE1 (SELECT COUNT( * ) > 0
adam@6: FROM nonces
adam@6: WHERE nonces.Endpoint = {[ep]}
adam@6: AND nonces.Nonce = {[nonce]});
adam@6:
adam@6: if b then
adam@6: return (Some "Duplicate nonce")
adam@6: else
adam@6: dml (INSERT INTO nonces (Endpoint, Nonce, Expires)
adam@6: VALUES ({[ep]}, {[nonce]}, {[exp]}));
adam@6: return None
adam@6:
adam@6: fun verifySig os =
adam@6: case OpenidFfi.getOutput os "openid.signed" of
adam@6: None => return (Some "Missing openid.signed in OP response")
adam@6: | Some signed =>
adam@6: case OpenidFfi.getOutput os "openid.sig" of
adam@6: None => return (Some "Missing openid.sig in OP response")
adam@6: | Some sign => let
adam@6: fun gatherNvps signed acc =
adam@6: let
adam@6: val (this, next) =
adam@6: case String.split signed #"," of
adam@6: None => (signed, None)
adam@6: | Some (this, next) => (this, Some next)
adam@6: in
adam@6: case OpenidFfi.getOutput os ("openid." ^ this) of
adam@6: None => None
adam@6: | Some value =>
adam@6: let
adam@6: val acc = acc ^ this ^ ":" ^ value ^ "\n"
adam@6: in
adam@6: case next of
adam@6: None => Some acc
adam@6: | Some next => gatherNvps next acc
adam@6: end
adam@6: end
adam@6: in
adam@6: case gatherNvps signed "" of
adam@6: None => return (Some "openid.signed mentions missing field")
adam@6: | Some nvps =>
adam@6: let
adam@6: val sign' = OpenidFfi.sha256 nvps
adam@6: in
adam@6: debug ("Fields: " ^ signed);
adam@6: debug ("Nvps: " ^ nvps);
adam@6: debug ("His: " ^ sign);
adam@6: debug ("Mine: " ^ sign');
adam@6: if sign' = sign then
adam@6: return None
adam@6: else
adam@6: return (Some "Signatures don't match")
adam@6: end
adam@6: end
adam@6:
adam@4: fun returnTo (qs : option queryString) =
adam@4: case qs of
adam@4: None => error Empty query string for OpenID callback
adam@4: | Some qs =>
adam@4: os <- OpenidFfi.indirect qs;
adam@4: case OpenidFfi.getOutput os "openid.error" of
adam@4: Some v => error Authentication failed: {[v]}
adam@4: | None =>
adam@5: case OpenidFfi.getOutput os "openid.mode" of
adam@6: None => error No openid.mode in response ({[qs]})
adam@5: | Some mode =>
adam@5: case mode of
adam@5: "cancel" => error You canceled the authentication!
adam@5: | "id_res" =>
adam@5: (case OpenidFfi.getOutput os "openid.identity" of
adam@5: None => error Missing identity in OP response
adam@6: | Some id =>
adam@6: errO <- verifyHandle os id;
adam@6: case errO of
adam@6: HandleError s => error {[s]}
adam@6: | HandleOk ep =>
adam@6: errO <- verifyReturnTo os;
adam@6: case errO of
adam@6: Some s => error {[s]}
adam@6: | None =>
adam@6: errO <- verifyNonce os ep;
adam@6: case errO of
adam@6: Some s => error {[s]}
adam@6: | None =>
adam@6: errO <- verifySig os;
adam@6: case errO of
adam@6: Some s => error {[s]}
adam@6: | None => return Identity: {[id]})
adam@5: | _ => error Unexpected openid.mode: {[mode]}
adam@4:
adam@6: and verifyReturnTo os =
adam@6: case OpenidFfi.getOutput os "openid.return_to" of
adam@6: None => return (Some "Missing return_to in OP response")
adam@6: | Some rt =>
adam@6: if rt <> show (effectfulUrl returnTo) then
adam@6: return (Some "Wrong return_to in OP response")
adam@6: else
adam@6: return None
adam@6:
adam@4: fun authenticate id =
adam@4: dy <- discover id;
adam@4: case dy of
adam@4: None => return "Discovery failed"
adam@4: | Some dy =>
adam@6: assoc <- association dy;
adam@4: case assoc of
adam@4: AssError msg => return msg
adam@4: | Association assoc =>
adam@6: redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
adam@4: ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
adam@4: ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
adam@6:
adam@6: task periodic 1 = fn () =>
adam@6: dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);
adam@6: dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP);
adam@6: dml (DELETE FROM nonces WHERE Expires < CURRENT_TIMESTAMP)