[4514] | 1 | # -*- mode: tcl; indent-tabs-mode: nil -*- |
---|
| 2 | # ---------------------------------------------------------------------- |
---|
| 3 | # COMPONENT: XAuth - authentication for Twitter/OAuth services |
---|
| 4 | # |
---|
| 5 | # This library is used for XAuth authenication with HUBzero services. |
---|
| 6 | # Takes a username/password and obtains a token for other web services |
---|
| 7 | # calls. |
---|
| 8 | # |
---|
| 9 | # XAuth::credentials load ~/.xauth |
---|
| 10 | # set clientToken [XAuth::credentials get nanoHUB.org -token] |
---|
| 11 | # set clientSecret [XAuth::credentials get nanoHUB.org -secret] |
---|
| 12 | # |
---|
[5121] | 13 | # XAuth::init $site $clientToken $clientSecret -user $username $password |
---|
[4514] | 14 | # XAuth::call $site $method $params |
---|
| 15 | # |
---|
| 16 | # Check out this awesome description of the whole XAuth process: |
---|
| 17 | # http://weblog.bluedonkey.org/?p=959 |
---|
| 18 | # https://dev.twitter.com/docs/oauth/xauth |
---|
| 19 | # |
---|
| 20 | # ====================================================================== |
---|
| 21 | # AUTHOR: Michael McLennan, Purdue University |
---|
[5121] | 22 | # Copyright (c) 2004-2015 HUBzero Foundation, LLC |
---|
[4514] | 23 | # |
---|
| 24 | # See the file "license.terms" for information on usage and |
---|
| 25 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 26 | # ====================================================================== |
---|
| 27 | package require Itcl |
---|
| 28 | package require http |
---|
| 29 | package require base64 |
---|
| 30 | package require sha1 |
---|
| 31 | package require tls |
---|
[6685] | 32 | http::register https 443 [list ::tls::socket -tls1 0 -ssl2 0 -ssl3 0] |
---|
[4514] | 33 | |
---|
| 34 | namespace eval XAuth { |
---|
| 35 | # stores token/secret info from a file containing site data |
---|
| 36 | variable sites |
---|
| 37 | |
---|
| 38 | # parser for managing sites files |
---|
| 39 | variable parser [interp create -safe] |
---|
| 40 | |
---|
| 41 | foreach cmd [$parser eval {info commands}] { |
---|
| 42 | $parser hide $cmd |
---|
| 43 | } |
---|
| 44 | $parser alias site ::XAuth::credentials add |
---|
| 45 | $parser invokehidden proc unknown {args} { |
---|
| 46 | error "bad command \"$args\": should be sites" |
---|
| 47 | } |
---|
| 48 | $parser expose error |
---|
| 49 | |
---|
| 50 | # maps a web services url prefix to client token/secret |
---|
| 51 | variable clients |
---|
| 52 | |
---|
| 53 | # maps a web services url prefix to an authenticated session token |
---|
| 54 | variable tokens |
---|
| 55 | |
---|
| 56 | # list of http redirects (so we can detect infinite loops) |
---|
| 57 | variable redirects "" |
---|
| 58 | } |
---|
| 59 | |
---|
| 60 | # used to store values from JSON objects |
---|
| 61 | itcl::class JsonObject { |
---|
| 62 | constructor {{parent ""}} { |
---|
| 63 | if {$parent ne ""} { |
---|
| 64 | if {[catch {$parent is JsonObject} valid] || !$valid} { |
---|
| 65 | error "bad value \"$parent\": should be JsonObject" |
---|
| 66 | } |
---|
| 67 | $parent attach $this |
---|
| 68 | } |
---|
| 69 | } |
---|
| 70 | |
---|
| 71 | destructor { |
---|
| 72 | foreach obj $_children { |
---|
| 73 | itcl::delete object $obj |
---|
| 74 | } |
---|
| 75 | } |
---|
| 76 | |
---|
| 77 | method attach {args} { |
---|
| 78 | foreach obj $args { |
---|
| 79 | if {[catch {$obj is JsonObject} valid] || !$valid} { |
---|
| 80 | error "bad value \"$obj\": should be JsonObject" |
---|
| 81 | } |
---|
| 82 | lappend _children $obj |
---|
| 83 | } |
---|
| 84 | } |
---|
| 85 | |
---|
| 86 | method assign {args} { |
---|
| 87 | switch -- [llength $args] { |
---|
| 88 | 1 { |
---|
| 89 | catch {unset _dict} |
---|
| 90 | set _value [lindex $args 0] |
---|
| 91 | set _type "scalar" |
---|
| 92 | if {[catch {$_value is JsonObject} valid] == 0 && $valid} { |
---|
| 93 | attach $_value |
---|
| 94 | } |
---|
| 95 | } |
---|
| 96 | 2 { |
---|
| 97 | set key [lindex $args 0] |
---|
| 98 | set value [lindex $args 1] |
---|
| 99 | if {[catch {$value is JsonObject} valid] == 0 && $valid} { |
---|
| 100 | attach $value |
---|
| 101 | } |
---|
| 102 | |
---|
| 103 | if {$key eq "-element"} { |
---|
| 104 | catch {unset _dict} |
---|
| 105 | lappend _value $value |
---|
| 106 | set _type "vector" |
---|
| 107 | } else { |
---|
| 108 | catch {unset _value} |
---|
| 109 | set _dict($key) $value |
---|
| 110 | set _type "struct" |
---|
| 111 | } |
---|
| 112 | } |
---|
| 113 | default { |
---|
| 114 | error "wrong # args: should be \"assign value\" or \"assign -element value\" or \"assign key value\"" |
---|
| 115 | } |
---|
| 116 | } |
---|
| 117 | } |
---|
| 118 | |
---|
| 119 | method get {{what ""}} { |
---|
| 120 | switch -- $_type { |
---|
| 121 | scalar { |
---|
| 122 | if {$what ne "" && $what ne "-scalar"} { |
---|
| 123 | error "type mismatch -- requested scalar but got $_type" |
---|
| 124 | } |
---|
| 125 | return $_value |
---|
| 126 | } |
---|
| 127 | vector { |
---|
| 128 | if {$what ne "" && $what ne "-vector"} { |
---|
| 129 | error "type mismatch -- requested vector but got $_type" |
---|
| 130 | } |
---|
| 131 | return $_value |
---|
| 132 | } |
---|
| 133 | struct { |
---|
| 134 | if {$what eq ""} { |
---|
| 135 | return [array names _dict] |
---|
| 136 | } elseif {[info exists _dict($what)]} { |
---|
| 137 | return $_dict($what) |
---|
| 138 | } else { |
---|
| 139 | return "" |
---|
| 140 | } |
---|
| 141 | } |
---|
| 142 | default { |
---|
| 143 | error "internal error: bad type \"$_type\"" |
---|
| 144 | } |
---|
| 145 | } |
---|
| 146 | } |
---|
| 147 | |
---|
| 148 | method type {} { |
---|
| 149 | return $_type |
---|
| 150 | } |
---|
| 151 | |
---|
| 152 | protected variable _children "" |
---|
| 153 | protected variable _type "scalar" |
---|
| 154 | protected variable _value "" |
---|
| 155 | protected variable _dict |
---|
| 156 | |
---|
| 157 | # decode JSON -- returns a JsonObject |
---|
| 158 | proc decode {str {leftoverVar ""}} { |
---|
| 159 | # look for opening curly brace (7B) |
---|
| 160 | if {[regexp -indices {^[[:space:]]*\x7B} $str match]} { |
---|
| 161 | set obj [JsonObject ::#auto] |
---|
| 162 | set str [substr $str $match -( >] |
---|
| 163 | while {1} { |
---|
| 164 | # should set "string":value |
---|
| 165 | if {[regexp -indices {^[[:space:]]*"(([^\\\"]|\\.)*)"[[:space:]]*:} $str match key]} { |
---|
| 166 | set key [substr $str $key | |] |
---|
| 167 | set str [substr $str $match -( >] |
---|
| 168 | set val [decode $str str] |
---|
| 169 | $obj assign $key $val |
---|
| 170 | if {[regexp -indices {^[[:space:]]*,} $str match]} { |
---|
| 171 | # found comma -- keep going |
---|
| 172 | set str [substr $str $match -( >] |
---|
| 173 | } elseif {[regexp -indices {^[[:space:]]*\x7D} $str match]} { |
---|
| 174 | # found closing curly brace (7D) |
---|
| 175 | if {$leftoverVar ne ""} { |
---|
| 176 | upvar $leftoverVar rest |
---|
| 177 | set rest [substr $str $match -( >] |
---|
| 178 | } |
---|
| 179 | return $obj |
---|
| 180 | } else { |
---|
| 181 | error "syntax error -- expected , or \x7D but got \"[string range $str 0 20]...\"" |
---|
| 182 | } |
---|
| 183 | } else { |
---|
| 184 | error "syntax error -- expected \"string\":value but got \"[string range $str 0 20]...\"" |
---|
| 185 | } |
---|
| 186 | } |
---|
| 187 | } elseif {[regexp -indices {^[[:space:]]*\x5B} $str match]} { |
---|
| 188 | # found opening square bracket (5B) -- start of array... |
---|
| 189 | set obj [JsonObject ::#auto] |
---|
| 190 | set str [substr $str $match -( >] |
---|
| 191 | |
---|
| 192 | if {[regexp -indices {^[[:space:]]*\x5D} $str match]} { |
---|
| 193 | # empty list |
---|
| 194 | if {$leftoverVar ne ""} { |
---|
| 195 | upvar $leftoverVar rest |
---|
| 196 | set rest [substr $str $match -( >] |
---|
| 197 | } |
---|
| 198 | return $obj |
---|
| 199 | } |
---|
| 200 | while {1} { |
---|
| 201 | # decode the element and add to the array |
---|
| 202 | set val [decode $str str] |
---|
| 203 | $obj assign -element $val |
---|
| 204 | |
---|
| 205 | if {[regexp -indices {^[[:space:]]*,} $str match]} { |
---|
| 206 | # found comma -- keeping going |
---|
| 207 | set str [substr $str $match -( >] |
---|
| 208 | } elseif {[regexp -indices {^[[:space:]]*\x5D} $str match]} { |
---|
| 209 | # found closing square bracket (5D) |
---|
| 210 | if {$leftoverVar ne ""} { |
---|
| 211 | upvar $leftoverVar rest |
---|
| 212 | set rest [substr $str $match -( >] |
---|
| 213 | } |
---|
| 214 | return $obj |
---|
| 215 | } else { |
---|
| 216 | error "syntax error -- expected , or \x7D but got \"[string range $str 0 20]...\"" |
---|
| 217 | } |
---|
| 218 | } |
---|
| 219 | } elseif {[regexp -indices {^[[:space:]]*"(([^\\\"]|\\.)*)"} $str match inner]} { |
---|
| 220 | # found quoted string value |
---|
| 221 | set val [substr $str $inner | |] |
---|
| 222 | |
---|
| 223 | # convert backslashes and newlines within string |
---|
| 224 | regsub -all {\\r\\n} $val "\n" val |
---|
| 225 | regsub -all {\\n} $val "\n" val |
---|
| 226 | regsub -all {\\(.)} $val {\1} val |
---|
| 227 | |
---|
| 228 | if {$leftoverVar ne ""} { |
---|
| 229 | upvar $leftoverVar rest |
---|
| 230 | set rest [substr $str $match -( >] |
---|
| 231 | } |
---|
| 232 | return $val |
---|
| 233 | } elseif {[regexp -indices {^[[:space:]]*([-+]?[0-9]+(\.[0-9]*)?([eEdE][-+]?[0-9]+)?)([^0-9eEdD.]|$)} $str match inner]} { |
---|
| 234 | # found number value |
---|
| 235 | set val [substr $str $inner | |] |
---|
| 236 | if {$leftoverVar ne ""} { |
---|
| 237 | upvar $leftoverVar rest |
---|
| 238 | set rest [substr $str $inner -( >] |
---|
| 239 | } |
---|
| 240 | return $val |
---|
| 241 | } elseif {[regexp -indices {^[[:space:]]*(true|false)} $str match inner]} { |
---|
| 242 | # found true/false value |
---|
| 243 | set val [substr $str $inner | |] |
---|
| 244 | if {$leftoverVar ne ""} { |
---|
| 245 | upvar $leftoverVar rest |
---|
| 246 | set rest [substr $str $match -( >] |
---|
| 247 | } |
---|
| 248 | return $val |
---|
| 249 | } elseif {[regexp -indices {^[[:space:]]*null} $str match]} { |
---|
| 250 | if {$leftoverVar ne ""} { |
---|
| 251 | upvar $leftoverVar rest |
---|
| 252 | set rest [substr $str $match -( >] |
---|
| 253 | } |
---|
| 254 | return "" |
---|
| 255 | } else { |
---|
| 256 | error "syntax error at: [string range $str 0 20]..." |
---|
| 257 | } |
---|
| 258 | } |
---|
| 259 | |
---|
| 260 | # substr -- given a string an indices from regexp, return a substring |
---|
| 261 | # | | ...... return exactly from one index to another |
---|
| 262 | # (- -) .... return stuff just inside the two indices |
---|
| 263 | # -( > ..... return everything after the last index |
---|
| 264 | # 0 )- ..... return everything until before the first index |
---|
| 265 | proc substr {str match lim0 lim1} { |
---|
| 266 | foreach {m0 m1} $match break |
---|
| 267 | switch -- $lim0 { |
---|
| 268 | 0 { set s0 0 } |
---|
| 269 | (- { set s0 [expr {$m0+1}] } |
---|
| 270 | -( { set s0 [expr {$m1+1}] } |
---|
| 271 | -) { set s0 [expr {$m1-1}] } |
---|
| 272 | | { set s0 $m0 } |
---|
| 273 | default { error "don't understand limit \"$lim0\"" } |
---|
| 274 | } |
---|
| 275 | switch -- $lim1 { |
---|
| 276 | > { set s1 end } |
---|
| 277 | -) { set s1 [expr {$m1-1}] } |
---|
| 278 | )- { set s0 [expr {$m0-1}] } |
---|
| 279 | (- { set s1 [expr {$m0+1}] } |
---|
| 280 | -( { set s1 [expr {$m1+1}] } |
---|
| 281 | | { set s1 $m1 } |
---|
| 282 | default { error "don't understand limit \"$lim1\"" } |
---|
| 283 | } |
---|
| 284 | return [string range $str $s0 $s1] |
---|
| 285 | } |
---|
| 286 | } |
---|
| 287 | |
---|
| 288 | # ---------------------------------------------------------------------- |
---|
[5121] | 289 | # USAGE: XAuth::init <site> <clientToken> <clientSecret> -user <u> <p> |
---|
| 290 | # USAGE: XAuth::init <site> <clientToken> <clientSecret> -session <n> <t> |
---|
[4514] | 291 | # |
---|
[5121] | 292 | # Should be called to initialize this library. Can be initialized |
---|
| 293 | # one of two ways: |
---|
| 294 | # |
---|
| 295 | # -user <u> <p> ...... sends username <u> and password <p> |
---|
| 296 | # -session <n> <t> ... sends tool session number <n> and token <t> |
---|
| 297 | # |
---|
| 298 | # Sends the credentials to the <site> for authentication. The client |
---|
| 299 | # token and secret are registered to identify the application. |
---|
[4514] | 300 | # If successful, this call stores an authenticated session token in |
---|
| 301 | # the tokens array for the <site> URL. Subsequent calls to XAuth::call |
---|
| 302 | # use this token to identify the user. |
---|
| 303 | # ---------------------------------------------------------------------- |
---|
[5121] | 304 | proc XAuth::init {site clientToken clientSecret args} { |
---|
[4514] | 305 | variable clients |
---|
| 306 | variable tokens |
---|
| 307 | |
---|
[5121] | 308 | set option [lindex $args 0] |
---|
| 309 | switch -- $option { |
---|
| 310 | -user { |
---|
| 311 | if {[llength $args] != 3} { |
---|
| 312 | error "wrong # args: should be \"-user name password\"" |
---|
| 313 | } |
---|
| 314 | set uname [lindex $args 1] |
---|
| 315 | set passw [lindex $args 2] |
---|
| 316 | } |
---|
| 317 | -session { |
---|
| 318 | if {[llength $args] != 3} { |
---|
| 319 | error "wrong # args: should be \"-session number token\"" |
---|
| 320 | } |
---|
| 321 | set snum [lindex $args 1] |
---|
| 322 | set stok [lindex $args 2] |
---|
| 323 | |
---|
| 324 | # store session info for later -- no need for oauth stuff |
---|
| 325 | set tokens($site) [list session $snum $stok] |
---|
| 326 | set clients($site) [list $clientToken $clientSecret] |
---|
| 327 | return |
---|
| 328 | } |
---|
| 329 | default { |
---|
| 330 | if {[llength $args] != 2} { |
---|
| 331 | error "wrong # args: should be \"XAuth::init site token secret ?-option? arg arg\"" |
---|
| 332 | } |
---|
| 333 | set uname [lindex $args 0] |
---|
| 334 | set passw [lindex $args 1] |
---|
| 335 | } |
---|
| 336 | } |
---|
| 337 | |
---|
[4514] | 338 | if {![regexp {^https://} $site]} { |
---|
| 339 | error "bad site URL \"$site\": should be https://..." |
---|
| 340 | } |
---|
| 341 | set site [string trimright $site /] |
---|
| 342 | |
---|
| 343 | if {![regexp {^[0-9a-zA-Z]+$} $clientToken]} { |
---|
| 344 | error "bad client token \"$clientToken\": should be alphanumeric" |
---|
| 345 | } |
---|
| 346 | |
---|
| 347 | set url $site/oauth/access_token |
---|
| 348 | set nonce [XAuth::nonce] |
---|
| 349 | set tstamp [clock seconds] |
---|
| 350 | |
---|
| 351 | |
---|
| 352 | # Twitter has this awesome test page: |
---|
| 353 | # https://dev.twitter.com/docs/oauth/xauth |
---|
| 354 | # |
---|
| 355 | # Use these values... |
---|
| 356 | # set url https://api.twitter.com/oauth/access_token |
---|
| 357 | # set clientToken JvyS7DO2qd6NNTsXJ4E7zA |
---|
| 358 | # set clientSecret 9z6157pUbOBqtbm0A0q4r29Y2EYzIHlUwbF4Cl9c |
---|
| 359 | # set nonce 6AN2dKRzxyGhmIXUKSmp1JcB4pckM8rD3frKMTmVAo |
---|
| 360 | # set tstamp 1284565601 |
---|
| 361 | # set passw twitter-xauth |
---|
| 362 | # set uname oauth_test_exec |
---|
| 363 | # |
---|
| 364 | # and the signature should be: 1L1oXQmawZAkQ47FHLwcOV%2Bkjwc%3D |
---|
| 365 | |
---|
| 366 | # BE CAREFUL -- put these parameters in exactly this order |
---|
| 367 | set query [http::formatQuery \ |
---|
| 368 | oauth_consumer_key $clientToken \ |
---|
| 369 | oauth_nonce $nonce \ |
---|
| 370 | oauth_signature_method "HMAC-SHA1" \ |
---|
| 371 | oauth_timestamp $tstamp \ |
---|
| 372 | oauth_version "1.0" \ |
---|
| 373 | x_auth_mode "client_auth" \ |
---|
| 374 | x_auth_password $passw \ |
---|
| 375 | x_auth_username $uname \ |
---|
| 376 | ] |
---|
| 377 | |
---|
| 378 | set base "POST&[urlencode $url]&[urlencode $query]" |
---|
| 379 | set key "$clientSecret&" |
---|
| 380 | set sig [urlencode [base64::encode [sha1::hmac -bin -key $key $base]]] |
---|
| 381 | |
---|
| 382 | # build the header and send the request |
---|
| 383 | set auth [format "OAuth oauth_consumer_key=\"%s\", oauth_nonce=\"%s\", oauth_signature_method=\"HMAC-SHA1\", oauth_signature=\"%s\", oauth_timestamp=\"%s\", oauth_version=\"1.0\"" $clientToken $nonce $sig $tstamp] |
---|
| 384 | |
---|
| 385 | set result [XAuth::fetch $url -headers [list Authorization $auth] -query $query] |
---|
| 386 | |
---|
| 387 | # pick apart the result and extra: oauth_token, oauth_token_secret |
---|
| 388 | foreach param [split $result &] { |
---|
| 389 | if {[regexp {^(oauth[^=]+)=(.+)} $param match name val]} { |
---|
| 390 | set got($name) $val |
---|
| 391 | } |
---|
| 392 | } |
---|
| 393 | if {![info exists got(oauth_token)] || ![info exists got(oauth_token_secret)]} { |
---|
| 394 | error "authentication failed: $result" |
---|
| 395 | } |
---|
| 396 | |
---|
| 397 | # success! store the session token for later |
---|
[5121] | 398 | set tokens($site) [list oauth $got(oauth_token) $got(oauth_token_secret)] |
---|
[4514] | 399 | set clients($site) [list $clientToken $clientSecret] |
---|
| 400 | } |
---|
| 401 | |
---|
| 402 | # ---------------------------------------------------------------------- |
---|
| 403 | # USAGE: XAuth::call <site> <method> ?<params>? |
---|
| 404 | # |
---|
| 405 | # Called after XAuth::init for each web service request. Calls the |
---|
| 406 | # given <site>/<method> with the specified <params>. Returns the |
---|
| 407 | # xml result string. |
---|
| 408 | # ---------------------------------------------------------------------- |
---|
| 409 | proc XAuth::call {site method {params ""}} { |
---|
| 410 | variable clients |
---|
| 411 | variable tokens |
---|
| 412 | |
---|
| 413 | if {![regexp {^https://} $site]} { |
---|
| 414 | error "bad site URL \"$site\": should be https://..." |
---|
| 415 | } |
---|
| 416 | set site [string trimright $site /] |
---|
| 417 | set method [string trimleft $method /] |
---|
| 418 | |
---|
| 419 | if {![info exists tokens($site)]} { |
---|
| 420 | error "must call XAuth::init for $site first to authenticate" |
---|
| 421 | } |
---|
| 422 | foreach {clientToken clientSecret} $clients($site) break |
---|
[5121] | 423 | foreach {scheme userToken userSecret} $tokens($site) break |
---|
[4514] | 424 | |
---|
| 425 | set url $site/$method |
---|
| 426 | |
---|
[5121] | 427 | switch -- $scheme { |
---|
| 428 | oauth { |
---|
| 429 | set nonce [XAuth::nonce] |
---|
| 430 | set tstamp [clock seconds] |
---|
[4514] | 431 | |
---|
[5121] | 432 | # BE CAREFUL -- put all query parameters in alphabetical order |
---|
| 433 | array set qparams [list \ |
---|
| 434 | oauth_consumer_key $clientToken \ |
---|
| 435 | oauth_nonce $nonce \ |
---|
| 436 | oauth_signature_method "HMAC-SHA1" \ |
---|
| 437 | oauth_timestamp $tstamp \ |
---|
| 438 | oauth_token $userToken \ |
---|
| 439 | oauth_version "1.0" \ |
---|
| 440 | x_auth_mode "client_auth" \ |
---|
| 441 | ] |
---|
| 442 | array set qparams $params |
---|
[4514] | 443 | |
---|
[5121] | 444 | set query "" |
---|
| 445 | foreach key [lsort [array names qparams]] { |
---|
| 446 | lappend query $key $qparams($key) |
---|
| 447 | } |
---|
| 448 | set query [eval http::formatQuery $query] |
---|
[4514] | 449 | |
---|
[5121] | 450 | set base "POST&[urlencode $url]&[urlencode $query]" |
---|
| 451 | set key "$clientSecret&$userSecret" |
---|
| 452 | set sig [urlencode [base64::encode [sha1::hmac -bin -key $key $base]]] |
---|
[4514] | 453 | |
---|
[5121] | 454 | # build the header and send the request |
---|
| 455 | set auth [format "OAuth oauth_consumer_key=\"%s\", oauth_token=\"%s\", oauth_nonce=\"%s\", oauth_signature_method=\"HMAC-SHA1\", oauth_signature=\"%s\", oauth_timestamp=\"%s\", oauth_version=\"1.0\"" $clientToken $userToken $nonce $sig $tstamp] |
---|
| 456 | set hdr [list Authorization $auth] |
---|
| 457 | } |
---|
| 458 | session { |
---|
| 459 | set hdr [list sessionnum $userToken sessiontoken $userSecret] |
---|
| 460 | set query "" |
---|
| 461 | foreach {key val} $params { |
---|
| 462 | lappend query $key $val |
---|
| 463 | } |
---|
| 464 | set query [eval http::formatQuery $query] |
---|
| 465 | } |
---|
| 466 | default { |
---|
| 467 | error "internal error -- don't understand call scheme \"$scheme\"" |
---|
| 468 | } |
---|
| 469 | } |
---|
| 470 | return [XAuth::fetch $url -headers $hdr -query $query] |
---|
[4514] | 471 | } |
---|
| 472 | |
---|
| 473 | # ---------------------------------------------------------------------- |
---|
| 474 | # USAGE: XAuth::fetch <url> ?-headers <keyvalList>? ?-query <str>? |
---|
| 475 | # |
---|
| 476 | # Sends a GET/POST request off to the specified <url>. If the -query |
---|
| 477 | # string is specified, then this is assumed to be an encoded list of |
---|
| 478 | # parameters and the operation is POST. Tries a few times in case the |
---|
| 479 | # web site is busy. |
---|
| 480 | # ---------------------------------------------------------------------- |
---|
| 481 | proc XAuth::fetch {url args} { |
---|
| 482 | variable redirects |
---|
| 483 | |
---|
| 484 | set hdr "" |
---|
| 485 | set query "" |
---|
| 486 | foreach {key val} $args { |
---|
| 487 | switch -- $key { |
---|
| 488 | -headers { set hdr $val } |
---|
| 489 | -query { set query $val } |
---|
| 490 | default { |
---|
| 491 | error "bad option \"$key\": should be -headers or -query" |
---|
| 492 | } |
---|
| 493 | } |
---|
| 494 | } |
---|
| 495 | |
---|
| 496 | # send off the request a few times |
---|
| 497 | set ntries 5 |
---|
| 498 | while {1} { |
---|
| 499 | if {[catch {http::geturl $url -headers $hdr -query $query -timeout 30000} token] == 0} { |
---|
| 500 | break |
---|
| 501 | } |
---|
| 502 | if {[incr ntries -1] <= 0} { |
---|
| 503 | error "web request \"$url\" failed to load: $token" |
---|
| 504 | } |
---|
| 505 | after 5000 |
---|
| 506 | } |
---|
| 507 | |
---|
| 508 | # handle the response |
---|
| 509 | upvar #0 $token state |
---|
| 510 | |
---|
| 511 | # look for errors |
---|
| 512 | switch -- [http::ncode $token] { |
---|
| 513 | 200 { |
---|
| 514 | set rval [http::data $token] |
---|
| 515 | |
---|
| 516 | array set meta $state(meta) |
---|
| 517 | if {[info exists meta(Transfer-Encoding)] |
---|
| 518 | && $meta(Transfer-Encoding) eq "chunked"} { |
---|
| 519 | set rval [XAuth::unchunk $rval] |
---|
| 520 | } |
---|
| 521 | |
---|
| 522 | if {[info exists meta(Content-Type)] |
---|
| 523 | && $meta(Content-Type) eq "application/json"} { |
---|
| 524 | set rval [JsonObject::decode $rval] |
---|
| 525 | } |
---|
| 526 | |
---|
| 527 | http::cleanup $token |
---|
| 528 | set redirects "" |
---|
| 529 | return $rval |
---|
| 530 | } |
---|
| 531 | 301 - 302 - 303 { |
---|
| 532 | lappend redirects $url |
---|
| 533 | if {[llength $redirects] > 5} { |
---|
| 534 | error "web page redirect loop for $url" |
---|
| 535 | } |
---|
| 536 | array set meta $state(meta) |
---|
| 537 | if {[info exists meta(Location)]} { |
---|
| 538 | set newurl $meta(Location) |
---|
| 539 | if {![regexp {^https?://} $newurl] && [regexp -nocase -indices {^https?://[^/]+} $url match]} { |
---|
| 540 | if {[string index $newurl 0] != "/"} { |
---|
| 541 | set newurl "/$newurl" |
---|
| 542 | } |
---|
| 543 | foreach {s0 s1} $match break |
---|
| 544 | set newurl "[string range $url $s0 $s1]$newurl" |
---|
| 545 | } |
---|
| 546 | return [fetch $newurl -headers $hdr -query $query] |
---|
| 547 | } |
---|
| 548 | return "" |
---|
| 549 | } |
---|
| 550 | default { |
---|
| 551 | set status [http::code $token] |
---|
| 552 | http::cleanup $token |
---|
| 553 | set redirects "" |
---|
| 554 | error "web request \"$url\" failed to load: $status" |
---|
| 555 | } |
---|
| 556 | } |
---|
| 557 | } |
---|
| 558 | |
---|
| 559 | # ---------------------------------------------------------------------- |
---|
| 560 | # USAGE: XAuth::urlencode <str> |
---|
| 561 | # |
---|
| 562 | # Encodes a string according to standard HTTP encoding conventions. |
---|
| 563 | # Punctuation characters are converted to their %XX equivalent. |
---|
| 564 | # Returns a properly encoded string. |
---|
| 565 | # ---------------------------------------------------------------------- |
---|
| 566 | proc XAuth::urlencode {str} { |
---|
| 567 | set str [http::formatQuery $str] |
---|
| 568 | regsub -all {%[a-fA-F0-9][a-fA-F0-9]} $str {[string toupper \0]} str |
---|
| 569 | return [subst $str] |
---|
| 570 | } |
---|
| 571 | |
---|
| 572 | # ---------------------------------------------------------------------- |
---|
| 573 | # USAGE: XAuth::nonce |
---|
| 574 | # |
---|
| 575 | # Random nonce (number used once) for the OAuth protocol. Each nonce |
---|
| 576 | # should be unique when interpreted in conjunction with the timestamp. |
---|
| 577 | # Any large, random number should work here. |
---|
| 578 | # ---------------------------------------------------------------------- |
---|
| 579 | proc XAuth::nonce {} { |
---|
| 580 | set nonce [expr {round(rand()*1e8)}][clock clicks] |
---|
| 581 | return [sha1::sha1 $nonce] |
---|
| 582 | } |
---|
| 583 | |
---|
| 584 | # ---------------------------------------------------------------------- |
---|
| 585 | # USAGE: XAuth::unchunk <string> |
---|
| 586 | # |
---|
| 587 | # Used internally to decode a <string> from a web server that has been |
---|
| 588 | # transferred with "chunk" encoding. In this case, the string contains |
---|
| 589 | # a hexadecimal size, a newline, a chunk of text, another hexadecimal |
---|
| 590 | # size, a newline, another chunk of text, etc. Returns a clean string |
---|
| 591 | # with all of the hex values removed. |
---|
| 592 | # ---------------------------------------------------------------------- |
---|
| 593 | proc XAuth::unchunk {str} { |
---|
| 594 | set rval "" |
---|
| 595 | while {[string length $str] > 0} { |
---|
| 596 | # get the hex string for the length |
---|
| 597 | set nlpos [string first "\n" $str] |
---|
| 598 | if {$nlpos < 0} { |
---|
| 599 | append rval $str |
---|
| 600 | break |
---|
| 601 | } |
---|
| 602 | set hex [string range $str 0 [expr {$nlpos-1}]] |
---|
| 603 | |
---|
| 604 | if {[scan $hex "%x" len] == 1} { |
---|
| 605 | # get the next chunk with that length |
---|
| 606 | set from [expr {$nlpos+1}] |
---|
| 607 | set to [expr {$from+$len}] |
---|
| 608 | append rval [string range $str $from [expr {$to-1}]] |
---|
| 609 | set nl [string index $str $to] |
---|
| 610 | |
---|
| 611 | if {$nl eq "\r"} { |
---|
| 612 | incr to |
---|
| 613 | set nl [string index $str $to] |
---|
| 614 | } |
---|
| 615 | if {$nl ne "\n" && $nl ne ""} { |
---|
| 616 | error "garbled text in chunk-encoded string -- missing newline" |
---|
| 617 | } |
---|
| 618 | set str [string range $str [expr {$to+1}] end] |
---|
| 619 | } else { |
---|
| 620 | error "garbled text in chunk-encoded string -- missing hex value" |
---|
| 621 | } |
---|
| 622 | } |
---|
| 623 | return $rval |
---|
| 624 | } |
---|
| 625 | |
---|
| 626 | # ---------------------------------------------------------------------- |
---|
| 627 | # USAGE: XAuth::credentials load ?<fileName>? |
---|
| 628 | # USAGE: XAuth::credentials get <site> ?<what>? |
---|
| 629 | # |
---|
| 630 | # Clients use this to load information about the client token/secret |
---|
| 631 | # from a file and feed it along to XAuth::init. The "load" operation |
---|
| 632 | # loads information from a file in the user's home directory. If not |
---|
| 633 | # specified, the name "~/.xauth" is assumed. This file contains a |
---|
| 634 | # series of lines as follows: |
---|
| 635 | # |
---|
| 636 | # site nanoHUB.org -token abLJdjfks -secret kd18293ksjshdkdjejd |
---|
| 637 | # site HUBzero.org -token adckdsjeL -secret dkejdklsje1wlsjd2je |
---|
| 638 | # ... |
---|
| 639 | # |
---|
| 640 | # The "get" call returns information for the specified <site> name. |
---|
| 641 | # The optional <what> parameter can be used to request -token or |
---|
| 642 | # -secret. Otherwise, it returns a list "-token xxx -secret yyy" |
---|
| 643 | # ---------------------------------------------------------------------- |
---|
| 644 | proc XAuth::credentials {option args} { |
---|
| 645 | variable sites |
---|
| 646 | variable parser |
---|
| 647 | |
---|
| 648 | switch -- $option { |
---|
| 649 | load { |
---|
| 650 | if {[llength $args] == 1} { |
---|
| 651 | set fname [lindex $args 0] |
---|
[5121] | 652 | } elseif {[llength $args] == 0} { |
---|
| 653 | if {[file exists ~/.xauth]} { |
---|
| 654 | set fname "~/.xauth" |
---|
| 655 | } else { |
---|
| 656 | set fname "" |
---|
| 657 | } |
---|
| 658 | } else { |
---|
[4514] | 659 | error "wrong # args: should be \"credentials load ?file?\"" |
---|
| 660 | } |
---|
| 661 | |
---|
[5121] | 662 | if {$fname ne ""} { |
---|
| 663 | if {![file readable $fname]} { |
---|
| 664 | error "file \"$fname\" not found" |
---|
| 665 | } |
---|
| 666 | set fid [open $fname r] |
---|
| 667 | set info [read $fid] |
---|
| 668 | close $fid |
---|
[4514] | 669 | |
---|
[5121] | 670 | if {[catch {$parser eval $info} result]} { |
---|
| 671 | error "error in sites file \"$fname\": $result" |
---|
| 672 | } |
---|
[4514] | 673 | } |
---|
| 674 | } |
---|
| 675 | add { |
---|
| 676 | set name [string tolower [lindex $args 0]] |
---|
| 677 | foreach {key val} [lrange $args 1 end] { |
---|
| 678 | if {$key ne "-token" && $key ne "-secret"} { |
---|
| 679 | error "bad option \"$key\": should be -token or -secret" |
---|
| 680 | } |
---|
| 681 | } |
---|
| 682 | set sites($name) [lrange $args 1 end] |
---|
| 683 | } |
---|
| 684 | get { |
---|
| 685 | set name [string tolower [lindex $args 0]] |
---|
| 686 | set what [lindex $args 1] |
---|
| 687 | if {$what ne "" && $what ne "-token" && $what ne "-secret"} { |
---|
| 688 | error "bad value \"$what\": should be -token or -secret" |
---|
| 689 | } |
---|
| 690 | |
---|
| 691 | if {[info exists sites($name)]} { |
---|
| 692 | if {$what eq ""} { |
---|
| 693 | return $sites($name) |
---|
| 694 | } |
---|
| 695 | array set data $sites($name) |
---|
| 696 | return $data($what) |
---|
| 697 | } |
---|
| 698 | return "" |
---|
| 699 | } |
---|
| 700 | default { |
---|
| 701 | error "bad option \"$option\": should be load or get" |
---|
| 702 | } |
---|
| 703 | } |
---|
| 704 | } |
---|