1# beep.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net>
2#
3# Provide an BEEP transport for the SOAP package, e.g.,
4#
5#     SOAP::configure -transport soap.beep \
6#         -debug true                      \
7#         -logfile ...                     \
8#         -logident ...                    \
9#         -option-for-mixer::init ...
10#
11#     SOAP::create echoInteger
12#         -uri    http://soapinterop.org/                         \
13#         -proxy  soap.beep://qawoor.dbc.mtview.ca.us/soapinterop \
14#         -params { inputInteger int }
15#
16# BEEP support using the beepcore-tcl code from
17# http://sourceforge.net/projects/beepcore-tcl provided by M Rose.
18#
19# -------------------------------------------------------------------------
20# This software is distributed in the hope that it will be useful, but
21# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
22# or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
23# for more details.
24# -------------------------------------------------------------------------
25
26package require beepcore::log;          # beepcore-tcl
27package require beepcore::mixer;        # beepcore-tcl
28package require beepcore::peer;         # beepcore-tcl
29package require mime;                   # tcllib
30
31namespace eval ::SOAP::Transport::beep {
32    variable version 1.0
33    variable rcsid {$Id: beep.tcl,v 1.8 2003/09/06 17:08:46 patthoyts Exp $}
34    variable options
35    variable sessions
36
37    ::SOAP::register soap.beep  [namespace current]
38    ::SOAP::register soap.beeps [namespace current]
39
40    # Initialize the transport options.
41    if {![info exists options]} {
42        array set options {
43            -logfile    /dev/null
44            -logident   soap
45        }
46    }
47
48    # beep sessions
49    array set sessions {}
50
51    # Declare the additional SOAP method options provided by this transport.
52    variable method:options [list \
53        debug \
54        logfile \
55        logident \
56        logT \
57        mixerT \
58        channelT \
59        features \
60        destroy \
61        wait \
62    ]
63}
64
65# -------------------------------------------------------------------------
66
67# Description:
68#  Implement the additional SOAP method configuration options provide
69#  for this transport.
70#
71proc ::SOAP::Transport::beep::method:configure {procVarName opt value} {
72    variable options
73
74    upvar $procVarName procvar
75    switch -glob -- $opt {
76        -debug -
77        -logfile -
78        -logident {
79            set options($opt) $value
80	}
81
82        -logT -
83        -mixerT -
84        -channelT -
85        -features -
86        -destroy -
87        -wait {
88            set procvar([string trimleft $opt -]) $value
89        }
90        default {
91            return -code error "unknown option \"$opt\""
92        }
93    }
94}
95
96# -------------------------------------------------------------------------
97
98# Description:
99#  Transport defined SOAP method creation hook. We initialize the
100#  method:options that were declared above and do any transport specific
101#  initialization for the method.
102# Parameters:
103#  procVarName - the name of the method configuration array
104#  args        - the argument list that was given to SOAP::create
105#
106proc ::SOAP::Transport::beep::method:create {procVarName args} {
107    global debugP
108    variable sessions
109    upvar $procVarName procvar
110
111    if { ![info exists debugP] } {
112	set debugP 0
113    }
114
115    # procvar(proxy) will not have been set yet so:
116    set ndx [lsearch -exact $args -proxy]
117    incr ndx 1
118    if {$ndx == 0} {
119        return -code error "invalid arguments:\
120            the \"-proxy URL\" argument is required"
121    } else {
122        set procvar(proxy) [lindex $args $ndx]
123    }
124    array set URL [uri::split $procvar(proxy)]
125
126    # create a logging object, if necessary
127    if { [set logT $procvar(logT)] == {} } {
128	set logT [set procvar(logT) \
129		      [::beepcore::log::init \
130                           [set [namespace current]::options(-logfile)] \
131                           [set [namespace current]::options(-logident)]]]
132    }
133
134    #
135    # when the RFC issues, update the default port number...
136    # -- this has now occurred: RFC 3288
137    #
138    if { $URL(port) == {} } {
139	set URL(port) 605
140    }
141    if { $URL(path) == {} } {
142	set URL(path) /
143    }
144
145    switch -- $URL(scheme) {
146	soap.beep {
147	    set privacy none
148	}
149
150	soap.beeps {
151	    set privacy strong
152	}
153    }
154    array set options [array get [namespace current]::options]
155    unset options(-logfile) \
156        options(-logident)
157    array set options [list -port	 $URL(port) \
158                            -privacy	 $privacy   \
159                            -servername  $URL(host)]
160
161    set procName [lindex [split $procVarName {_}] end]
162    set procFQName [string map {_ ::} $procVarName]
163
164    # see if we have a session already cached
165    set signature ""
166    foreach option [lsort [array names options]] {
167	append signature $option $options($option)
168    }
169    foreach mixerT [array name sessions] {
170	catch { unset props }
171	array set props $sessions($mixerT)
172
173	if { ($props(host) != $URL(host)) \
174		|| ($props(resource) != $URL(path)) \
175		|| ($props(signature) != $signature) } {
176	    continue
177	}
178
179	if { $procvar(mixerT) == $mixerT } {
180	    ::beepcore::log::entry $logT debug [lindex [info level 0] 0] "$procName noop"
181
182	    return
183	}
184
185	incr props(refcnt)
186	set sessions($mixerT) [array get props]
187	::beepcore::log::entry $logT debug [lindex [info level 0] 0] \
188	     "$procName using session $mixerT, refcnt now $props(refcnt)"
189
190	set procvar(mixerT) $mixerT
191	set procvar(channelT) $props(channelT)
192	set procvar(features) $props(features)
193
194	return
195    }
196
197    # start a new session
198    switch -- [catch { eval [list ::beepcore::mixer::init $logT $URL(host)] \
199			    [array get options] } mixerT] {
200	0 {
201	    set props(host) $URL(host)
202	    set props(resource) $URL(path)
203	    set props(signature) ""
204	    foreach option [lsort [array names options]] {
205		append props(signature) $option $options($option)
206	    }
207	    set props(features) {}
208	    set props(refcnt) 1
209	    set sessions($mixerT) [array get props]
210
211	    set procvar(mixerT) $mixerT
212	    ::beepcore::log::entry $logT debug [lindex [info level 0] 0] \
213		 "$procName adding $mixerT to session cache, host $URL(host)"
214	}
215
216	7 {
217	    array set parse $mixerT
218	    ::beepcore::log::entry $logT user \
219			 "beepcore::mixer::init $parse(code): $parse(diagnostic)"
220
221	    return -code error $parse(diagnostic)
222	}
223
224	default {
225	    ::beepcore::log::entry $logT error beepcore::mixer::init $mixerT
226
227	    return -code error $mixerT
228	}
229    }
230
231    # create the channel
232    set profile http://iana.org/beep/soap
233
234    set doc [dom::DOMImplementation create]
235    set bootmsg [dom::document createElement $doc bootmsg]
236    dom::element setAttribute $bootmsg resource /$URL(path)
237    set data [dom::DOMImplementation serialize $doc]
238    if { [set x [string first [set y "<!DOCTYPE bootmsg>\n"] $data]] >= 0 } {
239	set data [string range $data [expr $x+[string length $y]] end]
240    }
241    dom::DOMImplementation destroy $doc
242
243    switch -- [set code [catch { ::beepcore::mixer::create $mixerT $profile $data } \
244			       channelT]] {
245	0 {
246	    set props(channelT) $channelT
247	    set sessions($mixerT) [array get props]
248
249	    set procvar(channelT) $channelT
250	}
251
252	7 {
253	    array set parse $channelT
254	    ::beepcore::log::entry $logT user \
255			 "beepcore::mixer::create $parse(code): $parse(diagnostic)"
256
257            # We can't call SOAP::destroy because we havn't created a SOAP
258            # method yet. The local destroy proc will clean up for us.
259	    method:destroy $procVarName
260	    return -code error $parse(diagnostic)
261	}
262
263	default {
264	    ::beepcore::log::entry $logT error beepcore::mixer::create $channelT
265
266	    method:destroy $procVarName
267	    return -code error $channelT
268	}
269    }
270
271    # parse the response
272    if { [catch { ::beepcore::peer::getprop $channelT datum } data] } {
273	::beepcore::log::entry $logT error beepcore::peer::getprop $data
274
275	method:destroy $procVarName
276	return -code error $data
277    }
278    if { [catch { dom::DOMImplementation parse $data } doc] } {
279	::beepcore::log::entry $logT error dom::parse $doc
280
281	method:destroy $procVarName
282	return -code error "bootrpy is invalid xml: $doc"
283    }
284    if { [set node [SOAP::selectNode $doc /bootrpy]] != {} } {
285	catch {
286	    set props(features) \
287		[set [subst $procVarName](features) \
288			    [set [dom::node cget $node -attributes](features)]]
289	    set sessions($mixerT) [array get props]
290	}
291
292	dom::DOMImplementation destroy $doc
293    } elseif { [set node [SOAP::selectNode $doc /error]] != {} } {
294	if { [catch { set code [set [dom::node cget $node -attributes](code)]
295		      set diagnostic [SOAP::getElementValue $node] }] } {
296	    set code 500
297	    set diagnostic "unable to parse boot reply"
298	}
299
300	::beepcore::log::entry $logT user "$code: $diagnostic"
301
302	dom::DOMImplementation destroy $doc
303
304        method:destroy $procVarName
305	return -code error "$code: $diagnostic"
306    } else {
307	dom::DOMImplementation destroy $doc
308
309	method:destroy $procVarName
310	return -code error "invalid protocol: the boot reply is invalid"
311    }
312}
313
314# -------------------------------------------------------------------------
315
316# Description:
317#  Configure any beep transport specific settings.
318#  Anything that works for mixer::init works for us...
319#
320proc ::SOAP::Transport::beep::configure {args} {
321    variable options
322
323    if {[llength $args] == 0} {
324	return [array get options]
325    }
326    array set options $args
327    return {}
328}
329
330# -------------------------------------------------------------------------
331
332# Description:
333#  Called to release any retained resources from a SOAP method.
334# Parameters:
335#  methodVarName - the name of the SOAP method configuration array
336#
337proc ::SOAP::Transport::beep::method:destroy {methodVarName} {
338    variable sessions
339    upvar $methodVarName procvar
340
341    set procName [lindex [split $methodVarName {_}] end]
342
343    set mixerT $procvar(mixerT)
344    set logT   $procvar(logT)
345
346    if {[catch {::beepcore::mixer::wait $mixerT -timeout 0} result]} {
347        ::beepcore::log::entry $logT error beepcore::mixer::wait $result
348    }
349
350    array set props $sessions($mixerT)
351    if {[incr props(refcnt) -1] > 0} {
352	set sessions($mixerT) [array get props]
353	::beepcore::log::entry $logT debug [lindex [info level 0] 0]\
354	     "$procName no longer using session $mixerT, refcnt now $props(refcnt)"
355	return
356    }
357
358    unset sessions($mixerT)
359    ::beepcore::log::entry $logT debug [lindex [info level 0] 0] \
360	"$procName removing $mixerT from session cache"
361
362    if { [catch { ::beepcore::mixer::fin $mixerT } result] } {
363	::beepcore::log::entry $logT error beepcore::mixer::fin $result
364    }
365    set procvar(mixerT) {}
366}
367
368# -------------------------------------------------------------------------
369
370# Description:
371#   Do the SOAP RPC call using the BEEP transport.
372# Parameters:
373#   procVarName  - SOAP configuration variable identifier.
374#   url          - the endpoint address. eg: mailto:user@address
375#   soap         - the XML payload for the SOAP message.
376# Notes:
377#
378proc ::SOAP::Transport::beep::xfer {procVarName url request} {
379    upvar $procVarName procvar
380
381    if {$procvar(command) != {}} {
382	set rpyV "[namespace current]::async $procVarName"
383    } else {
384	set rpyV {}
385    }
386
387    set mixerT   $procvar(mixerT)
388    set channelT $procvar(channelT)
389    set logT     $procvar(logT)
390
391    if {[set x [string first [set y "?>\n"] $request]] >= 0 } {
392	set request [string range $request [expr $x+[string length $y]] end]
393    }
394    set reqT [::mime::initialize -canonical application/xml -string $request]
395
396    switch -- [set code [catch { ::beepcore::peer::message $channelT $reqT \
397				       -replyCallback $rpyV } rspT]] {
398	0 {
399	    ::mime::finalize $reqT
400
401	    if { $rpyV != {} } {
402		return
403	    }
404
405	    set content [::mime::getproperty $rspT content]
406	    set response [::mime::getbody $rspT]
407
408	    ::mime::finalize $rspT
409
410	    if {[string compare $content application/xml]} {
411		return -code error "not application/xml reply, not $content"
412	    }
413
414	    return $response
415	}
416
417	7 {
418	    array set parse [::beepcore::mixer::errscan $mixerT $rspT]
419	    ::beepcore::log::entry $logT user "$parse(code): $parse(diagnostic)"
420
421	    ::mime::finalize $reqT
422	    ::mime::finalize $rspT
423	    return -code error "$parse(code): $parse(diagnostic)"
424	}
425
426	default {
427	    ::beepcore::log::entry $logT error beepcore::peer::message $rspT
428
429	    ::mime::finalize $reqT
430	    return -code error $rspT
431	}
432    }
433}
434
435proc ::SOAP::Transport::beep::async {procVarName channelT args} {
436    upvar $procVarName procvar
437
438    if { [catch { eval [list async2 $procVarName] $args } result] } {
439	if { $procvar(errorCommand) != {} } {
440	    set errorCommand $procvar(errorCommand)
441	    if { ![catch { eval $errorCommand [list $result] } result] } {
442		return
443	    }
444	}
445
446	bgerror $result
447    }
448}
449
450proc ::SOAP::Transport::beep::async2 {procVarName args} {
451    upvar $procVarName procvar
452    array set argv $args
453
454    switch -- $argv(status) {
455	positive {
456	    set content [::mime::getproperty $argv(mimeT) content]
457	    set reply [::mime::getbody $argv(mimeT)]
458	    ::mime::finalize $argv(mimeT)
459
460	    if {[string compare $content application/xml]} {
461		return -code error "not application/xml reply, not $content"
462	    }
463
464	    set reply [SOAP::invoke2 $procVarName $reply]
465	    return [eval $procvar(command) [list $reply]]
466	}
467
468	negative {
469	    set mixerT $procvar(mixerT)
470	    set logT $procvar(logT)
471
472	    array set parse [::beepcore::mixer::errscan $mixerT $argv(mimeT)]
473	    ::beepcore::log::entry $logT user "$parse(code): $parse(diagnostic)"
474
475	    ::mime::finalize $argv(mimeT)
476	    return -code error "$parse(code): $parse(diagnostic)"
477	}
478
479	default {
480	    ::mime::finalize $argv(mimeT)
481
482	    return -code error "not expecting $argv(status) reply"
483	}
484    }
485}
486
487# -------------------------------------------------------------------------
488
489proc ::SOAP::Transport::beep::wait {procVarName} {
490    upvar $procVarName procvar
491    ::beepcore::mixer::wait $procvar(mixerT)
492}
493
494# -------------------------------------------------------------------------
495# Extend the uri package to support our beep URL's. I don't think these are
496# official scheme names. If they are then we can add them into the tcllib
497# code - in the meantime...
498
499catch {
500    ::uri::register {soap.beep soap.beeps beep} {
501        variable schemepart "//.*"
502        variable url "(soap.)?beeps?:${schemepart}"
503    }
504}
505
506proc ::uri::SplitSoap.beep {url} {
507    return [SplitHttp $url]
508}
509
510proc ::uri::SplitSoap.beeps {url} {
511    return [SplitHttp $url]
512}
513proc ::uri::SplitBeep {url} {
514    return [SplitHttp $url]
515}
516
517# -------------------------------------------------------------------------
518
519package provide SOAP::beep $SOAP::Transport::beep::version
520
521# -------------------------------------------------------------------------
522# Local Variables:
523#   indent-tabs-mode: nil
524# End:
525