tcllib 1.17-dfsg-1 / usr / share / tcltk / tcllib1.17 / oauth / oauth.tcl

# !/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