1# SOAP-domain.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sf.net> 2# Copyright (C) 2008 Andreas Kupries <andreask@activestate.com> 3# 4# SOAP Domain Service module for the tclhttpd web server. 5# 6# Get the server to require the SOAP::Domain package and call 7# SOAP::Domain::register to register the domain handler with the server. 8# ie: put the following in a file in tclhttpd/custom 9# package require SOAP::Domain 10# SOAP::Domain::register /soap 11# 12# ------------------------------------------------------------------------- 13# This software is distributed in the hope that it will be useful, but 14# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 15# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE' 16# for more details. 17# ------------------------------------------------------------------------- 18 19package require SOAP::Utils; # TclSOAP 1.6 20package require SOAP::CGI; # TclSOAP 1.6 21package require rpcvar; # TclSOAP 1.6 22package require log; # tcllib 1.0 23 24namespace eval ::SOAP::Domain { 25 variable version 1.4.1;# package version number 26 variable debug 0 ;# flag to toggle debug output 27 variable rcs_id {$Id: SOAP-domain.tcl,v 1.15 2008/07/09 16:14:23 andreas_kupries Exp $} 28 29 namespace export register 30 31 catch {namespace import -force [namespace parent]::Utils::*} 32 catch {namespace import -force [uplevel {namespace current}]::rpcvar::*} 33} 34 35# ------------------------------------------------------------------------- 36 37# Register this package with tclhttpd. 38# 39# eg: register -prefix /soap ?-namespace ::zsplat? ?-interp slave? 40# 41# -prefix is the URL prefix for the SOAP methods to be implemented under 42# -interp is the Tcl slave interpreter to use ( {} for the current interp) 43# -namespace is the Tcl namespace look for the implementations under 44# (default is global) 45# -uri the XML namespace for these methods. Defaults to the Tcl interpreter 46# and namespace name. 47# 48proc ::SOAP::Domain::register {args} { 49 50 if { [llength $args] < 1 } { 51 return -code error "invalid # args:\ 52 should be \"register ?option value ...?\"" 53 } 54 55 # set the default options. These work out to be the current interpreter, 56 # toplevel namespace and under /soap URL 57 array set opts [list \ 58 -prefix /soap \ 59 -namespace {::} \ 60 -interp {} \ 61 -uri {^} ] 62 63 # process the arguments 64 foreach {opt value} $args { 65 switch -glob -- $opt { 66 -pre* {set opts(-prefix) $value} 67 -nam* {set opts(-namespace) ::$value} 68 -int* {set opts(-interp) $value} 69 -uri {set opts(-uri) $value} 70 default { 71 set names [join [array names opts -*] ", "] 72 return -code error "unrecognised option \"$opt\":\ 73 must be one of $names" 74 } 75 } 76 } 77 78 # Construct a URI if not supplied (as indicated by the funny character) 79 # gives interpname hyphen namespace path (with more hyphens) 80 if { $opts(-uri) == {^} } { 81 set opts(-uri) 82 regsub -all -- {::+} "$opts(-interp)::$opts(-namespace)" {-} r 83 set opts(-uri) [string trim $r -] 84 } 85 86 # Generate the fully qualified name of our options array variable. 87 set optname [namespace current]::opts$opts(-prefix) 88 89 # check we didn't already have this registered. 90 if { [info exists $optname] } { 91 return -code error "URL prefix \"$opts(-prefix)\" already registered" 92 } 93 94 # set up the URL domain handler procedure. 95 # As interp eval {} evaluates in the current interpreter we can define 96 # both a slave interpreter _and_ a specific namespace if we need. 97 98 # If required create a slave interpreter. 99 if { $opts(-interp) != {} } { 100 catch {interp create -- $opts(-interp)} 101 } 102 103 # Now create a command in the slave interpreter's target namespace that 104 # links to our implementation in this interpreter in the SOAP::Domain 105 # namespace. 106 interp alias $opts(-interp) $opts(-namespace)::URLhandler \ 107 {} [namespace current]::domain_handler $optname 108 109 # Register the URL handler with tclhttpd now. 110 Url_PrefixInstall $opts(-prefix) \ 111 [list interp eval $opts(-interp) $opts(-namespace)::URLhandler] 112 113 # log the uri/domain registration 114 array set [namespace current]::opts$opts(-prefix) [array get opts] 115 116 return $opts(-prefix) 117} 118 119# ------------------------------------------------------------------------- 120 121# SOAP URL Domain handler 122# 123# Called from the namespace or interpreter domain_handler to perform the 124# work. 125# optsname the qualified name of the options array set up during registration. 126# sock socket back to the client 127# suffix the remainder of the url once the prefix was stripped. 128# 129proc ::SOAP::Domain::domain_handler {optsname sock args} { 130 variable debug 131 upvar \#0 Httpd$sock data 132 upvar \#0 $optsname options 133 134 135 # if suffix is {} then it fails to make it through the various evals. 136 set suffix [lindex $args 0] 137 138 # check this is an XML post 139 set failed [catch {set type $data(mime,content-type)} msg] 140 if { $failed } { 141 set msg "Invalid SOAP request: not XML data" 142 log::log debug $msg 143 Httpd_ReturnData $sock text/xml [SOAP::fault SOAP-ENV:Client $msg] 500 144 return $failed 145 } 146 147 # make sure we were sent some XML 148 set failed [catch {set query $data(query)} msg] 149 if { $failed } { 150 set msg "Invalid SOAP request: no data sent" 151 log::log debug $msg 152 Httpd_ReturnData $sock text/xml [SOAP::fault SOAP-ENV:Client $msg] 500 153 return $failed 154 } 155 156 # Check that we have a properly registered domain 157 if { ! [info exists options] } { 158 set msg "Internal server error: domain improperly registered" 159 log::log debug $msg 160 Httpd_ReturnData $sock text/xml [SOAP::fault SOAP-ENV:Server $msg] 500 161 return 1 162 } 163 164 # Parse the XML into a DOM tree. 165 set doc [parseXML $query] 166 if { $debug } { set ::doc $doc } 167 168 # Call the procedure and convert errors into SOAP Faults and the return 169 # data into a SOAP return packet. 170 set failed [catch {SOAP::CGI::soap_call $doc $options(-interp)} msg] 171 Httpd_ReturnData $sock text/xml $msg [expr {$failed ? 500 : 200}] 172 173 catch {deleteDocument $doc} 174 return $failed 175} 176 177# ------------------------------------------------------------------------- 178 179package provide SOAP::Domain $::SOAP::Domain::version 180 181# ------------------------------------------------------------------------- 182 183# Local variables: 184# mode: tcl 185# indent-tabs-mode: nil 186# End: 187