soap-cgi.tcl

Linux下的MSN聊天程序源码

	    	error "Mandatory header $eltName not understood." \
	    		{} MustUnderstand
	    }
	}
    }
    return $result
}

# -------------------------------------------------------------------------

# Description:
#   Handle incoming SOAP requests.
#   We extract the name of the SOAP method and the arguments and search for
#   the implementation in the specified namespace. This is then evaluated
#   and the result is wrapped up and returned or a SOAP Fault is generated.
# Parameters:
#   doc - a DOM tree constructed from the input request XML data.
#
proc ::SOAP::CGI::soap_call {doc {interp {}}} {
    variable methodName
    set headers {}
    if {[catch {

	# Check SOAP version by examining the namespace of the Envelope elt.
	set envnode [selectNode $doc "/Envelope"]
	if {$envnode != {}} {
	    #set envns [dom::node cget $envnode -namespaceURI]
	    set envns [namespaceURI $envnode]
	    if {$envns != "" && \
		    ! [string match $envns \
		    "http://schemas.xmlsoap.org/soap/envelope/"]} {
		error "The SOAP Envelope namespace does not match the\
			SOAP version 1.1 namespace." {} VersionMismatch
	    }
	}

	# Check for Header elements
	if {[set headerNode [selectNode $doc "/Envelope/Header"]] != {}} {
	    set headers [soap_header $doc 0]
	    dtrace "headers: $headers"
	}

	# Get the method name from the XML request.
        # Ensure we only select the first child element ([e-mail])
	set methodNodes [selectNode $doc "/Envelope/Body/*"]
        set methodNode [lindex $methodNodes 0]
	set methodName [nodeName $methodNode]

	# Get the XML namespace for this method.
	set methodNamespace [namespaceURI $methodNode]
	dtrace "methodinfo: ${methodNamespace}::${methodName}"

	# Extract the parameters.
	set argNodes [selectNode $doc "/Envelope/Body/${methodName}/*"]
	set argValues {}
	foreach node $argNodes {
	    lappend argValues [decomposeSoap $node]
	}

	# Check for a permitted methodname. This is defined by being in the
	# SOAP::export list for the given namespace. We must do this to prevent
	# clients arbitrarily calling tcl commands like 'eval' or 'error'
	#
        if {[catch {
	    interp eval $interp \
		    set ${methodNamespace}::__soap_exports($methodName)
	} fqdn]} {
	    dtrace "method not found: $fqdn"
	    error "Invalid SOAP request:\
		    method \"${methodNamespace}::${methodName}\" not found" \
		{} "Client"
	}

	# evaluate the method
	set msg [interp eval $interp $fqdn $argValues]

	# check for mustUnderstand headers that were not understood.
	# This will raise an error for any such header elements.
	if {$headerNode != {}} {
	    soap_header $doc 1
	}

	# generate a reply packet
	set reply [SOAP::reply \
		[dom::DOMImplementation create] \
		$methodNamespace "${methodName}Response" $msg]
	set xml [dom::DOMImplementation serialize $reply]
	regsub "<!DOCTYPE\[^>\]+>\n" $xml {} xml
	catch {dom::DOMImplementation destroy $reply}
	catch {dom::DOMImplementation destroy $doc}
	
    } msg]} {
	# Handle errors the SOAP way.
	#
	set detail [list "errorCode" $::errorCode "stackTrace" $::errorInfo]
	set code [lindex $detail 1]
	switch -exact -- $code {
	    "VersionMismatch" {
		set code "SOAP-ENV:VersionMismatch"
	    }
	    "MustUnderstand" {
		set code "SOAP-ENV:MustUnderstand"
	    }
	    "Client" {
		set code "SOAP-ENV:Client"
	    }
	    "Server" {
		set code "SOAP-ENV:Server"
	    }
	}
	set xml [SOAP::fault $code "$msg" $detail]
	return -code error -errorcode SOAP $xml
    }

    # publish the answer
    return $xml
}

# -------------------------------------------------------------------------

# Description:
#   Prepare the interpreter for XML-RPC method invocation. We try to identify
#   a Tcl file to source for the implementation of the method by using the 
#   XML-RPC class name (the bit before the dot) and looking it up in the
#   xmlrpcmap file. This file also tells us if we should use a safe 
#   interpreter for this method.
#
proc ::SOAP::CGI::xmlrpc_invocation {doc} {
    global env
    variable xmlrpcdir

    array set impl {filename {} interp {}}

    # Identify the classname part of the methodname
    set methodNode [selectNode $doc "/methodCall/methodName"]
    set methodName [getElementValue $methodNode]
    set className {}
    if {[regexp {.*\.} $methodName className]} {
	set className [string trim $className .]
    }
    set files {}
    if {$className != {}} {
	array set impl [xmlrpc_implementation $className]
	set files $impl(filename)
    }
    if {$files == {}} {
	set files [glob $xmlrpcdir/*]
    }
    # Do we want to use a safe interpreter?
    if {$impl(interp) != {}} {
	createInterp $impl(interp) $xmlrpcdir
    }
    dtrace "Interp: '$impl(interp)' - Files required: $files"

    # Source the XML-RPC implementation files at global level.
    foreach file $files {
	if {[file isfile $file] && [file readable $file]} {
	    itrace "debug: sourcing $file"
	    if {[catch {
		interp eval $impl(interp)\
			namespace eval :: \
			"source [list $file]"
	    } msg]} {
		itrace "warning: failed to source \"$file\""
		dtrace "failed to source \"$file\": $msg"
	    }
	}
    }
    set result [xmlrpc_call $doc $impl(interp)]
    if {$impl(interp) != {}} {
	safe::interpDelete $impl(interp)
    }
    return $result
}

# -------------------------------------------------------------------------

# Description:
#   Load in the SOAP method implementation file on the basis of the
#   SOAPAction header. We use this header plus a map file to decide
#   what file to source, or if we should source all the files in the
#   soapdir directory. The map also provides for evaluating this method in
#   a safe slave interpreter for extra security if needed.
#   See the cgi-bin/soapmap.dat file for more details.
#
proc ::SOAP::CGI::soap_invocation {doc} {
    global env
    variable soapdir

    # Obtain the SOAPAction header and strip the quotes.
    set SOAPAction {}
    if {[info exists env(HTTP_SOAPACTION)]} {
	set SOAPAction $env(HTTP_SOAPACTION)
    }
    set SOAPAction [string trim $SOAPAction "\""]
    itrace "SOAPAction set to \"$SOAPAction\""
    dtrace "SOAPAction set to \"$SOAPAction\""
    
    array set impl {filename {} interp {}}
    
    # Use the SOAPAction HTTP header to identify the files to source or
    # if it's null, source the lot.
    if {$SOAPAction == {} } {
	set files [glob [file join $soapdir *]] 
    } else {
	array set impl [soap_implementation $SOAPAction]
	set files $impl(filename)
	if {$files == {}} {
	    set files [glob [file join $soapdir *]]
	}
	itrace "interp: $impl(interp): files: $files"
	
	# Do we want to use a safe interpreter?
	if {$impl(interp) != {}} {
	    createInterp $impl(interp) $soapdir
	}
    }
    dtrace "Interp: '$impl(interp)' - Files required: $files"
    
    foreach file $files {
	if {[file isfile $file] && [file readable $file]} {
	    itrace "debug: sourcing \"$file\""
	    if {[catch {
		interp eval $impl(interp) \
			namespace eval :: \
			"source [list $file]"
	    } msg]} {
		itrace "warning: $msg"
		dtrace "Failed to source \"$file\": $msg"
	    }
	}
    }
    
    set result [soap_call $doc $impl(interp)]
    if {$impl(interp) != {}} {
	safe::interpDelete $impl(interp)
    }
    return $result
}

# -------------------------------------------------------------------------

# Description:
#    Examine the incoming data and decide which protocol handler to call.
#    Everything is evaluated in a large catch. If any errors are thrown we
#    will wrap them up in a suitable reply. At this stage we return
#    HTML for errors.
# Parameters:
#    xml - for testing purposes we can source this file and provide XML
#          as this parameter. Normally this will not be used.
#
proc ::SOAP::CGI::main {{xml {}} {debug 0}} {
    catch {package require tcllib} ;# re-eval the pkgIndex
    package require ncgi
    global env
    variable soapdir
    variable xmlrpcdir
    variable methodName
    variable debugging $debug
    variable debuginfo {}
    variable interactive 1

    if { [catch {
	
	# Get the POSTed XML data and parse into a DOM tree.
	if {$xml == {}} {
	    set xml [ncgi::query]	    
	    set interactive 0      ;# false if this is a CGI request

	    # Debugging can be set by the HTTP header "SOAPDebug: 1"
	    if {[info exists env(HTTP_SOAPDEBUG)]} {
		set debugging 1
	    }
	}

	set doc [dom::DOMImplementation parse [do_encoding $xml]]
	
	# Identify the type of request - SOAP or XML-RPC, load the
	# implementation and call.
	if {[selectNode $doc "/Envelope"] != {}} {
	    set result [soap_invocation $doc]
	    log "SOAP" $methodName "ok"
	} elseif {[selectNode $doc "/methodCall"] != {}} {
	    set result [xmlrpc_invocation $doc]
	    log "XMLRPC" $methodName "ok"
	} else {
	    dom::DOMImplementation destroy $doc
	    error "invalid protocol: the XML data is neither SOAP not XML-RPC"
	}

	# Send the answer to the caller
	write $result text/xml

    } msg]} {
	
	# if the error was thrown from either of the protocol
	# handlers then the error code is set to indicate that the
	# message is a properly encoded SOAP/XMLRPC Fault.
	# If its a CGI problem, then be a CGI error.
	switch -- $::errorCode {
	    SOAP   {
		write $msg text/xml "500 SOAP Error"
		catch {
		    set doc [dom::DOMImplementation parse $msg]
		    set r [decomposeSoap [selectNode $doc /Envelope/Body/*]]
		} msg
		log "SOAP" [list $methodName $msg] "error" 
	    }
	    XMLRPC {
		write $msg text/xml "500 XML-RPC Error"
		catch {
		    set doc [dom::DOMImplementation parse $msg]
		    set r [getElementNamedValues [selectNode $doc \
			    /methodResponse/*]]
		} msg
		log "XMLRPC" [list $methodName $msg] "error" 
	    }
	    default {
		variable rcsid

		set html "<!doctype HTML public \"-//W3O//DTD W3 HTML 2.0//EN\">\n"
		append html "<html>\n<head>\n<title>CGI Error</title>\n</head>\n<body>"
		append html "<h1>CGI Error</h1>\n<p>$msg</p>\n"
		append html "<br />\n<pre>$::errorInfo</pre>\n"
		append html "<p><font size=\"-1\">$rcsid</font></p>"
		append html "</body>\n</html>"
		write $html text/html "500 Internal Server Error"
		
		log "unknown" [string range $xml 0 60] "error"
	    }
	}
    }
}

# -------------------------------------------------------------------------
#
# Local variables:
# mode: tcl
# End: