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