[Tkabber-dev] r1761 - in trunk/tkabber: . plugins/filetransfer

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sun Mar 29 14:56:32 MSD 2009


Author: sergei
Date: 2009-03-29 14:56:32 +0400 (Sun, 29 Mar 2009)
New Revision: 1761

Modified:
   trunk/tkabber/ChangeLog
   trunk/tkabber/plugins/filetransfer/http.tcl
   trunk/tkabber/proxy.tcl
Log:
	* proxy.tcl: Moved wrapped geturl to ::http namespace and adopted it to
	  work with HTTPS through a proxy server. The technique uses pconnect
	  package, therefore it can't be proposed to http upstream as is.

	* plugins/filetransfer/http.tcl: Use original call of ::http::geturl.


Modified: trunk/tkabber/ChangeLog
===================================================================
--- trunk/tkabber/ChangeLog	2009-03-29 10:51:55 UTC (rev 1760)
+++ trunk/tkabber/ChangeLog	2009-03-29 10:56:32 UTC (rev 1761)
@@ -5,6 +5,12 @@
 
 	* msgs/de.msg: Updated German translation (thanks to Roger Sondermann).
 
+	* proxy.tcl: Moved wrapped geturl to ::http namespace and adopted it to
+	  work with HTTPS through a proxy server. The technique uses pconnect
+	  package, therefore it can't be proposed to http upstream as is.
+
+	* plugins/filetransfer/http.tcl: Use original call of ::http::geturl.
+
 2009-03-28  Sergei Golovan  <sgolovan at nes.ru>
 
 	* si.tcl, plugins/si/ibb.tcl, plugins/si/iqibb.tcl,

Modified: trunk/tkabber/plugins/filetransfer/http.tcl
===================================================================
--- trunk/tkabber/plugins/filetransfer/http.tcl	2009-03-29 10:51:55 UTC (rev 1760)
+++ trunk/tkabber/plugins/filetransfer/http.tcl	2009-03-29 10:56:32 UTC (rev 1761)
@@ -258,7 +258,7 @@
     set fds($winid) $fd
 
     set geturl \
-	[list ::proxy::http::geturl $url -channel $fd \
+	[list ::http::geturl $url -channel $fd \
 	      -blocksize $chunk_size \
 	      -progress [list [namespace current]::recv_file_progress $f.pb] \
 	      -command [list [namespace current]::recv_file_finish $winid $lang]]

Modified: trunk/tkabber/proxy.tcl
===================================================================
--- trunk/tkabber/proxy.tcl	2009-03-29 10:51:55 UTC (rev 1760)
+++ trunk/tkabber/proxy.tcl	2009-03-29 10:56:32 UTC (rev 1761)
@@ -56,18 +56,57 @@
     custom::defvar proxylist {tunnels {} http {}} \
 	[::msgcat::mc "Serialized array of proxy servers to connect via."] \
 	-type string -group Hidden
+}
 
-    ::http::config -proxyfilter [namespace current]::proxyfilter
+# http package doesn't work with HTTPS URLs through proxy, so workaround this:
+
+if {![catch {package require tls}]} {
+    # proxy::tlssocket --
+    #
+    # Arguments:
+    #	    ?options? host port
+    #
+    # Bugs:
+    #	    Doesn't work with -async
+
+    proc proxy::tlssocket {args} {
+	set host [lindex $args end-1]
+	set port [lindex $args end]
+
+	# Find HTTP proxy, not tunnelling one
+	if {![catch {proxyfilter $host} answer] && $answer != {}} {
+	    lassign $answer phost pport pusername ppassword
+	    set sock [::pconnect::socket $host $port \
+					 -proxy https \
+					 -host $phost \
+					 -port $pport \
+					 -username $pusername \
+					 -password $ppassword]
+	    return [::tls::import $sock]
+	} else {
+	    return [eval [list ::tls::socket] $args]
+	}
+    }
+
+    ::http::register https 443 [namespace current]::proxy::tlssocket
 }
 
-namespace eval proxy::http {}
-
-# proxy::http::geturl --
+# ::http::geturl --
 #
 #	A wrapper around http::geturl which adds proxy authorization header
 #	if necessary.
 
-proc proxy::http::geturl {url args} {
+rename ::http::geturl ::http::geturl:orig
+
+proc ::http::geturl {url args} {
+    # Save and remove proxy settings
+
+    set savedProxyHost   [::http::config -proxyhost]
+    set savedProxyPort   [::http::config -proxyport]
+    set savedProxyFilter [::http::config -proxyfilter]
+
+    ::http::config -proxyhost "" -proxyport "" -proxyfilter ""
+
     # URLmatcher is borrowed from http package.
     set URLmatcher {(?x)                    # this is _expanded_ syntax
         ^
@@ -89,15 +128,20 @@
     set auth {}
     if {[regexp -- $URLmatcher $url -> \
                    proto user host port srvurl]} {
-        if {![catch {eval ::proxy::proxyfilter $host} answer]} {
-            lassign $answer phost pport pusername ppassword
-            if {[info exists pusername] && [info exists ppassword]} {
-		set auth [list Proxy-Authorization \
-			       "Basic [base64::encode \
-					    [encoding convertto \
-						      $pusername:$ppassword]]"]
+
+	if {$proto != "https"} {
+	    ::http::config -proxyfilter [namespace current]::proxyfilter
+
+	    if {![catch {eval proxyfilter $host} answer]} {
+		lassign $answer phost pport pusername ppassword
+		if {[info exists pusername] && [info exists ppassword]} {
+		    set auth [list Proxy-Authorization \
+				   "Basic [base64::encode \
+					        [encoding convertto \
+						          $pusername:$ppassword]]"]
+		}
 	    }
-        }
+	}
     }
 
     set newArgs {}
@@ -117,7 +161,12 @@
 	lappend newArgs -headers $auth
     }
 
-    eval [list ::http::geturl $url] $newArgs
+    set res [eval [list ::http::geturl:orig $url] $newArgs]
+
+    ::http::config -proxyhost $savedProxyHost \
+		   -proxyport $savedProxyPort \
+		   -proxyfilter $savedProxyFilter
+    return $res
 }
 
 proc proxy::open {} {



More information about the Tkabber-dev mailing list