Mercurial > openid

comparison src/ur/openid.ur @ 6:99496175078b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Added preliminary versions of all the authentication verification steps
author Adam Chlipala <adam@chlipala.net>
date Mon, 27 Dec 2010 13:18:02 -0500
parents 443f27cd1572
children 976121190b2d
comparison
equal deleted inserted replaced
5:443f27cd1572 6:99496175078b
1 val discoveryExpiry = 3600
2 val nonceExpiry = 3600
3
1 task initialize = fn () => OpenidFfi.init 4 task initialize = fn () => OpenidFfi.init
2 5
6 table discoveries : { Identifier : string, Endpoint : string, Expires : time }
7 PRIMARY KEY Identifier
8
3 fun discover s = 9 fun discover s =
4 r <- OpenidFfi.discover s; 10 endpoint <- oneOrNoRowsE1 (SELECT (discoveries.Endpoint)
5 return (Option.mp (fn r => {Endpoint = OpenidFfi.endpoint r, 11 FROM discoveries
6 LocalId = OpenidFfi.localId r}) r) 12 WHERE discoveries.Identifier = {[s]});
13 case endpoint of
14 Some ep => return (Some ep)
15 | None =>
16 r <- OpenidFfi.discover s;
17 case r of
18 None => return None
19 | Some r =>
20 tm <- now;
21 dml (INSERT INTO discoveries (Identifier, Endpoint, Expires)
22 VALUES ({[s]}, {[OpenidFfi.endpoint r]}, {[addSeconds tm discoveryExpiry]}));
23 return (Some (OpenidFfi.endpoint r))
7 24
8 val createInputs = 25 val createInputs =
9 is <- OpenidFfi.createInputs; 26 is <- OpenidFfi.createInputs;
10 OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0"; 27 OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0";
11 return is 28 return is
12 29
13 table associations : { Endpoint : string, Handle : string, Key : string, Expires : time } 30 table associations : { Endpoint : string, Handle : string, Key : string, Expires : time }
14 PRIMARY KEY Endpoint 31 PRIMARY KEY Endpoint
15
16 task periodic 1 = fn () => dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP)
17 32
18 datatype association = Association of {Handle : string, Key : string} | AssError of string 33 datatype association = Association of {Handle : string, Key : string} | AssError of string
19 34
20 fun association url = 35 fun association url =
21 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Key 36 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Key
42 dml (INSERT INTO associations (Endpoint, Handle, Key, Expires) 57 dml (INSERT INTO associations (Endpoint, Handle, Key, Expires)
43 VALUES ({[url]}, {[handle]}, {[key]}, {[addSeconds tm expires]})); 58 VALUES ({[url]}, {[handle]}, {[key]}, {[addSeconds tm expires]}));
44 return (Association {Handle = handle, Key = key})) 59 return (Association {Handle = handle, Key = key}))
45 | _ => return (AssError "Missing fields in response from OP") 60 | _ => return (AssError "Missing fields in response from OP")
46 61
62 fun eatFragment s =
63 case String.split s #"#" of
64 Some (_, s') => s'
65 | _ => s
66
67 datatype handle_result = HandleOk of string | HandleError of string
68
69 fun verifyHandle os id =
70 ep <- discover (eatFragment id);
71 case ep of
72 None => return (HandleError "Discovery failed on returned endpoint")
73 | Some ep =>
74 case OpenidFfi.getOutput os "openid.assoc_handle" of
75 None => return (HandleError "Missing association handle in response")
76 | Some handle =>
77 assoc <- association ep;
78 case assoc of
79 AssError s => return (HandleError s)
80 | Association assoc =>
81 if assoc.Handle <> handle then
82 return (HandleError "Association handles don't match")
83 else
84 return (HandleOk ep)
85
86 table nonces : { Endpoint : string, Nonce : string, Expires : time }
87 PRIMARY KEY (Endpoint, Nonce)
88
89 fun timeOfNonce s =
90 case String.split s #"T" of
91 None => None
92 | Some (date, s) =>
93 case String.split s #"Z" of
94 None => None
95 | Some (time, _) => read (date ^ " " ^ time)
96
97 fun verifyNonce os ep =
98 case OpenidFfi.getOutput os "openid.response_nonce" of
99 None => return (Some "Missing nonce in OP response")
100 | Some nonce =>
101 case timeOfNonce nonce of
102 None => return (Some "Invalid timestamp in nonce")
103 | Some tm =>
104 now <- now;
105 exp <- return (addSeconds now nonceExpiry);
106 if tm < exp then
107 return (Some "Nonce timestamp is too old")
108 else
109 b <- oneRowE1 (SELECT COUNT( * ) > 0
110 FROM nonces
111 WHERE nonces.Endpoint = {[ep]}
112 AND nonces.Nonce = {[nonce]});
113
114 if b then
115 return (Some "Duplicate nonce")
116 else
117 dml (INSERT INTO nonces (Endpoint, Nonce, Expires)
118 VALUES ({[ep]}, {[nonce]}, {[exp]}));
119 return None
120
121 fun verifySig os =
122 case OpenidFfi.getOutput os "openid.signed" of
123 None => return (Some "Missing openid.signed in OP response")
124 | Some signed =>
125 case OpenidFfi.getOutput os "openid.sig" of
126 None => return (Some "Missing openid.sig in OP response")
127 | Some sign => let
128 fun gatherNvps signed acc =
129 let
130 val (this, next) =
131 case String.split signed #"," of
132 None => (signed, None)
133 | Some (this, next) => (this, Some next)
134 in
135 case OpenidFfi.getOutput os ("openid." ^ this) of
136 None => None
137 | Some value =>
138 let
139 val acc = acc ^ this ^ ":" ^ value ^ "\n"
140 in
141 case next of
142 None => Some acc
143 | Some next => gatherNvps next acc
144 end
145 end
146 in
147 case gatherNvps signed "" of
148 None => return (Some "openid.signed mentions missing field")
149 | Some nvps =>
150 let
151 val sign' = OpenidFfi.sha256 nvps
152 in
153 debug ("Fields: " ^ signed);
154 debug ("Nvps: " ^ nvps);
155 debug ("His: " ^ sign);
156 debug ("Mine: " ^ sign');
157 if sign' = sign then
158 return None
159 else
160 return (Some "Signatures don't match")
161 end
162 end
163
47 fun returnTo (qs : option queryString) = 164 fun returnTo (qs : option queryString) =
48 case qs of 165 case qs of
49 None => error <xml>Empty query string for OpenID callback</xml> 166 None => error <xml>Empty query string for OpenID callback</xml>
50 | Some qs => 167 | Some qs =>
51 os <- OpenidFfi.indirect qs; 168 os <- OpenidFfi.indirect qs;
52 case OpenidFfi.getOutput os "openid.error" of 169 case OpenidFfi.getOutput os "openid.error" of
53 Some v => error <xml>Authentication failed: {[v]}</xml> 170 Some v => error <xml>Authentication failed: {[v]}</xml>
54 | None => 171 | None =>
55 case OpenidFfi.getOutput os "openid.mode" of 172 case OpenidFfi.getOutput os "openid.mode" of
56 None => error <xml>No <tt>openid.mode</tt> in response</xml> 173 None => error <xml>No <tt>openid.mode</tt> in response ({[qs]})</xml>
57 | Some mode => 174 | Some mode =>
58 case mode of 175 case mode of
59 "cancel" => error <xml>You canceled the authentication!</xml> 176 "cancel" => error <xml>You canceled the authentication!</xml>
60 | "id_res" => 177 | "id_res" =>
61 (case OpenidFfi.getOutput os "openid.identity" of 178 (case OpenidFfi.getOutput os "openid.identity" of
62 None => error <xml>Missing identity in OP response</xml> 179 None => error <xml>Missing identity in OP response</xml>
63 | Some v => return <xml>Identity: {[v]}</xml>) 180 | Some id =>
181 errO <- verifyHandle os id;
182 case errO of
183 HandleError s => error <xml>{[s]}</xml>
184 | HandleOk ep =>
185 errO <- verifyReturnTo os;
186 case errO of
187 Some s => error <xml>{[s]}</xml>
188 | None =>
189 errO <- verifyNonce os ep;
190 case errO of
191 Some s => error <xml>{[s]}</xml>
192 | None =>
193 errO <- verifySig os;
194 case errO of
195 Some s => error <xml>{[s]}</xml>
196 | None => return <xml>Identity: {[id]}</xml>)
64 | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml> 197 | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml>
198
199 and verifyReturnTo os =
200 case OpenidFfi.getOutput os "openid.return_to" of
201 None => return (Some "Missing return_to in OP response")
202 | Some rt =>
203 if rt <> show (effectfulUrl returnTo) then
204 return (Some "Wrong return_to in OP response")
205 else
206 return None
65 207
66 fun authenticate id = 208 fun authenticate id =
67 dy <- discover id; 209 dy <- discover id;
68 case dy of 210 case dy of
69 None => return "Discovery failed" 211 None => return "Discovery failed"
70 | Some dy => 212 | Some dy =>
71 assoc <- association dy.Endpoint; 213 assoc <- association dy;
72 case assoc of 214 case assoc of
73 AssError msg => return msg 215 AssError msg => return msg
74 | Association assoc => 216 | Association assoc =>
75 redirect (bless (dy.Endpoint ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id=" 217 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
76 ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle=" 218 ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
77 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo))) 219 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
220
221 task periodic 1 = fn () =>
222 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);
223 dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP);
224 dml (DELETE FROM nonces WHERE Expires < CURRENT_TIMESTAMP)