package require Tcl 8.5
package require http
package require TclOO

# RESTful service core
package provide rest 0.1

# Support class for RESTful web services. This wraps up the http package to
# make everything appear nicer.
oo::class create REST {
        variable base wadls acceptedmimetypestack
        constructor baseURL {
                set base $baseURL
                my LogWADL $baseURL
        }

        # TODO: Cookies!

        method ExtractError {tok} {
                return [http::code $tok],[http::data $tok]
        }

        method OnRedirect {tok location} {
                upvar 1 url url
                set url $location
                # By default, GET doesn't follow redirects; the next line would
                # change that...
                #return -code continue
                set where $location
                my LogWADL $where
                if {[string equal -length [string length $base/] $location $base/]} {
                        set where [string range $where [string length $base/] end]
                        return -level 2 [split $where /]
                }
                return -level 2 $where
        }

        method LogWADL url {
                return;# do nothing
                set tok [http::geturl $url?_wadl]
                set w [http::data $tok]
                http::cleanup $tok
                if {![info exist wadls($w)]} {
                        set wadls($w) 1
                        puts stderr $w
                }
        }

        method PushAcceptedMimeTypes args {
                lappend acceptedmimetypestack [http::config -accept]
                http::config -accept [join $args ", "]
                return
        }
        method PopAcceptedMimeTypes {} {
                set old [lindex $acceptedmimetypestack end]
                set acceptedmimetypestack [lrange $acceptedmimetypestack 0 end-1]
                http::config -accept $old
                return
        }

        method DoRequest {method url {type ""} {value ""}} {
                for {set reqs 0} {$reqs < 5} {incr reqs} {
                        if {[info exists tok]} {
                                http::cleanup $tok
                        }
                        set tok [http::geturl $url -method $method -type $type -query $value]
                        if {[http::ncode $tok] > 399} {
                                set msg [my ExtractError $tok]
                                http::cleanup $tok
                                return -code error $msg
                        } elseif {[http::ncode $tok] > 299 || [http::ncode $tok] == 201} {
                                set location {}
                                if {[catch {
                                        set location [dict get [http::meta $tok] Location]
                                }]} {
                                        http::cleanup $tok
                                        error "missing a location header!"
                                }
                                my OnRedirect $tok $location
                        } else {
                                set s [http::data $tok]
                                http::cleanup $tok
                                return $s
                        }
                }
                error "too many redirections!"
        }

        method GET args {
                return [my DoRequest GET $base/[join $args /]]
        }

        method POST {args} {
                set type [lindex $args end-1]
                set value [lindex $args end]
                set m POST
                set path [join [lrange $args 0 end-2] /]
                return [my DoRequest $m $base/$path $type $value]
        }

        method PUT {args} {
                set type [lindex $args end-1]
                set value [lindex $args end]
                set m PUT
                set path [join [lrange $args 0 end-2] /]
                return [my DoRequest $m $base/$path $type $value]
        }

        method DELETE args {
                set m DELETE
                my DoRequest $m $base/[join $args /]
                return
        }
}

# Local Variables:
# mode: tcl
# tab-width: 4
# End: