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