|
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@5
|
55 case OpenidFfi.getOutput os "openid.mode" of
|
|
adam@5
|
56 None => error <xml>No <tt>openid.mode</tt> in response</xml>
|
|
adam@5
|
57 | Some mode =>
|
|
adam@5
|
58 case mode of
|
|
adam@5
|
59 "cancel" => error <xml>You canceled the authentication!</xml>
|
|
adam@5
|
60 | "id_res" =>
|
|
adam@5
|
61 (case OpenidFfi.getOutput os "openid.identity" of
|
|
adam@5
|
62 None => error <xml>Missing identity in OP response</xml>
|
|
adam@5
|
63 | Some v => return <xml>Identity: {[v]}</xml>)
|
|
adam@5
|
64 | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml>
|
|
adam@4
|
65
|
|
adam@4
|
66 fun authenticate id =
|
|
adam@4
|
67 dy <- discover id;
|
|
adam@4
|
68 case dy of
|
|
adam@4
|
69 None => return "Discovery failed"
|
|
adam@4
|
70 | Some dy =>
|
|
adam@4
|
71 assoc <- association dy.Endpoint;
|
|
adam@4
|
72 case assoc of
|
|
adam@4
|
73 AssError msg => return msg
|
|
adam@4
|
74 | Association assoc =>
|
|
adam@4
|
75 redirect (bless (dy.Endpoint ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
|
|
adam@4
|
76 ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
|
|
adam@4
|
77 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
|
