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@8: datatype association_type = HMAC_SHA1 | HMAC_SHA256
adam@8: datatype association_session_type = NoEncryption | DH_SHA1 | DH_SHA256
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@8:                      key <- OpenidFfi.compute dh pub;
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@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@6:         Some (_, s') => s'
adam@6:       | _ => s
adam@6: 
adam@8: datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : 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@8:             assoc <- oldAssociation ep;
adam@6:             case assoc of
adam@8:                 None => return (HandleError "Couldn't find association handle")
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@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@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@7:                     debug ("Nonce expires: " ^ show exp);
adam@6:                     dml (INSERT INTO nonces (Endpoint, Nonce, Expires)
adam@6:                          VALUES ({[ep]}, {[nonce]}, {[exp]}));
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@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@8:                         val sign' = case atype of
adam@8:                                         HMAC_SHA256 => OpenidFfi.sha256 key nvps
adam@8:                                       | HMAC_SHA1 => OpenidFfi.sha1 key nvps
adam@6:                     in
adam@6:                         debug ("Fields: " ^ signed);
adam@6:                         debug ("Nvps: " ^ nvps);
adam@7:                         debug ("Key: " ^ key);
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 <xml>Empty query string for OpenID callback</xml>
adam@4:       | Some qs =>
adam@4:         os <- OpenidFfi.indirect qs;
adam@4:         case OpenidFfi.getOutput os "openid.error" of
adam@4:             Some v => error <xml>Authentication failed: {[v]}</xml>
adam@4:           | None =>
adam@5:             case OpenidFfi.getOutput os "openid.mode" of
adam@6:                 None => error <xml>No <tt>openid.mode</tt> in response ({[qs]})</xml>
adam@5:               | Some mode =>
adam@5:                 case mode of
adam@5:                     "cancel" => error <xml>You canceled the authentication!</xml>
adam@5:                   | "id_res" =>
adam@5:                     (case OpenidFfi.getOutput os "openid.identity" of
adam@5:                          None => error <xml>Missing identity in OP response</xml>
adam@6:                        | Some id =>
adam@6:                          errO <- verifyHandle os id;
adam@6:                          case errO of
adam@6:                              HandleError s => error <xml>{[s]}</xml>
adam@8:                            | HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
adam@6:                              errO <- verifyReturnTo os;
adam@6:                              case errO of
adam@6:                                  Some s => error <xml>{[s]}</xml>
adam@6:                                | None =>
adam@6:                                  errO <- verifyNonce os ep;
adam@6:                                  case errO of
adam@6:                                      Some s => error <xml>{[s]}</xml>
adam@6:                                    | None =>
adam@8:                                      errO <- verifySig os atype key;
adam@6:                                      case errO of
adam@6:                                          Some s => error <xml>{[s]}</xml>
adam@6:                                        | None => return <xml>Identity: {[id]}</xml>)
adam@5:                   | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml>
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@8: fun authenticate atype stype id =
adam@4:     dy <- discover id;
adam@4:     case dy of
adam@4:         None => return "Discovery failed"
adam@4:       | Some dy =>
adam@8:         assoc <- association atype stype dy;
adam@4:         case assoc of
adam@8:             AssError msg => return ("Association failure: " ^ msg)
adam@8:           | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
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)