Tcl Library Source Code

[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 1.0]
[vset PACKAGE_VERSION 1.0.1]
[manpage_begin oauth n [vset PACKAGE_VERSION]]
[keywords {oauth}]
[keywords {RFC 5849}]
[keywords {RFC 2718}]
[keywords twitter]
[copyright {2014 Javi P. <[email protected]>}]
[moddesc   {oauth}]

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

#       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 provide oauth 1.0.1

package require http
package require tls
package require base64
package require sha1

http::register https 443 ::tls::socket

#       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 ""}} {
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" \

    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}
    set header $paramList

    if {$postQuery eq {}} {
	lassign [Split $baseURL ?] url queryString
	set httpMethod GET
    } else {
	set url $baseURL
	set httpMethod {POST}
	set url         $baseURL
	set queryString $postQuery
	set httpMethod POST
    }

    lappend paramList {*}[split $queryString &]
    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] {&}]

    set headerQ [QuoteValues $header]
    set paramString [join [lsort -dictionary $paramList] &]
    
    lappend baseList $httpMethod
    lappend baseList [PercentEncode $url]
    lappend baseList [PercentEncode $paramString]
    set signString [join $baseList {&}]
    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]\""
    lappend headerQ "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] {, }]]]"
    return "Authorization [list [concat OAuth [join [lsort -dictionary $headerQ] {, }]]]"
}

# 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:
# 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 ""}} {
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 ""} {

    }
    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]
	lassign [Split $baseURL ?] url queryString
	set queryString [join [lrange [split $baseURL {?}] 1 end] {?}]
	set httpMethod {GET}
	set httpMethod GET
    } else {
	set url $baseURL
	set queryString $postQuery
	set httpMethod {POST}
	set httpMethod POST
    }
    
    if {$httpMethod eq {GET}} {
    if {$httpMethod eq "GET"} {
	if {$queryString ne {}} {
	    append url ? $queryString
	}
	set requestBody {}
    } else {
	set requestBody $queryString
    }
    if {$queryString ne {}} {
	set headerURL ${url}?${queryString}
	set header [header $url $queryString]
    } else {
	set headerURL $url
	set header [header $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
}

# QuoteValues --
#    Add double-quotes around all values in the parameter string
#    and return a list of modified parameter assignments.
proc ::oauth::QuoteValues {params} {
    set tmp {}
    foreach parameter $header {
	lassign [Split $parameter =] key value
	lappend tmp "${key}=\"${value}\""
    }
    return $tmp
}

# Split -
#	Split the string on the first separator
#       and return both parts as a list.
proc ::oauth::Split {string sep} {
    regexp "{^(\[^${sep}\]+)${sep}(.*)\$" $string -> key value
    list $key $value
}

# 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"} \

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded oauth 1 [list source [file join $dir oauth.tcl]]
package ifneeded oauth 1.0.1 [list source [file join $dir oauth.tcl]]