Mercurial > openid

annotate 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
rev   line source
adam@6 1 val discoveryExpiry = 3600
adam@6 2 val nonceExpiry = 3600
adam@6 3
adam@0 4 task initialize = fn () => OpenidFfi.init
adam@1 5
adam@6 6 table discoveries : { Identifier : string, Endpoint : string, Expires : time }
adam@6 7 PRIMARY KEY Identifier
adam@6 8
adam@2 9 fun discover s =
adam@6 10 endpoint <- oneOrNoRowsE1 (SELECT (discoveries.Endpoint)
adam@6 11 FROM discoveries
adam@6 12 WHERE discoveries.Identifier = {[s]});
adam@6 13 case endpoint of
adam@6 14 Some ep => return (Some ep)
adam@6 15 | None =>
adam@6 16 r <- OpenidFfi.discover s;
adam@6 17 case r of
adam@6 18 None => return None
adam@6 19 | Some r =>
adam@6 20 tm <- now;
adam@6 21 dml (INSERT INTO discoveries (Identifier, Endpoint, Expires)
adam@6 22 VALUES ({[s]}, {[OpenidFfi.endpoint r]}, {[addSeconds tm discoveryExpiry]}));
adam@6 23 return (Some (OpenidFfi.endpoint r))
adam@3 24
adam@3 25 val createInputs =
adam@3 26 is <- OpenidFfi.createInputs;
adam@3 27 OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0";
adam@3 28 return is
adam@3 29
adam@8 30 datatype association_type = HMAC_SHA1 | HMAC_SHA256
adam@8 31 datatype association_session_type = NoEncryption | DH_SHA1 | DH_SHA256
adam@8 32
adam@8 33 table associations : { Endpoint : string, Handle : string, Typ : serialized association_type, Key : string, Expires : time }
adam@3 34 PRIMARY KEY Endpoint
adam@3 35
adam@8 36 datatype association = Association of {Handle : string, Typ : association_type, Key : string}
adam@8 37 | AssError of string
adam@8 38 | AssAlternate of {Atype : association_type, Stype : association_session_type}
adam@3 39
adam@8 40 fun atype_show v =
adam@8 41 case v of
adam@8 42 HMAC_SHA1 => "HMAC-SHA1"
adam@8 43 | HMAC_SHA256 => "HMAC-SHA256"
adam@8 44
adam@8 45 val show_atype = mkShow atype_show
adam@8 46
adam@8 47 fun stype_show v =
adam@8 48 case v of
adam@8 49 NoEncryption => "no-encryption"
adam@8 50 | DH_SHA1 => "DH-SHA1"
adam@8 51 | DH_SHA256 => "DH-SHA256"
adam@8 52
adam@8 53 val show_stype = mkShow stype_show
adam@8 54
adam@8 55 fun atype_read s =
adam@8 56 case s of
adam@8 57 "HMAC-SHA1" => Some HMAC_SHA1
adam@8 58 | "HMAC-SHA256" => Some HMAC_SHA256
adam@8 59 | _ => None
adam@8 60
adam@8 61 val read_atype = mkRead' atype_read "association type"
adam@8 62
adam@8 63 fun stype_read s =
adam@8 64 case s of
adam@8 65 "no-encryption" => Some NoEncryption
adam@8 66 | "DH-SHA1" => Some DH_SHA1
adam@8 67 | "DH-SHA256" => Some DH_SHA256
adam@8 68 | _ => None
adam@8 69
adam@8 70 val read_stype = mkRead' stype_read "association session type"
adam@8 71
adam@8 72 fun atype_eq v1 v2 =
adam@8 73 case (v1, v2) of
adam@8 74 (HMAC_SHA1, HMAC_SHA1) => True
adam@8 75 | (HMAC_SHA256, HMAC_SHA256) => True
adam@8 76 | _ => False
adam@8 77
adam@8 78 val eq_atype = mkEq atype_eq
adam@8 79
adam@8 80 fun stype_eq v1 v2 =
adam@8 81 case (v1, v2) of
adam@8 82 (NoEncryption, NoEncryption) => True
adam@8 83 | (DH_SHA1, DH_SHA1) => True
adam@8 84 | (DH_SHA256, DH_SHA256) => True
adam@8 85 | _ => False
adam@8 86
adam@8 87 val eq_stype = mkEq stype_eq
adam@8 88
adam@8 89 fun errorResult atype stype os =
adam@8 90 case OpenidFfi.getOutput os "error" of
adam@8 91 Some v =>
adam@8 92 (case (OpenidFfi.getOutput os "error_code", OpenidFfi.getOutput os "assoc_type", OpenidFfi.getOutput os "session_type") of
adam@8 93 (Some "unsupported-type", at, st) => Some (AssAlternate {Atype = Option.get atype (Option.bind read at),
adam@8 94 Stype = Option.get stype (Option.bind read st)})
adam@8 95 | _ => Some (AssError ("OP error during association: " ^ v)))
adam@8 96 | None => None
adam@8 97
adam@8 98 fun associateNoEncryption url atype =
adam@8 99 is <- createInputs;
adam@8 100 OpenidFfi.addInput is "openid.mode" "associate";
adam@8 101 OpenidFfi.addInput is "openid.assoc_type" (show atype);
adam@8 102 OpenidFfi.addInput is "openid.session_type" (show NoEncryption);
adam@8 103
adam@8 104 os <- OpenidFfi.direct url is;
adam@8 105 case errorResult atype NoEncryption os of
adam@8 106 Some v => return v
adam@8 107 | None =>
adam@8 108 case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "mac_key", OpenidFfi.getOutput os "expires_in") of
adam@8 109 (Some handle, Some key, Some expires) =>
adam@8 110 (case read expires of
adam@8 111 None => return (AssError "Invalid 'expires_in' field")
adam@8 112 | Some expires =>
adam@8 113 tm <- now;
adam@8 114 dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires)
adam@8 115 VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]}));
adam@8 116 return (Association {Handle = handle, Typ = atype, Key = key}))
adam@8 117 | (None, _, _) => return (AssError "Missing assoc_handle")
adam@8 118 | (_, None, _) => return (AssError "Missing mac_key")
adam@8 119 | _ => return (AssError "Missing expires_in")
adam@8 120
adam@8 121 fun associateDh url atype stype =
adam@8 122 dh <- OpenidFfi.generate;
adam@8 123
adam@8 124 is <- createInputs;
adam@8 125 OpenidFfi.addInput is "openid.mode" "associate";
adam@8 126 OpenidFfi.addInput is "openid.assoc_type" (show atype);
adam@8 127 OpenidFfi.addInput is "openid.session_type" (show stype);
adam@8 128 OpenidFfi.addInput is "openid.dh_modulus" (OpenidFfi.modulus dh);
adam@8 129 OpenidFfi.addInput is "openid.dh_gen" (OpenidFfi.generator dh);
adam@8 130 OpenidFfi.addInput is "openid.dh_consumer_public" (OpenidFfi.public dh);
adam@8 131
adam@8 132 os <- OpenidFfi.direct url is;
adam@8 133 case errorResult atype stype os of
adam@8 134 Some v => return v
adam@8 135 | None =>
adam@8 136 case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "dh_server_public",
adam@8 137 OpenidFfi.getOutput os "enc_mac_key", OpenidFfi.getOutput os "expires_in") of
adam@8 138 (Some handle, Some pub, Some mac, Some expires) =>
adam@8 139 (case read expires of
adam@8 140 None => return (AssError "Invalid 'expires_in' field")
adam@8 141 | Some expires =>
adam@8 142 key <- OpenidFfi.compute dh pub;
adam@8 143 tm <- now;
adam@8 144 dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires)
adam@8 145 VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]}));
adam@8 146 return (Association {Handle = handle, Typ = atype, Key = key}))
adam@8 147 | (None, _, _, _) => return (AssError "Missing assoc_handle")
adam@8 148 | (_, None, _, _) => return (AssError "Missing dh_server_public")
adam@8 149 | (_, _, None, _) => return (AssError "Missing enc_mac_key")
adam@8 150 | _ => return (AssError "Missing expires_in")
adam@8 151
adam@8 152 fun oldAssociation url =
adam@8 153 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Typ, associations.Key
adam@7 154 FROM associations
adam@7 155 WHERE associations.Endpoint = {[url]});
adam@3 156 case secret of
adam@8 157 Some r => return (Some (r -- #Typ ++ {Typ = deserialize r.Typ}))
adam@8 158 | None => return None
adam@8 159
adam@8 160 fun newAssociation url atype stype =
adam@8 161 case stype of
adam@8 162 NoEncryption => associateNoEncryption url atype
adam@8 163 | _ => associateDh url atype stype
adam@8 164
adam@8 165 fun association atype stype url =
adam@8 166 secret <- oldAssociation url;
adam@8 167 case secret of
adam@4 168 Some r => return (Association r)
adam@3 169 | None =>
adam@8 170 stype <- return (case (stype, String.isPrefix {Full = url, Prefix = "https://"}) of
adam@8 171 (NoEncryption, False) => DH_SHA256
adam@8 172 | _ => stype);
adam@8 173 r <- newAssociation url atype stype;
adam@8 174 case r of
adam@8 175 AssAlternate alt =>
adam@8 176 if alt.Atype = atype && alt.Stype = stype then
adam@8 177 return (AssError "Suggested new modes match old ones!")
adam@8 178 else
adam@8 179 newAssociation url alt.Atype alt.Stype
adam@8 180 | v => return v
adam@4 181
adam@6 182 fun eatFragment s =
adam@6 183 case String.split s #"#" of
adam@6 184 Some (_, s') => s'
adam@6 185 | _ => s
adam@6 186
adam@8 187 datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | HandleError of string
adam@6 188
adam@6 189 fun verifyHandle os id =
adam@6 190 ep <- discover (eatFragment id);
adam@6 191 case ep of
adam@6 192 None => return (HandleError "Discovery failed on returned endpoint")
adam@6 193 | Some ep =>
adam@6 194 case OpenidFfi.getOutput os "openid.assoc_handle" of
adam@6 195 None => return (HandleError "Missing association handle in response")
adam@6 196 | Some handle =>
adam@8 197 assoc <- oldAssociation ep;
adam@6 198 case assoc of
adam@8 199 None => return (HandleError "Couldn't find association handle")
adam@8 200 | Some assoc =>
adam@6 201 if assoc.Handle <> handle then
adam@6 202 return (HandleError "Association handles don't match")
adam@6 203 else
adam@8 204 return (HandleOk {Endpoint = ep, Typ = assoc.Typ, Key = assoc.Key})
adam@6 205
adam@6 206 table nonces : { Endpoint : string, Nonce : string, Expires : time }
adam@6 207 PRIMARY KEY (Endpoint, Nonce)
adam@6 208
adam@6 209 fun timeOfNonce s =
adam@6 210 case String.split s #"T" of
adam@6 211 None => None
adam@6 212 | Some (date, s) =>
adam@6 213 case String.split s #"Z" of
adam@6 214 None => None
adam@7 215 | Some (time, _) => readUtc (date ^ " " ^ time)
adam@6 216
adam@6 217 fun verifyNonce os ep =
adam@6 218 case OpenidFfi.getOutput os "openid.response_nonce" of
adam@6 219 None => return (Some "Missing nonce in OP response")
adam@6 220 | Some nonce =>
adam@6 221 case timeOfNonce nonce of
adam@6 222 None => return (Some "Invalid timestamp in nonce")
adam@6 223 | Some tm =>
adam@6 224 now <- now;
adam@6 225 exp <- return (addSeconds now nonceExpiry);
adam@6 226 if tm < exp then
adam@6 227 return (Some "Nonce timestamp is too old")
adam@6 228 else
adam@6 229 b <- oneRowE1 (SELECT COUNT( * ) > 0
adam@6 230 FROM nonces
adam@6 231 WHERE nonces.Endpoint = {[ep]}
adam@6 232 AND nonces.Nonce = {[nonce]});
adam@6 233
adam@6 234 if b then
adam@6 235 return (Some "Duplicate nonce")
adam@6 236 else
adam@7 237 debug ("Nonce expires: " ^ show exp);
adam@6 238 dml (INSERT INTO nonces (Endpoint, Nonce, Expires)
adam@6 239 VALUES ({[ep]}, {[nonce]}, {[exp]}));
adam@6 240 return None
adam@6 241
adam@8 242 fun verifySig os atype key =
adam@6 243 case OpenidFfi.getOutput os "openid.signed" of
adam@6 244 None => return (Some "Missing openid.signed in OP response")
adam@6 245 | Some signed =>
adam@6 246 case OpenidFfi.getOutput os "openid.sig" of
adam@6 247 None => return (Some "Missing openid.sig in OP response")
adam@6 248 | Some sign => let
adam@6 249 fun gatherNvps signed acc =
adam@6 250 let
adam@6 251 val (this, next) =
adam@6 252 case String.split signed #"," of
adam@6 253 None => (signed, None)
adam@6 254 | Some (this, next) => (this, Some next)
adam@6 255 in
adam@6 256 case OpenidFfi.getOutput os ("openid." ^ this) of
adam@6 257 None => None
adam@6 258 | Some value =>
adam@6 259 let
adam@6 260 val acc = acc ^ this ^ ":" ^ value ^ "\n"
adam@6 261 in
adam@6 262 case next of
adam@6 263 None => Some acc
adam@6 264 | Some next => gatherNvps next acc
adam@6 265 end
adam@6 266 end
adam@6 267 in
adam@6 268 case gatherNvps signed "" of
adam@6 269 None => return (Some "openid.signed mentions missing field")
adam@6 270 | Some nvps =>
adam@6 271 let
adam@8 272 val sign' = case atype of
adam@8 273 HMAC_SHA256 => OpenidFfi.sha256 key nvps
adam@8 274 | HMAC_SHA1 => OpenidFfi.sha1 key nvps
adam@6 275 in
adam@6 276 debug ("Fields: " ^ signed);
adam@6 277 debug ("Nvps: " ^ nvps);
adam@7 278 debug ("Key: " ^ key);
adam@6 279 debug ("His: " ^ sign);
adam@6 280 debug ("Mine: " ^ sign');
adam@6 281 if sign' = sign then
adam@6 282 return None
adam@6 283 else
adam@6 284 return (Some "Signatures don't match")
adam@6 285 end
adam@6 286 end
adam@6 287
adam@4 288 fun returnTo (qs : option queryString) =
adam@4 289 case qs of
adam@4 290 None => error <xml>Empty query string for OpenID callback</xml>
adam@4 291 | Some qs =>
adam@4 292 os <- OpenidFfi.indirect qs;
adam@4 293 case OpenidFfi.getOutput os "openid.error" of
adam@4 294 Some v => error <xml>Authentication failed: {[v]}</xml>
adam@4 295 | None =>
adam@5 296 case OpenidFfi.getOutput os "openid.mode" of
adam@6 297 None => error <xml>No <tt>openid.mode</tt> in response ({[qs]})</xml>
adam@5 298 | Some mode =>
adam@5 299 case mode of
adam@5 300 "cancel" => error <xml>You canceled the authentication!</xml>
adam@5 301 | "id_res" =>
adam@5 302 (case OpenidFfi.getOutput os "openid.identity" of
adam@5 303 None => error <xml>Missing identity in OP response</xml>
adam@6 304 | Some id =>
adam@6 305 errO <- verifyHandle os id;
adam@6 306 case errO of
adam@6 307 HandleError s => error <xml>{[s]}</xml>
adam@8 308 | HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
adam@6 309 errO <- verifyReturnTo os;
adam@6 310 case errO of
adam@6 311 Some s => error <xml>{[s]}</xml>
adam@6 312 | None =>
adam@6 313 errO <- verifyNonce os ep;
adam@6 314 case errO of
adam@6 315 Some s => error <xml>{[s]}</xml>
adam@6 316 | None =>
adam@8 317 errO <- verifySig os atype key;
adam@6 318 case errO of
adam@6 319 Some s => error <xml>{[s]}</xml>
adam@6 320 | None => return <xml>Identity: {[id]}</xml>)
adam@5 321 | _ => error <xml>Unexpected <tt>openid.mode</tt>: <tt>{[mode]}</tt></xml>
adam@4 322
adam@6 323 and verifyReturnTo os =
adam@6 324 case OpenidFfi.getOutput os "openid.return_to" of
adam@6 325 None => return (Some "Missing return_to in OP response")
adam@6 326 | Some rt =>
adam@6 327 if rt <> show (effectfulUrl returnTo) then
adam@6 328 return (Some "Wrong return_to in OP response")
adam@6 329 else
adam@6 330 return None
adam@6 331
adam@8 332 fun authenticate atype stype id =
adam@4 333 dy <- discover id;
adam@4 334 case dy of
adam@4 335 None => return "Discovery failed"
adam@4 336 | Some dy =>
adam@8 337 assoc <- association atype stype dy;
adam@4 338 case assoc of
adam@8 339 AssError msg => return ("Association failure: " ^ msg)
adam@8 340 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
adam@4 341 | Association assoc =>
adam@6 342 redirect (bless (dy ^ "?openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup&openid.claimed_id="
adam@4 343 ^ id ^ "&openid.identity=http://specs.openid.net/auth/2.0/identifier_select&openid.assoc_handle="
adam@4 344 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo)))
adam@6 345
adam@6 346 task periodic 1 = fn () =>
adam@6 347 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);
adam@6 348 dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP);
adam@6 349 dml (DELETE FROM nonces WHERE Expires < CURRENT_TIMESTAMP)