a rest framework

This is a framework to allow one to easily develop bindings for restful web services [L1 ]. Below the framework itself are examples of varying completeness that should give one a decent understanding of how to use the framework.

some minimal documentation

a binding consists of definitions of rest calls where each call is an array element. the name of the bindings and the namespace it is created in is taken from the array name. the array keys become the commands. each call definition is in the form of a dict where the keys and values are option names and values.

the recognized options and their allowed values are as follows

copy: this copies the definition of a previously defined call. this should probably the first element in a definition. after copying you can override selected options by defining them again.
unset: removes the named option. useful when using copy.
headers: the value must be another dict containing header fields and their values. default is empty.
content-type: specify the content type for the request
url: kind of self explanatory. the url may contain tokens in the form %name% where name becomes a required argument and the value is substituted into the url at call time. tokens in the form of %name:default_value% will be an optional argument with a default value.
method: the method to use on the url. valid values are the normal get/post/put/delete. default is get
req_args: a list of the required arguments. names ending in a colon will require a value.
opt_args: arguments that may be present but are not required.
static_args: arguments that are always the same. no sense in troubling the user with these.
auth: currently only accepts the value "basic". if this argument is used you can configure basic auth with the proc auth_basic which takes 2 arguments, the username and password.
sign: ?
pre_transform: this value takes the form of a proc which should perform some action on $result and return a value. it is run on the result before the output (xml/json/etc) transformation is done.
result: may have the value xml, json, raw, or auto. the default is auto and should auto detect json or xml results and transform them into a tcl list. this is here if you want to specify it explicitly.
post_transform: this value takes the form of a proc which should perform some action on $result and return a value. it is run on the result after the output transformation but before returning the value to the calling procedure.
check_result: this value should be a list of 2 expressions either of which may be empty. the first expression is checks the OK condition, it must return true when the result is satisfactory. the second expression is the error condition, it must return false unless there is an error.

after creating the definitions simple call rest::create_interface on the array. you may also use rest::save to save the created procedures as a standalone module.

Code

 package require dict
 package require http
 package require json
 package require tdom
 package require tls
 package require base64
 ::http::register https 443 [list ::tls::socket]

 package provide rest 1.0

 namespace eval ::rest {}

 proc ::rest::create_interface {name} {
    upvar $name in
    namespace eval ::$name {}
    foreach call [array names in] {
        set config $in($call)
        set proc [list]
        
        if {[dict exists $config copy]} {
            set config [dict merge $in([dict get $config copy]) $config]
        }
        if {[dict exists $config unset]} {
            set config [dict unset $config [dict get $config unset]]
        }
        
        
        lappend proc "set config \{$config\}"
        lappend proc "set headers \[list]"
        lappend proc "set url [dict get $config url]"

        set opts [list]
        if {[dict exists $config static_args]} {
            foreach {k v} [dict get $config static_args] {
                if {$v != ""} {
                    dict lappend config req_args ${k}:
                    lappend proc "lappend args -$k $v"
                } else {
                    dict lappend config req_args $k
                    lappend proc "lappend args -$k"
                }
            }
        }
        
        if {[dict exists $config headers]} {
            foreach val [dict values [dict get $config headers]] {
                foreach {junk x} [regexp -all -inline {%([a-z0-9_-]+)%} $val] {
                    dict lappend config req_args $x:
                }
            }
        }
        
        lappend opts [expr {[dict exists $config req_args] ? [dict get $config req_args] : ""}]
        lappend opts [expr {[dict exists $config opt_args] ? [dict get $config opt_args] : ""}]
        lappend proc "set parsed \[::rest::_parse_opts \$url $opts \$args]"
        lappend proc "set url \[lindex \$parsed 0]"
        lappend proc "set query \[lindex \$parsed 1]"
        lappend proc "set body \[lindex \$parsed 2]"

        if {[dict exists $config auth]} {
            set auth [dict get $config auth]
            if {$auth == "basic"} {
                lappend proc "lappend headers Authorization \"Basic \[base64::encode \$\{::${name}::user\}:\$\{::${name}::password\}]\""
            }
        }

        if {[dict exists $config headers]} {
            lappend proc "eval lappend headers \[::rest::_headers \{[dict get $config headers]\} query]"
        }
        if {[dict exists $config cookie]} {
            lappend proc "lappend headers Cookie [join [dict get $config cookie] \;]"
        }

        if {[dict exists $config sign]} {
            lappend proc "set query [::${name}::[dict get $config sign] \$query]"
        } else {
            lappend proc "set query \[eval ::http::formatQuery \$query]"
        }
        lappend proc "set result \[::rest::_call \$headers \$url \$query \$body]"
        if {[dict exists $config pre_transform]} {
            lappend proc "set result \[::${name}::_pre_transform_$call \$result]"
            proc ::${name}::_pre_transform_$call result [dict get $config pre_transform]
        }
        if {[dict exists $config result]} {
            lappend proc "set result \[::rest::_format_[dict get $config result] \$result]"
        } else {
            lappend proc "set result \[::rest::_format_auto \$result]"
        }
        if {[dict exists $config post_transform]} {
            lappend proc "set result \[::${name}::_post_transform_$call \$result]"
            proc ::${name}::_post_transform_$call result [dict get $config post_transform]
        }
        if {[dict exists $config check_result]} {
            lappend proc "::rest::_check_result \$result [dict get $config check_result]"
        }
        lappend proc "return \$result"
        
        proc ::${name}::$call args [join $proc \n]
        
    }
    proc ::${name}::basic_auth {u p} {
        variable user $u
        variable password $p
    }
    
    return $name
 }

 proc ::rest::save {name file} {
    set fh [open $file w]
    puts $fh {package require dict
 package require http
 package require json
 package require tdom
 package require tls
 package require base64
 ::http::register https 443 [list ::tls::socket]}
    puts $fh "namespace eval ::$name \{\}"
    foreach x {_call _parse_opts _check_result _format_xml _format_json} {
        puts $fh "proc ::${name}::$x \{[info args $x]\} \{[info body $x]\n\}\n"
    }
    foreach x [info commands ::${name}::*] {
        puts $fh "proc $x \{[info args $x]\} \{[info body $x]\n\}\n"
    }
    close $fh
 }

 proc ::rest::parameters {url args} {
    set dict [list]
    foreach x [split [lindex [split $url ?] 1] &] {
        set x [split $x =]
        if {[llength $x] < 2} { lappend x "" }
        eval lappend dict $x
    }
    if {[llength $args] > 0} {
        return [dict get $dict [lindex $args 0]]
    }
    return $dict
 }

 proc ::rest::_call {headers url query body} {
    upvar config config
    if {$body != ""} {
        set url $url?$query
        set query $body
    } elseif {![dict exists $config method] || [dict get $config method] == "get"} {
        set url $url?$query
    }
    #puts "geturl $url"
    #return
    set opts [list]
    if {[dict exists $config content-type]} {
        lappend opts -type [dict get $config content-type]
    }
    if {[dict exists $config method]} {
        if {[dict get $config method] == "post"} {
            lappend opts -query $query
        } else {
            lappend opts -method [dict get $config method]
        }
    }
    set t [eval [list http::geturl $url -headers $headers] $opts]
    if {![string match 2* [http::ncode $t]]} {
        #parray $t
        if {[http::ncode $t] == "302"} {
            upvar #0 $t a
            return -code error "HTTP 302 [dict get $a(meta) Location]"
        }
        return -code error "HTTP [http::ncode $t]"
    }
    set data [http::data $t]
    #parray $t
    #puts "data: $data"
    http::cleanup $t
    return $data
 }

 proc ::rest::_parse_opts {url required optional options} {
    set args $options
    set query [list]
    if {[set params [regexp -all -inline {%([a-z0-9_:-]+)%} $url]] != ""} {
        foreach {junk x} $params {
            if {[string match *:* $x]} {
                set x [split $x :]
                lappend optional [lindex $x 0]:
            } else {
                lappend required $x:
            }
        }
    }
    foreach opt $required {
        set hasarg 0
        if {[string index $opt end] == ":"} {
            set opt [string range $opt 0 end-1]
            set hasarg 1
        }
        if {[set i [lsearch -exact $args -$opt]] < 0} {
            return -code error "the -$opt argument is required"
        }
        if {$hasarg} {
            lappend query $opt [lindex $args [expr {$i+1}]]
            set args [lreplace $args $i [expr {$i+1}]]
        } else {
            lappend query $opt ""
            set args [lreplace $args $i $i]
        }
    }
    for {set i 0} {$i < [llength $args]} {incr i} {
        set opt [lindex $args $i]
        if {![string match -* $opt]} break
        set opt [string range $opt 1 end]
        
        if {[set j [lsearch -exact $optional $opt:]] > -1} {
            lappend query $opt [lindex $args [expr {$i+1}]]
            set args [lreplace $args $i [expr {$i+1}]]
            incr i -1
        } elseif {[set j [lsearch -exact $optional $opt]] > -1} {
            lappend query $opt ""
            set args [lreplace $args $i $i]
        } else {
            return -code error "Unknown option $opt"
        }
    }
    
    foreach {junk x} $params {
        if {[string match *:* $x]} {
            set x [split $x :]
            if {![dict exists $query [lindex $x 0]]} {
                eval lappend query $x
            }
        } else {
            set val [dict get $query $x]
            set query [dict remove $query $x]
            set url [string map [list %$x% $val] $url]
        }
    }
    puts "url: $url\nquery: $query\nbody: [join $args]"
    return [list $url $query [join $args]]
 }

 proc ::rest::_headers {headers q} {
    upvar $q query
    dict for {key val} $headers {
        foreach {junk x} [regexp -all -inline {%([a-z0-9_-]+)%} $val] {
            set replace [dict get $query $x]
            set query [dict remove $query $x]
            set val [string map [list %$x% $replace] $val]
            set headers [dict replace $headers $key $val]
        }
    }
    return $headers
 }

 proc ::rest::_check_result {result ok err} {
    if {$err != "" && ![catch {expr $err} out] && [expr {$out}]} {
        return -code error "Error expression failed or returned true"
    }
    if {$ok != "" && ![catch {expr $ok} out] && [expr {$out}]} {
        return -code ok
    }
    return -code error "Ok expression failed or returned false"
 }

 proc ::rest::_format_raw {data} {
    return $data
 }

 proc ::rest::_format_auto {data} {
    if {[string match {<*} [string trimleft $data]]} {
        return [_format_xml $data]
    }
    if {[regexp {":\s*\{} $data]} {
        return [_format_json $data]
    }
    return $data
 }

 proc ::rest::_format_json {data} {
    #if {[regexp -nocase {^[a-z_.]+ *= *(.*)} $data -> json]} {
    #    set data $json
    #}
    #puts $data
    return [json::json2dict $data]
 }

 proc ::rest::_format_xml {data} {
    set d [[dom parse -simple $data] documentElement]
    return [$d asList]
    return $data
 }

bindings for del.icio.us

 set delicious(updated) {
    url https://api.del.icio.us/v1/posts/update
    auth basic
    post_transform {
        regexp {<update time=\"(.*?)\"} $result -> update
        return [clock scan [string map {T " " Z " UTC"} $update]]
    }
 }

 set delicious(add_post) {
    url https://api.del.icio.us/v1/posts/add
    auth basic
    req_args { url: description: }
    opt_args { extended: tags: dt: replace: shared: }
    check_result { {[regexp {<result code=\"done} $result]} {} }
    result raw
 }

 set delicious(delete_post) {
    url { https://api.del.icio.us/v1/posts/delete }
    auth basic
    req_args { url: }
    check_result { {[regexp {<result code=\"done} $result]} {} }
 }

 set delicious(get_posts) {
    url { https://api.del.icio.us/v1/posts/get }
    auth basic
    opt_args { url: tag: dt: hashes: meta: }
 }

 set delicious(recent_posts) {
    url { https://api.del.icio.us/v1/posts/recent }
    auth basic
    opt_args { tag: }
 }

 set delicious(post_dates) {
    url { https://api.del.icio.us/v1/posts/dates }
    auth basic
    opt_args { tag: count: }
 }

 set delicious(get_all_posts) {
    url { https://api.del.icio.us/v1/posts/all }
    auth basic
    opt_args { tag: start: results: fromdt: todt: meta: }
 }

 set delicious(get_hashes) {
    url { https://api.del.icio.us/v1/posts/all }
    auth basic
    static_args { hashes {} }
 }

 set delicious(get_tags) {
    url { https://api.del.icio.us/v1/tags/get }
    auth basic
 }

 set delicious(delete_tag) {
    url { https://api.del.icio.us/v1/tags/delete }
    auth basic
    req_args { tag: }
    check_result { {[regexp {<result>done} $result]} {} }
 }

 set delicious(rename_tag) {
    url { https://api.del.icio.us/v1/tags/rename }
    auth basic
    req_args { old: new: }
    check_result { {[regexp {<result>done} $result]} {} }
 }

 set delicious(get_bundles) {
    url { https://api.del.icio.us/v1/bundles/all }
    auth basic
    opt_args { bundle: }
    result xml
 }

 set delicious(set_bundle) {
    url { https://api.del.icio.us/v1/bundles/set }
    auth basic
    req_args { bundle: tags: }
    check_result { {[regexp {<result>ok} $result]} {} }
 }

 set delicious(delete_bundle) {
    url { https://api.del.icio.us/v1/bundles/delete }
    auth basic
    req_args { bundle: }
    check_result { {[regexp {<result>done} $result]} {} }
 }

 set delicious(public_posts) {
    url http://feeds.delicious.com/v2/json/%user%
    opt_args { count: }
    pre_transform {
        regexp {Delicious.posts = (.*)} $result -> json
        return $json
    }
    result json
 }

bindings for twitter

 set twitter(public_timeline) {
   url http://twitter.com/statuses/public_timeline.json
   result json
 }

 set twitter(friends_timeline) {
   url http://twitter.com/statuses/friends_timeline.json
   auth basic
   opt_args { since: since_id: count: page: }
 }

 set twitter(user_timeline) {
   url http://twitter.com/statuses/user_timeline.json
   auth basic
   opt_args { id: since: since_id: count: page: }
 }

 set twitter(show_status) {
   url http://twitter.com/statuses/show/%id%.json
   auth basic
 }

 set twitter(update) {
   url http://twitter.com/statuses/update.json
   auth basic
   method post
   req_args { status: }
   opt_args { in_reply_to_status_id: }
 }

 set twitter(replies) {
   url http://twitter.com/statuses/replies.json
   auth basic
   opt_args { since: since_id: page: }
 }

 set twitter(destroy) {
   url http://twitter.com/statuses/destroy/%id%.json
   auth basic
   method post
 }

 set twitter(friends) {
   url http://twitter.com/statuses/friends.json
   auth basic
   opt_args { id: page: lite: since: }
 }

 set twitter(followers) {
   url http://twitter.com/statuses/followers.json
   auth basic
   opt_args { id: page: lite: }
 }

 set twitter(featured) {
   url http://twitter.com/statuses/featured.json
   auth basic
 }

 set twitter(show_user) {
   url http://twitter.com/users/show/%id%.json
   auth basic
   opt_args { email: }
 }

bindings for yahoo boss

(build your own search service)

 set yboss(web) {
   url http://boss.yahooapis.com/ysearch/web/v1/%query%
   req_args { appid: }
   opt_args { start: count: lang: region: sites: filter: type: }
   #result json
   post_transform { return [dict get $result ysearchresponse] }
   check_result { {[dict get $result responsecode] == "200"} {} }
 }

 set yboss(news) {
   url http://boss.yahooapis.com/ysearch/news/v1/%query%
   req_args { appid: }
   opt_args { start: count: lang: region: sites: age: }
   result json
   check_result { {[dict $result responsecode] == "200"} {} }
 }

bindings for google calendar

Attention: ClientLogin has been officially deprecated since April 20, 2012 and is now no longer available. Requests to ClientLogin will fail with a HTTP 404 response. We encourage you to migrate to OAuth 2.0 as soon as possible.

 set gcal(auth) {
   url https://www.google.com/accounts/ClientLogin
   method post
   req_args { Email: Passwd: source: }
   static_args { service cl }
   post_transform {
       regexp {Auth=(.*)} $result -> result
       return $result
   }
 }

 set gcal(all_calendars) {
    url http://www.google.com/calendar/feeds/default/allcalendars/full
    headers { Authorization {GoogleLogin auth=%token%} }
    opt_args { gsessionid: }
 }

 set gcal(own_calendars) {
    url http://www.google.com/calendar/feeds/default/owncalendars/full
    headers { Authorization {GoogleLogin auth=%token%} }
    opt_args { gsessionid: }
 }

 set gcal(new_calendar) {
    url http://www.google.com/calendar/feeds/default/owncalendars/full
    method post
    content-type application/atom+xml
    headers { Authorization {GoogleLogin auth=%token%} }
    opt_args { gsessionid: }
 }

 set gcal(edit_calendar) {
    url http://www.google.com/calendar/feeds/default/owncalendars/full/%calendar%
    method put
    content-type application/atom+xml
    headers { Authorization {GoogleLogin auth=%token%} }
    opt_args { gsessionid: }
 }

 set gcal(delete_calendar) {
    url http://www.google.com/calendar/feeds/default/owncalendars/full/%calendar%
    method delete
    headers { Authorization {GoogleLogin auth=%token%} }
    opt_args { gsessionid: }
 }

 set gcal(all_events) {
    url http://www.google.com/calendar/feeds/%user:default%/%calendar%/%visibility:private%/full
    headers { Authorization {GoogleLogin auth=%token%} }
    opt_args { gsessionid: }
 }

 set gcal(new_event) {
    url http://www.google.com/calendar/feeds/default/private/full
    method post
    content-type application/atom+xml
    headers { Authorization {GoogleLogin auth=%token%} }
    opt_args { gsessionid: }
 }

 proc ::gcal::handle_redir {args} {
    if {[catch {eval $args} out]} {
        if {[lindex $out 1] == "302"} {
        puts $out
            eval [linsert $args 1 -gsessionid [rest::parameters [lindex $out 2] gsessionid]]
        } else {
            return -code error $out
        }
    }
 }

Note that yesterday, gsessionid seemed to have disappeared in favour of a new t parameter, I have recoded my own handle_redir to be as follows instead:

 proc ::gcal::handle_redir {args} {
    if {[catch {eval $args} out]} {
        if {[lindex $out 1] == "302"} {
            set parms [rest::parameters [lindex $out 2]]
            if { [dict exists $parms gsessionid] } {
                eval [linsert $args 1 -gsessionid [dict get $parms gsessionid]]
            } elseif { [dict exists $parms t] } {
                eval [linsert $args 1 -t [dict get $parms t]]
            }
        } else {
            return -code error $out
        }
    } else {
        return $out
    }
 }

Usage Examples

 set auth [gcal::auth -Email [email protected] -Passwd password -source tcl]
 puts [gcal::handle_redir gcal::all_events -token $auth -calendar]


 puts [delicious::get_posts -url https://wiki.tcl-lang.org/]

 delicious::basic_auth user password
 puts [delicious::add_post -url https://wiki.tcl-lang.org -description "the tclers wiki"]



 twitter::auth user password
 puts [twitter::user_timeline]



 set appid X
 set data [yboss::web -appid $appid -count 50 -start 250 -query tcl]
 foreach x [dict get $data resultset_web] {
    puts [dict get $x abstract]
 }

Category Internet

Category Interprocess Communication

Category web