Mercurial > openid

annotate src/ur/openid.ur @ 58:9f392276d614

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Graceful handling of OpenID providers that log the user in as the wrong identifier
author Adam Chlipala <adam@chlipala.net>
date Tue, 09 Aug 2011 09:53:40 -0400
parents f8c9e1e4d337
children
rev   line source
adam@6 1 val discoveryExpiry = 3600
adam@11 2 val nonceExpiry = 600
adam@11 3 val nonceSkew = 600
adam@6 4
adam@0 5 task initialize = fn () => OpenidFfi.init
adam@1 6
adam@6 7 table discoveries : { Identifier : string, Endpoint : string, Expires : time }
adam@6 8 PRIMARY KEY Identifier
adam@6 9
adam@17 10 fun eatFragment s =
adam@17 11 case String.split s #"#" of
adam@17 12 Some (s', _) => s'
adam@17 13 | _ => s
adam@17 14
adam@2 15 fun discover s =
adam@17 16 s <- return (eatFragment s);
adam@6 17 endpoint <- oneOrNoRowsE1 (SELECT (discoveries.Endpoint)
adam@6 18 FROM discoveries
adam@6 19 WHERE discoveries.Identifier = {[s]});
adam@6 20 case endpoint of
adam@6 21 Some ep => return (Some ep)
adam@6 22 | None =>
adam@6 23 r <- OpenidFfi.discover s;
adam@6 24 case r of
adam@6 25 None => return None
adam@6 26 | Some r =>
adam@6 27 tm <- now;
adam@6 28 dml (INSERT INTO discoveries (Identifier, Endpoint, Expires)
adam@6 29 VALUES ({[s]}, {[OpenidFfi.endpoint r]}, {[addSeconds tm discoveryExpiry]}));
adam@6 30 return (Some (OpenidFfi.endpoint r))
adam@3 31
adam@3 32 val createInputs =
adam@3 33 is <- OpenidFfi.createInputs;
adam@3 34 OpenidFfi.addInput is "openid.ns" "http://specs.openid.net/auth/2.0";
adam@3 35 return is
adam@3 36
adam@8 37 datatype association_type = HMAC_SHA1 | HMAC_SHA256
adam@8 38 datatype association_session_type = NoEncryption | DH_SHA1 | DH_SHA256
adam@13 39 datatype association_mode =
adam@13 40 Stateless
adam@13 41 | Stateful of {AssociationType : association_type,
adam@13 42 AssociationSessionType : association_session_type}
adam@8 43
adam@39 44 datatype authentication_mode =
adam@39 45 ChooseIdentifier of string
adam@39 46 | KnownIdentifier of string
adam@39 47
adam@8 48 table associations : { Endpoint : string, Handle : string, Typ : serialized association_type, Key : string, Expires : time }
adam@3 49 PRIMARY KEY Endpoint
adam@3 50
adam@8 51 datatype association = Association of {Handle : string, Typ : association_type, Key : string}
adam@8 52 | AssError of string
adam@8 53 | AssAlternate of {Atype : association_type, Stype : association_session_type}
adam@3 54
adam@8 55 fun atype_show v =
adam@8 56 case v of
adam@8 57 HMAC_SHA1 => "HMAC-SHA1"
adam@8 58 | HMAC_SHA256 => "HMAC-SHA256"
adam@8 59
adam@8 60 val show_atype = mkShow atype_show
adam@8 61
adam@8 62 fun stype_show v =
adam@8 63 case v of
adam@8 64 NoEncryption => "no-encryption"
adam@8 65 | DH_SHA1 => "DH-SHA1"
adam@8 66 | DH_SHA256 => "DH-SHA256"
adam@8 67
adam@8 68 val show_stype = mkShow stype_show
adam@8 69
adam@8 70 fun atype_read s =
adam@8 71 case s of
adam@8 72 "HMAC-SHA1" => Some HMAC_SHA1
adam@8 73 | "HMAC-SHA256" => Some HMAC_SHA256
adam@8 74 | _ => None
adam@8 75
adam@8 76 val read_atype = mkRead' atype_read "association type"
adam@8 77
adam@8 78 fun stype_read s =
adam@8 79 case s of
adam@8 80 "no-encryption" => Some NoEncryption
adam@8 81 | "DH-SHA1" => Some DH_SHA1
adam@8 82 | "DH-SHA256" => Some DH_SHA256
adam@8 83 | _ => None
adam@8 84
adam@8 85 val read_stype = mkRead' stype_read "association session type"
adam@8 86
adam@8 87 fun atype_eq v1 v2 =
adam@8 88 case (v1, v2) of
adam@8 89 (HMAC_SHA1, HMAC_SHA1) => True
adam@8 90 | (HMAC_SHA256, HMAC_SHA256) => True
adam@8 91 | _ => False
adam@8 92
adam@8 93 val eq_atype = mkEq atype_eq
adam@8 94
adam@8 95 fun stype_eq v1 v2 =
adam@8 96 case (v1, v2) of
adam@8 97 (NoEncryption, NoEncryption) => True
adam@8 98 | (DH_SHA1, DH_SHA1) => True
adam@8 99 | (DH_SHA256, DH_SHA256) => True
adam@8 100 | _ => False
adam@8 101
adam@8 102 val eq_stype = mkEq stype_eq
adam@8 103
adam@8 104 fun errorResult atype stype os =
adam@8 105 case OpenidFfi.getOutput os "error" of
adam@8 106 Some v =>
adam@8 107 (case (OpenidFfi.getOutput os "error_code", OpenidFfi.getOutput os "assoc_type", OpenidFfi.getOutput os "session_type") of
adam@8 108 (Some "unsupported-type", at, st) => Some (AssAlternate {Atype = Option.get atype (Option.bind read at),
adam@8 109 Stype = Option.get stype (Option.bind read st)})
adam@8 110 | _ => Some (AssError ("OP error during association: " ^ v)))
adam@8 111 | None => None
adam@8 112
adam@27 113 fun eatQstring s =
adam@27 114 case String.split s #"?" of
adam@27 115 Some (s', _) => s'
adam@27 116 | _ => s
adam@27 117
adam@8 118 fun associateNoEncryption url atype =
adam@27 119 url <- return (eatQstring url);
adam@8 120 is <- createInputs;
adam@8 121 OpenidFfi.addInput is "openid.mode" "associate";
adam@8 122 OpenidFfi.addInput is "openid.assoc_type" (show atype);
adam@8 123 OpenidFfi.addInput is "openid.session_type" (show NoEncryption);
adam@8 124
adam@8 125 os <- OpenidFfi.direct url is;
adam@8 126 case errorResult atype NoEncryption os of
adam@8 127 Some v => return v
adam@8 128 | None =>
adam@8 129 case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "mac_key", OpenidFfi.getOutput os "expires_in") of
adam@8 130 (Some handle, Some key, Some expires) =>
adam@8 131 (case read expires of
adam@8 132 None => return (AssError "Invalid 'expires_in' field")
adam@8 133 | Some expires =>
adam@8 134 tm <- now;
adam@8 135 dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires)
adam@8 136 VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]}));
adam@8 137 return (Association {Handle = handle, Typ = atype, Key = key}))
adam@8 138 | (None, _, _) => return (AssError "Missing assoc_handle")
adam@8 139 | (_, None, _) => return (AssError "Missing mac_key")
adam@8 140 | _ => return (AssError "Missing expires_in")
adam@8 141
adam@8 142 fun associateDh url atype stype =
adam@27 143 url <- return (eatQstring url);
adam@8 144 dh <- OpenidFfi.generate;
adam@8 145
adam@8 146 is <- createInputs;
adam@8 147 OpenidFfi.addInput is "openid.mode" "associate";
adam@8 148 OpenidFfi.addInput is "openid.assoc_type" (show atype);
adam@8 149 OpenidFfi.addInput is "openid.session_type" (show stype);
adam@8 150 OpenidFfi.addInput is "openid.dh_modulus" (OpenidFfi.modulus dh);
adam@8 151 OpenidFfi.addInput is "openid.dh_gen" (OpenidFfi.generator dh);
adam@8 152 OpenidFfi.addInput is "openid.dh_consumer_public" (OpenidFfi.public dh);
adam@8 153
adam@8 154 os <- OpenidFfi.direct url is;
adam@8 155 case errorResult atype stype os of
adam@8 156 Some v => return v
adam@8 157 | None =>
adam@8 158 case (OpenidFfi.getOutput os "assoc_handle", OpenidFfi.getOutput os "dh_server_public",
adam@8 159 OpenidFfi.getOutput os "enc_mac_key", OpenidFfi.getOutput os "expires_in") of
adam@8 160 (Some handle, Some pub, Some mac, Some expires) =>
adam@8 161 (case read expires of
adam@8 162 None => return (AssError "Invalid 'expires_in' field")
adam@8 163 | Some expires =>
adam@12 164 secret <- OpenidFfi.compute dh pub;
adam@12 165 digest <- return (case stype of
adam@12 166 DH_SHA1 => OpenidFfi.sha1 secret
adam@12 167 | DH_SHA256 => OpenidFfi.sha256 secret
adam@12 168 | _ => error <xml>Non-DH stype in associateDh</xml>);
adam@12 169 key <- return (OpenidFfi.xor mac digest);
adam@8 170 tm <- now;
adam@8 171 dml (INSERT INTO associations (Endpoint, Handle, Typ, Key, Expires)
adam@8 172 VALUES ({[url]}, {[handle]}, {[serialize atype]}, {[key]}, {[addSeconds tm expires]}));
adam@8 173 return (Association {Handle = handle, Typ = atype, Key = key}))
adam@8 174 | (None, _, _, _) => return (AssError "Missing assoc_handle")
adam@8 175 | (_, None, _, _) => return (AssError "Missing dh_server_public")
adam@8 176 | (_, _, None, _) => return (AssError "Missing enc_mac_key")
adam@8 177 | _ => return (AssError "Missing expires_in")
adam@8 178
adam@8 179 fun oldAssociation url =
adam@27 180 url <- return (eatQstring url);
adam@8 181 secret <- oneOrNoRows1 (SELECT associations.Handle, associations.Typ, associations.Key
adam@7 182 FROM associations
adam@7 183 WHERE associations.Endpoint = {[url]});
adam@3 184 case secret of
adam@8 185 Some r => return (Some (r -- #Typ ++ {Typ = deserialize r.Typ}))
adam@8 186 | None => return None
adam@8 187
adam@8 188 fun newAssociation url atype stype =
adam@8 189 case stype of
adam@8 190 NoEncryption => associateNoEncryption url atype
adam@8 191 | _ => associateDh url atype stype
adam@8 192
adam@8 193 fun association atype stype url =
adam@8 194 secret <- oldAssociation url;
adam@8 195 case secret of
adam@4 196 Some r => return (Association r)
adam@3 197 | None =>
adam@8 198 stype <- return (case (stype, String.isPrefix {Full = url, Prefix = "https://"}) of
adam@8 199 (NoEncryption, False) => DH_SHA256
adam@8 200 | _ => stype);
adam@8 201 r <- newAssociation url atype stype;
adam@8 202 case r of
adam@8 203 AssAlternate alt =>
adam@8 204 if alt.Atype = atype && alt.Stype = stype then
adam@8 205 return (AssError "Suggested new modes match old ones!")
adam@8 206 else
adam@12 207 debug "Renegotiating protocol";
adam@8 208 newAssociation url alt.Atype alt.Stype
adam@8 209 | v => return v
adam@4 210
adam@13 211 datatype handle_result = HandleOk of {Endpoint : string, Typ : association_type, Key : string} | NoAssociation of string | HandleError of string
adam@13 212
adam@13 213 datatype authentication = AuthenticatedAs of string | Canceled | Failure of string
adam@6 214
adam@6 215 fun verifyHandle os id =
adam@10 216 id' <- return (eatFragment id);
adam@10 217 ep <- discover id';
adam@6 218 case ep of
adam@10 219 None => return (HandleError ("Discovery failed on returned identifier: " ^ id'))
adam@6 220 | Some ep =>
adam@6 221 case OpenidFfi.getOutput os "openid.assoc_handle" of
adam@6 222 None => return (HandleError "Missing association handle in response")
adam@6 223 | Some handle =>
adam@8 224 assoc <- oldAssociation ep;
adam@6 225 case assoc of
adam@13 226 None => return (NoAssociation ep)
adam@8 227 | Some assoc =>
adam@6 228 if assoc.Handle <> handle then
adam@6 229 return (HandleError "Association handles don't match")
adam@6 230 else
adam@8 231 return (HandleOk {Endpoint = ep, Typ = assoc.Typ, Key = assoc.Key})
adam@6 232
adam@14 233 fun verifyStateless os ep id expectInvalidation =
adam@13 234 os' <- OpenidFfi.direct ep (OpenidFfi.remode os "check_authentication");
adam@13 235 case OpenidFfi.getOutput os' "error" of
adam@13 236 Some msg => return (Failure ("Failure confirming message contents with OP: " ^ msg))
adam@13 237 | None =>
adam@14 238 let
adam@14 239 fun finish () = case OpenidFfi.getOutput os' "is_valid" of
adam@14 240 Some "true" => return (AuthenticatedAs id)
adam@14 241 | _ => return (Failure "OP does not confirm message contents")
adam@14 242 in
adam@14 243 case OpenidFfi.getOutput os' "invalidate_handle" of
adam@14 244 None =>
adam@14 245 if expectInvalidation then
adam@14 246 return (Failure "Claimed invalidate_handle is not confirmed")
adam@14 247 else
adam@14 248 finish ()
adam@14 249 | Some handle =>
adam@14 250 dml (DELETE FROM associations
adam@14 251 WHERE Endpoint = {[ep]} AND Handle = {[handle]});
adam@14 252 finish ()
adam@14 253 end
adam@13 254
adam@6 255 table nonces : { Endpoint : string, Nonce : string, Expires : time }
adam@6 256 PRIMARY KEY (Endpoint, Nonce)
adam@6 257
adam@6 258 fun timeOfNonce s =
adam@6 259 case String.split s #"T" of
adam@6 260 None => None
adam@6 261 | Some (date, s) =>
adam@6 262 case String.split s #"Z" of
adam@6 263 None => None
adam@7 264 | Some (time, _) => readUtc (date ^ " " ^ time)
adam@6 265
adam@6 266 fun verifyNonce os ep =
adam@6 267 case OpenidFfi.getOutput os "openid.response_nonce" of
adam@6 268 None => return (Some "Missing nonce in OP response")
adam@6 269 | Some nonce =>
adam@6 270 case timeOfNonce nonce of
adam@6 271 None => return (Some "Invalid timestamp in nonce")
adam@6 272 | Some tm =>
adam@6 273 now <- now;
adam@9 274 if tm < addSeconds now (-nonceExpiry) then
adam@6 275 return (Some "Nonce timestamp is too old")
adam@9 276 else if tm > addSeconds now nonceSkew then
adam@11 277 return (Some "Nonce timestamp is too far in the future")
adam@6 278 else
adam@6 279 b <- oneRowE1 (SELECT COUNT( * ) > 0
adam@6 280 FROM nonces
adam@6 281 WHERE nonces.Endpoint = {[ep]}
adam@6 282 AND nonces.Nonce = {[nonce]});
adam@6 283
adam@6 284 if b then
adam@6 285 return (Some "Duplicate nonce")
adam@6 286 else
adam@6 287 dml (INSERT INTO nonces (Endpoint, Nonce, Expires)
adam@9 288 VALUES ({[ep]}, {[nonce]}, {[addSeconds now nonceExpiry]}));
adam@6 289 return None
adam@6 290
adam@8 291 fun verifySig os atype key =
adam@6 292 case OpenidFfi.getOutput os "openid.signed" of
adam@6 293 None => return (Some "Missing openid.signed in OP response")
adam@6 294 | Some signed =>
adam@6 295 case OpenidFfi.getOutput os "openid.sig" of
adam@6 296 None => return (Some "Missing openid.sig in OP response")
adam@6 297 | Some sign => let
adam@9 298 fun gatherNvps signed required acc =
adam@6 299 let
adam@6 300 val (this, next) =
adam@6 301 case String.split signed #"," of
adam@6 302 None => (signed, None)
adam@6 303 | Some (this, next) => (this, Some next)
adam@6 304 in
adam@6 305 case OpenidFfi.getOutput os ("openid." ^ this) of
adam@6 306 None => None
adam@6 307 | Some value =>
adam@6 308 let
adam@9 309 val required = List.filter (fn other => other <> this) required
adam@6 310 val acc = acc ^ this ^ ":" ^ value ^ "\n"
adam@6 311 in
adam@6 312 case next of
adam@9 313 None => Some (required, acc)
adam@9 314 | Some next => gatherNvps next required acc
adam@6 315 end
adam@6 316 end
adam@6 317 in
adam@9 318 case gatherNvps signed ("op_endpoint" :: "return_to" :: "response_nonce" :: "assoc_handle" :: "claimed_id" :: "identity" :: []) "" of
adam@6 319 None => return (Some "openid.signed mentions missing field")
adam@9 320 | Some ([], nvps) =>
adam@6 321 let
adam@8 322 val sign' = case atype of
adam@12 323 HMAC_SHA256 => OpenidFfi.hmac_sha256 key nvps
adam@12 324 | HMAC_SHA1 => OpenidFfi.hmac_sha1 key nvps
adam@6 325 in
adam@44 326 if OpenidFfi.secCmp sign' sign then
adam@6 327 return None
adam@6 328 else
adam@6 329 return (Some "Signatures don't match")
adam@6 330 end
adam@9 331 | Some (left, _) => return (Some ("openid.signed is missing required fields: " ^ show left))
adam@6 332 end
adam@6 333
adam@10 334 fun authenticate after r =
adam@10 335 let
adam@12 336 fun returnTo (qs : option queryString) =
adam@10 337 case qs of
adam@10 338 None => after (Failure "Empty query string for OpenID callback")
adam@10 339 | Some qs =>
adam@10 340 os <- OpenidFfi.indirect qs;
adam@10 341 case OpenidFfi.getOutput os "openid.error" of
adam@13 342 Some v => after (Failure ("Authentication failed: " ^ v))
adam@10 343 | None =>
adam@10 344 case OpenidFfi.getOutput os "openid.mode" of
adam@10 345 None => after (Failure "No openid.mode in response")
adam@10 346 | Some mode =>
adam@10 347 case mode of
adam@10 348 "cancel" => after Canceled
adam@10 349 | "id_res" =>
adam@10 350 (case OpenidFfi.getOutput os "openid.claimed_id" of
adam@10 351 None => after (Failure "Missing identity in OP response")
adam@10 352 | Some id =>
adam@13 353 errO <- verifyReturnTo os;
adam@6 354 case errO of
adam@13 355 Some s => after (Failure s)
adam@13 356 | None =>
adam@13 357 errO <- verifyHandle os id;
adam@6 358 case errO of
adam@13 359 HandleError s => after (Failure s)
adam@13 360 | NoAssociation ep =>
adam@14 361 r <- verifyStateless os ep id False;
adam@13 362 after r
adam@13 363 | HandleOk {Endpoint = ep, Typ = atype, Key = key} =>
adam@14 364 case OpenidFfi.getOutput os "openid.invalidate_handle" of
adam@14 365 Some _ =>
adam@14 366 r <- verifyStateless os ep id True;
adam@14 367 after r
adam@10 368 | None =>
adam@14 369 errO <- verifyNonce os ep;
adam@10 370 case errO of
adam@10 371 Some s => after (Failure s)
adam@14 372 | None =>
adam@14 373 errO <- verifySig os atype key;
adam@14 374 case errO of
adam@14 375 Some s => after (Failure s)
adam@14 376 | None => after (AuthenticatedAs id))
adam@10 377 | _ => after (Failure ("Unexpected openid.mode: " ^ mode))
adam@4 378
adam@12 379 and verifyReturnTo os =
adam@10 380 case OpenidFfi.getOutput os "openid.return_to" of
adam@10 381 None => return (Some "Missing return_to in OP response")
adam@10 382 | Some rt =>
adam@12 383 if rt <> show (effectfulUrl returnTo) then
adam@10 384 return (Some "Wrong return_to in OP response")
adam@10 385 else
adam@10 386 return None
adam@15 387
adam@15 388 val realmString = case r.Realm of
adam@15 389 None => ""
adam@15 390 | Some realm => "&openid.realm=" ^ realm
adam@39 391
adam@39 392 val (ident, claimed) =
adam@39 393 case r.Identifier of
adam@39 394 ChooseIdentifier s => (eatFragment s, "http://specs.openid.net/auth/2.0/identifier_select")
adam@39 395 | KnownIdentifier s =>
adam@39 396 let
adam@39 397 val s = eatFragment s
adam@39 398 in
adam@39 399 (s, s)
adam@39 400 end
adam@10 401 in
adam@39 402 dy <- discover ident;
adam@10 403 case dy of
adam@10 404 None => return "Discovery failed"
adam@10 405 | Some dy =>
adam@27 406 let
adam@27 407 val begin = case String.index dy #"?" of
adam@27 408 None => "?"
adam@27 409 | Some _ => "&"
adam@27 410 in
adam@27 411 case r.Association of
adam@27 412 Stateless =>
adam@27 413 redirect (bless (dy ^ begin ^ "openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup"
adam@39 414 ^ "&openid.claimed_id=" ^ claimed
adam@39 415 ^ "&openid.identity=" ^ claimed ^ "&openid.assoc_handle="
adam@27 416 ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString))
adam@27 417 | Stateful ar =>
adam@27 418 assoc <- association ar.AssociationType ar.AssociationSessionType dy;
adam@27 419 case assoc of
adam@27 420 AssError msg => return ("Association failure: " ^ msg)
adam@27 421 | AssAlternate _ => return "Association failure: server didn't accept its own alternate association modes"
adam@27 422 | Association assoc =>
adam@27 423 redirect (bless (dy ^ begin ^ "openid.ns=http://specs.openid.net/auth/2.0&openid.mode=checkid_setup"
adam@39 424 ^ "&openid.claimed_id=" ^ claimed
adam@39 425 ^ "&openid.identity=" ^ claimed ^ "&openid.assoc_handle="
adam@27 426 ^ assoc.Handle ^ "&openid.return_to=" ^ show (effectfulUrl returnTo) ^ realmString))
adam@27 427 end
adam@10 428 end
adam@6 429
adam@22 430 task periodic 60 = fn () =>
adam@22 431 dml (DELETE FROM discoveries WHERE Expires < CURRENT_TIMESTAMP);
adam@22 432 dml (DELETE FROM associations WHERE Expires < CURRENT_TIMESTAMP);
adam@22 433 dml (DELETE FROM nonces WHERE Expires < CURRENT_TIMESTAMP)