1# SOAP-service.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
2#                    Copyright (C) 2008 Andreas Kupries <andreask@activestate.com>
3#
4# Provide a SOAP demo service.
5#
6# This package provides a simple HTTP server that is useful for stand-alone
7# testing of HTTP requests (including SOAP requests). This is not meant
8# to be a production-quality web server.
9#
10# Replies to GET requests with the contents of a file in a subdirectory if
11# the requested file can be found. Some simple filename extension to MIME
12# content-type matching is performed.
13#
14# POST requests are passed to a handler function, currently only /soap/base64
15# is actually valid and this returns a fixed base64 encoded string.
16#
17# The toplevel procedures are `start', `stop' and `stats' which respectively
18# start or stop the service, or provide some statistics on the requests
19# handled so far.
20#
21# -------------------------------------------------------------------------
22# This software is distributed in the hope that it will be useful, but
23# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
24# or FITNESS FOR A PARTICULAR PURPOSE.  See the accompanying file `LICENSE'
25# for more details.
26# -------------------------------------------------------------------------
27
28package require SOAP::Utils
29package provide SOAP::Service 0.5
30
31if { [catch {package require Trf}] } {
32    if { [catch {package require base64}] } {
33        error "missing required package: base64 command needs to be provided"
34    }
35}
36
37# -------------------------------------------------------------------------
38
39namespace eval SOAP::Service {
40    variable version 0.5
41    variable rcs_version { $Id: SOAP-service.tcl,v 1.7 2008/07/09 16:14:23 andreas_kupries Exp $ }
42    variable socket
43    variable port
44    variable stats
45    namespace export start stop stats
46
47    catch {namespace import -force ::SOAP::Utils::*}
48}
49
50# -------------------------------------------------------------------------
51
52proc SOAP::Service::start { {server_port {80}} } {
53    variable socket
54    variable port
55    variable stats
56
57    if { [catch { set s $socket }] != 0 } {
58        set socket {}
59    }
60    if { $socket != {} } {
61        return -code error "SOAP service already running on socket $socket"
62    }
63
64    set port $server_port
65    set socket [socket -server [namespace current]::service $port]
66    puts "SOAP service started on port $port"
67
68    array set stats {
69        zsplat-Base64 0
70        error_404     0
71        error_500     0
72        fault         0
73    }
74
75    return $socket
76}
77
78# -------------------------------------------------------------------------
79
80proc SOAP::Service::stop {} {
81    variable socket
82    close $socket
83    set socket {}
84}
85
86# -------------------------------------------------------------------------
87
88proc SOAP::Service::stats {} {
89    variable stats
90    set count 0
91    foreach uri [array names stats] {
92        puts "$uri $stats($uri)"
93        incr count $stats($uri)
94    }
95    return $count
96}
97
98# -------------------------------------------------------------------------
99
100proc SOAP::Service::service {channel client_addr client_port} {
101
102    # read the request (if any)
103    set request {}
104    set line {1}
105    while { $line != {} && ! [eof $channel] } {
106	gets $channel line
107	lappend request $line
108    }
109
110    puts "[join $request \n]"
111
112    set http_request [split [lindex $request 0] ]
113    set http_action  [lindex $http_request 0]  ;# type of request
114    set http_url     [lindex $http_request 1]  ;# what URL requested
115
116    switch -- $http_action {
117	GET {
118	    set reply [get $http_url]
119	}
120	POST {
121            set reply [post $http_url $request $channel]
122	}
123	default {
124	    set reply [error500]
125	}
126    }
127
128    puts $channel "$reply"
129    flush $channel
130    close $channel
131}
132
133# -------------------------------------------------------------------------
134
135proc SOAP::Service::post { url headers channel} {
136    # Get the amount of data from the Content-Length header and read it.
137    set data {}
138    set length [lsearch -regexp $headers {^Content-Length:}]
139    if { $length != -1 } {
140        set length [split [lindex $headers $length] :]
141        set length [expr {[lindex $length 1] + 0}]
142    }
143
144    if { $length > 0 } {
145        set data [read $channel $length]
146    }
147
148    switch -- $url {
149        /soap/base64 {
150            set reply [base64_service $data]
151        }
152        default {
153            set reply [error404]
154        }
155    }
156    return $reply
157}
158
159# -------------------------------------------------------------------------
160
161proc SOAP::Service::get { path } {
162    variable stats
163    set path [eval file join [split $path {\\/}] ] ;# make it relative
164    if { [file exists $path] && [file readable $path] && [file isfile $path]} {
165	set body {}
166	set f [open $path "r"]
167	while { ! [eof $f] } {
168	    gets $f l
169	    lappend body $l
170	}
171	close $f
172	set body [join $body "\n"]
173
174	set head [join [list \
175		"HTTP/1.1 200 OK" \
176		"Content-Type: [content_type $path]" \
177		"Content-Length: [string length $body]" ] "\n"]
178        set reply "${head}\n\n${body}"
179
180        if { [info exists stats($path)] } {
181            incr stats($path)
182        } else {
183            set stats($path) 1
184        }
185
186    } else {
187        set reply [error404]
188    }
189
190    return $reply
191}
192
193# -------------------------------------------------------------------------
194
195proc SOAP::Service::content_type { file } {
196    set ext [file extension $file]
197    switch -- $ext {
198	.htm { set type text/html }
199	.xml { set type text/xml }
200	.jpg { set type image/jpeg }
201	.tcl { set type application/x-tcl }
202	default { set type text/plain }
203    }
204    return $type
205}
206
207# -------------------------------------------------------------------------
208
209proc SOAP::Service::error404 {} {
210    variable stats
211    incr stats(error_404)
212    set body [join [list \
213            "<html><head><title>File not found</title></head>"\
214            "<body><h1>Error 404 File not found</h1><p>" \
215            "The requested file could not be found on this server." \
216            "</p></body></html>" \
217            ] "\n" ]
218
219    set head [join [list \
220	    "HTTP/1.1 404 Error File not found" \
221	    "Content-Type: text/html" \
222	    "Content-Length: [string length $body]"] "\n"]
223
224    return "${head}\n\n${body}"
225}
226
227# -------------------------------------------------------------------------
228
229proc SOAP::Service::error500 {} {
230    variable stats
231    incr stats(error_500)
232
233    set body [list \
234	    "Requests must be GET or POST." ]
235    set head [list \
236	    "HTTP/1.1 500 ERROR Invalid HTTP request type" \
237	    "Content-Type: text/html" \
238	    "Content-Length: [string length $body]" ]
239    return "[join $head \n]\n\n[join $body \n]"
240}
241
242# -------------------------------------------------------------------------
243
244proc SOAP::Service::base64_service { request } {
245    variable stats
246
247    set req [parseXML $request]
248    set failed [catch {
249        set value {}
250        foreach node [selectNode $req "SENV:Envelope/SENV:Body/zsplat-Base64/*"] {
251            lappend value [getSimpleElementValue $node]
252        }
253        set value
254    } result]
255
256    if { $failed } {
257        set doc [newDocument]
258        set bod [gen_reply_envelope $doc]
259        set flt [addNode $bod "SOAP-ENV:Fault"]
260        set fcd [addNode $flt "faultcode"]
261        addTextNode $fcd {SOAP-ENV:Client}
262        set fst [addNode $flt "faultstring"]
263        addTextNode $fst {Incorrect number of arguments}
264        #set dtl [addNode $flt "detail"]
265
266        set head {HTTP/1.1 500 Internal Server Error}
267        incr stats(fault)
268    } else {
269        set doc [zsplat_base64_reply [newDocument] $result]
270        set head {HTTP/1.1 200 OK}
271        incr stats(zsplat-Base64)
272    }
273
274    set body [generateXML $doc]
275    deleteDocument $doc            ;# clean up
276
277    set head [join [list $head \
278            "Content-Type: text/xml" \
279            "Content-Length: [string length $body]"\
280            "" ] "\n" ]
281    return "${head}\n${body}"
282}
283
284# -------------------------------------------------------------------------
285
286proc SOAP::Service::zsplat_base64_reply { doc msg } {
287    set bod [gen_reply_envelope $doc]
288    set cmd [addNode $bod "zsplat:getBase64"]
289    setElementAttribute $cmd "xmlns:zsplat" "urn:zsplat-Base64"
290    setElementAttribute $cmd \
291	    "SOAP-ENV:encodingStyle" "http://schemas.xmlsoap.org/soap/encoding/"
292    set par [addNode $cmd "return"]
293    setElementAttribute $par "xsi:type" "xsd:string"
294    addTextNode $par [base64 -mode enc $msg]
295    return $doc
296
297}
298
299# Mostly this boilerplate code to generate a general SOAP reply
300
301proc SOAP::Service::gen_reply_envelope { doc } {
302    set env [addNode $doc "SOAP-ENV:Envelope"]
303    setElementAttribute $env \
304	    "xmlns:SOAP-ENV" "http://schemas.xmlsoap.org/soap/envelope/"
305    setElementAttribute $env \
306	    "xmlns:xsi"      "http://www.w3.org/1999/XMLSchema-instance"
307    setElementAttribute $env \
308	    "xmlns:xsd"      "http://www.w3.org/1999/XMLSchema"
309    set bod [addNode $env "SOAP-ENV:Body"]
310    return $bod
311}
312
313# -------------------------------------------------------------------------
314
315# Local variables:
316#   indent-tabs-mode: nil
317# End:
318