You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
296 lines
9.6 KiB
296 lines
9.6 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-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] |
|
|
|
|