Mercurial > openid

annotate src/ur/openid.ur @ 6:99496175078b

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