Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

3 files changed, 484 insertions, 0 deletions

diff --git a/tcllib/modules/oauth/oauth.man b/tcllib/modules/oauth/oauth.man
new file mode 100644
index 0000000..6a1fea1
--- /dev/null
+++ b/tcllib/modules/oauth/oauth.man
@@ -0,0 +1,191 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 1.0]
+[manpage_begin oauth n [vset PACKAGE_VERSION]]
+[keywords {oauth}]
+[keywords {RFC 5849}]
+[keywords {RFC 2718}]
+[keywords twitter]
+[copyright {2014 Javi P. <hxm@eggdrop.es>}]
+[moddesc   {oauth}]
+[titledesc {oauth API base signature}]
+[category  Networking]
+[require Tcl 8.5]
+[require oauth [opt [vset PACKAGE_VERSION]]]
+[description]
+[para]
+
+The [package oauth] package provides a simple Tcl-only library
+for communication with [uri http://oauth.net oauth] APIs.
+
+This current version of the package supports the Oauth 1.0 Protocol,
+as specified in [uri http://tools.ietf.org/rfc/rfc5849.txt {RFC 5849}].
+
+[include ../common-text/tls-security-notes.inc]
+
+[section Commands]
+
+[list_begin definitions]
+[call [cmd ::oauth::config]]
+
+When this command is invoked without arguments it returns a dictionary
+containing the current values of all options.
+
+[call [cmd ::oauth::config] [opt [arg options]...]]
+
+When invoked with arguments, options followed by their values, it is used
+to set and query various parameters of application and client, like proxy
+host and user agent for the HTTP requests. The detailed list of options
+is below:
+
+[list_begin options]
+[opt_def -accesstoken [arg string]]
+This is the user's token.
+
+[opt_def -accesstokensecret [arg string]]
+This is the user's secret token.
+
+[opt_def -consumerkey [arg string]]
+This is the public token of your app.
+
+[opt_def -consumersecret [arg string]]
+This is the private token of your app.
+
+[opt_def -debug [arg bool]]
+The default value is [const off]. If you change this option to [const on],
+the basic signature just created will be printed to stdout, among other
+debug output.
+
+[opt_def -oauthversion [arg version]]
+This is the version of the OAuth protocol to use.
+At the moment only [const 1.0] is supported, the default.
+
+[opt_def -proxyhost [arg hostname]]
+You can set up a proxy host for send contact the oauth's api server.
+
+[opt_def -proxyport [arg port-number]]
+Port number of your proxy.
+
+[opt_def -signmethod [arg method]]
+The signature method to use. OAuth 1.0 only supports [const HMAC-SHA1], the default.
+
+[opt_def -timeout [arg milliseconds]]
+Timeout in milliseconds for your query.
+The default value is [const 6000], i.e. 6 seconds.
+
+[opt_def -urlencoding [emph encoding]]
+The encoding used for creating the x-url-encoded URLs with
+[cmd ::http::formatQuery]. The default is [const utf-8], as specified
+by [uri http://tools.ietf.org/rfc/rfc2718.txt {RFC 2718}].
+
+[list_end]
+
+[call [cmd ::oauth::header] [arg baseURL] [opt [arg postQuery]]]
+
+This command is the base signature creator. With proper settings for various tokens
+and secrets (See [cmd ::oauth::config]) the result is the base authentication string
+to send to the server.
+
+[para] You do not need to call this procedure to create the query because
+[cmd ::oauth::query] (see below) will do for it for you.
+
+Doing so is useful for debugging purposes, though.
+
+[list_begin arguments]
+[arg_def url baseURL]
+
+This argument is the URI path to the OAuth API server.
+If you plan send a GET query, you should provide a full path.
+
+[example_begin]
+HTTP GET 
+::oauth::header {https://api.twitter.com/1.1/users/lookup.json?screen_name=AbiertaMente} 
+[example_end]
+
+[arg_def url-encoded-string postQuery]
+
+When you have to send a header in POST format, you have to put the query string into this argument.
+
+[example_begin]
+::oauth::header {https://api.twitter.com/1.1/friendships/create.json} {user_id=158812437&follow=true}
+[example_end]
+
+[list_end]
+
+[call [cmd ::oauth::query] [arg baseURL] [opt [arg postQuery]]]
+
+This procedure will use the settings made with [cmd ::oauth::config] to create the
+basic authentication and then send the command to the server API.
+
+It takes the same arguments as [cmd ::oauth::header].
+
+[para] The returned result will be a list containing 2 elements. The first
+element will be a dictionary containing the HTTP header data response.
+This allows you, for example, to check the X-Rate-Limit from OAuth.
+The second element will be the raw data returned from API server.
+This string is usually a json object which can be further decoded with the
+functions of package [package json], or any other json-parser for Tcl.
+
+[para] Here is an example of how it would work in Twitter. Do not forget to
+replace the placeholder tokens and keys of the example with your own tokens
+and keys when trying it out.
+
+[example {% package require oauth
+% package require json
+% oauth::config -consumerkey {your_consumer_key}\
+-consumersecret {your_consumer_key_secret}\
+-accesstoken {your_access_token}\
+-accesstokensecret {your_access_token_secret}
+
+% set response [oauth::query https://api.twitter.com/1.1/users/lookup.json?screen_name=AbiertaMente]
+% set jsondata [lindex $response 1]
+% set data [json::json2dict $jsondata]
+$ set data [lindex $data 0]
+% dict for {key val} $data {puts "$key => $val"}
+id => 158812437
+id_str => 158812437
+name => Un Librepensador
+screen_name => AbiertaMente
+location => Explico mis tuits ahí →
+description => 160Caracteres para un SMS y contaba mi vida entera sin recortar vocales. Ahora en Twitter, podemos usar hasta 140 y a mí me sobrarían 20 para contaros todo lo q
+url => http://t.co/SGs3k9odBn
+entities => url {urls {{url http://t.co/SGs3k9odBn expanded_url http://librepensamiento.es display_url librepensamiento.es indices {0 22}}}} description {urls {}}
+protected => false
+followers_count => 72705
+friends_count => 53099
+listed_count => 258
+created_at => Wed Jun 23 18:29:58 +0000 2010
+favourites_count => 297
+utc_offset => 7200
+time_zone => Madrid
+geo_enabled => false
+verified => false
+statuses_count => 8996
+lang => es
+status => created_at {Sun Oct 12 08:02:38 +0000 2014} id 521209314087018496 id_str 521209314087018496 text {@thesamethanhim http://t.co/WFoXOAofCt} source {<a href="http://twitter.com" rel="nofollow">Twitter Web Client</a>} truncated false in_reply_to_status_id 521076457490350081 in_reply_to_status_id_str 521076457490350081 in_reply_to_user_id 2282730867 in_reply_to_user_id_str 2282730867 in_reply_to_screen_name thesamethanhim geo null coordinates null place null contributors null retweet_count 0 favorite_count 0 entities {hashtags {} symbols {} urls {{url http://t.co/WFoXOAofCt expanded_url http://www.elmundo.es/internacional/2014/03/05/53173dc1268e3e3f238b458a.html display_url elmundo.es/internacional/… indices {16 38}}} user_mentions {{screen_name thesamethanhim name Ἑλένη id 2282730867 id_str 2282730867 indices {0 15}}}} favorited false retweeted false possibly_sensitive false lang und
+contributors_enabled => false
+is_translator => true
+is_translation_enabled => false
+profile_background_color => 709397
+profile_background_image_url => http://pbs.twimg.com/profile_background_images/704065051/9309c02aa2728bdf543505ddbd408e2e.jpeg
+profile_background_image_url_https => https://pbs.twimg.com/profile_background_images/704065051/9309c02aa2728bdf543505ddbd408e2e.jpeg
+profile_background_tile => true
+profile_image_url => http://pbs.twimg.com/profile_images/2629816665/8035fb81919b840c5cc149755d3d7b0b_normal.jpeg
+profile_image_url_https => https://pbs.twimg.com/profile_images/2629816665/8035fb81919b840c5cc149755d3d7b0b_normal.jpeg
+profile_banner_url => https://pbs.twimg.com/profile_banners/158812437/1400828874
+profile_link_color => FF3300
+profile_sidebar_border_color => FFFFFF
+profile_sidebar_fill_color => A0C5C7
+profile_text_color => 333333
+profile_use_background_image => true
+default_profile => false
+default_profile_image => false
+following => true
+follow_request_sent => false
+notifications => false}]
+
+[list_end]
+[para]
+
+[vset CATEGORY oauth]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/oauth/oauth.tcl b/tcllib/modules/oauth/oauth.tcl
new file mode 100644
index 0000000..b6ab07e
--- /dev/null
+++ b/tcllib/modules/oauth/oauth.tcl
@@ -0,0 +1,291 @@
+# !/bin/sh
+# the next line will restart with tclsh wherever it is \
+exec tclsh "$0" "$@"
+
+# oauth.tcl -*- tcl -*-
+# 		This module pretend give full support to API version 1.1 of Twitter
+#		according to API v1.1’s Authentication Model
+#
+# Copyright (c) 2014 Javier Pérez - <hxm@eggdrop.es>
+#   gave to tcllib
+#
+# About OAuthv1.0a
+#       There are 3 steps we need complete to get authenticated with OAuth.
+# Steps:
+#   1. Authorizing a request: we need 7 parameters.
+#       1.1 Consumer key (oauth_consumer_key) from your app (dev.twitter.com/apps)
+#       1.2 Nonce (oauth_nonce) unique&random token autogenerated by base64 32bits
+#       1.3 Signature (oauth_signature) all the other requests and 2 secret values
+#            trought a signing algorithm.
+#       1.4 Signature method (oauth_signature_method) which is HMAC-SHA1
+#       1.5 Timestamp (oauth_timestamp) time in unix format of the request
+#       1.6 Token (oauth_token) a parameter you can obtain in your account settings
+#       1.7 Version (oauth_version) the OAuth version, actually 1.0
+
+#  TODO: create online documentation
+
+package require Tcl 8.5
+package provide oauth 1
+
+package require http
+package require tls
+package require base64
+package require sha1
+
+http::register https 443 ::tls::socket
+    
+namespace eval ::oauth {
+    namespace export query
+
+    variable commands [namespace export]
+    variable project {OAuth1.0}
+    variable version [package present oauth]
+    variable description {OAuth authentication for Twitter support.}
+    variable author {Javier Pérez <hxm@eggdrop.es>}
+    # AK: changed to ISO date format.
+    variable created {2012-12-30, published 2014-02-10}
+    variable script [info script]
+    variable contact "$project $version ~ $description ($author)"
+
+    variable oauth
+    if {![info exists oauth]} {
+        array set oauth {
+            -accesstoken        {}
+            -accesstokensecret  {}
+            -consumerkey        {}
+            -consumersecret     {}
+            -debug              0
+            -oauthversion       1.0
+            -proxyhost          {}
+            -proxyport          {}
+            -ratelimit          1
+            -signmethod         HMAC-SHA1
+            -timeout            6000
+            -urlencoding        utf-8
+        }
+        set oauth(-useragent) "Mozilla/5.0\
+                ([string totitle $::tcl_platform(platform)]; U;\
+                $::tcl_platform(os) $::tcl_platform(osVersion))\
+                oauth/${version} Tcl/[package provide Tcl]"
+    }
+}
+
+# config --
+#
+#   See documentation for details.
+#
+# Arguments:
+#   args    options parsed by the procedure.
+# Results:
+#   This procedure returns the array with the current configuration
+#   In order to create an array with the result of this procedure you can do
+#   it in this way: array set settings [oauth::config ...]
+proc ::oauth::config {args} {
+    variable oauth
+    set options [array names oauth -*]
+    set usage [join $options {, }]
+    if {$args eq {}} {
+	return [array get oauth]
+    }
+    foreach {flag value} $args {
+	set optionflag [lsearch -inline -nocase $options $flag]
+	if {$optionflag eq ""} {
+	    Error "Unknown option \"${flag}\", must be: $usage" BAD OPTION
+	}
+	set oauth($optionflag) $value
+    }
+    return [array get oauth]
+}
+
+# header --
+#       Following OAuth1.0a rules, this procedure collects all
+#       information required for get the authentication.  All we need
+#       is a header for our api queries with our user and app
+#       information for the verification of who we are. Collect it,
+#       encode it as the protocol says and add it to the geturl
+#       command.  If you want, you can use this procedure for your
+#       own queries, just use it as header. Example:
+#           http::geturl $twitter(url) -header [oauth::header <...>] <...>
+#
+# You can get more information about how twitter api works reading this:
+#   https://dev.twitter.com/overview/documentation
+#
+# Arguments:
+#       baseURL:     full url path of twitter api. If it should be sent
+#                    as GET, add the query string.
+#       postQuery:   arguments passed at the request body as POST. This
+#                    should be in http query format.
+# Result:
+#       This proc will return a list of values like this:
+#   Authorization: 
+#       OAuth oauth_consumer_key="xvz1evFS4wEEPTGEFPHBog", 
+#             oauth_nonce="kYjzVBB8Y0ZFabxSWbWovY3uYSQ2pTgmZeNu2VS4cg", 
+#             oauth_signature="tnnArxj06cWHq44gCs1OSKk%2FjLY%3D", 
+#             oauth_signature_method="HMAC-SHA1", 
+#             oauth_timestamp="1318622958", 
+#             oauth_token="370773112-GmHxMAgYyLbNEtIKZeRNFsMKPR9EyMZeS9weJAEb", 
+#             oauth_version="1.0"
+proc ::oauth::header {baseURL {postQuery ""}} {
+    variable oauth
+
+    if {$oauth(-signmethod) eq ""} {
+	Error "ERROR: invalid argument for -signmethod." BAD SIGN-METHOD
+    }
+    if {[package vcompare $oauth(-oauthversion) 1.0] != 0} {
+	Error "ERROR: this script only supports oauth_version 1.0" \
+	    BAD OAUTH-VERSION
+    }
+    if {$oauth(-consumerkey) eq ""} {
+	Error "ERROR: please define your consumer key.\
+             [namespace current]::config -consumerkey <...>" \
+	    BAD CONSUMER-KEY
+    }
+    if {$oauth(-accesstoken) eq ""} {
+	Error "ERROR: please define your app's access token.\
+             [namespace current]::config -accesstoken <...>" \
+	    BAD ACCESS-TOKEN
+    }
+
+    set randomKey [sha1::sha1 [expr {[clock milliseconds] + round(rand()*50000)}]]
+    set timestamp [clock seconds]
+
+    lappend paramList "oauth_consumer_key=$oauth(-consumerkey)"
+    lappend paramList "oauth_nonce=$randomKey"
+    lappend paramList "oauth_signature_method=$oauth(-signmethod)"
+    lappend paramList "oauth_timestamp=$timestamp"
+    lappend paramList "oauth_token=$oauth(-accesstoken)"
+    lappend paramList "oauth_version=$oauth(-oauthversion)"
+    
+    if {$postQuery eq {}} {
+	set url [lindex [split $baseURL {?}] 0]
+	set queryString [lindex [split $baseURL {?}] 1]
+	foreach argument [split $queryString {&}] {
+	    lappend paramList $argument
+	}
+	set httpMethod {GET}
+    } else {
+	set url $baseURL
+	set httpMethod {POST}
+    }
+
+    foreach parameter $paramList {
+	set key [lindex [split $parameter {=}] 0]
+	set value [join [lrange [split $parameter {=}] 1 end] {=}]
+	lappend header "${key}=\"${value}\""
+    }
+    set paramString [join [lsort -dictionary $paramList] {&}]
+    
+    lappend baseList $httpMethod
+    lappend baseList [PercentEncode $url]
+    lappend baseList [PercentEncode $paramString]
+    set signString [join $baseList {&}]
+    
+    set signKey "[PercentEncode $oauth(-consumersecret)]&[PercentEncode $oauth(-accesstokensecret)]"
+    set signature [base64::encode [sha1::hmac -bin -key $signKey $signString]]
+
+    lappend header "oauth_signature=\"[PercentEncode $signature]\""
+    if {$oauth(-debug) == 1} {
+	puts {oauth::header: Authorization Oauth}
+	foreach line $header {
+	    puts "\t$line"
+	}
+	puts "\nBaseString: $signString"
+    }
+    return "Authorization [list [concat OAuth [join [lsort -dictionary $header] {, }]]]"
+}
+
+# query --
+#       Sends to oauth API url the proper oauth header and querybody
+#       returning the raw data from Twitter for your parse.
+# Arguments:
+#       baseURL     api host URL with ?arguments if it's a GET request
+#       postQuery   POST query if it's a POST query
+# Result:
+#       The result will be list with 2 arguments.
+#       The first argument is an array with the http's header
+#       and the second one is JSON data received from the server. The header is
+#       very important because it reports your rest API limit and will
+#       inform you if you can get your account suspended.
+proc ::oauth::query {baseURL {postQuery ""}} {
+    variable oauth
+    if {$oauth(-consumerkey) eq ""} {
+	Error "ERROR: please define your consumer key.\
+            [namespace current]::config -consumerkey <...>" \
+	    BAD CONSUMER-KEY
+    }
+    if {$oauth(-consumersecret) eq ""} {
+	Error "ERROR: please define your app's consumer secret.\
+            [namespace current]::config -consumersecret <...>" \
+	    BAD CONSUMER-SECRET
+    }
+    if {$oauth(-accesstoken) eq ""} {
+	Error "ERROR: please define your access token.\
+            [namespace current]::config -accesstoken <...>" \
+	    BAD ACCESS-TOKEN
+    }
+    if {$oauth(-accesstokensecret) eq ""} {
+	Error "ERROR: please define your app's access token secret.\
+            [namespace current]::config -accesstokensecret <...>" \
+	    BAD ACCESS-TOKEN-SECRET
+    }
+    if {$postQuery eq ""} {
+	set url [lindex [split $baseURL {?}] 0]
+	set queryString [join [lrange [split $baseURL {?}] 1 end] {?}]
+	set httpMethod {GET}
+    } else {
+	set url $baseURL
+	set httpMethod {POST}
+    }
+    
+    if {$httpMethod eq {GET}} {
+	if {$queryString ne {}} {
+	    append url ? $queryString
+	}
+	set requestBody {}
+    } else {
+	set requestBody $queryString
+    }
+    if {$queryString ne {}} {
+	set headerURL ${url}?${queryString}
+    } else {
+	set headerURL $url
+    }
+
+    set header [header $headerURL]
+
+    http::config \
+	-proxyhost $oauth(-proxyhost) \
+	-proxyport $oauth(-proxyport) \
+	-useragent $oauth(-useragent)
+
+    set token [http::geturl $baseURL \
+		   -headers $header \
+		   -query   $requestBody \
+		   -method  $httpMethod \
+		   -timeout $oauth(-timeout)]
+    set ncode [http::ncode $token]
+    set data  [http::data $token]
+    upvar #0 $token state
+    lappend result [array names state]
+    lappend result $data
+    http::cleanup $token
+
+    return $result
+}
+
+
+# PercentEncode --
+#       Encoding process in http://tools.ietf.org/html/rfc3986#section-2.1
+#       for Twitter authentication. (http::formatQuery is lowcase)
+proc ::oauth::PercentEncode {string} {
+    set utf8String [encoding convertto utf-8 $string]
+    return [string map {"\n" "%0A"} \
+		[subst [regsub -all \
+			    {[^-A-Za-z0-9._~\n]} $utf8String \
+			    {%[format "%02X" [scan "\\\0" "%c"]]}]]]
+}
+
+proc ::oauth::Error {string args} {
+    return -code error -errorcode [linsert $args 0 OAUTH] $string
+}
+return
diff --git a/tcllib/modules/oauth/pkgIndex.tcl b/tcllib/modules/oauth/pkgIndex.tcl
new file mode 100644
index 0000000..513e7ff
--- /dev/null
+++ b/tcllib/modules/oauth/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded oauth 1 [list source [file join $dir oauth.tcl]]