Check-in [a18130bfaf]
Not logged in
Home Documentation Downloads Timeline Files Branches Tags Tickets Wiki Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:::WS::Utils::geturl_followRedirects : limit to 5 redirects, plug http package memory leak, add redirect test scripts
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: a18130bfafb49e71935e82e0ffc9ddeb0a560fa0
User & Date: oehhar 2015-11-09 16:17:13
Context
2015-11-09 16:19
Removed own debugging message, sorry check-in: 0cda2c9b1d user: oehhar tags: trunk
2015-11-09 16:17
::WS::Utils::geturl_followRedirects : limit to 5 redirects, plug http package memory leak, add redirect test scripts check-in: a18130bfaf user: oehhar tags: trunk
2015-11-03 17:42
Fixed outdated example EchoEmbeddedService. Ticket [0e2728fadd] check-in: 1610455cee user: oehhar tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to Examples/Echo/CallEchoWebService.tcl. 

29
30
31
32
33
34
35

36
37
38
39
40
41
42
43
44

##  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT       ##
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################


package require WS::Utils 2.1.3
package require WS::Client 2.1.3

##
## Get Definition of the offered services
##
::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsEchoExample/wsdl

set testString "This is a test"







>
|
|








29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

##  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT       ##
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]]
package require WS::Utils
package require WS::Client

##
## Get Definition of the offered services
##
::WS::Client::GetAndParseWsdl http://localhost:8015/service/wsEchoExample/wsdl

set testString "This is a test"

Changes to Examples/Echo/EchoEmbeddedService.tcl. 

29
30
31
32
33
34
35
36
37
38
39

40
41
42
43
44
45
46
..
83
84
85
86
87
88
89





90
91
92
93
94
95
96
97

##  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT       ##
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

lappend auto_path [file join [file dirname [info script]] ../..]
package require WS::Server
package require WS::Utils
package require WS::Embeded


##
## Define the service
##
::WS::Server::Service \
    -service wsEchoExample \
    -description  {Echo Example - Tcl Web Services} \
................................................................................
    return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp]  ]
}

set ::errorInfo {}
set SocketHandle [::WS::Embeded::Listen 8015]
set ::errorInfo {}






puts stdout {Server started. Press Enter to stop}
flush stdout
fileevent stdin readable {set QuitNow 1}
vwait QuitNow
close $SocketHandle
puts stdout {Exited event loop}
flush stdout








|



>







 







>
>
>
>
>
|



<
<
<
|

29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
..
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99



100

##  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT       ##
##  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR  OTHERWISE) ARISING IN       ##
##  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF  ADVISED OF THE         ##
##  POSSIBILITY OF SUCH DAMAGE.                                              ##
##                                                                           ##
###############################################################################

set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]]
package require WS::Server
package require WS::Utils
package require WS::Embeded
catch {console show}

##
## Define the service
##
::WS::Server::Service \
    -service wsEchoExample \
    -description  {Echo Example - Tcl Web Services} \
................................................................................
    return [list ComplexEchoResult [list echoBack $TestString echoTS $timeStamp]  ]
}

set ::errorInfo {}
set SocketHandle [::WS::Embeded::Listen 8015]
set ::errorInfo {}

proc x {} {
    close $::SocketHandle
    exit
}

puts stdout {Server started. Press x and Enter to stop}
flush stdout
fileevent stdin readable {set QuitNow 1}
vwait QuitNow



x

Added Examples/redirect_test/redirect_call.tcl. 




















>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9

# Call redirect server
# 2015-11-09 Harald Oehlmann
# Start the redirect_server.tcl and the embedded echo sample to test.
set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]]
package require WS::Utils
package require WS::Client
catch {console show}
::log::lvSuppressLE debug 0
::WS::Client::GetAndParseWsdl http://localhost:8014/service/wsEchoExample/wsdl

Added Examples/redirect_test/redirect_server.tcl. 
















































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55

# Test tclws redirection
# 2015-11-09 by Harald Oehlmann
#
# If (set loop 1), infinite redirect is tested, otherwise one redirect.
# Start the embedded test server and use redirect_call to call.
#
set auto_path [linsert $auto_path 0 [file join [file dirname [info script]] ../..]]
catch {console show}
package require uri

proc ::Listen {port} {
	return [socket -server ::Accept $port]
}

 
proc ::Accept {sock ip clientport} {
    if {1 == [catch {
        gets $sock line
        set request {}
        while {[gets $sock temp] > 0 && ![eof $sock]} {
            if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                dict set request header [string tolower $key] [string trim $data]
            }
        }
        if {[eof $sock]} {
            puts "Connection closed from $ip"
            return
        }
        if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {
            puts  "Wrong request: $line"
            return
        }
        array set uri [::uri::split $url]
        if {[info exists ::loop]} {
            set uri(host) "localhost:8014"
        } else {
            set uri(host) "localhost:8015"
        }
        set url [eval ::uri::join [array get uri]]
        puts "Redirecting to $url"
        puts $sock "HTTP/1.1 301 Moved Permanently"
        puts $sock "Location: $url"
        puts $sock "Content-Type: text/html"
        puts $sock "Content-Length: 0\n\n"
        close $sock
    } Err]} {
        puts "Socket Error: $Err"
        return
    }
}

Listen 8014

Changes to Utilities.tcl. 

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
....
4528
4529
4530
4531
4532
4533
4534

4535


4536

4537
































4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566

4567
4568

4569
4570
4571
4572
4573

4574
4575
4576
4577
4578
4579
4580
4581


4582

    }
}

package require log
package require tdom 0.8
package require struct::set

package provide WS::Utils 2.3.9

namespace eval ::WS {}

namespace eval ::WS::Utils {
    set ::WS::Utils::typeInfo {}
    set ::WS::Utils::currentSchema {}
    array set ::WS::Utils::importedXref {}
................................................................................
    ## 8.5 or later, so use {*} expansion
    ##
    proc ::WS::Utils::setAttr {node attrList} {
        $node setAttribute {*}$attrList
    }
}








































proc ::WS::Utils::geturl_followRedirects {url args} {
    ::log::log debug "[info level 0]"
    #global redirectArray
    set initialUrl $url
    set finalUrl $url
    array set URI [::uri::split $url] ;# Need host info from here
    while {1} {
        if {[llength $args]} {
            ::log::log info [concat [list ::http::geturl $url] $args]
            set token [eval [list http::geturl $url] $args]
        } else {
            ::log::log info [list ::http::geturl $url]
            set token [::http::geturl $url]
        }
        set ncode [::http::ncode $token]
        ::log::log info "ncode = $ncode"
        if {![string match {30[1237]} $ncode]} {
            ::log::log debug "initialUrl = $initialUrl, finalUrl = $finalUrl"
            if {![string equal $finalUrl {}]} {
                ::log::log debug "Getting initial URL directory"
                set lastPos [string last / $initialUrl]
                set initialUrlDir [string range $initialUrl 0 [expr {$lastPos - 1}]]
                set lastPos [string last / $finalUrl]
                set finalUrlDir [string range $finalUrl 0 [expr {$lastPos - 1}]]
                ::log::log debug "initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir"
                set ::WS::Utils::redirectArray($initialUrlDir) $finalUrlDir
            }
            return $token
        }

        array set meta [set ${token}(meta)]
        if {![info exist meta(Location)]} {

            return $token
        }
        array set uri [::uri::split $meta(Location)]
        unset meta
        array unset meta

        if {[string equal $uri(host) {}]} {
            set uri(host) $URI(host)
        }
        # problem w/ relative versus absolute paths
        set url [eval ::uri::join [array get uri]]
        ::log::log debug "url = $url"
        set finalUrl $url
    }


}







|







 







>
|
>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


<



|








|
|












>


>





>








>
>


55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
....
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575

4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622

    }
}

package require log
package require tdom 0.8
package require struct::set

package provide WS::Utils 2.3.10

namespace eval ::WS {}

namespace eval ::WS::Utils {
    set ::WS::Utils::typeInfo {}
    set ::WS::Utils::currentSchema {}
    array set ::WS::Utils::importedXref {}
................................................................................
    ## 8.5 or later, so use {*} expansion
    ##
    proc ::WS::Utils::setAttr {node attrList} {
        $node setAttribute {*}$attrList
    }
}

###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                           that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Utils::geturl_followRedirects
#
# Description : fetch via http following redirects.
#               May not be used as asynchronous call with -command option.
#
# Arguments :
#       url        - target document url
#       args       - additional argument list to http::geturl call
#
# Returns :     nothing
#
# Side-Effects :        Save final url in redirectArray to forward info to
#                       procedure "processImport".
#
# Exception Conditions :        None
#
# Pre-requisite Conditions :    None
#
# Original Author : Gerald Lester
#
#>>END PRIVATE<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  02/24/2011  G. Lester    Initial version
#  2.3.10  11/09/2015  H. Oehlmann  Allow only 5 redirects (loop protection)
#
###########################################################################
proc ::WS::Utils::geturl_followRedirects {url args} {
    ::log::log debug "[info level 0]"

    set initialUrl $url
    set finalUrl $url
    array set URI [::uri::split $url] ;# Need host info from here
    for {set loop 1} {$loop <=5} {incr loop} {
        if {[llength $args]} {
            ::log::log info [concat [list ::http::geturl $url] $args]
            set token [eval [list http::geturl $url] $args]
        } else {
            ::log::log info [list ::http::geturl $url]
            set token [::http::geturl $url]
        }
        set ncode [::http::ncode $token]
        puts **$ncode
        if {![string match {30[12378]} $ncode]} {
            ::log::log debug "initialUrl = $initialUrl, finalUrl = $finalUrl"
            if {![string equal $finalUrl {}]} {
                ::log::log debug "Getting initial URL directory"
                set lastPos [string last / $initialUrl]
                set initialUrlDir [string range $initialUrl 0 [expr {$lastPos - 1}]]
                set lastPos [string last / $finalUrl]
                set finalUrlDir [string range $finalUrl 0 [expr {$lastPos - 1}]]
                ::log::log debug "initialUrlDir = $initialUrlDir, finalUrlDir = $finalUrlDir"
                set ::WS::Utils::redirectArray($initialUrlDir) $finalUrlDir
            }
            return $token
        }
        # http code announces redirect (3xx)
        array set meta [set ${token}(meta)]
        if {![info exist meta(Location)]} {
            ::log::log debug "Redirect http code without Location"
            return $token
        }
        array set uri [::uri::split $meta(Location)]
        unset meta
        array unset meta
        ::http::cleanup $token
        if {[string equal $uri(host) {}]} {
            set uri(host) $URI(host)
        }
        # problem w/ relative versus absolute paths
        set url [eval ::uri::join [array get uri]]
        ::log::log debug "url = $url"
        set finalUrl $url
    }
    # > 5 redirects reached -> exit with error
    return -code error "http redirect limit exceeded"
}

Changes to pkgIndex.tcl. 

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded WS::Client 2.3.8  [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Server 2.3.7  [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.3.9 [list source [file join $dir Utilities.tcl]]

package ifneeded WS::Embeded 2.3.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::AOLserver 2.0.0 [list source [file join $dir AOLserver.tcl]]
package ifneeded WS::Channel 2.0.0 [list source [file join $dir ChannelServer.tcl]]

package ifneeded WS::Wub 2.2.1 [list source [file join $dir WubServer.tcl]]
package ifneeded Wsdl 2.0.0 [list source [file join $dir WubServer.tcl]]

package ifneeded WS::CheckAndBuild 0.0.3 [list source [file join $dir CheckAndBuild.tcl]]







|










6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded WS::Client 2.3.8  [list source [file join $dir ClientSide.tcl]]
package ifneeded WS::Server 2.3.7  [list source [file join $dir ServerSide.tcl]]
package ifneeded WS::Utils 2.3.10 [list source [file join $dir Utilities.tcl]]

package ifneeded WS::Embeded 2.3.0 [list source [file join $dir Embedded.tcl]]
package ifneeded WS::AOLserver 2.0.0 [list source [file join $dir AOLserver.tcl]]
package ifneeded WS::Channel 2.0.0 [list source [file join $dir ChannelServer.tcl]]

package ifneeded WS::Wub 2.2.1 [list source [file join $dir WubServer.tcl]]
package ifneeded Wsdl 2.0.0 [list source [file join $dir WubServer.tcl]]

package ifneeded WS::CheckAndBuild 0.0.3 [list source [file join $dir CheckAndBuild.tcl]]

Fossil 2.10 [eb804dc674] 2019-09-19 14:14:14