source: trunk/lang/tcl/scripts/xauth.tcl @ 4660

Last change on this file since 4660 was 4660, checked in by ldelgass, 6 years ago

copy tls fix from 1.3 branch

File size: 22.8 KB
Line 
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#
13#    XAuth::init $site $clientToken $clientSecret $username $password
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
22#  Copyright (c) 2004-2013  HUBzero Foundation, LLC
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# ======================================================================
27package require Itcl
28package require http
29package require base64
30package require sha1
31package require tls
32http::register https 443 [list ::tls::socket -tls1 1]
33
34namespace 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
61itcl::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# ----------------------------------------------------------------------
289# USAGE: XAuth::init <site> <clientToken> <clientSecret> <username> <password>
290#
291# Should be called to initialize this library.  Sends the <username>
292# and <password> to the <site> for authentication.  The <client> ID
293# is registered with the OAuth provider to identify the application.
294# If successful, this call stores an authenticated session token in
295# the tokens array for the <site> URL.  Subsequent calls to XAuth::call
296# use this token to identify the user.
297# ----------------------------------------------------------------------
298proc XAuth::init {site clientToken clientSecret uname passw} {
299    variable clients
300    variable tokens
301
302    if {![regexp {^https://} $site]} {
303        error "bad site URL \"$site\": should be https://..."
304    }
305    set site [string trimright $site /]
306
307    if {![regexp {^[0-9a-zA-Z]+$} $clientToken]} {
308        error "bad client token \"$clientToken\": should be alphanumeric"
309    }
310
311    set url $site/oauth/access_token
312    set nonce [XAuth::nonce]
313    set tstamp [clock seconds]
314
315
316    # Twitter has this awesome test page:
317    # https://dev.twitter.com/docs/oauth/xauth
318    #
319    # Use these values...
320    #   set url https://api.twitter.com/oauth/access_token
321    #   set clientToken JvyS7DO2qd6NNTsXJ4E7zA
322    #   set clientSecret 9z6157pUbOBqtbm0A0q4r29Y2EYzIHlUwbF4Cl9c
323    #   set nonce 6AN2dKRzxyGhmIXUKSmp1JcB4pckM8rD3frKMTmVAo
324    #   set tstamp 1284565601
325    #   set passw twitter-xauth
326    #   set uname oauth_test_exec
327    #
328    # and the signature should be: 1L1oXQmawZAkQ47FHLwcOV%2Bkjwc%3D
329
330    # BE CAREFUL -- put these parameters in exactly this order
331    set query [http::formatQuery \
332        oauth_consumer_key $clientToken \
333        oauth_nonce $nonce \
334        oauth_signature_method "HMAC-SHA1" \
335        oauth_timestamp $tstamp \
336        oauth_version "1.0" \
337        x_auth_mode "client_auth" \
338        x_auth_password $passw \
339        x_auth_username $uname \
340    ]
341
342    set base "POST&[urlencode $url]&[urlencode $query]"
343    set key "$clientSecret&"
344    set sig [urlencode [base64::encode [sha1::hmac -bin -key $key $base]]]
345
346    # build the header and send the request
347    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]
348
349    set result [XAuth::fetch $url -headers [list Authorization $auth] -query $query]
350
351    # pick apart the result and extra: oauth_token, oauth_token_secret
352    foreach param [split $result &] {
353        if {[regexp {^(oauth[^=]+)=(.+)} $param match name val]} {
354            set got($name) $val
355        }
356    }
357    if {![info exists got(oauth_token)] || ![info exists got(oauth_token_secret)]} {
358        error "authentication failed: $result"
359    }
360
361    # success! store the session token for later
362    set tokens($site) [list $got(oauth_token) $got(oauth_token_secret)]
363    set clients($site) [list $clientToken $clientSecret]
364}
365
366# ----------------------------------------------------------------------
367# USAGE: XAuth::call <site> <method> ?<params>?
368#
369# Called after XAuth::init for each web service request.  Calls the
370# given <site>/<method> with the specified <params>.  Returns the
371# xml result string.
372# ----------------------------------------------------------------------
373proc XAuth::call {site method {params ""}} {
374    variable clients
375    variable tokens
376
377    if {![regexp {^https://} $site]} {
378        error "bad site URL \"$site\": should be https://..."
379    }
380    set site [string trimright $site /]
381    set method [string trimleft $method /]
382
383    if {![info exists tokens($site)]} {
384        error "must call XAuth::init for $site first to authenticate"
385    }
386    foreach {clientToken clientSecret} $clients($site) break
387    foreach {userToken userSecret} $tokens($site) break
388
389    set url $site/$method
390    set nonce [XAuth::nonce]
391    set tstamp [clock seconds]
392
393    # BE CAREFUL -- put all query parameters in alphabetical order
394    array set qparams [list \
395        oauth_consumer_key $clientToken \
396        oauth_nonce $nonce \
397        oauth_signature_method "HMAC-SHA1" \
398        oauth_timestamp $tstamp \
399        oauth_token $userToken \
400        oauth_version "1.0" \
401        x_auth_mode "client_auth" \
402    ]
403    array set qparams $params
404
405    set query ""
406    foreach key [lsort [array names qparams]] {
407        lappend query $key $qparams($key)
408    }
409    set query [eval http::formatQuery $query]
410
411    set base "POST&[urlencode $url]&[urlencode $query]"
412    set key "$clientSecret&$userSecret"
413    set sig [urlencode [base64::encode [sha1::hmac -bin -key $key $base]]]
414
415    # build the header and send the request
416    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]
417
418    return [XAuth::fetch $url -headers [list Authorization $auth] -query $query]
419}
420
421# ----------------------------------------------------------------------
422# USAGE: XAuth::fetch <url> ?-headers <keyvalList>? ?-query <str>?
423#
424# Sends a GET/POST request off to the specified <url>.  If the -query
425# string is specified, then this is assumed to be an encoded list of
426# parameters and the operation is POST.  Tries a few times in case the
427# web site is busy.
428# ----------------------------------------------------------------------
429proc XAuth::fetch {url args} {
430    variable redirects
431
432    set hdr ""
433    set query ""
434    foreach {key val} $args {
435        switch -- $key {
436            -headers { set hdr $val }
437            -query   { set query $val }
438            default {
439                error "bad option \"$key\": should be -headers or -query"
440            }
441        }
442    }
443
444    # send off the request a few times
445    set ntries 5
446    while {1} {
447        if {[catch {http::geturl $url -headers $hdr -query $query -timeout 30000} token] == 0} {
448            break
449        }
450        if {[incr ntries -1] <= 0} {
451            error "web request \"$url\" failed to load: $token"
452        }
453        after 5000
454    }
455
456    # handle the response
457    upvar #0 $token state
458
459    # look for errors
460    switch -- [http::ncode $token] {
461        200 {
462            set rval [http::data $token]
463
464            array set meta $state(meta)
465            if {[info exists meta(Transfer-Encoding)]
466                  && $meta(Transfer-Encoding) eq "chunked"} {
467                set rval [XAuth::unchunk $rval]
468            }
469
470            if {[info exists meta(Content-Type)]
471                  && $meta(Content-Type) eq "application/json"} {
472                set rval [JsonObject::decode $rval]
473            }
474
475            http::cleanup $token
476            set redirects ""
477            return $rval
478        }
479        301 - 302 - 303 {
480            lappend redirects $url
481            if {[llength $redirects] > 5} {
482                error "web page redirect loop for $url"
483            }
484            array set meta $state(meta)
485            if {[info exists meta(Location)]} {
486                set newurl $meta(Location)
487                if {![regexp {^https?://} $newurl] && [regexp -nocase -indices {^https?://[^/]+} $url match]} {
488                    if {[string index $newurl 0] != "/"} {
489                        set newurl "/$newurl"
490                    }
491                    foreach {s0 s1} $match break
492                    set newurl "[string range $url $s0 $s1]$newurl"
493                }
494                return [fetch $newurl -headers $hdr -query $query]
495            }
496            return ""
497        }
498        default {
499            set status [http::code $token]
500            http::cleanup $token
501            set redirects ""
502            error "web request \"$url\" failed to load: $status"
503        }
504    }
505}
506
507# ----------------------------------------------------------------------
508# USAGE: XAuth::urlencode <str>
509#
510# Encodes a string according to standard HTTP encoding conventions.
511# Punctuation characters are converted to their %XX equivalent.
512# Returns a properly encoded string.
513# ----------------------------------------------------------------------
514proc XAuth::urlencode {str} {
515    set str [http::formatQuery $str]
516    regsub -all {%[a-fA-F0-9][a-fA-F0-9]} $str {[string toupper \0]} str
517    return [subst $str]
518}
519
520# ----------------------------------------------------------------------
521# USAGE: XAuth::nonce
522#
523# Random nonce (number used once) for the OAuth protocol.  Each nonce
524# should be unique when interpreted in conjunction with the timestamp.
525# Any large, random number should work here.
526# ----------------------------------------------------------------------
527proc XAuth::nonce {} {
528    set nonce [expr {round(rand()*1e8)}][clock clicks]
529    return [sha1::sha1 $nonce]
530}
531
532# ----------------------------------------------------------------------
533# USAGE: XAuth::unchunk <string>
534#
535# Used internally to decode a <string> from a web server that has been
536# transferred with "chunk" encoding.  In this case, the string contains
537# a hexadecimal size, a newline, a chunk of text, another hexadecimal
538# size, a newline, another chunk of text, etc.  Returns a clean string
539# with all of the hex values removed.
540# ----------------------------------------------------------------------
541proc XAuth::unchunk {str} {
542    set rval ""
543    while {[string length $str] > 0} {
544        # get the hex string for the length
545        set nlpos [string first "\n" $str]
546        if {$nlpos < 0} {
547            append rval $str
548            break
549        }
550        set hex [string range $str 0 [expr {$nlpos-1}]]
551
552        if {[scan $hex "%x" len] == 1} {
553            # get the next chunk with that length
554            set from [expr {$nlpos+1}]
555            set to [expr {$from+$len}]
556            append rval [string range $str $from [expr {$to-1}]]
557            set nl [string index $str $to]
558
559            if {$nl eq "\r"} {
560                incr to
561                set nl [string index $str $to]
562            }
563            if {$nl ne "\n" && $nl ne ""} {
564                error "garbled text in chunk-encoded string -- missing newline"
565            }
566            set str [string range $str [expr {$to+1}] end]
567        } else {
568            error "garbled text in chunk-encoded string -- missing hex value"
569        }
570    }
571    return $rval
572}
573
574# ----------------------------------------------------------------------
575# USAGE: XAuth::credentials load ?<fileName>?
576# USAGE: XAuth::credentials get <site> ?<what>?
577#
578# Clients use this to load information about the client token/secret
579# from a file and feed it along to XAuth::init.  The "load" operation
580# loads information from a file in the user's home directory.  If not
581# specified, the name "~/.xauth" is assumed.  This file contains a
582# series of lines as follows:
583#
584#   site nanoHUB.org -token abLJdjfks -secret kd18293ksjshdkdjejd
585#   site HUBzero.org -token adckdsjeL -secret dkejdklsje1wlsjd2je
586#   ...
587#
588# The "get" call returns information for the specified <site> name.
589# The optional <what> parameter can be used to request -token or
590# -secret.  Otherwise, it returns a list "-token xxx -secret yyy"
591# ----------------------------------------------------------------------
592proc XAuth::credentials {option args} {
593    variable sites
594    variable parser
595
596    switch -- $option {
597        load {
598            set fname "~/.xauth"
599            if {[llength $args] == 1} {
600                set fname [lindex $args 0]
601            } elseif {[llength $args] > 1} {
602                error "wrong # args: should be \"credentials load ?file?\""
603            }
604
605            if {![file readable $fname]} {
606                error "file \"$fname\" not found"
607            }
608            set fid [open $fname r]
609            set info [read $fid]
610            close $fid
611
612            if {[catch {$parser eval $info} result]} {
613                error "error in sites file \"$fname\": $result"
614            }
615        }
616        add {
617            set name [string tolower [lindex $args 0]]
618            foreach {key val} [lrange $args 1 end] {
619                if {$key ne "-token" && $key ne "-secret"} {
620                    error "bad option \"$key\": should be -token or -secret"
621                }
622            }
623            set sites($name) [lrange $args 1 end]
624        }
625        get {
626            set name [string tolower [lindex $args 0]]
627            set what [lindex $args 1]
628            if {$what ne "" && $what ne "-token" && $what ne "-secret"} {
629                error "bad value \"$what\": should be -token or -secret"
630            }
631
632            if {[info exists sites($name)]} {
633                if {$what eq ""} {
634                    return $sites($name)
635                }
636                array set data $sites($name)
637                return $data($what)
638            }
639            return ""
640        }
641        default {
642            error "bad option \"$option\": should be load or get"
643        }
644    }
645}
Note: See TracBrowser for help on using the repository browser.