# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -buildversion.txt # module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # (C) DKF (based on DKF's REST client support class) # (C) 2024 JMN - packaging/possible mods # # @@ Meta Begin # Application punk::rest 999999.0a1.0 # Meta platform tcl # Meta license MIT # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[manpage_begin punkshell_module_punk::rest 0 999999.0a1.0] #[copyright "2024"] #[titledesc {punk::rest}] [comment {-- Name section and table of contents description --}] #[moddesc {experimental rest}] [comment {-- Description at end of page heading --}] #[require punk::rest] #[keywords module rest http] #[description] #[para] Experimental *basic rest as wrapper over http lib - use tcllib's rest package for a more complete implementation of a rest client # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Overview] #[para] overview of punk::rest #[subsection Concepts] #[para] - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[subsection dependencies] #[para] packages used by punk::rest #[list_begin itemized] package require Tcl 8.6- package require http #*** !doctools #[item] [package {Tcl 8.6}] # #package require frobz # #*** !doctools # #[item] [package {frobz}] #*** !doctools #[list_end] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section API] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #tcl::namespace::eval punk::rest::class { #*** !doctools #[subsection {Namespace punk::rest::class}] #[para] class definitions #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { #*** !doctools #[list_begin enumerated] # oo::class create interface_sample1 { # #*** !doctools # #[enum] CLASS [class interface_sample1] # #[list_begin definitions] # method test {arg1} { # #*** !doctools # #[call class::interface_sample1 [method test] [arg arg1]] # #[para] test method # puts "test: $arg1" # } # #*** !doctools # #[list_end] [comment {-- end definitions interface_sample1}] # } #*** !doctools #[list_end] [comment {--- end class enumeration ---}] #} #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::rest { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase #variable xyz #*** !doctools #[subsection {Namespace punk::rest}] #[para] Core API functions for punk::rest #[list_begin definitions] #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] # return "ok" #} set objname [namespace current]::matrixchain if {$objname ni [info commands $objname]} { # Support class for RESTful web services. # This wraps up the http package to make everything appear nicer. oo::class create CLIENT { 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 } export GET POST PUT DELETE } } #*** !doctools #[list_end] [comment {--- end definitions namespace punk::rest ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::rest::lib { tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase tcl::namespace::path [tcl::namespace::parent] #*** !doctools #[subsection {Namespace punk::rest::lib}] #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] # #[para]Description of utility1 # return 1 #} #*** !doctools #[list_end] [comment {--- end definitions namespace punk::rest::lib ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Internal] #tcl::namespace::eval punk::rest::system { #*** !doctools #[subsection {Namespace punk::rest::system}] #[para] Internal functions that are not part of the API #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::rest [tcl::namespace::eval punk::rest { variable pkg punk::rest variable version set version 999999.0a1.0 }] return #*** !doctools #[manpage_end]