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@7:                             FROM associations
adam@7:                             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@7:         debug ("Contacting " ^ url);
adam@7: 
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@7:               | (None, _, _) => return (AssError "Missing assoc_handle")
adam@7:               | (_, None, _) => return (AssError "Missing mac_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@7: datatype handle_result = HandleOk of {Endpoint : string, 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@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@7:                     return (HandleOk {Endpoint = ep, 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@7: fun verifySig os 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@7:                         val sign' = OpenidFfi.sha256 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@7:                            | HandleOk {Endpoint = ep, 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@7:                                      errO <- verifySig os 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@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)