annotate src/ur/openid.ur @ 4:2d409aff8800

Received an OpenID authentication response, but haven't checked it yet
author Adam Chlipala <adam@chlipala.net>
date Sun, 26 Dec 2010 17:19:52 -0500
parents f59083771ee2
children 443f27cd1572
rev   line source
adam@0 1 task initialize = fn () => OpenidFfi.init
adam@1 2
adam@2 3 fun discover s =
adam@2 4 r <- OpenidFfi.discover s;
adam@2 5 return (Option.mp (fn r => {Endpoint = OpenidFfi.endpoint r,
adam@2 6 LocalId = OpenidFfi.localId r}) r)
adam@3 7
adam@3 8 val createInputs =
adam@3 9 is <- OpenidFfi.createInputs;
adam@3 10 OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0";
adam@3 11 return is
adam@3 12
adam@4 13 table associations : { Endpoint : string, Handle : string, Key : string, Expires : time }
adam@3 14 PRIMARY KEY Endpoint
adam@3 15
adam@4 16 task periodic 1 = fn () => dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP)
adam@3 17
adam@4 18 datatype association = Association of {Handle : string, Key : string} | AssError of string
adam@3 19
adam@3 20 fun association url =
adam@4 21 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Key
adam@3 22 FROM associations
adam@3 23 WHERE associations.Endpoint = {[url]});
adam@3 24 case secret of
adam@4 25 Some r => return (Association r)
adam@3 26 | None =>
adam@3 27 is <- createInputs;
adam@3 28 OpenidFfi.addInput is "openid.mode" "associate";
adam@3 29 OpenidFfi.addInput is "openid.assoc_type" "HMAC-SHA256";
adam@3 30 OpenidFfi.addInput is "openid.session_type" "no-encryption";
adam@4 31
adam@4 32 os <- OpenidFfi.direct url is;
adam@3 33 case OpenidFfi.getOutput os "error" of
adam@4 34 Some v => return (AssError v)
adam@3 35 | None =>
adam@4 36 case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "mac_key", OpenidFfi.getOutput os "expires_in") of
adam@4 37 (Some handle, Some key, Some expires) =>
adam@3 38 (case read expires of
adam@4 39 None => return (AssError "Invalid 'expires_in' field")
adam@3 40 | Some expires =>
adam@3 41 tm <- now;
adam@4 42 dml (INSERT INTO associations (Endpoint, Handle, Key, Expires)
adam@4 43 VALUES ({[url]}, {[handle]}, {[key]}, {[addSeconds tm expires]}));
adam@4 44 return (Association {Handle = handle, Key = key}))
adam@4 45 | _ => return (AssError "Missing fields in response from OP")
adam@4 46
adam@4 47 fun returnTo (qs : option queryString) =
adam@4 48 case qs of
adam@4 49 None => error <xml>Empty query string for OpenID callback</xml>
adam@4 50 | Some qs =>
adam@4 51 os <- OpenidFfi.indirect qs;
adam@4 52 case OpenidFfi.getOutput os "openid.error" of
adam@4 53 Some v => error <xml>Authentication failed: {[v]}</xml>
adam@4 54 | None =>
adam@4 55 case OpenidFfi.getOutput os "openid.identity" of
adam@4 56 None => error <xml>Missing identity in OP response</xml>
adam@4 57 | Some v => return <xml>Identity: {[v]}</xml>
adam@4 58
adam@4 59 fun authenticate id =
adam@4 60 dy <- discover id;
adam@4 61 case dy of
adam@4 62 None => return "Discovery failed"
adam@4 63 | Some dy =>
adam@4 64 assoc <- association dy.Endpoint;
adam@4 65 case assoc of
adam@4 66 AssError msg => return msg
adam@4 67 | Association assoc =>
adam@4 68 redirect (bless (dy.Endpoint ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
adam@4 69 ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
adam@4 70 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))