Tcl Library Source Code

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

[comment {-*- tcl -*- doctools manpage}]
[vset VERSION 1.2]
[manpage_begin rest n [vset VERSION]]
[moddesc   {A framework for RESTful web services}]
[titledesc {define REST web APIs and call them inline or asychronously}]
[require Tcl 8.5]
[require rest [opt [vset VERSION]]]
[description]

[para] The [arg config] dictionary supports the following keys

[list_begin definitions]
[def [const auth]]
[def [const content-type]]
[def [const cookie]]
[def [const error-body]]
[def [const format]]
[def [const headers]]
[def [const method]]

[comment {-- TODO -- describe the meaning of the various keys -- }]
[list_end]

[def [const callback]]

If this option is present then the method will be created as an
[term async] call. Such calls will return immediately with the value
of the associated http token instead of the call's result. The event
loop must be active to use this option.

[para] The value of this option is treated as a command prefix which
is invoked when the HTTP call is complete. The prefix will receive at
least two additional arguments, the name of the calling procedure and
the status of the result (one of [const OK] or [const ERROR]), in this
order.

[para] In case of [const OK] a third argument is added, the data
associated with the result.

[para] If and only if the [const ERROR] is a redirection, the location
redirected to will be added as argument.

Further, if the configuration key [const error-body] is set to
[const true] the data associated with the result will be added as
argument as well.

[para] The http request header will be available in that procedure via
[cmd {upvar token token}].

[comment @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@]
[def [const cookie]]

The value of this option is a list of cookies to be passed in the http
header. This is a shortcut to the [const headers] option.

[para] The first expression is checks the OK condition, it must return
[const true] when the result is satisfactory, and [const false]
otherwise.

[para] The second expression is the ERROR condition, it must return
[const false] unless there is an error, then it has to return
[const true].

[comment @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@]
[def [const error_body]]

The value of this option determines whether to return the response
when encountering an HTTP error, or not. The default is to not return
the response body on error.

[para] See [const callback] above for more information.

[comment @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@]
[list_end]

[list_end][comment {-- end of command list --}]

[section Examples]

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

package provide rest 1.2

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

# simple --

    }
    if {[dict exists $config headers]} {
        dict for {key val} [dict get $config headers] { lappend headers $key $val }
    }
    if {[dict exists $config cookie]} {
        lappend headers Cookie [join [dict get $config cookie] \;]
    }
    if {[dict exists $config error-body]} {
        set error_body [dict get $config error-body]
    } else {
        set error_body 0
    }
 
    set result [::rest::_call {} $headers $url $query $body $error_body]

    # if a format was specified then convert the data, but dont do any auto formatting
    if {[dict exists $config result]} {
        set result [::rest::format_[dict get $config result] $result]
    }

    return $result

                lappend proc "lappend query [lindex [dict get $config body] 1] \$body" {set body ""}
            } elseif {[string match mime_multi* [lindex [dict get $config body] 0]]} {
                lappend proc {if {$body == ""} { return -code error "wrong # args: should be \"[lindex [info level 0] 0] ?options? string\"" }}
                lappend proc {set b [::rest::mime_multipart body $body]}
                lappend proc {dict set config headers content-type "multipart/related; boundary=$b"}
            }
        }
        if {[dict exists $config error-body]} {
            set error_body [dict get $config error-body]
        } else {
            set error_body 0
        }
        lappend proc "set error_body $error_body"
        # end option processing

        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 {[info commands ::${name}::basic_auth] == ""} {

        lappend proc {set query [::http::formatQuery {*}$query]}
        
        # 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]"
            lappend proc {return $t}
            proc ::${name}::$call args [join $proc \n]
            set proc {}
            lappend proc {upvar token token}
        } else {
            lappend proc {set result [::rest::_call {} $headers $url $query $body $error_body]}
        }
        
        # process results
        _transform $name $call $config proc pre_transform result
        if {[dict exists $config result]} {
            lappend proc "set result \[::rest::format_[dict get $config result] \$result]"
        } elseif {[dict exists $config format]} {

#
# 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 $callback $headers $url $query $body $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 -command [list ::rest::_callback {*}$callback]
    }

    #puts "headers $headers"
    #puts "opts $opts"
    #puts "geturl $url"
    #return
    set t        [http::geturl $url -headers $headers {*}$opts]
    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
            lappend retList [dict get $a(meta) Location]
        }
        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
    # token
    upvar token token
    array set token [array get $t]

    #parray $t
    #puts "data: $data"
    http::cleanup $t
    return $data