soap-cgi.tcl

Linux下的MSN聊天程序源码

# SOAP-CGI.tcl - Copyright (C) 2001 Pat Thoyts <[e-mail]>
#
# 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.0

namespace 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} {