1# SOAP.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net> 2# Copyright (C) 2008 Andreas Kupries <andreask@activestate.com> 3# 4# Provide Tcl access to SOAP 1.1 methods. 5# 6# See http://tclsoap.sourceforge.net/ or doc/TclSOAP.html for usage details. 7# 8# ------------------------------------------------------------------------- 9# This software is distributed in the hope that it will be useful, but 10# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 11# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE' 12# for more details. 13# ------------------------------------------------------------------------- 14 15package require http 2.0; # tcl 8.n 16package require log; # tcllib 1.0 17package require uri; # tcllib 1.0 18catch {package require uri::urn}; # tcllib 1.2 19package require SOAP::Utils; # TclSOAP 20package require rpcvar; # TclSOAP 21 22# ------------------------------------------------------------------------- 23 24namespace eval ::SOAP {variable domVersion} 25 26# ------------------------------------------------------------------------- 27 28namespace eval ::SOAP { 29 variable version 1.6.8.1 30 variable logLevel warning 31 variable rcs_version { $Id: SOAP.tcl,v 1.51 2008/07/09 16:14:23 andreas_kupries Exp $ } 32 33 namespace export create cget dump configure proxyconfig export 34 catch {namespace import -force Utils::*} ;# catch to allow pkg_mkIndex. 35 catch {namespace import -force [uplevel {namespace current}]::rpcvar::*} 36} 37 38# ------------------------------------------------------------------------- 39 40# Description: 41# Register the namespace for handling SOAP methods using 'scheme' as a 42# transport. See the http.tcl and smtp.tcl files for examples of how 43# to plug in a new scheme. 44# A SOAP transport package requires an 'xfer' method for performing the 45# SOAP method call and a 'configure' method for setting any transport 46# specific options via SOAP::configure -transport. 47# You may also have a 'dump' method to help with debugging. 48# Parameters: 49# scheme - should be a URI scheme (in fact it must be recognised by the 50# then uri package from tcllib) 51# namespace - the namespace within which the transport methods are defined. 52# 53proc ::SOAP::register {scheme namespace} { 54 variable transports 55 set transports($scheme) $namespace 56} 57 58# Description: 59# Internal method to return the namespace hosting a SOAP transport using 60# the URL scheme 'scheme'. 61# 62proc ::SOAP::schemeloc {scheme} { 63 variable transports 64 if {[info exists transports($scheme)]} { 65 return $transports($scheme) 66 } else { 67 return -code error "invalid transport scheme:\ 68 \"$scheme\" is not registered. Try one of [array names transports]" 69 } 70} 71 72# Description: 73# Check for the existence of a SOAP Transport specific procedure. 74# If the named proc exists then the fully qualified name is returned 75# otherwise an empty string is returned. 76# Used by SOAP::destroy, SOAP::wait and others. 77# 78proc ::SOAP::transportHook {procVarName cmdname} { 79 upvar $procVarName procvar 80 81 array set URL [uri::split $procvar(proxy)] 82 if {$URL(scheme) == "urn"} { 83 set URL(scheme) "$a(scheme):$a(nid)" 84 } 85 set cmd [schemeloc $URL(scheme)]::$cmdname 86 if {[info command $cmd] == {}} { 87 set cmd {} 88 } 89 return $cmd 90} 91# ------------------------------------------------------------------------- 92 93# Description: 94# Called from SOAP package methods, shift up to the callers level and 95# get the fully namespace qualified name for the given proc / var 96# Parameters: 97# name - the name of a Tcl entity, or list of command and arguments 98# Result: 99# Fully qualified namespace path for the named entity. If the name 100# parameter is a list the the first element is namespace qualified 101# and the remainder of the list is unchanged. 102# 103proc ::SOAP::qualifyNamespace {name} { 104 if {$name != {}} { 105 set name [lreplace $name 0 0 \ 106 [uplevel 2 namespace origin [lindex $name 0]]] 107 } 108 return $name 109} 110 111# ------------------------------------------------------------------------- 112 113# Description: 114# An interal procedure to mangle and SOAP method name and it's namespace 115# and generate a name for use as a specific SOAP variable. This ensures 116# that similarly named methods in different namespaces do not conflict 117# within the SOAP package. 118# Parameters: 119# methodName - the SOAP method name 120# 121proc ::SOAP::methodVarName {methodName} { 122 if {[catch {uplevel 2 namespace origin $methodName} name]} { 123 return -code error "invalid method name:\ 124 \"$methodName\" is not a SOAP method" 125 } 126 regsub -all {::+} $name {_} name 127 return [namespace current]::$name 128} 129 130# ------------------------------------------------------------------------- 131 132# Description: 133# Set the amount of logging you would like to see. This is for debugging 134# the SOAP package. We use the tcllib log package for this so the level 135# must be one of log::levels. The default is 'warning'. 136# Parameters: 137# level - one of log::levels. See the tcllib log package documentation. 138# 139proc ::SOAP::setLogLevel {level} { 140 variable logLevel 141 set logLevel $level 142 log::lvSuppressLE emergency 0 143 log::lvSuppressLE $logLevel 1 144 log::lvSuppress $logLevel 0 145 return $logLevel 146} 147if {[info exists SOAP::logLevel]} { 148 SOAP::setLogLevel $SOAP::logLevel 149} 150 151# ------------------------------------------------------------------------- 152 153# Description: 154# Retrieve configuration variables from the SOAP package. The options 155# are all as found for SOAP::configure. 156# 157# FIXME: do for -transport as well! 158# 159proc ::SOAP::cget { args } { 160 161 if { [llength $args] != 2 } { 162 return -code error "wrong # args:\ 163 should be \"cget methodName optionName\"" 164 } 165 166 set methodName [lindex $args 0] 167 set optionName [lindex $args 1] 168 set configVarName [methodVarName $methodName] 169 170 # FRINK: nocheck 171 if {[catch {set [subst $configVarName]([string trimleft $optionName "-"])} result]} { 172 # kenstir@synchonicity.com: Fixed typo. 173 return -code error "unknown option \"$optionName\"" 174 } 175 return $result 176} 177 178# ------------------------------------------------------------------------- 179 180# Description: 181# Dump out information concerning the last SOAP transaction for a 182# SOAP method. What you can dump depends on the transport involved. 183# Parameters: 184# ?-option? - specify type of data to dump. 185# methodName - the SOAP method to dump data from. 186# Notes: 187# Delegates to the transport namespace to a 'dump' procedure. 188# 189proc ::SOAP::dump {args} { 190 if {[llength $args] == 1} { 191 set type -reply 192 set methodName [lindex $args 0] 193 } elseif { [llength $args] == 2 } { 194 set type [lindex $args 0] 195 set methodName [lindex $args 1] 196 } else { 197 return -code error "wrong # args:\ 198 should be \"dump ?option? methodName\"" 199 } 200 201 # call the transports 'dump' proc if found 202 set procVarName [methodVarName $methodName] 203 if {[set cmd [transportHook $procVarName dump]] != {}} { 204 $cmd $methodName $type 205 } else { 206 return -code error "no dump available:\ 207 the configured transport has no 'dump' procedure defined" 208 } 209} 210 211# ------------------------------------------------------------------------- 212 213# Description: 214# Configure or display a SOAP method options. 215# Parameters: 216# procName - the SOAP method Tcl procedure name 217# args - list of option name / option pairs 218# Result: 219# Sets up a configuration array for the SOAP method. 220# 221proc ::SOAP::configure { procName args } { 222 variable transports 223 224 # The list of valid options, used in the error messsage 225 set options { uri proxy params name transport action \ 226 wrapProc replyProc parseProc postProc \ 227 command errorCommand schemas version \ 228 encoding} 229 230 if { $procName == "-transport" } { 231 set scheme [lindex $args 0] 232 set config "[schemeloc $scheme]::configure" 233 if {[info command $config] != {}} { 234 return [eval $config [lrange $args 1 end]] 235 } else { 236 return -code error "invalid transport:\ 237 \"$scheme\" is not a valid SOAP transport method." 238 } 239 } 240 241 if { [string match "-logLevel" $procName] } { 242 if {[llength $args] > 0} { 243 setLogLevel [lindex $args 0] 244 } 245 variable logLevel 246 return $logLevel 247 } 248 249 # construct the name of the options array from the procName. 250 set procVarName "[uplevel namespace current]::$procName" 251 regsub -all {::+} $procVarName {_} procVarName 252 set procVarName [namespace current]::$procVarName 253 254 # Check that the named method has actually been defined 255 if {! [array exists $procVarName]} { 256 return -code error "invalid command: \"$procName\" not defined" 257 } 258 upvar $procVarName procvar 259 260 # Add in transport plugin defined options and locate the 261 # configuration hook procedure if one exists. 262 set scheme [eval getTransportFromArgs $procVarName $args] 263 if {$scheme != {}} { 264 set transport_opts "[schemeloc $scheme]::method:options" 265 if {[info exists $transport_opts]} { 266 # FRINK: nocheck 267 set options [concat $options [set $transport_opts]] 268 } 269 set transportHook "[schemeloc $scheme]::method:configure" 270 } 271 272 # if no args - print out the current settings. 273 if { [llength $args] == 0 } { 274 set r {} 275 foreach opt $options { 276 if {[info exists procvar($opt)]} { 277 lappend r -$opt $procvar($opt) 278 } 279 } 280 return $r 281 } 282 283 foreach {opt value} $args { 284 switch -glob -- $opt { 285 -rpcprot* { set procvar(rpcprotocol) $value } 286 -uri { set procvar(uri) $value } 287 -proxy { set procvar(proxy) $value } 288 -param* { set procvar(params) $value } 289 -trans* { set procvar(transport) $value } 290 -name { set procvar(name) $value } 291 -action { set procvar(action) $value } 292 -schema* { set procvar(schemas) $value } 293 -ver* { set procvar(version) $value } 294 -enc* { set procvar(encoding) $value } 295 -namedpar* { set procvar(namedparams) $value } 296 -wrap* { set procvar(wrapProc) [qualifyNamespace $value] } 297 -rep* { set procvar(replyProc) [qualifyNamespace $value] } 298 -parse* { set procvar(parseProc) [qualifyNamespace $value] } 299 -post* { set procvar(postProc) [qualifyNamespace $value] } 300 -com* { set procvar(command) [qualifyNamespace $value] } 301 -err* { 302 set procvar(errorCommand) [qualifyNamespace $value] 303 } 304 default { 305 # might be better to delete the args as we process them 306 # and then call this once with all the remaining args. 307 # Still - this will work fine. 308 if {[info exists transportHook] 309 && [info command $transportHook] != {}} { 310 if {[catch {eval $transportHook $procVarName \ 311 [list $opt] [list $value]}]} { 312 return -code error "unknown option \"$opt\":\ 313 must be one of ${options}" 314 } 315 } else { 316 return -code error "unknown option \"$opt\":\ 317 must be one of ${options}" 318 } 319 } 320 } 321 } 322 323 if { $procvar(name) == {} } { 324 set procvar(name) $procName 325 } 326 327 # If the transport proc is not overridden then set based upon the proxy 328 # scheme registered by SOAP::register. 329 if { $procvar(transport) == {} } { 330 set xferProc "[schemeloc $scheme]::xfer" 331 if {[info command $xferProc] != {}} { 332 set procvar(transport) $xferProc 333 } else { 334 return -code error "invalid transport:\ 335 \"$scheme\" is improperly registered" 336 } 337 } 338 339 340 if {$procvar(rpcprotocol) eq "SOAP"} { 341 # The default version is SOAP 1.1 342 if { $procvar(version) == {} } { 343 set procvar(version) SOAP1.1 344 } 345 # Canonicalize the SOAP version URI 346 switch -glob -- $procvar(version) { 347 SOAP1.1 - 1.1 { 348 set procvar(version) "http://schemas.xmlsoap.org/soap/envelope/" 349 } 350 SOAP1.2 - 1.2 { 351 set procvar(version) "http://www.w3.org/2001/06/soap-envelope" 352 } 353 } 354 } 355 356 # Default SOAP encoding is SOAP 1.1 357 if { $procvar(encoding) == {} } { 358 set procvar(encoding) SOAP1.1 359 } 360 switch -glob -- $procvar(encoding) { 361 SOAP1.1 - 1.1 { 362 set procvar(encoding) "http://schemas.xmlsoap.org/soap/encoding/" 363 } 364 SOAP1.2 - 1.2 { 365 set procvar(encoding) "http://www.w3.org/2001/06/soap-encoding" 366 } 367 } 368 369 # Select the default parser unless one is specified 370 if { $procvar(parseProc) == {} } { 371 set procvar(parseProc) [namespace current]::parse_soap_response 372 } 373 374 # If no request wrapper is set, use the default SOAP wrap proc. 375 if { $procvar(wrapProc) == {} } { 376 set procvar(wrapProc) [namespace current]::soap_request 377 } 378 379 # Create the Tcl procedure that maps to this RPC method. 380 uplevel 1 "proc $procName { args } {eval [namespace current]::invoke $procVarName \$args}" 381 382 # return the fully qualified command name created. 383 return [uplevel 1 "namespace which $procName"] 384} 385 386# ------------------------------------------------------------------------- 387 388# Description: 389# Create a Tcl wrapper for a SOAP methodcall. This constructs a Tcl command 390# and the necessary data structures to support the method call using the 391# specified transport. 392# 393proc ::SOAP::create { args } { 394 if { [llength $args] < 1 } { 395 return -code error "wrong # args:\ 396 should be \"create procName ?options?\"" 397 } else { 398 set procName [lindex $args 0] 399 set args [lreplace $args 0 0] 400 } 401 402 set ns "[uplevel namespace current]::$procName" 403 regsub -all {::+} $ns {_} varName 404 set varName [namespace current]::$varName 405 array set $varName {} 406 array set $varName {rpcprotocol SOAP} ;# SOAP, XMLRPC or JSONRPC 407 array set $varName {uri {}} ;# the XML namespace URI for this method 408 array set $varName {proxy {}} ;# URL for the location of a provider 409 array set $varName {params {}} ;# name/type pairs for the parameters 410 array set $varName {transport {}} ;# transport procedure for this method 411 array set $varName {name {}} ;# SOAP method name 412 array set $varName {action {}} ;# Contents of the SOAPAction header 413 array set $varName {wrapProc {}} ;# encode request into XML for sending 414 array set $varName {replyProc {}} ;# post process the raw XML result 415 array set $varName {parseProc {}} ;# parse raw XML and extract the values 416 array set $varName {postProc {}} ;# post process the parsed result 417 array set $varName {command {}} ;# asynchronous reply handler 418 array set $varName {errorCommand {}} ;# asynchronous error handler 419 array set $varName {headers {}} ;# SOAP Head elements returned. 420 array set $varName {schemas {}} ;# List of SOAP Schemas in force 421 array set $varName {version {}} ;# SOAP Version in force (URI) 422 array set $varName {encoding {}} ;# SOAP Encoding (URI) 423 array set $varName {namedparams false}; # Use named or positional params ? 424 425 set scheme [eval getTransportFromArgs $varName $args] 426 if {$scheme != {}} { 427 # Add any transport defined method options 428 set transportOptions "[schemeloc $scheme]::method:options" 429 # FRINK: nocheck 430 foreach opt [set $transportOptions] { 431 array set $varName [list $opt {}] 432 } 433 434 # Call any transport defined construction proc 435 set createHook "[schemeloc $scheme]::method:create" 436 if {[info command $createHook] != {}} { 437 eval $createHook $varName $args 438 } 439 } 440 441 # call configure from the callers level so it can get the namespace. 442 return [uplevel 1 "[namespace current]::configure $procName $args"] 443} 444 445# Identify the transport protocol so we can include transport specific 446# creation code. 447proc getTransportFromArgs {procVarName args} { 448 upvar $procVarName procvar 449 set uri {} 450 set scheme {} 451 if {$procvar(proxy) != {}} { 452 set uri $procvar(proxy) 453 } elseif {[set n [lsearch -exact $args -proxy]] != -1} { 454 incr n 455 set uri [lindex $args $n] 456 } 457 458 if {$uri != {}} { 459 array set URL [uri::split $uri] 460 if {$URL(scheme) == "urn"} { 461 set URL(scheme) $URL(scheme):$URL(nid) 462 } 463 set scheme $URL(scheme) 464 } 465 return $scheme 466} 467 468# ------------------------------------------------------------------------- 469 470# Description: 471# Export a list of procedure names as SOAP endpoints. This is only used 472# in the SOAP server code to specify the subset of Tcl commands that should 473# be accessible via a SOAP call. 474# Parameters: 475# args - a list of tcl commands to be made available as SOAP endpoints. 476# 477proc ::SOAP::export {args} { 478 foreach item $args { 479 uplevel "set \[namespace current\]::__soap_exports($item)\ 480 \[namespace code $item\]" 481 } 482 return 483} 484 485# ------------------------------------------------------------------------- 486 487# Description: 488# Reverse the SOAP::create command by deleting the SOAP method binding and 489# freeing up any allocated resources. This needs to delegate to the 490# transports cleanup procedure if one is defined as well. 491# Parameters: 492# methodName - the name of the SOAP method command 493# 494proc ::SOAP::destroy {methodName} { 495 set procVarName [methodVarName $methodName] 496 497 # Delete the SOAP command 498 uplevel rename $methodName {{}} 499 500 # Call the transport specific method destructor (if any) 501 if {[set cmd [transportHook $procVarName method:destroy]] != {}} { 502 $cmd $procVarName 503 } 504 505 # Delete the SOAP method configuration array 506 # FRINK: nocheck 507 unset $procVarName 508} 509 510# ------------------------------------------------------------------------- 511 512# Description: 513# Wait for any pending asynchronous method calls. 514# Parameters: 515# methodName - the method binding we are interested in. 516# 517proc ::SOAP::wait {methodName} { 518 set procVarName [methodVarName $methodName] 519 520 # Call the transport specific method wait proc (if any) 521 if {[set cmd [transportHook $procVarName wait]] != {}} { 522 $cmd $procVarName 523 } 524} 525 526# ------------------------------------------------------------------------- 527 528# Description: 529# Make a SOAP method call using the configured transport. 530# See also 'invoke2' for the reply handling which may be asynchronous. 531# Parameters: 532# procName - the SOAP method configuration variable path 533# args - the parameter list for the SOAP method call 534# Returns: 535# Returns the parsed and processed result of the method call 536# 537proc ::SOAP::invoke { procVarName args } { 538 set procName [lindex [split $procVarName {_}] end] 539 if {![array exists $procVarName]} { 540 return -code error "invalid command: \"$procName\" not defined" 541 } 542 543 upvar $procVarName procvar 544 545 # Get the URL 546 set url $procvar(proxy) 547 548 # Get the XML data containing our request by calling the -wrapProc 549 # procedure 550 set req [eval "$procvar(wrapProc) $procVarName $args"] 551 552 # Send the SOAP packet (req) using the configured transport procedure 553 set transport $procvar(transport) 554 set reply [$transport $procVarName $url $req] 555 556 # Check for an async command handler. If async then return now, 557 # otherwise call the invoke second stage immediately. 558 if { $procvar(command) != {} } { 559 return $reply 560 } 561 return [invoke2 $procVarName $reply] 562} 563 564# ------------------------------------------------------------------------- 565 566# Description: 567# The second stage of the method invocation deals with unwrapping the 568# reply packet that has been received from the remote service. 569# Parameters: 570# procVarName - the SOAP method configuration variable path 571# reply - the raw data returned from the remote service 572# Notes: 573# This has been separated from `invoke' to support asynchronous 574# transports. It calls the various unwrapping hooks in turn. 575# 576proc ::SOAP::invoke2 {procVarName reply} { 577 set ::lastReply $reply 578 579 set procName [lindex [split $procVarName {_}] end] 580 upvar $procVarName procvar 581 582 # Post-process the raw XML using -replyProc 583 if { $procvar(replyProc) != {} } { 584 set reply [$procvar(replyProc) $procVarName $reply] 585 } 586 587 # Call the relevant parser to extract the returned values 588 set parseProc $procvar(parseProc) 589 if { $parseProc == {} } { 590 set parseProc parse_soap_response 591 } 592 set r [$parseProc $procVarName $reply] 593 594 # Post process the parsed reply using -postProc 595 if { $procvar(postProc) != {} } { 596 set r [$procvar(postProc) $procVarName $r] 597 } 598 599 return $r 600} 601 602# ------------------------------------------------------------------------- 603 604# Description: 605# Dummy SOAP transports to examine the SOAP requests generated for use 606# with the test package and for debugging. 607# Parameters: 608# procVarName - SOAP method name configuration variable 609# url - URL of the remote server method implementation 610# soap - the XML payload for this SOAP method call 611# 612namespace eval SOAP::Transport::print { 613 variable method:options {} 614 proc configure {args} { 615 return 616 } 617 proc xfer { procVarName url soap } { 618 puts "$soap" 619 } 620 SOAP::register urn:print [namespace current] 621} 622 623namespace eval SOAP::Transport::reflect { 624 variable method:options {} 625 proc configure {args} { 626 return 627 } 628 proc xfer {procVarName url soap} { 629 return $soap 630 } 631 SOAP::register urn:reflect [namespace current] 632} 633 634# ------------------------------------------------------------------------- 635 636# Description: 637# Setup SOAP HTTP transport for an authenticating proxy HTTP server. 638# At present the SOAP package only supports Basic authentication and this 639# dialog is used to configure the proxy information. 640# Parameters: 641# none 642 643proc ::SOAP::proxyconfig {} { 644 package require Tk 645 if { [catch {package require base64}] } { 646 return -code error "proxyconfig requires the tcllib base64 package." 647 } 648 toplevel .tx 649 wm title .tx "Proxy Authentication Configuration" 650 set m [message .tx.m1 -relief groove -justify left -width 6c -aspect 200 \ 651 -text "Enter details of your proxy server (if any) and your\ 652 username and password if it is needed by the proxy."] 653 set f1 [frame .tx.f1] 654 set f2 [frame .tx.f2] 655 button $f2.b -text "OK" -command {destroy .tx} 656 pack $f2.b -side right 657 label $f1.l1 -text "Proxy (host:port)" 658 label $f1.l2 -text "Username" 659 label $f1.l3 -text "Password" 660 entry $f1.e1 -textvariable SOAP::conf_proxy 661 entry $f1.e2 -textvariable SOAP::conf_userid 662 entry $f1.e3 -textvariable SOAP::conf_passwd -show {*} 663 grid $f1.l1 -column 0 -row 0 -sticky e 664 grid $f1.l2 -column 0 -row 1 -sticky e 665 grid $f1.l3 -column 0 -row 2 -sticky e 666 grid $f1.e1 -column 1 -row 0 -sticky news 667 grid $f1.e2 -column 1 -row 1 -sticky news 668 grid $f1.e3 -column 1 -row 2 -sticky news 669 grid columnconfigure $f1 1 -weight 1 670 pack $f2 -side bottom -fill x 671 pack $m -side top -fill x -expand 1 672 pack $f1 -side top -anchor n -fill both -expand 1 673 674 #bind .tx <Enter> "$f2.b invoke" 675 676 tkwait window .tx 677 SOAP::configure -transport http -proxy $SOAP::conf_proxy 678 if { [info exists SOAP::conf_userid] } { 679 SOAP::configure -transport http \ 680 -headers [list "Proxy-Authorization" \ 681 "Basic [lindex [base64::encode ${SOAP::conf_userid}:${SOAP::conf_passwd}] 0]" ] 682 } 683 unset SOAP::conf_passwd 684} 685 686# ------------------------------------------------------------------------- 687 688# Description: 689# Prepare a SOAP fault message 690# Parameters: 691# faultcode - the SOAP faultcode e.g: SOAP-ENV:Client 692# faultstring - summary of the fault 693# detail - list of {detailName detailInfo} 694# Result: 695# returns the XML text of the SOAP Fault packet. 696# 697proc ::SOAP::fault {faultcode faultstring {detail {}}} { 698 set doc [newDocument] 699 set bod [reply_envelope $doc] 700 set flt [addNode $bod "SOAP-ENV:Fault"] 701 set fcd [addNode $flt "faultcode"] 702 addTextNode $fcd $faultcode 703 set fst [addNode $flt "faultstring"] 704 addTextNode $fst $faultstring 705 706 if { $detail != {} } { 707 set dtl0 [addNode $flt "detail"] 708 set dtl [addNode $dtl0 "e:errorInfo"] 709 setElementAttribute $dtl "xmlns:e" "urn:TclSOAP-ErrorInfo" 710 711 foreach {detailName detailInfo} $detail { 712 set err [addNode $dtl $detailName] 713 addTextNode $err $detailInfo 714 } 715 } 716 717 # serialize the DOM document and return the XML text 718 set r [generateXML $doc] 719 deleteDocument $doc 720 return $r 721} 722 723# ------------------------------------------------------------------------- 724 725# Description: 726# Generate the common portion of a SOAP replay packet 727# Parameters: 728# doc - the document element of a DOM document 729# Result: 730# returns the body node 731# 732proc ::SOAP::reply_envelope { doc } { 733 set env [addNode $doc "SOAP-ENV:Envelope"] 734 setElementAttribute $env \ 735 "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/" 736 setElementAttribute $env \ 737 "xmlns:xsi" "http://www.w3.org/1999/XMLSchema-instance" 738 setElementAttribute $env \ 739 "xmlns:xsd" "http://www.w3.org/1999/XMLSchema" 740 setElementAttribute $env \ 741 "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" 742 set bod [addNode $env "SOAP-ENV:Body"] 743 return $bod 744} 745 746# ------------------------------------------------------------------------- 747 748# Description: 749# Generate a SOAP reply packet. Uses 'rpcvar' variable type information to 750# manage complex data structures and arrays. 751# Parameters: 752# doc empty DOM document element 753# uri URI of the SOAP method 754# methodName the SOAP method name 755# result the reply data 756# Result: 757# returns the DOM document root 758# 759proc ::SOAP::reply { doc uri methodName result } { 760 set bod [reply_envelope $doc] 761 set cmd [addNode $bod "ns:$methodName"] 762 setElementAttribute $cmd "xmlns:ns" $uri 763 setElementAttribute $cmd \ 764 "SOAP-ENV:encodingStyle" \ 765 "http://schemas.xmlsoap.org/soap/encoding/" 766 767 # insert the results into the DOM tree (unless it's a void result) 768 if {$result != {}} { 769 # Some methods may return a parameter list of name - value pairs. 770 if {[rpctype $result] == "PARAMLIST"} { 771 foreach {resultName resultValue} [rpcvalue $result] { 772 set retnode [addNode $cmd $resultName] 773 SOAP::insert_value $retnode $resultValue 774 } 775 } else { 776 set retnode [addNode $cmd "return"] 777 SOAP::insert_value $retnode $result 778 } 779 } 780 781 return $doc 782} 783 784# ------------------------------------------------------------------------- 785 786# Description: 787# Procedure to generate the XML data for a configured SOAP procedure. 788# This is the default SOAP -wrapProc procedure 789# Parameters: 790# procVarName - the path of the SOAP method configuration variable 791# args - the arguments for this SOAP method 792# Result: 793# XML data containing the SOAP method call. 794# Notes: 795# We permit a small number of option to be specified on the method call 796# itself. -headers is used to set SOAP Header elements and -attr can be 797# used to set additional XML attributes on the method element (needed for 798# UDDI.) 799# 800proc ::SOAP::soap_request {procVarName args} { 801 upvar $procVarName procvar 802 803 set procName [lindex [split $procVarName {_}] end] 804 set params $procvar(params) 805 set name $procvar(name) 806 set uri $procvar(uri) 807 set soapenv $procvar(version) 808 set soapenc $procvar(encoding) 809 810 # Check for options (ie: -header) give up on the fist non-matching arg. 811 array set opts {-headers {} -attributes {}} 812 while {[string match -* [lindex $args 0]]} { 813 switch -glob -- [lindex $args 0] { 814 -header* { 815 set opts(-headers) [concat $opts(-headers) [lindex $args 1]] 816 set args [lreplace $args 0 0] 817 } 818 -attr* { 819 set opts(-attributes) [concat $opts(-attributes) [lindex $args 1]] 820 set args [lreplace $args 0 0] 821 } 822 -- { 823 set args [lreplace $args 0 0] 824 break 825 } 826 default { 827 # stop option processing at the first invalid option. 828 break 829 } 830 } 831 set args [lreplace $args 0 0] 832 } 833 834 # check for variable number of params and set the num required. 835 if {[lindex $params end] == "args"} { 836 set n_params [expr {( [llength $params] - 1 ) / 2}] 837 } else { 838 set n_params [expr {[llength $params] / 2}] 839 } 840 841 # check we have the correct number of parameters supplied. 842 if {[llength $args] < $n_params} { 843 set msg "wrong # args: should be \"$procName" 844 foreach { id type } $params { 845 append msg " " $id 846 } 847 append msg "\"" 848 return -code error $msg 849 } 850 851 set doc [newDocument] 852 set envx [addNode $doc "SOAP-ENV:Envelope"] 853 854 setElementAttribute $envx "xmlns:SOAP-ENV" $soapenv 855 setElementAttribute $envx "xmlns:SOAP-ENC" $soapenc 856 setElementAttribute $envx "SOAP-ENV:encodingStyle" $soapenc 857 858 # The set of namespaces depends upon the SOAP encoding as specified by 859 # the encoding option and the user specified set of relevant schemas. 860 foreach {nsname url} [concat \ 861 [rpcvar::default_schemas $soapenc] \ 862 $procvar(schemas)] { 863 if {! [string match "xmlns:*" $nsname]} { 864 set nsname "xmlns:$nsname" 865 } 866 setElementAttribute $envx $nsname $url 867 } 868 869 # Insert the Header elements (if any) 870 if {$opts(-headers) != {}} { 871 set headelt [addNode $envx "SOAP-ENV:Header"] 872 foreach {hname hvalue} $opts(-headers) { 873 set hnode [addNode $headelt $hname] 874 insert_value $hnode $hvalue 875 } 876 } 877 878 # Insert the body element and atributes. 879 set bod [addNode $envx "SOAP-ENV:Body"] 880 if {$uri == ""} { 881 # don't use a namespace prefix if we don't have a namespace. 882 set cmd [addNode $bod "$name" ] 883 } else { 884 set cmd [addNode $bod "ns:$name" ] 885 setElementAttribute $cmd "xmlns:ns" $uri 886 } 887 888 # Insert any method attributes 889 if {$opts(-attributes) != {}} { 890 foreach {atname atvalue} $opts(-attributes) { 891 setElementAttribute $cmd $atname $atvalue 892 } 893 } 894 895 # insert the parameters. 896 set param_no 0 897 foreach {key type} $params { 898 set val [lindex $args $param_no] 899 set d_param [addNode $cmd $key] 900 insert_value $d_param [rpcvar $type $val] 901 incr param_no 902 } 903 904 # We have to strip out the DOCTYPE element though. It would be better to 905 # remove the DOM node for this, but that didn't work. 906 set req [generateXML $doc] 907 deleteDocument $doc ;# clean up 908 909 set req [encoding convertto utf-8 $req] ;# make it UTF-8 910 return $req ;# return the XML data 911} 912 913# ------------------------------------------------------------------------- 914 915# Description: 916# Procedure to generate the XML data for a configured XML-RPC procedure. 917# Parameters: 918# procVarName - the name of the XML-RPC method variable 919# args - the arguments for this RPC method 920# Result: 921# XML data containing the XML-RPC method call. 922# 923proc ::SOAP::xmlrpc_request {procVarName args} { 924 upvar $procVarName procvar 925 926 set procName [lindex [split $procVarName {_}] end] 927 set params $procvar(params) 928 set name $procvar(name) 929 930 if { [llength $args] != [expr { [llength $params] / 2 } ]} { 931 set msg "wrong # args: should be \"$procName" 932 foreach { id type } $params { 933 append msg " " $id 934 } 935 append msg "\"" 936 return -code error $msg 937 } 938 939 set doc [newDocument] 940 set d_root [addNode $doc "methodCall"] 941 set d_meth [addNode $d_root "methodName"] 942 addTextNode $d_meth $name 943 944 if { [llength $params] != 0 } { 945 set d_params [addNode $d_root "params"] 946 } 947 948 set param_no 0 949 foreach {key type} $params { 950 set val [lindex $args $param_no] 951 set d_param [addNode $d_params "param"] 952 XMLRPC::insert_value $d_param [rpcvar $type $val] 953 incr param_no 954 } 955 956 # We have to strip out the DOCTYPE element though. It would be better to 957 # remove the DOM element, but that didn't work. 958 set req [generateXML $doc] 959 deleteDocument $doc ;# clean up 960 961 return $req ;# return the XML data 962} 963 964# ------------------------------------------------------------------------- 965 966# Description: 967# Parse a SOAP response payload. Check for Fault response otherwise 968# extract the value data. 969# Parameters: 970# procVarName - the name of the SOAP method configuration variable 971# xml - the XML payload of the response 972# Result: 973# The returned value data. 974# Notes: 975# Needs work to cope with struct or array types. 976# 977proc ::SOAP::parse_soap_response { procVarName xml } { 978 upvar $procVarName procvar 979 980 # Sometimes Fault packets come back with HTTP code 200 981 # 982 # kenstir@synchronicity.com: Catch xml parse errors and present a 983 # friendlier message. The parse method throws awful messages like 984 # "{invalid attribute list} around line 16". 985 if {$xml == {} && ![string match "http*" $procvar(proxy)]} { 986 # This is probably not an error. SMTP and FTP won't return anything 987 # HTTP should always return though (I think). 988 return {} 989 } else { 990 if {[catch {set doc [parseXML $xml]}]} { 991 return -code error -errorcode Server \ 992 "Server response is not well-formed XML.\nresponse was $xml" 993 } 994 } 995 996 set faultNode [selectNode $doc "/SENV:Envelope/SENV:Body/SENV:Fault"] 997 if {$faultNode != {}} { 998 array set fault [decomposeSoap $faultNode] 999 deleteDocument $doc 1000 if {![info exists fault(detail)]} { set fault(detail) {}} 1001 return -code error -errorinfo $fault(detail) \ 1002 [list $fault(faultcode) $fault(faultstring)] 1003 } 1004 1005 # If there is a header element then make it available via SOAP::getHeader 1006 set headerNode [selectNode $doc "/SENV:Envelope/SENV:Header"] 1007 if {$headerNode != {} \ 1008 && [string match \ 1009 "http://schemas.xmlsoap.org/soap/envelope/" \ 1010 [namespaceURI $headerNode]]} { 1011 set procvar(headers) [decomposeSoap $headerNode] 1012 } else { 1013 set procvar(headers) {} 1014 } 1015 1016 set result {} 1017 1018 if {[info exists procvar(name)]} { 1019 set responseName "$procvar(name)Response" 1020 } else { 1021 set responseName "*" 1022 } 1023 set responseNode [selectNode $doc "/SENV:Envelope/SENV:Body/$responseName"] 1024 if {$responseNode == {}} { 1025 set responseNode [lindex [selectNode $doc "/SENV:Envelope/SENV:Body/*"] 0] 1026 } 1027 1028 set nodes [getElements $responseNode] 1029 foreach node $nodes { 1030 set r [decomposeSoap $node] 1031 if {$result == {}} { set result $r } else { lappend result $r } 1032 } 1033 1034 deleteDocument $doc 1035 return $result 1036} 1037 1038# ------------------------------------------------------------------------- 1039 1040# Description: 1041# Parse an XML-RPC response payload. Check for fault response otherwise 1042# extract the value data. 1043# Parameters: 1044# procVarName - the name of the XML-RPC method configuration variable 1045# xml - the XML payload of the response 1046# Result: 1047# The extracted value(s). Array types are converted into lists and struct 1048# types are turned into lists of name/value pairs suitable for array set 1049# Notes: 1050# The XML-RPC fault response doesn't allow us to add in extra values 1051# to the fault struct. So where to put the servers errorInfo? 1052# 1053proc ::SOAP::parse_xmlrpc_response { procVarName xml } { 1054 upvar $procVarName procvar 1055 set result {} 1056 if {$xml == {} && ![string match "http*" $procvar(proxy)]} { 1057 # This is probably not an error. SMTP and FTP won't return anything 1058 # HTTP should always return though (I think). 1059 return {} 1060 } else { 1061 if {[catch {set doc [parseXML $xml]}]} { 1062 return -code error -errorcode Server \ 1063 "Server response is not well-formed XML.\n\ 1064 response was $xml" 1065 } 1066 } 1067 1068 set faultNode [selectNode $doc "/methodResponse/fault"] 1069 if {$faultNode != {}} { 1070 array set err [lindex [decomposeXMLRPC \ 1071 [selectNode $doc /methodResponse]] 0] 1072 deleteDocument $doc 1073 return -code error \ 1074 -errorcode $err(faultCode) \ 1075 -errorinfo $err(faultString) \ 1076 "Received XML-RPC Error" 1077 } 1078 1079 # Recurse over each params/param/value 1080 set n_params 0 1081 foreach valueNode [selectNode $doc \ 1082 "/methodResponse/params/param/value"] { 1083 lappend result [xmlrpc_value_from_node $valueNode] 1084 incr n_params 1085 } 1086 deleteDocument $doc 1087 1088 # If (as is usual) there is only one param, simplify things for the user 1089 # ie: sort {one two three} should return a 3 element list, not a single 1090 # element list whose first element has 3 elements! 1091 if {$n_params == 1} {set result [lindex $result 0]} 1092 return $result 1093} 1094 1095# ------------------------------------------------------------------------- 1096# Description: 1097# Parse an XML-RPC call payload. Extracts method name and parameters. 1098# Parameters: 1099# procVarName - the name of the XML-RPC method configuration variable 1100# xml - the XML payload of the response 1101# Result: 1102# A list containing the name of the called method as first element 1103# and the extracted parameter(s) as second element. Array types are 1104# converted into lists and struct types are turned into lists of 1105# name/value pairs suitable for array set 1106# Notes: 1107# 1108proc ::SOAP::parse_xmlrpc_request { xml } { 1109 set result {} 1110 if {[catch {set doc [parseXML $xml]}]} { 1111 return -code error -errorinfo Server \ 1112 "Client request is not well-formed XML.\n\ 1113 call was $xml" 1114 } 1115 1116 set methodNode [selectNode $doc "/methodCall/methodName"] 1117 set methodName [getElementValue $methodNode] 1118 1119 # Get the parameters. 1120 1121 # If there is only one parameter, simplify things for the user, 1122 # ie: sort {one two three} should return a 3 element list, not a 1123 # single element list whose first element has 3 elements! 1124 1125 set paramsNode [selectNode $doc "/methodCall/params"] 1126 set paramValues {} 1127 if {$paramsNode != {}} { 1128 set paramValues [decomposeXMLRPC $paramsNode] 1129 } 1130 if {[llength $paramValues] == 1} { 1131 set paramValues [lindex $paramValues 0] 1132 } 1133 1134 catch {deleteDocument $doc} 1135 1136 return [list $methodName $paramValues] 1137} 1138 1139# ------------------------------------------------------------------------- 1140 1141### NB: this procedure needs to be moved into XMLRPC namespace 1142 1143# Description: 1144# Retrieve the value under the given <value> node. 1145# Parameters: 1146# valueNode - reference to a <value> element in the response dom tree 1147# Result: 1148# Either a single value or a list of values. Arrays expand into a list 1149# of values, structs to a list of name/value pairs. 1150# Notes: 1151# Called recursively when processing arrays and structs. 1152# 1153proc ::SOAP::xmlrpc_value_from_node {valueNode} { 1154 set value {} 1155 set elts [getElements $valueNode] 1156 1157 if {[llength $elts] != 1} { 1158 return [getElementValue $valueNode] 1159 } 1160 set typeElement [lindex $elts 0] 1161 set type [getElementName $typeElement] 1162 1163 if {$type == "array"} { 1164 set dataElement [lindex [getElements $typeElement] 0] 1165 foreach valueElement [getElements $dataElement] { 1166 lappend value [xmlrpc_value_from_node $valueElement] 1167 } 1168 } elseif {$type == "struct"} { 1169 # struct type has 1+ members which have a name and a value elt. 1170 foreach memberElement [getElements $typeElement] { 1171 set params [getElements $memberElement] 1172 foreach param $params { 1173 set nodeName [getElementName $param] 1174 if { $nodeName == "name"} { 1175 set pname [getElementValue $param] 1176 } elseif { $nodeName == "value" } { 1177 set pvalue [xmlrpc_value_from_node $param] 1178 } 1179 } 1180 lappend value $pname $pvalue 1181 } 1182 } else { 1183 set value [getElementValue $typeElement] 1184 } 1185 return $value 1186} 1187 1188# ------------------------------------------------------------------------- 1189 1190proc ::SOAP::insert_headers {node headers} { 1191 set doc [getDocumentElement $node] 1192 if {[set h [selectNode $doc /SENV:Envelope/SENV:Header]] == {}} { 1193 set e [documentElement $doc] 1194 set h [addNode $e "SOAP-ENV:Header"] 1195 } 1196 foreach {name value} $headers { 1197 if {$name != {}} { 1198 set elt [addNode $h $name] 1199 insert_value $elt $value 1200 } 1201 } 1202} 1203 1204# ------------------------------------------------------------------------- 1205 1206proc ::SOAP::insert_value {node value} { 1207 1208 set type [rpctype $value] 1209 set subtype [rpcsubtype $value] 1210 set attrs [rpcattributes $value] 1211 set headers [rpcheaders $value] 1212 set value [rpcvalue $value] 1213 set typeinfo [typedef -info $type] 1214 set typexmlns [typedef -namespace $type] 1215 1216 # Handle any header elements 1217 if {$headers != {}} { 1218 insert_headers $node $headers 1219 } 1220 1221 # If the rpcvar namespace is a URI then assign it a tag and ensure we 1222 # have our colon only when required. 1223 if {$typexmlns != {} && [regexp : $typexmlns]} { 1224 setElementAttribute $node "xmlns:t" $typexmlns 1225 set typexmlns t 1226 } 1227 if {$typexmlns != {}} { append typexmlns : } 1228 1229 # If there are any attributes assigned, apply them. 1230 if {$attrs != {}} { 1231 foreach {aname avalue} $attrs { 1232 setElementAttribute $node $aname $avalue 1233 } 1234 } 1235 1236 if {[string match {*()} $typeinfo] || [string match {*()} $type] 1237 || [string match array $type]} { 1238 # array type: arrays are indicated by one or more () suffixes or 1239 # the word 'array' (depreciated) 1240 1241 if {[string length $typeinfo] == 0} { 1242 set dimensions [regexp -all -- {\(\)} $type] 1243 set itemtype [string trimright $type ()] 1244 if {$itemtype == "array"} { 1245 set itemtype ur-type 1246 set dimensions 1 1247 } 1248 } else { 1249 set dimensions [regexp -all -- {\(\)} $typeinfo] 1250 set itemtype [string trimright $typeinfo ()] 1251 } 1252 1253 # Look up the typedef info of the item type 1254 set itemxmlns [typedef -namespace $itemtype] 1255 if {$itemxmlns != {} && [regexp : $itemxmlns]} { 1256 setElementAttribute $node "xmlns:i" $itemxmlns 1257 set itemxmlns i 1258 } 1259 1260 # Currently we do not support non-0 offsets into the array. 1261 # This is because I don;t know how I should present this to the 1262 # user. It's got to be a dynamic attribute on the value. 1263 setElementAttribute $node \ 1264 "xmlns:SOAP-ENC" "http://schemas.xmlsoap.org/soap/encoding/" 1265 setElementAttribute $node "xsi:type" "SOAP-ENC:Array" 1266 setElementAttribute $node "SOAP-ENC:offset" "\[0\]" 1267 1268 # we need to break a multi-dim array into r0c0,r0c1,r1c0,r1c1 1269 # so list0 followed by list1 etc. 1270 # FIX ME 1271 set arrayType "$itemxmlns:$itemtype" 1272 #for {set cn 0} {$cn < $dimensions} {incr cn} 1273 append arrayType "\[[llength $value]\]" 1274 setElementAttribute $node "SOAP-ENC:arrayType" $arrayType 1275 1276 foreach elt $value { 1277 set d_elt [addNode $node "item"] 1278 if {[string match "ur-type" $itemtype]} { 1279 insert_value $d_elt $elt 1280 } else { 1281 insert_value $d_elt [rpcvar $itemtype $elt] 1282 } 1283 } 1284 } elseif {[llength $typeinfo] > 1} { 1285 # a typedef'd struct. 1286 if {$typexmlns != {}} { 1287 setElementAttribute $node "xsi:type" "${typexmlns}${type}" 1288 } 1289 array set ti $typeinfo 1290 # Bounds checking - <simon@e-ppraisal.com> 1291 if {[llength $typeinfo] != [llength $value]} { 1292 return -code error "wrong # args:\ 1293 type $type contains \"$typeinfo\"" 1294 } 1295 foreach {eltname eltvalue} $value { 1296 set d_elt [addNode $node $eltname] 1297 if {![info exists ti($eltname)]} { 1298 return -code error "invalid member name:\ 1299 \"$eltname\" is not a member of the $type type." 1300 } 1301 insert_value $d_elt [rpcvar $ti($eltname) $eltvalue] 1302 } 1303 } elseif {$type == "struct"} { 1304 # an unspecified struct 1305 foreach {eltname eltvalue} $value { 1306 set d_elt [addNode $node $eltname] 1307 insert_value $d_elt $eltvalue 1308 } 1309 } else { 1310 # simple type or typedef'd enumeration 1311 if {$typexmlns != {}} { 1312 setElementAttribute $node "xsi:type" "${typexmlns}${type}" 1313 } 1314 addTextNode $node $value 1315 } 1316} 1317 1318# ------------------------------------------------------------------------- 1319 1320package provide SOAP $::SOAP::version 1321 1322if {[catch {package present SOAP::http}]} { 1323 package require SOAP::http; # TclSOAP 1.6.2+ 1324} 1325 1326# ------------------------------------------------------------------------- 1327 1328# Local variables: 1329# indent-tabs-mode: nil 1330# End: 1331