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