Mercurial > openid

annotate src/ur/openid.ur @ 7:976121190b2d

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