1# beep.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# Provide an BEEP transport for the SOAP package, e.g., 4# 5# SOAP::configure -transport soap.beep \ 6# -debug true \ 7# -logfile ... \ 8# -logident ... \ 9# -option-for-mixer::init ... 10# 11# SOAP::create echoInteger 12# -uri http://soapinterop.org/ \ 13# -proxy soap.beep://qawoor.dbc.mtview.ca.us/soapinterop \ 14# -params { inputInteger int } 15# 16# BEEP support using the beepcore-tcl code from 17# http://sourceforge.net/projects/beepcore-tcl provided by M Rose. 18# 19# ------------------------------------------------------------------------- 20# This software is distributed in the hope that it will be useful, but 21# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 22# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE' 23# for more details. 24# ------------------------------------------------------------------------- 25 26package require beepcore::log; # beepcore-tcl 27package require beepcore::mixer; # beepcore-tcl 28package require beepcore::peer; # beepcore-tcl 29package require mime; # tcllib 30 31namespace eval ::SOAP::Transport::beep { 32 variable version 1.0 33 variable rcsid {$Id: beep.tcl,v 1.8 2003/09/06 17:08:46 patthoyts Exp $} 34 variable options 35 variable sessions 36 37 ::SOAP::register soap.beep [namespace current] 38 ::SOAP::register soap.beeps [namespace current] 39 40 # Initialize the transport options. 41 if {![info exists options]} { 42 array set options { 43 -logfile /dev/null 44 -logident soap 45 } 46 } 47 48 # beep sessions 49 array set sessions {} 50 51 # Declare the additional SOAP method options provided by this transport. 52 variable method:options [list \ 53 debug \ 54 logfile \ 55 logident \ 56 logT \ 57 mixerT \ 58 channelT \ 59 features \ 60 destroy \ 61 wait \ 62 ] 63} 64 65# ------------------------------------------------------------------------- 66 67# Description: 68# Implement the additional SOAP method configuration options provide 69# for this transport. 70# 71proc ::SOAP::Transport::beep::method:configure {procVarName opt value} { 72 variable options 73 74 upvar $procVarName procvar 75 switch -glob -- $opt { 76 -debug - 77 -logfile - 78 -logident { 79 set options($opt) $value 80 } 81 82 -logT - 83 -mixerT - 84 -channelT - 85 -features - 86 -destroy - 87 -wait { 88 set procvar([string trimleft $opt -]) $value 89 } 90 default { 91 return -code error "unknown option \"$opt\"" 92 } 93 } 94} 95 96# ------------------------------------------------------------------------- 97 98# Description: 99# Transport defined SOAP method creation hook. We initialize the 100# method:options that were declared above and do any transport specific 101# initialization for the method. 102# Parameters: 103# procVarName - the name of the method configuration array 104# args - the argument list that was given to SOAP::create 105# 106proc ::SOAP::Transport::beep::method:create {procVarName args} { 107 global debugP 108 variable sessions 109 upvar $procVarName procvar 110 111 if { ![info exists debugP] } { 112 set debugP 0 113 } 114 115 # procvar(proxy) will not have been set yet so: 116 set ndx [lsearch -exact $args -proxy] 117 incr ndx 1 118 if {$ndx == 0} { 119 return -code error "invalid arguments:\ 120 the \"-proxy URL\" argument is required" 121 } else { 122 set procvar(proxy) [lindex $args $ndx] 123 } 124 array set URL [uri::split $procvar(proxy)] 125 126 # create a logging object, if necessary 127 if { [set logT $procvar(logT)] == {} } { 128 set logT [set procvar(logT) \ 129 [::beepcore::log::init \ 130 [set [namespace current]::options(-logfile)] \ 131 [set [namespace current]::options(-logident)]]] 132 } 133 134 # 135 # when the RFC issues, update the default port number... 136 # -- this has now occurred: RFC 3288 137 # 138 if { $URL(port) == {} } { 139 set URL(port) 605 140 } 141 if { $URL(path) == {} } { 142 set URL(path) / 143 } 144 145 switch -- $URL(scheme) { 146 soap.beep { 147 set privacy none 148 } 149 150 soap.beeps { 151 set privacy strong 152 } 153 } 154 array set options [array get [namespace current]::options] 155 unset options(-logfile) \ 156 options(-logident) 157 array set options [list -port $URL(port) \ 158 -privacy $privacy \ 159 -servername $URL(host)] 160 161 set procName [lindex [split $procVarName {_}] end] 162 set procFQName [string map {_ ::} $procVarName] 163 164 # see if we have a session already cached 165 set signature "" 166 foreach option [lsort [array names options]] { 167 append signature $option $options($option) 168 } 169 foreach mixerT [array name sessions] { 170 catch { unset props } 171 array set props $sessions($mixerT) 172 173 if { ($props(host) != $URL(host)) \ 174 || ($props(resource) != $URL(path)) \ 175 || ($props(signature) != $signature) } { 176 continue 177 } 178 179 if { $procvar(mixerT) == $mixerT } { 180 ::beepcore::log::entry $logT debug [lindex [info level 0] 0] "$procName noop" 181 182 return 183 } 184 185 incr props(refcnt) 186 set sessions($mixerT) [array get props] 187 ::beepcore::log::entry $logT debug [lindex [info level 0] 0] \ 188 "$procName using session $mixerT, refcnt now $props(refcnt)" 189 190 set procvar(mixerT) $mixerT 191 set procvar(channelT) $props(channelT) 192 set procvar(features) $props(features) 193 194 return 195 } 196 197 # start a new session 198 switch -- [catch { eval [list ::beepcore::mixer::init $logT $URL(host)] \ 199 [array get options] } mixerT] { 200 0 { 201 set props(host) $URL(host) 202 set props(resource) $URL(path) 203 set props(signature) "" 204 foreach option [lsort [array names options]] { 205 append props(signature) $option $options($option) 206 } 207 set props(features) {} 208 set props(refcnt) 1 209 set sessions($mixerT) [array get props] 210 211 set procvar(mixerT) $mixerT 212 ::beepcore::log::entry $logT debug [lindex [info level 0] 0] \ 213 "$procName adding $mixerT to session cache, host $URL(host)" 214 } 215 216 7 { 217 array set parse $mixerT 218 ::beepcore::log::entry $logT user \ 219 "beepcore::mixer::init $parse(code): $parse(diagnostic)" 220 221 return -code error $parse(diagnostic) 222 } 223 224 default { 225 ::beepcore::log::entry $logT error beepcore::mixer::init $mixerT 226 227 return -code error $mixerT 228 } 229 } 230 231 # create the channel 232 set profile http://iana.org/beep/soap 233 234 set doc [dom::DOMImplementation create] 235 set bootmsg [dom::document createElement $doc bootmsg] 236 dom::element setAttribute $bootmsg resource /$URL(path) 237 set data [dom::DOMImplementation serialize $doc] 238 if { [set x [string first [set y "<!DOCTYPE bootmsg>\n"] $data]] >= 0 } { 239 set data [string range $data [expr $x+[string length $y]] end] 240 } 241 dom::DOMImplementation destroy $doc 242 243 switch -- [set code [catch { ::beepcore::mixer::create $mixerT $profile $data } \ 244 channelT]] { 245 0 { 246 set props(channelT) $channelT 247 set sessions($mixerT) [array get props] 248 249 set procvar(channelT) $channelT 250 } 251 252 7 { 253 array set parse $channelT 254 ::beepcore::log::entry $logT user \ 255 "beepcore::mixer::create $parse(code): $parse(diagnostic)" 256 257 # We can't call SOAP::destroy because we havn't created a SOAP 258 # method yet. The local destroy proc will clean up for us. 259 method:destroy $procVarName 260 return -code error $parse(diagnostic) 261 } 262 263 default { 264 ::beepcore::log::entry $logT error beepcore::mixer::create $channelT 265 266 method:destroy $procVarName 267 return -code error $channelT 268 } 269 } 270 271 # parse the response 272 if { [catch { ::beepcore::peer::getprop $channelT datum } data] } { 273 ::beepcore::log::entry $logT error beepcore::peer::getprop $data 274 275 method:destroy $procVarName 276 return -code error $data 277 } 278 if { [catch { dom::DOMImplementation parse $data } doc] } { 279 ::beepcore::log::entry $logT error dom::parse $doc 280 281 method:destroy $procVarName 282 return -code error "bootrpy is invalid xml: $doc" 283 } 284 if { [set node [SOAP::selectNode $doc /bootrpy]] != {} } { 285 catch { 286 set props(features) \ 287 [set [subst $procVarName](features) \ 288 [set [dom::node cget $node -attributes](features)]] 289 set sessions($mixerT) [array get props] 290 } 291 292 dom::DOMImplementation destroy $doc 293 } elseif { [set node [SOAP::selectNode $doc /error]] != {} } { 294 if { [catch { set code [set [dom::node cget $node -attributes](code)] 295 set diagnostic [SOAP::getElementValue $node] }] } { 296 set code 500 297 set diagnostic "unable to parse boot reply" 298 } 299 300 ::beepcore::log::entry $logT user "$code: $diagnostic" 301 302 dom::DOMImplementation destroy $doc 303 304 method:destroy $procVarName 305 return -code error "$code: $diagnostic" 306 } else { 307 dom::DOMImplementation destroy $doc 308 309 method:destroy $procVarName 310 return -code error "invalid protocol: the boot reply is invalid" 311 } 312} 313 314# ------------------------------------------------------------------------- 315 316# Description: 317# Configure any beep transport specific settings. 318# Anything that works for mixer::init works for us... 319# 320proc ::SOAP::Transport::beep::configure {args} { 321 variable options 322 323 if {[llength $args] == 0} { 324 return [array get options] 325 } 326 array set options $args 327 return {} 328} 329 330# ------------------------------------------------------------------------- 331 332# Description: 333# Called to release any retained resources from a SOAP method. 334# Parameters: 335# methodVarName - the name of the SOAP method configuration array 336# 337proc ::SOAP::Transport::beep::method:destroy {methodVarName} { 338 variable sessions 339 upvar $methodVarName procvar 340 341 set procName [lindex [split $methodVarName {_}] end] 342 343 set mixerT $procvar(mixerT) 344 set logT $procvar(logT) 345 346 if {[catch {::beepcore::mixer::wait $mixerT -timeout 0} result]} { 347 ::beepcore::log::entry $logT error beepcore::mixer::wait $result 348 } 349 350 array set props $sessions($mixerT) 351 if {[incr props(refcnt) -1] > 0} { 352 set sessions($mixerT) [array get props] 353 ::beepcore::log::entry $logT debug [lindex [info level 0] 0]\ 354 "$procName no longer using session $mixerT, refcnt now $props(refcnt)" 355 return 356 } 357 358 unset sessions($mixerT) 359 ::beepcore::log::entry $logT debug [lindex [info level 0] 0] \ 360 "$procName removing $mixerT from session cache" 361 362 if { [catch { ::beepcore::mixer::fin $mixerT } result] } { 363 ::beepcore::log::entry $logT error beepcore::mixer::fin $result 364 } 365 set procvar(mixerT) {} 366} 367 368# ------------------------------------------------------------------------- 369 370# Description: 371# Do the SOAP RPC call using the BEEP transport. 372# Parameters: 373# procVarName - SOAP configuration variable identifier. 374# url - the endpoint address. eg: mailto:user@address 375# soap - the XML payload for the SOAP message. 376# Notes: 377# 378proc ::SOAP::Transport::beep::xfer {procVarName url request} { 379 upvar $procVarName procvar 380 381 if {$procvar(command) != {}} { 382 set rpyV "[namespace current]::async $procVarName" 383 } else { 384 set rpyV {} 385 } 386 387 set mixerT $procvar(mixerT) 388 set channelT $procvar(channelT) 389 set logT $procvar(logT) 390 391 if {[set x [string first [set y "?>\n"] $request]] >= 0 } { 392 set request [string range $request [expr $x+[string length $y]] end] 393 } 394 set reqT [::mime::initialize -canonical application/xml -string $request] 395 396 switch -- [set code [catch { ::beepcore::peer::message $channelT $reqT \ 397 -replyCallback $rpyV } rspT]] { 398 0 { 399 ::mime::finalize $reqT 400 401 if { $rpyV != {} } { 402 return 403 } 404 405 set content [::mime::getproperty $rspT content] 406 set response [::mime::getbody $rspT] 407 408 ::mime::finalize $rspT 409 410 if {[string compare $content application/xml]} { 411 return -code error "not application/xml reply, not $content" 412 } 413 414 return $response 415 } 416 417 7 { 418 array set parse [::beepcore::mixer::errscan $mixerT $rspT] 419 ::beepcore::log::entry $logT user "$parse(code): $parse(diagnostic)" 420 421 ::mime::finalize $reqT 422 ::mime::finalize $rspT 423 return -code error "$parse(code): $parse(diagnostic)" 424 } 425 426 default { 427 ::beepcore::log::entry $logT error beepcore::peer::message $rspT 428 429 ::mime::finalize $reqT 430 return -code error $rspT 431 } 432 } 433} 434 435proc ::SOAP::Transport::beep::async {procVarName channelT args} { 436 upvar $procVarName procvar 437 438 if { [catch { eval [list async2 $procVarName] $args } result] } { 439 if { $procvar(errorCommand) != {} } { 440 set errorCommand $procvar(errorCommand) 441 if { ![catch { eval $errorCommand [list $result] } result] } { 442 return 443 } 444 } 445 446 bgerror $result 447 } 448} 449 450proc ::SOAP::Transport::beep::async2 {procVarName args} { 451 upvar $procVarName procvar 452 array set argv $args 453 454 switch -- $argv(status) { 455 positive { 456 set content [::mime::getproperty $argv(mimeT) content] 457 set reply [::mime::getbody $argv(mimeT)] 458 ::mime::finalize $argv(mimeT) 459 460 if {[string compare $content application/xml]} { 461 return -code error "not application/xml reply, not $content" 462 } 463 464 set reply [SOAP::invoke2 $procVarName $reply] 465 return [eval $procvar(command) [list $reply]] 466 } 467 468 negative { 469 set mixerT $procvar(mixerT) 470 set logT $procvar(logT) 471 472 array set parse [::beepcore::mixer::errscan $mixerT $argv(mimeT)] 473 ::beepcore::log::entry $logT user "$parse(code): $parse(diagnostic)" 474 475 ::mime::finalize $argv(mimeT) 476 return -code error "$parse(code): $parse(diagnostic)" 477 } 478 479 default { 480 ::mime::finalize $argv(mimeT) 481 482 return -code error "not expecting $argv(status) reply" 483 } 484 } 485} 486 487# ------------------------------------------------------------------------- 488 489proc ::SOAP::Transport::beep::wait {procVarName} { 490 upvar $procVarName procvar 491 ::beepcore::mixer::wait $procvar(mixerT) 492} 493 494# ------------------------------------------------------------------------- 495# Extend the uri package to support our beep URL's. I don't think these are 496# official scheme names. If they are then we can add them into the tcllib 497# code - in the meantime... 498 499catch { 500 ::uri::register {soap.beep soap.beeps beep} { 501 variable schemepart "//.*" 502 variable url "(soap.)?beeps?:${schemepart}" 503 } 504} 505 506proc ::uri::SplitSoap.beep {url} { 507 return [SplitHttp $url] 508} 509 510proc ::uri::SplitSoap.beeps {url} { 511 return [SplitHttp $url] 512} 513proc ::uri::SplitBeep {url} { 514 return [SplitHttp $url] 515} 516 517# ------------------------------------------------------------------------- 518 519package provide SOAP::beep $SOAP::Transport::beep::version 520 521# ------------------------------------------------------------------------- 522# Local Variables: 523# indent-tabs-mode: nil 524# End: 525