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