# SOAP-CGI.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sf.net>## A CGI framework for SOAP and XML-RPC services from TclSOAP## -------------------------------------------------------------------------# This software is distributed in the hope that it will be useful, but# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY# or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'# for more details.# -------------------------------------------------------------------------#package provide SOAP::CGI 1.0namespace eval ::SOAP {    namespace eval CGI {	# -----------------------------------------------------------------	# Configuration Parameters	# -----------------------------------------------------------------	#   soapdir   - the directory searched for SOAP methods	#   xmlrpcdir - the directory searched for XML-RPC methods	#   logfile   - a file to update with usage data. 	#	#   This framework is such that the same tcl procedure can be called 	#   for both types of request. The result will be packaged correctly	#   So these variables can point to the _same_ directory.	#	# ** Note **	#   These directories will be relative to your httpd's cgi-bin	#   directory.	variable soapdir       "soap"	variable soapmapfile   "soapmap.dat"	variable xmlrpcdir     $soapdir	variable xmlrpcmapfile "xmlrpcmap.dat"	variable logfile       "rpc.log"		# -----------------------------------------------------------------	variable rcsid {	    $Id: SOAP-CGI.tcl 6394 2006-04-14 17:36:29Z tjikkun $	}	variable methodName  {}	variable debugging   0	variable debuginfo   {}	variable interactive 0		package require dom	package require SOAP	package require XMLRPC	package require SOAP::Utils        package require SOAP::http	catch {namespace import -force [namespace parent]::Utils::*}	namespace export log main    }}# -------------------------------------------------------------------------# Description:#   Maintain a basic call log so that we can monitor for errors and #   popularity.# Notes:#   This file will need to be writable by the httpd user. This is usually#   'nobody' on unix systems, so the logfile will need to be world writeable.#proc ::SOAP::CGI::log {protocol action result} {    variable logfile    catch {	if {[info exists logfile] && $logfile != {} && \		[file writable $logfile]} {	    set stamp [clock format [clock seconds] \		    -format {%Y%m%dT%H%M%S} -gmt true]	    set f [open $logfile "a+"]	    puts $f [list $stamp $protocol $action $result \		    $::env(REMOTE_ADDR) $::env(HTTP_USER_AGENT)]	    close $f	}    }}# -------------------------------------------------------------------------# Description:#   Write a complete html page to stdout, setting the content length correctly.# Notes:#   The string length is incremented by the number of newlines as HTTP content#   assumes CR-NL line endings.#proc ::SOAP::CGI::write {html {type text/html} {status {}}} {    variable debuginfo    # Do some debug info:    if {$debuginfo != {}} {	append html "\n<!-- Debugging Information-->"	foreach item $debuginfo {	    append html "\n<!-- $item -->"	}    }    # For errors, status should be "500 Reason Text"    if {$status != {}} {	puts "Status: $status"    }    puts "SOAPServer: TclSOAP/1.6"    puts "Content-Type: $type"    set len [string length $html]    puts "X-Content-Length: $len"    incr len [regexp -all "\n" $html]    puts "Content-Length: $len"    puts "\n$html"    catch {flush stdout}}# -------------------------------------------------------------------------# Description:#   Convert a SOAPAction HTTP header value into a script filename.#   This is used to identify the file to source for the implementation of#   a SOAP webservice by looking through a user defined map.#   Also used to load an equvalent map for XML-RPC based on the class name# Result:#   Returns the list for an array with filename, interp and classname elts.#proc ::SOAP::CGI::get_implementation_details {mapfile classname} {    if {[file exists $mapfile]} {	set f [open $mapfile r]	while {! [eof $f] } {	    gets $f line	    regsub "#.*" $line {} line                 ;# delete comments.	    regsub -all {[[:space:]]+} $line { } line  ;# fold whitespace	    set line [string trim $line]	    if {$line != {}} {		set line [split $line]		catch {unset elt}		set elt(classname) [lindex $line 0]		set elt(filename)  [string trim [lindex $line 1] "\""]		set elt(interp)    [lindex $line 2]		set map($elt(classname)) [array get elt]	    }	}	close $f    }        if {[catch {set map($classname)} r]} {	error "\"$classname\" not implemented by this endpoint."    }    return $r}proc ::SOAP::CGI::soap_implementation {SOAPAction} {    variable soapmapfile    variable soapdir    if {[catch {get_implementation_details $soapmapfile $SOAPAction} detail]} {	set xml [SOAP::fault "Client" \		"Invalid SOAPAction header: $detail" {}]	error $xml {} SOAP    }        array set impl $detail    if {$impl(filename) != {}} {	set impl(filename) [file join $soapdir $impl(filename)]    }    return [array get impl]}proc ::SOAP::CGI::xmlrpc_implementation {classname} {    variable xmlrpcmapfile    variable xmlrpcdir    if {[catch {get_implementation_details $xmlrpcmapfile $classname} r]} {	set xml [XMLRPC::fault 500 "Invalid classname: $r" {}]	error $xml {} XMLRPC    }    array set impl $r    if {$impl(filename) != {}} {	set impl(filename) [file join $xmlrpcdir $impl(filename)]    }    return [array get impl]}proc ::SOAP::CGI::createInterp {interp path} {    safe::setLogCmd [namespace current]::itrace    set slave [safe::interpCreate $interp]    safe::interpAddToAccessPath $slave $path    # override the safe restrictions so we can load our    # packages (actually the xml package files)    proc ::safe::CheckFileName {slave file} {	if {![file exists $file]} {error "file non-existent"}	if {![file readable $file]} {error "file not readable"}    }    return $slave}# -------------------------------------------------------------------------# Description:#   itrace prints it's arguments to stdout if we were called interactively.#proc ::SOAP::CGI::itrace args {    variable interactive    if {$interactive} {	puts $args    }}# Description:#   dtrace logs debug information for appending to the end of the SOAP/XMLRPC#   response in a comment. This is not allowed by the standards so is switched#   on by the use of the SOAPDebug header. You can enable this with:#     SOAP::configure -transport http -headers {SOAPDebug 1}#proc ::SOAP::CGI::dtrace args {    variable debuginfo    variable debugging    if {$debugging} {	lappend debuginfo $args    }}# -------------------------------------------------------------------------# Description:#   Handle UTF-8 and UTF-16 data and convert into unicode for DOM parsing#   as necessary.#proc ::SOAP::CGI::do_encoding {xml} {    if {[binary scan $xml ccc c0 c1 c2] == 3} {	if {$c0 == -1 && $c1 == -2} {	    dtrace "encoding: UTF-16 little endian"	    set xml [encoding convertfrom unicode $xml]	} elseif {$c0 == -2 && $c1 == -1} {	    dtrace "encoding: UTF-16 big endian"	    binary scan $xml S* xml	    set xml [encoding convertfrom unicode [binary format s* $xml]]	} elseif {$c0 == -17 && $c1 == -69 && $c2 == -65} {	    dtrace "encoding: UTF-8"	    set xml [encoding convertfrom utf-8 $xml]	}    }    return $xml}# -------------------------------------------------------------------------# Description:#   Handle incoming XML-RPC requests.#   We extract the name of the method and the arguments and search for#   the implementation in $::xmlrpcdir. This is then evaluated and the result#   is wrapped up and returned or a fault packet is generated.# Parameters:#   doc - a DOM tree constructed from the input request XML data.#proc ::SOAP::CGI::xmlrpc_call {doc {interp {}}} {    variable methodName    if {[catch {		set methodNode [selectNode $doc "/methodCall/methodName"]	set methodName [getElementValue $methodNode]	set methodNamespace {}	# Get the parameters.	set paramsNode [selectNode $doc "/methodCall/params"]	set argValues {}	if {$paramsNode != {}} {	    set argValues [decomposeXMLRPC $paramsNode]	}	catch {dom::DOMImplementation destroy $doc}	# Check for a permitted methodname. This is defined by being in the	# XMLRPC::export list for the given namespace. We must do this to	# prevent clients arbitrarily calling tcl commands.	#	if {[catch {	    interp eval $interp \		    set ${methodNamespace}::__xmlrpc_exports($methodName)	} fqdn]} {	    error "Invalid request: \		    method \"${methodNamespace}::${methodName}\" not found"\	}	# evaluate the method	set msg [interp eval $interp $fqdn $argValues]	# generate a reply packet	set reply [XMLRPC::reply \		[dom::DOMImplementation create] \		{urn:xmlrpc-cgi} "${methodName}Response" $msg]	set xml [dom::DOMImplementation serialize $reply]	regsub "<!DOCTYPE\[^>\]+>\n" $xml {} xml	catch {dom::DOMImplementation destroy $reply}    } msg]} {	set detail [list "errorCode" $::errorCode "stackTrace" $::errorInfo]	set xml [XMLRPC::fault 500 "$msg" $detail]	error $xml {} XMLRPC    }    # publish the answer    return $xml}# -------------------------------------------------------------------------# Description:#   Handle the Head section of a SOAP request. If there is a problem we #   shall throw an error.# Parameters:#   doc#   mandate - boolean: if true then throw an error for any mustUnderstand#proc ::SOAP::CGI::soap_header {doc {mandate 0}} {    dtrace "Handling SOAP Header"    set result {}    foreach elt [selectNode $doc "/Envelope/Header/*"] {	set eltName [dom::node cget $elt -nodeName]	set actor [getElementAttribute $elt actor]	dtrace "SOAP actor $eltName = $actor"	# If it's not for me, don't handle the header.	if {$actor == "" || [string match $actor \		"http://schemas.xmlsoap.org/soap/actor/next"]} {		    # Check for Mandatory Headers.	    set mustUnderstand [getElementAttribute $elt mustUnderstand]	    	    dtrace "SOAP mustUnderstand $eltName $mustUnderstand"	    # add to the list of suitable headers.	    lappend result [getElementName $elt] [getElementValue $elt]	    	    ## Until we know what to do with such headers, we will have to	    ## Fault.	    if {$mustUnderstand == 1 && $mandate == 1} {