Mercurial > openid

annotate src/ur/openid.ur @ 41:a77f4cd1336d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix OpenSSL memory leak (spotted by Chris Double)
author Adam Chlipala <adam@chlipala.net>
date Sun, 12 Jun 2011 17:49:43 -0400
parents f6b3fbf10dac
children 00c8f43be8b7
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@6 326 if 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)