Mercurial > openid

comparison src/ur/openid.ur @ 8:870d99055dd1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Diffie-Hellman started but not fully tested; successfully checked signature from AOL
author Adam Chlipala <adam@chlipala.net>
date Wed, 29 Dec 2010 12:16:32 -0500
parents 976121190b2d
children 426dd5c88df1
comparison
equal deleted inserted replaced
7:976121190b2d 8:870d99055dd1
25 val createInputs = 25 val createInputs =
26 is <- OpenidFfi.createInputs; 26 is <- OpenidFfi.createInputs;
27 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";
28 return is 28 return is
29 29
30 table associations : { Endpoint : string, Handle : string, Key : string, Expires : time } 30 datatype association_type = HMAC_SHA1 | HMAC_SHA256
31 datatype association_session_type = NoEncryption | DH_SHA1 | DH_SHA256
32
33 table associations : { Endpoint : string, Handle : string, Typ : serialized association_type, Key : string, Expires : time }
31 PRIMARY KEY Endpoint 34 PRIMARY KEY Endpoint
32 35
33 datatype association = Association of {Handle : string, Key : string} | AssError of string 36 datatype association = Association of {Handle : string, Typ : association_type, Key : string}
34 37 | AssError of string
35 fun association url = 38 | AssAlternate of {Atype : association_type, Stype : association_session_type}
36 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Key 39
40 fun atype_show v =
41 case v of
42 HMAC_SHA1 => "HMAC-SHA1"
43 | HMAC_SHA256 => "HMAC-SHA256"
44
45 val show_atype = mkShow atype_show
46
47 fun stype_show v =
48 case v of
49 NoEncryption => "no-encryption"
50 | DH_SHA1 => "DH-SHA1"
51 | DH_SHA256 => "DH-SHA256"
52
53 val show_stype = mkShow stype_show
54
55 fun atype_read s =
56 case s of
57 "HMAC-SHA1" => Some HMAC_SHA1
58 | "HMAC-SHA256" => Some HMAC_SHA256
59 | _ => None
60
61 val read_atype = mkRead' atype_read "association type"
62
63 fun stype_read s =
64 case s of
65 "no-encryption" => Some NoEncryption
66 | "DH-SHA1" => Some DH_SHA1
67 | "DH-SHA256" => Some DH_SHA256
68 | _ => None
69
70 val read_stype = mkRead' stype_read "association session type"
71
72 fun atype_eq v1 v2 =
73 case (v1, v2) of
74 (HMAC_SHA1, HMAC_SHA1) => True
75 | (HMAC_SHA256, HMAC_SHA256) => True
76 | _ => False
77
78 val eq_atype = mkEq atype_eq
79
80 fun stype_eq v1 v2 =
81 case (v1, v2) of
82 (NoEncryption, NoEncryption) => True
83 | (DH_SHA1, DH_SHA1) => True
84 | (DH_SHA256, DH_SHA256) => True
85 | _ => False
86
87 val eq_stype = mkEq stype_eq
88
89 fun errorResult atype stype os =
90 case OpenidFfi.getOutput os "error" of
91 Some v =>
92 (case (OpenidFfi.getOutput os "error_code", OpenidFfi.getOutput os "assoc_type", OpenidFfi.getOutput os "session_type") of
93 (Some "unsupported-type", at, st) => Some (AssAlternate {Atype = Option.get atype (Option.bind read at),
94 Stype = Option.get stype (Option.bind read st)})
95 | _ => Some (AssError ("OP error during association: " ^ v)))
96 | None => None
97
98 fun associateNoEncryption url atype =
99 is <- createInputs;
100 OpenidFfi.addInput is "openid.mode" "associate";
101 OpenidFfi.addInput is "openid.assoc_type" (show atype);
102 OpenidFfi.addInput is "openid.session_type" (show NoEncryption);
103
104 os <- OpenidFfi.direct url is;
105 case errorResult atype NoEncryption os of
106 Some v => return v
107 | None =>
108 case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "mac_key", OpenidFfi.getOutput os "expires_in") of
109 (Some handle, Some key, Some expires) =>
110 (case read expires of
111 None => return (AssError "Invalid 'expires_in' field")
112 | Some expires =>
113 tm <- now;
114 dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires)
115 VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]}));
116 return (Association {Handle = handle, Typ = atype, Key = key}))
117 | (None, _, _) => return (AssError "Missing assoc_handle")
118 | (_, None, _) => return (AssError "Missing mac_key")
119 | _ => return (AssError "Missing expires_in")
120
121 fun associateDh url atype stype =
122 dh <- OpenidFfi.generate;
123
124 is <- createInputs;
125 OpenidFfi.addInput is "openid.mode" "associate";
126 OpenidFfi.addInput is "openid.assoc_type" (show atype);
127 OpenidFfi.addInput is "openid.session_type" (show stype);
128 OpenidFfi.addInput is "openid.dh_modulus" (OpenidFfi.modulus dh);
129 OpenidFfi.addInput is "openid.dh_gen" (OpenidFfi.generator dh);
130 OpenidFfi.addInput is "openid.dh_consumer_public" (OpenidFfi.public dh);
131
132 os <- OpenidFfi.direct url is;
133 case errorResult atype stype os of
134 Some v => return v
135 | None =>
136 case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "dh_server_public",
137 OpenidFfi.getOutput os "enc_mac_key", OpenidFfi.getOutput os "expires_in") of
138 (Some handle, Some pub, Some mac, Some expires) =>
139 (case read expires of
140 None => return (AssError "Invalid 'expires_in' field")
141 | Some expires =>
142 key <- OpenidFfi.compute dh pub;
143 tm <- now;
144 dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires)
145 VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]}));
146 return (Association {Handle = handle, Typ = atype, Key = key}))
147 | (None, _, _, _) => return (AssError "Missing assoc_handle")
148 | (_, None, _, _) => return (AssError "Missing dh_server_public")
149 | (_, _, None, _) => return (AssError "Missing enc_mac_key")
150 | _ => return (AssError "Missing expires_in")
151
152 fun oldAssociation url =
153 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Typ, associations.Key
37 FROM associations 154 FROM associations
38 WHERE associations.Endpoint = {[url]}); 155 WHERE associations.Endpoint = {[url]});
39 case secret of 156 case secret of
157 Some r => return (Some (r -- #Typ ++ {Typ = deserialize r.Typ}))
158 | None => return None
159
160 fun newAssociation url atype stype =
161 case stype of
162 NoEncryption => associateNoEncryption url atype
163 | _ => associateDh url atype stype
164
165 fun association atype stype url =
166 secret <- oldAssociation url;
167 case secret of
40 Some r => return (Association r) 168 Some r => return (Association r)
41 | None => 169 | None =>
42 is <- createInputs; 170 stype <- return (case (stype, String.isPrefix {Full = url, Prefix = "https://"}) of
43 OpenidFfi.addInput is "openid.mode" "associate"; 171 (NoEncryption, False) => DH_SHA256
44 OpenidFfi.addInput is "openid.assoc_type" "HMAC-SHA256"; 172 | _ => stype);
45 OpenidFfi.addInput is "openid.session_type" "no-encryption"; 173 r <- newAssociation url atype stype;
46 174 case r of
47 debug ("Contacting " ^ url); 175 AssAlternate alt =>
48 176 if alt.Atype = atype && alt.Stype = stype then
49 os <- OpenidFfi.direct url is; 177 return (AssError "Suggested new modes match old ones!")
50 case OpenidFfi.getOutput os "error" of 178 else
51 Some v => return (AssError v) 179 newAssociation url alt.Atype alt.Stype
52 | None => 180 | v => return v
53 case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "mac_key", OpenidFfi.getOutput os "expires_in") of
54 (Some handle, Some key, Some expires) =>
55 (case read expires of
56 None => return (AssError "Invalid 'expires_in' field")
57 | Some expires =>
58 tm <- now;
59 dml (INSERT INTO associations (Endpoint, Handle, Key, Expires)
60 VALUES ({[url]}, {[handle]}, {[key]}, {[addSeconds tm expires]}));
61 return (Association {Handle = handle, Key = key}))
62 | (None, _, _) => return (AssError "Missing assoc_handle")
63 | (_, None, _) => return (AssError "Missing mac_key")
64 | _ => return (AssError "Missing fields in response from OP")
65 181
66 fun eatFragment s = 182 fun eatFragment s =
67 case String.split s #"#" of 183 case String.split s #"#" of
68 Some (_, s') => s' 184 Some (_, s') => s'
69 | _ => s 185 | _ => s
70 186
71 datatype handle_result = HandleOk of {Endpoint : string, Key : string} | HandleError of string 187 datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | HandleError of string
72 188
73 fun verifyHandle os id = 189 fun verifyHandle os id =
74 ep <- discover (eatFragment id); 190 ep <- discover (eatFragment id);
75 case ep of 191 case ep of
76 None => return (HandleError "Discovery failed on returned endpoint") 192 None => return (HandleError "Discovery failed on returned endpoint")
77 | Some ep => 193 | Some ep =>
78 case OpenidFfi.getOutput os "openid.assoc_handle" of 194 case OpenidFfi.getOutput os "openid.assoc_handle" of
79 None => return (HandleError "Missing association handle in response") 195 None => return (HandleError "Missing association handle in response")
80 | Some handle => 196 | Some handle =>
81 assoc <- association ep; 197 assoc <- oldAssociation ep;
82 case assoc of 198 case assoc of
83 AssError s => return (HandleError s) 199 None => return (HandleError "Couldn't find association handle")
84 | Association assoc => 200 | Some assoc =>
85 if assoc.Handle <> handle then 201 if assoc.Handle <> handle then
86 return (HandleError "Association handles don't match") 202 return (HandleError "Association handles don't match")
87 else 203 else
88 return (HandleOk {Endpoint = ep, Key = assoc.Key}) 204 return (HandleOk {Endpoint = ep, Typ = assoc.Typ, Key = assoc.Key})
89 205
90 table nonces : { Endpoint : string, Nonce : string, Expires : time } 206 table nonces : { Endpoint : string, Nonce : string, Expires : time }
91 PRIMARY KEY (Endpoint, Nonce) 207 PRIMARY KEY (Endpoint, Nonce)
92 208
93 fun timeOfNonce s = 209 fun timeOfNonce s =
121 debug ("Nonce expires: " ^ show exp); 237 debug ("Nonce expires: " ^ show exp);
122 dml (INSERT INTO nonces (Endpoint, Nonce, Expires) 238 dml (INSERT INTO nonces (Endpoint, Nonce, Expires)
123 VALUES ({[ep]}, {[nonce]}, {[exp]})); 239 VALUES ({[ep]}, {[nonce]}, {[exp]}));
124 return None 240 return None
125 241
126 fun verifySig os key = 242 fun verifySig os atype key =
127 case OpenidFfi.getOutput os "openid.signed" of 243 case OpenidFfi.getOutput os "openid.signed" of
128 None => return (Some "Missing openid.signed in OP response") 244 None => return (Some "Missing openid.signed in OP response")
129 | Some signed => 245 | Some signed =>
130 case OpenidFfi.getOutput os "openid.sig" of 246 case OpenidFfi.getOutput os "openid.sig" of
131 None => return (Some "Missing openid.sig in OP response") 247 None => return (Some "Missing openid.sig in OP response")
151 in 267 in
152 case gatherNvps signed "" of 268 case gatherNvps signed "" of
153 None => return (Some "openid.signed mentions missing field") 269 None => return (Some "openid.signed mentions missing field")
154 | Some nvps => 270 | Some nvps =>
155 let 271 let
156 val sign' = OpenidFfi.sha256 key nvps 272 val sign' = case atype of
273 HMAC_SHA256 => OpenidFfi.sha256 key nvps
274 | HMAC_SHA1 => OpenidFfi.sha1 key nvps
157 in 275 in
158 debug ("Fields: " ^ signed); 276 debug ("Fields: " ^ signed);
159 debug ("Nvps: " ^ nvps); 277 debug ("Nvps: " ^ nvps);
160 debug ("Key: " ^ key); 278 debug ("Key: " ^ key);
161 debug ("His: " ^ sign); 279 debug ("His: " ^ sign);
185 None => error <xml>Missing identity in OP response</xml> 303 None => error <xml>Missing identity in OP response</xml>
186 | Some id => 304 | Some id =>
187 errO <- verifyHandle os id; 305 errO <- verifyHandle os id;
188 case errO of 306 case errO of
189 HandleError s => error <xml>{[s]}</xml> 307 HandleError s => error <xml>{[s]}</xml>
190 | HandleOk {Endpoint = ep, Key = key} => 308 | HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
191 errO <- verifyReturnTo os; 309 errO <- verifyReturnTo os;
192 case errO of 310 case errO of
193 Some s => error <xml>{[s]}</xml> 311 Some s => error <xml>{[s]}</xml>
194 | None => 312 | None =>
195 errO <- verifyNonce os ep; 313 errO <- verifyNonce os ep;
196 case errO of 314 case errO of
197 Some s => error <xml>{[s]}</xml> 315 Some s => error <xml>{[s]}</xml>
198 | None => 316 | None =>
199 errO <- verifySig os key; 317 errO <- verifySig os atype key;
200 case errO of 318 case errO of
201 Some s => error <xml>{[s]}</xml> 319 Some s => error <xml>{[s]}</xml>
202 | None => return <xml>Identity: {[id]}</xml>) 320 | None => return <xml>Identity: {[id]}</xml>)
203 | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml> 321 | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml>
204 322
209 if rt <> show (effectfulUrl returnTo) then 327 if rt <> show (effectfulUrl returnTo) then
210 return (Some "Wrong return_to in OP response") 328 return (Some "Wrong return_to in OP response")
211 else 329 else
212 return None 330 return None
213 331
214 fun authenticate id = 332 fun authenticate atype stype id =
215 dy <- discover id; 333 dy <- discover id;
216 case dy of 334 case dy of
217 None => return "Discovery failed" 335 None => return "Discovery failed"
218 | Some dy => 336 | Some dy =>
219 assoc <- association dy; 337 assoc <- association atype stype dy;
220 case assoc of 338 case assoc of
221 AssError msg => return msg 339 AssError msg => return ("Association failure: " ^ msg)
340 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
222 | Association assoc => 341 | Association assoc =>
223 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id=" 342 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
224 ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle=" 343 ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
225 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo))) 344 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
226 345