Tcl Library Source Code

# rest.tcl --
#
# A framework for RESTful web services
#
# Copyright (c) 2009 Aaron Faupell

package require Tcl 8.5 9+
package require http 2.7
package require json
package require tdom
package require base64

package provide rest 1.8

namespace eval ::rest {
    namespace export create_interface parameters parse_opts save \
    describe substitute
}

# simple --

        set body [lindex $opts 1]
    } else {
        set body [lindex $args 1]
    }

    DetermineMethod config

#### CLIF FIX
    # if query has a space assume it might be a list of key value pairs, 
    #   and do the formatting
    # Unless there's a space and it's a single list element,
    #   then it's more likely a json encoded string, so don't touch it.

  if {([string first " " $query] > 0) && ([llength $query] > 1)} {

        set query [::http::formatQuery {*}$query]
    } elseif {[string first ? $url] > 0 && $query == ""} {
        # if the url contains a query string and query empty then split it to the correct vars
        set query [join [lrange [split $url ?] 1 end] ?]
        set url [lindex [split $url ?] 0]
    }
#### CLIF FIX

    if {[dict exists $config auth]} {
        set auth [dict get $config auth]
        if {[lindex $auth 0] == "basic"} {
            lappend headers Authorization "Basic [base64::encode [lindex $auth 1]:[lindex $auth 2]]"
	} elseif {[lindex $auth 0] == "bearer"} {
            lappend headers Authorization "Bearer [lindex $auth 1]"

    #            break
    #        }
    #    }
    #}

    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]} {

            lappend proc {lappend headers Cookie [join [dict get $config cookie] \;]}
        }
        _transform $name $call $config proc input_transform query
        if {[dict exists $config auth] && [lindex [dict get $config auth] 0] == "sign"} {
            lappend proc "set query \[::${name}::[lindex [dict get $config auth] 1] \$query]"
        }

#        lappend proc {set query [::http::formatQuery {*}$query]}
# CLIF FIX
        # If there's headers, and if there's content-type,
	# and if that's application/json, use json format
	# else use formatQuery
        if {[dict exists $config headers]} {
	  set headers [string tolower [dict get $config headers]]
	  if {[dict exists $headers content-type]} {
	    set ctype [dict get $headers content-type]
	    switch $ctype {
	      application/json {
                lappend proc {set query [json::write object-string {*}$query]}
	      }
	      application/x-www-form-urlencoded -
	      default {
                lappend proc {set query [::http::formatQuery {*}$query]}
	      }
	    }
	  }
	} else {
          lappend proc {set query [::http::formatQuery {*}$query]}
	}
	
# CLIF FIX

        # if this is an async call (has defined a callback)
        # then end the main proc here by returning the http token
        # the rest of the normal result processing will be put in a _callback_NAME
        # proc which is called by the generic _callback proc
        if {[dict exists $config callback]} {
            lappend proc "set t \[::rest::_call \{[list ::${name}::_callback_$call [dict get $config callback]]\} \$headers \$url \$query \$body \$error_body]"

# EFFECTS:
#       creates a new namespace and builds api procedures within it
#
# RETURNS:
#       the data from the http reply, or an http token if the request was async
#
proc ::rest::_call {callback headers url query body error_body} {
    puts "_call [list C: $callback\n H: $headers\n U $url\n Q $query\n B $body\n E $error_body]"
    # get the settings from the calling proc
    upvar config config

    set method GET
    if {[dict exists $config method]} { set method [string toupper [dict get $config method]] }

    # assume the query should really be the body for post or put requests

        lappend opts -timeout [dict get $config timeout]
    }

    #puts "headers $headers"
    #puts "opts $opts"
    #puts "geturl $url"
    #return

# CLIF FIX
    if {$headers ne ""} {
      set t        [http::geturl $url -headers $headers {*}$opts]
    } else {
      set t        [http::geturl $url {*}$opts]
    }
# CLIF FIX
    set data     [http::data  $t]
    set httpCode [http::ncode $t]

    # if this is an async request return now, otherwise process the
    # result
    if {$callback != ""} { return $t }

    # Generate an error return for a failed request
    if {![string match 2* $httpCode]} {
        #parray $t
	set retList [list HTTP $httpCode]
        if {[string match {30[123]} $httpCode]} {
            upvar #0 $t a

### CLIF FIX ###
	    if {[dict exists $a(meta) Location]} {
              lappend retList [dict get $a(meta) Location]
	    } else {
	      lappend retList "Moved to undefined location"
	    }
### CLIF FIX ###
        }
        if {$error_body} {lappend retList $data}
        return -code error $retList
    }

    # copy the token into the calling scope so that the transforms can
    # access it via uplevel, and we can still call cleanup on the real