1# http.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# The SOAP HTTP Transport. 4# 5# ------------------------------------------------------------------------- 6# This software is distributed in the hope that it will be useful, but 7# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 8# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE' 9# for more details. 10# ------------------------------------------------------------------------- 11 12package provide SOAP::http 1.0 13 14if {[catch {package present SOAP}]} { 15 package require SOAP 16} 17 18package require http 2; # tcl 19 20namespace eval ::SOAP::Transport::http { 21 variable version 1.0 22 variable rcsid {$Id: http.tcl,v 1.8 2008/07/04 18:11:19 apnadkarni Exp $} 23 variable options 24 25 SOAP::register http [namespace current] 26 27 # Initialize the transport options. 28 if {![info exists options]} { 29 array set options { 30 headers {} 31 proxy {} 32 progress {} 33 timeout 0 34 } 35 } 36 37 # Declare the additional SOAP method options provided by this transport. 38 variable method:options [list \ 39 httpheaders \ 40 timeout \ 41 contenttype \ 42 ] 43 44 # Provide missing code for http < 2.3 45 if {[info proc ::http::ncode] == {}} { 46 namespace eval ::http { 47 proc ncode {token} { 48 return [lindex [split [code $token]] 1] 49 } 50 } 51 } 52} 53 54# ------------------------------------------------------------------------- 55 56# Description: 57# Implement the additional SOAP method configuration options provide 58# for this transport. 59# Notes: 60# -httpheaders - additional HTTP headers may be defined for specific 61# SOAP methods. Argument should be a two element list made of 62# the header name and value eg: [list Cookie $cookiedata] 63# -timeout - the method can override the transport defined http timeout. 64# Set to {} to use the transport timeout, 0 for infinity. 65proc ::SOAP::Transport::http::method:configure {procVarName opt value} { 66 upvar $procVarName procvar 67 switch -glob -- $opt { 68 -httpheaders { 69 set procvar(httpheaders) $value 70 } 71 -timeout { 72 set procvar(timeout) $value 73 } 74 -contenttype { 75 set procvar(contenttype) $value 76 } 77 default { 78 # not reached. 79 return -code error "unknown option \"$opt\"" 80 } 81 } 82} 83 84# ------------------------------------------------------------------------- 85 86# Description: 87# Configure any http transport specific settings. 88# 89proc ::SOAP::Transport::http::configure {args} { 90 variable options 91 92 if {[llength $args] == 0} { 93 set r {} 94 foreach {opt value} [array get options] { 95 lappend r "-$opt" $value 96 } 97 return $r 98 } 99 100 foreach {opt value} $args { 101 switch -- $opt { 102 -proxy - -timeout - -progress { 103 set options([string trimleft $opt -]) $value 104 } 105 -headers { 106 set options(headers) $value 107 } 108 default { 109 return -code error "invalid option \"$opt\":\ 110 must be \"-proxy host:port\" or \"-headers list\"" 111 } 112 } 113 } 114 return {} 115} 116 117# ------------------------------------------------------------------------- 118 119# Description: 120# Perform a remote procedure call using HTTP as the transport protocol. 121# This uses the Tcl http package to do the work. If the SOAP method has 122# the -command option set to something then the call is made 123# asynchronously and the result data passed to the users callback 124# procedure. 125# If you have an HTTP proxy to deal with then you should set up the 126# SOAP::Transport::http::filter procedure and proxy variable to suit. 127# This can be done using SOAP::proxyconfig. 128# Parameters: 129# procVarName - the name of the SOAP config array for this method. 130# url - the SOAP endpoint URL 131# request - the XML data making up the SOAP request 132# Result: 133# The request data is POSTed to the SOAP provider via HTTP using any 134# configured proxy host. If the HTTP returns an error code then an error 135# is raised otherwise the reply data is returned. If the method has 136# been configured to be asynchronous then the async handler is called 137# once the http request completes. 138# 139proc ::SOAP::Transport::http::xfer { procVarName url request } { 140 variable options 141 upvar $procVarName procvar 142 143 # Get the SOAP package version 144 # FRINK: nocheck 145 set version [set [namespace parent [namespace parent]]::version] 146 147 # setup the HTTP POST request 148 ::http::config -useragent "TclSOAP/$version ($::tcl_platform(os))" 149 150 # If a proxy was configured, use it. 151 if { [info exists options(proxy)] && $options(proxy) != {} } { 152 ::http::config -proxyfilter [namespace origin filter] 153 } 154 155 # Check for an HTTP progress callback. 156 set local_progress {} 157 if { [info exists options(progress)] && $options(progress) != {} } { 158 set local_progress "-progress [list $options(progress)]" 159 } 160 161 # Check for a timeout. Method timeout overrides transport timeout. 162 set timeout $options(timeout) 163 if {$procvar(timeout) != {}} { 164 set timeout $procvar(timeout) 165 } 166 167 # There may be http headers configured. eg: for proxy servers 168 # eg: SOAP::configure -transport http -headers 169 # [list "Proxy-Authorization" [basic_authorization]] 170 set local_headers {} 171 if {[info exists options(headers)]} { 172 set local_headers $options(headers) 173 } 174 if {[info exists procvar(httpheaders)]} { 175 set local_headers [concat $local_headers $procvar(httpheaders)] 176 } 177 178 # Add mandatory SOAPAction header (SOAP 1.1). This may be empty otherwise 179 # must be in quotes. 180 set action $procvar(action) 181 if { $action != {} } { 182 set action [string trim $action "\""] 183 set action "\"$action\"" 184 lappend local_headers "SOAPAction" $action 185 } 186 187 # cleanup the last http request 188 if {[info exists procvar(http)] && $procvar(http) != {}} { 189 catch {::http::cleanup $procvar(http)} 190 } 191 192 # Check for an asynchronous handler and perform the transfer. 193 # If async - return immediately. 194 set command {} 195 if {$procvar(command) != {}} { 196 set command "-command {[namespace current]::asynchronous $procVarName}" 197 } 198 199 set contenttype text/xml 200 if {[info exists procvar(contenttype)] && $procvar(contenttype) ne ""} { 201 set contenttype $procvar(contenttype) 202 } 203 set token [eval ::http::geturl_followRedirects [list $url] \ 204 -headers [list $local_headers] \ 205 -type $contenttype \ 206 -timeout $timeout \ 207 -query [list $request] \ 208 $local_progress $command] 209 210 # store the http structure reference for possible access later. 211 set procvar(http) $token 212 213 if { $command != {}} { 214 return {} 215 } 216 217 log::log debug "[::http::status $token] - [::http::code $token]" 218 219 # Check for Proxy Authentication requests and handle it. 220 if {[::http::ncode $token] == 407} { 221 SOAP::proxyconfig 222 return [xfer $procVarName $url $request] 223 } 224 225 # Some other sort of error ... 226 switch -exact -- [set status [::http::status $token]] { 227 timeout { 228 return -code error "error: SOAP http transport timed out\ 229 after $timeout ms" 230 } 231 ok { 232 } 233 default { 234 return -code error "SOAP transport error:\ 235 token $token status is \"$status\" and HTTP result code is\ 236 \"[::http::code $token]\"" 237 } 238 } 239 240 return [::http::data $token] 241} 242 243# this proc contributed by [Donal Fellows] 244proc ::http::geturl_followRedirects {url args} { 245 set limit 10 246 while {$limit > 0} { 247 set token [eval [list ::http::geturl $url] $args] 248 switch -glob -- [ncode $token] { 249 30[1237] { 250 incr limit -1 251 ### redirect - see below ### 252 } 253 default { return $token } 254 } 255 upvar \#0 $token state 256 array set meta $state(meta) 257 if {![info exist meta(Location)]} { 258 return $token 259 } 260 set url $meta(Location) 261 unset meta 262 } 263 return -code error "maximum relocation depth reached: site loop?" 264} 265 266 267# ------------------------------------------------------------------------- 268 269# Description: 270# Asynchronous http handler command. 271proc ::SOAP::Transport::http::asynchronous {procVarName token} { 272 upvar $procVarName procvar 273 274 if {[catch {asynchronous2 $procVarName $token} msg]} { 275 if {$procvar(errorCommand) != {}} { 276 set errorCommand $procvar(errorCommand) 277 if {[catch {eval $errorCommand [list $msg]} result]} { 278 bgerror $result 279 } 280 } else { 281 bgerror $msg 282 } 283 } 284 return $msg 285} 286 287proc ::SOAP::Transport::http::asynchronous2 {procVarName token} { 288 upvar $procVarName procvar 289 set procName [lindex [split $procVarName {_}] end] 290 291 # Some other sort of error ... 292 if {[::http::status $token] != "ok"} { 293 return -code error "SOAP transport error: \"[::http::code $token]\"" 294 } 295 296 set reply [::http::data $token] 297 298 # Call the second part of invoke to unwrap the packet data. 299 set reply [SOAP::invoke2 $procVarName $reply] 300 301 # Call the users handler. 302 set command $procvar(command) 303 return [eval $command [list $reply]] 304} 305 306# ------------------------------------------------------------------------- 307 308# Description: 309# Handle a proxy server. If the -proxy options is set then this is used 310# to override the http package configuration. 311# Notes: 312# Needs expansion to use a list of non-proxied sites or a list of 313# {regexp proxy} or something. 314# The proxy variable in this namespace is set up by 315# SOAP::configure -transport http. 316# 317proc ::SOAP::Transport::http::filter {host} { 318 variable options 319 if { [string match "localhost*" $host] \ 320 || [string match "127.*" $host] } { 321 return {} 322 } 323 return [lrange [split $options(proxy) {:}] 0 1] 324} 325 326# ------------------------------------------------------------------------- 327 328# Description: 329# Support asynchronous transactions and permit waiting for completed 330# calls. 331# Parameters: 332# 333proc ::SOAP::Transport::http::wait {procVarName} { 334 upvar $procVarName procvar 335 http::wait $procvar(http) 336} 337# ------------------------------------------------------------------------- 338 339# Description: 340# Called to release any retained resources from a SOAP method. For the 341# http transport this is just the http token. 342# Parameters: 343# methodVarName - the name of the SOAP method configuration array 344# 345proc ::SOAP::Transport::http::method:destroy {methodVarName} { 346 upvar $methodVarName procvar 347 if {[info exists procvar(http)] && $procvar(http) != {}} { 348 catch {::http::cleanup $procvar(http)} 349 } 350} 351 352# ------------------------------------------------------------------------- 353 354proc ::SOAP::Transport::http::dump {methodName type} { 355 SOAP::cget $methodName proxy 356 if {[catch {SOAP::cget $methodName http} token]} { 357 set token {} 358 } 359 360 if { $token == {} } { 361 return -code error "cannot dump:\ 362 no information is available for \"$methodName\"" 363 } 364 365 set result {} 366 switch -glob -- $type { 367 -meta {set result [lindex [array get $token meta] 1]} 368 -qu* - 369 -req* {set result [lindex [array get $token -query] 1]} 370 -rep* {set result [::http::data $token]} 371 default { 372 return -code error "unrecognised option: must be one of \ 373 \"-meta\", \"-request\" or \"-reply\"" 374 } 375 } 376 377 return $result 378} 379 380# ------------------------------------------------------------------------- 381# Local variables: 382# mode: tcl 383# indent-tabs-mode: nil 384# End: 385