source: branches/1.7/lang/tcl/scripts/xauth.tcl @ 6685

Last change on this file since 6685 was 6685, checked in by clarksm, 6 years ago

Upgrade TLS protocol with merge from trunk 6684
File size: 24.9 KB
RevLine 
[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# ======================================================================
27package require Itcl
28package require http
29package require base64
30package require sha1
31package require tls
[6685]32http::register https 443 [list ::tls::socket -tls1 0 -ssl2 0 -ssl3 0]
[4514]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# ----------------------------------------------------------------------
[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]304proc 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# ----------------------------------------------------------------------
409proc 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# ----------------------------------------------------------------------
481proc 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# ----------------------------------------------------------------------
566proc 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# ----------------------------------------------------------------------
579proc 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# ----------------------------------------------------------------------
593proc 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# ----------------------------------------------------------------------
644proc 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}
Note: See TracBrowser for help on using the repository browser.