1# SOAP-CGI.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sf.net> 2# Copyright (C) 2008 Andreas Kupries <andreask@activestate.com> 3# 4# A CGI framework for SOAP and XML-RPC services from TclSOAP 5# 6# ------------------------------------------------------------------------- 7# This software is distributed in the hope that it will be useful, but 8# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 9# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE' 10# for more details. 11# ------------------------------------------------------------------------- 12# 13 14package require SOAP 15package require XMLRPC 16package require SOAP::Utils 17package require SOAP::http 18 19package provide SOAP::CGI 1.0.1 20 21namespace eval ::SOAP { 22 namespace eval CGI { 23 24 # ----------------------------------------------------------------- 25 # Configuration Parameters 26 # ----------------------------------------------------------------- 27 # soapdir - the directory searched for SOAP methods 28 # xmlrpcdir - the directory searched for XML-RPC methods 29 # logfile - a file to update with usage data. 30 # 31 # This framework is such that the same tcl procedure can be called 32 # for both types of request. The result will be packaged correctly 33 # So these variables can point to the _same_ directory. 34 # 35 # ** Note ** 36 # These directories will be relative to your httpd's cgi-bin 37 # directory. 38 39 variable soapdir "soap" 40 variable soapmapfile "soapmap.dat" 41 variable xmlrpcdir $soapdir 42 variable xmlrpcmapfile "xmlrpcmap.dat" 43 variable logfile "rpc.log" 44 45 # ----------------------------------------------------------------- 46 47 variable rcsid { 48 $Id: SOAP-CGI.tcl,v 1.17 2009/02/26 23:45:35 andreas_kupries Exp $ 49 } 50 variable methodName {} 51 variable debugging 0 52 variable debuginfo {} 53 variable interactive 0 54 55 catch {namespace import -force [namespace parent]::Utils::*} 56 57 namespace export log main 58 } 59} 60 61# ------------------------------------------------------------------------- 62 63# Description: 64# Maintain a basic call log so that we can monitor for errors and 65# popularity. 66# Notes: 67# This file will need to be writable by the httpd user. This is usually 68# 'nobody' on unix systems, so the logfile will need to be world writeable. 69# 70proc ::SOAP::CGI::log {protocol action result} { 71 variable logfile 72 catch { 73 if {[info exists logfile] && $logfile != {} && \ 74 [file writable $logfile]} { 75 set stamp [clock format [clock seconds] \ 76 -format {%Y%m%dT%H%M%S} -gmt true] 77 set f [open $logfile "a+"] 78 puts $f [list $stamp $protocol $action $result \ 79 $::env(REMOTE_ADDR) $::env(HTTP_USER_AGENT)] 80 close $f 81 } 82 } 83} 84 85# ------------------------------------------------------------------------- 86 87# Description: 88# Write a complete html page to stdout, setting the content length correctly. 89# Notes: 90# The string length is incremented by the number of newlines as HTTP content 91# assumes CR-NL line endings. 92# 93proc ::SOAP::CGI::write {html {type text/html} {status {}}} { 94 variable debuginfo 95 96 # Do some debug info: 97 if {$debuginfo != {}} { 98 append html "\n<!-- Debugging Information-->" 99 foreach item $debuginfo { 100 append html "\n<!-- $item -->" 101 } 102 } 103 104 # For errors, status should be "500 Reason Text" 105 if {$status != {}} { 106 puts "Status: $status" 107 } 108 109 puts "SOAPServer: TclSOAP/1.6" 110 puts "Content-Type: $type" 111 set len [string length $html] 112 puts "X-Content-Length: $len" 113 incr len [regexp -all "\n" $html] 114 puts "Content-Length: $len" 115 116 puts "\n$html" 117 catch {flush stdout} 118} 119 120# ------------------------------------------------------------------------- 121 122# Description: 123# Convert a SOAPAction HTTP header value into a script filename. 124# This is used to identify the file to source for the implementation of 125# a SOAP webservice by looking through a user defined map. 126# Also used to load an equvalent map for XML-RPC based on the class name 127# Result: 128# Returns the list for an array with filename, interp and classname elts. 129# 130proc ::SOAP::CGI::get_implementation_details {mapfile classname} { 131 if {[file exists $mapfile]} { 132 set f [open $mapfile r] 133 while {! [eof $f] } { 134 gets $f line 135 regsub "#.*" $line {} line ;# delete comments. 136 regsub -all {[[:space:]]+} $line { } line ;# fold whitespace 137 set line [string trim $line] 138 if {$line != {}} { 139 set line [split $line] 140 catch {unset elt} 141 set elt(classname) [lindex $line 0] 142 set elt(filename) [string trim [lindex $line 1] "\""] 143 set elt(interp) [lindex $line 2] 144 set map($elt(classname)) [array get elt] 145 } 146 } 147 close $f 148 } 149 150 if {[catch {set map($classname)} r]} { 151 error "\"$classname\" not implemented by this endpoint." 152 } 153 154 return $r 155} 156 157proc ::SOAP::CGI::soap_implementation {SOAPAction} { 158 variable soapmapfile 159 variable soapdir 160 161 if {[catch {get_implementation_details $soapmapfile $SOAPAction} detail]} { 162 set xml [SOAP::fault "Client" \ 163 "Invalid SOAPAction header: $detail" {}] 164 error $xml {} SOAP 165 } 166 167 array set impl $detail 168 if {$impl(filename) != {}} { 169 set impl(filename) [file join $soapdir $impl(filename)] 170 } 171 return [array get impl] 172} 173 174proc ::SOAP::CGI::xmlrpc_implementation {classname} { 175 variable xmlrpcmapfile 176 variable xmlrpcdir 177 178 if {[catch {get_implementation_details $xmlrpcmapfile $classname} r]} { 179 set xml [XMLRPC::fault 500 "Invalid classname: $r" {}] 180 error $xml {} XMLRPC 181 } 182 183 array set impl $r 184 if {$impl(filename) != {}} { 185 set impl(filename) [file join $xmlrpcdir $impl(filename)] 186 } 187 return [array get impl] 188} 189 190proc ::SOAP::CGI::createInterp {interp path} { 191 safe::setLogCmd [namespace current]::itrace 192 set slave [safe::interpCreate $interp] 193 safe::interpAddToAccessPath $slave $path 194 # override the safe restrictions so we can load our 195 # packages (actually the xml package files) 196 proc ::safe::CheckFileName {slave file} { 197 if {![file exists $file]} {error "file non-existent"} 198 if {![file readable $file]} {error "file not readable"} 199 } 200 return $slave 201} 202 203# ------------------------------------------------------------------------- 204 205# Description: 206# itrace prints it's arguments to stdout if we were called interactively. 207# 208proc ::SOAP::CGI::itrace args { 209 variable interactive 210 if {$interactive} { 211 puts $args 212 } 213} 214 215# Description: 216# dtrace logs debug information for appending to the end of the SOAP/XMLRPC 217# response in a comment. This is not allowed by the standards so is switched 218# on by the use of the SOAPDebug header. You can enable this with: 219# SOAP::configure -transport http -headers {SOAPDebug 1} 220# 221proc ::SOAP::CGI::dtrace args { 222 variable debuginfo 223 variable debugging 224 if {$debugging} { 225 lappend debuginfo $args 226 } 227} 228 229# ------------------------------------------------------------------------- 230 231# Description: 232# Handle UTF-8 and UTF-16 data and convert into unicode for DOM parsing 233# as necessary. 234# 235proc ::SOAP::CGI::do_encoding {xml} { 236 if {[binary scan $xml ccc c0 c1 c2] == 3} { 237 if {$c0 == -1 && $c1 == -2} { 238 dtrace "encoding: UTF-16 little endian" 239 set xml [encoding convertfrom unicode $xml] 240 } elseif {$c0 == -2 && $c1 == -1} { 241 dtrace "encoding: UTF-16 big endian" 242 binary scan $xml S* xml 243 set xml [encoding convertfrom unicode [binary format s* $xml]] 244 } elseif {$c0 == -17 && $c1 == -69 && $c2 == -65} { 245 dtrace "encoding: UTF-8" 246 set xml [encoding convertfrom utf-8 $xml] 247 } 248 } 249 return $xml 250} 251 252# ------------------------------------------------------------------------- 253 254# Description: 255# Handle incoming XML-RPC requests. 256# We extract the name of the method and the arguments and search for 257# the implementation in $::xmlrpcdir. This is then evaluated and the result 258# is wrapped up and returned or a fault packet is generated. 259# Parameters: 260# doc - a DOM tree constructed from the input request XML data. 261# 262proc ::SOAP::CGI::xmlrpc_call {doc {interp {}}} { 263 variable methodName 264 if {[catch { 265 266 set methodNode [selectNode $doc "/methodCall/methodName"] 267 set methodName [getElementValue $methodNode] 268 set methodNamespace {} 269 270 # Get the parameters. 271 set paramsNode [selectNode $doc "/methodCall/params"] 272 set argValues {} 273 if {$paramsNode != {}} { 274 set argValues [decomposeXMLRPC $paramsNode] 275 } 276 catch {deleteDocument $doc} 277 278 # Check for a permitted methodname. This is defined by being in the 279 # XMLRPC::export list for the given namespace. We must do this to 280 # prevent clients arbitrarily calling tcl commands. 281 # 282 if {[catch { 283 interp eval $interp \ 284 set ${methodNamespace}::__xmlrpc_exports($methodName) 285 } fqdn]} { 286 error "Invalid request: \ 287 method \"${methodNamespace}::${methodName}\" not found"\ 288 } 289 290 # evaluate the method 291 set msg [interp eval $interp $fqdn $argValues] 292 293 # generate a reply packet 294 set reply [XMLRPC::reply \ 295 [newDocument] \ 296 {urn:xmlrpc-cgi} "${methodName}Response" $msg] 297 298 set xml [generateXML $reply] 299 catch {deleteDocument $reply} 300 301 } msg]} { 302 set detail [list "errorCode" $::errorCode "stackTrace" $::errorInfo] 303 set xml [XMLRPC::fault 500 "$msg" $detail] 304 error $xml {} XMLRPC 305 } 306 307 # publish the answer 308 return $xml 309} 310 311# ------------------------------------------------------------------------- 312 313# Description: 314# Handle the Head section of a SOAP request. If there is a problem we 315# shall throw an error. 316# Parameters: 317# doc 318# mandate - boolean: if true then throw an error for any mustUnderstand 319# 320proc ::SOAP::CGI::soap_header {doc {mandate 0}} { 321 dtrace "Handling SOAP Header" 322 set result {} 323 foreach elt [selectNode $doc "SENV:/Envelope/SENV:Header/*"] { 324 set eltName [getElementName $elt] 325 set actor [getElementAttribute $elt actor] 326 dtrace "SOAP actor $eltName = $actor" 327 328 # If it's not for me, don't handle the header. 329 if {$actor == "" || [string match $actor \ 330 "http://schemas.xmlsoap.org/soap/actor/next"]} { 331 332 # Check for Mandatory Headers. 333 set mustUnderstand [getElementAttribute $elt mustUnderstand] 334 dtrace "SOAP mustUnderstand $eltName $mustUnderstand" 335 336 # add to the list of suitable headers. 337 lappend result [getElementName $elt] [getElementValue $elt] 338 339 340 ## Until we know what to do with such headers, we will have to 341 ## Fault. 342 if {$mustUnderstand == 1 && $mandate == 1} { 343 error "Mandatory header $eltName not understood." \ 344 {} MustUnderstand 345 } 346 } 347 } 348 return $result 349} 350 351# ------------------------------------------------------------------------- 352 353# Description: 354# Handle incoming SOAP requests. 355# We extract the name of the SOAP method and the arguments and search for 356# the implementation in the specified namespace. This is then evaluated 357# and the result is wrapped up and returned or a SOAP Fault is generated. 358# Parameters: 359# doc - a DOM tree constructed from the input request XML data. 360# 361proc ::SOAP::CGI::soap_call {doc {interp {}}} { 362 variable methodName 363 set headers {} 364 if {[catch { 365 366 # Check SOAP version by examining the namespace of the Envelope elt. 367 set envnode [selectNode $doc "/SENV:Envelope"] 368 if {$envnode != {}} { 369 #set envns [dom::node cget $envnode -namespaceURI] 370 set envns [namespaceURI $envnode] 371 if {$envns != "" && \ 372 ! [string match $envns \ 373 "http://schemas.xmlsoap.org/soap/envelope/"]} { 374 error "The SOAP Envelope namespace does not match the\ 375 SOAP version 1.1 namespace." {} VersionMismatch 376 } 377 } 378 379 # Check for Header elements 380 if {[set headerNode [selectNode $doc "/SENV:Envelope/SENV:Header"]] != {}} { 381 set headers [soap_header $doc 0] 382 dtrace "headers: $headers" 383 } 384 385 # Get the method name from the XML request. 386 # Ensure we only select the first child element (Vico.Klump@risa.de) 387 set methodNodes [selectNode $doc "/SENV:Envelope/SENV:Body/*"] 388 set methodNode [lindex $methodNodes 0] 389 set methodName [nodeName $methodNode] 390 391 # Get the XML namespace for this method. 392 set methodNamespace [namespaceURI $methodNode] 393 dtrace "methodinfo: ${methodNamespace}::${methodName}" 394 395 # Extract the parameters. 396 set old [$doc selectNodesNamespaces] 397 $doc selectNodesNamespaces [linsert $old 0 MNAME $methodNamespace] 398 set argNodes [selectNode $doc "/SENV:Envelope/SENV:Body/MNAME:${methodName}/*"] 399 $doc selectNodesNamespaces $old 400 401 set argValues {} 402 foreach node $argNodes { 403 lappend argValues [decomposeSoap $node] 404 } 405 406 # Check for a permitted methodname. This is defined by being in the 407 # SOAP::export list for the given namespace. We must do this to prevent 408 # clients arbitrarily calling tcl commands like 'eval' or 'error' 409 # 410 if {[catch { 411 interp eval $interp \ 412 set ${methodNamespace}::__soap_exports($methodName) 413 } fqdn]} { 414 dtrace "method not found: $fqdn" 415 error "Invalid SOAP request:\ 416 method \"${methodNamespace}::${methodName}\" not found" \ 417 {} "Client" 418 } 419 420 # evaluate the method 421 set msg [interp eval $interp $fqdn $argValues] 422 423 # check for mustUnderstand headers that were not understood. 424 # This will raise an error for any such header elements. 425 if {$headerNode != {}} { 426 soap_header $doc 1 427 } 428 429 # generate a reply packet 430 set reply [SOAP::reply \ 431 [newDocument] \ 432 $methodNamespace "${methodName}Response" $msg] 433 set xml [generateXML $reply] 434 catch {deleteDocument $reply} 435 catch {deleteDocument $doc} 436 437 } msg]} { 438 # Handle errors the SOAP way. 439 # 440 set detail [list "errorCode" $::errorCode "stackTrace" $::errorInfo] 441 set code [lindex $detail 1] 442 switch -exact -- $code { 443 "VersionMismatch" { 444 set code "SOAP-ENV:VersionMismatch" 445 } 446 "MustUnderstand" { 447 set code "SOAP-ENV:MustUnderstand" 448 } 449 "Client" { 450 set code "SOAP-ENV:Client" 451 } 452 "Server" { 453 set code "SOAP-ENV:Server" 454 } 455 } 456 set xml [SOAP::fault $code "$msg" $detail] 457 return -code error -errorcode SOAP $xml 458 } 459 460 # publish the answer 461 return $xml 462} 463 464# ------------------------------------------------------------------------- 465 466# Description: 467# Prepare the interpreter for XML-RPC method invocation. We try to identify 468# a Tcl file to source for the implementation of the method by using the 469# XML-RPC class name (the bit before the dot) and looking it up in the 470# xmlrpcmap file. This file also tells us if we should use a safe 471# interpreter for this method. 472# 473proc ::SOAP::CGI::xmlrpc_invocation {doc} { 474 global env 475 variable xmlrpcdir 476 477 array set impl {filename {} interp {}} 478 479 # Identify the classname part of the methodname 480 set methodNode [selectNode $doc "/methodCall/methodName"] 481 set methodName [getElementValue $methodNode] 482 set className {} 483 if {[regexp {.*\.} $methodName className]} { 484 set className [string trim $className .] 485 } 486 set files {} 487 if {$className != {}} { 488 array set impl [xmlrpc_implementation $className] 489 set files $impl(filename) 490 } 491 if {$files == {}} { 492 set files [glob $xmlrpcdir/*] 493 } 494 # Do we want to use a safe interpreter? 495 if {$impl(interp) != {}} { 496 createInterp $impl(interp) $xmlrpcdir 497 } 498 dtrace "Interp: '$impl(interp)' - Files required: $files" 499 500 # Source the XML-RPC implementation files at global level. 501 foreach file $files { 502 if {[file isfile $file] && [file readable $file]} { 503 itrace "debug: sourcing $file" 504 if {[catch { 505 interp eval $impl(interp)\ 506 namespace eval :: \ 507 "source [list $file]" 508 } msg]} { 509 itrace "warning: failed to source \"$file\"" 510 dtrace "failed to source \"$file\": $msg" 511 } 512 } 513 } 514 set result [xmlrpc_call $doc $impl(interp)] 515 if {$impl(interp) != {}} { 516 safe::interpDelete $impl(interp) 517 } 518 return $result 519} 520 521# ------------------------------------------------------------------------- 522 523# Description: 524# Load in the SOAP method implementation file on the basis of the 525# SOAPAction header. We use this header plus a map file to decide 526# what file to source, or if we should source all the files in the 527# soapdir directory. The map also provides for evaluating this method in 528# a safe slave interpreter for extra security if needed. 529# See the cgi-bin/soapmap.dat file for more details. 530# 531proc ::SOAP::CGI::soap_invocation {doc} { 532 global env 533 variable soapdir 534 535 # Obtain the SOAPAction header and strip the quotes. 536 set SOAPAction {} 537 if {[info exists env(HTTP_SOAPACTION)]} { 538 set SOAPAction $env(HTTP_SOAPACTION) 539 } 540 set SOAPAction [string trim $SOAPAction "\""] 541 itrace "SOAPAction set to \"$SOAPAction\"" 542 dtrace "SOAPAction set to \"$SOAPAction\"" 543 544 array set impl {filename {} interp {}} 545 546 # Use the SOAPAction HTTP header to identify the files to source or 547 # if it's null, source the lot. 548 if {$SOAPAction == {} } { 549 set files [glob [file join $soapdir *]] 550 } else { 551 array set impl [soap_implementation $SOAPAction] 552 set files $impl(filename) 553 if {$files == {}} { 554 set files [glob [file join $soapdir *]] 555 } 556 itrace "interp: $impl(interp): files: $files" 557 558 # Do we want to use a safe interpreter? 559 if {$impl(interp) != {}} { 560 createInterp $impl(interp) $soapdir 561 } 562 } 563 dtrace "Interp: '$impl(interp)' - Files required: $files" 564 565 foreach file $files { 566 if {[file isfile $file] && [file readable $file]} { 567 itrace "debug: sourcing \"$file\"" 568 if {[catch { 569 interp eval $impl(interp) \ 570 namespace eval :: \ 571 "source [list $file]" 572 } msg]} { 573 itrace "warning: $msg" 574 dtrace "Failed to source \"$file\": $msg" 575 } 576 } 577 } 578 579 set result [soap_call $doc $impl(interp)] 580 if {$impl(interp) != {}} { 581 safe::interpDelete $impl(interp) 582 } 583 return $result 584} 585 586# ------------------------------------------------------------------------- 587 588# Description: 589# Examine the incoming data and decide which protocol handler to call. 590# Everything is evaluated in a large catch. If any errors are thrown we 591# will wrap them up in a suitable reply. At this stage we return 592# HTML for errors. 593# Parameters: 594# xml - for testing purposes we can source this file and provide XML 595# as this parameter. Normally this will not be used. 596# 597proc ::SOAP::CGI::main {{xml {}} {debug 0}} { 598 catch {package require tcllib} ;# re-eval the pkgIndex 599 package require ncgi 600 global env 601 variable soapdir 602 variable xmlrpcdir 603 variable methodName 604 variable debugging $debug 605 variable debuginfo {} 606 variable interactive 1 607 608 if { [catch { 609 610 # Get the POSTed XML data and parse into a DOM tree. 611 if {$xml == {}} { 612 set xml [ncgi::query] 613 set interactive 0 ;# false if this is a CGI request 614 615 # Debugging can be set by the HTTP header "SOAPDebug: 1" 616 if {[info exists env(HTTP_SOAPDEBUG)]} { 617 set debugging 1 618 } 619 } 620 621 set doc [parseXML [do_encoding $xml]] 622 623 # Identify the type of request - SOAP or XML-RPC, load the 624 # implementation and call. 625 if {[selectNode $doc "/SENV:Envelope"] != {}} { 626 set result [soap_invocation $doc] 627 log "SOAP" $methodName "ok" 628 } elseif {[selectNode $doc "/methodCall"] != {}} { 629 set result [xmlrpc_invocation $doc] 630 log "XMLRPC" $methodName "ok" 631 } else { 632 deleteDocument $doc 633 error "invalid protocol: the XML data is neither SOAP not XML-RPC" 634 } 635 636 # Send the answer to the caller 637 write $result text/xml 638 639 } msg]} { 640 641 # if the error was thrown from either of the protocol 642 # handlers then the error code is set to indicate that the 643 # message is a properly encoded SOAP/XMLRPC Fault. 644 # If its a CGI problem, then be a CGI error. 645 switch -- $::errorCode { 646 SOAP { 647 write $msg text/xml "500 SOAP Error" 648 catch { 649 set doc [parseXML $msg] 650 set r [decomposeSoap [selectNode $doc /SENV:Envelope/SENV:Body/*]] 651 } msg 652 log "SOAP" [list $methodName $msg] "error" 653 } 654 XMLRPC { 655 write $msg text/xml "500 XML-RPC Error" 656 catch { 657 set doc [parseXML $msg] 658 set r [getElementNamedValues [selectNode $doc \ 659 /methodResponse/*]] 660 } msg 661 log "XMLRPC" [list $methodName $msg] "error" 662 } 663 default { 664 variable rcsid 665 666 set html "<!doctype HTML public \"-//W3O//DTD W3 HTML 2.0//EN\">\n" 667 append html "<html>\n<head>\n<title>CGI Error</title>\n</head>\n<body>" 668 append html "<h1>CGI Error</h1>\n<p>$msg</p>\n" 669 append html "<br />\n<pre>$::errorInfo</pre>\n" 670 append html "<p><font size=\"-1\">$rcsid</font></p>" 671 append html "</body>\n</html>" 672 write $html text/html "500 Internal Server Error" 673 674 log "unknown" [string range $xml 0 60] "error" 675 } 676 } 677 } 678} 679 680# ------------------------------------------------------------------------- 681# 682# Local variables: 683# mode: tcl 684# End: 685