adam@0: task initialize = fn () => OpenidFfi.init
adam@1: 
adam@2: fun discover s =
adam@2:     r <- OpenidFfi.discover s;
adam@2:     return (Option.mp (fn r => {Endpoint = OpenidFfi.endpoint r,
adam@2:                                 LocalId = OpenidFfi.localId r}) 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: task periodic 1 = fn () => dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP)
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@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@5:                 None => error <xml>No <tt>openid.mode</tt> in response</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@5:                        | Some v => return <xml>Identity: {[v]}</xml>)
adam@5:                   | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml>
adam@4: 
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@4:         assoc <- association dy.Endpoint;
adam@4:         case assoc of
adam@4:             AssError msg => return msg
adam@4:           | Association assoc =>
adam@4:             redirect (bless (dy.Endpoint ^ "?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)))