adam@6: val discoveryExpiry = 3600 adam@11: val nonceExpiry = 600 adam@11: val nonceSkew = 600 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@8: datatype association_type = HMAC_SHA1 | HMAC_SHA256 adam@8: datatype association_session_type = NoEncryption | DH_SHA1 | DH_SHA256 adam@13: datatype association_mode = adam@13: Stateless adam@13: | Stateful of {AssociationType : association_type, adam@13: AssociationSessionType : association_session_type} adam@8: adam@8: table associations : { Endpoint : string, Handle : string, Typ : serialized association_type, Key : string, Expires : time } adam@3: PRIMARY KEY Endpoint adam@3: adam@8: datatype association = Association of {Handle : string, Typ : association_type, Key : string} adam@8: | AssError of string adam@8: | AssAlternate of {Atype : association_type, Stype : association_session_type} adam@3: adam@8: fun atype_show v = adam@8: case v of adam@8: HMAC_SHA1 => "HMAC-SHA1" adam@8: | HMAC_SHA256 => "HMAC-SHA256" adam@8: adam@8: val show_atype = mkShow atype_show adam@8: adam@8: fun stype_show v = adam@8: case v of adam@8: NoEncryption => "no-encryption" adam@8: | DH_SHA1 => "DH-SHA1" adam@8: | DH_SHA256 => "DH-SHA256" adam@8: adam@8: val show_stype = mkShow stype_show adam@8: adam@8: fun atype_read s = adam@8: case s of adam@8: "HMAC-SHA1" => Some HMAC_SHA1 adam@8: | "HMAC-SHA256" => Some HMAC_SHA256 adam@8: | _ => None adam@8: adam@8: val read_atype = mkRead' atype_read "association type" adam@8: adam@8: fun stype_read s = adam@8: case s of adam@8: "no-encryption" => Some NoEncryption adam@8: | "DH-SHA1" => Some DH_SHA1 adam@8: | "DH-SHA256" => Some DH_SHA256 adam@8: | _ => None adam@8: adam@8: val read_stype = mkRead' stype_read "association session type" adam@8: adam@8: fun atype_eq v1 v2 = adam@8: case (v1, v2) of adam@8: (HMAC_SHA1, HMAC_SHA1) => True adam@8: | (HMAC_SHA256, HMAC_SHA256) => True adam@8: | _ => False adam@8: adam@8: val eq_atype = mkEq atype_eq adam@8: adam@8: fun stype_eq v1 v2 = adam@8: case (v1, v2) of adam@8: (NoEncryption, NoEncryption) => True adam@8: | (DH_SHA1, DH_SHA1) => True adam@8: | (DH_SHA256, DH_SHA256) => True adam@8: | _ => False adam@8: adam@8: val eq_stype = mkEq stype_eq adam@8: adam@8: fun errorResult atype stype os = adam@8: case OpenidFfi.getOutput os "error" of adam@8: Some v => adam@8: (case (OpenidFfi.getOutput os "error_code", OpenidFfi.getOutput os "assoc_type", OpenidFfi.getOutput os "session_type") of adam@8: (Some "unsupported-type", at, st) => Some (AssAlternate {Atype = Option.get atype (Option.bind read at), adam@8: Stype = Option.get stype (Option.bind read st)}) adam@8: | _ => Some (AssError ("OP error during association: " ^ v))) adam@8: | None => None adam@8: adam@8: fun associateNoEncryption url atype = adam@8: is <- createInputs; adam@8: OpenidFfi.addInput is "openid.mode" "associate"; adam@8: OpenidFfi.addInput is "openid.assoc_type" (show atype); adam@8: OpenidFfi.addInput is "openid.session_type" (show NoEncryption); adam@8: adam@8: os <- OpenidFfi.direct url is; adam@8: case errorResult atype NoEncryption os of adam@8: Some v => return v adam@8: | None => adam@8: case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "mac_key", OpenidFfi.getOutput os "expires_in") of adam@8: (Some handle, Some key, Some expires) => adam@8: (case read expires of adam@8: None => return (AssError "Invalid 'expires_in' field") adam@8: | Some expires => adam@8: tm <- now; adam@8: dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires) adam@8: VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]})); adam@8: return (Association {Handle = handle, Typ = atype, Key = key})) adam@8: | (None, _, _) => return (AssError "Missing assoc_handle") adam@8: | (_, None, _) => return (AssError "Missing mac_key") adam@8: | _ => return (AssError "Missing expires_in") adam@8: adam@8: fun associateDh url atype stype = adam@8: dh <- OpenidFfi.generate; adam@8: adam@8: is <- createInputs; adam@8: OpenidFfi.addInput is "openid.mode" "associate"; adam@8: OpenidFfi.addInput is "openid.assoc_type" (show atype); adam@8: OpenidFfi.addInput is "openid.session_type" (show stype); adam@8: OpenidFfi.addInput is "openid.dh_modulus" (OpenidFfi.modulus dh); adam@8: OpenidFfi.addInput is "openid.dh_gen" (OpenidFfi.generator dh); adam@8: OpenidFfi.addInput is "openid.dh_consumer_public" (OpenidFfi.public dh); adam@8: adam@8: os <- OpenidFfi.direct url is; adam@8: case errorResult atype stype os of adam@8: Some v => return v adam@8: | None => adam@8: case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "dh_server_public", adam@8: OpenidFfi.getOutput os "enc_mac_key", OpenidFfi.getOutput os "expires_in") of adam@8: (Some handle, Some pub, Some mac, Some expires) => adam@8: (case read expires of adam@8: None => return (AssError "Invalid 'expires_in' field") adam@8: | Some expires => adam@12: secret <- OpenidFfi.compute dh pub; adam@12: digest <- return (case stype of adam@12: DH_SHA1 => OpenidFfi.sha1 secret adam@12: | DH_SHA256 => OpenidFfi.sha256 secret adam@12: | _ => error Non-DH stype in associateDh); adam@12: key <- return (OpenidFfi.xor mac digest); adam@8: tm <- now; adam@8: dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires) adam@8: VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]})); adam@8: return (Association {Handle = handle, Typ = atype, Key = key})) adam@8: | (None, _, _, _) => return (AssError "Missing assoc_handle") adam@8: | (_, None, _, _) => return (AssError "Missing dh_server_public") adam@8: | (_, _, None, _) => return (AssError "Missing enc_mac_key") adam@8: | _ => return (AssError "Missing expires_in") adam@8: adam@8: fun oldAssociation url = adam@8: secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Typ, associations.Key adam@7: FROM associations adam@7: WHERE associations.Endpoint = {[url]}); adam@3: case secret of adam@8: Some r => return (Some (r -- #Typ ++ {Typ = deserialize r.Typ})) adam@8: | None => return None adam@8: adam@8: fun newAssociation url atype stype = adam@8: case stype of adam@8: NoEncryption => associateNoEncryption url atype adam@8: | _ => associateDh url atype stype adam@8: adam@8: fun association atype stype url = adam@8: secret <- oldAssociation url; adam@8: case secret of adam@4: Some r => return (Association r) adam@3: | None => adam@8: stype <- return (case (stype, String.isPrefix {Full = url, Prefix = "https://"}) of adam@8: (NoEncryption, False) => DH_SHA256 adam@8: | _ => stype); adam@8: r <- newAssociation url atype stype; adam@8: case r of adam@8: AssAlternate alt => adam@8: if alt.Atype = atype && alt.Stype = stype then adam@8: return (AssError "Suggested new modes match old ones!") adam@8: else adam@12: debug "Renegotiating protocol"; adam@8: newAssociation url alt.Atype alt.Stype adam@8: | v => return v adam@4: adam@6: fun eatFragment s = adam@6: case String.split s #"#" of adam@10: Some (s', _) => s' adam@6: | _ => s adam@6: adam@13: datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | NoAssociation of string | HandleError of string adam@13: adam@13: datatype authentication = AuthenticatedAs of string | Canceled | Failure of string adam@6: adam@6: fun verifyHandle os id = adam@10: id' <- return (eatFragment id); adam@10: ep <- discover id'; adam@6: case ep of adam@10: None => return (HandleError ("Discovery failed on returned identifier: " ^ id')) 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@8: assoc <- oldAssociation ep; adam@6: case assoc of adam@13: None => return (NoAssociation ep) adam@8: | Some assoc => adam@6: if assoc.Handle <> handle then adam@6: return (HandleError "Association handles don't match") adam@6: else adam@8: return (HandleOk {Endpoint = ep, Typ = assoc.Typ, Key = assoc.Key}) adam@6: adam@14: fun verifyStateless os ep id expectInvalidation = adam@13: os' <- OpenidFfi.direct ep (OpenidFfi.remode os "check_authentication"); adam@13: case OpenidFfi.getOutput os' "error" of adam@13: Some msg => return (Failure ("Failure confirming message contents with OP: " ^ msg)) adam@13: | None => adam@14: let adam@14: fun finish () = case OpenidFfi.getOutput os' "is_valid" of adam@14: Some "true" => return (AuthenticatedAs id) adam@14: | _ => return (Failure "OP does not confirm message contents") adam@14: in adam@14: case OpenidFfi.getOutput os' "invalidate_handle" of adam@14: None => adam@14: if expectInvalidation then adam@14: return (Failure "Claimed invalidate_handle is not confirmed") adam@14: else adam@14: finish () adam@14: | Some handle => adam@14: dml (DELETE FROM associations adam@14: WHERE Endpoint = {[ep]} AND Handle = {[handle]}); adam@14: finish () adam@14: end adam@13: 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@7: | Some (time, _) => readUtc (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@9: if tm < addSeconds now (-nonceExpiry) then adam@6: return (Some "Nonce timestamp is too old") adam@9: else if tm > addSeconds now nonceSkew then adam@11: return (Some "Nonce timestamp is too far in the future") 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@9: VALUES ({[ep]}, {[nonce]}, {[addSeconds now nonceExpiry]})); adam@6: return None adam@6: adam@8: fun verifySig os atype key = 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@9: fun gatherNvps signed required 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@9: val required = List.filter (fn other => other <> this) required adam@6: val acc = acc ^ this ^ ":" ^ value ^ "\n" adam@6: in adam@6: case next of adam@9: None => Some (required, acc) adam@9: | Some next => gatherNvps next required acc adam@6: end adam@6: end adam@6: in adam@9: case gatherNvps signed ("op_endpoint" :: "return_to" :: "response_nonce" :: "assoc_handle" :: "claimed_id" :: "identity" :: []) "" of adam@6: None => return (Some "openid.signed mentions missing field") adam@9: | Some ([], nvps) => adam@6: let adam@8: val sign' = case atype of adam@12: HMAC_SHA256 => OpenidFfi.hmac_sha256 key nvps adam@12: | HMAC_SHA1 => OpenidFfi.hmac_sha1 key nvps adam@6: in adam@9: (*debug ("Fields: " ^ signed); adam@6: debug ("Nvps: " ^ nvps); adam@7: debug ("Key: " ^ key); adam@6: debug ("His: " ^ sign); adam@9: 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@9: | Some (left, _) => return (Some ("openid.signed is missing required fields: " ^ show left)) adam@6: end adam@6: adam@10: fun authenticate after r = adam@10: let adam@12: fun returnTo (qs : option queryString) = adam@10: case qs of adam@10: None => after (Failure "Empty query string for OpenID callback") adam@10: | Some qs => adam@10: os <- OpenidFfi.indirect qs; adam@10: case OpenidFfi.getOutput os "openid.error" of adam@13: Some v => after (Failure ("Authentication failed: " ^ v)) adam@10: | None => adam@10: case OpenidFfi.getOutput os "openid.mode" of adam@10: None => after (Failure "No openid.mode in response") adam@10: | Some mode => adam@10: case mode of adam@10: "cancel" => after Canceled adam@10: | "id_res" => adam@10: (case OpenidFfi.getOutput os "openid.claimed_id" of adam@10: None => after (Failure "Missing identity in OP response") adam@10: | Some id => adam@13: errO <- verifyReturnTo os; adam@6: case errO of adam@13: Some s => after (Failure s) adam@13: | None => adam@13: errO <- verifyHandle os id; adam@6: case errO of adam@13: HandleError s => after (Failure s) adam@13: | NoAssociation ep => adam@14: r <- verifyStateless os ep id False; adam@13: after r adam@13: | HandleOk {Endpoint = ep, Typ = atype, Key = key} => adam@14: case OpenidFfi.getOutput os "openid.invalidate_handle" of adam@14: Some _ => adam@14: r <- verifyStateless os ep id True; adam@14: after r adam@10: | None => adam@14: errO <- verifyNonce os ep; adam@10: case errO of adam@10: Some s => after (Failure s) adam@14: | None => adam@14: errO <- verifySig os atype key; adam@14: case errO of adam@14: Some s => after (Failure s) adam@14: | None => after (AuthenticatedAs id)) adam@10: | _ => after (Failure ("Unexpected openid.mode: " ^ mode)) adam@4: adam@12: and verifyReturnTo os = adam@10: case OpenidFfi.getOutput os "openid.return_to" of adam@10: None => return (Some "Missing return_to in OP response") adam@10: | Some rt => adam@12: if rt <> show (effectfulUrl returnTo) then adam@10: return (Some "Wrong return_to in OP response") adam@10: else adam@10: return None adam@15: adam@15: val realmString = case r.Realm of adam@15: None => "" adam@15: | Some realm => "&openid.realm=" ^ realm adam@10: in adam@10: dy <- discover r.Identifier; adam@10: case dy of adam@10: None => return "Discovery failed" adam@10: | Some dy => adam@13: case r.Association of adam@13: Stateless => adam@10: redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id=" adam@13: ^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.return_to=" adam@15: ^ show (effectfulUrl returnTo) ^ realmString)) adam@13: | Stateful ar => adam@13: assoc <- association ar.AssociationType ar.AssociationSessionType dy; adam@13: case assoc of adam@13: AssError msg => return ("Association failure: " ^ msg) adam@13: | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes" adam@13: | Association assoc => adam@13: redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id=" adam@13: ^ r.Identifier ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle=" adam@15: ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString)) adam@10: end 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)